diff --git a/src/tekuti b/src/tekuti index eb216bb..c68b12d 100755 --- a/src/tekuti +++ b/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*) diff --git a/tekuti/popen.scm b/tekuti/popen.scm deleted file mode 100644 index 25eec6d..0000000 --- a/tekuti/popen.scm +++ /dev/null @@ -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))