diff options
| author |  Andy Wingo | 2010-11-22 23:33:08 +0100 |
|---|---|---|
| committer | Andy Wingo | 2010-11-22 23:33:08 +0100 |
| commit | dda89fe5bfc1ef58abfc426e5dd68f58a1c84360 (patch) | |
| tree | 0dae1b7fe6cc4c896bc80dc836c5ac3adfd3b922 | |
| parent | 3ece90674ac6b63e98a3bc0d0c392aab9e46f70d (diff) | |
| download | tekuti-dda89fe5bfc1ef58abfc426e5dd68f58a1c84360.tar.gz tekuti-dda89fe5bfc1ef58abfc426e5dd68f58a1c84360.zip | |
config refactor so that tekuti knows its public address
* tekuti/config.scm (*public-host*, *public-port*)
(*private-host*, *private-port*): Use these instead of *host* and the
recently removed *port*. A web app needs to know its public address,
and the private ports are part of its config.
(*server-impl-args*): Redefine as a thunk to delay the dereferencing
of config parameters like *private-host*.
* tekuti/page-helpers.scm (ensure-public-uri): New helper, uses the new
conf vars to ensure that a value is a URI.
(build-headers): New helper, like the old acons* without consing a
rest list.
(respond): Use the two new helpers.
(atom-header, atom-entry): No need for server-name arg, as we know how
to make a public URI.
* tekuti/page.scm (page-feed-atom): Adapt to no need to guess at the
server-name.
* tekuti/web.scm (main-loop): Allow *server-impl-args* to be a thunk.
| -rw-r--r-- | tekuti/config.scm | 19 | ||||
| -rw-r--r-- | tekuti/page-helpers.scm | 50 | ||||
| -rw-r--r-- | tekuti/page.scm | 9 | ||||
| -rw-r--r-- | tekuti/web.scm | 4 |
4 files changed, 48 insertions, 34 deletions
diff --git a/tekuti/config.scm b/tekuti/config.scm index 4dd97c9..c8553ae 100644 --- a/tekuti/config.scm +++ b/tekuti/config.scm @@ -27,17 +27,23 @@ (define-module (tekuti config) #:use-module (tekuti util) #:use-module ((sxml ssax) #:select (define-parsed-entity!)) - #:export (*host* *git-dir* *git* *debug* *admin-user* *admin-pass* + #:export (*public-host* *public-port* *public-path-base* + *private-host* *private-port* *private-path-base* + *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 *git-dir* "~/blog.git") -(define *git* "git") +(define *public-host* "127.0.0.1") +(define *public-port* 8080) (define *public-path-base* '()) + +(define *private-host* "127.0.0.1") +(define *private-port* 8080) (define *private-path-base* '()) + +(define *git-dir* "~/blog.git") +(define *git* "git") (define *css-file* "/base.css") (define *navbar-links* '()) (define *navbar-infix* " ") @@ -49,7 +55,8 @@ (define *name* "Joe Schmo") (define *server-impl* 'http) -(define *server-impl-args* '(#:host "127.0.0.1" #:port 8080)) +(define *server-impl-args* + (lambda () `(#:host ,*private-host* #:port ,*private-port*))) (define-parsed-entity! 'agrave 224) (define-parsed-entity! 'laquo 171) diff --git a/tekuti/page-helpers.scm b/tekuti/page-helpers.scm index ed6fb8a..effdc00 100644 --- a/tekuti/page-helpers.scm +++ b/tekuti/page-helpers.scm @@ -55,13 +55,25 @@ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" " "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n")) -(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-syntax build-headers + (syntax-rules () + ((_ k v-exp rest ...) + (let ((v v-exp)) + (let ((tail (build-headers rest ...))) + (if v + (acons 'k v tail) + tail)))) + ((_ tail) + tail))) + +(define (ensure-public-uri x) + (cond + ((uri? x) x) + ((string? x) + (build-uri 'http #:host *public-host* #:port *public-port* #:path x)) + ((list? x) + (ensure-public-uri (relurl x))) + (else (error "can't turn into a uri" x)))) (define* (respond #:optional body #:key redirect @@ -72,14 +84,14 @@ (content-type-params '(("charset" . "utf-8"))) (content-type "text/html") (extra-headers '()) - (sxml (templatize #:title title #:body body))) + (sxml (and body (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))) + #:headers (build-headers + location (and=> redirect ensure-public-uri) + last-modified last-modified + content-type (cons content-type content-type-params) + extra-headers)) (lambda (port) (if sxml (begin @@ -347,11 +359,9 @@ #:status 401 #:extra-headers '((www-authenticate . "Basic realm=\"Tekuti\""))))) -(define (atom-header server-name last-modified) +(define (atom-header last-modified) (define (relurl . tail) - (string-append "http://" server-name "/" - (encode-and-join-uri-path - (append *public-path-base* tail)))) + (unparse-uri (ensure-public-uri tail))) `(feed (@ (xmlns "http://www.w3.org/2005/Atom") (xml:base ,(relurl))) (title (@ (type "text")) ,*title*) @@ -368,11 +378,9 @@ (link (@ (rel "self") (type "application/atom+xml") (href ,(relurl "feed" "atom")))))) -(define (atom-entry server-name post) +(define (atom-entry post) (define (relurl . tail) - (string-append "http://" server-name "/" - (encode-and-join-uri-path - (append *public-path-base* tail)))) + (unparse-uri (ensure-public-uri tail))) `(entry (author (name ,*name*) (uri ,(relurl))) (title (@ (type "text")) ,(post-title post)) diff --git a/tekuti/page.scm b/tekuti/page.scm index 67d9001..9d0de95 100644 --- a/tekuti/page.scm +++ b/tekuti/page.scm @@ -295,10 +295,7 @@ (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 (or (request-host request) - (uri-host (request-uri request)) - *host*))) + (post-timestamp (car posts)))))) (cond ((let ((since (request-if-modified-since request))) (and since (>= (date->timestamp since) last-modified))) @@ -308,8 +305,8 @@ #:last-modified (and=> last-modified timestamp->date) #:doctype #f #:content-type "application/atom+xml" - #:sxml (append (atom-header server-name last-modified) + #:sxml (append (atom-header last-modified) (map (lambda (post) - (atom-entry server-name post)) + (atom-entry post)) (published-posts index 10)))))))) diff --git a/tekuti/web.scm b/tekuti/web.scm index ae190a8..31ef42b 100644 --- a/tekuti/web.scm +++ b/tekuti/web.scm @@ -69,5 +69,7 @@ (define (main-loop) (run-server (lambda (r b i) (handler r b i)) *server-impl* - *server-impl-args* + (if (list? *server-impl-args*) + *server-impl-args* + (*server-impl-args*)) (read-index))) |