new clever indexing scheme

src/upgrade-metadata

@@ -31,7 +31,6 @@ exec guile $GUILE_FLAGS -l $0 -e main -- "$@"
 ;; (turn-on-debugging)
 (use-modules (tekuti git) (tekuti post))
 
-;; order: name object type mode
 (define (make-tree-full alist)
   (string-trim-both
    (git* '("mktree")

tekuti/categories.scm

@@ -33,11 +33,11 @@
 (define (compute-categories posts)
   (let ((hash (make-hash-table)))
     (for-each
-     (lambda (post-pair)
+     (lambda (post)
        (for-each
         (lambda (cat)
-          (hash-push! hash cat post-pair))
-        (post-categories (cdr post-pair))))
+          (hash-push! hash cat (assq-ref post 'key)))
+        (post-categories post)))
      posts)
     hash))
 

tekuti/comment.scm

@@ -43,7 +43,7 @@
   `((timestamp . ,string->number)))
 (define (comment-from-tree encoded-name sha1)
   (acons 'encoded-name encoded-name
-         (parse-metadata (string-append sha1 ":" "metadata"))))
+         (parse-metadata (string-append sha1 ":" "metadata") *comment-spec*)))
 
 (define (comment-timestamp comment-alist)
   (or (assq-ref comment-alist 'timestamp) #f))

tekuti/git.scm

@@ -38,7 +38,9 @@
 
             git git* ensure-git-repo git-ls-tree git-ls-subdirs
             parse-metadata parse-commit commit-utc-timestamp
-            commit-parents make-tree git-rev-parse))
+            commit-parents make-tree git-rev-parse
+
+            write-indices read-indices))
 
 (define-condition-type &git-condition &condition git-condition?
   (argv git-condition-argv)
@@ -137,8 +139,19 @@
                "^(.+) tree (.+)\t(.+)$" (_ mode object name)
                (cons name object)))
 
-(define (parse-metadata treeish)
-  (with-input-from-string (git "show" treeish) read))
+(define (parse-metadata treeish specs)
+  (filter
+   identity
+   (match-lines (git "show" treeish)
+                "^([^: ]+): +(.*)$" (_ k v)
+                (let* ((k (string->symbol k))
+                       (parse (assq-ref specs k)))
+                  (if parse
+                      (catch 'parse-error
+                             (lambda ()
+                               (cons k (parse v)))
+                             (lambda args #f))
+                      (cons k v))))))
 
 (define (parse-commit commit)
   (let ((text (git "cat-file" "commit" commit)))
@@ -157,6 +170,8 @@
    (let ((ts (string->number ts)) (tz (string->number tz)))
      (- ts (* (+ (* (quotient tz 100) 60) (remainder tz 100)) 60)))))
 
+;; fixme: do to commits what i already did to posts
+
 (define (commit-parents commit)
   (map cdr
        (filter
@@ -175,3 +190,62 @@
 
 (define (git-rev-parse rev)
   (string-trim-both (git "rev-parse" rev)))
+
+(define (create-blob contents)
+  (string-trim-both
+   (git* '("hash-object" "-w" "--stdin") #:input contents)))
+
+;; order: name object type mode
+(define (make-tree-full alist)
+  (string-trim-both
+   (git* '("mktree")
+         #:input (string-join
+                  (map (lambda (l)
+                         (apply format #f "~a ~a ~a\t~a"
+                                (reverse l)))
+                       alist)
+                  "\n" 'suffix))))
+
+;; fixme: map-pairs
+
+(define (assoc-list-ref alist key n default)
+  (let ((l (assoc key alist)))
+    (if l (list-ref l n) default)))
+
+(define (write-indices indices oldref specs)
+  (let* ((master (assq-ref indices 'master))
+         (ts (commit-utc-timestamp master))
+         (env (list "GIT_COMMMITTER=tekuti"
+                    (format #f "GIT_COMMITTER_DATE=~a +0100" ts)
+                    (format #f "GIT_AUTHOR_DATE=~a +0100" ts)))
+         (tree (make-tree-full
+                (map (lambda (pair)
+                       (list (symbol->string (car pair))
+                             (create-blob
+                              (with-output-to-string
+                                (lambda ()
+                                  ((assoc-list-ref specs (car pair) 2 write)
+                                   (cdr pair)))))
+                             "blob" "100644"))
+                     indices))))
+    (let ((new (string-trim-both
+                (git* (cons* "commit-tree" tree
+                             (if oldref (list "-p" oldref) '()))
+                      #:input "reindex\n" #:env env))))
+      (or (false-if-git-error
+           (git "update-ref" "refs/heads/index" new (or oldref "")))
+          (warn "could not update indexes ref"))
+      new)))
+
+(define (read-indices specs)
+  (and=> (false-if-git-error (git-rev-parse "refs/heads/index"))
+         (lambda (ref)
+           (cons ref
+                 (map (lambda (dent)
+                        (cons (string->symbol (car dent))
+                              (with-input-from-string 
+                                  (git "show" (cadr dent))
+                                (assoc-list-ref specs (string->symbol (car dent)) 3 read))))
+                      (git-ls-tree (assq-ref (parse-commit ref) 'tree)
+                                    #f))))))
+

tekuti/mod-lisp.scm

@@ -119,9 +119,20 @@
         
         val))))
 
+(define (write-hash h)
+  (write (hash-fold acons '() h)))
+
+;; fixme: doesn't share structure with posts index
+(define (read-hash)
+  (let ((h (make-hash-table)))
+    (for-each (lambda (pair)
+                (hash-set! h (car pair) (cdr pair)))
+              (read))
+    h))
+
 (define indices                          
-  `((posts . ,reindex-posts)
-    (categories . ,reindex-categories)))
+  `((posts ,reindex-posts ,write ,read)
+    (categories ,reindex-categories ,write-hash ,read-hash)))
 
 (use-modules (statprof))
 (define (reindex master)
@@ -131,34 +142,30 @@
       (lambda ()
         (with-statprof #:hz 100
                        (fold (lambda (pair index)
-                               (acons (car pair) ((cdr pair) index)
+                               (acons (car pair) ((cadr pair) index)
                                       index))
                              (acons 'master master '())
                              indices)))))))
 
-(define (maybe-reindex old-master old-index)
+(define (maybe-reindex old-index)
   (let ((master (git-rev-parse "master")))
-    (values
-     master 
-     (if (equal? master old-master)
-         old-index
-         (reindex master)))))
+    (if (and old-index (equal? (assq-ref (cdr old-index) 'master) master))
+        old-index
+        (let ((new-index (reindex master)))
+          (cons (write-indices new-index (and=> old-index car) indices)
+                new-index)))))
 
-(define (inner-loop socket cookie index)
+(define (inner-loop socket index)
   (let* ((pair (accept socket))
          (fd (car pair))
-         (sockaddr (cdr pair)))
-    (receive
-     (new-cookie new-index) (maybe-reindex cookie index)
-     (connection-received (car pair) (cdr pair) new-index)
-     (inner-loop socket new-cookie new-index))))
+         (sockaddr (cdr pair))
+         (new-index (maybe-reindex index)))
+    (connection-received (car pair) (cdr pair) (cdr new-index))
+    (inner-loop socket new-index)))
 
 (define (event-loop)
   (with-socket
    (lambda (socket)
-     (format #t "running initial index\n")
-     (receive
-      (master index) (maybe-reindex #f #f)
-      (format #t "entering inner loop\n")
-      (inner-loop socket master index)))))
+     (format #t "entering inner loop\n")
+     (inner-loop socket (read-indices indices)))))
 

tekuti/post.scm

@@ -57,7 +57,8 @@
 (define-memoized (post-from-tree encoded-name sha1)
   (acons 'key encoded-name
          (acons 'content-ref (string-append sha1 ":content")
-                (parse-metadata (string-append sha1 ":metadata")))))
+                (parse-metadata (string-append sha1 ":metadata")
+                                *post-spec*))))
 
 (define (post-raw-content post)
   (git "show" (assq-ref post 'content-ref)))