Support for relative URIs for https + http access.

* tekuti/page-helpers.scm (ensure-uri): Rename from ensure-public-uri.
  A URI is absolute by definition.
  (ensure-uri-reference): New helper.  Requires git guile.
  (respond): Use ensure-URI-reference to get the reference.
  (atom-header, atom-entry): Use ensure-uri.

* tekuti/page.scm (atom-feed-from-posts): Pass the URI scheme from the
  request-uri when reconstructing

* tekuti/config.scm (*public-scheme*): New config variable, defaulting
  to http.

tekuti/config.scm

@@ -1,5 +1,5 @@
 ;; Tekuti
-;; Copyright (C) 2008, 2010, 2012 Andy Wingo <wingo at pobox dot com>
+;; Copyright (C) 2008, 2010, 2012, 2014 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
@@ -27,13 +27,14 @@
 (define-module (tekuti config)
   #:use-module (tekuti util)
   #:use-module ((sxml ssax) #:select (define-parsed-entity!))
-  #:export (*public-host* *public-port* *public-path-base*
+  #:export (*public-scheme* *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*
             *server-impl* *server-impl-args*))
 
+(define *public-scheme* 'http)
 (define *public-host* "127.0.0.1")
 (define *public-port* 8080)
 (define *public-path-base* '())

tekuti/page-helpers.scm

@@ -65,13 +65,23 @@
     ((_ tail)
      tail)))
 
-(define (ensure-public-uri x)
+(define (ensure-uri x)
   (cond
    ((uri? x) x)
    ((string? x)
-    (build-uri 'http #:host *public-host* #:port *public-port* #:path x))
+    (build-uri *public-scheme* #:host *public-host* #:port *public-port*
+               #:path x))
    ((list? x)
-    (ensure-public-uri (relurl x)))
+    (ensure-uri (relurl x)))
+   (else (error "can't turn into a uri" x))))
+
+(define (ensure-uri-reference x)
+  (cond
+   ((uri? x) x)
+   ((string? x)
+    (build-uri-reference #:path x))
+   ((list? x)
+    (ensure-uri-reference (relurl x)))
    (else (error "can't turn into a uri" x))))
 
 (define* (respond #:optional body #:key
@@ -88,7 +98,7 @@
   (values (build-response
            #:code status
            #:headers (build-headers
-                      location (and=> redirect ensure-public-uri)
+                      location (and=> redirect ensure-uri-reference)
                       last-modified last-modified
                       content-type (cons content-type content-type-params)
                       date (current-date)
@@ -377,7 +387,7 @@
 
 (define (atom-header last-modified)
   (define (relurl . tail)
-    (uri->string (ensure-public-uri tail)))
+    (uri->string (ensure-uri tail)))
   `(feed
      (@ (xmlns "http://www.w3.org/2005/Atom") (xml:base ,(relurl)))
      (title (@ (type "text")) ,*title*)
@@ -396,7 +406,7 @@
 
 (define (atom-entry post)
   (define (relurl . tail)
-    (uri->string (ensure-public-uri tail)))
+    (uri->string (ensure-uri tail)))
   `(entry
     (author (name ,*name*) (uri ,(relurl)))
     (title (@ (type "text")) ,(post-title post))