redo reindexing to be more erlangy
This commit is contained in:
parent
da58b95476
commit
8c52717d5d
3 changed files with 55 additions and 59 deletions
24
src/tekuti
24
src/tekuti
|
@ -39,11 +39,8 @@ exec guile $GUILE_FLAGS -l $0 -e main "$@"
|
||||||
(tekuti mod-lisp)
|
(tekuti mod-lisp)
|
||||||
(tekuti web))
|
(tekuti web))
|
||||||
|
|
||||||
(define (handle-request headers post-data)
|
(define (handle-request headers post-data index)
|
||||||
(let ((heads (fetch-heads `(posts . ,reindex-posts)
|
(let-headers headers ((method "method") (path "url"))
|
||||||
`(categories . ,reindex-categories))))
|
|
||||||
(let-headers
|
|
||||||
headers ((method "method") (path "url"))
|
|
||||||
(url-relative-path-case
|
(url-relative-path-case
|
||||||
method path
|
method path
|
||||||
((POST admin new-post)
|
((POST admin new-post)
|
||||||
|
@ -64,8 +61,21 @@ exec guile $GUILE_FLAGS -l $0 -e main "$@"
|
||||||
(page-debug headers))
|
(page-debug headers))
|
||||||
((POST search)
|
((POST search)
|
||||||
(unimplemented 'search))
|
(unimplemented 'search))
|
||||||
(else (page-not-found path))))))
|
(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)
|
(define (main args)
|
||||||
(ensure-git-repo)
|
(ensure-git-repo)
|
||||||
(event-loop handle-request))
|
(event-loop handle-request maybe-reindex))
|
||||||
|
|
||||||
|
|
|
@ -34,7 +34,7 @@
|
||||||
#:use-module (ice-9 regex) ; hack
|
#:use-module (ice-9 regex) ; hack
|
||||||
#:export (git git* ensure-git-repo git-ls-tree git-ls-subdirs
|
#:export (git git* ensure-git-repo git-ls-tree git-ls-subdirs
|
||||||
parse-metadata parse-commit commit-utc-timestamp
|
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)
|
(define (call-with-pipe pipe proc)
|
||||||
(unwind-protect
|
(unwind-protect
|
||||||
|
@ -148,25 +148,3 @@
|
||||||
|
|
||||||
(define (git-rev-parse rev)
|
(define (git-rev-parse rev)
|
||||||
(string-trim-both (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)
|
(define-module (tekuti mod-lisp)
|
||||||
#:use-module (ice-9 rdelim)
|
#:use-module (ice-9 rdelim)
|
||||||
|
#:use-module (ice-9 receive)
|
||||||
#:use-module (sxml simple)
|
#:use-module (sxml simple)
|
||||||
#:use-module (sxml transform)
|
#:use-module (sxml transform)
|
||||||
#:use-module (tekuti url)
|
#:use-module (tekuti url)
|
||||||
|
@ -57,14 +58,14 @@
|
||||||
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" "
|
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" "
|
||||||
"\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n"))
|
"\"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))
|
(let ((headers (read-headers socket))
|
||||||
(post-data "")) ;; blocks: (read-delimited "" socket)))
|
(post-data "")) ;; blocks: (read-delimited "" socket)))
|
||||||
|
|
||||||
(dbg "~a" headers)
|
(dbg "~a" headers)
|
||||||
(catch #t
|
(catch #t
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let ((sxml (handle-request headers post-data)))
|
(let ((sxml (handle-request headers post-data index)))
|
||||||
(write-headers '(("Status" . "200 OK")
|
(write-headers '(("Status" . "200 OK")
|
||||||
("Content-Type" . "text/html"))
|
("Content-Type" . "text/html"))
|
||||||
socket)
|
socket)
|
||||||
|
@ -78,16 +79,23 @@
|
||||||
|
|
||||||
(close-port socket)))
|
(close-port socket)))
|
||||||
|
|
||||||
(define (event-loop handle-request)
|
(define (with-socket proc)
|
||||||
(pk 'listening)
|
(pk 'listening)
|
||||||
(let ((socket (socket PF_INET SOCK_STREAM 0)))
|
(let ((socket (socket PF_INET SOCK_STREAM 0)))
|
||||||
(bind socket AF_INET (inet-aton *host*) *port*)
|
(bind socket AF_INET (inet-aton *host*) *port*)
|
||||||
(listen socket *backlog*)
|
(listen socket *backlog*)
|
||||||
(unwind-protect
|
(unwind-protect
|
||||||
(let lp ((pair (accept socket)))
|
(proc socket)
|
||||||
(pk pair)
|
|
||||||
(connection-received (car pair) (cdr pair) handle-request)
|
|
||||||
(pk 'done)
|
|
||||||
(lp (accept socket)))
|
|
||||||
(shutdown socket 2))))
|
(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