From 746469e5e4be20dada50fccfdf7ca7d707cd6f66 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Tue, 15 Mar 2011 22:08:15 +0100
Subject: Use PURI for calculation of absolute URIs from relative ones.

---
 mulkcms.asd  |  2 +-
 mulkcms.lisp | 59 ++++++++++++++++++++++++++++++++---------------------------
 2 files changed, 33 insertions(+), 28 deletions(-)

diff --git a/mulkcms.asd b/mulkcms.asd
index 7668a81..4bd0f05 100644
--- a/mulkcms.asd
+++ b/mulkcms.asd
@@ -10,7 +10,7 @@
   :version "0.0.1"
   :depends-on (:cl-who :cl-json :alexandria :postmodern :split-sequence
                :cl-ppcre :cl-fad :cxml :closure-html :json-template :cxml-stp
-               :ironclad :flexi-streams :drakma)
+               :ironclad :flexi-streams :drakma :puri)
   :components ((:file "package")
                (:file "site")
                (:file "mulkcms")
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))
-- 
cgit v1.2.3