diff --git a/src/tekuti b/src/tekuti index c3dccfa..2873ff6 100755 --- a/src/tekuti +++ b/src/tekuti @@ -39,33 +39,43 @@ exec guile $GUILE_FLAGS -l $0 -e main "$@" (tekuti mod-lisp) (tekuti web)) -(define (handle-request headers post-data) - (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 (handle-request headers post-data index) + (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 (maybe-reindex old-master old-index) + (let ((master (git-rev-parse "master"))) + (values + master + (if (equal? master old-master) + old-index + (acons 'master master + (map (lambda (k reindex) + (cons k (reindex master))) + (list 'posts 'categories) + (list reindex-posts reindex-categories))))))) + (define (main args) (ensure-git-repo) - (event-loop handle-request)) + (event-loop handle-request maybe-reindex)) + diff --git a/tekuti/git.scm b/tekuti/git.scm index 0ebf26c..162ba8a 100644 --- a/tekuti/git.scm +++ b/tekuti/git.scm @@ -34,7 +34,7 @@ #:use-module (ice-9 regex) ; hack #:export (git git* ensure-git-repo git-ls-tree git-ls-subdirs parse-metadata parse-commit commit-utc-timestamp - commit-parents make-tree fetch-heads)) + commit-parents make-tree git-rev-parse)) (define (call-with-pipe pipe proc) (unwind-protect @@ -148,25 +148,3 @@ (define (git-rev-parse rev) (string-trim-both (git "rev-parse" rev))) - -(define (fetch-heads . heads) - (let ((master (git-rev-parse "master"))) - (acons - 'master master - (map (lambda (spec) - (let ((ref (car spec)) (reindex (cdr spec))) - (let ((head (false-if-exception - (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))))))) - heads)))) diff --git a/tekuti/mod-lisp.scm b/tekuti/mod-lisp.scm index 613bda9..585c393 100644 --- a/tekuti/mod-lisp.scm +++ b/tekuti/mod-lisp.scm @@ -26,6 +26,7 @@ (define-module (tekuti mod-lisp) #:use-module (ice-9 rdelim) + #:use-module (ice-9 receive) #:use-module (sxml simple) #:use-module (sxml transform) #:use-module (tekuti url) @@ -57,14 +58,14 @@ "\n")) -(define (connection-received socket sockaddr handle-request) +(define (connection-received socket sockaddr index handle-request) (let ((headers (read-headers socket)) (post-data "")) ;; blocks: (read-delimited "" socket))) (dbg "~a" headers) (catch #t (lambda () - (let ((sxml (handle-request headers post-data))) + (let ((sxml (handle-request headers post-data index))) (write-headers '(("Status" . "200 OK") ("Content-Type" . "text/html")) socket) @@ -78,16 +79,23 @@ (close-port socket))) -(define (event-loop handle-request) +(define (with-socket proc) (pk 'listening) (let ((socket (socket PF_INET SOCK_STREAM 0))) (bind socket AF_INET (inet-aton *host*) *port*) (listen socket *backlog*) (unwind-protect - (let lp ((pair (accept socket))) - (pk pair) - (connection-received (car pair) (cdr pair) handle-request) - (pk 'done) - (lp (accept socket))) + (proc socket) (shutdown socket 2)))) +(define (event-loop handle-request maybe-reindex) + (with-socket + (lambda (socket) + (let lp ((old-cookie #f) (old-index #f)) + (let* ((pair (accept socket)) + (fd (car pair)) + (sockaddr (cdr pair))) + (receive + (cookie index) (maybe-reindex old-cookie old-index) + (connection-received (car pair) (cdr pair) index handle-request) + (lp cookie index)))))))