stop hitting git when fetching post metadata

Inspired by a patch from Aleix Conchillo Flaqué.  Thanks, Aleix!

* tekuti/index.scm (index-specs):
* tekuti/post.scm (reindex-posts, reindex-posts-by-date): Change to have
  the "posts" index be a hash table mapping key -> post.
  "posts-by-date" is a list of keys, from newest to oldest.
  (post-from-git): This is what post-from-key was.
  (post-from-key): New function, pulls out a post from the posts hash
  table.
  (munge-post): Use post-from-git.
  (delete-post): Take the post directly.
  (latest-posts): New awesome helper for fetching the lastest N posts
  that match some predicates.

* tekuti/page-helpers.scm (find-posts-matching): Adapt to post-from-key
  change.
  (published-posts): Remove, replaced with latest-posts.

* tekuti/page.scm (page-admin, page-admin-posts, page-admin-post)
  (page-archives, page-feed-atom): Use the new latest-posts helper.
  (page-admin-delete-post, page-admin-delete-comment, page-show-post)
  (page-new-comment, page-show-tag): Adapt to post-from-key change.

* tekuti/tags.scm (compute-related-posts, compute-related-tags): Adapt
  to post-from-key change.
  (reindex-tags): Use latest-posts.

tekuti/index.scm

@@ -35,7 +35,8 @@
   #:export (maybe-reindex read-index update-index))
 
 (define index-specs
-  `((posts ,reindex-posts ,write ,read)
+  `((posts ,reindex-posts ,write-hash ,read-hash)
+    (posts-by-date ,reindex-posts-by-date ,write ,read)
     (tags ,reindex-tags ,write-hash ,read-hash)
     (cache ,(lambda _ (make-empty-cache)) ,(lambda (x) #f) ,(lambda () '()))))
 

tekuti/page-helpers.scm

@@ -1,5 +1,5 @@
 ;; Tekuti
-;; Copyright (C) 2008, 2010 Andy Wingo <wingo at pobox dot com>
+;; Copyright (C) 2008, 2010, 2012 Andy Wingo <wingo at pobox dot com>
 
 ;; This program is free software; you can redistribute it and/or    
 ;; modify it under the terms of the GNU General Public License as   
@@ -41,7 +41,6 @@
   #:export (respond
             relurl rellink
             post-url
-            published-posts
             post-editing-form
             sidebar-ul top-tags tag-cloud
             main-sidebar post-sidebar related-tag-cloud
@@ -151,12 +150,6 @@
   (relative-path-link *public-path-base* path-components text #:query query
                       #:fragment fragment))
 
-(define (published-posts index n)
-  (filter-mapn (lambda (post)
-                 (and (post-published? post) post))
-               (assq-ref index 'posts)
-               n))
-
 (define (post-editing-form post)
   `(div
     (form (@ (method "POST")
@@ -371,7 +364,7 @@
                         (git "grep" "-l" "-F" string master "--" "*/content"))
                        "")
                    ":(.+)/content$" (_ key)
-                   (post-from-key master key)))
+                   (post-from-key index key)))
      post-timestamp
      >)))
 

tekuti/page.scm

@@ -1,5 +1,5 @@
 ;; Tekuti
-;; Copyright (C) 2008, 2010, 2011 Andy Wingo <wingo at pobox dot com>
+;; Copyright (C) 2008, 2010, 2011, 2012 Andy Wingo <wingo at pobox dot com>
 
 ;; This program is free software; you can redistribute it and/or    
 ;; modify it under the terms of the GNU General Public License as   
@@ -75,10 +75,9 @@
    (lambda ()
      ;; here we need to be giving a dashboard view instead of this
      (define (post-links n)
-       (mapn (lambda (post)
+       (map (lambda (post)
-               `(li ,(admin-post-link post)))
+              `(li ,(admin-post-link post)))
-             (assq-ref index 'posts)
+            (latest-posts index #:allow-unpublished? #t #:limit n)))
-             n))
      (define (recent-changes n)
        (map (lambda (rev)
               `(li ,(rellink `("admin" "changes" ,(car rev))
@@ -100,7 +99,7 @@
      (define (post-headers)
        (map (lambda (post)
               `(h3 ,(admin-post-link post)))
-            (assq-ref index 'posts)))
+            (latest-posts index #:allow-unpublished? #t #:limit -1)))
      (respond `((h1 "all your posts are belong to tekuti")
                 ,@(post-headers))))))
 
@@ -108,7 +107,7 @@
   (with-authentication
    request
    (lambda ()
-     (let ((post (post-from-key (assq-ref index 'master) key #t)))
+     (let ((post (post-from-key index key #:allow-unpublished? #t)))
        (respond `((h1 ,(post-title post))
                   ,(post-editing-form post)))))))
 
@@ -132,14 +131,14 @@
   (with-authentication
    request
    (lambda ()
-     (delete-post key)
+     (delete-post (post-from-key index key #:allow-unpublished? #t))
      (respond `((p "redirecting...")) #:redirect (relurl `("admin"))))))
      
 (define (page-admin-delete-comment request body index key comment-id)
   (with-authentication
    request
    (lambda ()
-     (let ((post (post-from-key (assq-ref index 'master) key #t)))
+     (let ((post (post-from-key index key #:allow-unpublished? #t)))
        (delete-comment post comment-id)
        (respond `((p "redirecting...")) #:redirect (admin-post-url post))))))
      
@@ -189,13 +188,12 @@
   (respond `(,(main-sidebar request index)
              ,@(map (lambda (post)
                       (show-post post #f))
-                    (published-posts index 10)))
+                    (latest-posts index #:limit 10)))
            #:etag (assq-ref index 'master)))
 
 (define (page-show-post request body index year month day post)
   (cond
-   ((post-from-key (assq-ref index 'master)
+   ((post-from-key index (make-post-key year month day post))
-                   (make-post-key year month day post))
     => (lambda (post)
          (respond `(,(post-sidebar post index)
                     ,(show-post post #t))
@@ -207,8 +205,7 @@
 (define (page-new-comment request body index year month day name)
   (let ((data (request-form-data request body)))
     (cond
-     ((post-from-key (assq-ref index 'master)
+     ((post-from-key index (make-post-key year month day name))
-                     (make-post-key year month day name))
       => (lambda (post)
            (cond
             ((bad-new-comment-post? data)
@@ -243,7 +240,7 @@
       (define (make-date-header post)
         (lambda (x) #f))
     
-      (let lp ((posts (published-posts index -1)))
+      (let lp ((posts (latest-posts index #:limit -1)))
         (cond ((or (null? posts) (too-early? (car posts)))
                (respond `((h1 "No posts found")
                           (p "No posts were found in the specified period."))
@@ -283,7 +280,7 @@
 (define (page-show-tag request body index tag)
   (let* ((tags (assq-ref index 'tags))
          (posts (map (lambda (key)
-                       (post-from-key (assq-ref index 'master) key))
+                       (post-from-key index key))
                      (hash-ref tags tag '()))))
     (if (pair? posts)
         (respond `((h2 "posts tagged \"" ,tag "\" ("
@@ -343,9 +340,7 @@
 (define (page-feed-atom request body index)
   (let ((with (request-query-ref-all request "with"))
         (without (request-query-ref-all request "without"))
-        (tags (assq-ref index 'tags))
+        (tags (assq-ref index 'tags)))
-        (posts (assq-ref index 'posts))
-        (master (assq-ref index 'master)))
     (define include?
       (if (pair? with)
           (fold (lambda (tag cont)
@@ -369,9 +364,8 @@
     
     (atom-feed-from-posts
      request body index
-     (filter-mapn (lambda (post)
+     (latest-posts index
-                    (and (include? post) (not (exclude? post))
+                   #:filter
-                         (post-published? post)
+                   (lambda (post)
-                         post))
+                     (and (include? post) (not (exclude? post))))
-                  posts
+                   #:limit 10))))
-                  10))))

tekuti/post.scm

@@ -1,5 +1,5 @@
 ;; Tekuti
-;; Copyright (C) 2008, 2010, 2011 Andy Wingo <wingo at pobox dot com>
+;; Copyright (C) 2008, 2010, 2011, 2012 Andy Wingo <wingo at pobox dot com>
 
 ;; This program is free software; you can redistribute it and/or    
 ;; modify it under the terms of the GNU General Public License as   
@@ -35,7 +35,7 @@
   #:use-module (tekuti filters)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
-  #:export (post-from-tree post-from-key
+  #:export (post-from-key
 
             post-tags post-timestamp post-key post-published?
             post-comments-open? post-comments
@@ -44,14 +44,14 @@
             post-title
 
             make-new-post modify-post delete-post
-            
-            all-published-posts
 
-            reindex-posts))
+            latest-posts
 
-;;; 
+            reindex-posts reindex-posts-by-date))
+
+;;;
 ;;; pulling posts out of git
-;;; 
+;;;
 
 (define *post-spec*
   `((timestamp . ,string->number)
@@ -69,15 +69,21 @@
                              identity)))
              (cons k (parse v))))))
 
-(define (post-from-key master key . allow-unpublished)
+(define (post-from-git master key)
   (false-if-git-error
    (let ((pairs (git-ls-subdirs master key)))
      (and (= (length pairs) 1)
-          (let ((post (post-from-tree key (cdar pairs))))
+          (post-from-tree key (cdar pairs))))))
-            (if (or (post-published? post)
+
-                    (and (pair? allow-unpublished) (car allow-unpublished)))
+;;;
-                post
+;;; pulling posts out of the index
-                #f))))))
+;;;
+
+(define* (post-from-key index key #:key allow-unpublished?)
+  (let ((post (hash-ref (assq-ref index 'posts) key)))
+    (if (and post (or (post-published? post) allow-unpublished?))
+        post
+        #f)))
 
 ;;; 
 ;;; accessors
@@ -156,13 +162,13 @@
                 (maybe-clear
                  `((create (,key) ("metadata" ,metadata blob))
                    (create (,key) ("content" ,content blob)))))))
-      (post-from-key
+      (post-from-git
        (git-update-ref "refs/heads/master"
                        (lambda (master)
                          (git-commit-tree (munge-tree master ops)
                                           master message #f))
                        5)
-       key #t))))
+       key))))
 
 (define space-to-dash (s///g "[ .]" "-"))
 (define remove-extraneous (s///g "[^a-z0-9-]+" ""))
@@ -201,41 +207,45 @@
 (define (modify-post old-key post-data)
   (munge-post old-key (parse-post-data post-data)))
 
-(define (delete-post key)
+(define (delete-post post)
-  (let* ((post (post-from-key "refs/heads/master" key))
+  (let ((message (format #f "~a: \"~a\"" "post deleted" (post-title post))))
-         (message (format #f "~a: \"~a\"" "post deleted" (post-title post))))
     (git-update-ref "refs/heads/master"
                   (lambda (master)
-                    (git-commit-tree (munge-tree1 master 'delete '() `(,key))
+                    (git-commit-tree
-                                     master message #f))
+                     (munge-tree1 master 'delete '() `(,(post-key post)))
+                     master message #f))
                   5)))
 
-(define (all-posts master)
+(define* (latest-posts index #:key allow-unpublished? (filter identity)
-  (map (lambda (pair)
+                       (limit 10))
-         (post-from-tree (car pair) (cdr pair)))
+  (filter-mapn
-       (git-ls-subdirs master #f)))
+   (lambda (key)
+     (and=> (post-from-key index key #:allow-unpublished? allow-unpublished?)
+            (lambda (post) (and post (filter post) post))))
+   (assq-ref index 'posts-by-date)
+   limit))
 
-(define (all-published-posts master)
+(define (reindex-posts old-index index)
-  (dsu-sort
+  (let ((old (assq-ref old-index 'posts))
-   (filter post-published? (all-posts master))
+        (new (make-hash-table)))
-   post-timestamp
+    (for-each
-   >))
+     (lambda (dent)
-
+       (let* ((key (car dent))
-(define (hash-fill proc list)
+              (sha1 (cadr dent))
-  (let ((table (make-hash-table)))
+              (prev (and (hash-table? old) (hash-ref old key))))
-    (for-each (lambda (x) (proc x table))
+         (hash-set! new key
-              list)
+                    (if (and prev (equal? (assq-ref prev 'sha1) sha1))
-    table))
+                        prev
-
+                        (begin
-(define (reindex-posts oldindex newindex)
+                          (pk 'updated dent)
-  (let ((old (hash-fill (lambda (post h)
+                          (post-from-tree key sha1))))))
-                          (hash-set! h (assq-ref post 'sha1) post))
+     (git-ls-tree (assq-ref index 'master) #f))
-                        (or (assq-ref oldindex 'posts) '()))))
+    new))
-    (dsu-sort (map (lambda (dent)
-                     (or (hash-ref old (cadr dent))
-                         (begin (pk 'updated dent)
-                                (post-from-tree (car dent) (cadr dent)))))
-                   (git-ls-tree (assq-ref newindex 'master) #f))
-              post-timestamp
-              >)))
 
+(define (reindex-posts-by-date old-index index)
+  (map cdr
+       (sort (hash-map->list (lambda (key post)
+                               (cons (post-timestamp post) key))
+                             (assq-ref index 'posts))
+             (lambda (x y)
+               (> (car x) (car y))))))

tekuti/tags.scm

@@ -1,5 +1,5 @@
 ;; Tekuti
-;; Copyright (C) 2008, 2010 Andy Wingo <wingo at pobox dot com>
+;; Copyright (C) 2008, 2010, 2012 Andy Wingo <wingo at pobox dot com>
 
 ;; This program is free software; you can redistribute it and/or    
 ;; modify it under the terms of the GNU General Public License as   
@@ -54,8 +54,7 @@
     hash))
 
 (define (compute-related-posts post index)
-  (let ((hash (assq-ref index 'tags))
+  (let ((hash (assq-ref index 'tags)))
-        (master (assq-ref index 'master)))
     (if hash
         (let ((accum (make-hash-table)))
           (for-each
@@ -69,7 +68,7 @@
           (dsu-sort (dsu-sort
                      (hash-fold
                       (lambda (key tags rest)
-                        (acons (post-from-key master key) tags rest))
+                        (acons (post-from-key index key) tags rest))
                       '() accum)
                      (lambda (x) (post-timestamp (car x)))
                      >)
@@ -77,8 +76,7 @@
         '())))
 
 (define (compute-related-tags tag index)
-  (let ((hash (assq-ref index 'tags))
+  (let ((hash (assq-ref index 'tags)))
-        (master (assq-ref index 'master)))
     (if hash
         (let ((accum (make-hash-table)))
           (for-each
@@ -87,7 +85,7 @@
               (lambda (other-tag)
                 (if (not (equal? other-tag tag))
                     (hash-push! accum other-tag key)))
-              (post-tags (post-from-key master key))))
+              (post-tags (post-from-key index key))))
            (or (hash-ref hash tag) '()))
           (dsu-sort
            (hash-fold
@@ -99,4 +97,4 @@
         '())))
 
 (define (reindex-tags old-index index)
-  (compute-tags (filter post-published? (assq-ref index 'posts))))
+  (compute-tags (latest-posts index #:limit -1)))