more hacks, git index done (yay)

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)
+(define (git/input+env input env . args)
-  (let* ((template "/tmp/tekutiXXXXXX")
+  (let* ((template (string-copy "/tmp/tekutiXXXXXX"))
          (tmp (mkstemp! template)))
     (display input tmp)
     (close tmp)
-    (unwind-protect
+    (let ((cmd (string-join `("env" ,@env ,*git* "--bare" ,@args "<" ,template) " ")))
-     (with-pipe
+      (display cmd)(newline)
-      pipe (open-pipe* OPEN_BOTH "/bin/sh" "-c"
+      (unwind-protect
-                       (string-join `(,*git* "--bare" ,@args "<" ,template) " "))
+       (with-pipe
-      (read-delimited "" pipe))
+        pipe (open-pipe* OPEN_BOTH "/bin/sh" "-c"
-     (delete-file template))))
+                         (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)))
+   (filter timestamp (git-ls-subdirs master #f))
-   post-timestamp
+   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
+          (let* ((ts (comment-timestamp sha1))
-           (if parent
+                 (env (list "GIT_COMMMITTER=tekuti"
-               (git/input "comment" "commit-tree" sha1)
+                            ;; this quoting is a hack
-               (git/input "comment" "commit-tree" "-p" parent sha1))))
+                            (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")
+(define (build-post-skeleton master posts)
-(git/input "comment" "commit-tree" "fae8f17277f74fe1e0710fd3be6ebb7879b65969")
+  (fold (lambda (sha1 parent)
-(all-published-posts)
+          (let* ((ts (post-timestamp sha1))
-(string-trim-both "aadabe54f0a4d141657f208645955a2c85af4e0b
+                 (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)
+(define (compute-categories posts)
-  (reindex-posts)
+  (let ((hash (make-hash-table)))
-  (reindex-categories))
+    (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*)

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))