From ca585c382fe5adc8d8d64d63d56e43925756cd5e Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 Feb 2008 12:57:18 +0100 Subject: new clever indexing scheme --- src/upgrade-metadata | 1 - tekuti/categories.scm | 6 ++-- tekuti/comment.scm | 2 +- tekuti/git.scm | 80 +++++++++++++++++++++++++++++++++++++++++++++++++-- tekuti/mod-lisp.scm | 47 +++++++++++++++++------------- tekuti/post.scm | 3 +- 6 files changed, 110 insertions(+), 29 deletions(-) diff --git a/src/upgrade-metadata b/src/upgrade-metadata index 14edadb..4a4a6b1 100755 --- a/src/upgrade-metadata +++ b/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") diff --git a/tekuti/categories.scm b/tekuti/categories.scm index 77ec047..332d64a 100644 --- a/tekuti/categories.scm +++ b/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)) diff --git a/tekuti/comment.scm b/tekuti/comment.scm index 6754f77..f0deb43 100644 --- a/tekuti/comment.scm +++ b/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)) diff --git a/tekuti/git.scm b/tekuti/git.scm index 35323dd..5c516fa 100644 --- a/tekuti/git.scm +++ b/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)))))) + diff --git a/tekuti/mod-lisp.scm b/tekuti/mod-lisp.scm index b796815..da2e7fa 100644 --- a/tekuti/mod-lisp.scm +++ b/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))))) diff --git a/tekuti/post.scm b/tekuti/post.scm index 3748e66..a1b7531 100644 --- a/tekuti/post.scm +++ b/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))) -- cgit v1.2.3-54-g00ecf