aliens/tekuti
1
0
Fork 0
Code Activity

comment deletion, post editing.

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2008-03-07 13:09:47 +01:00
parent 579a5d7ae4
commit c0f32d5484
10 changed files with 373 additions and 202 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
tekuti/comment.scm
View file

@ -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)
author)))
(message (format #f "comment on \"~a\" by ~a" title author)))
(git-update-ref
"refs/heads/master"
(lambda (master)
(git-commit-tree (munge-tree master
`(((,(assq-ref post 'key) "comments")
. (,sha1 ,sha1 blob)))
'()
'())
(git-commit-tree (munge-tree1 master
'create
(list key "comments")
(list sha1 sha1 'blob))
master message #f))
5))))

197
tekuti/git.scm
View file

@ -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-git env #f args)))
(run env tempname (cons* *git* "--bare" 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)
(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)
;; unused.
(define (patch-blob sha1 patch)
(call-with-temp-file
(git "cat-file" "blob" sha1)
(lambda (orig)
(run '() patch (list "patch" "-N" "-s" "-u" "-r" "/dev/null" orig))
(with-output-to-blob
(display
(call-with-input-file (orig)
(read-delimited "" port)))))))
;; could leave stray comments if the post directory changes. but this is
;; probably the best that we can do, given that git does not track
;; directory renames.
(define (git-commit-reverse-operations sha1)
(with-input-from-string (git "diff-tree" "-R" "-r" sha1)
(lambda ()
(read-line) ;; throw away the header
(let lp ((ops '()))
(let ((line (read-line)))
(if (eof-object? line)
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
(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 (delete-duplicates
(filter-map (lambda (x)
(and (not (assoc (caar x) dents))
(list (caar x) #f 'tree)))
dadd))
dents))))))
(case command
((create) (if dent
(command-error 'file-present)
(cons arg dents)))
((delete) (if dent
(delq dent dents)
(command-error 'file-not-present)))
((rename) (if dent
(acons (cadr arg) (cdr dent) (delq dent dents))
(command-error 'file-not-present)))
(else (command-error 'unrecognized))))))
(define (munge-tree1-recursive dents command ldir rdir arg)
(define (command-error why)
(error "munge-tree1-recursive error" why command dir arg))
(let ((dent (assoc ldir dents)))
(if (and dent (not (eq? (caddr dent) 'tree)))
(command-error 'not-a-tree))
(let ((subtree (and=> dent cadr))
(other-dents (if dent (delq dent dents) dents)))
(let ((new (case command
((create)
(munge-tree1 subtree command rdir arg))
((delete rename)
(if subtree
(munge-tree1 subtree command rdir arg)
(command-error 'file-not-present)))
(else (command-error 'unrecognized)))))
(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)))

2
tekuti/mod-lisp.scm
View file

@ -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)

28
tekuti/page-helpers.scm
View file

@ -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)))
(post-title post)))
`(a (@ (href ,(admin-post-url 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)

80
tekuti/page.scm
View file

@ -41,8 +41,9 @@
page-admin-post
page-admin-new-post
page-admin-modify-post
page-admin-delete-comment
page-admin-delete-post
page-admin-changes
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")
(p "ain't got none"))))
(li (h2 "changes" ,(rellink "admin/changes" ">>"))
(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
'status 201 ; created
;; perhaps set Location:
'body `((h1 ,(post-title post))
,(post-editing-form post)))))))
(rcons* (admin-post-redirect request post)
'body `((p "redirecting...")))))))
(define (page-admin-modify-post request index key)
(with-authentication
request
(lambda ()
(let ((post (modify-post key (request-form-data request))))
(rcons* 'status 303
'body `((h1 ,(post-title post))
,(post-editing-form post)))))))
(rcons* (admin-post-redirect request post)
'body `((p "redirecting...")))))))
(define page-delete-comment not-implemented)
(define page-delete-post not-implemented)
(define (page-admin-changes request index)
(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.")
;; fixme: show the post directly; or a redirect?
(p "Back to the post: " ,(post-link post)))))))))
'body `((p "Comment posted, thanks."))))))))
(else
(page-not-found request index)))))

97
tekuti/post.scm
View file

@ -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)
(map string-trim-both (string-split string delimiter)))
(define (munge-post old-key parsed)
(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 (make-post-key date name)
(url:encode (string-append (date->string date "~Y/~m/~d/")
(url:encode name))))
(define (parse-post-data post-data)
(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")))
(let ((timestamp (if (string-null? date)
(status (assoc-ref post-data "status"))
(date-str (assoc-ref post-data "date")))
(let ((timestamp (if (string-null? date-str)
(time-second (current-time))
(rfc822-date->timestamp date))))
(let ((metadata (with-output-to-blob
(for-each
(lambda (pair)
(format #t "~a: ~a\n" (car pair) (cdr pair)))
`((timestamp . ,timestamp)
(rfc822-date->timestamp date)))
(name (title->name title)))
`((title . ,title)
(body . ,body)
(tags . ,tags)
(status . ,status)
(title . ,title)
(name . ,(title->name title))))))
(content (with-output-to-blob (display body)))
(key (make-post-key (timestamp->date timestamp)
(title->name title)))
(message (format #f "new post: \"~a\"" title)))
(post-from-key
(git-update-ref
"refs/heads/master"
(lambda (master)
(git-commit-tree (munge-tree master
`(((,key)
. ("metadata" ,metadata blob))
((,key)
. ("content" ,content blob)))
'()
'())
master message #f))
5)
key
#t)))))
(timestamp . ,timestamp)
(name . ,name)
(key . ,(url:encode
(string-append (date->string (timestamp->date timestamp)
"~Y/~m/~d/")
(url:encode name))))))))
(define (make-new-post post-data)
(munge-post #f (parse-post-data post-data)))
(define (modify-post old-key post-data)
(munge-post old-key (parse-post-data post-data)))
(define (all-posts master)
(map (lambda (pair)

31
tekuti/request.scm
View file

@ -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
(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 #\&)))
(parse-www-form-urlencoded 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))

9
tekuti/url.scm
View file

@ -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) "/"))

29
tekuti/util.scm
View file

@ -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")))

6
tekuti/web.scm
View file

@ -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)
((POST admin delete-post post-key!) page-admin-delete-post)
((GET admin changes) page-admin-changes)
((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)