Use PURI for calculation of absolute URIs from relative ones.

1 files changed, 32 insertions, 27 deletions

diff --git a/mulkcms.lisp b/mulkcms.lisp
index 9662b06..0e2c4ae 100644
--- a/mulkcms.lisp
+++ b/mulkcms.lisp
@@ -124,33 +124,38 @@
 
 (defun link-to (action &key comment-id article-id revision-id (absolute nil))
   ;; Taken from Mulkblog.
-  (with-output-to-string (out)
-    (format out "~A" (if absolute *base-uri* ""))
-    (symbol-macrolet ((article-base (find-canonical-article-alias article-id)))
-      (multiple-value-call
-          #'(lambda (&rest args) (apply #'format out args))
-        (ecase action
-          (:index "")
-          (:full-index "/?full")
-          (:view-atom-feed (values "/feed"))
-          (:view-comment-feed (cond (article-id (values "/~A?comment-feed" article-base))
-                                    (t "/comment-feed")))
-          (:view (cond (comment-id (values "/~A#comment-~D" article-base comment-id))
-                       (article-id (values "/~A" article-base))
-                       (t "/")))
-          (:view-comments (values "/~A#comments" article-base))
-          ((:edit :preview) (cond (revision-id (values "/~A?edit&revision=~D" article-base revision-id))
-                                  (t           (values "/~A?edit" article-base))))
-          (:post-comment (values "/~A" article-base))
-          (:trackback (values "/~A?trackback" article-base))
-          (:view-atom-entry (values "/~A?atom" article-base))
-          (:save (values "/~A?save" article-base))
-          (:moderation-page "/moderate")
-          (:css "/journal.css")
-          (:prettify.css "/prettify/prettify.css")
-          (:prettify.js "/prettify/prettify.js")
-          (:prettify-lisp.js "/prettify/lang-lisp.js")
-          (:pingback "/rpc"))))))
+  (symbol-macrolet ((article-base (find-canonical-article-alias article-id)))
+    (multiple-value-call
+        #'(lambda (&rest args)
+            (print args)
+            (let ((path (apply #'format nil args)))
+              (if absolute
+                  (with-output-to-string (strout)
+                    (puri:render-uri (puri:merge-uris path *base-uri*)
+                                     strout))
+                  path)))
+      (ecase action
+        (:index "")
+        (:full-index "/?full")
+        (:view-atom-feed (values "/feed"))
+        (:view-comment-feed (cond (article-id (values "/~A?comment-feed" article-base))
+                                  (t "/comment-feed")))
+        (:view (cond (comment-id (values "/~A#comment-~D" article-base comment-id))
+                     (article-id (values "/~A" article-base))
+                     (t "/")))
+        (:view-comments (values "/~A#comments" article-base))
+        ((:edit :preview) (cond (revision-id (values "/~A?edit&revision=~D" article-base revision-id))
+                                (t           (values "/~A?edit" article-base))))
+        (:post-comment (values "/~A" article-base))
+        (:trackback (values "/~A?trackback" article-base))
+        (:view-atom-entry (values "/~A?atom" article-base))
+        (:save (values "/~A?save" article-base))
+        (:moderation-page "/moderate")
+        (:css "/journal.css")
+        (:prettify.css "/prettify/prettify.css")
+        (:prettify.js "/prettify/prettify.js")
+        (:prettify-lisp.js "/prettify/lang-lisp.js")
+        (:pingback "/rpc")))))
 
 (defun call-with-db (thunk)
   (call-with-connection *database-connection-spec* thunk))