diff options
| -rw-r--r-- | mulkcms.asd | 2 | ||||
| -rw-r--r-- | 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)) |