aliens/tekuti
1
0
Fork 0
Code Activity

config refactor so that tekuti knows its public address

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2010-11-22 23:33:08 +01:00
parent 3ece90674a
commit dda89fe5bf
4 changed files with 48 additions and 34 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
tekuti/config.scm
View file

@ -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 *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 *public-path-base* '())
(define *private-path-base* '())
(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)

50
tekuti/page-helpers.scm
View file

@ -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))

9
tekuti/page.scm
View file

@ -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))))))))

4
tekuti/web.scm
View file

@ -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)))