big change to use new (web server) infrastructure
Change to use (web server) instead of our own loop. This also means that requests are request objects from (web request), and responses are from (web response). * tekuti/boot.scm (boot): Run the main loop from (tekuti web). * tekuti/config.scm (*port*, *backlog*, *public-url-base*) (*private-url-base*): Remove extraneous config vars. * tekuti/mod-lisp.scm: Rewrite to be a (web server) server-impl. Not tested very well. * tekuti/page-helpers.scm (respond): New procedure, now the primary way to respond to a request. (relurl, rellink): Take path components as a list, and encode the parts when making the resulting URL. All callers changed. * tekuti/page.scm: Change all handlers to take an additional `body' argument, to respond using `respond', and to use the new `relurl' / `rellink' protocol. * tekuti/request.scm: Eviscerate, leaving only pieces that deal in request objects from `(web request)'. * tekuti/web.scm: Update to use (weeb server).
This commit is contained in:
Andy Wingo
parent
1152ccf68a
commit
befda5cb02
7 changed files with 509 additions and 448 deletions
|
|
@ -1,5 +1,5 @@
|
|||
;; Tekuti
|
||||
;; Copyright (C) 2008 Andy Wingo <wingo at pobox dot com>
|
||||
;; Copyright (C) 2008, 2010 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
|
||||
|
|
@ -30,7 +30,7 @@
|
|||
#:use-module (ice-9 format)
|
||||
#:use-module (ice-9 getopt-long)
|
||||
#:use-module (tekuti git)
|
||||
#:use-module (tekuti mod-lisp)
|
||||
#:use-module (tekuti web)
|
||||
#:export (boot))
|
||||
|
||||
(define *option-grammar* '((listen)
|
||||
|
|
@ -80,4 +80,4 @@
|
|||
(set-current-module config-module)
|
||||
(primitive-load config))))))
|
||||
(ensure-git-repo)
|
||||
(event-loop)))
|
||||
(main-loop)))
|
||||
|
|
|
|||
|
|
@ -27,20 +27,15 @@
|
|||
(define-module (tekuti config)
|
||||
#:use-module (tekuti util)
|
||||
#:use-module ((sxml ssax) #:select (define-parsed-entity!))
|
||||
#:export (*host* *port* *backlog* *git-dir* *git* *public-url-base*
|
||||
*private-url-base* *debug* *admin-user* *admin-pass*
|
||||
#:export (*host* *git-dir* *git* *debug* *admin-user* *admin-pass*
|
||||
*css-file* *navbar-links* *navbar-infix*
|
||||
*title* *subtitle* *name*
|
||||
*public-path-base* *private-path-base*
|
||||
*server-impl* *server-impl-args*))
|
||||
|
||||
(define *host* "127.0.0.1")
|
||||
(define *port* 8081)
|
||||
(define *backlog* 5)
|
||||
(define *git-dir* "~/blog.git")
|
||||
(define *git* "git")
|
||||
(define *public-url-base* "/")
|
||||
(define *private-url-base* "/")
|
||||
(define *public-path-base* '())
|
||||
(define *private-path-base* '())
|
||||
(define *css-file* "/base.css")
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
;; Tekuti
|
||||
;; Copyright (C) 2008 Andy Wingo <wingo at pobox dot com>
|
||||
;; Copyright (C) 2008, 2010 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
|
||||
|
|
@ -20,102 +20,196 @@
|
|||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; This is the main script that will launch tekuti.
|
||||
;; Web server implementation for mod-lisp.
|
||||
;;
|
||||
;;; Code:
|
||||
|
||||
(define-module (tekuti mod-lisp)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:use-module (tekuti config)
|
||||
#:use-module (tekuti util)
|
||||
#:use-module (tekuti index)
|
||||
#:use-module (tekuti request)
|
||||
#:use-module (tekuti web)
|
||||
#:export (event-loop))
|
||||
#:use-module (system repl error-handling)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (web http)
|
||||
#:use-module (web request)
|
||||
#:use-module (web response)
|
||||
#:use-module (web server))
|
||||
|
||||
|
||||
;;; FIXME: ignore SIGPIPE, otherwise apache dying will kill us
|
||||
|
||||
(define (read-headers socket)
|
||||
(define *mod-lisp-headers* (make-hash-table))
|
||||
|
||||
(define (define-mod-lisp-header! sym name parser)
|
||||
(hash-set! *mod-lisp-headers* name (cons sym parser)))
|
||||
|
||||
(define (mod-lisp-sym-and-parser name)
|
||||
(hash-ref *mod-lisp-headers* name))
|
||||
|
||||
(define-mod-lisp-header! 'server-protocol
|
||||
"server-protocol"
|
||||
parse-http-version)
|
||||
|
||||
(define-mod-lisp-header! 'method
|
||||
"method"
|
||||
parse-http-method)
|
||||
|
||||
(define-mod-lisp-header! 'url
|
||||
"URL"
|
||||
parse-request-uri)
|
||||
|
||||
(define-mod-lisp-header! 'server-ip-addr
|
||||
"server-ip-addr"
|
||||
identity)
|
||||
|
||||
(define-mod-lisp-header! 'server-ip-port
|
||||
"server-ip-port"
|
||||
string->number)
|
||||
|
||||
(define-mod-lisp-header! 'remote-ip-addr
|
||||
"remote-ip-addr"
|
||||
identity)
|
||||
|
||||
(define-mod-lisp-header! 'remote-ip-port
|
||||
"remote-ip-port"
|
||||
string->number)
|
||||
|
||||
(define-mod-lisp-header! 'server-id
|
||||
"server-id"
|
||||
identity)
|
||||
|
||||
(define-mod-lisp-header! 'server-ip-addr
|
||||
"server-ip-addr"
|
||||
identity)
|
||||
|
||||
(define-mod-lisp-header! 'server-baseversion
|
||||
"server-baseversion"
|
||||
identity)
|
||||
|
||||
(define-mod-lisp-header! 'modlisp-version
|
||||
"modlisp-version"
|
||||
identity)
|
||||
|
||||
(define-mod-lisp-header! 'modlisp-major-version
|
||||
"modlisp-major-version"
|
||||
string->number)
|
||||
|
||||
(define (read-headers/mod-lisp socket)
|
||||
(define (read-line*)
|
||||
(let ((line (read-line socket)))
|
||||
(if (eof-object? line)
|
||||
(error "unexpected eof")
|
||||
line)))
|
||||
(let lp ((keys '()) (values '()))
|
||||
(let lp ((headers '()) (meta '()))
|
||||
(let ((k (read-line*)))
|
||||
(if (string=? k "end")
|
||||
(reverse (map cons keys values))
|
||||
(lp (cons (string-downcase k) keys)
|
||||
(cons (read-line*) values))))))
|
||||
(values (reverse! headers) (reverse! meta))
|
||||
(let ((sym-and-parser (mod-lisp-sym-and-parser k))
|
||||
(v (read-line*)))
|
||||
(if sym-and-parser
|
||||
(lp headers
|
||||
(acons (car sym-and-parser)
|
||||
((cdr sym-and-parser) v)
|
||||
meta))
|
||||
(call-with-values (lambda () (parse-header k v))
|
||||
(lambda (k v)
|
||||
(lp (acons k v headers) meta)))))))))
|
||||
|
||||
(define (read-chars nchars port)
|
||||
(let ((buf (make-string nchars)))
|
||||
(read-delimited! "" buf port)
|
||||
buf))
|
||||
(define (read-request/mod-lisp port)
|
||||
(call-with-values (lambda () (read-headers/mod-lisp port))
|
||||
(lambda (headers meta)
|
||||
(build-request
|
||||
#:method (assq-ref meta 'method)
|
||||
#:uri (assq-ref meta 'url)
|
||||
#:version (assq-ref meta 'url)
|
||||
#:headers headers
|
||||
#:meta meta
|
||||
#:port port))))
|
||||
|
||||
(define (write-headers headers port)
|
||||
(define (write-header/mod-lisp name val port)
|
||||
(if (string? name)
|
||||
;; assume that it's a header we don't know about...
|
||||
(begin
|
||||
(display name port) (newline port)
|
||||
(display val port) (newline port))
|
||||
(let ((decl (lookup-header-decl name)))
|
||||
(if (not decl)
|
||||
(error "Unknown header" name)
|
||||
(begin
|
||||
(display (header-decl-name decl) port) (newline port)
|
||||
((header-decl-writer decl) val port) (newline port))))))
|
||||
|
||||
(define (write-response-line/mod-lisp code phrase port)
|
||||
(write-header/mod-lisp "Status"
|
||||
(string-append (number->string code) " " phrase)
|
||||
port))
|
||||
|
||||
(define (write-headers/mod-lisp headers port)
|
||||
(for-each
|
||||
(lambda (pair)
|
||||
(format port "~a\n~a\n" (car pair) (cdr pair)))
|
||||
headers)
|
||||
(display "end\n" port))
|
||||
(lambda (pair)
|
||||
(write-header (car pair) (cdr pair) port))
|
||||
headers))
|
||||
|
||||
(define (write-body request socket)
|
||||
((rref request 'output error) socket))
|
||||
(define (write-response/mod-lisp r port)
|
||||
(write-response-line/mod-lisp (response-code r)
|
||||
(response-reason-phrase r) port)
|
||||
(write-headers (response-headers r) port)
|
||||
(display "end" port) (newline port)
|
||||
(if (eq? port (response-port r))
|
||||
r
|
||||
(build-response #:version (response-version r)
|
||||
#:code (response-code r)
|
||||
#:reason-phrase (response-reason-phrase r)
|
||||
#:headers (response-headers r)
|
||||
#:port port)))
|
||||
|
||||
(define (request-output-headers request)
|
||||
(rref request 'output-headers '()))
|
||||
(define (make-default-socket family addr port)
|
||||
(let ((sock (socket PF_INET SOCK_STREAM 0)))
|
||||
(setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
|
||||
(bind sock family addr port)
|
||||
sock))
|
||||
|
||||
(define (connection-received socket sockaddr index)
|
||||
(let* ((headers (read-headers socket))
|
||||
(post-data (read-chars (string->number
|
||||
(or (assoc-ref headers "content-length")
|
||||
"0"))
|
||||
socket)))
|
||||
(catch
|
||||
#t
|
||||
(lambda ()
|
||||
(let ((res (handle-request (make-request 'headers headers
|
||||
'post-data post-data)
|
||||
index)))
|
||||
(write-headers (request-output-headers res) socket)
|
||||
(write-body res socket)))
|
||||
(lambda args
|
||||
(write-headers '(("Status" . "500 Internal Server Error")
|
||||
("Content-Type" . "text/plain"))
|
||||
socket)
|
||||
(display "Sorry bub, had an error. Please let the admin know. Thanks!\n"
|
||||
socket)
|
||||
(write headers) (newline)
|
||||
(write args) (newline)
|
||||
(backtrace))
|
||||
(lambda args
|
||||
(fluid-set! the-last-stack (make-stack #t 2 0))
|
||||
(apply throw args)))
|
||||
|
||||
(close-port socket)))
|
||||
;; -> server
|
||||
(define* (mod-lisp-open #:key
|
||||
(host #f)
|
||||
(family AF_INET)
|
||||
(addr (if host
|
||||
(inet-pton family host)
|
||||
INADDR_LOOPBACK))
|
||||
(port 8080)
|
||||
(socket (make-default-socket family addr port)))
|
||||
(listen socket 5)
|
||||
socket)
|
||||
|
||||
(define (with-socket proc)
|
||||
(pk 'listening)
|
||||
(let ((socket (socket PF_INET SOCK_STREAM 0)))
|
||||
(setsockopt socket SOL_SOCKET SO_REUSEADDR 1)
|
||||
(bind socket AF_INET (inet-aton *host*) *port*)
|
||||
(listen socket *backlog*)
|
||||
(unwind-protect
|
||||
(proc socket)
|
||||
(shutdown socket 2))))
|
||||
;; For mod-lisp, we don't do keep-alive.
|
||||
(define (keep-alive? response)
|
||||
#f)
|
||||
|
||||
(define (inner-loop socket index)
|
||||
(let* ((pair (accept socket))
|
||||
(fd (car pair))
|
||||
(sockaddr (cdr pair))
|
||||
(new-index (maybe-reindex index)))
|
||||
(connection-received fd sockaddr (cdr new-index))
|
||||
(inner-loop socket new-index)))
|
||||
;; -> (keep-alive client request body | keep-alive #f #f #f)
|
||||
(define (mod-lisp-read server keep-alive)
|
||||
(let* ((client (accept server))
|
||||
(req (read-request/mod-lisp (car client)))
|
||||
(body-str (read-request-body/latin-1 req)))
|
||||
(values keep-alive (car client) req body-str)))
|
||||
|
||||
(define (event-loop)
|
||||
(with-socket
|
||||
(lambda (socket)
|
||||
(format #t "entering inner loop\n")
|
||||
(inner-loop socket (read-index)))))
|
||||
;; -> (#f | client)
|
||||
(define (mod-lisp-write server client response body)
|
||||
(let ((response (write-response/mod-lisp response client)))
|
||||
(cond
|
||||
((not body)) ; pass
|
||||
((string? body)
|
||||
(write-response-body/latin-1 response body))
|
||||
((bytevector? body)
|
||||
(write-response-body/bytevector response body))
|
||||
(else
|
||||
(error "Expected a string or bytevector for body" body)))
|
||||
(close-port (response-port response))
|
||||
#f))
|
||||
|
||||
;; -> unspecified values
|
||||
(define (mod-lisp-close server)
|
||||
(close-port server))
|
||||
|
||||
(define-server-impl mod-lisp
|
||||
mod-lisp-open
|
||||
mod-lisp-read
|
||||
mod-lisp-write
|
||||
mod-lisp-close)
|
||||
|
|
|
|||
|
|
@ -25,31 +25,116 @@
|
|||
;;; Code:
|
||||
|
||||
(define-module (tekuti page-helpers)
|
||||
#:use-module (sxml simple)
|
||||
#:use-module (web uri)
|
||||
#:use-module (web http)
|
||||
#:use-module (web response)
|
||||
#:use-module (tekuti config)
|
||||
#:use-module (tekuti util)
|
||||
#:use-module (tekuti git)
|
||||
#:use-module (tekuti post)
|
||||
#:use-module (tekuti tags)
|
||||
#:use-module (tekuti comment)
|
||||
#:use-module (tekuti url)
|
||||
#:use-module (tekuti request)
|
||||
#:use-module (tekuti template)
|
||||
#:use-module (srfi srfi-19)
|
||||
#:export (relurl rellink redirect post-url
|
||||
#:export (respond
|
||||
relurl rellink
|
||||
post-url
|
||||
published-posts
|
||||
post-editing-form
|
||||
sidebar-ul top-tags tag-cloud
|
||||
main-sidebar post-sidebar related-tag-cloud
|
||||
post-link admin-post-link admin-post-redirect
|
||||
post-link admin-post-url admin-post-link
|
||||
show-post with-authentication
|
||||
find-posts-matching
|
||||
atom-header atom-entry))
|
||||
|
||||
(define (relurl . paths)
|
||||
(apply string-append *public-url-base* paths))
|
||||
(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 (rellink path . body)
|
||||
`(a (@ (href ,(relurl path)))
|
||||
,@body))
|
||||
(define (acons* tail . args)
|
||||
(let lp ((tail tail) (args args))
|
||||
(if (null? args)
|
||||
tail
|
||||
(let ((k (car args)) (v (cadr args)))
|
||||
(lp (if v (acons k v tail) tail)
|
||||
(cddr args))))))
|
||||
|
||||
(define* (respond #:optional body #:key
|
||||
redirect
|
||||
(status (if redirect 302 200))
|
||||
(title *title*)
|
||||
last-modified
|
||||
(doctype xhtml-doctype)
|
||||
(content-type-params '(("charset" . "utf-8")))
|
||||
(content-type "text/html")
|
||||
(extra-headers '())
|
||||
(sxml (templatize #:title title #:body body)))
|
||||
(values (build-response
|
||||
#:code status
|
||||
#:headers (acons*
|
||||
extra-headers
|
||||
'location redirect
|
||||
'last-modified last-modified
|
||||
'content-type (cons content-type content-type-params)))
|
||||
(lambda (port)
|
||||
(if sxml
|
||||
(begin
|
||||
(display doctype port)
|
||||
(sxml->xml sxml port))))))
|
||||
|
||||
(define (unparse-www-form-urlencoded alist)
|
||||
(string-join (map (lambda (pair)
|
||||
(if (cdr pair)
|
||||
(string-append (uri-encode (car pair))
|
||||
"="
|
||||
(uri-encode (cdr pair)))
|
||||
(uri-encode (car pair))))
|
||||
alist)
|
||||
"&"))
|
||||
|
||||
(define* (relative-url uri path-components #:key query fragment)
|
||||
(unparse-uri
|
||||
(build-uri (uri-scheme uri)
|
||||
#:userinfo (uri-userinfo uri) #:host (uri-host uri)
|
||||
#:port (uri-port uri)
|
||||
#:path (encode-and-join-uri-path
|
||||
(append (split-and-decode-uri-path (uri-path uri))
|
||||
path-components))
|
||||
#:query (and=> query unparse-www-form-urlencoded)
|
||||
#:fragment fragment)))
|
||||
|
||||
(define* (relative-link uri path-components text #:key query fragment)
|
||||
`(a (@ (href ,(relative-url uri path-components #:query query
|
||||
#:fragment fragment)))
|
||||
,@text))
|
||||
|
||||
(define* (relative-path base path-components #:key query fragment)
|
||||
(let ((path (encode-and-join-uri-path (append base path-components)))
|
||||
(query (and=> query unparse-www-form-urlencoded)))
|
||||
(if query
|
||||
(if fragment
|
||||
(string-append "/" path "?" query "#" fragment)
|
||||
(string-append "/" path "?" query))
|
||||
(if fragment
|
||||
(string-append "/" path "#" fragment)
|
||||
(string-append "/" path)))))
|
||||
|
||||
(define* (relative-path-link base path-components text #:key query fragment)
|
||||
`(a (@ (href ,(relative-path base path-components #:query query
|
||||
#:fragment fragment)))
|
||||
,text))
|
||||
|
||||
(define* (relurl path-components #:key query fragment)
|
||||
(relative-path *public-path-base* path-components #:query query
|
||||
#:fragment fragment))
|
||||
|
||||
(define* (rellink path-components text #:key query fragment)
|
||||
(relative-path-link *public-path-base* path-components text #:query query
|
||||
#:fragment fragment))
|
||||
|
||||
(define (published-posts index n)
|
||||
(filter-mapn (lambda (post)
|
||||
|
|
@ -60,10 +145,9 @@
|
|||
(define (post-editing-form post)
|
||||
`(div
|
||||
(form (@ (method "POST")
|
||||
(action ,(relurl (if post
|
||||
(string-append "admin/modify-post/"
|
||||
(url:encode (post-key post)))
|
||||
"admin/new-post"))))
|
||||
(action ,(if post
|
||||
(relurl `("admin" "modify-post" ,(post-key post)))
|
||||
(relurl '("admin" "new-post")))))
|
||||
(p (input (@ (name "title") (type "text")
|
||||
(value ,(if post (post-title post) ""))))
|
||||
(label (@ (for "title")) " <- title"))
|
||||
|
|
@ -97,18 +181,21 @@
|
|||
`(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))))
|
||||
(relurl `("admin" "posts" ,(post-key post))))
|
||||
|
||||
(define (admin-post-link post)
|
||||
`(a (@ (href ,(admin-post-url post))) ,(post-title post)))
|
||||
|
||||
(define (post-url post . tail)
|
||||
(apply relurl "archives/" (url:decode (post-key post)) tail))
|
||||
(define* (post-url post #:key fragment)
|
||||
(relative-path *public-path-base*
|
||||
(cons "archives"
|
||||
(split-and-decode-uri-path (uri-decode (post-key post))))
|
||||
#:fragment fragment))
|
||||
|
||||
(define (post-link post . tail)
|
||||
`(a (@ (href ,(apply post-url post tail))) ,(post-title post)))
|
||||
(define* (post-link post #:key fragment)
|
||||
`(a (@ (href ,(post-url post #:fragment fragment)))
|
||||
,(post-title post)))
|
||||
|
||||
(define (comment-form post author email url comment)
|
||||
`(form
|
||||
|
|
@ -154,8 +241,7 @@
|
|||
,(comment-form post "" "" "" ""))))))
|
||||
|
||||
(define (tag-link tagname)
|
||||
(rellink (string-append "tags/" (url:encode tagname))
|
||||
tagname))
|
||||
(rellink `("tags" ,tagname) tagname))
|
||||
|
||||
(define (show-post post comments?)
|
||||
`((h2 (@ (class "storytitle"))
|
||||
|
|
@ -172,19 +258,12 @@
|
|||
,@(if comments?
|
||||
'()
|
||||
`((div (@ (class "feedback"))
|
||||
(a (@ (href ,(post-url post "#comments")))
|
||||
(a (@ (href ,(post-url post #:fragment "comments")))
|
||||
"(" ,(post-n-comments post) ")")))))
|
||||
,@(if comments?
|
||||
(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)))
|
||||
|
||||
(define (top-tags index n)
|
||||
(let ((hash (assq-ref index 'tags)))
|
||||
(if hash
|
||||
|
|
@ -205,7 +284,7 @@
|
|||
counts)))
|
||||
(list-intersperse
|
||||
(map (lambda (name size)
|
||||
`(a (@ (href ,(relurl "tags/" (url:encode name)))
|
||||
`(a (@ (href ,(relurl `("tags" ,name)))
|
||||
(rel "tag")
|
||||
(style ,(format #f "font-size: ~d%" size)))
|
||||
,name))
|
||||
|
|
@ -215,25 +294,25 @@
|
|||
|
||||
(define (main-sidebar request index)
|
||||
(sidebar-ul
|
||||
`((li (h2 (a (@ (href ,(relurl "feed/atom")))
|
||||
`((li (h2 (a (@ (href ,(relurl '("feed" "atom"))))
|
||||
"subscribe "
|
||||
(img (@ (src ,(relurl "wp-content/feed-icon-14x14.png"))
|
||||
(img (@ (src ,(relurl '("wp-content" "feed-icon-14x14.png")))
|
||||
(alt "[feed]")))
|
||||
)))
|
||||
(li (h2 "search")
|
||||
(form (@ (method "POST")
|
||||
(action ,(relurl "search")))
|
||||
(action ,(relurl '("search"))))
|
||||
(input (@ (name "string") (type "text") (size "15")
|
||||
(value "")))))
|
||||
(li (h2 "tags " ,(rellink "tags/" ">>"))
|
||||
(li (h2 "tags " ,(rellink '("tags") ">>"))
|
||||
(ul (li (@ (style "line-height: 150%"))
|
||||
,@(tag-cloud (top-tags index 30))))))))
|
||||
|
||||
(define (post-sidebar post index)
|
||||
(sidebar-ul
|
||||
`((li (h2 (a (@ (href ,(relurl "feed/atom")))
|
||||
`((li (h2 (a (@ (href ,(relurl '("feed" "atom"))))
|
||||
"subscribe "
|
||||
(img (@ (src ,(relurl "wp-content/feed-icon-14x14.png"))
|
||||
(img (@ (src ,(relurl '("wp-content" "feed-icon-14x14.png")))
|
||||
(alt "[feed]")))
|
||||
)))
|
||||
(li (h2 "related")
|
||||
|
|
@ -264,17 +343,17 @@
|
|||
(define (with-authentication request thunk)
|
||||
(if (request-authenticated? request)
|
||||
(thunk)
|
||||
(rcons* (rpush 'output-headers
|
||||
'("WWW-Authenticate" . "Basic realm=\"Tekuti\"")
|
||||
request)
|
||||
'status 401
|
||||
'body `((p "Authentication required, yo")))))
|
||||
(respond `((p "Authentication required, yo"))
|
||||
#:status 401
|
||||
#:extra-headers '((www-authenticate . "Basic realm=\"Tekuti\"")))))
|
||||
|
||||
(define (atom-header server-name last-modified)
|
||||
(define (relurl tail)
|
||||
(string-append "http://" server-name *public-url-base* tail))
|
||||
(define (relurl . tail)
|
||||
(string-append "http://" server-name "/"
|
||||
(encode-and-join-uri-path
|
||||
(append *public-path-base* tail))))
|
||||
`(feed
|
||||
(@ (xmlns "http://www.w3.org/2005/Atom") (xml:base ,(relurl "")))
|
||||
(@ (xmlns "http://www.w3.org/2005/Atom") (xml:base ,(relurl)))
|
||||
(title (@ (type "text")) ,*title*)
|
||||
(subtitle (@ (type "text")) ,*subtitle*)
|
||||
,@(if last-modified
|
||||
|
|
@ -284,20 +363,25 @@
|
|||
(version "what"))
|
||||
"tekuti")
|
||||
(link (@ (rel "alternate") (type "text/html")
|
||||
(href ,(relurl ""))))
|
||||
(id ,(relurl "feed/atom"))
|
||||
(href ,(relurl))))
|
||||
(id ,(relurl "feed" "atom"))
|
||||
(link (@ (rel "self") (type "application/atom+xml")
|
||||
(href ,(relurl "feed/atom"))))))
|
||||
(href ,(relurl "feed" "atom"))))))
|
||||
|
||||
(define (atom-entry server-name post)
|
||||
(define (relurl . tail)
|
||||
(apply string-append "http://" server-name *public-url-base* tail))
|
||||
(string-append "http://" server-name "/"
|
||||
(encode-and-join-uri-path
|
||||
(append *public-path-base* tail))))
|
||||
`(entry
|
||||
(author (name ,*name*) (uri ,(relurl "")))
|
||||
(author (name ,*name*) (uri ,(relurl)))
|
||||
(title (@ (type "text")) ,(post-title post))
|
||||
(id ,(relurl (url:decode (post-key post)))) ;hack -- should include archives...
|
||||
(id ,(apply relurl
|
||||
;; hack -- should include archives...
|
||||
(split-and-decode-uri-path (uri-decode (post-key post)))))
|
||||
(link (@ (rel "alternate") (type "text/html")
|
||||
(href ,(relurl "archives/" (url:decode (post-key post))))))
|
||||
(href ,(apply relurl "archives" (split-and-decode-uri-path
|
||||
(uri-decode (post-key post)))))))
|
||||
(published ,(timestamp->atom-date (post-timestamp post)))
|
||||
(updated ,(timestamp->atom-date (post-timestamp post)))
|
||||
(content (@ (type "xhtml"))
|
||||
|
|
|
|||
283
tekuti/page.scm
283
tekuti/page.scm
|
|
@ -30,7 +30,8 @@
|
|||
#:use-module (tekuti git)
|
||||
#:use-module (tekuti post)
|
||||
#:use-module (tekuti comment)
|
||||
#:use-module (tekuti url)
|
||||
#:use-module (web uri)
|
||||
#:use-module (web request)
|
||||
#:use-module (tekuti request)
|
||||
#:use-module (tekuti page-helpers)
|
||||
#:use-module (srfi srfi-34)
|
||||
|
|
@ -55,17 +56,17 @@
|
|||
page-debug
|
||||
page-not-found))
|
||||
|
||||
;; Encoded twice, so as to form a single path-component.
|
||||
(define (make-post-key . parts)
|
||||
(url:encode (format #f "~{~a~^/~}" (map url:encode parts))))
|
||||
(uri-encode (encode-and-join-uri-path parts)))
|
||||
|
||||
(define (not-implemented request . args)
|
||||
(rcons* request
|
||||
'status 500
|
||||
'body `((h1 "Not yet implemented")
|
||||
(respond `((h1 "Not yet implemented")
|
||||
(p "Path handler not yet implemented: "
|
||||
,(rref request 'path-str)))))
|
||||
,(request-relative-path-str request)))
|
||||
#:status 500))
|
||||
|
||||
(define (page-admin request index)
|
||||
(define (page-admin request body index)
|
||||
(with-authentication
|
||||
request
|
||||
(lambda ()
|
||||
|
|
@ -77,18 +78,19 @@
|
|||
n))
|
||||
(define (recent-changes n)
|
||||
(map (lambda (rev)
|
||||
`(li ,(rellink (string-append "admin/changes/" (car rev))
|
||||
`(li ,(rellink `("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 "changes" ,(rellink "admin/changes" ">>"))
|
||||
(ul ,(recent-changes 5)))))
|
||||
(h2 "new post")
|
||||
,(post-editing-form #f))))))
|
||||
(respond `(,(sidebar-ul `((li (h2 "posts " ,(rellink '("admin" "posts")
|
||||
">>"))
|
||||
(ul ,@(post-links 5)))
|
||||
(li (h2 "changes" ,(rellink '("admin" "changes")
|
||||
">>"))
|
||||
(ul ,(recent-changes 5)))))
|
||||
(h2 "new post")
|
||||
,(post-editing-form #f))))))
|
||||
|
||||
(define (page-admin-posts request index)
|
||||
(define (page-admin-posts request body index)
|
||||
(with-authentication
|
||||
request
|
||||
(lambda ()
|
||||
|
|
@ -96,100 +98,94 @@
|
|||
(map (lambda (post)
|
||||
`(h3 ,(admin-post-link post)))
|
||||
(assq-ref index 'posts)))
|
||||
(rcons* request
|
||||
'body `((h1 "all your posts are belong to tekuti")
|
||||
,@(post-headers))))))
|
||||
(respond `((h1 "all your posts are belong to tekuti")
|
||||
,@(post-headers))))))
|
||||
|
||||
(define (page-admin-post request index key)
|
||||
(define (page-admin-post request body index key)
|
||||
(with-authentication
|
||||
request
|
||||
(lambda ()
|
||||
(let ((post (post-from-key (assq-ref index 'master) key #t)))
|
||||
(rcons* request
|
||||
'body `((h1 ,(post-title post))
|
||||
,(post-editing-form post)))))))
|
||||
(respond `((h1 ,(post-title post))
|
||||
,(post-editing-form post)))))))
|
||||
|
||||
(define (page-admin-new-post request index)
|
||||
(define (page-admin-new-post request body index)
|
||||
(with-authentication
|
||||
request
|
||||
(lambda ()
|
||||
(let ((post (make-new-post (request-form-data request))))
|
||||
(rcons* (admin-post-redirect request post)
|
||||
'body `((p "redirecting...")))))))
|
||||
(let ((post (make-new-post (request-form-data request body))))
|
||||
(respond `((p "redirecting..."))
|
||||
#:redirect (admin-post-url post))))))
|
||||
|
||||
(define (page-admin-modify-post request index key)
|
||||
(define (page-admin-modify-post request body index key)
|
||||
(with-authentication
|
||||
request
|
||||
(lambda ()
|
||||
(let ((post (modify-post key (request-form-data request))))
|
||||
(rcons* (admin-post-redirect request post)
|
||||
'body `((p "redirecting...")))))))
|
||||
(let ((post (modify-post key (request-form-data request body))))
|
||||
(respond `((p "redirecting..."))
|
||||
#:redirect (admin-post-url post))))))
|
||||
|
||||
(define (page-admin-changes request index)
|
||||
(define (page-admin-changes request body index)
|
||||
(with-authentication
|
||||
request
|
||||
(lambda ()
|
||||
(let ((revs (git-rev-list (or (assoc-ref (rref request 'query '())
|
||||
"start")
|
||||
"refs/heads/master")
|
||||
(let ((revs (git-rev-list (request-query-ref request "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" ))))))))
|
||||
(respond `((h2 "recent changes")
|
||||
,@(map (lambda (rev)
|
||||
`(div (h3 ,(rellink `("admin" "changes" ,(car rev))
|
||||
(caddr rev)))
|
||||
,(timestamp->rfc822-date (cadr rev))))
|
||||
revs)
|
||||
(h3 ,(rellink '("admin" "changes")
|
||||
"more"
|
||||
#:query
|
||||
`(("start" . ,(caar (last-pair revs))))))))))))
|
||||
|
||||
(define (page-admin-change request index sha1)
|
||||
(define (page-admin-change request body 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"))))))))))
|
||||
(respond `((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)
|
||||
(define (page-admin-revert-change request body index sha1)
|
||||
(with-authentication
|
||||
request
|
||||
(lambda ()
|
||||
(let ((new-master (git-revert "refs/heads/master" sha1)))
|
||||
(rcons* (redirect request (relurl "admin"))
|
||||
'body `((h3 "Change reverted")))))))
|
||||
(respond `((h3 "Change reverted"))
|
||||
#:redirect (relurl '("admin")))))))
|
||||
|
||||
(define (page-index request index)
|
||||
(rcons* request
|
||||
'body `(,(main-sidebar request index)
|
||||
,@(map (lambda (post)
|
||||
(show-post post #f))
|
||||
(published-posts index 10)))))
|
||||
(define (page-index request body index)
|
||||
(respond `(,(main-sidebar request index)
|
||||
,@(map (lambda (post)
|
||||
(show-post post #f))
|
||||
(published-posts index 10)))))
|
||||
|
||||
(define (page-show-post request index year month day post)
|
||||
(define (page-show-post request body index year month day post)
|
||||
(cond
|
||||
((post-from-key (assq-ref index 'master)
|
||||
(make-post-key year month day post))
|
||||
=> (lambda (post)
|
||||
(rcons* request
|
||||
'title (string-append (post-title post) " -- " *title*)
|
||||
'body `(,(post-sidebar post index)
|
||||
,(show-post post #t)))))
|
||||
(respond `(,(post-sidebar post index)
|
||||
,(show-post post #t))
|
||||
#:title (string-append (post-title post) " -- " *title*))))
|
||||
(else
|
||||
(page-not-found request index))))
|
||||
(page-not-found request body index))))
|
||||
|
||||
(define (page-new-comment request index year month day name)
|
||||
(let ((data (request-form-data request)))
|
||||
(define (page-new-comment request body index year month day name)
|
||||
(let ((data (request-form-data request body)))
|
||||
(cond
|
||||
((post-from-key (assq-ref index 'master)
|
||||
(make-post-key year month day name))
|
||||
|
|
@ -197,20 +193,19 @@
|
|||
(cond
|
||||
((bad-new-comment-post? data)
|
||||
=> (lambda (reason)
|
||||
(rcons* request
|
||||
'body `((p "Bad post data: " ,(pk reason))))))
|
||||
(respond `((p "Bad post data: " ,(pk reason))))))
|
||||
(else
|
||||
(let ((comment (make-new-comment (post-key post) (post-title post)
|
||||
data)))
|
||||
;; nb: at this point, `post' is out-of-date
|
||||
(rcons* (redirect request (post-url post "#comments"))
|
||||
'title "comment posted"
|
||||
'body `((p "Comment posted, thanks."))))))))
|
||||
(respond `((p "Comment posted, thanks."))
|
||||
#:redirect (post-url post #:fragment "comments")
|
||||
#:title "comment posted"))))))
|
||||
(else
|
||||
(page-not-found request index)))))
|
||||
(page-not-found request body index)))))
|
||||
|
||||
;; fixme exception handling for input
|
||||
(define (page-archives request index year month day)
|
||||
(define (page-archives request body index year month day)
|
||||
(let ((year (and=> year string->number))
|
||||
(month (and=> month string->number))
|
||||
(day (and=> day string->number)))
|
||||
|
|
@ -230,17 +225,15 @@
|
|||
|
||||
(let lp ((posts (published-posts index -1)))
|
||||
(cond ((or (null? posts) (too-early? (car posts)))
|
||||
(rcons* request
|
||||
'title *title*
|
||||
'body `((h1 "No posts found")
|
||||
(p "No posts were found in the specified period."))))
|
||||
(respond `((h1 "No posts found")
|
||||
(p "No posts were found in the specified period."))
|
||||
#:title *title*))
|
||||
((early-enough? (car posts))
|
||||
(let lp ((posts posts) (new-header (make-date-header #t)) (out '()))
|
||||
(cond
|
||||
((or (null? posts) (too-early? (car posts)))
|
||||
(rcons* request
|
||||
'title (string-append "archives -- " *title*)
|
||||
'body (reverse out)))
|
||||
(respond (reverse out)
|
||||
#:title (string-append "archives -- " *title*)))
|
||||
((new-header (car posts))
|
||||
=> (lambda (sxml)
|
||||
(lp (cdr posts) (make-date-header (car posts))
|
||||
|
|
@ -249,80 +242,74 @@
|
|||
(lp (cdr posts) new-header (cons `(p ,(post-link (car posts))) out))))))
|
||||
(else (lp (cdr posts))))))))
|
||||
|
||||
(define (page-search request index)
|
||||
(let* ((string (or (assoc-ref (request-form-data request) "string") ""))
|
||||
(define (page-search request body index)
|
||||
(let* ((string (or (assoc-ref (request-form-data request body) "string") ""))
|
||||
(posts (find-posts-matching string index)))
|
||||
(rcons* request
|
||||
'body `((h2 "search results: \"" ,string "\"")
|
||||
,@(if (null? posts)
|
||||
`((p "No posts matched your search string."))
|
||||
(map (lambda (post)
|
||||
`(p ,(post-link post)))
|
||||
posts))))))
|
||||
(respond `((h2 "search results: \"" ,string "\"")
|
||||
,@(if (null? posts)
|
||||
`((p "No posts matched your search string."))
|
||||
(map (lambda (post)
|
||||
`(p ,(post-link post)))
|
||||
posts))))))
|
||||
|
||||
(define (page-show-tags request index)
|
||||
(rcons* request
|
||||
'title (string-append "all tags -- " *title*)
|
||||
'body `((div (@ (id "tag-cloud"))
|
||||
(h2 "all tags")
|
||||
,@(tag-cloud (top-tags index 200))))))
|
||||
(define (page-show-tags request body index)
|
||||
(respond `((div (@ (id "tag-cloud"))
|
||||
(h2 "all tags")
|
||||
,@(tag-cloud (top-tags index 200))))
|
||||
#:title (string-append "all tags -- " *title*)))
|
||||
|
||||
(define (page-show-tag request index tag)
|
||||
(define (page-show-tag request body index tag)
|
||||
(let* ((tags (assq-ref index 'tags))
|
||||
(posts (map (lambda (key)
|
||||
(post-from-key (assq-ref index 'master) key))
|
||||
(hash-ref tags tag '()))))
|
||||
(if (pair? posts)
|
||||
(rcons* request
|
||||
'title (string-append "posts tagged \"" tag "\"")
|
||||
'body `((h2 "posts tagged \"" ,tag "\"")
|
||||
,@(map (lambda (post) `(p ,(post-link post)))
|
||||
posts)
|
||||
,(related-tag-cloud tag index)))
|
||||
(rcons* request
|
||||
'status 404
|
||||
'body `((h2 "Unknown tag " ,tag)
|
||||
(p "No posts were found tagged as \"" ,tag "\"."))))))
|
||||
(respond `((h2 "posts tagged \"" ,tag "\"")
|
||||
,@(map (lambda (post) `(p ,(post-link post)))
|
||||
posts)
|
||||
,(related-tag-cloud tag index))
|
||||
#:title (string-append "posts tagged \"" tag "\""))
|
||||
(respond `((h2 "Unknown tag " ,tag)
|
||||
(p "No posts were found tagged as \"" ,tag "\"."))
|
||||
#:status 404))))
|
||||
|
||||
(define (page-debug request index)
|
||||
(rcons* request
|
||||
'title "debug"
|
||||
'body `((p "hello world!")
|
||||
(table
|
||||
(tr (th "header") (th "value"))
|
||||
,@(map (lambda (pair)
|
||||
`(tr (td ,(car pair)) (td ,(cdr pair))))
|
||||
(rref request 'headers))))))
|
||||
(define (page-debug request body index)
|
||||
(respond `((p "hello world!")
|
||||
(table
|
||||
(tr (th "header") (th "value"))
|
||||
,@(map (lambda (pair)
|
||||
`(tr (td (tt ,(with-output-to-string
|
||||
(lambda () (display (car pair))))))
|
||||
(td (tt ,(with-output-to-string
|
||||
(lambda ()
|
||||
(write (cdr pair))))))))
|
||||
(request-headers request))))
|
||||
#:title "debug"))
|
||||
|
||||
(define (page-not-found request index)
|
||||
(rcons* (pk 'not-found request)
|
||||
'status 404
|
||||
'body `((h1 "Page not found")
|
||||
(p "Unknown path: " ,(rref request 'path-str)))))
|
||||
(define (page-not-found request body index)
|
||||
(respond `((h1 "Page not found")
|
||||
(p "Unknown path: "
|
||||
,(request-relative-path-str (pk 'not-found request))))
|
||||
#:status 404))
|
||||
|
||||
(define (page-feed-atom request index)
|
||||
(define (page-feed-atom request body index)
|
||||
(let ((last-modified (let ((posts (published-posts index 1)))
|
||||
(and (pair? posts)
|
||||
(post-timestamp (car posts)))))
|
||||
(server-name (request-server-name request)))
|
||||
(server-name (or (request-host request)
|
||||
(uri-host (request-uri request))
|
||||
*host*)))
|
||||
(cond
|
||||
((let ((since (assoc-ref (rref request 'headers '())
|
||||
"if-modified-since")))
|
||||
(and since (>= (rfc822-date->timestamp since) last-modified)))
|
||||
(rcons* request
|
||||
'status 304
|
||||
'doctype #f))
|
||||
((let ((since (request-if-modified-since request)))
|
||||
(and since (>= (date->timestamp since) last-modified)))
|
||||
(respond #f #:status 304))
|
||||
(else
|
||||
(rcons* (if last-modified
|
||||
(rpush 'output-headers (cons "Last-Modified"
|
||||
(timestamp->rfc822-date
|
||||
last-modified))
|
||||
request)
|
||||
request)
|
||||
'doctype ""
|
||||
'content-type "application/atom+xml"
|
||||
'sxml (append (atom-header server-name last-modified)
|
||||
(map
|
||||
(lambda (post)
|
||||
(atom-entry server-name post))
|
||||
(published-posts index 10))))))))
|
||||
(respond #f
|
||||
#:last-modified (and=> last-modified timestamp->date)
|
||||
#:doctype #f
|
||||
#:content-type "application/atom+xml"
|
||||
#:sxml (append (atom-header server-name last-modified)
|
||||
(map
|
||||
(lambda (post)
|
||||
(atom-entry server-name post))
|
||||
(published-posts index 10))))))))
|
||||
|
|
|
|||
|
|
@ -25,126 +25,69 @@
|
|||
;;; Code:
|
||||
|
||||
(define-module (tekuti request)
|
||||
#:use-module ((srfi srfi-1) #:select (find-tail fold))
|
||||
#:use-module ((srfi srfi-1) #:select (find-tail))
|
||||
#:use-module (tekuti match-bind)
|
||||
#:use-module (tekuti util)
|
||||
#:use-module (tekuti url)
|
||||
#:use-module (web uri)
|
||||
#:use-module (web request)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (tekuti config)
|
||||
#:use-module (tekuti base64)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:export (make-request rcons rcons* rpush rpush* rref let-request
|
||||
request-path-case request-authenticated?
|
||||
request-form-data request-server-name))
|
||||
|
||||
(define (header-ref headers key default)
|
||||
(let ((pair (assoc key headers)))
|
||||
(if pair
|
||||
(cdr pair)
|
||||
default)))
|
||||
#:export (request-relative-path
|
||||
request-relative-path-str
|
||||
request-query-ref
|
||||
request-path-case
|
||||
request-authenticated?
|
||||
request-form-data))
|
||||
|
||||
(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) ""))))
|
||||
(cons (uri-decode (substring piece 0 equals))
|
||||
(uri-decode (substring piece (1+ equals))))
|
||||
(cons (uri-decode piece) ""))))
|
||||
(string-split str #\&)))
|
||||
|
||||
(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 '()))))
|
||||
(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")))))
|
||||
(define (request-relative-path r)
|
||||
(let ((base *private-path-base*)
|
||||
(path (split-and-decode-uri-path (uri-path (request-uri r)))))
|
||||
(let ((tail (list-head-match base path (length base))))
|
||||
(or tail
|
||||
(error "unexpected path" path base)))))
|
||||
|
||||
(define-syntax let-request
|
||||
(lambda (stx)
|
||||
(define (make-binding b)
|
||||
(syntax-case b ()
|
||||
((id option ...)
|
||||
(identifier? #'id)
|
||||
#'(id (rref request-var 'id option ...)))
|
||||
(id
|
||||
(identifier? #'id)
|
||||
#'(id (rref request-var 'id)))))
|
||||
(syntax-case stx ()
|
||||
((_ request (binding ...) body ...)
|
||||
(with-syntax (((binding ...) (map make-binding #'(binding ...))))
|
||||
#'(let ((request-var request))
|
||||
(let (binding ...)
|
||||
body ...)))))))
|
||||
(define (request-relative-path-str r)
|
||||
(encode-and-join-uri-path (request-relative-path r)))
|
||||
|
||||
(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")
|
||||
(parse-www-form-urlencoded 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))
|
||||
(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 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* (rref request k #:optional (default #f) #:key (default-proc #f))
|
||||
(let ((pair (assq k request)))
|
||||
(define (request-query-ref r param default)
|
||||
(let ((q (uri-query (request-uri r))))
|
||||
(cond
|
||||
(pair (cdr pair))
|
||||
(default-proc (default-proc request k))
|
||||
((and q (assoc param (parse-www-form-urlencoded q))) => cdr)
|
||||
(else default))))
|
||||
|
||||
(define (request-form-data request body)
|
||||
(if (or (not body) (string-null? body))
|
||||
'()
|
||||
(let ((content-type (request-content-type request)))
|
||||
(cond
|
||||
((equal? content-type '("application" "x-www-form-urlencoded"))
|
||||
(parse-www-form-urlencoded body))
|
||||
(else
|
||||
(error "bad content-type" content-type))))))
|
||||
|
||||
;; 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 "^([^:]*):(.*)$"
|
||||
(utf8->string (base64-decode b64))
|
||||
(_ user pass)
|
||||
(and (equal? user *admin-user*)
|
||||
(equal? pass *admin-pass*))
|
||||
#f)
|
||||
#f)))))
|
||||
(let ((auth (request-authorization request)))
|
||||
(and auth
|
||||
(match-bind "^Basic ([A-Za-z0-9+/=]*)$" auth (_ b64)
|
||||
(match-bind "^([^:]*):(.*)$"
|
||||
(utf8->string (base64-decode b64))
|
||||
(_ user pass)
|
||||
(and (equal? user *admin-user*)
|
||||
(equal? pass *admin-pass*))
|
||||
#f)
|
||||
#f))))
|
||||
|
||||
(define-syntax path-proc-case
|
||||
(lambda (stx)
|
||||
|
|
@ -191,22 +134,10 @@
|
|||
#'(let ((path-var path))
|
||||
(cond cond-clause ...)))))))
|
||||
|
||||
(define (rcons*-fold request . keys-and-procs)
|
||||
(foldn (lambda (request k proc)
|
||||
(rcons k (proc request) request))
|
||||
2 request keys-and-procs))
|
||||
|
||||
(define-syntax request-path-case
|
||||
(syntax-rules ()
|
||||
((_ request clause ...)
|
||||
(path-proc-case
|
||||
(let-request request (method path)
|
||||
(cons method path))
|
||||
clause ...))))
|
||||
|
||||
(define (request-server-name request)
|
||||
(let ((headers (rref request 'headers)))
|
||||
(or (assoc-ref headers "host")
|
||||
(assoc-ref headers "server-ip-addr"))))
|
||||
|
||||
|
||||
(let ((r request))
|
||||
(path-proc-case
|
||||
(cons (symbol->string (request-method r)) (request-relative-path r))
|
||||
clause ...)))))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
;; Tekuti
|
||||
;; Copyright (C) 2008 Andy Wingo <wingo at pobox dot com>
|
||||
;; Copyright (C) 2008, 2010 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
|
||||
|
|
@ -25,54 +25,13 @@
|
|||
;;; Code:
|
||||
|
||||
(define-module (tekuti web)
|
||||
#:use-module (sxml simple)
|
||||
#:use-module (sxml transform)
|
||||
#:use-module (tekuti url)
|
||||
#:use-module (web server)
|
||||
#:use-module (tekuti request)
|
||||
#:use-module (tekuti template)
|
||||
#:use-module (tekuti index)
|
||||
#:use-module (tekuti page)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:export (header-ref
|
||||
handle-request))
|
||||
#:use-module (tekuti config)
|
||||
#:export (main-loop))
|
||||
|
||||
(define *status-names*
|
||||
'((200 . "OK")
|
||||
(201 . "Created")
|
||||
(303 . "See Other")
|
||||
(304 . "Not Modified")
|
||||
(401 . "Unauthorized")
|
||||
(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 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 (make-output request)
|
||||
(lambda (port)
|
||||
(let ((sxml (or (rref request 'sxml #f)
|
||||
(templatize request))))
|
||||
(if sxml
|
||||
(begin (display (rref request 'doctype "") port)
|
||||
(sxml->xml sxml port))
|
||||
(display "" port)))))
|
||||
|
||||
(define (finalize request)
|
||||
;; update output headers
|
||||
;; templatize body
|
||||
(rpush* (rcons 'output (make-output request) request)
|
||||
'output-headers
|
||||
(cons "Status" (status->string (rref request 'status 200)))
|
||||
'output-headers
|
||||
(cons "Content-Type"
|
||||
(string-append (rref request 'content-type "text/html")
|
||||
"; charset=utf-8"))))
|
||||
|
||||
(define (choose-handler request)
|
||||
(request-path-case
|
||||
request
|
||||
|
|
@ -98,6 +57,17 @@
|
|||
((GET debug) page-debug)
|
||||
(else page-not-found)))
|
||||
|
||||
(define (handle-request request index)
|
||||
(let ((handler (choose-handler request)))
|
||||
(finalize (handler (rcons 'doctype xhtml-doctype request) index))))
|
||||
(define (handler request body index)
|
||||
(let ((index (maybe-reindex index)))
|
||||
(call-with-values (lambda ()
|
||||
((choose-handler request) request body (cdr index)))
|
||||
(lambda (response body)
|
||||
(values response body index)))))
|
||||
|
||||
;; The seemingly useless lambda is to allow for `handler' to be
|
||||
;; redefined at runtime.
|
||||
(define (main-loop)
|
||||
(run-server (lambda (r b i) (handler r b i))
|
||||
*server-impl*
|
||||
*server-impl-args*
|
||||
(read-index)))
|
||||
|
|
|
|||
Loading…
Reference in a new issue