continuing simplification work

tekuti/boot.scm

@@ -1,7 +1,3 @@
-#! /bin/bash
-# -*- scheme -*-
-exec guile $GUILE_FLAGS -l $0 -e main -- "$@"
-!#
 ;; Tekuti
 ;; Copyright (C) 2008 Andy Wingo <wingo at pobox dot com>
 
@@ -24,7 +20,7 @@ exec guile $GUILE_FLAGS -l $0 -e main -- "$@"
 
 ;;; Commentary:
 ;;
-;; This is the main script that will launch tekuti.
+;; Module to parse options, etc before dropping into the main loop.
 ;;
 ;;; Code:
 
@@ -77,7 +73,7 @@ exec guile $GUILE_FLAGS -l $0 -e main -- "$@"
         (let ((run-utility (@ (ice-9 gds-client) run-utility)))
           (make-thread
            (lambda ()
-             (with-backtrace run-utility)))))
+             (with-backtrace (run-utility))))))
     opts))
 
 (define (boot args)

tekuti/comment.scm

@@ -221,7 +221,7 @@
     (assert-referenced-files-present
      (append (map cdr lremove) (map caar lchange)) dents)
     ; (trc 'make-tree-deep treeish add remove change)
-    (make-tree-full
+    (git-mktree
      (append
       (map cdr ladd)
       (filter-map
@@ -231,7 +231,7 @@
            #f)
           ((member (car dent) (map cadr lchange))
            (cdr lchange))
-          ((and (equal? (caddr dent) "tree")
+          ((and (eq? (caddr dent) 'tree)
                 (member (car dent)
                         (map caar (append dadd dremove dchange))))
            (let ((level-down (lambda (x)
@@ -243,11 +243,11 @@
                                    (filter-map level-down dadd)
                                    (filter-map level-down dremove)
                                    (filter-map level-down dchange))
-                   "tree" "040000")))
+                   'tree)))
           (else dent)))
        (append (filter-map (lambda (x)
                              (and (not (assoc (caar x) dents))
-                                  (list (caar x) #f "tree" #f)))
+                                  (list (caar x) #f 'tree)))
                            dadd)
                dents))))))
     

tekuti/git.scm

@@ -38,8 +38,9 @@
 
             git git* ensure-git-repo git-ls-tree git-ls-subdirs
             parse-metadata parse-commit commit-utc-timestamp
-            commit-parents make-tree git-rev-parse make-tree-full
+            commit-parents git-mktree git-rev-parse
             create-blob git-update-ref
+            git-commit-tree
 
             write-indices read-indices))
 
@@ -135,7 +136,7 @@
        (match-lines (git "ls-tree" treeish (or path "."))
                     "^(.+) (.+) (.+)\t(.+)$" (_ mode type object name)
                     ;; reversed for assoc
-                    (list name object type mode)))
+                    (list name object (string->symbol type))))
       '()))
 
 (define (git-ls-subdirs treeish path)
@@ -184,13 +185,17 @@
         (lambda (x) (eq? (car x) 'parent))
         (parse-commit commit))))
 
-(define (make-tree alist)
+(define (git-mktree alist)
   (string-trim-both
    (git* '("mktree")
          #:input (string-join
-                  (map (lambda (pair)
+                  (map (lambda (l)
-                         (let ((name (car pair)) (sha (cdr pair)))
+                         (format #f
-                           (format #f "040000 tree ~a\t~a" sha name)))
+                                 (if (or (null? (cddr l))
+                                         (equal? (caddr l) 'blob))
+                                     "100644 blob ~a\t~a"
+                                     "040000 tree ~a\t~a")
+                                 (cadr l) (car l)))
                        alist)
                   "\n" 'suffix))))
 
@@ -201,17 +206,6 @@
   (string-trim-both
    (git* '("hash-object" "-w" "--stdin") #:input contents)))
 
-;; order: name object type mode
-(define (make-tree-full alist)
-  (string-trim-both
-   (git* '("mktree")
-         #:input (string-join
-                  (map (lambda (l)
-                         (apply format #f "~a ~a ~a\t~a"
-                                (reverse l)))
-                       alist)
-                  "\n" 'suffix))))
-
 (define (git-update-ref refname proc count)
   (let* ((ref (git-rev-parse refname))
          (commit (proc ref)))
@@ -225,46 +219,15 @@
       (pk "failed to update the ref, trying again..." refname)
       (git-update-ref (git-rev-parse refname) (1- count))))))
 
+(define (git-commit-tree tree parent message timestamp)
+  (string-trim-both
+   (git* (cons* "commit-tree" tree
+                (if parent (list "-p" parent) '()))
+         #:input message
+         #:env (if timestamp
+                   (list "GIT_COMMMITTER=tekuti"
+                         (format #f "GIT_COMMITTER_DATE=~a +0100" timestamp)
+                         (format #f "GIT_AUTHOR_DATE=~a +0100" timestamp))))))
+
 ;; fixme: map-pairs
 
-(define (assoc-list-ref alist key n default)
-  (let ((l (assoc key alist)))
-    (if l (list-ref l n) default)))
-
-(define (write-indices indices oldref specs)
-  (let* ((master (assq-ref indices 'master))
-         (ts (commit-utc-timestamp master))
-         (env (list "GIT_COMMMITTER=tekuti"
-                    (format #f "GIT_COMMITTER_DATE=~a +0100" ts)
-                    (format #f "GIT_AUTHOR_DATE=~a +0100" ts)))
-         (tree (make-tree-full
-                (map (lambda (pair)
-                       (list (symbol->string (car pair))
-                             (create-blob
-                              (with-output-to-string
-                                (lambda ()
-                                  ((assoc-list-ref specs (car pair) 2 write)
-                                   (cdr pair)))))
-                             "blob" "100644"))
-                     indices))))
-    (let ((new (string-trim-both
-                (git* (cons* "commit-tree" tree
-                             (if oldref (list "-p" oldref) '()))
-                      #:input "reindex\n" #:env env))))
-      (or (false-if-git-error
-           (git "update-ref" "refs/heads/index" new (or oldref "")))
-          (warn "could not update indexes ref"))
-      new)))
-
-(define (read-indices specs)
-  (and=> (false-if-git-error (git-rev-parse "refs/heads/index"))
-         (lambda (ref)
-           (cons ref
-                 (map (lambda (dent)
-                        (cons (string->symbol (car dent))
-                              (with-input-from-string 
-                                  (git "show" (cadr dent))
-                                (assoc-list-ref specs (string->symbol (car dent)) 3 read))))
-                      (git-ls-tree (assq-ref (parse-commit ref) 'tree)
-                                    #f))))))
-

tekuti/mod-lisp.scm

@@ -26,20 +26,12 @@
 
 (define-module (tekuti mod-lisp)
   #:use-module (ice-9 rdelim)
-  #:use-module (ice-9 receive)
-  #:use-module (ice-9 stack-catch)
   #:use-module ((srfi srfi-1) #:select (fold))
-  #:use-module (sxml simple)
-  #:use-module (sxml transform)
   #:use-module (tekuti config)
   #:use-module (tekuti util)
-  #:use-module (tekuti git) ; rev-parse
+  #:use-module (tekuti index) ; rev-parse
   #:use-module (tekuti request)
   #:use-module (tekuti web)
-
-  ;; these for their reindex methods
-  #:use-module (tekuti post)
-  #:use-module (tekuti categories)
   #:export (event-loop))
 
 ;;; thought: ignore SIGPIPE, otherwise apache dying will kill us
@@ -69,23 +61,13 @@
   (display "end\n" port))
 
 (define (write-body request socket)
-  (let ((sxml (rref request 'sxml #f)))
+  ((rref request 'output error) socket))
-    (if sxml
-        (begin (display (rref request 'doctype "") socket)
-               (sxml->xml sxml socket))
-        (display "" socket))))
 
 (define (request-output-headers request)
-  (let ((rheads '(("Content-Type" . output-type))))
+  (rref request 'output-headers '()))
-    (map (lambda (h)
-           (cons (car h)
-                 (or (and=> (assoc-ref (car h) rheads)
-                            (lambda (k) (rref request k #f)))
-                     (cdr h))))
-         (rref request 'output-headers '()))))
 
 (define (connection-received socket sockaddr index)
-  (let* ((headers (pk (read-headers socket)))
+  (let* ((headers (read-headers socket))
          (post-data (read-chars (string->number
                                  (or (assoc-ref headers "content-length")
                                      "0"))
@@ -102,9 +84,11 @@
        (write-headers '(("Status" . "500 Internal Server Error")
                         ("Content-Type" . "text/plain"))
                       socket)
-       (write args socket)
+       (display "Sorry bub, had an error. Please let the admin know. Thanks!\n"
-       (newline)
+                socket)
-       (with-output-to-port socket backtrace))
+       (write headers) (newline)
+       (write args) (newline)
+       (backtrace))
      (lambda args
        (fluid-set! the-last-stack (make-stack #t 2 0))
        (apply throw args)))
@@ -121,58 +105,6 @@
      (proc socket)
      (shutdown socket 2))))
 
-(define (with-time-debugging proc)
-  (let ((start (gettimeofday)))
-    (pk 'start-clock)
-    (let ((val (proc)))
-      (let ((stop (gettimeofday)))
-        (pk 'stop-clock (+ (- (car stop) (car start))
-                           (* 1e-6 (- (cdr stop) (cdr start)))))
-        
-        val))))
-
-(define (write-hash h)
-  (write (hash-fold acons '() h)))
-
-;; fixme: doesn't share structure with posts index
-(define (read-hash)
-  (let ((h (make-hash-table)))
-    (for-each (lambda (pair)
-                (hash-set! h (car pair) (cdr pair)))
-              (read))
-    h))
-
-(define indices                          
-  `((posts ,reindex-posts ,write ,read)
-    (categories ,reindex-categories ,write-hash ,read-hash)))
-
-(use-modules (statprof))
-(define (reindex oldindex master)
-  (with-backtrace
-   (lambda ()
-     (with-time-debugging
-      (lambda ()
-        (with-statprof #:hz 100
-                       (fold (lambda (pair index)
-                               (acons (car pair)
-                                      ((cadr pair) oldindex index)
-                                      index))
-                             (acons 'master master '())
-                             indices)))))))
-
-(define (maybe-reindex old-index)
-  (let ((master (git-rev-parse "master")))
-    (if (and old-index (equal? (assq-ref (cdr old-index) 'master) master))
-        old-index
-        (catch #t
-               (lambda ()
-                 (let ((new-index (reindex (and=> old-index cdr) master)))
-                   (cons (write-indices new-index (and=> old-index car) indices)
-                         new-index)))
-               (lambda (key . args)
-                 (warn "error while reindexing:" key args)
-                 old-index)))))
-
 (define (inner-loop socket index)
   (let* ((pair (accept socket))
          (fd (car pair))
@@ -185,5 +117,5 @@
   (with-socket
    (lambda (socket)
      (format #t "entering inner loop\n")
-     (inner-loop socket (read-indices indices)))))
+     (inner-loop socket (read-index)))))
 

tekuti/page.scm

@@ -170,7 +170,7 @@
     (div (@ (class "post"))
          (h3 (@ (class "meta"))
              ,(post-readable-date post)
-             " (" ,@(list-intersperse (post-category-links post)
+             " (" ,@(list-intersperse (post-tag-links post)
                                       " | ")
              ")")
          (div (@ (class "storycontent"))
@@ -191,14 +191,18 @@
 (define page-delete-comment not-implemented)
 (define page-delete-post not-implemented)
 
+;; fixme: borks in the no-tags case
 (define (tag-cloud index)
   (define (determine-sizes counts)
     (let ((maxcount (apply max counts)))
       (map (lambda (x)
              (floor (+ 80 (* 120 (/ x maxcount)))))
            counts)))
-  (let* ((cats (hash-fold (lambda (k v seed) (acons k (length v) seed))
+  (let* ((hash (assq-ref index 'tags))
-                          '() (assq-ref index 'categories)))
+         (cats (if hash
+                   (hash-fold (lambda (k v seed) (acons k (length v) seed))
+                              '() hash)
+                   '()))
          (top-20 (dsu-sort (take-max (dsu-sort cats cdr >) 20)
                            car string<?)))
     `(ul (li (@ (style "line-height: 150%"))
@@ -218,9 +222,10 @@
 (define (main-sidebar request index)
   (sidebar-ul
    `((li (h2 (a (@ (href ,(relurl "feed/atom")))
-                (img (@ (href ,(relurl "wp-content/feed-icon-14x14.png"))
+                "subscribe "
+                (img (@ (src ,(relurl "wp-content/feed-icon-14x14.png"))
                         (alt "subscribe to this feed")))
-                " subscribe")))
+                )))
      (li (h2 "tags "
              (a (@ (href ,(string-append *public-url-base* "tags/")))
                 ">>"))
@@ -372,6 +377,10 @@
   (date->string (time-utc->date (make-time time-utc 0 timestamp) 0)
                 "~Y-~m-~dT~H:~M:~SZ"))
 
+(define (timestamp->rfc822-date timestamp)
+  (date->string (time-utc->date (make-time time-utc 0 timestamp) 0)
+                "~a, ~d ~b ~Y ~H:~M:~S GMT"))
+
 (define (request-relurl request)
   (let ((headers (rref request 'headers)))
     (let ((server (or (assoc-ref headers "Host")
@@ -392,7 +401,10 @@
               'status 304
               'doctype #f))
      (else
-      (rcons* request
+      (rcons* (rpush 'output-headers (cons "Last-Modified"
+                                           (timestamp->rfc822-date
+                                            last-modified))
+                     request)
               'doctype ""
               'content-type "application/atom+xml"
               'sxml `(feed

tekuti/post.scm

@@ -35,10 +35,10 @@
   #:use-module (tekuti filters)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
-  #:export (reindex-posts post-from-tree post-from-key post-categories
+  #:export (reindex-posts post-from-tree post-from-key post-tags
-                          post-timestamp
+                          post-timestamp post-key
             post-sxml-content post-raw-content all-published-posts
-            post-readable-date post-category-links post-sxml-n-comments
+            post-readable-date post-tag-links post-sxml-n-comments
             post-sxml-comments))
 
   
@@ -49,14 +49,17 @@
   (equal? (assq-ref post-alist 'status) "publish"))
 
 (define (post-timestamp post-alist)
-  (or (assq-ref post-alist 'timestamp) #f))
+  (assq-ref post-alist 'timestamp))
 
-(define (post-categories post-alist)
+(define (post-tags post-alist)
-  (or (assq-ref post-alist 'categories) '()))
+  (or (assq-ref post-alist 'tags) '()))
+
+(define (post-key post)
+  (assq-ref post 'key))
 
 (define *post-spec*
   `((timestamp . ,string->number)
-    (categories . ,(lambda (v) (map string-trim-both (string-split v #\,))))
+    (tags . ,(lambda (v) (map string-trim-both (string-split v #\,))))
     (title . ,identity)))
 
 (define (post-from-tree encoded-name sha1)
@@ -80,12 +83,14 @@
                (make-time time-utc 0 (assq-ref post 'timestamp)))))
     (date->string date "~e ~B ~Y ~l:~M ~p")))
 
-(define (post-category-links post)
+;; hack :-/
-  (map (lambda (cat)
+(define (tag-link tagname)
   `(a (@ (href ,(string-append *public-url-base* "tags/"
-                                      (url:encode cat))))
+                               (url:encode tagname))))
-             ,cat))
+      ,tagname))
-       (post-categories post)))
+
+(define (post-tag-links post)
+  (map tag-link (post-tags post)))
 
 (define (post-from-key master key)
   (let ((pairs (git-ls-subdirs master key)))

tekuti/tags.scm

@@ -20,26 +20,33 @@
 
 ;;; Commentary:
 ;;
-;; This is the main script that will launch tekuti.
+;; Tags, tags, tags
 ;;
 ;;; Code:
 
-(define-module (tekuti categories)
+(define-module (tekuti tags)
   #:use-module (tekuti util)
+  #:use-module (tekuti url)
+  #:use-module (tekuti config)
   #:use-module (tekuti post)
   #:use-module (tekuti git)
-  #:export (reindex-categories))
+  #:export (tag-link reindex-tags))
 
-(define (compute-categories posts)
+(define (tag-link tagname)
+  `(a (@ (href ,(string-append *public-url-base* "tags/"
+                               (url:encode tagname))))
+      ,tagname))
+
+(define (compute-tags posts)
   (let ((hash (make-hash-table)))
     (for-each
      (lambda (post)
        (for-each
         (lambda (cat)
           (hash-push! hash cat (assq-ref post 'key)))
-        (post-categories post)))
+        (post-tags post)))
      posts)
     hash))
 
-(define (reindex-categories old-index index)
+(define (reindex-tags old-index index)
-  (compute-categories (assq-ref index 'posts)))
+  (compute-tags (assq-ref index 'posts)))

tekuti/util.scm

@@ -29,8 +29,8 @@
   #:use-module (srfi srfi-1)
   #:export (expanduser match-lines dbg unwind-protect dbg dsu-sort
             hash-push! list-has-length? list-head-match mapn
-            take-max
+            take-max read-hash write-hash
-            list-intersperse with-backtrace define-memoized))
+            list-intersperse with-backtrace with-time-debugging define-memoized))
 
 (define (expanduser path)
   (let ((parts (string-split path #\/)))
@@ -115,7 +115,7 @@
     (force-output cep)
     (apply throw key args)))
 
-(define (with-backtrace proc)
+(define (with-backtrace* proc)
   (debug-enable 'backtrace)
   (start-stack 'with-backtrace
                (catch #t
@@ -125,6 +125,24 @@
                         (fluid-set! the-last-stack (make-stack #t 2 0))
                         (apply throw args)))))
 
+(define-macro (with-backtrace . forms)
+  `(,with-backtrace* (lambda () ,@forms)))
+
+(define (gettimeofday-diff prev)
+  (let ((now (gettimeofday)))
+   (+ (- (car now) (car prev))
+      (* 1e-6 (- (cdr now) (cdr prev))))))
+
+(define (with-time-debugging* proc)
+  (pk 'start-clock)
+  (let ((start (gettimeofday)))
+    (unwind-protect
+     (proc)
+     (pk 'stop-clock (gettimeofday-diff start)))))
+
+(define-macro (with-time-debugging . forms)
+  `(,with-time-debugging* (lambda () ,@forms)))
+
 (define (memoize1 proc)
   (let ((old-args #f) (cache #f) (proc proc))
     (lambda args
@@ -139,3 +157,14 @@
   `(begin
      (define ,form ,@body)
      (set! ,(car form) (,memoize1 ,(car form)))))
+
+(define (write-hash h)
+  (write (hash-fold acons '() h)))
+
+(define (read-hash)
+  (let ((h (make-hash-table)))
+    (for-each (lambda (pair)
+                (hash-set! h (car pair) (cdr pair)))
+              (read))
+    h))
+

tekuti/web.scm

@@ -63,13 +63,19 @@
                     bindings))
          ,@body))))
 
+(define (make-output request)
+  (lambda (port)
+    (let ((sxml (or (rref request 'sxml #f)
+                    (templatize request))))
+      (if sxml
+          (begin (display (rref request 'doctype "") port)
+                 (sxml->xml sxml port))
+          (display "" port)))))
+
 (define (finalize request)
   ;; update output headers
   ;; templatize body
-  (rpush* (if (assq 'sxml request)
+  (rpush* (rcons 'output (make-output request) request)
-              request
-              (rcons 'sxml (templatize request)
-                     request))
           'output-headers
           (cons "Status" (status->string (rref request 'status 200)))
           'output-headers