add missing files

2 files changed, 273 insertions, 0 deletions

diff --git a/tekuti/index.scm b/tekuti/index.scm
new file mode 100644
index 0000000..7524712
--- /dev/null
+++ b/tekuti/index.scm
@@ -0,0 +1,101 @@
+;; Tekuti
+;; Copyright (C) 2008 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   
+;; published by the Free Software Foundation; either version 3 of   
+;; the License, or (at your option) any later version.              
+;;                                                                  
+;; This program 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 General Public License for more details.                     
+;;                                                                  
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, contact:
+;;
+;; Free Software Foundation           Voice:  +1-617-542-5942
+;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
+;; Boston, MA  02111-1307,  USA       gnu@gnu.org
+
+;;; Commentary:
+;;
+;; Indexing of the persistent data store.
+;;
+;;; Code:
+
+(define-module (tekuti index)
+  #:use-module ((srfi srfi-1) #:select (fold))
+  #:use-module (tekuti util)
+  #:use-module (tekuti git)
+  #:use-module (tekuti post)
+  #:use-module (tekuti tags)
+  #:export (maybe-reindex read-index))
+
+(define index-specs
+  `((posts ,reindex-posts ,write ,read)
+    (tags ,reindex-tags ,write-hash ,read-hash)))
+
+(define (reindex oldindex master)
+  (with-backtrace
+   (with-time-debugging
+    (fold (lambda (pair index)
+            (acons (car pair) ((cadr pair) oldindex index)
+                   index))
+          (acons 'master master '())
+          index-specs))))
+
+(define (assoc-list-ref alist key n default)
+  (let ((l (assoc key alist)))
+    (if l (list-ref l n) default)))
+
+(define (index->blob key value)
+  (with-output-to-blob
+   ((assoc-list-ref index-specs key 2 write) value)))
+  
+(define (blob->index name sha1)
+  (with-input-from-blob
+   sha1
+   ((assoc-list-ref index-specs (string->symbol name) 3 read))))
+
+(define (write-index index oldref)
+  (let ((new (git-commit-tree
+              (git-mktree
+               (pk (map (lambda (pair)
+                          (list (car pair)
+                                (index->blob (car pair) (cdr pair))
+                                'blob))
+                        index)))
+              oldref "reindex\n"
+              (commit-utc-timestamp (assq-ref index 'master)))))
+    (or (false-if-git-error
+         (git "update-ref" "refs/heads/index" new (or oldref "")))
+        (warn "could not update indexes ref"))
+    new))
+
+(define (read-index)
+  (let* ((ref (false-if-git-error (git-rev-parse "refs/heads/index")))
+         (dents (if ref (git-ls-tree ref #f) '())))
+    (cons ref
+          (and (and-map (lambda (spec)
+                          (assoc (symbol->string (car spec)) dents))
+                        index-specs)
+               (map (lambda (dent)
+                      (cons (string->symbol (car dent))
+                            (blob->index (car dent) (cadr dent))))
+                    dents)))))
+
+(define (maybe-reindex old-index)
+  (let ((master (git-rev-parse "refs/heads/master"))
+        (old-index-sha1 (and=> old-index car))
+        (old-index-data (if old-index (cdr old-index) '())))
+    (if (equal? (assq-ref old-index-data 'master) master)
+        old-index
+        (catch #t
+               (lambda ()
+                 (let ((new-index (reindex old-index-data master)))
+                   (cons (write-index new-index old-index-sha1)
+                         new-index)))
+               (lambda (key . args)
+                 (warn "error while reindexing:" key args)
+                 old-index)))))
diff --git a/tekuti/page-helpers.scm b/tekuti/page-helpers.scm
new file mode 100644
index 0000000..57cabec
--- /dev/null
+++ b/tekuti/page-helpers.scm
@@ -0,0 +1,172 @@
+;; Tekuti
+;; Copyright (C) 2008 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   
+;; published by the Free Software Foundation; either version 3 of   
+;; the License, or (at your option) any later version.              
+;;                                                                  
+;; This program 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 General Public License for more details.                     
+;;                                                                  
+;; You should have received a copy of the GNU General Public License
+;; along with this program; if not, contact:
+;;
+;; Free Software Foundation           Voice:  +1-617-542-5942
+;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
+;; Boston, MA  02111-1307,  USA       gnu@gnu.org
+
+;;; Commentary:
+;;
+;; Helper bits, mostly verbose-like SXML stuff.
+;;
+;;; Code:
+
+(define-module (tekuti page-helpers)
+  #:use-module (tekuti config)
+  #:use-module (tekuti util)
+  #:use-module (tekuti git)
+  #:use-module (tekuti post)
+  #:use-module (tekuti comment)
+  #:use-module (tekuti url)
+  #:use-module (tekuti request)
+  #:use-module (srfi srfi-19)
+  #:use-module (scheme kwargs)
+  #:export (relurl rellink
+            published-posts
+            post-editing-form
+            sidebar-ul main-sidebar tag-cloud
+            post-link admin-post-link
+            show-post
+            atom-header atom-entry))
+
+(define (relurl path)
+  (string-append *public-url-base* path))
+
+(define (rellink path . body)
+  `(a (@ (href ,(relurl path)))
+      ,@body))
+
+(define (published-posts index n)
+  (filter-mapn (lambda (post)
+                 (and (post-published? post) post))
+               (assq-ref index 'posts)
+               n))
+
+(define (post-editing-form post)
+  `(form (@ (method "POST")
+            (action ,(relurl (if post
+                                 (string-append "admin/modify-post/"
+                                                (url:encode (assq-ref post 'key)))
+                                 "admin/new-post"))))
+         (p "title: "
+            (input (@ (name "title") (type "text")
+                      (value ,(if post (post-title post) "")))))
+         (div (textarea (@ (name "body") (rows "20") (cols "80"))
+                        ,(if post (post-raw-content post) "")))
+         (input (@ (type "submit")
+                   (value ,(if post "edit post" "new post"))))))
+
+(define (sidebar-ul body)
+  `(div (@ (id "menu"))
+        (ul ,@body)))
+
+;; double-encoding is a hack to trick apache
+(define (admin-post-link post)
+  (rellink (string-append "admin/posts/"
+                         (url:encode (post-key post)))
+           (assq-ref post 'title)))
+
+(define (post-link post)
+  (rellink (string-append "archives/" (url:decode (post-key post)))
+           (assq-ref post 'title)))
+
+(define (show-post post comments?)
+  `((h2 (@ (class "storytitle"))
+        ,(post-link post))
+    (div (@ (class "post"))
+         (h3 (@ (class "meta"))
+             ,(post-readable-date post)
+             " (" ,@(list-intersperse (post-tag-links post)
+                                      " | ")
+             ")")
+         (div (@ (class "storycontent"))
+              ,(post-sxml-content post))
+         ,@(if comments? '()
+               (list (post-sxml-n-comments post))))
+    ,@(if comments?
+          (list (post-sxml-comments post))
+          '())))
+
+;; fixme: borks in the no-tags case
+(define (tag-cloud index)
+  (define (determine-sizes counts)
+    (let ((maxcount (apply max counts)))
+      (map (lambda (x)
+             (floor (+ 80 (* 120 (/ x maxcount)))))
+           counts)))
+  (let* ((hash (assq-ref index 'tags))
+         (cats (if hash
+                   (hash-fold (lambda (k v seed) (acons k (length v) seed))
+                              '() hash)
+                   '()))
+         (top-20 (dsu-sort (take-max (dsu-sort cats cdr >) 20)
+                           car string<?)))
+    `(ul (li (@ (style "line-height: 150%"))
+             ,@(list-intersperse
+                (map (lambda (name size)
+                       `(a (@ (href ,(string-append
+                                      *public-url-base* "tags/"
+                                      (url:encode name)))
+                              (rel "tag")
+                              (style ,(format #f "font-size: ~d%" size)))
+                           ,name))
+                     (map car top-20)
+                     (determine-sizes (map cdr top-20)))
+                " "))
+         )))
+
+(define (main-sidebar request index)
+  (sidebar-ul
+   `((li (h2 (a (@ (href ,(relurl "feed/atom")))
+                "subscribe "
+                (img (@ (src ,(relurl "wp-content/feed-icon-14x14.png"))
+                        (alt "subscribe to this feed")))
+                )))
+     (li (h2 "tags "
+             (a (@ (href ,(string-append *public-url-base* "tags/")))
+                ">>"))
+         ,(tag-cloud index)))))
+
+(define (atom-header server-name last-modified)
+  (define (relurl tail)
+    (string-append "http://" server-name *public-url-base* tail))
+  `(feed
+     (@ (xmlns "http://www.w3.org/2005/Atom")
+        (xml:base ,(relurl "feed/atom")))
+     (title (@ (type "text")) ,*title*)
+     (subtitle (@ (type "text")) ,*subtitle*)
+     (updated ,(timestamp->atom-date last-modified))
+     (generator (@ (uri "http://wingolog.org/software/tekuti")
+                   (version "what"))
+                "tekuti")
+     (link (@ (rel "alternate") (type "text/html")
+              (href ,(relurl ""))))
+     (id ,(relurl "feed/atom"))
+     (link (@ (rel "self") (type "application/atom+xml")
+              (href ,(relurl "feed/atom"))))))
+
+(define (atom-entry server-name post)
+  (define (relurl tail)
+    (string-append "http://" server-name *public-url-base* tail))
+  `(entry
+    (author (name ,*name*) (uri ,(relurl "")))
+    (title (@ (type "text")) ,(post-title post))
+    (id ,(relurl (url:decode (post-key post)))) ;hack
+    (published ,(timestamp->atom-date (post-timestamp post)))
+    (updated ,(timestamp->atom-date (post-timestamp post)))
+    (content (@ (type "xhtml"))
+             (div (@ (xmlns "http://www.w3.org/1999/xhtml"))
+                  ,(post-sxml-content post)))))