comment deletion, post editing.

* tekuti/comment.scm (make-new-comment): Refactor to decouple comment.scm
  from post.scm.

* tekuti/git.scm (run): Generalize so it can run any executable.
  (git-ls-tree, git-ls-subdirs): Check for a #f treeish, return directly
  in that case, avoiding tracebacks in the forked kid.
  (git-mktree): Return #f if the tree is empty.
  (git-rev-list): New command, something like git log.
  (patch-blob): New function; unused, though. Perhaps I should just
  delete it.
  (git-commit-reverse-operations): New function, constructs munge-tree
  operations to revert a commit.
  (git-revert): New operator, reverts a commit. Can't use git's revert
  because it requires a working tree.
  (munge-tree): Rewrite to unify the various commands, and process the
  commands in order. Makes a bit more garbage, but is much more
  understandable.

* tekuti/page-helpers.scm (post-editing-form): Add a preview.
  (admin-post-url): New helper.
  (redirect): New helper.
  (admin-post-redirect): New helper.

* tekuti/page.scm (page-admin): Show recent changes in the sidebar.
  (page-admin-new-post): Redirect to the new post.
  (page-new-comment): Rework for make-new-comment changes, and redirect
  to the post. Would be nice to redirect to the comment though.
  (page-admin-changes): New page, lists recent changes.
  (page-admin-change): New page, shows a change, allowing it to be
  undone.
  (page-admin-revert-change): New page, actually reverts a change. Thus
  we have comment deletion.

* tekuti/post.scm (munge-post): New helper, factored out of
  make-new-post.
  (parse-post-data): Another new helper. Needs to do more validation,
  though.
  (modify-post): Post editing, yay!

* tekuti/request.scm (parse-www-form-urlencoded): Factored out of
  request-form-data.
  (*request-initializers*): Initialize 'query to have the parsed query
  string data.

* tekuti/url.scm (url:path-part, url:query-part): New somewhat hacky
  functions. url.scm needs some love.
  (url:path-split): Split on only the "path part" of the URL.

* tekuti/util.scm (foldn): New export. Probably a bad idea.
  (match-case): New macro, not used though.
  (string-split/trimming): New util.

* tekuti/web.scm (choose-handler): Update the set of pages.

tekuti/comment.scm

@@ -114,7 +114,7 @@
 
 (define de-newline (s///g "[\n\r]" " "))
 
-(define (make-new-comment post post-data)
+(define (make-new-comment key title post-data)
   (let ((content (assoc-ref post-data "comment"))
         (author (assoc-ref post-data "author"))
         (email (assoc-ref post-data "email"))
@@ -129,15 +129,13 @@
                     (author_url . ,url)))
                  (display "\n")
                  (display content)))
-          (message (format #f "comment on \"~a\" by ~a" (post-title post)
+          (message (format #f "comment on \"~a\" by ~a" title author)))
-                           author)))
       (git-update-ref
        "refs/heads/master"
        (lambda (master)
-         (git-commit-tree (munge-tree master
+         (git-commit-tree (munge-tree1 master
-                                      `(((,(assq-ref post 'key) "comments")
+                                       'create
-                                         . (,sha1 ,sha1 blob)))
+                                       (list key "comments")
-                                      '()
+                                       (list sha1 sha1 'blob))
-                                      '())
                           master message #f))
        5))))

tekuti/git.scm

@@ -33,7 +33,6 @@
   #:use-module (match-bind)
   #:use-module ((srfi srfi-1) #:select (filter-map partition
                                         delete-duplicates))
-  #: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
@@ -41,9 +40,9 @@
 
             git git* ensure-git-repo git-ls-tree git-ls-subdirs
             git-mktree git-rev-parse git-hash-object git-update-ref
-            git-commit-tree
+            git-commit-tree git-rev-list git-revert
 
-            munge-tree parse-commit commit-utc-timestamp
+            munge-tree munge-tree1 parse-commit commit-utc-timestamp
             
             with-output-to-blob with-input-from-blob))
 
@@ -71,20 +70,18 @@
       (apply pk args)
       (car (last-pair args))))
 
-(define (run-git env input-file args)
+(define (run env input-file args)
   (define (prepend-env args)
     (if (null? env)
         args
         (cons "/usr/bin/env" (append env args))))
-  (define (prepend-git args)
-    (cons* *git* "--bare" args))
   (define (redirect-input args)
     (if input-file
         (list "/bin/sh" "-c"
               (string-append (string-join (map shell:quote args) " ")
                              "<" input-file))
         args))
-  (let* ((real-args (trc (redirect-input (prepend-env (prepend-git args)))))
+  (let* ((real-args (trc (redirect-input (prepend-env args))))
          (pipe (apply open-pipe* OPEN_READ real-args))
          (output (read-delimited "" pipe))
          (ret (close-pipe pipe)))
@@ -102,8 +99,8 @@
        input
        (lambda (tempname)
          (trc input)
-         (run-git env tempname args)))
+         (run env tempname (cons* *git* "--bare" args))))
-      (run-git env #f args)))
+      (run env #f (cons* *git* "--bare" args))))
 
 (define (git . args)
   (git* args))
@@ -127,21 +124,25 @@
         (chdir d))))
 
 (define (git-ls-tree treeish path)
-  (or (false-if-git-error
+  (or (and treeish
+           (false-if-git-error
             (match-lines (git "ls-tree" treeish (or path "."))
                          "^(.+) (.+) (.+)\t(.+)$" (_ mode type object name)
                          ;; reversed for assoc
-                    (list name object (string->symbol type))))
+                         (list name object (string->symbol type)))))
       '()))
 
 (define (git-ls-subdirs treeish path)
-  (or (false-if-git-error
+  (or (and treeish
+           (false-if-git-error
             (match-lines (git "ls-tree" treeish (or path "."))
                          "^(.+) tree (.+)\t(.+)$" (_ mode object name)
-                    (cons name object)))
+                         (cons name object))))
       '()))
 
 (define (git-mktree alist)
+  (if (null? alist)
+      #f
       (string-trim-both
        (git* '("mktree")
              #:input (string-join
@@ -153,11 +154,29 @@
                                          "040000 tree ~a\t~a")
                                      (cadr l) (car l)))
                            alist)
-                  "\n" 'suffix))))
+                      "\n" 'suffix)))))
 
 (define (git-rev-parse rev)
   (string-trim-both (git "rev-parse" rev)))
 
+(define (git-rev-list rev n)
+  (let lp ((lines (string-split
+                   (git "rev-list" "--pretty=format:%ct %s"
+                        "-n" (number->string n) rev) #\newline))
+           (ret '()))
+    (if (or (null? lines)
+            (and (null? (cdr lines)) (string-null? (car lines))))
+        (reverse ret)
+        (lp (cddr lines)
+            (let ((line1 (car lines)) (line2 (cadr lines)))
+              (match-bind
+               "^commit (.*)$" line1 (_ sha1)
+               (match-bind
+                "^([0-9]+) (.*)$" line2 (_ ts subject)
+                (cons `(,sha1 ,(string->number ts) ,subject) ret)
+                (error "bad line2" line2))
+               (error "bad line1" line1)))))))
+
 (define (git-hash-object contents)
   (string-trim-both
    (git* '("hash-object" "-w" "--stdin") #:input contents)))
@@ -190,58 +209,106 @@
 ;;; utilities
 ;;; 
 
-(define (munge-tree treeish add remove change)
+;; unused.
-  (define (local? x) (null? (car x)))
+(define (patch-blob sha1 patch)
-  (define (assert-added-files-not-present names dents)
+  (call-with-temp-file
-    (for-each
+   (git "cat-file" "blob" sha1)
-     (lambda (dent)
+   (lambda (orig)
-       (if (member (car dent) names)
+     (run '() patch (list "patch" "-N" "-s" "-u" "-r" "/dev/null" orig))
-           (error "file already added" dent)))
+     (with-output-to-blob
-     dents))
+       (display
-  (define (assert-referenced-files-present names dents)
+        (call-with-input-file (orig)
-    (for-each
+          (read-delimited "" port)))))))
-     (lambda (name)
+
-       (if (not (assoc name dent-names))
+;; could leave stray comments if the post directory changes. but this is
-           (error "file already removed" name)))
+;; probably the best that we can do, given that git does not track
-     names))
+;; directory renames.
-  (let-values (((dents) (if treeish (git-ls-tree treeish #f) '()))
+(define (git-commit-reverse-operations sha1)
-               ((ladd dadd) (partition local? add))
+  (with-input-from-string (git "diff-tree" "-R" "-r" sha1)
-               ((lremove dremove) (partition local? remove))
+    (lambda ()
-               ((lchange dchange) (partition local? change)))
+      (read-line) ;; throw away the header
-    (assert-added-files-not-present (map cadr ladd) dents)
+      (let lp ((ops '()))
-    (assert-referenced-files-present
+        (let ((line (read-line)))
-     (append (map cdr lremove) (map caar lchange)) dents)
+          (if (eof-object? line)
-    ; (trc 'munge-tree treeish add remove change)
+              ops
+              (match-bind
+               "^:([0-9]+) ([0-9]+) ([0-9a-f]+) ([0-9a-f]+) (.)\t(.*)$"
+               line (_ mode1 mode2 ob1 ob2 op path)
+               (let ((head (let ((d (dirname path)))
+                                  (if (string=? d ".") '()
+                                      (string-split d #\/))))
+                     (tail (basename path)))
+                 (lp
+                  (case (string-ref op 0)
+                    ((#\D) (cons `(delete ,head (,tail))
+                                 ops))
+                    ((#\A) (cons `(create ,head (,tail ,ob2 blob))
+                                 ops))
+                    ((#\M) (cons* `(delete ,head (,tail))
+                                  `(create ,head (,tail ,ob2 blob))
+                                  ops)))))
+               (error "crack line" line))))))))
+
+(define (git-revert ref sha1)
+  (let ((ops (git-commit-reverse-operations sha1)))
+    (git-update-ref ref
+                    (lambda (master)
+                      (git-commit-tree (munge-tree master ops)
+                                       master "revert change" #f))
+                    5)))
+
+(define (munge-tree1-local dents command arg)
+  (define (command-error why)
+    (error "munge-tree1-local error" why command arg))
+  (let ((dent (assoc (car arg) dents)))
     (git-mktree
-     (append
+     (case command
-      (map cdr ladd)
+       ((create) (if dent
-      (filter-map
+                     (command-error 'file-present)
-       (lambda (dent)
+                     (cons arg dents)))
-         (cond
+       ((delete) (if dent
-          ((member (car dent) (map cdr lremove))
+                     (delq dent dents)
-           #f)
+                     (command-error 'file-not-present)))
-          ((member (car dent) (map cadr lchange))
+       ((rename) (if dent
-           (cdr lchange))
+                     (acons (cadr arg) (cdr dent) (delq dent dents))
-          ((and (eq? (caddr dent) 'tree)
+                     (command-error 'file-not-present)))
-                (member (car dent)
+       (else (command-error 'unrecognized))))))
-                        (map caar (append dadd dremove dchange))))
+
-           (let ((level-down (lambda (x)
+(define (munge-tree1-recursive dents command ldir rdir arg)
-                               (if (equal? (caar x) (car dent))
+  (define (command-error why)
-                                   (cons (cdar x) (cdr x))
+    (error "munge-tree1-recursive error" why command dir arg))
-                                   #f))))
+  (let ((dent (assoc ldir dents)))
-             (list (car dent)
+    (if (and dent (not (eq? (caddr dent) 'tree)))
-                   (munge-tree (cadr dent)
+        (command-error 'not-a-tree))
-                               (filter-map level-down dadd)
+    (let ((subtree (and=> dent cadr))
-                               (filter-map level-down dremove)
+          (other-dents (if dent (delq dent dents) dents)))
-                               (filter-map level-down dchange))
+      (let ((new (case command
-                   'tree)))
+                   ((create)
-          (else dent)))
+                    (munge-tree1 subtree command rdir arg))
-       (append (delete-duplicates
+                   ((delete rename)
-                (filter-map (lambda (x)
+                    (if subtree
-                              (and (not (assoc (caar x) dents))
+                        (munge-tree1 subtree command rdir arg)
-                                   (list (caar x) #f 'tree)))
+                        (command-error 'file-not-present)))
-                            dadd))
+                   (else (command-error 'unrecognized)))))
-               dents))))))
+        (git-mktree (if new
+                        (cons (list ldir new 'tree) other-dents)
+                        other-dents))))))
+
+(define (munge-tree1 treeish command dir arg)
+  (let ((dents (git-ls-tree treeish #f)))
+    (if (null? dir)
+        (munge-tree1-local dents command arg)
+        (munge-tree1-recursive dents command (car dir) (cdr dir) arg))))
+
+;; (munge-tree sha1 ((create (key comments) (name sha1 blob))
+;;                   (delete (foo bar) (name))
+;;                   (rename (baz borky) (from to))))
+(define (munge-tree treeish operations)
+  (if (null? operations)
+      treeish
+      (let ((op (car operations)))
+        (munge-tree (munge-tree1 treeish (car op) (cadr op) (caddr op))
+                    (cdr operations)))))
 
 (define (parse-commit commit)
   (let ((text (git "cat-file" "commit" commit)))

tekuti/mod-lisp.scm

@@ -109,7 +109,7 @@
          (fd (car pair))
          (sockaddr (cdr pair))
          (new-index (maybe-reindex index)))
-    (connection-received (car pair) (cdr pair) (cdr new-index))
+    (connection-received fd sockaddr (cdr new-index))
     (inner-loop socket new-index)))
 
 (define (event-loop)

tekuti/page-helpers.scm

@@ -34,11 +34,11 @@
   #:use-module (tekuti request)
   #:use-module (srfi srfi-19)
   #:use-module (scheme kwargs)
-  #:export (relurl rellink
+  #:export (relurl rellink redirect post-url
             published-posts
             post-editing-form
             sidebar-ul main-sidebar tag-cloud
-            post-link admin-post-link
+            post-link admin-post-link admin-post-redirect
             show-post with-authentication
             atom-header atom-entry))
 
@@ -56,7 +56,8 @@
                n))
 
 (define (post-editing-form post)
-  `(form (@ (method "POST")
+  `(div
+    (form (@ (method "POST")
              (action ,(relurl (if post
                                   (string-append "admin/modify-post/"
                                                  (url:encode (post-key post)))
@@ -73,23 +74,29 @@
                        (value ,(if (and=> post post-published?)
                                    (timestamp->rfc822-date (post-timestamp post))
                                    ""))))
-            (label (@ (for "date")) " <- date"))
+             (label (@ (for "date")) " <- date (empty == now)"))
           (div (textarea (@ (name "body") (rows "20") (cols "60"))
                          ,(if post (post-raw-content post) "")))
           (input (@ (type "submit") (name "status")
                     (value "publish")))
           " "
           (input (@ (type "submit") (name "status")
-                   (value "draft")))))
+                    (value "draft"))))
+    ,@(if post
+          `((h2 "preview")
+            ,(show-post post #f))
+          '())))
 
 (define (sidebar-ul body)
   `(div (@ (id "menu"))
         (ul ,@body)))
 
 ;; double-encoding is a hack to trick apache
+(define (admin-post-url post)
+  (relurl "admin/posts/" (url:encode (post-key post))))
+
 (define (admin-post-link post)
-  (rellink (string-append "admin/posts/" (url:encode (post-key post)))
+  `(a (@ (href ,(admin-post-url post))) ,(post-title post)))
-           (post-title post)))
 
 (define (post-url post . tail)
   (apply relurl "archives/" (url:decode (post-key post)) tail))
@@ -162,6 +169,13 @@
           (list (post-sxml-comments post))
           '())))
 
+(define (redirect request location)
+  (rpush 'output-headers (cons "Location" location)
+         (rcons 'status 302 request)))
+
+(define (admin-post-redirect request post)
+  (redirect request (admin-post-url post)))
+
 ;; fixme: borks in the no-tags case; ugly code
 (define (tag-cloud index)
   (define (determine-sizes counts)

tekuti/page.scm

@@ -41,8 +41,9 @@
             page-admin-post
             page-admin-new-post
             page-admin-modify-post 
-            page-admin-delete-comment 
+            page-admin-changes 
-            page-admin-delete-post 
+            page-admin-change
+            page-admin-revert-change
             page-index 
             page-show-post 
             page-new-comment
@@ -76,11 +77,16 @@
                `(li ,(admin-post-link post)))
              (assq-ref index 'posts)
              n))
+     (define (recent-changes n)
+       (map (lambda (rev)
+              `(li ,(rellink (string-append "admin/changes/" (car rev))
+                             (caddr rev))))
+            (git-rev-list "refs/heads/master" n)))
      (rcons* request
              'body `(,(sidebar-ul `((li (h2 "posts " ,(rellink "admin/posts" ">>"))
                                         (ul ,@(post-links 5)))
-                                    (li (h2 "recent comments")
+                                    (li (h2 "changes" ,(rellink "admin/changes" ">>"))
-                                        (p "ain't got none"))))
+                                        (ul ,(recent-changes 5)))))
                      (h2 "new post")
                      ,(post-editing-form #f))))))
 
@@ -110,23 +116,60 @@
    request
    (lambda ()
      (let ((post (make-new-post (request-form-data request))))
-       (rcons* request
+       (rcons* (admin-post-redirect request post)
-               'status 201              ; created
+               'body `((p "redirecting...")))))))
-               ;; perhaps set Location:
-               'body `((h1 ,(post-title post))
-                       ,(post-editing-form post)))))))
 
 (define (page-admin-modify-post request index key)
   (with-authentication
    request
    (lambda ()
      (let ((post (modify-post key (request-form-data request))))
-       (rcons* 'status 303
+       (rcons* (admin-post-redirect request post)
-               'body `((h1 ,(post-title post))
+               'body `((p "redirecting...")))))))
-                       ,(post-editing-form post)))))))
      
-(define page-delete-comment not-implemented)
+(define (page-admin-changes request index) 
-(define page-delete-post not-implemented)
+  (with-authentication
+   request
+   (lambda ()
+     (let ((revs (git-rev-list (or (assoc-ref (rref request 'query '())
+                                              "start")
+                                   "refs/heads/master")
+                               10)))
+       (rcons* request
+               'body `((h2 "recent changes")
+                       ,@(map (lambda (rev)
+                                `(div (h3 ,(rellink (string-append "admin/changes/"
+                                                                   (car rev))
+                                                    (caddr rev)))
+                                      ,(timestamp->rfc822-date (cadr rev))))
+                              revs)
+                       (h3 ,(rellink (string-append "admin/changes/?start=" (caar (last-pair revs)))
+                                     "more" ))))))))
+
+(define (page-admin-change request index sha1) 
+  (with-authentication
+   request
+   (lambda ()
+     (let ((commit (parse-commit sha1)))
+       (rcons* request
+               'body `((h2 ,(assq-ref commit 'message))
+                       (p "Committed on "
+                          ,(timestamp->rfc822-date
+                            ;; needlessly goes to git again...
+                            (commit-utc-timestamp sha1)))
+                       (pre ,(git "diff-tree" "-M" "-p" sha1))
+                       (form (@ (action ,(relurl "admin/revert-change/" sha1))
+                                (method "POST"))
+                             (input (@ (type "submit") (value "Undo this change"))))))))))
+
+
+(define (page-admin-revert-change request index sha1)
+  (with-authentication
+   request
+   (lambda ()
+     (let ((new-master (git-revert "refs/heads/master" sha1)))
+       (rcons* (redirect request (relurl "admin"))
+               'body `((h3 "Change reverted")))))))
 
 (define (page-index request index)
   (rcons* request
@@ -158,13 +201,12 @@
                   (rcons* request
                           'body `((p "Bad post data: " ,(pk reason))))))
             (else
-             (let ((comment (make-new-comment post data)))
+             (let ((comment (make-new-comment (post-key post) (post-title post)
+                                              data)))
                ;; nb: at this point, `post' is out-of-date
-               (rcons* request
+               (rcons* (redirect request (post-url post "#comments"))
                        '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: " ,(post-link post)))))))))
      (else
       (page-not-found request index)))))
 

tekuti/post.scm

@@ -43,7 +43,7 @@
             post-raw-content
             post-title
 
-            make-new-post
+            make-new-post modify-post
 
             all-published-posts
 
@@ -55,7 +55,7 @@
 
 (define *post-spec*
   `((timestamp . ,string->number)
-    (tags . ,(lambda (v) (map string-trim-both (string-split v #\,))))
+    (tags . ,(lambda (v) (string-split/trimming v #\,)))
     (title . ,identity)))
 
 (define (post-from-tree encoded-name sha1)
@@ -127,56 +127,73 @@
 (define (post-n-comments post)
   (length (git-ls-tree (string-append (assq-ref post 'sha1) ":comments") #f)))
 
-(define (string-split/trimming string delimiter)
+(define (munge-post old-key parsed)
-  (map string-trim-both (string-split string delimiter)))
+  (let ((metadata (with-output-to-blob
+                   (for-each
+                    (lambda (k)
+                      (format #t "~a: ~a\n" k (assq-ref parsed k)))
+                    '(timestamp tags status title name))))
+        (content (with-output-to-blob (display (assq-ref parsed 'body))))
+        (key (assq-ref parsed 'key))
+        (message (format #f "~a: \"~a\"" 
+                         (if old-key "post modified" "new post")
+                         (assq-ref parsed 'title))))
+    (define (maybe-rename ops)
+      (if (and old-key (not (equal? old-key key)))
+          (cons `(rename () (,old-key ,key)) ops)
+          ops))
+    (define (maybe-clear ops)
+      (if old-key
+          (append `((delete (,key) ("content"))
+                    (delete (,key) ("metadata")))
+                  ops)
+          ops))
+    (let ((ops (maybe-rename
+                (maybe-clear
+                 `((create (,key) ("metadata" ,metadata blob))
+                   (create (,key) ("content" ,content blob)))))))
+      (post-from-key
+       (git-update-ref "refs/heads/master"
+                       (lambda (master)
+                         (git-commit-tree (munge-tree master ops)
+                                          master message #f))
+                       5)
+       key #t))))
 
-(define space-to-dash (s///g " +" "-"))
+(define space-to-dash (s///g " " "-"))
 (define remove-extraneous (s///g "[^a-z-]+" ""))
+(define collapse (s///g "-+" "-"))
 
 (define (title->name title)
-  (remove-extraneous (space-to-dash (string-downcase title))))
+  (collapse (remove-extraneous (space-to-dash (string-downcase title)))))
 
 ;; some verification necessary...
-(define (make-new-post post-data)
+(define (parse-post-data post-data)
-  (define (make-post-key date name)
-    (url:encode (string-append (date->string date "~Y/~m/~d/")
-                               (url:encode name))))
   (let ((title (assoc-ref post-data "title"))
         (body (assoc-ref post-data "body"))
         (tags (assoc-ref post-data "tags"))
-        (date (assoc-ref post-data "date"))
+        (status (assoc-ref post-data "status"))
-        (status (assoc-ref post-data "status")))
+        (date-str (assoc-ref post-data "date")))
-    (let ((timestamp (if (string-null? date)
+    (let ((timestamp (if (string-null? date-str)
                          (time-second (current-time))
-                         (rfc822-date->timestamp date))))
+                         (rfc822-date->timestamp date)))
-      (let ((metadata (with-output-to-blob
+          (name (title->name title)))
-                       (for-each
+      `((title . ,title)
-                        (lambda (pair)
+        (body . ,body)
-                          (format #t "~a: ~a\n" (car pair) (cdr pair)))
-                        `((timestamp . ,timestamp)
         (tags . ,tags)
         (status . ,status)
-                          (title . ,title)
+        (timestamp . ,timestamp)
-                          (name . ,(title->name title))))))
+        (name . ,name)
-            (content (with-output-to-blob (display body)))
+        (key . ,(url:encode
-            (key (make-post-key (timestamp->date timestamp)
+                 (string-append (date->string (timestamp->date timestamp)
-                                (title->name title)))
+                                              "~Y/~m/~d/")
-            (message (format #f "new post: \"~a\"" title)))
+                                (url:encode name))))))))
-        (post-from-key
+
-         (git-update-ref
+(define (make-new-post post-data)
-          "refs/heads/master"
+  (munge-post #f (parse-post-data post-data)))
-          (lambda (master)
+
-            (git-commit-tree (munge-tree master
+(define (modify-post old-key post-data)
-                                         `(((,key)
+  (munge-post old-key (parse-post-data post-data)))
-                                            . ("metadata" ,metadata blob))
-                                           ((,key)
-                                            . ("content" ,content blob)))
-                                         '()
-                                         '())
-                             master message #f))
-          5)
-         key
-         #t)))))
 
 (define (all-posts master)
   (map (lambda (pair)

tekuti/request.scm

@@ -42,6 +42,16 @@
         (cdr pair)
         default)))
 
+(define (parse-www-form-urlencoded str)
+  (map
+   (lambda (piece)
+     (let ((equals (string-index piece #\=)))
+       (if equals
+           (cons (url:decode (substring piece 0 equals))
+                 (url:decode (substring piece (1+ equals))))
+           (cons (url:decode piece) ""))))
+   (string-split str #\&)))
+
 (define *request-initializers*
   `((path . ,(lambda (r)
                (let ((private-url-path (url:path-split *private-url-base*))
@@ -54,6 +64,11 @@
                    tail))))
     (path-str . ,(lambda (r)
                    (url:path-join (rref r 'path '()))))
+    (query . ,(lambda (r)
+                (or (and=> (url:query-part
+                            (header-ref (rref r 'headers '()) "url" ""))
+                           parse-www-form-urlencoded)
+                    '())))
     (method . ,(lambda (r)
                  (header-ref (rref r 'headers '()) "method" "GET")))))
 
@@ -64,14 +79,7 @@
         (let ((content-type (assoc-ref headers "content-type")))
           (cond
            ((equal? content-type "application/x-www-form-urlencoded")
-            (map
+            (parse-www-form-urlencoded post-data))
-             (lambda (piece)
-               (let ((equals (string-index piece #\=)))
-                 (if equals
-                     (cons (url:decode (substring piece 0 equals))
-                           (url:decode (substring piece (1+ equals))))
-                     (cons (url:decode piece) ""))))
-             (string-split post-data #\&)))
            (else
             (error "bad content-type" content-type)))))))
 
@@ -172,13 +180,6 @@
     `(let ((,path-var ,path))
        (cond ,@(map process-clause clauses)))))
 
-(define (foldn kons n knil values)
-  (if (null? values)
-      knil
-      (foldn kons n
-             (apply kons knil (list-head values n))
-             (list-tail values n))))
-
 (define (rcons*-fold request . keys-and-procs)
   (foldn (lambda (request k proc)
            (rcons k (proc request) request))

tekuti/url.scm

@@ -170,9 +170,16 @@
       (char-numeric? ch)
       (memv ch special-chars)))
 
+(define-public (url:path-part path)
+  (substring path 0 (or (string-index path #\?) (string-length path))))
+
+(define-public (url:query-part path)
+  (let ((q (string-index path #\?)))
+    (if q (substring path (1+ q)) #f)))
+
 (define-public (url:path-split path)
   (filter (lambda (x) (not (string-null? x)))
-          (map url:decode (string-split path #\/))))
+          (map url:decode (string-split (url:path-part path) #\/))))
 
 (define-public (url:path-join path)
   (string-join (map url:encode path) "/"))

tekuti/util.scm

@@ -31,11 +31,11 @@
   #:use-module (srfi srfi-19)
   #:export (expanduser match-lines dbg unwind-protect dbg dsu-sort
             hash-push! list-has-length? list-head-match mapn filter-mapn
-            take-max read-hash write-hash shell:quote
+            take-max read-hash write-hash shell:quote foldn
             call-with-temp-file emailish? urlish?
             date-increment date-comparator date-before? date-after? compose1
             rfc822-date->timestamp timestamp->rfc822-date timestamp->atom-date
-            timestamp->date
+            timestamp->date string-split/trimming
             list-intersperse with-backtrace with-time-debugging define-memoized))
 
 (define (emailish? x)
@@ -50,6 +50,14 @@
               x
               #f))
 
+;; bad name relative to mapn...
+(define (foldn kons n knil values)
+  (if (null? values)
+      knil
+      (foldn kons n
+             (apply kons knil (list-head values n))
+             (list-tail values n))))
+
 (define (call-with-temp-file contents proc)
   (let* ((template (string-copy "/tmp/tekutiXXXXXX"))
          (tmp (mkstemp! template)))
@@ -88,6 +96,20 @@
                     ,seed))
       '() (string-split ,string #\newline))))
 
+;; clause := ((pat args) body...)
+(define-macro (match-case string . clauses)
+  (let ((str (gensym)))
+    `(let ((,str ,string))
+       ,(let lp ((in clauses))
+          (let ((clause (car in)))
+            (if (eq? (car clause) 'else)
+                `(begin ,@(cdr clause))
+                `(match-bind ,(caar clause) ,str ,(cadar clause)
+                             (begin ,@(cdr clause))
+                             ,(if (null? (cdr in))
+                                  #f
+                                  (lp (cdr in))))))))))
+
 (define (dbg fmt . args)
   (apply format (current-error-port) fmt args))
 
@@ -240,6 +262,9 @@
         (lambda (x)
           (proc (other x))))))
 
+(define (string-split/trimming string delimiter)
+  (map string-trim-both (string-split string delimiter)))
+
 (define (rfc822-date->timestamp str)
   (+ (time-second (date->time-utc
                    (string->date str "~a, ~d ~b ~Y ~H:~M:~S GMT")))

tekuti/web.scm

@@ -94,9 +94,9 @@
    ;; would be fine to have e.g. (DELETE admin posts posts-key!), but
    ;; web browsers don't handle that
    ((POST admin modify-post post-key!) page-admin-modify-post)
-   ((POST admin delete-comment comment-key!) page-admin-delete-comment)
+   ((GET admin changes) page-admin-changes)
-   ((POST admin delete-post post-key!) page-admin-delete-post)
+   ((GET admin changes sha1!) page-admin-change)
-    
+   ((POST admin revert-change sha1!) page-admin-revert-change)
    ((GET) page-index)
    ((GET archives year? month? day?) page-archives)
    ((GET archives year! month! day! post!) page-show-post)