diff --git a/tekuti/comment.scm b/tekuti/comment.scm index db6cdd6..f177082 100644 --- a/tekuti/comment.scm +++ b/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) - 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)))) diff --git a/tekuti/git.scm b/tekuti/git.scm index 7bc174c..35b3b27 100644 --- a/tekuti/git.scm +++ b/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 diff --git a/tekuti/mod-lisp.scm b/tekuti/mod-lisp.scm index 1ad775d..458f2bc 100644 --- a/tekuti/mod-lisp.scm +++ b/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) diff --git a/tekuti/page-helpers.scm b/tekuti/page-helpers.scm index ff5281c..72bbe23 100644 --- a/tekuti/page-helpers.scm +++ b/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,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) diff --git a/tekuti/page.scm b/tekuti/page.scm index e4e5a80..bf36ca5 100644 --- a/tekuti/page.scm +++ b/tekuti/page.scm @@ -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))))) diff --git a/tekuti/post.scm b/tekuti/post.scm index 957342f..a0012a9 100644 --- a/tekuti/post.scm +++ b/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) diff --git a/tekuti/request.scm b/tekuti/request.scm index 0a82be4..276691d 100644 --- a/tekuti/request.scm +++ b/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 - (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)) diff --git a/tekuti/url.scm b/tekuti/url.scm index ffac093..dc50dea 100644 --- a/tekuti/url.scm +++ b/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) "/")) diff --git a/tekuti/util.scm b/tekuti/util.scm index 1c04f27..81a4d0b 100644 --- a/tekuti/util.scm +++ b/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"))) diff --git a/tekuti/web.scm b/tekuti/web.scm index 171c69e..d181145 100644 --- a/tekuti/web.scm +++ b/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) - ((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)