cleanups, refactorings, what-not

tekuti/comment.scm

@@ -33,32 +33,26 @@
   #:use-module (srfi srfi-19)
   #:use-module (sxml transform)
   #:use-module (match-bind)
-  #:export (comment-from-object comment-sxml-content comment-timestamp build-comment-skeleton comment-readable-date
-            bad-new-comment-post? make-new-comment))
+  #:export (blob->comment comment-sxml-content comment-timestamp
+            comment-readable-date bad-new-comment-post? make-new-comment))
 
 (define *comment-spec*
   `((timestamp . ,string->number)))
-(define (comment-from-object encoded-name sha1)
+
+(define (blob->comment encoded-name sha1)
   (let ((blob (git "show" sha1)))
     (match-bind
      "\n\n(.*)$" blob (_ content)
-     (fold cons
-           (filter
-            identity
-            (match-lines (substring blob 0 (- (string-length blob)
-                                              (string-length _)))
-                         "^([^: ]+): +(.*)$" (_ k v)
-                         (let* ((k (string->symbol k))
-                                (parse (assq-ref *comment-spec* k)))
-                           (if parse
-                               (catch 'parse-error
-                                      (lambda ()
-                                        (cons k (parse v)))
-                                      (lambda args #f))
-                               (cons k v)))))
-           `((raw-content . ,content)
-             (sha1 . ,sha1)
-             (key . ,encoded-name))))))
+     (append
+      `((raw-content . ,content)
+        (sha1 . ,sha1)
+        (key . ,encoded-name))
+      (match-lines (substring blob 0 (- (string-length blob)
+                                        (string-length _)))
+                   "^([^: ]+): +(.*)$" (_ k v)
+                   (let* ((k (string->symbol k))
+                          (parse (or (assq-ref *comment-spec* k) identity)))
+                     (cons k (parse v))))))))
 
 (define (comment-readable-date comment)
   (let ((date (time-utc->date
@@ -78,117 +72,21 @@
 (define (comment-timestamp comment-alist)
   (or (assq-ref comment-alist 'timestamp) #f))
 
-(define (build-comment-skeleton comments)
-  (fold (lambda (sha1 parent)
-          (let* ((ts (comment-timestamp sha1))
-                 (env (list "GIT_COMMMITTER=tekuti"
-                            (format #f "GIT_COMMITTER_DATE=~a +0100" ts)
-                            (format #f "GIT_AUTHOR_DATE=~a +0100" ts))))
-            (string-trim-both
-             (git* (cons* "commit-tree" sha1 (if parent (list "-p" parent) '()))
-                   #:input "comment\n" #:env env))))
-        #f
-        comments))
-
-(define (emailish? x)
-  (match-bind "^([a-zA-Z0-9.+-]+)@([a-zA-Z0-9-]+\\.)+[a-zA-Z]+$"
-              x (_ . args)
-              x
-              #f))
-
 (define (bad-email? x)
   (if (emailish? x)
       #f
       `(p "Please pretend to specify a valid email address.")))
 
-(define (urlish? x)
-  (match-bind "^https?://([a-zA-Z0-9-]+\\.)+[a-zA-Z]+/[a-zA-Z0-9$_.+!*'(),;/?:@&=-]*$"
-              x (_ . args)
-              x
-              #f))
-
 (define (bad-url? x)
   (if (or (string-null? x) (urlish? x))
       #f
       `(p "Bad URL. (Only http and https are allowed.)")))
 
-(define *allowed-tags*
-  `((a (href . ,urlish?) title)
-    (abbr title)
-    (acronym title)
-    (b)
-    (br)
-    (blockquote (cite . ,urlish?))
-    (code)
-    (em)
-    (i)
-    (p)
-    (pre)
-    (strike)
-    (strong)))
-
-(define (compile-sxslt-rules tags)
-  (define (ok . body)
-    body)
-  (define (compile-attribute-rule rule)
-    (if (symbol? rule)
-        `(,rule . ,ok)
-        `(,(car rule) . ,(lambda (tag text)
-                           (or ((cdr rule) text)
-                               (throw 'bad-attr-value text))
-                           (list tag text)))))
-  `(,@(map (lambda (spec)
-             `(,(car spec)
-               ((@ *preorder*
-                   . ,(let ((rules `((@ (,@(map compile-attribute-rule
-                                                (cdr spec))
-                                         (*text*
-                                          . ,(lambda (tag text) text))
-                                         (*default*
-                                          . ,(lambda (tag . body)
-                                               (throw 'bad-attr tag))))
-                                        . ,ok))))
-                        (lambda tree
-                          (pre-post-order tree rules)))))
-               . ,ok))
-           *allowed-tags*)
-    (*text* . ,(lambda (tag text)
-                 text))
-    (*default* . ,(lambda (tag . body)
-                    (throw 'bad-tag tag)))))
-
-;; could be better, reflect nesting rules...
-(define *valid-xhtml-rules*
-  `((div ,(compile-sxslt-rules *allowed-tags*)
-         . ,(lambda body body))))
-
-(use-modules (sxml transform) (tekuti filters))
-(define (bad-xhtml? x)
-  (catch #t
-         (lambda ()
-           (pre-post-order (wordpress->sxml x) *valid-xhtml-rules*)
-           #f)
-         (lambda (key . args)
-           `(div (p "Invalid XHTML")
-                 ,(case key
-                    ((parser-error)
-                     `(pre ,(with-output-to-string
-                              (lambda () (write args)))))
-                    ((bad-tag)
-                     `(p "XHTML tag disallowed: " ,(symbol->string (car args))))
-                    ((bad-attr)
-                     `(p "XHTML attribute disallowed: " ,(symbol->string (car args))))
-                    ((bad-attr-value)
-                     `(p "XHTML attribute has bad value: " ,(car args)))
-                    (else
-                     (pk key args)
-                     `(p "Jesus knows why, and so do you")))))))
-
 (define *new-comment-spec*
   `(("author" ,(lambda (x) #f))
     ("email" ,bad-email?)
     ("url" ,bad-url?)
-    ("comment" ,bad-xhtml?)
+    ("comment" ,bad-user-submitted-xhtml?)
     ("submit" ,(lambda (x) #f))))
 
 (define (bad-new-comment-post? post-data)
@@ -204,59 +102,6 @@
                 ((cadr pair) (assoc-ref post-data (car pair))))
               *new-comment-spec*)))
 
-(use-modules (srfi srfi-11))
-(define (make-tree-deep treeish add remove change)
-  (define (local? x) (null? (car x)))
-  (define (assert-added-files-not-present names dents)
-    (for-each
-     (lambda (dent)
-       (if (member (car dent) names)
-           (error "file already added" dent)))
-     dents))
-  (define (assert-referenced-files-present names dents)
-    (for-each
-     (lambda (name)
-       (if (not (assoc name dent-names))
-           (error "file already removed" name)))
-     names))
-  (let-values (((dents) (if treeish (git-ls-tree treeish #f) '()))
-               ((ladd dadd) (partition local? add))
-               ((lremove dremove) (partition local? remove))
-               ((lchange dchange) (partition local? change)))
-    (assert-added-files-not-present (map cadr ladd) dents)
-    (assert-referenced-files-present
-     (append (map cdr lremove) (map caar lchange)) dents)
-    ; (trc 'make-tree-deep treeish add remove change)
-    (git-mktree
-     (append
-      (map cdr ladd)
-      (filter-map
-       (lambda (dent)
-         (cond
-          ((member (car dent) (map cdr lremove))
-           #f)
-          ((member (car dent) (map cadr lchange))
-           (cdr lchange))
-          ((and (eq? (caddr dent) 'tree)
-                (member (car dent)
-                        (map caar (append dadd dremove dchange))))
-           (let ((level-down (lambda (x)
-                               (if (equal? (caar x) (car dent))
-                                   (cons (cdar x) (cdr x))
-                                   #f))))
-             (list (car dent)
-                   (make-tree-deep (cadr dent)
-                                   (filter-map level-down dadd)
-                                   (filter-map level-down dremove)
-                                   (filter-map level-down dchange))
-                   'tree)))
-          (else dent)))
-       (append (filter-map (lambda (x)
-                             (and (not (assoc (caar x) dents))
-                                  (list (caar x) #f 'tree)))
-                           dadd)
-               dents))))))
-    
 (define de-newline (s///g "[\n\r]" " "))
 
 (define (make-new-comment post post-data)
@@ -277,13 +122,10 @@
       (git-update-ref
        "refs/heads/master"
        (lambda (master)
-         (git-commit-tree
-          (make-tree-deep master
-                          `(((,(assq-ref post 'key) "comments")
-                             . (,sha1 ,sha1 blob)))
-                          '()
-                          '())
-          master
-          "new comment"
-          #f))
+         (git-commit-tree (munge-tree master
+                                      `(((,(assq-ref post 'key) "comments")
+                                         . (,sha1 ,sha1 blob)))
+                                      '()
+                                      '())
+                          master "new comment" #f))
        5))))

tekuti/filters.scm

@@ -28,7 +28,9 @@
   #:use-module (sxml simple)
   #:use-module (sxml transform)
   #:use-module (match-bind)
-  #:export (wordpress->sxml))
+  #:use-module (tekuti util)
+  #:export (wordpress->sxml
+            *allowed-tags* bad-user-submitted-xhtml?))
 
 (define blocks '(table thead tfoot caption colgroup tbody tr td th div
                  dl dd dt ul ol li pre select form map area blockquote
@@ -76,10 +78,6 @@
         (lp #f (cdr in)
             (cons (car in) (pclose p out))))))))
 
-(wpautop 'div
-         `((b "foo") "\n\n" (b "bar")))
-
-
 (define (wordpress->sxml text)
   (let ((sxml (cadr (with-input-from-string (string-append "<div>" text "</div>")
                       xml->sxml))))
@@ -91,3 +89,75 @@
                            (cons tag body))))
        (*text* . ,(lambda (tag text)
                     text))))))
+
+(define *allowed-tags*
+  `((a (href . ,urlish?) title)
+    (abbr title)
+    (acronym title)
+    (b)
+    (br)
+    (blockquote (cite . ,urlish?))
+    (code)
+    (em)
+    (i)
+    (p)
+    (pre)
+    (strike)
+    (strong)))
+
+(define (compile-sxslt-rules tags)
+  (define (ok . body)
+    body)
+  (define (compile-attribute-rule rule)
+    (if (symbol? rule)
+        `(,rule . ,ok)
+        `(,(car rule) . ,(lambda (tag text)
+                           (or ((cdr rule) text)
+                               (throw 'bad-attr-value text))
+                           (list tag text)))))
+  `(,@(map (lambda (spec)
+             `(,(car spec)
+               ((@ *preorder*
+                   . ,(let ((rules `((@ (,@(map compile-attribute-rule
+                                                (cdr spec))
+                                         (*text*
+                                          . ,(lambda (tag text) text))
+                                         (*default*
+                                          . ,(lambda (tag . body)
+                                               (throw 'bad-attr tag))))
+                                        . ,ok))))
+                        (lambda tree
+                          (pre-post-order tree rules)))))
+               . ,ok))
+           *allowed-tags*)
+    (*text* . ,(lambda (tag text)
+                 text))
+    (*default* . ,(lambda (tag . body)
+                    (throw 'bad-tag tag)))))
+
+;; could be better, reflect nesting rules.
+(define *valid-xhtml-rules*
+  `((div ,(compile-sxslt-rules *allowed-tags*)
+         . ,(lambda body body))))
+
+(define (bad-user-submitted-xhtml? x)
+  (catch #t
+         (lambda ()
+           (pre-post-order (wordpress->sxml x) *valid-xhtml-rules*)
+           #f)
+         (lambda (key . args)
+           `(div (p "Invalid XHTML")
+                 ,(case key
+                    ((parser-error)
+                     `(pre ,(with-output-to-string
+                              (lambda () (write args)))))
+                    ((bad-tag)
+                     `(p "XHTML tag disallowed: " ,(symbol->string (car args))))
+                    ((bad-attr)
+                     `(p "XHTML attribute disallowed: " ,(symbol->string (car args))))
+                    ((bad-attr-value)
+                     `(p "XHTML attribute has bad value: " ,(car args)))
+                    (else
+                     (pk key args)
+                     `(p "Jesus knows why, and so do you")))))))
+

tekuti/git.scm

@@ -20,7 +20,7 @@
 
 ;;; Commentary:
 ;;
-;; This is the main script that will launch tekuti.
+;; Using git's object database as a persistent store.
 ;;
 ;;; Code:
 
@@ -31,20 +31,25 @@
   #:use-module (tekuti config)
   #:use-module (scheme kwargs)
   #:use-module (match-bind)
+  #:use-module ((srfi srfi-1) #:select (filter-map partition))
+  #:use-module (srfi srfi-11) ; let-values
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:export (&git-condition git-condition? git-condition-argv
             git-condition-output git-condition-status false-if-git-error
 
             git git* ensure-git-repo git-ls-tree git-ls-subdirs
-            parse-metadata parse-commit commit-utc-timestamp
-            commit-parents git-mktree git-rev-parse
-            git-hash-object git-update-ref
+            git-mktree git-rev-parse git-hash-object git-update-ref
             git-commit-tree
 
-            with-output-to-blob with-input-from-blob
+            munge-tree parse-commit commit-utc-timestamp
+            
+            with-output-to-blob with-input-from-blob))
 
-            write-indices read-indices))
+
+;;;
+;;; git conditions
+;;;
 
 (define-condition-type &git-condition &condition git-condition?
   (argv git-condition-argv)
@@ -55,6 +60,10 @@
   `(,guard (c ((,git-condition? c) #f))
            ,@body))
 
+;;;
+;;; running git
+;;; 
+
 (define *debug* #f)
 (define (trc . args)
   (if *debug*
@@ -86,17 +95,7 @@
                                (output output)
                                (status ret))))))))
 
-(define (call-with-temp-file contents proc)
-  (let* ((template (string-copy "/tmp/tekutiXXXXXX"))
-         (tmp (mkstemp! template)))
-    (display contents tmp)
-    (close tmp)
-    (unwind-protect
-     (proc template)
-     (delete-file template))))
-
 (define/kwargs (git* args (input #f) (env '()))
-  ;; foolishness regarding env
   (if input
       (call-with-temp-file
        input
@@ -108,6 +107,10 @@
 (define (git . args)
   (git* args))
 
+;;;
+;;; git commands
+;;; 
+
 (define (is-dir? path)
   (catch 'system-error
          (lambda () (eq? (stat:type (stat path)) 'directory))
@@ -137,45 +140,6 @@
                     (cons name object)))
       '()))
 
-(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)))
-    (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)))))
-
-;; fixme: do to commits what i already did to posts
-
-(define (commit-parents commit)
-  (map cdr
-       (filter
-        (lambda (x) (eq? (car x) 'parent))
-        (parse-commit commit))))
-
 (define (git-mktree alist)
   (string-trim-both
    (git* '("mktree")
@@ -197,18 +161,6 @@
   (string-trim-both
    (git* '("hash-object" "-w" "--stdin") #:input contents)))
 
-(define (with-output-to-blob* thunk)
-  (git-hash-object (with-output-to-string thunk)))
-
-(define-macro (with-output-to-blob . forms)
-  `(,with-output-to-blob* (lambda () ,@forms)))
-
-(define (with-input-from-blob* sha1 thunk)
-  (with-input-from-string (git "show" sha1) thunk))
-
-(define-macro (with-input-from-blob sha1 . forms)
-  `(,with-input-from-blob* ,sha1 (lambda () ,@forms)))
-
 (define (git-update-ref refname proc count)
   (let* ((ref (git-rev-parse refname))
          (commit (proc ref)))
@@ -233,5 +185,87 @@
                          (format #f "GIT_AUTHOR_DATE=~a +0100" timestamp))
                    (list "GIT_COMMMITTER=tekuti")))))
 
-;; fixme: map-pairs
+;;; 
+;;; utilities
+;;; 
 
+(define (munge-tree treeish add remove change)
+  (define (local? x) (null? (car x)))
+  (define (assert-added-files-not-present names dents)
+    (for-each
+     (lambda (dent)
+       (if (member (car dent) names)
+           (error "file already added" dent)))
+     dents))
+  (define (assert-referenced-files-present names dents)
+    (for-each
+     (lambda (name)
+       (if (not (assoc name dent-names))
+           (error "file already removed" name)))
+     names))
+  (let-values (((dents) (if treeish (git-ls-tree treeish #f) '()))
+               ((ladd dadd) (partition local? add))
+               ((lremove dremove) (partition local? remove))
+               ((lchange dchange) (partition local? change)))
+    (assert-added-files-not-present (map cadr ladd) dents)
+    (assert-referenced-files-present
+     (append (map cdr lremove) (map caar lchange)) dents)
+    ; (trc 'munge-tree treeish add remove change)
+    (git-mktree
+     (append
+      (map cdr ladd)
+      (filter-map
+       (lambda (dent)
+         (cond
+          ((member (car dent) (map cdr lremove))
+           #f)
+          ((member (car dent) (map cadr lchange))
+           (cdr lchange))
+          ((and (eq? (caddr dent) 'tree)
+                (member (car dent)
+                        (map caar (append dadd dremove dchange))))
+           (let ((level-down (lambda (x)
+                               (if (equal? (caar x) (car dent))
+                                   (cons (cdar x) (cdr x))
+                                   #f))))
+             (list (car dent)
+                   (munge-tree (cadr dent)
+                               (filter-map level-down dadd)
+                               (filter-map level-down dremove)
+                               (filter-map level-down dchange))
+                   'tree)))
+          (else dent)))
+       (append (filter-map (lambda (x)
+                             (and (not (assoc (caar x) dents))
+                                  (list (caar x) #f 'tree)))
+                           dadd)
+               dents))))))
+    
+(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 (with-output-to-blob* thunk)
+  (git-hash-object (with-output-to-string thunk)))
+
+(define-macro (with-output-to-blob . forms)
+  `(,with-output-to-blob* (lambda () ,@forms)))
+
+(define (with-input-from-blob* sha1 thunk)
+  (with-input-from-string (git "show" sha1) thunk))
+
+(define-macro (with-input-from-blob sha1 . forms)
+  `(,with-input-from-blob* ,sha1 (lambda () ,@forms)))

tekuti/page.scm

@@ -32,6 +32,7 @@
   #:use-module (tekuti comment)
   #:use-module (tekuti url)
   #:use-module (tekuti request)
+  #:use-module (tekuti page-helpers)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-19)
   #:use-module (scheme kwargs)
@@ -52,17 +53,9 @@
             page-search 
             page-show-post 
             page-feed-atom
-            page-feed-rss2
             page-debug
             page-not-found))
 
-(define (relurl path)
-  (string-append *public-url-base* path))
-
-(define (rellink path . body)
-  `(a (@ (href ,(relurl path)))
-      ,@body))
-
 (define (make-post-key . parts)
   (url:encode (format #f "~{~a~^/~}" (map url:encode parts))))
 
@@ -73,34 +66,6 @@
                   (p "Path handler not yet implemented: "
                      ,(rref request 'path-str)))))
 
-(define (post-editing-form post)
-  `(form (@ (method "POST")
-            (action ,(string-append *public-url-base* 
-                                    (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 (assq-ref post 'title) "")))))
-         (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)))
-
-(define (with-authentication request thunk)
-  (if (request-authenticated? request)
-      (thunk)
-      (rcons* (rpush 'output-headers
-                     '("WWW-Authenticate" . "Basic realm=\"Tekuti\"")
-                     request)
-              'status 401
-              'body `((p "Authentication required, yo")))))
-
 (define (page-admin request index)
   (with-authentication
    request
@@ -119,24 +84,13 @@
                      (h2 "new post")
                      ,(post-editing-form #f))))))
 
-(define (admin-post-link post)
-  (rellink (string-append "admin/posts/"
-                         (url:encode (assq-ref post 'key)))
-          (assq-ref post 'title)))
-
-(define (post-link post)
-  (rellink (string-append "archives/" (url:decode (assq-ref post 'key)))
-          (assq-ref post 'title)))
-
 (define (page-admin-posts request index)
   (with-authentication
    request
    (lambda ()
      (define (post-headers)
        (map (lambda (post)
-              ;; double-encoding is a hack to trick apache
-              `(h3 ,(rellink (string-append "admin/posts/" (url:encode (assq-ref post 'key)))
-                            (assq-ref post 'title))))
+              `(h3 ,(admin-post-link post)))
             (assq-ref index 'posts)))
      (rcons* request
              'body `((h1 "all your posts are belong to tekuti")
@@ -148,7 +102,7 @@
    (lambda ()
      (let ((post (post-from-key (assq-ref index 'master) key)))
        (rcons* request
-               'body `((h1 ,(assq-ref post 'title))
+               'body `((h1 ,(post-title post))
                        ,(post-editing-form post)))))))
 
 (define (page-admin-new-post request index)
@@ -164,25 +118,6 @@
                        (p "Created new post: " ,(assoc-ref form-data "title"))
                        (pre ,(assoc-ref form-data "body"))))))))
 
-(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))
-          '())))
-
-;;                     (a (@ (href ,new-url)) ,new-url)
-
 (define (page-admin-modify-post request index key)
   (with-authentication
    request
@@ -191,118 +126,46 @@
 (define page-delete-comment not-implemented)
 (define page-delete-post not-implemented)
 
-;; 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 (page-index request index)
   (rcons* request
           'body `(,(main-sidebar request index)
                   ,@(map (lambda (post)
                            (show-post post #f))
-                         (take-max (assq-ref index 'posts) 10)))))
+                         (published-posts index 10)))))
 
 (define (page-show-post request index year month day post)
-  (let ((slug (make-post-key year month day post)))
-    (cond
-     ((false-if-git-error
-       (git-rev-parse (string-append (assq-ref index 'master) ":" slug)))
-      => (lambda (tree)
-           (let ((post (post-from-tree slug tree)))
-             (rcons* request
-                     'title (string-append (assq-ref post 'title)
-                                           " -- " *title*)
-                     'body (show-post post #t)))))
-     (else
-      (page-not-found request index)))))
+  (cond
+   ((post-from-key (assq-ref index 'master)
+                   (make-post-key year month day post))
+    => (lambda (post)
+         (rcons* request
+                 'title (string-append (post-title post) " -- " *title*)
+                 'body (show-post post #t))))
+   (else
+    (page-not-found request index))))
 
-(define (page-new-comment request index year month day post)
-  (let ((slug (make-post-key year month day post))
-        (data (request-form-data request)))
+(define (page-new-comment request index year month day name)
+  (let ((data (request-form-data request)))
     (cond
-     ((false-if-git-error
-       (git-rev-parse (string-append (assq-ref index 'master) ":" slug)))
-      => (lambda (tree)
+     ((post-from-key (assq-ref index 'master)
+                     (make-post-key year month day name))
+      => (lambda (post)
            (cond
             ((bad-new-comment-post? data)
              => (lambda (reason)
-                  (pk reason)
                   (rcons* request
-                          'body `((p "Bad post data: " ,reason)))))
+                          'body `((p "Bad post data: " ,(pk reason))))))
             (else
-             (let ((comment (make-new-comment (post-from-tree slug tree) data)))
+             (let ((comment (make-new-comment post data)))
+               ;; nb: at this point, `post' is out-of-date
                (rcons* request
                        'title "comment posted"
-                       'body `((p "Comment, posted, thanks.")
+                       'body `((p "Comment posted, thanks.")
                                ;; fixme: show the post directly; or a redirect?
-                               (p "Back to the post: "
-                                  ,(rellink (string-append "archives/" (url:decode slug))
-                                            post)))))))))
-     
+                               (p "Back to the post: " ,(post-link post)))))))))
      (else
       (page-not-found request index)))))
 
-(define/kwargs (date-increment date (day 0) (month 0) (year 0))
-  (make-date (date-nanosecond date) (date-second date)
-             (date-minute date) (date-minute date)
-             (+ (date-day date) day) (+ (date-month date) month)
-             (+ (date-year date) year) (date-zone-offset date)))
-
-(define (date-comparator date comp)
-  (let ((this (time-second (date->time-utc date))))
-    (lambda (that)
-      (comp that this))))
-
-(define (date-before? date)
-  (date-comparator date <))
-
-(define (date-after? date)
-  (date-comparator date >))
-
-(define (compose1 proc . procs)
-  (if (null? procs)
-      proc
-      (let ((other (apply compose1 procs)))
-        (lambda (x)
-          (proc (other x))))))
-
 ;; fixme exception handling for input
 (define (page-archives request index year month day)
   (let ((year (and=> year string->number))
@@ -322,7 +185,7 @@
       (define (make-date-header post)
         (lambda (x) #f))
     
-      (let lp ((posts (assq-ref index 'posts)))
+      (let lp ((posts (published-posts index -1)))
         (cond ((or (null? posts) (too-early? (car posts)))
                (rcons* request
                        'title *title*
@@ -362,41 +225,16 @@
 (define page-search not-implemented)
 
 (define (page-not-found request index)
-  (pk request)
-  (rcons* request
+  (rcons* (pk 'not-found request)
           'status 404
           'body `((h1 "Page not found")
                   (p "Unknown path: " ,(rref request 'path-str)))))
 
-(define (page-feed-rss2 request index)
-  (not-implemented request index))
-
-
-(define (rfc822-date->timestamp str)
-  (+ (time-second (date->time-utc
-                   (string->date str "~a, ~d ~b ~Y ~H:~M:~S GMT")))
-     (date-zone-offset (current-date))))
-
-(define (timestamp->atom-date timestamp)
-  (date->string (time-utc->date (make-time time-utc 0 timestamp) 0)
-                "~Y-~m-~dT~H:~M:~SZ"))
-
-(define (timestamp->rfc822-date timestamp)
-  (date->string (time-utc->date (make-time time-utc 0 timestamp) 0)
-                "~a, ~d ~b ~Y ~H:~M:~S GMT"))
-
-(define (request-relurl request)
-  (let ((headers (rref request 'headers)))
-    (let ((server (or (assoc-ref headers "Host")
-                      (assoc-ref headers "server-ip-addr"))))
-      (lambda (tail)
-        (string-append "http://" server "/" tail)))))
-
 (define (page-feed-atom request index)
-  (let ((last-modified (let ((posts (assq-ref index 'posts)))
+  (let ((last-modified (let ((posts (published-posts index 1)))
                          (and (pair? posts)
                               (assq-ref (car posts) 'timestamp))))
-        (relurl (request-relurl request)))
+        (server-name (request-server-name request)))
     (cond
      ((let ((since (assoc-ref (rref request 'headers '())
                               "If-Modified-Since")))
@@ -411,31 +249,8 @@
                      request)
               'doctype ""
               'content-type "application/atom+xml"
-              'sxml `(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"))))
-                      ,@(map
-                         (lambda (post)
-                           `(entry
-                             (author (name ,*name*) (uri ,(relurl "")))
-                             (title (@ (type "text")) ,(assq-ref post 'title))
-                             (id ,(relurl (url:decode (assq-ref post 'key)))) ;hack
-                             (published ,(timestamp->atom-date
-                                          (assq-ref post 'timestamp)))
-                             (updated ,(timestamp->atom-date
-                                        (assq-ref post 'timestamp)))
-                             (content (@ (type "xhtml"))
-                                      (div (@ (xmlns "http://www.w3.org/1999/xhtml"))
-                                           ,(post-sxml-content post)))))
-                         (take-max (assq-ref index 'posts) 10))))))))
+              'sxml (append (atom-header server-name last-modified)
+                            (map
+                             (lambda (post)
+                               (atom-entry server-name post))
+                             (published-posts index 10))))))))

tekuti/post.scm

@@ -35,16 +35,50 @@
   #:use-module (tekuti filters)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
-  #:export (reindex-posts post-from-tree post-from-key post-tags
-                          post-timestamp post-key
-            post-sxml-content post-raw-content all-published-posts
-            post-readable-date post-tag-links post-sxml-n-comments
-            post-sxml-comments))
+  #:export (post-from-tree post-from-key
 
-  
-;; introducing new assumption: post urls like yyyy/dd/mm/post; post dirnames the urlencoded post
+            post-tags post-timestamp post-key post-published?
+            post-sxml-content post-raw-content post-readable-date post-tag-links post-sxml-n-comments
+            post-sxml-comments post-title
+
+            all-published-posts
+
+            reindex-posts))
+
+;;; 
+;;; pulling posts out of git
+;;; 
+
+(define *post-spec*
+  `((timestamp . ,string->number)
+    (tags . ,(lambda (v) (map string-trim-both (string-split v #\,))))
+    (title . ,identity)))
+
+(define (post-from-tree encoded-name sha1)
+  (append `((key . ,encoded-name)
+            (sha1 . ,sha1))
+          (match-lines
+           (git "show" (string-append sha1 ":metadata"))
+           "^([^: ]+): +(.*)$" (_ k v)
+           (let* ((k (string->symbol k))
+                  (parse (or (assq-ref *post-spec* k)
+                             identity)))
+             (cons k (parse v))))))
+
+(define (post-from-key master key . allow-unpublished)
+  (false-if-git-error
+   (let ((pairs (git-ls-subdirs master key)))
+     (and (= (length pairs) 1)
+          (let ((post (post-from-tree key (cdar pairs))))
+            (if (or (post-published? post)
+                    (and (pair? allow-unpublished) (car allow-unpublished)))
+                post
+                #f))))))
+
+;;; 
+;;; accessors
+;;; 
 
-;; perhaps push this processing into post-from-tree
 (define (post-published? post-alist)
   (equal? (assq-ref post-alist 'status) "publish"))
 
@@ -57,16 +91,8 @@
 (define (post-key post)
   (assq-ref post 'key))
 
-(define *post-spec*
-  `((timestamp . ,string->number)
-    (tags . ,(lambda (v) (map string-trim-both (string-split v #\,))))
-    (title . ,identity)))
-
-(define (post-from-tree encoded-name sha1)
-  (acons 'key encoded-name
-         (acons 'sha1 sha1
-                (parse-metadata (string-append sha1 ":metadata")
-                                *post-spec*))))
+(define (post-title post)
+  (assq-ref post 'title))
 
 (define (post-raw-content post)
   (git "show" (string-append (assq-ref post 'sha1) ":content")))
@@ -92,26 +118,10 @@
 (define (post-tag-links post)
   (map tag-link (post-tags post)))
 
-(define (post-from-key master key)
-  (let ((pairs (git-ls-subdirs master key)))
-    (and (= (length pairs) 1)
-         (post-from-tree key (cdar pairs)))))
-
-(define (all-posts master)
-  (map (lambda (pair)
-         (post-from-tree (car pair) (cdr pair)))
-       (git-ls-subdirs master #f)))
-
-(define (all-published-posts master)
-  (dsu-sort
-   (filter post-published? (all-posts master))
-   post-timestamp
-   >))
-
 (define (post-comments post)
   (dsu-sort
    (map (lambda (pair)
-          (comment-from-object (car pair) (cadr pair)))
+          (blob->comment (car pair) (cadr pair)))
         (git-ls-tree (string-append (assq-ref post 'sha1) ":comments") #f))
    comment-timestamp
    <))
@@ -180,6 +190,17 @@
                                     "#comments")))
            "(" ,(post-n-comments post) ")")))
 
+(define (all-posts master)
+  (map (lambda (pair)
+         (post-from-tree (car pair) (cdr pair)))
+       (git-ls-subdirs master #f)))
+
+(define (all-published-posts master)
+  (dsu-sort
+   (filter post-published? (all-posts master))
+   post-timestamp
+   >))
+
 (define (hash-fill proc list)
   (let ((table (make-hash-table)))
     (for-each (lambda (x) (proc x table))

tekuti/request.scm

@@ -34,7 +34,7 @@
   #:use-module (tekuti base64)
   #:export (make-request rcons rcons* rpush rpush* rref let-request
             request-path-case request-authenticated?
-            request-form-data))
+            request-form-data request-server-name))
 
 (define (header-ref headers key default)
   (let ((pair (assoc key headers)))
@@ -189,3 +189,10 @@
     (,let-request ,request (method path)
                   (cons method path))
     ,@clauses))
+
+(define (request-server-name request)
+  (let ((headers (rref request 'headers)))
+    (or (assoc-ref headers "Host")
+        (assoc-ref headers "server-ip-addr"))))
+
+

tekuti/util.scm

@@ -20,18 +20,44 @@
 
 ;;; Commentary:
 ;;
-;; This is the main script that will launch tekuti.
+;; Utility procedures and macros.
 ;;
 ;;; Code:
 
 (define-module (tekuti util)
   #:use-module (match-bind)
+  #:use-module (scheme kwargs)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
   #:export (expanduser match-lines dbg unwind-protect dbg dsu-sort
-            hash-push! list-has-length? list-head-match mapn
+            hash-push! list-has-length? list-head-match mapn filter-mapn
             take-max read-hash write-hash shell:quote
+            call-with-temp-file emailish? urlish?
+            date-increment date-comparator date-before? date-after? compose1
+            rfc822-date->timestamp timestamp->rfc822-date timestamp->atom-date
             list-intersperse with-backtrace with-time-debugging define-memoized))
 
+(define (emailish? x)
+  (match-bind "^([a-zA-Z0-9.+-]+)@([a-zA-Z0-9-]+\\.)+[a-zA-Z]+$"
+              x (_ . args)
+              x
+              #f))
+
+(define (urlish? x)
+  (match-bind "^https?://([a-zA-Z0-9-]+\\.)+[a-zA-Z]+/[a-zA-Z0-9$_.+!*'(),;/?:@&=-]*$"
+              x (_ . args)
+              x
+              #f))
+
+(define (call-with-temp-file contents proc)
+  (let* ((template (string-copy "/tmp/tekutiXXXXXX"))
+         (tmp (mkstemp! template)))
+    (display contents tmp)
+    (close tmp)
+    (unwind-protect
+     (proc template)
+     (delete-file template))))
+
 (define (shell:quote str)
   (with-output-to-string
     (lambda ()
@@ -103,6 +129,16 @@
         (reverse out)
         (lp (cdr in) (cons (proc (car in)) out) (1- n)))))
 
+(define (filter-mapn proc l nmax)
+  (let lp ((in l) (out '()) (n nmax))
+    (if (or (null? in) (zero? n))
+        (reverse out)
+        (let ((val (proc (car in))))
+          (if val
+              (lp (cdr in) (cons val out) (1- n))
+              (lp (cdr in) out n))
+          ))))
+
 (define (list-intersperse src-l elem)
   (if (null? src-l) src-l
       (let loop ((l (cdr src-l)) (dest (cons (car src-l) '())))
@@ -179,3 +215,40 @@
               (read))
     h))
 
+(define/kwargs (date-increment date (day 0) (month 0) (year 0))
+  (make-date (date-nanosecond date) (date-second date)
+             (date-minute date) (date-minute date)
+             (+ (date-day date) day) (+ (date-month date) month)
+             (+ (date-year date) year) (date-zone-offset date)))
+
+(define (date-comparator date comp)
+  (let ((this (time-second (date->time-utc date))))
+    (lambda (that)
+      (comp that this))))
+
+(define (date-before? date)
+  (date-comparator date <))
+
+(define (date-after? date)
+  (date-comparator date >))
+
+(define (compose1 proc . procs)
+  (if (null? procs)
+      proc
+      (let ((other (apply compose1 procs)))
+        (lambda (x)
+          (proc (other x))))))
+
+(define (rfc822-date->timestamp str)
+  (+ (time-second (date->time-utc
+                   (string->date str "~a, ~d ~b ~Y ~H:~M:~S GMT")))
+     (date-zone-offset (current-date))))
+
+(define (timestamp->atom-date timestamp)
+  (date->string (time-utc->date (make-time time-utc 0 timestamp) 0)
+                "~Y-~m-~dT~H:~M:~SZ"))
+
+(define (timestamp->rfc822-date timestamp)
+  (date->string (time-utc->date (make-time time-utc 0 timestamp) 0)
+                "~a, ~d ~b ~Y ~H:~M:~S GMT"))
+