modularization

1 files changed, 34 insertions, 428 deletions

diff --git a/src/tekuti b/src/tekuti
index c68b12d..c3dccfa 100755
--- a/src/tekuti
+++ b/src/tekuti
@@ -29,437 +29,43 @@ exec guile $GUILE_FLAGS -l $0 -e main "$@"
 ;;; Code:
 
 ;;hack!
-(use-modules (ice-9 regex))
 
-(use-modules (ice-9 rdelim)
-             (ice-9 popen)
-             (srfi srfi-1)
-             (sxml simple)
-             (tekuti url)
-             (match-bind)
-             (sxml transform))
 (debug-enable 'backtrace)
-
-(define (expanduser path)
-  (let ((parts (string-split path #\/)))
-    (if (eqv? (string-ref (car parts) 0) #\~)
-        (let ((user (if (= (string-length (car parts)) 1)
-                        (cuserid)
-                        (substring (car parts) 1))))
-          (string-join (cons (passwd:dir (getpwnam user)) (cdr parts)) "/"))
-        path)))
-
-(define *host* "127.0.0.1")
-(define *port* 8081)
-(define *backlog* 5)
-(define *git-dir* (expanduser "~/blog.git"))
-(define *git* "git")
-(define *public-url-base* "/")
-(define *private-url-base* "/blog/")
-(define *debug* #t)
-
-(define (dbg fmt . args)
-  (apply format (current-error-port) fmt args))
-
-(define-macro (unwind-protect form . cleanups)
-  `(dynamic-wind (lambda () #t)
-       (lambda () ,form)
-       (lambda () ,@cleanups)))
-
-(define-macro (with-pipe var make-pipe . body)
-  `(let ((,var ,make-pipe))
-     (unwind-protect
-      (begin ,@body)
-      (let ((ret (close-pipe ,var)))
-        (if (not (eq? (status:exit-val ret) 0))
-            (throw 'pipe-error ,var ret))))))
-
-(define (git . args)
-  (with-pipe
-   pipe (apply open-pipe* OPEN_READ *git* "--bare" args)
-   (read-delimited "" pipe)))
-
-;; true badness
-(define (git/input+env input env . args)
-  (let* ((template (string-copy "/tmp/tekutiXXXXXX"))
-         (tmp (mkstemp! template)))
-    (display input tmp)
-    (close tmp)
-    (let ((cmd (string-join `("env" ,@env ,*git* "--bare" ,@args "<" ,template) " ")))
-      (display cmd)(newline)
-      (unwind-protect
-       (with-pipe
-        pipe (open-pipe* OPEN_BOTH "/bin/sh" "-c"
-                         (string-join `("env" ,@env ,*git* "--bare" ,@args "<" ,template) " "))
-        (read-delimited "" pipe))
-       (delete-file template)))))
-
-(define (is-dir? path)
-  (catch 'system-error
-         (lambda () (eq? (stat:type (stat path)) 'directory))
-         (lambda args #f)))
-
-(define (ensure-git-repo)
-  (if (not (is-dir? *git-dir*))
-      (begin
-        (mkdir *git-dir*)
-        (chdir *git-dir*)
-        (git "init"))
-      (chdir *git-dir*)))
-
-(define (strip-headers socket)
-  (define (read-line*)
-    (let ((line (read-line socket)))
-      (if (eof-object? line)
-          (error "unexpected eof")
-          line)))
-  (let lp ((keys '()) (values '()))
-    (let ((k (read-line*)))
-      (if (string=? k "end")
-          (reverse (map cons keys values))
-          (lp (cons k keys) (cons (read-line*) values))))))
-
-(define (output-headers headers port)
-  (for-each
-   (lambda (k v)
-     (format port "~a\n~a\n" k v))
-   (map car headers) (map cdr headers))
-  (display "end\n" port))
-
-(define-macro (let-headers headers bindings . body)
-  (let ((headers-var (gensym)))
-    `(let ((,headers-var ,headers))
-       (let (,@(map (lambda (binding)
-                      `(,(car binding)
-                        (or (assoc-ref ,headers-var ,(cadr binding))
-                            (error "Missing header:" ,(cadr binding)))))
-                    bindings))
-         ,@body))))
-
-(define (page-debug headers)
-  `(html (head (title "hello"))
-         (body (p "hello world!")
-               (table
-                (tr (th "header") (th "value"))
-                ,@(map (lambda (pair)
-                         `(tr (td ,(car pair)) (td ,(cdr pair))))
-                       headers)))))
-
-(define (visible-error . html-body)
-  (throw 'visible-error 404 html-body))
-
-(define (page-not-found path)
-  (throw 'html-error 404 path))
-
-(define (url-path-split path)
-  (filter (lambda (x) (not (string-null? x)))
-          (map url:decode (string-split path #\/))))
-
-(define-macro (url-path-case method path . clauses)
-  (define (optional-argument arg)
-    (let ((len (string-length arg)))
-      (and (eqv? (string-ref arg (1- len)) #\?)
-           (substring arg 0 (1- len)))))
-  (let ((method-sym (gensym)) (path-parts (gensym)))
-    (define (process-clauses)
-      (map (lambda (clause)
-             (let ((pattern (car clause)) (body (cdr clause)))
-               (cond
-                ((eq? pattern 'else)
-                 clause)
-                (else
-                 (let* ((method-match (car pattern))
-                        (parts-match (map symbol->string (cdr pattern)))
-                        (nargs (length parts-match))
-                        (opt (or (find-tail optional-argument parts-match) '()))
-                        (nopt (length opt))
-                        (nreq (- nargs nopt)))
-                   (cond
-                    ((null? opt)
-                     `((and (eq? ,method-sym ',method-match)
-                            (equal? ,path-parts ',parts-match))
-                       ,@body))
-                    (else
-                     `((and (eq? ,method-sym ',method-match)
-                            (equal? (list-head ,path-parts ,nreq)
-                                    ',(list-head parts-match nreq))
-                            (< (length ,path-parts) ,nargs))
-                       (apply
-                        (lambda ,(map string->symbol (map optional-argument opt))
-                          ,@body)
-                        (let ((tail (list-tail ,path-parts ,nreq)))
-                          (append tail (make-list (- ,nopt (length tail)) #f))))))))))))
-           clauses))
-    `(let ((,method-sym (string->symbol ,method))
-           (,path-parts (url-path-split ,path)))
-       (cond ,@(process-clauses)))))
-
-(define-macro (url-relative-path-case method path . clauses)
-  (let ((infix (map string->symbol (url-path-split *private-url-base*))))
-    (define (munge-clause clause)
-      (cond
-       ((eq? (car clause) 'else) clause)
-       (else
-        (let ((method (caar clause))
-              (parts (cdar clause))
-              (body (cdr clause)))
-          `((,method ,@infix ,@parts) ,@body)))))
-    `(url-path-case ,method ,path
-                    ,@(map munge-clause clauses))))
-
-(define (unimplemented . args)
-  (apply throw 'unimplemented args))
-
-(use-modules (scheme session))
-(use-modules (match-bind))
-
-;;(putenv "GIT_DIR=/home/wingo/blog.git")
-(define-macro (match-lines string pattern bindings expr)
-  (let ((line (gensym)) (seed (gensym)))
-    `(fold
-      (lambda (,line ,seed)
-        (match-bind ,pattern ,line ,bindings
-                    (cons ,expr ,seed)
-                    ,seed))
-      '() (string-split ,string #\newline))))
-
-(define (git-ls-tree treeish path)
-  (match-lines (git "ls-tree" treeish (or path "."))
-               "^(.+) (.+) (.+)\t(.+)$" (_ mode type object name)
-               (list mode type object name)))
-
-(define (git-ls-subdirs treeish path)
-  (match-lines (git "ls-tree" treeish (or path "."))
-               "^(.+) tree (.+)\t(.+)$" (_ mode object name)
-               (cons name object)))
-
-(define (dsu-sort list key less)
-  (map cdr
-       (stable-sort (map (lambda (x) (cons (key x) x)) list)
-                    (lambda (x y) (less (car x) (car y))))))
-
-(define (all-published-posts master)
-  (define (timestamp x)
-    (post-timestamp (cdr x)))
-  (dsu-sort
-   (filter timestamp (git-ls-subdirs master #f))
-   timestamp
-   <))
-
-(define (post-metadata sha1)
-  (match-lines (git "cat-file" "blob" (string-append sha1 ":" "metadata"))
-               "^([^: ]+): +(.*)$" (_ k v)
-               (cons (string->symbol k) v)))
-
-(define (post-timestamp sha1)
-  (and=> (assq-ref (post-metadata sha1) 'timestamp)
-         string->number))
-
-(define (post-categories sha1)
-  (or (and=> (assq-ref (post-metadata sha1) 'categories)
-             (lambda (x) (map string-trim-both (string-split x #\,))))
-      '()))
-             
-(define (comment-metadata sha1)
-  (match-lines (git "cat-file" "blob" (string-append sha1 ":" "metadata"))
-               "^([^: ]+): +(.*)$" (_ k v)
-               (cons (string->symbol k) v)))
-
-(define (comment-timestamp sha1)
-  (and=> (assq-ref (comment-metadata sha1) 'timestamp)
-         string->number))
-
-(define (post-comments sha1)
-  (dsu-sort
-   (map cdr (git-ls-subdirs sha1 "comments/"))
-   comment-timestamp
-   <))
-
-(define (parse-commit commit)
-  (let ((text (git "cat-file" "commit" commit)))
-    (match-bind
-     "\n\n(.*)$" text (_ message)
-     (acons
-      'message message
-      (match-lines (substring text 0 (- (string-length text) (string-length _)))
-                   "^([^ ]+) (.*)$" (_ k v)
-                   (cons (string->symbol k) v))))))
-
-(define (commit-utc-timestamp commit)
-  (match-bind
-   "^(.*) ([0-9]+) ([+-][0-9]+)" (assq-ref (parse-commit commit) 'committer)
-   (_ who ts tz)
-   (let ((ts (string->number ts)) (tz (string->number tz)))
-     (- ts (* (+ (* (quotient tz 100) 60) (remainder tz 100)) 60)))))
-
-(define (commit-parents commit)
-  (map cdr
-       (filter
-        (lambda (x) (eq? (car x) 'parent))
-        (parse-commit commit))))
-
-(define (build-comment-skeleton comments)
-  (fold (lambda (sha1 parent)
-          (let* ((ts (comment-timestamp sha1))
-                 (env (list "GIT_COMMMITTER=tekuti"
-                            ;; this quoting is a hack
-                            (format #f "'GIT_COMMITTER_DATE=~a +0100'" ts)
-                            (format #f "'GIT_AUTHOR_DATE=~a +0100'" ts))))
-            (string-trim-both
-             (apply git/input+env "comment\n" env "commit-tree" sha1
-                    (if parent (list "-p" parent) '())))))
-        #f
-        comments))
-
-(define (build-post-skeleton master posts)
-  (fold (lambda (sha1 parent)
-          (let* ((ts (post-timestamp sha1))
-                 (comments (build-comment-skeleton (post-comments sha1)))
-                 (env (list "GIT_COMMMITTER=tekuti"
-                            ;; this quoting is a hack
-                            (format #f "'GIT_COMMITTER_DATE=~a +0100'" ts)
-                            (format #f "'GIT_AUTHOR_DATE=~a +0100'" ts))))
-            (string-trim-both
-             (apply git/input+env "post\n" env "commit-tree" sha1
-                    "-p" master
-                    (append (if parent (list "-p" parent) '())
-                            (if comments (list "-p" comments) '()))))))
-        #f
-        (map cdr posts)))
-
-(define (reindex-posts master)
-  (build-post-skeleton master (all-published-posts master)))
-
-(define (hash-push! h key value)
-  (let ((handle (hash-create-handle! h key '())))
-    (set-cdr! handle (cons value (cdr handle)))))
-
-(define (make-tree alist)
-  (string-trim-both
-   (git/input+env (string-join
-                   (map (lambda (pair)
-                          (let ((name (car pair)) (sha (cdr pair)))
-                            (format #f "040000 tree ~a\t~a" sha name)))
-                        alist)
-                   "\n" 'suffix)
-                  '()
-                  "mktree")))
-
-(define (compute-categories posts)
-  (let ((hash (make-hash-table)))
-    (for-each
-     (lambda (post-pair)
-       (for-each
-        (lambda (cat)
-          (hash-push! hash cat post-pair))
-        (post-categories (cdr post-pair))))
-     posts)
-    hash))
-
-(define (build-categories-tree master posts)
-  (if (null? posts)
-      #f
-      (let* ((hash (compute-categories posts))
-             (tree (make-tree (hash-map->list
-                               (lambda (k v) (cons k (make-tree v)))
-                               hash)))
-             (ts (commit-utc-timestamp master))
-             (env (list "GIT_COMMMITTER=tekuti"
-                        ;; this quoting is a hack
-                        (format #f "'GIT_COMMITTER_DATE=~a +0000'" ts)
-                        (format #f "'GIT_AUTHOR_DATE=~a +0000'" ts))))
-        (string-trim-both
-         (git/input+env "categories\n" env "commit-tree" tree
-                        "-p" master))))) ;; FIXME: keep history?
-
-(define (reindex-categories master)
-  (build-categories-tree master (all-published-posts master)))
-
-(define (fetch-heads master)
-  (map (lambda (spec)
-         (let ((ref (car spec)) (reindex (cdr spec)))
-           (let ((head (false-if-exception
-                        (string-trim-both (git "rev-parse" (car spec))))))
-             (cons
-              ref
-              (if (and head (member master (commit-parents head)))
-                  head
-                  (and=> (reindex master)
-                    (lambda (new)
-                      (if (not (false-if-exception 
-                                (if head
-                                    (git "update-ref" ref new head)
-                                    (git "branch" ref new))))
-                          (dbg "couldn't update ref ~a to ~a" ref new))
-                      new)))))))
-       `(("posts" . ,reindex-posts)
-         ("categories" . ,reindex-categories))))
+(use-modules (tekuti git)
+             (tekuti page)
+             (tekuti util)
+             (tekuti post)
+             (tekuti categories)
+             (tekuti mod-lisp)
+             (tekuti web))
 
 (define (handle-request headers post-data)
-  (let-headers
-   headers ((method "method") (path "url"))
-   (url-relative-path-case
-    method path
-    ((POST admin new-post)
-     (unimplemented 'new-post))
-    ((POST admin modify-post)
-     (unimplemented 'modify-post))
-    ((POST admin new-comment)
-     (unimplemented 'new-comment))
-    ((POST admin delete-comment)
-     (unimplemented 'delete-comment))
-    ((POST admin delete-post)
-     (unimplemented 'delete-post))
-    ((GET)
-     (unimplemented 'index))
-    ((GET archives year? month? day? post?)
-     (unimplemented 'archives))
-    ((GET debug)
-     (page-debug headers))
-    ((POST search)
-     (unimplemented 'search))
-    (else (page-not-found path)))))
+  (let ((heads (fetch-heads `(posts . ,reindex-posts)
+                            `(categories . ,reindex-categories))))
+    (let-headers
+     headers ((method "method") (path "url"))
+     (url-relative-path-case
+      method path
+      ((POST admin new-post)
+       (unimplemented 'new-post))
+      ((POST admin modify-post)
+       (unimplemented 'modify-post))
+      ((POST admin new-comment)
+       (unimplemented 'new-comment))
+      ((POST admin delete-comment)
+       (unimplemented 'delete-comment))
+      ((POST admin delete-post)
+       (unimplemented 'delete-post))
+      ((GET)
+       (unimplemented 'index))
+      ((GET archives year? month? day? post?)
+       (unimplemented 'archives))
+      ((GET debug)
+       (page-debug headers))
+      ((POST search)
+       (unimplemented 'search))
+      (else (page-not-found path))))))
      
-(define xhtml-doctype
-  (string-append
-   "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" "
-   "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n"))
-
-(define (connection-received socket sockaddr)
-  (let ((headers (strip-headers socket))
-        (post-data "")) ;; blocks: (read-delimited "" socket)))
-
-    (dbg "~a" headers)
-    (catch #t
-           (lambda ()
-             (let ((sxml (handle-request headers post-data)))
-               (output-headers '(("Status" . "200 OK")
-                                 ("Content-Type" . "text/html"))
-                               socket)
-               (display xhtml-doctype socket)
-               (sxml->xml sxml socket)))
-           (lambda args
-             (output-headers '(("Status" . "500 Internal Server Error")
-                               ("Content-Type" . "text/plain"))
-                             socket)
-             (write args socket)))
-             
-    (close-port socket)))
-
-(define (event-loop socket)
-  (let ((master (string-trim-both (git "rev-parse" "master"))))
-    (pk (fetch-heads master)))
-  (pk 'listening)
-  (bind socket AF_INET (inet-aton *host*) *port*)
-  (listen socket *backlog*)
-  (let lp ((pair (accept socket)))
-    (pk pair)
-    (connection-received (car pair) (cdr pair))
-    (pk 'done)
-    (lp (accept socket))))
-    
-(define (main)
+(define (main args)
   (ensure-git-repo)
-  (event-loop (socket PF_INET SOCK_STREAM 0)))
-
-(main)
+  (event-loop handle-request))