more hacks, git index done (yay)
This commit is contained in:
Andy Wingo
parent
04ee329b4b
commit
4c9b3b52ae
2 changed files with 145 additions and 241 deletions
171
src/tekuti
171
src/tekuti
|
|
@ -28,6 +28,8 @@ exec guile $GUILE_FLAGS -l $0 -e main "$@"
|
|||
;;
|
||||
;;; Code:
|
||||
|
||||
;;hack!
|
||||
(use-modules (ice-9 regex))
|
||||
|
||||
(use-modules (ice-9 rdelim)
|
||||
(ice-9 popen)
|
||||
|
|
@ -70,7 +72,7 @@ exec guile $GUILE_FLAGS -l $0 -e main "$@"
|
|||
(begin ,@body)
|
||||
(let ((ret (close-pipe ,var)))
|
||||
(if (not (eq? (status:exit-val ret) 0))
|
||||
(throw 'system-error ,var ret))))))
|
||||
(throw 'pipe-error ,var ret))))))
|
||||
|
||||
(define (git . args)
|
||||
(with-pipe
|
||||
|
|
@ -78,17 +80,19 @@ exec guile $GUILE_FLAGS -l $0 -e main "$@"
|
|||
(read-delimited "" pipe)))
|
||||
|
||||
;; true badness
|
||||
(define (git/input input . args)
|
||||
(let* ((template "/tmp/tekutiXXXXXX")
|
||||
(define (git/input+env input env . args)
|
||||
(let* ((template (string-copy "/tmp/tekutiXXXXXX"))
|
||||
(tmp (mkstemp! template)))
|
||||
(display input tmp)
|
||||
(close tmp)
|
||||
(unwind-protect
|
||||
(with-pipe
|
||||
pipe (open-pipe* OPEN_BOTH "/bin/sh" "-c"
|
||||
(string-join `(,*git* "--bare" ,@args "<" ,template) " "))
|
||||
(read-delimited "" pipe))
|
||||
(delete-file template))))
|
||||
(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
|
||||
|
|
@ -234,12 +238,28 @@ exec guile $GUILE_FLAGS -l $0 -e main "$@"
|
|||
(stable-sort (map (lambda (x) (cons (key x) x)) list)
|
||||
(lambda (x y) (less (car x) (car y))))))
|
||||
|
||||
(define (all-published-posts)
|
||||
(define (all-published-posts master)
|
||||
(define (timestamp x)
|
||||
(post-timestamp (cdr x)))
|
||||
(dsu-sort
|
||||
(filter post-timestamp (map cdr (git-ls-subdirs "master" #f)))
|
||||
post-timestamp
|
||||
(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)
|
||||
|
|
@ -255,29 +275,125 @@ exec guile $GUILE_FLAGS -l $0 -e main "$@"
|
|||
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)
|
||||
(string-trim-both
|
||||
(if parent
|
||||
(git/input "comment" "commit-tree" sha1)
|
||||
(git/input "comment" "commit-tree" "-p" parent sha1))))
|
||||
(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))
|
||||
|
||||
(post-comments "085138c227a15c1462138958868f8ef45741e5c5")
|
||||
(git/input "comment" "commit-tree" "fae8f17277f74fe1e0710fd3be6ebb7879b65969")
|
||||
(all-published-posts)
|
||||
(string-trim-both "aadabe54f0a4d141657f208645955a2c85af4e0b
|
||||
")
|
||||
(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)))
|
||||
|
||||
(post-metadata "9a83feef2c2304797ad295043d1f33d8e2dae52d")
|
||||
(define (hash-push! h key value)
|
||||
(let ((handle (hash-create-handle! h key '())))
|
||||
(set-cdr! handle (cons value (cdr handle)))))
|
||||
|
||||
(define (reindex-posts)
|
||||
(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 (reindex)
|
||||
(reindex-posts)
|
||||
(reindex-categories))
|
||||
(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))))
|
||||
|
||||
(define (handle-request headers post-data)
|
||||
(let-headers
|
||||
|
|
@ -312,6 +428,7 @@ exec guile $GUILE_FLAGS -l $0 -e main "$@"
|
|||
(define (connection-received socket sockaddr)
|
||||
(let ((headers (strip-headers socket))
|
||||
(post-data "")) ;; blocks: (read-delimited "" socket)))
|
||||
|
||||
(dbg "~a" headers)
|
||||
(catch #t
|
||||
(lambda ()
|
||||
|
|
@ -330,6 +447,8 @@ exec guile $GUILE_FLAGS -l $0 -e main "$@"
|
|||
(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*)
|
||||
|
|
|
|||
215
tekuti/popen.scm
215
tekuti/popen.scm
|
|
@ -1,215 +0,0 @@
|
|||
;; popen emulation, for non-stdio based ports.
|
||||
|
||||
;;;; Copyright (C) 1998, 1999, 2000, 2001, 2003, 2006 Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; This library is free software; you can redistribute it and/or
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
;;;; License as published by the Free Software Foundation; either
|
||||
;;;; version 2.1 of the License, or (at your option) any later version.
|
||||
;;;;
|
||||
;;;; This library is distributed in the hope that it will be useful,
|
||||
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||||
;;;; Lesser General Public License for more details.
|
||||
;;;;
|
||||
;;;; You should have received a copy of the GNU Lesser General Public
|
||||
;;;; License along with this library; if not, write to the Free Software
|
||||
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||||
;;;;
|
||||
|
||||
(define-module (tekuti popen)
|
||||
:export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe
|
||||
open-output-pipe open-input-output-pipe))
|
||||
|
||||
(define (make-rw-port read-port write-port)
|
||||
(make-soft-port
|
||||
(vector
|
||||
(lambda (c) (write-char c write-port))
|
||||
(lambda (s) (display s write-port))
|
||||
(lambda () (force-output write-port))
|
||||
(lambda () (read-char read-port))
|
||||
(lambda () (close-port read-port) (close-port write-port)))
|
||||
"r+"))
|
||||
|
||||
;; a guardian to ensure the cleanup is done correctly when
|
||||
;; an open pipe is gc'd or a close-port is used.
|
||||
(define pipe-guardian (make-guardian))
|
||||
|
||||
;; a weak hash-table to store the process ids.
|
||||
(define port/pid-table (make-weak-key-hash-table 31))
|
||||
|
||||
(define (ensure-fdes port mode)
|
||||
(or (false-if-exception (fileno port))
|
||||
(open-fdes *null-device* mode)))
|
||||
|
||||
;; run a process connected to an input, an output or an
|
||||
;; input/output port
|
||||
;; mode: OPEN_READ, OPEN_WRITE or OPEN_BOTH
|
||||
;; returns port/pid pair.
|
||||
(define (open-process mode prog . args)
|
||||
(let* ((reading (or (equal? mode OPEN_READ)
|
||||
(equal? mode OPEN_BOTH)))
|
||||
(writing (or (equal? mode OPEN_WRITE)
|
||||
(equal? mode OPEN_BOTH)))
|
||||
(c2p (if reading (pipe) #f)) ; child to parent
|
||||
(p2c (if writing (pipe) #f))) ; parent to child
|
||||
|
||||
(if c2p (setvbuf (cdr c2p) _IONBF))
|
||||
(if p2c (setvbuf (cdr p2c) _IONBF))
|
||||
(let ((pid (primitive-fork)))
|
||||
(cond ((= pid 0)
|
||||
;; child
|
||||
(set-batch-mode?! #t)
|
||||
|
||||
;; select the three file descriptors to be used as
|
||||
;; standard descriptors 0, 1, 2 for the new
|
||||
;; process. They are pipes to/from the parent or taken
|
||||
;; from the current Scheme input/output/error ports if
|
||||
;; possible.
|
||||
|
||||
(let ((input-fdes (if writing
|
||||
(fileno (car p2c))
|
||||
(ensure-fdes (current-input-port)
|
||||
O_RDONLY)))
|
||||
(output-fdes (if reading
|
||||
(fileno (cdr c2p))
|
||||
(ensure-fdes (current-output-port)
|
||||
O_WRONLY)))
|
||||
(error-fdes (ensure-fdes (current-error-port)
|
||||
O_WRONLY)))
|
||||
|
||||
;; close all file descriptors in ports inherited from
|
||||
;; the parent except for the three selected above.
|
||||
;; this is to avoid causing problems for other pipes in
|
||||
;; the parent.
|
||||
|
||||
;; use low-level system calls, not close-port or the
|
||||
;; scsh routines, to avoid side-effects such as
|
||||
;; flushing port buffers or evicting ports.
|
||||
|
||||
(port-for-each (lambda (pt-entry)
|
||||
(false-if-exception
|
||||
(let ((pt-fileno (fileno pt-entry)))
|
||||
(if (not (or (= pt-fileno input-fdes)
|
||||
(= pt-fileno output-fdes)
|
||||
(= pt-fileno error-fdes)))
|
||||
(close-fdes pt-fileno))))))
|
||||
|
||||
;; Copy the three selected descriptors to the standard
|
||||
;; descriptors 0, 1, 2, if not already there
|
||||
|
||||
(cond ((not (= input-fdes 0))
|
||||
(if (= output-fdes 0)
|
||||
(set! output-fdes (dup->fdes 0)))
|
||||
(if (= error-fdes 0)
|
||||
(set! error-fdes (dup->fdes 0)))
|
||||
(dup2 input-fdes 0)
|
||||
;; it's possible input-fdes is error-fdes
|
||||
(if (not (= input-fdes error-fdes))
|
||||
(close-fdes input-fdes))))
|
||||
|
||||
(cond ((not (= output-fdes 1))
|
||||
(if (= error-fdes 1)
|
||||
(set! error-fdes (dup->fdes 1)))
|
||||
(dup2 output-fdes 1)
|
||||
;; it's possible output-fdes is error-fdes
|
||||
(if (not (= output-fdes error-fdes))
|
||||
(close-fdes output-fdes))))
|
||||
|
||||
(cond ((not (= error-fdes 2))
|
||||
(dup2 error-fdes 2)
|
||||
(close-fdes error-fdes)))
|
||||
|
||||
(apply execlp prog prog args)))
|
||||
|
||||
(else
|
||||
;; parent
|
||||
(if c2p (close-port (cdr c2p)))
|
||||
(if p2c (close-port (car p2c)))
|
||||
(cons (cond ((not writing) (car c2p))
|
||||
((not reading) (cdr p2c))
|
||||
(else (make-rw-port (car c2p)
|
||||
(cdr p2c))))
|
||||
pid))))))
|
||||
|
||||
(define (open-pipe* mode command . args)
|
||||
"Executes the program @var{command} with optional arguments
|
||||
@var{args} (all strings) in a subprocess.
|
||||
A port to the process (based on pipes) is created and returned.
|
||||
@var{modes} specifies whether an input, an output or an input-output
|
||||
port to the process is created: it should be the value of
|
||||
@code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}."
|
||||
(let* ((port/pid (apply open-process mode command args))
|
||||
(port (car port/pid)))
|
||||
(pipe-guardian port)
|
||||
(hashq-set! port/pid-table port (cdr port/pid))
|
||||
port))
|
||||
|
||||
(define (open-pipe command mode)
|
||||
"Executes the shell command @var{command} (a string) in a subprocess.
|
||||
A port to the process (based on pipes) is created and returned.
|
||||
@var{modes} specifies whether an input, an output or an input-output
|
||||
port to the process is created: it should be the value of
|
||||
@code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}."
|
||||
(open-pipe* mode "/bin/sh" "-c" command))
|
||||
|
||||
(define (fetch-pid port)
|
||||
(let ((pid (hashq-ref port/pid-table port)))
|
||||
(hashq-remove! port/pid-table port)
|
||||
pid))
|
||||
|
||||
(define (close-process port/pid)
|
||||
(close-port (car port/pid))
|
||||
(cdr (waitpid (cdr port/pid))))
|
||||
|
||||
;; for the background cleanup handler: just clean up without reporting
|
||||
;; errors. also avoids blocking the process: if the child isn't ready
|
||||
;; to be collected, puts it back into the guardian's live list so it
|
||||
;; can be tried again the next time the cleanup runs.
|
||||
(define (close-process-quietly port/pid)
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(close-port (car port/pid)))
|
||||
(lambda args #f))
|
||||
(catch 'system-error
|
||||
(lambda ()
|
||||
(let ((pid/status (waitpid (cdr port/pid) WNOHANG)))
|
||||
(cond ((= (car pid/status) 0)
|
||||
;; not ready for collection
|
||||
(pipe-guardian (car port/pid))
|
||||
(hashq-set! port/pid-table
|
||||
(car port/pid) (cdr port/pid))))))
|
||||
(lambda args #f)))
|
||||
|
||||
(define (close-pipe p)
|
||||
"Closes the pipe created by @code{open-pipe}, then waits for the process
|
||||
to terminate and returns its status value, @xref{Processes, waitpid}, for
|
||||
information on how to interpret this value."
|
||||
(let ((pid (fetch-pid p)))
|
||||
(if (not pid)
|
||||
(error "close-pipe: pipe not in table"))
|
||||
(close-process (cons p pid))))
|
||||
|
||||
(define reap-pipes
|
||||
(lambda ()
|
||||
(let loop ((p (pipe-guardian)))
|
||||
(cond (p
|
||||
;; maybe removed already by close-pipe.
|
||||
(let ((pid (fetch-pid p)))
|
||||
(if pid
|
||||
(close-process-quietly (cons p pid))))
|
||||
(loop (pipe-guardian)))))))
|
||||
|
||||
(add-hook! after-gc-hook reap-pipes)
|
||||
|
||||
(define (open-input-pipe command)
|
||||
"Equivalent to @code{open-pipe} with mode @code{OPEN_READ}"
|
||||
(open-pipe command OPEN_READ))
|
||||
|
||||
(define (open-output-pipe command)
|
||||
"Equivalent to @code{open-pipe} with mode @code{OPEN_WRITE}"
|
||||
(open-pipe command OPEN_WRITE))
|
||||
|
||||
(define (open-input-output-pipe command)
|
||||
"Equivalent to @code{open-pipe} with mode @code{OPEN_BOTH}"
|
||||
(open-pipe command OPEN_BOTH))
|
||||
Loading…
Reference in a new issue