using new one-file-per-comment
This commit is contained in:
parent
8dbbc023a9
commit
85b09abad7
9 changed files with 443 additions and 70 deletions
110
tekuti/base64.scm
Normal file
110
tekuti/base64.scm
Normal file
|
@ -0,0 +1,110 @@
|
||||||
|
;; Tekuti
|
||||||
|
;; Copyright (C) 2008 Andy Wingo <wingo at pobox dot com>
|
||||||
|
|
||||||
|
;; This program is free software; you can redistribute it and/or
|
||||||
|
;; modify it under the terms of the GNU General Public License as
|
||||||
|
;; published by the Free Software Foundation; either version 3 of
|
||||||
|
;; the License, or (at your option) any later version.
|
||||||
|
;;
|
||||||
|
;; This program is distributed in the hope that it will be useful,
|
||||||
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||||
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||||
|
;; GNU General Public License for more details.
|
||||||
|
;;
|
||||||
|
;; You should have received a copy of the GNU General Public License
|
||||||
|
;; along with this program; if not, contact:
|
||||||
|
;;
|
||||||
|
;; Free Software Foundation Voice: +1-617-542-5942
|
||||||
|
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
|
||||||
|
;; Boston, MA 02111-1307, USA gnu@gnu.org
|
||||||
|
|
||||||
|
;;; Commentary:
|
||||||
|
;;
|
||||||
|
;; base 64 y'all
|
||||||
|
;;
|
||||||
|
;;; Code:
|
||||||
|
|
||||||
|
(define-module (tekuti base64)
|
||||||
|
#:export (base64-encode base64-decode))
|
||||||
|
|
||||||
|
(define b64-chars
|
||||||
|
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwzyz0123456789+/")
|
||||||
|
|
||||||
|
(define (int->b64-char i)
|
||||||
|
(string-ref b64-chars (logand i 63)))
|
||||||
|
|
||||||
|
(define b64-char-ranges
|
||||||
|
(map cons
|
||||||
|
(map char->integer '(#\A #\a #\0 #\+ #\/))
|
||||||
|
(map char->integer '(#\Z #\z #\9 #\+ #\/))))
|
||||||
|
|
||||||
|
(define (b64-char->int c)
|
||||||
|
(let ((i (char->integer c)))
|
||||||
|
(let lp ((ranges b64-char-ranges) (out 0))
|
||||||
|
(cond ((null? ranges)
|
||||||
|
(error "bad base64 char" c))
|
||||||
|
((and (>= i (caar ranges)) (<= i (cdar ranges)))
|
||||||
|
(+ out (- i (caar ranges))))
|
||||||
|
(else
|
||||||
|
(lp (cdr ranges) (+ out (1+ (- (cdar ranges)
|
||||||
|
(caar ranges))))))))))
|
||||||
|
|
||||||
|
(define make-bytevector make-string)
|
||||||
|
(define bytevector-ref string-ref)
|
||||||
|
(define bytevector-length string-length)
|
||||||
|
(define bytevector-set! string-set!)
|
||||||
|
(define bytevector-pad string-pad-right)
|
||||||
|
(define byte->integer char->integer)
|
||||||
|
(define integer->byte integer->char)
|
||||||
|
|
||||||
|
(define-macro (bytevector-map-n-to-m n m)
|
||||||
|
`(lambda (proc s)
|
||||||
|
(let* ((len (bytevector-length s))
|
||||||
|
(out (make-bytevector (* len (/ ,m ,n)))))
|
||||||
|
(let lp ((i 0) (j 0))
|
||||||
|
(cond
|
||||||
|
((< i len)
|
||||||
|
(let inner ((k 0) (bytes (proc ,@(map (lambda (x)
|
||||||
|
`(bytevector-ref s (+ i ,x)))
|
||||||
|
(iota n)))))
|
||||||
|
(if (not (null? bytes))
|
||||||
|
(begin (bytevector-set! out (+ j k) (car bytes))
|
||||||
|
(inner (1+ k) (cdr bytes)))))
|
||||||
|
(lp (+ i ,n) (+ j ,m)))
|
||||||
|
(else out))))))
|
||||||
|
|
||||||
|
(define bytevector-map-3-to-4
|
||||||
|
(bytevector-map-n-to-m 3 4))
|
||||||
|
(define bytevector-map-4-to-3
|
||||||
|
(bytevector-map-n-to-m 4 3))
|
||||||
|
|
||||||
|
(define (base64-encode s)
|
||||||
|
(let* ((npad (remainder (- 3 (remainder (bytevector-length s) 3)) 3))
|
||||||
|
(out (bytevector-map-3-to-4
|
||||||
|
(lambda (x y z)
|
||||||
|
(let ((n (logior (ash (byte->integer x) 16)
|
||||||
|
(ash (byte->integer y) 8)
|
||||||
|
(byte->integer z))))
|
||||||
|
(map int->b64-char
|
||||||
|
(list (ash n -18) (ash n -12) (ash n -6) n))))
|
||||||
|
(bytevector-pad s (+ (bytevector-length s) npad)
|
||||||
|
(integer->byte 0)))))
|
||||||
|
(string-append (substring out 0 (- (string-length out) npad))
|
||||||
|
(make-string npad #\=))))
|
||||||
|
|
||||||
|
(define (base64-decode s)
|
||||||
|
(let* ((npad (cond ((string-suffix? "==" s) 2)
|
||||||
|
((string-suffix? "=" s) 1)
|
||||||
|
(else 0)))
|
||||||
|
(out (bytevector-map-4-to-3
|
||||||
|
(lambda (w x y z)
|
||||||
|
(let ((n (logior (ash (b64-char->int w) 18)
|
||||||
|
(ash (b64-char->int x) 12)
|
||||||
|
(ash (b64-char->int y) 6)
|
||||||
|
(b64-char->int z))))
|
||||||
|
(map integer->byte
|
||||||
|
(list (ash n -16) (logand (ash n -8) 255)
|
||||||
|
(logand n 255)))))
|
||||||
|
(string-append (substring s 0 (- (string-length s) npad))
|
||||||
|
(make-string npad #\A)))))
|
||||||
|
(substring out 0 (- (string-length out) npad))))
|
|
@ -31,23 +31,34 @@
|
||||||
#:use-module (tekuti filters)
|
#:use-module (tekuti filters)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-19)
|
#:use-module (srfi srfi-19)
|
||||||
#:export (comment-from-tree comment-sxml-content comment-timestamp build-comment-skeleton comment-readable-date))
|
#:use-module (sxml transform)
|
||||||
|
#:use-module (match-bind)
|
||||||
(use-modules (ice-9 rdelim)
|
#:export (comment-from-object comment-sxml-content comment-timestamp build-comment-skeleton comment-readable-date
|
||||||
(ice-9 popen)
|
bad-new-comment-post?))
|
||||||
(srfi srfi-1)
|
|
||||||
(sxml simple)
|
|
||||||
(tekuti url)
|
|
||||||
(match-bind)
|
|
||||||
(sxml transform))
|
|
||||||
|
|
||||||
(define *comment-spec*
|
(define *comment-spec*
|
||||||
`((timestamp . ,string->number)))
|
`((timestamp . ,string->number)))
|
||||||
(define (comment-from-tree encoded-name sha1)
|
(define (comment-from-object encoded-name sha1)
|
||||||
(acons 'encoded-name encoded-name
|
(let ((blob (git "show" sha1)))
|
||||||
(acons 'sha1 sha1
|
(match-bind
|
||||||
(parse-metadata (string-append sha1 ":" "metadata")
|
"\n\n(.*)$" blob (_ content)
|
||||||
*comment-spec*))))
|
(fold cons
|
||||||
|
(filter
|
||||||
|
identity
|
||||||
|
(match-lines (substring blob 0 (- (string-length blob)
|
||||||
|
(string-length _)))
|
||||||
|
"^([^: ]+): +(.*)$" (_ k v)
|
||||||
|
(let* ((k (string->symbol k))
|
||||||
|
(parse (assq-ref *comment-spec* k)))
|
||||||
|
(if parse
|
||||||
|
(catch 'parse-error
|
||||||
|
(lambda ()
|
||||||
|
(cons k (parse v)))
|
||||||
|
(lambda args #f))
|
||||||
|
(cons k v)))))
|
||||||
|
`((raw-content . ,content)
|
||||||
|
(sha1 . ,sha1)
|
||||||
|
(key . ,encoded-name))))))
|
||||||
|
|
||||||
(define (comment-readable-date comment)
|
(define (comment-readable-date comment)
|
||||||
(let ((date (time-utc->date
|
(let ((date (time-utc->date
|
||||||
|
@ -55,7 +66,7 @@
|
||||||
(date->string date "~e ~B ~Y ~l:~M ~p")))
|
(date->string date "~e ~B ~Y ~l:~M ~p")))
|
||||||
|
|
||||||
(define (comment-raw-content comment)
|
(define (comment-raw-content comment)
|
||||||
(git "show" (string-append (assq-ref comment 'sha1) ":content")))
|
(assq-ref comment 'raw-content))
|
||||||
|
|
||||||
(define (comment-sxml-content comment)
|
(define (comment-sxml-content comment)
|
||||||
(let ((format (or (assq-ref comment 'format) 'wordpress)))
|
(let ((format (or (assq-ref comment 'format) 'wordpress)))
|
||||||
|
@ -78,3 +89,201 @@
|
||||||
#:input "comment\n" #:env env))))
|
#:input "comment\n" #:env env))))
|
||||||
#f
|
#f
|
||||||
comments))
|
comments))
|
||||||
|
|
||||||
|
(define (emailish? x)
|
||||||
|
(match-bind "^([a-zA-Z0-9.+-]+)@([a-zA-Z0-9-]+\\.)+[a-zA-Z]+$"
|
||||||
|
x (_ . args)
|
||||||
|
x
|
||||||
|
#f))
|
||||||
|
|
||||||
|
(define (bad-email? x)
|
||||||
|
(if (emailish? x)
|
||||||
|
#f
|
||||||
|
`(p "Please pretend to specify a valid email address.")))
|
||||||
|
|
||||||
|
(define (urlish? x)
|
||||||
|
(match-bind "^https?://([a-zA-Z0-9-]+\\.)+[a-zA-Z]+/.*$"
|
||||||
|
x (_ . args)
|
||||||
|
x
|
||||||
|
#f))
|
||||||
|
|
||||||
|
(define (bad-url? x)
|
||||||
|
(if (or (string-null? x) (urlish? x))
|
||||||
|
#f
|
||||||
|
`(p "Bad URL. (Only http and https are allowed.)")))
|
||||||
|
|
||||||
|
(define *allowed-tags*
|
||||||
|
`((a (href . ,urlish?) title)
|
||||||
|
(abbr title)
|
||||||
|
(acronym title)
|
||||||
|
(b)
|
||||||
|
(br)
|
||||||
|
(blockquote (cite . ,urlish?))
|
||||||
|
(code)
|
||||||
|
(em)
|
||||||
|
(i)
|
||||||
|
(p)
|
||||||
|
(pre)
|
||||||
|
(strike)
|
||||||
|
(strong)))
|
||||||
|
|
||||||
|
(define (compile-sxslt-rules tags)
|
||||||
|
(define (ok . body)
|
||||||
|
body)
|
||||||
|
`(,@(map (lambda (spec)
|
||||||
|
`(,(car spec)
|
||||||
|
((@ (,@(map (lambda (attr)
|
||||||
|
(if (symbol? attr)
|
||||||
|
`(,attr . ,ok)
|
||||||
|
`(,(car attr)
|
||||||
|
. ,(lambda (tag text)
|
||||||
|
(or ((cdr attr) text)
|
||||||
|
(throw 'bad-attr-value text))
|
||||||
|
(list tag text)))))
|
||||||
|
(cdr spec)))
|
||||||
|
. ,ok))
|
||||||
|
. ,ok))
|
||||||
|
*allowed-tags*)
|
||||||
|
(*text* . ,(lambda (tag text)
|
||||||
|
text))
|
||||||
|
(@ . ,(lambda (tag text)
|
||||||
|
(throw 'bad-attr tag)))
|
||||||
|
(*default* . ,(lambda (tag . body)
|
||||||
|
(throw 'bad-tag tag)))))
|
||||||
|
|
||||||
|
;; could be better, reflect nesting rules...
|
||||||
|
(define *valid-xhtml-rules*
|
||||||
|
`((div ,(compile-sxslt-rules *allowed-tags*)
|
||||||
|
. ,(lambda body body))))
|
||||||
|
|
||||||
|
(use-modules (sxml transform) (tekuti filters))
|
||||||
|
(define (bad-xhtml? x)
|
||||||
|
(catch #t
|
||||||
|
(lambda ()
|
||||||
|
(pre-post-order (wordpress->sxml x) *valid-xhtml-rules*)
|
||||||
|
#f)
|
||||||
|
(lambda (key . args)
|
||||||
|
`(div (p "Invalid XHTML")
|
||||||
|
,(case key
|
||||||
|
((parser-error)
|
||||||
|
`(pre ,(with-output-to-string
|
||||||
|
(lambda () (write args)))))
|
||||||
|
((bad-tag)
|
||||||
|
`(p "XHTML tag disallowed: " ,(symbol->string (car args))))
|
||||||
|
((bad-attr)
|
||||||
|
`(p "XHTML attribute disallowed: " ,(symbol->string (car args))))
|
||||||
|
((bad-attr-value)
|
||||||
|
`(p "XHTML attribute has bad value: " ,(car args)))
|
||||||
|
(else
|
||||||
|
(pk key args)
|
||||||
|
`(p "Jesus knows why, and so do you")))))))
|
||||||
|
|
||||||
|
(define *new-comment-spec*
|
||||||
|
`(("author" ,(lambda (x) #f))
|
||||||
|
("email" ,bad-email?)
|
||||||
|
("url" ,bad-url?)
|
||||||
|
("comment" ,bad-xhtml?)
|
||||||
|
("submit" ,(lambda (x) #f))))
|
||||||
|
|
||||||
|
(define (bad-new-comment-post? post-data)
|
||||||
|
(or (or-map (lambda (pair)
|
||||||
|
(and (not (assoc (car pair) *new-comment-spec*))
|
||||||
|
`(p "Bad post data: " ,(car pair))))
|
||||||
|
post-data)
|
||||||
|
(or-map (lambda (pair)
|
||||||
|
(and (not (assoc (car pair) post-data))
|
||||||
|
`(p "Incomplete post data:" ,(car pair))))
|
||||||
|
*new-comment-spec*)
|
||||||
|
(or-map (lambda (pair)
|
||||||
|
((cadr pair) (assoc-ref post-data (car pair))))
|
||||||
|
*new-comment-spec*)))
|
||||||
|
|
||||||
|
(use-modules (srfi srfi-11))
|
||||||
|
(define (make-tree-deep treeish add remove change)
|
||||||
|
(define (local? x) (null? (car x)))
|
||||||
|
(define (assert-added-files-not-present names dents)
|
||||||
|
(for-each
|
||||||
|
(lambda (dent)
|
||||||
|
(if (member (car dent) names)
|
||||||
|
(error "file already added" dent)))
|
||||||
|
dents))
|
||||||
|
(define (assert-referenced-files-present names dents)
|
||||||
|
(for-each
|
||||||
|
(lambda (name)
|
||||||
|
(if (not (assoc name dent-names))
|
||||||
|
(error "file already removed" name)))
|
||||||
|
names))
|
||||||
|
(define (collect proc l)
|
||||||
|
(reverse! (fold (lambda (x y)
|
||||||
|
(let ((foo (proc x)))
|
||||||
|
(if foo (cons foo y) y)))
|
||||||
|
'() l)))
|
||||||
|
(define (level-down x)
|
||||||
|
(cons (cdar x) (cdr x)))
|
||||||
|
|
||||||
|
(let-values (((dents) (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 caadr ladd) dents)
|
||||||
|
(assert-referenced-files-present
|
||||||
|
(append (map cadr lremove) (map caadr lchange)) dents)
|
||||||
|
|
||||||
|
(make-tree
|
||||||
|
(append
|
||||||
|
(map cdr ladd)
|
||||||
|
(collect
|
||||||
|
(lambda (dent)
|
||||||
|
(cond
|
||||||
|
((member (car dent) (map cadr lremove))
|
||||||
|
#f)
|
||||||
|
((member (car dent) (map caadr lchange))
|
||||||
|
(cadr lchange))
|
||||||
|
((and (equal? (caddr dent) "tree")
|
||||||
|
(or (member (car dent)
|
||||||
|
(map cadr (append dadd dremove dchange)))))
|
||||||
|
`(,(car dent) (make-tree-deep (cadr dent)
|
||||||
|
(map level-down dadd)
|
||||||
|
(map level-down dremove)
|
||||||
|
(map level-down dchange))
|
||||||
|
,(caddr dent) ,(cadddr dent)))
|
||||||
|
(else dent))))))))
|
||||||
|
|
||||||
|
|
||||||
|
(define (mutate-tree master add remove change message)
|
||||||
|
(let ((tree (make-tree-deep master add remove change)))
|
||||||
|
(string-trim-both
|
||||||
|
(git* `("commit-tree" ,tree "-p" ,master) #:input message
|
||||||
|
#:env '("GIT_COMMMITTER=tekuti")))))
|
||||||
|
|
||||||
|
(define (update-master master proc)
|
||||||
|
(let lp ((master master))
|
||||||
|
(let ((commit (proc master)) (count 5))
|
||||||
|
(cond
|
||||||
|
((zero? count)
|
||||||
|
(error "my god, we looped 5 times" commit))
|
||||||
|
((false-if-git-error
|
||||||
|
(git "update-ref" "refs/heads/master" commit master))
|
||||||
|
commit)
|
||||||
|
(else
|
||||||
|
(pk "failed to update the master ref, trying again...")
|
||||||
|
(lp (git-rev-parse "master") (1- count)))))))
|
||||||
|
|
||||||
|
(define (make-new-comment post content)
|
||||||
|
(let ((content-sha1 (make-blob
|
||||||
|
(assoc-ref post-data "comment")))
|
||||||
|
(metadata-sha1 (make-blob (with-output-to-string
|
||||||
|
(lambda ()
|
||||||
|
(write )
|
||||||
|
)
|
||||||
|
) metadata)))
|
||||||
|
(update-master
|
||||||
|
master
|
||||||
|
(lambda (master)
|
||||||
|
(mutate-tree master
|
||||||
|
`(((,(assq-ref post 'key) "comments" ,comment-key)
|
||||||
|
("content" ,content-sha1 "blob" "100644"))
|
||||||
|
((,(assq-ref post 'key) "metadata" ,comment-key)
|
||||||
|
("metadata" ,metadata-sha1 "blob" "100644")))
|
||||||
|
'()
|
||||||
|
'())))))
|
||||||
|
|
|
@ -27,7 +27,7 @@
|
||||||
(define-module (tekuti config)
|
(define-module (tekuti config)
|
||||||
#:use-module (tekuti util)
|
#:use-module (tekuti util)
|
||||||
#:export (*host* *port* *backlog* *git-dir* *git* *public-url-base*
|
#:export (*host* *port* *backlog* *git-dir* *git* *public-url-base*
|
||||||
*private-url-base* *debug*))
|
*private-url-base* *debug* *admin-user* *admin-pass*))
|
||||||
|
|
||||||
(define *host* "127.0.0.1")
|
(define *host* "127.0.0.1")
|
||||||
(define *port* 8081)
|
(define *port* 8081)
|
||||||
|
@ -37,3 +37,5 @@
|
||||||
(define *public-url-base* "/blog/")
|
(define *public-url-base* "/blog/")
|
||||||
(define *private-url-base* "/blog/")
|
(define *private-url-base* "/blog/")
|
||||||
(define *debug* #t)
|
(define *debug* #t)
|
||||||
|
(define *admin-user* "admin")
|
||||||
|
(define *admin-pass* "totingiini")
|
||||||
|
|
|
@ -38,7 +38,8 @@
|
||||||
|
|
||||||
git git* ensure-git-repo git-ls-tree git-ls-subdirs
|
git git* ensure-git-repo git-ls-tree git-ls-subdirs
|
||||||
parse-metadata parse-commit commit-utc-timestamp
|
parse-metadata parse-commit commit-utc-timestamp
|
||||||
commit-parents make-tree git-rev-parse
|
commit-parents make-tree git-rev-parse make-tree-full
|
||||||
|
create-blob
|
||||||
|
|
||||||
write-indices read-indices))
|
write-indices read-indices))
|
||||||
|
|
||||||
|
@ -129,10 +130,12 @@
|
||||||
(chdir d))))
|
(chdir d))))
|
||||||
|
|
||||||
(define (git-ls-tree treeish path)
|
(define (git-ls-tree treeish path)
|
||||||
|
(or (false-if-git-error
|
||||||
(match-lines (git "ls-tree" treeish (or path "."))
|
(match-lines (git "ls-tree" treeish (or path "."))
|
||||||
"^(.+) (.+) (.+)\t(.+)$" (_ mode type object name)
|
"^(.+) (.+) (.+)\t(.+)$" (_ mode type object name)
|
||||||
;; reversed for assoc
|
;; reversed for assoc
|
||||||
(list name object type mode)))
|
(list name object type mode)))
|
||||||
|
'()))
|
||||||
|
|
||||||
(define (git-ls-subdirs treeish path)
|
(define (git-ls-subdirs treeish path)
|
||||||
(or (false-if-git-error
|
(or (false-if-git-error
|
||||||
|
|
|
@ -29,6 +29,7 @@
|
||||||
#:use-module (tekuti util)
|
#:use-module (tekuti util)
|
||||||
#:use-module (tekuti git)
|
#:use-module (tekuti git)
|
||||||
#:use-module (tekuti post)
|
#:use-module (tekuti post)
|
||||||
|
#:use-module (tekuti comment)
|
||||||
#:use-module (tekuti url)
|
#:use-module (tekuti url)
|
||||||
#:use-module (tekuti request)
|
#:use-module (tekuti request)
|
||||||
#:use-module (srfi srfi-34)
|
#:use-module (srfi srfi-34)
|
||||||
|
@ -38,12 +39,12 @@
|
||||||
page-admin-posts
|
page-admin-posts
|
||||||
page-admin-post
|
page-admin-post
|
||||||
page-admin-new-post
|
page-admin-new-post
|
||||||
page-admin-new-comment
|
|
||||||
page-admin-modify-post
|
page-admin-modify-post
|
||||||
page-admin-delete-comment
|
page-admin-delete-comment
|
||||||
page-admin-delete-post
|
page-admin-delete-post
|
||||||
page-index
|
page-index
|
||||||
page-show-post
|
page-show-post
|
||||||
|
page-new-comment
|
||||||
page-archives
|
page-archives
|
||||||
page-show-tags
|
page-show-tags
|
||||||
page-show-tag
|
page-show-tag
|
||||||
|
@ -87,18 +88,13 @@
|
||||||
(ul ,@body)))
|
(ul ,@body)))
|
||||||
|
|
||||||
(define (with-authentication request thunk)
|
(define (with-authentication request thunk)
|
||||||
(let ((headers (rref request 'headers '())))
|
(if (request-authenticated? request)
|
||||||
(define (authenticated?)
|
|
||||||
(let ((b64 (assoc-ref headers "Authorization")))
|
|
||||||
(pk b64) ;; FIXME, decode
|
|
||||||
))
|
|
||||||
(if (authenticated?)
|
|
||||||
(thunk)
|
(thunk)
|
||||||
(rcons* (rpush 'output-headers
|
(rcons* (rpush 'output-headers
|
||||||
'("WWW-Authenticate" . "Basic realm=\"Tekuti\"")
|
'("WWW-Authenticate" . "Basic realm=\"Tekuti\"")
|
||||||
request)
|
request)
|
||||||
'status 401
|
'status 401
|
||||||
'body `((p "Authentication required, yo"))))))
|
'body `((p "Authentication required, yo")))))
|
||||||
|
|
||||||
(define (page-admin request index)
|
(define (page-admin request index)
|
||||||
(with-authentication
|
(with-authentication
|
||||||
|
@ -150,29 +146,11 @@
|
||||||
'body `((h1 ,(assq-ref post 'title))
|
'body `((h1 ,(assq-ref post 'title))
|
||||||
,(post-editing-form post)))))))
|
,(post-editing-form post)))))))
|
||||||
|
|
||||||
(define (decode-form-data request)
|
|
||||||
(let-request request (headers post-data)
|
|
||||||
(if (string-null? post-data)
|
|
||||||
'()
|
|
||||||
(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 #\&)))
|
|
||||||
(else
|
|
||||||
(error "bad content-type" content-type)))))))
|
|
||||||
|
|
||||||
(define (page-admin-new-post request index)
|
(define (page-admin-new-post request index)
|
||||||
(with-authentication
|
(with-authentication
|
||||||
request
|
request
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(let ((form-data (decode-form-data request)))
|
(let ((form-data (request-form-data request)))
|
||||||
(rcons* request
|
(rcons* request
|
||||||
'status 201 ; created
|
'status 201 ; created
|
||||||
'output-headers (acons "Location" *public-url-base*
|
'output-headers (acons "Location" *public-url-base*
|
||||||
|
@ -205,7 +183,6 @@
|
||||||
request
|
request
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(not-implemented request index))))
|
(not-implemented request index))))
|
||||||
(define page-new-comment not-implemented)
|
|
||||||
(define page-delete-comment not-implemented)
|
(define page-delete-comment not-implemented)
|
||||||
(define page-delete-post not-implemented)
|
(define page-delete-post not-implemented)
|
||||||
|
|
||||||
|
@ -265,13 +242,31 @@
|
||||||
(git-rev-parse (string-append (assq-ref index 'master) ":" slug)))
|
(git-rev-parse (string-append (assq-ref index 'master) ":" slug)))
|
||||||
=> (lambda (tree)
|
=> (lambda (tree)
|
||||||
(let ((post (post-from-tree slug tree)))
|
(let ((post (post-from-tree slug tree)))
|
||||||
(pk post)
|
|
||||||
(rcons* request
|
(rcons* request
|
||||||
'title (assq-ref post 'title)
|
'title (assq-ref post 'title)
|
||||||
'body (show-post post #t)))))
|
'body (show-post post #t)))))
|
||||||
(else
|
(else
|
||||||
(page-not-found request index)))))
|
(page-not-found request index)))))
|
||||||
|
|
||||||
|
(define (page-new-comment request index year month day post)
|
||||||
|
(let ((slug (make-post-key year month day post))
|
||||||
|
(data (request-form-data request)))
|
||||||
|
(cond
|
||||||
|
((false-if-git-error
|
||||||
|
(git-rev-parse (string-append (assq-ref index 'master) ":" slug)))
|
||||||
|
=> (lambda (tree)
|
||||||
|
(cond
|
||||||
|
((bad-new-comment-post? data)
|
||||||
|
=> (lambda (reason)
|
||||||
|
(pk reason)
|
||||||
|
(rcons* request
|
||||||
|
'body `((p "Bad post data: " ,reason)))))
|
||||||
|
(else
|
||||||
|
(rcons* request
|
||||||
|
'body `((p "hey hey hey like fat albert")))))))
|
||||||
|
(else
|
||||||
|
(page-not-found request index)))))
|
||||||
|
|
||||||
(define/kwargs (date-increment date (day 0) (month 0) (year 0))
|
(define/kwargs (date-increment date (day 0) (month 0) (year 0))
|
||||||
(make-date (date-nanosecond date) (date-second date)
|
(make-date (date-nanosecond date) (date-second date)
|
||||||
(date-minute date) (date-minute date)
|
(date-minute date) (date-minute date)
|
||||||
|
|
|
@ -106,11 +106,32 @@
|
||||||
(define (post-comments post)
|
(define (post-comments post)
|
||||||
(dsu-sort
|
(dsu-sort
|
||||||
(map (lambda (pair)
|
(map (lambda (pair)
|
||||||
(comment-from-tree (car pair) (cdr pair)))
|
(comment-from-object (car pair) (cadr pair)))
|
||||||
(git-ls-subdirs (assq-ref post 'sha1) "comments/"))
|
(git-ls-tree (string-append (assq-ref post 'sha1) ":comments") #f))
|
||||||
comment-timestamp
|
comment-timestamp
|
||||||
<))
|
<))
|
||||||
|
|
||||||
|
(define (comment-form post author email url comment)
|
||||||
|
`(form
|
||||||
|
(@ (action ,(string-append *public-url-base* "archives/"
|
||||||
|
(url:decode (assq-ref post 'key))))
|
||||||
|
(method "POST"))
|
||||||
|
(p (input (@ (type "text") (name "author") (value ,author)
|
||||||
|
(size "22") (tabindex "1")))
|
||||||
|
" " (label (@ (for "author")) (small "Name")))
|
||||||
|
(p (input (@ (type "text") (name "email") (value ,email)
|
||||||
|
(size "22") (tabindex "2")))
|
||||||
|
" " (label (@ (for "email")) (small "Mail (will not be published)")))
|
||||||
|
(p (input (@ (type "text") (name "url") (value ,url)
|
||||||
|
(size "22") (tabindex "3")))
|
||||||
|
" " (label (@ (for "url")) (small "Website")))
|
||||||
|
;(p (small "allowed tags: "))
|
||||||
|
(p (textarea (@ (name "comment") (id "comment") (cols "100%")
|
||||||
|
(rows "10") (tabindex "4"))
|
||||||
|
,comment))
|
||||||
|
(p (input (@ (name "submit") (type "submit") (id "submit") (tabindex "5")
|
||||||
|
(value "Submit Comment"))))))
|
||||||
|
|
||||||
(define (post-sxml-comments post)
|
(define (post-sxml-comments post)
|
||||||
(let ((comments (post-comments post))
|
(let ((comments (post-comments post))
|
||||||
(comment-status (assq-ref post 'comment_status)))
|
(comment-status (assq-ref post 'comment_status)))
|
||||||
|
@ -123,7 +144,7 @@
|
||||||
((1) "One response")
|
((1) "One response")
|
||||||
(else (format #f "~d responses" len)))))))
|
(else (format #f "~d responses" len)))))))
|
||||||
(define (show-comment comment)
|
(define (show-comment comment)
|
||||||
`(li (@ (class "alt") (id ,(assq-ref comment 'encoded-name)))
|
`(li (@ (class "alt") (id ,(assq-ref comment 'key)))
|
||||||
(cite ,(let ((url (assq-ref comment 'author_url))
|
(cite ,(let ((url (assq-ref comment 'author_url))
|
||||||
(name (assq-ref comment 'author)))
|
(name (assq-ref comment 'author)))
|
||||||
(if url
|
(if url
|
||||||
|
@ -131,8 +152,7 @@
|
||||||
name)))
|
name)))
|
||||||
" says:" (br)
|
" says:" (br)
|
||||||
(small (@ (class "commentmetadata"))
|
(small (@ (class "commentmetadata"))
|
||||||
(a (@ (href ,(string-append
|
(a (@ (href ,(string-append "#" (assq-ref comment 'key))))
|
||||||
"#" (assq-ref comment 'encoded-name))))
|
|
||||||
,(comment-readable-date comment)))
|
,(comment-readable-date comment)))
|
||||||
,(comment-sxml-content comment)))
|
,(comment-sxml-content comment)))
|
||||||
`(div
|
`(div
|
||||||
|
@ -142,8 +162,8 @@
|
||||||
`((ol (@ (class "commentlist")) ,@l))))
|
`((ol (@ (class "commentlist")) ,@l))))
|
||||||
,(if (equal? comment-status "closed")
|
,(if (equal? comment-status "closed")
|
||||||
`(p (@ (id "nocomments")) "Comments are closed.")
|
`(p (@ (id "nocomments")) "Comments are closed.")
|
||||||
'(div (h3 "Leave a Reply")
|
`(div (h3 "Leave a Reply")
|
||||||
"...")))))
|
,(comment-form post "" "" "" ""))))))
|
||||||
|
|
||||||
(define (post-n-comments post)
|
(define (post-n-comments post)
|
||||||
(length (git-ls-subdirs (assq-ref post 'sha1) "comments/")))
|
(length (git-ls-subdirs (assq-ref post 'sha1) "comments/")))
|
||||||
|
|
|
@ -27,11 +27,14 @@
|
||||||
(define-module (tekuti request)
|
(define-module (tekuti request)
|
||||||
#:use-module ((srfi srfi-1) #:select (find-tail fold))
|
#:use-module ((srfi srfi-1) #:select (find-tail fold))
|
||||||
#:use-module (scheme kwargs)
|
#:use-module (scheme kwargs)
|
||||||
|
#:use-module (match-bind)
|
||||||
#:use-module (tekuti util)
|
#:use-module (tekuti util)
|
||||||
#:use-module (tekuti url)
|
#:use-module (tekuti url)
|
||||||
#:use-module (tekuti config)
|
#:use-module (tekuti config)
|
||||||
|
#:use-module (tekuti base64)
|
||||||
#:export (make-request rcons rcons* rpush rpush* rref let-request
|
#:export (make-request rcons rcons* rpush rpush* rref let-request
|
||||||
request-path-case))
|
request-path-case request-authenticated?
|
||||||
|
request-form-data))
|
||||||
|
|
||||||
(define (header-ref headers key default)
|
(define (header-ref headers key default)
|
||||||
(let ((pair (assoc key headers)))
|
(let ((pair (assoc key headers)))
|
||||||
|
@ -54,6 +57,24 @@
|
||||||
(method . ,(lambda (r)
|
(method . ,(lambda (r)
|
||||||
(header-ref (rref r 'headers '()) "method" "GET")))))
|
(header-ref (rref r 'headers '()) "method" "GET")))))
|
||||||
|
|
||||||
|
(define (request-form-data request)
|
||||||
|
(let-request request (headers post-data)
|
||||||
|
(if (string-null? post-data)
|
||||||
|
'()
|
||||||
|
(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 #\&)))
|
||||||
|
(else
|
||||||
|
(error "bad content-type" content-type)))))))
|
||||||
|
|
||||||
(define (make-request . keys-and-values)
|
(define (make-request . keys-and-values)
|
||||||
(fold (lambda (pair r)
|
(fold (lambda (pair r)
|
||||||
(rcons (car pair) ((cdr pair) r) r))
|
(rcons (car pair) ((cdr pair) r) r))
|
||||||
|
@ -86,6 +107,19 @@
|
||||||
(default-proc (default-proc request k))
|
(default-proc (default-proc request k))
|
||||||
(else default))))
|
(else default))))
|
||||||
|
|
||||||
|
;; danger here, regarding the optional alternate clauses...
|
||||||
|
(define (request-authenticated? request)
|
||||||
|
(let ((headers (rref request 'headers '())))
|
||||||
|
(let ((auth (assoc-ref headers "Authorization")))
|
||||||
|
(and auth
|
||||||
|
(match-bind "^Basic ([A-Za-z0-9+/=]*)$" auth (_ b64)
|
||||||
|
(match-bind "^([^:]*):(.*)$"
|
||||||
|
(base64-decode b64) (_ user pass)
|
||||||
|
(and (equal? user *admin-user*)
|
||||||
|
(equal? pass *admin-pass*))
|
||||||
|
#f)
|
||||||
|
#f)))))
|
||||||
|
|
||||||
(define-macro (let-request request bindings . body)
|
(define-macro (let-request request bindings . body)
|
||||||
(let ((request-var (gensym)))
|
(let ((request-var (gensym)))
|
||||||
(define (make-binding b)
|
(define (make-binding b)
|
||||||
|
|
|
@ -88,7 +88,6 @@
|
||||||
((GET admin posts) page-admin-posts)
|
((GET admin posts) page-admin-posts)
|
||||||
((GET admin posts post-key!) page-admin-post)
|
((GET admin posts post-key!) page-admin-post)
|
||||||
((POST admin new-post) page-admin-new-post)
|
((POST admin new-post) page-admin-new-post)
|
||||||
((POST admin new-comment post-key!) page-admin-new-comment)
|
|
||||||
;; would be fine to have e.g. (DELETE admin posts posts-key!), but
|
;; would be fine to have e.g. (DELETE admin posts posts-key!), but
|
||||||
;; web browsers don't handle that
|
;; web browsers don't handle that
|
||||||
((POST admin modify-post post-key!) page-admin-modify-post)
|
((POST admin modify-post post-key!) page-admin-modify-post)
|
||||||
|
@ -98,6 +97,7 @@
|
||||||
((GET) page-index)
|
((GET) page-index)
|
||||||
((GET archives year? month? day?) page-archives)
|
((GET archives year? month? day?) page-archives)
|
||||||
((GET archives year! month! day! post!) page-show-post)
|
((GET archives year! month! day! post!) page-show-post)
|
||||||
|
((POST archives year! month! day! post!) page-new-comment)
|
||||||
((GET tags) page-show-tags)
|
((GET tags) page-show-tags)
|
||||||
((GET tags tag!) page-show-tag)
|
((GET tags tag!) page-show-tag)
|
||||||
((GET debug) page-debug)
|
((GET debug) page-debug)
|
||||||
|
|
|
@ -63,9 +63,8 @@ def write_comment(comment, dir):
|
||||||
out += 'timestamp: %s\n' % int(time.mktime(date.timetuple()))
|
out += 'timestamp: %s\n' % int(time.mktime(date.timetuple()))
|
||||||
return out
|
return out
|
||||||
|
|
||||||
d = make_dir(dir + str(comment['id']))
|
write_file(dir + str(comment['id']),
|
||||||
write_file(d + 'content', comment['content'])
|
make_metadata() + '\n' + comment['content'])
|
||||||
write_file(d + 'metadata', make_metadata())
|
|
||||||
|
|
||||||
def make_post_key(post):
|
def make_post_key(post):
|
||||||
d = post['date']
|
d = post['date']
|
||||||
|
@ -87,6 +86,7 @@ def write_post(post, categories, comments):
|
||||||
write_file(d + 'content', post['content'])
|
write_file(d + 'content', post['content'])
|
||||||
write_file(d + 'content-filtered', post['content_filtered'])
|
write_file(d + 'content-filtered', post['content_filtered'])
|
||||||
write_file(d + 'metadata', make_metadata())
|
write_file(d + 'metadata', make_metadata())
|
||||||
|
if comments:
|
||||||
c = make_dir(d + 'comments')
|
c = make_dir(d + 'comments')
|
||||||
for comment in comments:
|
for comment in comments:
|
||||||
write_comment(comment, c)
|
write_comment(comment, c)
|
||||||
|
|
Loading…
Reference in a new issue