redo reindexing to be more erlangy
This commit is contained in:
Andy Wingo
parent
da58b95476
commit
8c52717d5d
3 changed files with 55 additions and 59 deletions
66
src/tekuti
66
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))
|
||||
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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 @@
|
|||
"<!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 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)))))))
|
||||
|
|
|
|||
Loading…
Reference in a new issue