diff options
Diffstat (limited to 'src')
-rwxr-xr-x | src/tekuti | 462 |
1 files changed, 34 insertions, 428 deletions
@@ -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)) |