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.
This commit is contained in:
Andy Wingo
parent
579a5d7ae4
commit
c0f32d5484
10 changed files with 373 additions and 202 deletions
|
|
@ -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))))
|
||||
|
|
|
|||
231
tekuti/git.scm
231
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-git env #f args)))
|
||||
(run env tempname (cons* *git* "--bare" args))))
|
||||
(run env #f (cons* *git* "--bare" args))))
|
||||
|
||||
(define (git . args)
|
||||
(git* args))
|
||||
|
|
@ -127,37 +124,59 @@
|
|||
(chdir d))))
|
||||
|
||||
(define (git-ls-tree treeish path)
|
||||
(or (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))))
|
||||
(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)))))
|
||||
'()))
|
||||
|
||||
(define (git-ls-subdirs treeish path)
|
||||
(or (false-if-git-error
|
||||
(match-lines (git "ls-tree" treeish (or path "."))
|
||||
"^(.+) tree (.+)\t(.+)$" (_ mode object name)
|
||||
(cons name object)))
|
||||
(or (and treeish
|
||||
(false-if-git-error
|
||||
(match-lines (git "ls-tree" treeish (or path "."))
|
||||
"^(.+) tree (.+)\t(.+)$" (_ mode object name)
|
||||
(cons name object))))
|
||||
'()))
|
||||
|
||||
(define (git-mktree alist)
|
||||
(string-trim-both
|
||||
(git* '("mktree")
|
||||
#:input (string-join
|
||||
(map (lambda (l)
|
||||
(format #f
|
||||
(if (or (null? (cddr l))
|
||||
(equal? (caddr l) 'blob))
|
||||
"100644 blob ~a\t~a"
|
||||
"040000 tree ~a\t~a")
|
||||
(cadr l) (car l)))
|
||||
alist)
|
||||
"\n" 'suffix))))
|
||||
(if (null? alist)
|
||||
#f
|
||||
(string-trim-both
|
||||
(git* '("mktree")
|
||||
#:input (string-join
|
||||
(map (lambda (l)
|
||||
(format #f
|
||||
(if (or (null? (cddr l))
|
||||
(equal? (caddr l) 'blob))
|
||||
"100644 blob ~a\t~a"
|
||||
"040000 tree ~a\t~a")
|
||||
(cadr l) (car l)))
|
||||
alist)
|
||||
"\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,59 +209,107 @@
|
|||
;;; 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)))
|
||||
(match-bind
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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,40 +56,47 @@
|
|||
n))
|
||||
|
||||
(define (post-editing-form post)
|
||||
`(form (@ (method "POST")
|
||||
(action ,(relurl (if post
|
||||
(string-append "admin/modify-post/"
|
||||
(url:encode (post-key post)))
|
||||
"admin/new-post"))))
|
||||
(p (input (@ (name "title") (type "text")
|
||||
(value ,(if post (post-title post) ""))))
|
||||
(label (@ (for "title")) " <- title"))
|
||||
(p (input (@ (name "tags") (type "text")
|
||||
(value ,(if post
|
||||
(string-join (post-tags post) ", ")
|
||||
""))))
|
||||
(label (@ (for "tags")) " <- tags, comma-separated"))
|
||||
(p (input (@ (name "date") (type "text")
|
||||
(value ,(if (and=> post post-published?)
|
||||
(timestamp->rfc822-date (post-timestamp post))
|
||||
""))))
|
||||
(label (@ (for "date")) " <- date"))
|
||||
(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")))))
|
||||
`(div
|
||||
(form (@ (method "POST")
|
||||
(action ,(relurl (if post
|
||||
(string-append "admin/modify-post/"
|
||||
(url:encode (post-key post)))
|
||||
"admin/new-post"))))
|
||||
(p (input (@ (name "title") (type "text")
|
||||
(value ,(if post (post-title post) ""))))
|
||||
(label (@ (for "title")) " <- title"))
|
||||
(p (input (@ (name "tags") (type "text")
|
||||
(value ,(if post
|
||||
(string-join (post-tags post) ", ")
|
||||
""))))
|
||||
(label (@ (for "tags")) " <- tags, comma-separated"))
|
||||
(p (input (@ (name "date") (type "text")
|
||||
(value ,(if (and=> post post-published?)
|
||||
(timestamp->rfc822-date (post-timestamp post))
|
||||
""))))
|
||||
(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"))))
|
||||
,@(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)
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
||||
|
|
|
|||
101
tekuti/post.scm
101
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)
|
||||
(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)
|
||||
(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)))))
|
||||
(rfc822-date->timestamp date)))
|
||||
(name (title->name title)))
|
||||
`((title . ,title)
|
||||
(body . ,body)
|
||||
(tags . ,tags)
|
||||
(status . ,status)
|
||||
(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)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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) "/"))
|
||||
|
|
|
|||
|
|
@ -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")))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in a new issue