snapshot
This commit is contained in:
Andy Wingo
parent
7fe3def61e
commit
c2580a017d
10 changed files with 381 additions and 256 deletions
|
|
@ -35,50 +35,9 @@ exec guile $GUILE_FLAGS -l $0 -e main -- "$@"
|
|||
#:use-module (ice-9 getopt-long)
|
||||
#:use-module (ice-9 threads)
|
||||
#:use-module (tekuti git)
|
||||
#:use-module (tekuti page)
|
||||
#:use-module (tekuti util)
|
||||
#:use-module (tekuti post)
|
||||
#:use-module (tekuti url)
|
||||
#:use-module (tekuti request)
|
||||
#:use-module (tekuti categories)
|
||||
#:use-module (tekuti mod-lisp)
|
||||
#:use-module (tekuti web)
|
||||
#:export (boot))
|
||||
|
||||
(define (make-post-slug y m day post)
|
||||
(url:encode (format #f "~a/~a/~a" y m (url:encode post))))
|
||||
|
||||
(define (show-post slug index)
|
||||
`(sxml . (p "hello" ,slug)))
|
||||
|
||||
(define (handle-request request index)
|
||||
((request-path-case
|
||||
request
|
||||
((POST admin new-post) page-new-post)
|
||||
((POST admin modify-post) page-modify-post)
|
||||
((POST admin new-comment) page-new-comment)
|
||||
((POST admin delete-comment) page-delete-comment)
|
||||
((POST admin delete-post) page-delete-post)
|
||||
((GET) page-index)
|
||||
((GET archives year? month? day?) page-archives)
|
||||
((GET archives year? month? day? post?) page-show-post)
|
||||
((GET debug) page-debug)
|
||||
((POST search) page-search)
|
||||
(else page-not-found))
|
||||
request index))
|
||||
|
||||
(define (maybe-reindex old-master old-index)
|
||||
(let ((master (git-rev-parse "master")))
|
||||
(values
|
||||
master
|
||||
(if (equal? master old-master)
|
||||
old-index
|
||||
(acons 'master master
|
||||
(map (lambda (k reindex)
|
||||
(cons k (reindex master)))
|
||||
(list 'posts 'categories)
|
||||
(list reindex-posts reindex-categories)))))))
|
||||
|
||||
(define *option-grammar* '((gds)
|
||||
(usage)
|
||||
(version (single-char #\v))
|
||||
|
|
@ -120,4 +79,4 @@ exec guile $GUILE_FLAGS -l $0 -e main -- "$@"
|
|||
(define (boot args)
|
||||
(let ((options (parse-options args)))
|
||||
(ensure-git-repo)
|
||||
(event-loop handle-request maybe-reindex)))
|
||||
(event-loop)))
|
||||
|
|
|
|||
|
|
@ -55,9 +55,8 @@
|
|||
(fold (lambda (sha1 parent)
|
||||
(let* ((ts (comment-timestamp sha1))
|
||||
(env (list "GIT_COMMMITTER=tekuti"
|
||||
;; this quoting is a hack
|
||||
(format #f "'GIT_COMMITTER_DATE=~a +0100'" ts)
|
||||
(format #f "'GIT_AUTHOR_DATE=~a +0100'" ts))))
|
||||
(format #f "GIT_COMMITTER_DATE=~a +0100" ts)
|
||||
(format #f "GIT_AUTHOR_DATE=~a +0100" ts))))
|
||||
(string-trim-both
|
||||
(git* (cons* "commit-tree" sha1 (if parent (list "-p" parent) '()))
|
||||
#:input "comment\n" #:env env))))
|
||||
|
|
|
|||
|
|
@ -34,6 +34,6 @@
|
|||
(define *backlog* 5)
|
||||
(define *git-dir* "~/blog.git")
|
||||
(define *git* "git")
|
||||
(define *public-url-base* "/")
|
||||
(define *public-url-base* "/blog/")
|
||||
(define *private-url-base* "/blog/")
|
||||
(define *debug* #t)
|
||||
|
|
|
|||
|
|
@ -32,16 +32,57 @@
|
|||
#:use-module (scheme kwargs)
|
||||
#:use-module (match-bind)
|
||||
#:use-module (ice-9 regex) ; hack
|
||||
#:export (git git* ensure-git-repo git-ls-tree git-ls-subdirs
|
||||
#:use-module (srfi srfi-34)
|
||||
#:use-module (srfi srfi-35)
|
||||
#:export (&git-condition git-condition? git-condition-argv
|
||||
git-condition-output git-condition-status false-if-git-error
|
||||
|
||||
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))
|
||||
|
||||
(define (call-with-pipe pipe proc)
|
||||
(unwind-protect
|
||||
(proc pipe)
|
||||
(let ((ret (close-pipe pipe)))
|
||||
(if (not (eq? (status:exit-val ret) 0))
|
||||
(throw 'pipe-error proc ret)))))
|
||||
(define-condition-type &git-condition &condition git-condition?
|
||||
(argv git-condition-argv)
|
||||
(output git-condition-output)
|
||||
(status git-condition-status))
|
||||
|
||||
(define-macro (false-if-git-error . body)
|
||||
`(,guard (c ((,git-condition? c) #f))
|
||||
,@body))
|
||||
|
||||
(define (shell:quote str)
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(display #\')
|
||||
(for-each (lambda (ch)
|
||||
(if (eqv? ch #\')
|
||||
(begin (display #\\) (display #\'))
|
||||
(display ch)))
|
||||
(string->list str))
|
||||
(display #\'))))
|
||||
|
||||
(define (run-git 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-join (map shell:quote args) " ")
|
||||
"<" input-file)
|
||||
args))
|
||||
(let* ((real-args (pk (redirect-input (prepend-env (prepend-git args)))))
|
||||
(pipe (apply open-pipe* OPEN_READ real-args))
|
||||
(output (read-delimited "" pipe))
|
||||
(ret (close-pipe pipe)))
|
||||
(case (status:exit-val ret)
|
||||
((0) (if (eof-object? output) "" output))
|
||||
(else (raise (condition (&git-condition
|
||||
(argv real-args)
|
||||
(output output)
|
||||
(status ret))))))))
|
||||
|
||||
(define (call-with-temp-file contents proc)
|
||||
(let* ((template (string-copy "/tmp/tekutiXXXXXX"))
|
||||
|
|
@ -54,23 +95,12 @@
|
|||
|
||||
(define/kwargs (git* args (input #f) (env '()))
|
||||
;; foolishness regarding env
|
||||
(define (nyam-nyam-nyam pipe)
|
||||
(read-delimited "" pipe))
|
||||
(cond
|
||||
(input
|
||||
(call-with-temp-file
|
||||
input
|
||||
(lambda (tempname)
|
||||
(let ((cmd (string-join `("env" ,@env ,*git* "--bare" ,@args "<" ,input) " ")))
|
||||
(pk cmd)
|
||||
(call-with-pipe
|
||||
(open-pipe* OPEN_BOTH "/bin/sh" "-c" cmd)
|
||||
nyam-nyam-nyam)))))
|
||||
(else
|
||||
(pk args)
|
||||
(call-with-pipe
|
||||
(apply open-pipe* OPEN_READ *git* "--bare" args)
|
||||
nyam-nyam-nyam))))
|
||||
(if input
|
||||
(call-with-temp-file
|
||||
input
|
||||
(lambda (tempname)
|
||||
(run-git env tempname args)))
|
||||
(run-git env #f args)))
|
||||
|
||||
(define (git . args)
|
||||
(git* args))
|
||||
|
|
|
|||
|
|
@ -30,10 +30,15 @@
|
|||
#:use-module (ice-9 stack-catch)
|
||||
#:use-module (sxml simple)
|
||||
#:use-module (sxml transform)
|
||||
#:use-module (tekuti url)
|
||||
#:use-module (tekuti util)
|
||||
#:use-module (tekuti config)
|
||||
#:use-module (tekuti util)
|
||||
#:use-module (tekuti git) ; rev-parse
|
||||
#:use-module (tekuti request)
|
||||
#:use-module (tekuti web)
|
||||
|
||||
;; these for their reindex methods
|
||||
#:use-module (tekuti post)
|
||||
#:use-module (tekuti categories)
|
||||
#:export (event-loop))
|
||||
|
||||
;;; thought: ignore SIGPIPE, otherwise apache dying will kill us
|
||||
|
|
@ -50,55 +55,36 @@
|
|||
(reverse (map cons keys values))
|
||||
(lp (cons k keys) (cons (read-line*) values))))))
|
||||
|
||||
(define (read-chars nchars port)
|
||||
(let ((buf (make-string nchars)))
|
||||
(read-delimited! "" buf port)
|
||||
buf))
|
||||
|
||||
(define (write-headers headers port)
|
||||
(for-each
|
||||
(lambda (k v)
|
||||
(format port "~a\n~a\n" k v))
|
||||
(map car headers) (map cdr headers))
|
||||
(lambda (pair)
|
||||
(format port "~a\n~a\n" (car pair) (cdr pair)))
|
||||
headers)
|
||||
(display "end\n" port))
|
||||
|
||||
(define xhtml-doctype
|
||||
(string-append
|
||||
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" "
|
||||
"\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n"))
|
||||
|
||||
(define (templatize request)
|
||||
(let-request request (title body)
|
||||
`(html (head
|
||||
(title ,(or title "foo")))
|
||||
(body
|
||||
,(or body '(p "what"))))))
|
||||
|
||||
(define *status-names*
|
||||
'((200 . "OK")
|
||||
(404 . "Not Found")
|
||||
(500 . "Internal Server Error")))
|
||||
|
||||
(define (status->string status)
|
||||
(format #f "~a ~a" status (or (assv-ref *status-names* status)
|
||||
"Unknown Error")))
|
||||
|
||||
(define (write-body request socket)
|
||||
(display xhtml-doctype socket)
|
||||
(sxml->xml (templatize request) socket))
|
||||
(display (rref request 'doctype "") socket)
|
||||
(sxml->xml (rref request 'sxml '()) socket))
|
||||
|
||||
(define (connection-received socket sockaddr index handle-request)
|
||||
(let ((headers (read-headers socket))
|
||||
(post-data "")) ;; blocks: (read-delimited "" socket)))
|
||||
|
||||
(dbg "~a" headers)
|
||||
(define (connection-received socket sockaddr index)
|
||||
(let* ((headers (pk (read-headers socket)))
|
||||
(post-data (read-chars (string->number
|
||||
(pk (or (assoc-ref headers "content-length")
|
||||
"0")))
|
||||
socket)))
|
||||
(catch
|
||||
#t
|
||||
(lambda ()
|
||||
(let ((res (pk (handle-request
|
||||
(make-request 'headers headers
|
||||
'post-data post-data)
|
||||
index))))
|
||||
(let-request res ((status 200))
|
||||
(write-headers `(("Status" . ,(status->string status))
|
||||
("Content-Type" . "text/html"))
|
||||
socket)
|
||||
(write-body res socket))))
|
||||
(let ((res (handle-request (make-request 'headers headers
|
||||
'post-data post-data)
|
||||
index)))
|
||||
(write-headers (rref res 'output-headers '()) socket)
|
||||
(write-body res socket)))
|
||||
(lambda args
|
||||
(write-headers '(("Status" . "500 Internal Server Error")
|
||||
("Content-Type" . "text/plain"))
|
||||
|
|
@ -121,17 +107,29 @@
|
|||
(proc socket)
|
||||
(shutdown socket 2))))
|
||||
|
||||
(define (inner-loop socket cookie index handle-request maybe-reindex)
|
||||
(define (inner-loop socket cookie index)
|
||||
(let* ((pair (accept socket))
|
||||
(fd (car pair))
|
||||
(sockaddr (cdr pair)))
|
||||
(receive
|
||||
(new-cookie new-index) (maybe-reindex cookie index)
|
||||
(pk new-cookie new-index)
|
||||
(connection-received (car pair) (cdr pair) new-index handle-request)
|
||||
(inner-loop socket new-cookie new-index handle-request maybe-reindex))))
|
||||
(connection-received (car pair) (cdr pair) new-index)
|
||||
(inner-loop socket new-cookie new-index))))
|
||||
|
||||
(define (event-loop handle-request maybe-reindex)
|
||||
(define (maybe-reindex old-master old-index)
|
||||
(let ((master (git-rev-parse "master")))
|
||||
(values
|
||||
master
|
||||
(if (equal? master old-master)
|
||||
old-index
|
||||
(acons 'master master
|
||||
(map (lambda (k reindex)
|
||||
(cons k (reindex master)))
|
||||
(list 'posts 'categories)
|
||||
(list reindex-posts reindex-categories)))))))
|
||||
|
||||
(define (event-loop)
|
||||
(with-socket
|
||||
(lambda (socket)
|
||||
(inner-loop socket #f #f handle-request maybe-reindex))))
|
||||
(inner-loop socket #f #f))))
|
||||
|
|
|
|||
144
tekuti/page.scm
144
tekuti/page.scm
|
|
@ -25,14 +25,20 @@
|
|||
;;; Code:
|
||||
|
||||
(define-module (tekuti page)
|
||||
#:use-module (tekuti config)
|
||||
#:use-module (tekuti git)
|
||||
#:use-module (tekuti post)
|
||||
#:use-module (tekuti url)
|
||||
#:use-module (tekuti request)
|
||||
#:export (page-new-post
|
||||
page-modify-post
|
||||
page-new-comment
|
||||
page-delete-comment
|
||||
page-delete-post
|
||||
#:use-module (srfi srfi-34)
|
||||
#:export (page-admin
|
||||
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-archives
|
||||
|
|
@ -42,40 +48,133 @@
|
|||
page-debug
|
||||
page-not-found))
|
||||
|
||||
(define (make-post-slug y m day post)
|
||||
(url:encode (format #f "~a/~a/~a" y m (url:encode post))))
|
||||
(define (relurl path . body)
|
||||
`(a (@ (href ,(string-append *public-url-base* path)))
|
||||
,@body))
|
||||
|
||||
(define (make-post-key . parts)
|
||||
(url:encode (format #f "~{~a~^/~}" (map url:encode parts))))
|
||||
|
||||
(define (show-post slug index)
|
||||
`(sxml . (p "hello" ,slug)))
|
||||
|
||||
(define (not-implemented request . args)
|
||||
(rcons* request
|
||||
'status 404
|
||||
'body `(p "Not implemented:" ,(rref request 'url))))
|
||||
'status 500
|
||||
'body `((h1 "Not yet implemented")
|
||||
(p "Path handler not yet implemented: "
|
||||
,(rref request 'path-str)))))
|
||||
|
||||
(define page-new-post not-implemented)
|
||||
(define page-modify-post not-implemented)
|
||||
;; thought: url mapping for post modification? probably including git sha1
|
||||
|
||||
(define (relform path . body)
|
||||
`(form (@ (method "POST")
|
||||
(action ,(string-append *public-url-base* path)))
|
||||
,@body))
|
||||
|
||||
(define (page-admin request index)
|
||||
;; here we need to be giving a dashboard view instead of this
|
||||
(define (post-headers)
|
||||
(map (lambda (post)
|
||||
;; double-encoding is a hack to trick apache
|
||||
`(li ,(relurl (string-append "admin/posts/" (url:encode (assq-ref post 'key)))
|
||||
(assq-ref post 'title))))
|
||||
(assq-ref index 'posts)))
|
||||
(rcons* request
|
||||
'body `((h2 "all your posts")
|
||||
(ul ,@(post-headers))
|
||||
(h2 "are belong to tekuti")
|
||||
,(apply
|
||||
relform
|
||||
"admin/new-post"
|
||||
`((div "title" (input (@ (name "title") (type "text"))))
|
||||
(div (textarea (@ (name "body") (rows "20") (cols "80"))
|
||||
""))
|
||||
(input (@ (type "submit") (value "new post"))))))))
|
||||
|
||||
(define (page-admin-posts request index)
|
||||
(define (post-headers)
|
||||
(map (lambda (post)
|
||||
;; double encoding is a hack
|
||||
`(div (h3 ,(relurl (string-append "admin/posts/"
|
||||
(url:encode (assq-ref post 'key)))
|
||||
(assq-ref post 'title)))
|
||||
(p "This is a post")))
|
||||
(assq-ref index 'posts)))
|
||||
(rcons* request
|
||||
'body `((h1 "all your posts are belong to tekuti")
|
||||
,@(post-headers))))
|
||||
|
||||
(define (page-admin-post request index key)
|
||||
(let ((post (post-from-key (assq-ref index 'master) key)))
|
||||
(pk 'foo post)
|
||||
(rcons* request
|
||||
'body `((h1 ,(assq-ref post 'title))
|
||||
"foo?"))))
|
||||
|
||||
(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)
|
||||
(let ((form-data (decode-form-data request)))
|
||||
(rcons* request
|
||||
'status 201 ; created
|
||||
'output-headers (acons "Location" *public-url-base*
|
||||
(rref request 'output-headers '()))
|
||||
'body `((h1 "Created")
|
||||
(p "Created new post: " ,(assoc-ref form-data "title"))
|
||||
(pre ,(assoc-ref form-data "body"))))))
|
||||
|
||||
|
||||
;; (a (@ (href ,new-url)) ,new-url)
|
||||
|
||||
(define (page-new-post request index)
|
||||
()
|
||||
not-implemented)
|
||||
(define (page-modify-post request index)
|
||||
()
|
||||
not-implemented)
|
||||
(define page-new-comment not-implemented)
|
||||
(define page-delete-comment not-implemented)
|
||||
(define page-delete-post not-implemented)
|
||||
(define page-index not-implemented)
|
||||
|
||||
(define (page-show-post request index year month day post)
|
||||
(let ((slug (make-post-slug year month day post)))
|
||||
(let ((tree (git-rev-parse (string-append (assq-ref index 'master) ":" slug))))
|
||||
(let ((post (post-from-tree slug tree)))
|
||||
`((title . "post")
|
||||
(sxml . (pre ,(with-output-to-string
|
||||
(lambda ()
|
||||
(write post))))))))))
|
||||
(let ((slug (make-post-key year month day post)))
|
||||
(cond
|
||||
((false-if-git-error
|
||||
(git-rev-parse (string-append (assq-ref index 'master) ":" slug)))
|
||||
=> (lambda (tree)
|
||||
(let ((post (post-from-tree slug tree)))
|
||||
(rcons* request
|
||||
'title "post"
|
||||
'body `((pre ,(with-output-to-string
|
||||
(lambda ()
|
||||
(write post)))))))))
|
||||
(else
|
||||
(page-not-found request index)))))
|
||||
|
||||
(define page-archives not-implemented)
|
||||
|
||||
(define (page-debug request index)
|
||||
(rcons* request
|
||||
'title "hello"
|
||||
'body `(div
|
||||
(p "hello world!")
|
||||
'body `((p "hello world!")
|
||||
(table
|
||||
(tr (th "header") (th "value"))
|
||||
,@(map (lambda (pair)
|
||||
|
|
@ -85,7 +184,8 @@
|
|||
(define page-search not-implemented)
|
||||
|
||||
(define (page-not-found request index)
|
||||
(pk request)
|
||||
(rcons* request
|
||||
'status 404
|
||||
'body `(p "Not found:" ,(rref request 'url))))
|
||||
|
||||
'body `((h1 "Page not found")
|
||||
(p "Unknown path: " ,(rref request 'path-str)))))
|
||||
|
|
|
|||
|
|
@ -31,13 +31,13 @@
|
|||
#:use-module (tekuti comment)
|
||||
#:use-module (tekuti git)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:export (reindex-posts post-from-tree post-categories all-published-posts))
|
||||
#:export (reindex-posts post-from-tree post-from-key post-categories all-published-posts))
|
||||
|
||||
;; introducing new assumption: post urls like yyyy/dd/mm/post; post dirnames the urlencoded post
|
||||
|
||||
;; perhaps push this processing into post-from-tree
|
||||
(define (post-published? post-alist)
|
||||
(equal? (assq-ref post-alist 'status) "published"))
|
||||
(equal? (assq-ref post-alist 'status) "publish"))
|
||||
|
||||
(define (post-timestamp post-alist)
|
||||
(or (assq-ref post-alist 'timestamp) #f))
|
||||
|
|
@ -47,12 +47,18 @@
|
|||
|
||||
(define *post-spec*
|
||||
`((timestamp . ,string->number)
|
||||
(categories . ,(lambda (v) (map string-trim-both (string-split v #\,))))))
|
||||
(categories . ,(lambda (v) (map string-trim-both (string-split v #\,))))
|
||||
(title . ,identity)))
|
||||
|
||||
(define (post-from-tree encoded-name sha1)
|
||||
(acons 'url encoded-name
|
||||
(acons 'key encoded-name
|
||||
(parse-metadata (string-append sha1 ":" "metadata") *post-spec*)))
|
||||
|
||||
(define (post-from-key master key)
|
||||
(let ((pairs (git-ls-subdirs master key)))
|
||||
(and (= (length pairs) 1)
|
||||
(post-from-tree key (cdar pairs)))))
|
||||
|
||||
(define (all-posts master)
|
||||
(map (lambda (pair)
|
||||
(post-from-tree (car pair) (cdr pair)))
|
||||
|
|
|
|||
|
|
@ -25,27 +25,60 @@
|
|||
;;; Code:
|
||||
|
||||
(define-module (tekuti request)
|
||||
#:use-module ((srfi srfi-1) #:select (find-tail))
|
||||
#:use-module ((srfi srfi-1) #:select (find-tail fold))
|
||||
#:use-module (scheme kwargs)
|
||||
#:use-module (tekuti util)
|
||||
#:use-module (tekuti url)
|
||||
#:use-module (tekuti config)
|
||||
#:use-module (tekuti web)
|
||||
#:export (make-request rcons rcons* rref let-request
|
||||
#:export (make-request rcons rcons* rpush rpush* rref let-request
|
||||
request-path-case))
|
||||
|
||||
(define (header-ref headers key default)
|
||||
(let ((pair (assoc key headers)))
|
||||
(if pair
|
||||
(cdr pair)
|
||||
default)))
|
||||
|
||||
(define *request-initializers*
|
||||
`((path . ,(lambda (r)
|
||||
(let ((private-url-path (url:path-split *private-url-base*))
|
||||
(path (header-ref (rref r 'headers '())
|
||||
"url" *private-url-base*)))
|
||||
(let* ((tail (list-head-match private-url-path
|
||||
(url:path-split path)
|
||||
(length private-url-path))))
|
||||
(or tail (error "unexpected path" path *private-url-base*))
|
||||
tail))))
|
||||
(path-str . ,(lambda (r)
|
||||
(url:path-join (rref r 'path '()))))
|
||||
(method . ,(lambda (r)
|
||||
(header-ref (rref r 'headers '()) "method" "GET")))))
|
||||
|
||||
(define (make-request . keys-and-values)
|
||||
(apply rcons* '() keys-and-values))
|
||||
(fold (lambda (pair r)
|
||||
(rcons (car pair) ((cdr pair) r) r))
|
||||
(apply rcons* '() keys-and-values)
|
||||
*request-initializers*))
|
||||
|
||||
(define (rcons k v request)
|
||||
(or (symbol? k) (error "request keys should be symbols"))
|
||||
(acons k v request))
|
||||
|
||||
(define (rcons* request . keys-and-values)
|
||||
(let lp ((request '()) (kv keys-and-values))
|
||||
(let lp ((request request) (kv keys-and-values))
|
||||
(if (null? kv)
|
||||
request
|
||||
(lp (rcons (car kv) (cadr kv) request) (cddr kv)))))
|
||||
|
||||
(define (rpush k v request)
|
||||
(rcons k (cons v (rref request k '())) request))
|
||||
|
||||
(define (rpush* request . keys-and-values)
|
||||
(let lp ((request request) (kv keys-and-values))
|
||||
(if (null? kv)
|
||||
request
|
||||
(lp (rpush (car kv) (cadr kv) request) (cddr kv)))))
|
||||
|
||||
(define/kwargs (rref request k (default #f) (default-proc #f))
|
||||
(let ((pair (assq k request)))
|
||||
(cond
|
||||
|
|
@ -68,6 +101,10 @@
|
|||
(let ((path-var (gensym)))
|
||||
(define (optional-argument? arg)
|
||||
(eqv? (string-ref arg (1- (string-length arg))) #\?))
|
||||
(define (required-argument? arg)
|
||||
(eqv? (string-ref arg (1- (string-length arg))) #\!))
|
||||
(define (output-argument? arg)
|
||||
(or (optional-argument? arg) (required-argument? arg)))
|
||||
(define (process-clause clause)
|
||||
(or (list-has-length? clause 2) (error "foo"))
|
||||
(if (eq? (car clause) 'else)
|
||||
|
|
@ -75,40 +112,46 @@
|
|||
(let ((pat (map symbol->string (car clause)))
|
||||
(proc (cadr clause)))
|
||||
(cond
|
||||
((find-tail optional-argument? pat)
|
||||
((find-tail output-argument? pat)
|
||||
=> (lambda (tail)
|
||||
(define test
|
||||
(let* ((len (length pat))
|
||||
(nopt (length tail))
|
||||
(nreq (- len nopt)))
|
||||
(let* ((npat (length pat))
|
||||
(ntail (length tail))
|
||||
(req (find-tail required-argument? tail))
|
||||
(opt (find-tail optional-argument? tail))
|
||||
(nopt (if opt (length opt) 0))
|
||||
(nreq (if req (- (length req) nopt) 0)))
|
||||
(lambda (path)
|
||||
(let ((pathtail (list-head-match pat path nreq)))
|
||||
(if (and pathtail (<= (length pathtail) nopt))
|
||||
pathtail
|
||||
(let ((pathtail (list-head-match pat path (- npat ntail))))
|
||||
(pk pat npat ntail req opt nopt nreq path pathtail)
|
||||
(if (and pathtail (>= (length pathtail) nreq)
|
||||
(<= (length pathtail) (+ nreq nopt)))
|
||||
(append pathtail
|
||||
(make-list (- (+ nreq nopt) (length pathtail)) #f))
|
||||
#f)))))
|
||||
`((,test ,path-var)
|
||||
=> (lambda (optargs)
|
||||
=> (lambda (outargs)
|
||||
(lambda args
|
||||
(apply ,proc (append args optargs)))))))
|
||||
(apply ,proc (append args outargs)))))))
|
||||
(else
|
||||
`((equal? ,path-var ',pat) ,proc))))))
|
||||
`(let ((,path-var ,path))
|
||||
(cond ,@(map process-clause clauses)))))
|
||||
|
||||
;; hmm, style mismatch between these let macros
|
||||
(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))
|
||||
2 request keys-and-procs))
|
||||
|
||||
(define-macro (request-path-case request . clauses)
|
||||
(define (make-path request)
|
||||
(let ((private-url-path (url-path-split *private-url-base*)))
|
||||
(let-request request (headers)
|
||||
(let-headers headers ((method "method") (path "url"))
|
||||
(let* ((tail (list-head-match private-url-path
|
||||
(url-path-split path)
|
||||
(length private-url-path))))
|
||||
(if (not tail)
|
||||
(error "unexpected path" path *private-url-base*)
|
||||
(cons method tail)))))))
|
||||
(let ((req-sym (gensym)))
|
||||
`(let* ((,req-sym ,request))
|
||||
(,path-proc-case
|
||||
(,make-path ,req-sym)
|
||||
,@clauses))))
|
||||
`(,path-proc-case
|
||||
(,let-request ,request (method path)
|
||||
(cons method path))
|
||||
,@clauses))
|
||||
|
|
|
|||
|
|
@ -48,6 +48,7 @@
|
|||
;; encoding methods (e.g. a url-scheme-reserved-char-alist)
|
||||
|
||||
(define-module (tekuti url)
|
||||
#:use-module ((srfi srfi-1) #:select (filter))
|
||||
#:use-module (ice-9 regex))
|
||||
|
||||
;; `url:scheme' is an unfortunate term, but it is the technical
|
||||
|
|
@ -156,8 +157,10 @@
|
|||
(display (number->string (char->integer ch) 16)))))
|
||||
(string->list str)))))
|
||||
|
||||
(define safe-chars
|
||||
'(#\$ #\- #\_ #\. #\+ #\! #\* #\' #\( #\) #\, #\; #\/ #\? #\: #\@ #\& #\=))
|
||||
(define special-chars
|
||||
(string->list "$-_.+!*'()"))
|
||||
(define reserved-chars
|
||||
(string->list ";/?:@&="))
|
||||
|
||||
(define (safe-char? ch)
|
||||
;; ``Thus, only alphanumerics, the special characters "$-_.+!*'(),", and
|
||||
|
|
@ -165,6 +168,13 @@
|
|||
;; unencoded within a URL.'' RFC 1738, #2.2.
|
||||
(or (char-alphabetic? ch)
|
||||
(char-numeric? ch)
|
||||
(memv ch safe-chars)))
|
||||
(memv ch special-chars)))
|
||||
|
||||
(define-public (url:path-split path)
|
||||
(filter (lambda (x) (not (string-null? x)))
|
||||
(map url:decode (string-split path #\/))))
|
||||
|
||||
(define-public (url:path-join path)
|
||||
(string-join (map url:encode path) "/"))
|
||||
|
||||
;;; www/url.scm ends here
|
||||
|
|
|
|||
140
tekuti/web.scm
140
tekuti/web.scm
|
|
@ -28,31 +28,37 @@
|
|||
#:use-module (sxml simple)
|
||||
#:use-module (sxml transform)
|
||||
#:use-module (tekuti url)
|
||||
#:use-module (tekuti config)
|
||||
#:use-module (tekuti request)
|
||||
#:use-module (tekuti template)
|
||||
#:use-module (tekuti page)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:export (read-headers write-headers let-headers
|
||||
visible-error unimplemented
|
||||
url-path-split url-path-case url-relative-path-case))
|
||||
#:export (let-headers header-ref
|
||||
handle-request))
|
||||
|
||||
(define (read-headers socket)
|
||||
(define (read-line*)
|
||||
(let ((line (read-line socket)))
|
||||
(if (eof-object? line)
|
||||
(error "unexpected eof")
|
||||
line)))
|
||||
(let lp ((keys '()) (values '()))
|
||||
(let ((k (read-line*)))
|
||||
(if (string=? k "end")
|
||||
(reverse (map cons keys values))
|
||||
(lp (cons k keys) (cons (read-line*) values))))))
|
||||
(define *status-names*
|
||||
'((200 . "OK")
|
||||
(201 . "Created")
|
||||
(404 . "Not Found")
|
||||
(500 . "Internal Server Error")))
|
||||
|
||||
(define (write-headers-headers headers port)
|
||||
(for-each
|
||||
(lambda (k v)
|
||||
(format port "~a\n~a\n" k v))
|
||||
(map car headers) (map cdr headers))
|
||||
(display "end\n" port))
|
||||
(define (status->string status)
|
||||
(format #f "~a ~a" status (or (assv-ref *status-names* status)
|
||||
"Unknown Error")))
|
||||
|
||||
(define xhtml-doctype
|
||||
(string-append
|
||||
"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" "
|
||||
"\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n"))
|
||||
|
||||
(define (request-output-headers request)
|
||||
(let-request request ((output-headers '())
|
||||
(status 200)
|
||||
(content-type "text/html"))
|
||||
(acons "Status" (status->string status)
|
||||
(acons "Content-Type" content-type
|
||||
output-headers))))
|
||||
|
||||
;;; useless macro
|
||||
(define-macro (let-headers headers bindings . body)
|
||||
(let ((headers-var (gensym)))
|
||||
`(let ((,headers-var ,headers))
|
||||
|
|
@ -63,64 +69,38 @@
|
|||
bindings))
|
||||
,@body))))
|
||||
|
||||
(define (visible-error . html-body)
|
||||
(throw 'visible-error 404 html-body))
|
||||
(define (finalize request)
|
||||
;; update output headers
|
||||
;; templatize body
|
||||
(rpush* (rcons* request
|
||||
'sxml (templatize request)
|
||||
'doctype xhtml-doctype)
|
||||
'output-headers
|
||||
(cons "Status" (status->string (rref request 'status 200)))
|
||||
'output-headers
|
||||
(cons "Content-Type" (rref request 'content-type "text/html"))))
|
||||
|
||||
(define (url-path-split path)
|
||||
(filter (lambda (x) (not (string-null? x)))
|
||||
(map url:decode (string-split path #\/))))
|
||||
(define (choose-handler request)
|
||||
(request-path-case
|
||||
request
|
||||
((GET admin) page-admin)
|
||||
((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)
|
||||
((POST admin delete-comment comment-key!) page-admin-delete-comment)
|
||||
((POST admin delete-post post-key!) page-admin-delete-post)
|
||||
|
||||
((GET) page-index)
|
||||
((GET archives year? month? day?) page-archives)
|
||||
((GET archives year! month! day! post!) page-show-post)
|
||||
((GET debug) page-debug)
|
||||
((POST search) page-search)
|
||||
(else page-not-found)))
|
||||
|
||||
(define-macro (url-path-case method path . clauses)
|
||||
(define (optional-argument arg)
|
||||
(let ((len (string-length arg)))
|
||||
(and (eqv? (string-ref arg (1- len)) #\?)
|
||||
(substring arg 0 (1- len)))))
|
||||
(let ((method-sym (gensym)) (path-parts (gensym)))
|
||||
(define (process-clauses)
|
||||
(map (lambda (clause)
|
||||
(let ((pattern (car clause)) (body (cdr clause)))
|
||||
(cond
|
||||
((eq? pattern 'else)
|
||||
clause)
|
||||
(else
|
||||
(let* ((method-match (car pattern))
|
||||
(parts-match (map symbol->string (cdr pattern)))
|
||||
(nargs (length parts-match))
|
||||
(opt (or (find-tail optional-argument parts-match) '()))
|
||||
(nopt (length opt))
|
||||
(nreq (- nargs nopt)))
|
||||
(cond
|
||||
((null? opt)
|
||||
`((and (eq? ,method-sym ',method-match)
|
||||
(equal? ,path-parts ',parts-match))
|
||||
,@body))
|
||||
(else
|
||||
`((and (eq? ,method-sym ',method-match)
|
||||
(equal? (list-head ,path-parts ,nreq)
|
||||
',(list-head parts-match nreq))
|
||||
(<= (length ,path-parts) ,nargs))
|
||||
(apply
|
||||
(lambda ,(map string->symbol (map optional-argument opt))
|
||||
,@body)
|
||||
(let ((tail (list-tail ,path-parts ,nreq)))
|
||||
(append tail (make-list (- ,nopt (length tail)) #f))))))))))))
|
||||
clauses))
|
||||
`(let ((,method-sym (string->symbol ,method))
|
||||
(,path-parts (url-path-split ,path)))
|
||||
(cond ,@(process-clauses)))))
|
||||
|
||||
(define-macro (url-relative-path-case method path . clauses)
|
||||
(let ((infix (map string->symbol (url-path-split *private-url-base*))))
|
||||
(define (munge-clause clause)
|
||||
(cond
|
||||
((eq? (car clause) 'else) clause)
|
||||
(else
|
||||
(let ((method (caar clause))
|
||||
(parts (cdar clause))
|
||||
(body (cdr clause)))
|
||||
`((,method ,@infix ,@parts) ,@body)))))
|
||||
`(url-path-case ,method ,path
|
||||
,@(map munge-clause clauses))))
|
||||
|
||||
(define (unimplemented . args)
|
||||
(apply throw 'unimplemented args))
|
||||
(define (handle-request request index)
|
||||
(let ((handler (choose-handler request)))
|
||||
(pk (finalize (handler request index)))))
|
||||
|
|
|
|||
Loading…
Reference in a new issue