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) (define-module (tekuti config)
#:use-module (tekuti util) #:use-module (tekuti util)
#:use-module ((sxml ssax) #:select (define-parsed-entity!)) #: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* *css-file* *navbar-links* *navbar-infix*
*title* *subtitle* *name* *title* *subtitle* *name*
*public-path-base* *private-path-base*
*server-impl* *server-impl-args*)) *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-dir* "~/blog.git")
(define *git* "git") (define *git* "git")
(define *public-path-base* '())
(define *private-path-base* '())
(define *css-file* "/base.css") (define *css-file* "/base.css")
(define *navbar-links* '()) (define *navbar-links* '())
(define *navbar-infix* " ") (define *navbar-infix* " ")
@ -49,7 +55,8 @@
(define *name* "Joe Schmo") (define *name* "Joe Schmo")
(define *server-impl* 'http) (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! 'agrave 224)
(define-parsed-entity! 'laquo 171) (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\" " "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" "
"\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n")) "\"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n"))
(define (acons* tail . args) (define-syntax build-headers
(let lp ((tail tail) (args args)) (syntax-rules ()
(if (null? args) ((_ k v-exp rest ...)
tail (let ((v v-exp))
(let ((k (car args)) (v (cadr args))) (let ((tail (build-headers rest ...)))
(lp (if v (acons k v tail) tail) (if v
(cddr args)))))) (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 (define* (respond #:optional body #:key
redirect redirect
@ -72,14 +84,14 @@
(content-type-params '(("charset" . "utf-8"))) (content-type-params '(("charset" . "utf-8")))
(content-type "text/html") (content-type "text/html")
(extra-headers '()) (extra-headers '())
(sxml (templatize #:title title #:body body))) (sxml (and body (templatize #:title title #:body body))))
(values (build-response (values (build-response
#:code status #:code status
#:headers (acons* #:headers (build-headers
extra-headers location (and=> redirect ensure-public-uri)
'location redirect last-modified last-modified
'last-modified last-modified content-type (cons content-type content-type-params)
'content-type (cons content-type content-type-params))) extra-headers))
(lambda (port) (lambda (port)
(if sxml (if sxml
(begin (begin
@ -347,11 +359,9 @@
#:status 401 #:status 401
#:extra-headers '((www-authenticate . "Basic realm=\"Tekuti\""))))) #:extra-headers '((www-authenticate . "Basic realm=\"Tekuti\"")))))
(define (atom-header server-name last-modified) (define (atom-header last-modified)
(define (relurl . tail) (define (relurl . tail)
(string-append "http://" server-name "/" (unparse-uri (ensure-public-uri tail)))
(encode-and-join-uri-path
(append *public-path-base* tail))))
`(feed `(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*) (title (@ (type "text")) ,*title*)
@ -368,11 +378,9 @@
(link (@ (rel "self") (type "application/atom+xml") (link (@ (rel "self") (type "application/atom+xml")
(href ,(relurl "feed" "atom")))))) (href ,(relurl "feed" "atom"))))))
(define (atom-entry server-name post) (define (atom-entry post)
(define (relurl . tail) (define (relurl . tail)
(string-append "http://" server-name "/" (unparse-uri (ensure-public-uri tail)))
(encode-and-join-uri-path
(append *public-path-base* tail))))
`(entry `(entry
(author (name ,*name*) (uri ,(relurl))) (author (name ,*name*) (uri ,(relurl)))
(title (@ (type "text")) ,(post-title post)) (title (@ (type "text")) ,(post-title post))

9
tekuti/page.scm
View file

@ -295,10 +295,7 @@
(define (page-feed-atom request body index) (define (page-feed-atom request body index)
(let ((last-modified (let ((posts (published-posts index 1))) (let ((last-modified (let ((posts (published-posts index 1)))
(and (pair? posts) (and (pair? posts)
(post-timestamp (car posts))))) (post-timestamp (car posts))))))
(server-name (or (request-host request)
(uri-host (request-uri request))
*host*)))
(cond (cond
((let ((since (request-if-modified-since request))) ((let ((since (request-if-modified-since request)))
(and since (>= (date->timestamp since) last-modified))) (and since (>= (date->timestamp since) last-modified)))
@ -308,8 +305,8 @@
#:last-modified (and=> last-modified timestamp->date) #:last-modified (and=> last-modified timestamp->date)
#:doctype #f #:doctype #f
#:content-type "application/atom+xml" #:content-type "application/atom+xml"
#:sxml (append (atom-header server-name last-modified) #:sxml (append (atom-header last-modified)
(map (map
(lambda (post) (lambda (post)
(atom-entry server-name post)) (atom-entry post))
(published-posts index 10)))))))) (published-posts index 10))))))))

4
tekuti/web.scm
View file

@ -69,5 +69,7 @@
(define (main-loop) (define (main-loop)
(run-server (lambda (r b i) (handler r b i)) (run-server (lambda (r b i) (handler r b i))
*server-impl* *server-impl*
*server-impl-args* (if (list? *server-impl-args*)
*server-impl-args*
(*server-impl-args*))
(read-index))) (read-index)))