rewrite genurl: use 'puri:uri class for render url

archimag · Mar 23, 2010 · a0d4c6d · a0d4c6d
1 parent e91aa14
commit a0d4c6d
Showing 1 changed file with 29 additions and 23 deletions.
diff --git a/src/route.lisp b/src/route.lisp
@@ -102,37 +102,43 @@
   (routes:parse-template (get route-symbol :template)))
 
 (defun genurl/impl (tmpl args)
-  (format nil
-          "/~{~A~^/~}"
-          (routes::apply-bindings tmpl 
-                                  (iter (for pair in (alexandria:plist-alist args))
-                                        (collect (cons (car pair)
-                                                       (if (or (stringp (cdr pair))
-                                                               (consp (cdr pair)))
-                                                           (cdr pair)
-                                                           (write-to-string (cdr pair)))))))))
+  (let ((uri (make-instance 'puri:uri)))
+    (setf (puri:uri-parsed-path uri)
+          (cons :absolute
+                (routes::apply-bindings tmpl 
+                                        (iter (for pair in (alexandria:plist-alist args))
+                                              (collect (cons (car pair)
+                                                             (if (or (stringp (cdr pair))
+                                                                     (consp (cdr pair)))
+                                                                 (cdr pair)
+                                                                 (write-to-string (cdr pair)))))))))
+    uri))
 
 
 (defun genurl (route-symbol &rest args)
-  (genurl/impl (concatenate 'list
-                            (submodule-full-baseurl (slot-value *route* 'submodule))
-                            (route-symbol-template route-symbol))
-               args))
+  (puri:render-uri (genurl/impl (concatenate 'list
+                                             (submodule-full-baseurl (slot-value *route* 'submodule))
+                                             (route-symbol-template route-symbol))
+                                args)
+                   nil))
 
 (defun genurl-toplevel (submodule route-symbol &rest args)
-  (genurl/impl (concatenate 'list
-                            (submodule-full-baseurl (submodule-toplevel (slot-value *route* 'submodule)))
-                            (if submodule
-                                (submodule-baseurl submodule))
-                            (route-symbol-template route-symbol))
-               args))
+  (puri:render-uri (genurl/impl (concatenate 'list
+                                             (submodule-full-baseurl (submodule-toplevel (slot-value *route* 'submodule)))
+                                             (if submodule
+                                                 (submodule-baseurl submodule))
+                                             (route-symbol-template route-symbol))
+                                args)
+                   nil))
 
 
 
 (defun genurl-with-host (route &rest args)
-  (format nil
-          "http://~A~A"
-          (hunchentoot:host)
-          (apply #'restas:genurl route args)))
+  (let ((uri (apply #'restas:genurl route args)))
+    (setf (puri:uri-scheme uri)
+          :http)
+    (setf (puri:uri-host uri)
+          (hunchentoot:host))
+    (puri:render-uri uri nil)))