using new one-file-per-comment
This commit is contained in:
Andy Wingo
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 (srfi srfi-1)
|
||||
#:use-module (srfi srfi-19)
|
||||
#:export (comment-from-tree comment-sxml-content comment-timestamp build-comment-skeleton comment-readable-date))
|
||||
|
||||
(use-modules (ice-9 rdelim)
|
||||
(ice-9 popen)
|
||||
(srfi srfi-1)
|
||||
(sxml simple)
|
||||
(tekuti url)
|
||||
(match-bind)
|
||||
(sxml transform))
|
||||
#:use-module (sxml transform)
|
||||
#:use-module (match-bind)
|
||||
#:export (comment-from-object comment-sxml-content comment-timestamp build-comment-skeleton comment-readable-date
|
||||
bad-new-comment-post?))
|
||||
|
||||
(define *comment-spec*
|
||||
`((timestamp . ,string->number)))
|
||||
(define (comment-from-tree encoded-name sha1)
|
||||
(acons 'encoded-name encoded-name
|
||||
(acons 'sha1 sha1
|
||||
(parse-metadata (string-append sha1 ":" "metadata")
|
||||
*comment-spec*))))
|
||||
(define (comment-from-object encoded-name sha1)
|
||||
(let ((blob (git "show" sha1)))
|
||||
(match-bind
|
||||
"\n\n(.*)$" blob (_ content)
|
||||
(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)
|
||||
(let ((date (time-utc->date
|
||||
|
|
@ -55,7 +66,7 @@
|
|||
(date->string date "~e ~B ~Y ~l:~M ~p")))
|
||||
|
||||
(define (comment-raw-content comment)
|
||||
(git "show" (string-append (assq-ref comment 'sha1) ":content")))
|
||||
(assq-ref comment 'raw-content))
|
||||
|
||||
(define (comment-sxml-content comment)
|
||||
(let ((format (or (assq-ref comment 'format) 'wordpress)))
|
||||
|
|
@ -78,3 +89,201 @@
|
|||
#:input "comment\n" #:env env))))
|
||||
#f
|
||||
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)
|
||||
#:use-module (tekuti util)
|
||||
#: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 *port* 8081)
|
||||
|
|
@ -37,3 +37,5 @@
|
|||
(define *public-url-base* "/blog/")
|
||||
(define *private-url-base* "/blog/")
|
||||
(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
|
||||
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))
|
||||
|
||||
|
|
@ -129,10 +130,12 @@
|
|||
(chdir d))))
|
||||
|
||||
(define (git-ls-tree treeish path)
|
||||
(match-lines (git "ls-tree" treeish (or path "."))
|
||||
"^(.+) (.+) (.+)\t(.+)$" (_ mode type object name)
|
||||
;; reversed for assoc
|
||||
(list name object type mode)))
|
||||
(or (false-if-git-error
|
||||
(match-lines (git "ls-tree" treeish (or path "."))
|
||||
"^(.+) (.+) (.+)\t(.+)$" (_ mode type object name)
|
||||
;; reversed for assoc
|
||||
(list name object type mode)))
|
||||
'()))
|
||||
|
||||
(define (git-ls-subdirs treeish path)
|
||||
(or (false-if-git-error
|
||||
|
|
|
|||
|
|
@ -29,6 +29,7 @@
|
|||
#:use-module (tekuti util)
|
||||
#:use-module (tekuti git)
|
||||
#:use-module (tekuti post)
|
||||
#:use-module (tekuti comment)
|
||||
#:use-module (tekuti url)
|
||||
#:use-module (tekuti request)
|
||||
#:use-module (srfi srfi-34)
|
||||
|
|
@ -38,12 +39,12 @@
|
|||
page-admin-posts
|
||||
page-admin-post
|
||||
page-admin-new-post
|
||||
page-admin-new-comment
|
||||
page-admin-modify-post
|
||||
page-admin-delete-comment
|
||||
page-admin-delete-post
|
||||
page-index
|
||||
page-show-post
|
||||
page-new-comment
|
||||
page-archives
|
||||
page-show-tags
|
||||
page-show-tag
|
||||
|
|
@ -87,18 +88,13 @@
|
|||
(ul ,@body)))
|
||||
|
||||
(define (with-authentication request thunk)
|
||||
(let ((headers (rref request 'headers '())))
|
||||
(define (authenticated?)
|
||||
(let ((b64 (assoc-ref headers "Authorization")))
|
||||
(pk b64) ;; FIXME, decode
|
||||
))
|
||||
(if (authenticated?)
|
||||
(thunk)
|
||||
(rcons* (rpush 'output-headers
|
||||
'("WWW-Authenticate" . "Basic realm=\"Tekuti\"")
|
||||
request)
|
||||
'status 401
|
||||
'body `((p "Authentication required, yo"))))))
|
||||
(if (request-authenticated? request)
|
||||
(thunk)
|
||||
(rcons* (rpush 'output-headers
|
||||
'("WWW-Authenticate" . "Basic realm=\"Tekuti\"")
|
||||
request)
|
||||
'status 401
|
||||
'body `((p "Authentication required, yo")))))
|
||||
|
||||
(define (page-admin request index)
|
||||
(with-authentication
|
||||
|
|
@ -150,29 +146,11 @@
|
|||
'body `((h1 ,(assq-ref post 'title))
|
||||
,(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)
|
||||
(with-authentication
|
||||
request
|
||||
(lambda ()
|
||||
(let ((form-data (decode-form-data request)))
|
||||
(let ((form-data (request-form-data request)))
|
||||
(rcons* request
|
||||
'status 201 ; created
|
||||
'output-headers (acons "Location" *public-url-base*
|
||||
|
|
@ -205,7 +183,6 @@
|
|||
request
|
||||
(lambda ()
|
||||
(not-implemented request index))))
|
||||
(define page-new-comment not-implemented)
|
||||
(define page-delete-comment not-implemented)
|
||||
(define page-delete-post not-implemented)
|
||||
|
||||
|
|
@ -265,13 +242,31 @@
|
|||
(git-rev-parse (string-append (assq-ref index 'master) ":" slug)))
|
||||
=> (lambda (tree)
|
||||
(let ((post (post-from-tree slug tree)))
|
||||
(pk post)
|
||||
(rcons* request
|
||||
'title (assq-ref post 'title)
|
||||
'body (show-post post #t)))))
|
||||
(else
|
||||
(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))
|
||||
(make-date (date-nanosecond date) (date-second date)
|
||||
(date-minute date) (date-minute date)
|
||||
|
|
|
|||
|
|
@ -106,11 +106,32 @@
|
|||
(define (post-comments post)
|
||||
(dsu-sort
|
||||
(map (lambda (pair)
|
||||
(comment-from-tree (car pair) (cdr pair)))
|
||||
(git-ls-subdirs (assq-ref post 'sha1) "comments/"))
|
||||
(comment-from-object (car pair) (cadr pair)))
|
||||
(git-ls-tree (string-append (assq-ref post 'sha1) ":comments") #f))
|
||||
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)
|
||||
(let ((comments (post-comments post))
|
||||
(comment-status (assq-ref post 'comment_status)))
|
||||
|
|
@ -123,7 +144,7 @@
|
|||
((1) "One response")
|
||||
(else (format #f "~d responses" len)))))))
|
||||
(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))
|
||||
(name (assq-ref comment 'author)))
|
||||
(if url
|
||||
|
|
@ -131,8 +152,7 @@
|
|||
name)))
|
||||
" says:" (br)
|
||||
(small (@ (class "commentmetadata"))
|
||||
(a (@ (href ,(string-append
|
||||
"#" (assq-ref comment 'encoded-name))))
|
||||
(a (@ (href ,(string-append "#" (assq-ref comment 'key))))
|
||||
,(comment-readable-date comment)))
|
||||
,(comment-sxml-content comment)))
|
||||
`(div
|
||||
|
|
@ -142,8 +162,8 @@
|
|||
`((ol (@ (class "commentlist")) ,@l))))
|
||||
,(if (equal? comment-status "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)
|
||||
(length (git-ls-subdirs (assq-ref post 'sha1) "comments/")))
|
||||
|
|
|
|||
|
|
@ -27,11 +27,14 @@
|
|||
(define-module (tekuti request)
|
||||
#:use-module ((srfi srfi-1) #:select (find-tail fold))
|
||||
#:use-module (scheme kwargs)
|
||||
#:use-module (match-bind)
|
||||
#:use-module (tekuti util)
|
||||
#:use-module (tekuti url)
|
||||
#:use-module (tekuti config)
|
||||
#:use-module (tekuti base64)
|
||||
#: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)
|
||||
(let ((pair (assoc key headers)))
|
||||
|
|
@ -54,6 +57,24 @@
|
|||
(method . ,(lambda (r)
|
||||
(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)
|
||||
(fold (lambda (pair r)
|
||||
(rcons (car pair) ((cdr pair) r) r))
|
||||
|
|
@ -86,6 +107,19 @@
|
|||
(default-proc (default-proc request k))
|
||||
(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)
|
||||
(let ((request-var (gensym)))
|
||||
(define (make-binding b)
|
||||
|
|
|
|||
|
|
@ -88,7 +88,6 @@
|
|||
((GET admin posts) page-admin-posts)
|
||||
((GET admin posts post-key!) page-admin-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
|
||||
;; web browsers don't handle that
|
||||
((POST admin modify-post post-key!) page-admin-modify-post)
|
||||
|
|
@ -98,6 +97,7 @@
|
|||
((GET) page-index)
|
||||
((GET archives year? month? day?) page-archives)
|
||||
((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 tag!) page-show-tag)
|
||||
((GET debug) page-debug)
|
||||
|
|
|
|||
|
|
@ -63,9 +63,8 @@ def write_comment(comment, dir):
|
|||
out += 'timestamp: %s\n' % int(time.mktime(date.timetuple()))
|
||||
return out
|
||||
|
||||
d = make_dir(dir + str(comment['id']))
|
||||
write_file(d + 'content', comment['content'])
|
||||
write_file(d + 'metadata', make_metadata())
|
||||
write_file(dir + str(comment['id']),
|
||||
make_metadata() + '\n' + comment['content'])
|
||||
|
||||
def make_post_key(post):
|
||||
d = post['date']
|
||||
|
|
@ -87,9 +86,10 @@ def write_post(post, categories, comments):
|
|||
write_file(d + 'content', post['content'])
|
||||
write_file(d + 'content-filtered', post['content_filtered'])
|
||||
write_file(d + 'metadata', make_metadata())
|
||||
c = make_dir(d + 'comments')
|
||||
for comment in comments:
|
||||
write_comment(comment, c)
|
||||
if comments:
|
||||
c = make_dir(d + 'comments')
|
||||
for comment in comments:
|
||||
write_comment(comment, c)
|
||||
|
||||
def main(args):
|
||||
global cxn
|
||||
|
|
|
|||
Loading…
Reference in a new issue