Commit 6950bd3c authored by hayeah via gmail com's avatar hayeah via gmail com

Fancy URL mapping

No nesting url-map definition yet. Should be fairly easy to add...

darcs-hash:e65fa5f0ac850e82dc2d21fa0a87cd400c8cde14
parent 6eeec969
;;; Copyright (c) 2006 Howard Yeh
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;;
;; - Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;;
;; - Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in the
;; documentation and/or other materials provided with the distribution.
;;
;; - Neither the name of Howard Yeh, nor the names of its
;; contributors may be used to endorse or promote products derived
;; from this software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :wisp-mvc) (in-package :wisp-mvc)
(define-condition werror (error) (define-condition werror (error)
...@@ -18,4 +48,11 @@ ...@@ -18,4 +48,11 @@
(:report (lambda (c s) (:report (lambda (c s)
(with-slots (view-name) c (with-slots (view-name) c
(fmt :> s (fmt :> s
"Unable to render the undefined view " view-name))))) "Unable to render the undefined view " view-name)))))
\ No newline at end of file
(define-condition wisp-no-dispatch-for-url (werror)
((url :initarg :url))
(:report (lambda (c s)
(with-slots (url) c
(fmt :> s
"No dispatch is associated with " url)))))
\ No newline at end of file
;; What happens if I output half of the page, then decided to transffer control to some other page? ;;; Copyright (c) 2006 Howard Yeh
;; ;; As in forward and error report. ;; All rights reserved.
;;
;; Problem. Class methods and instance methods can't share the same name. ;; Redistribution and use in source and binary forms, with or without
;; ;; I might want to (list badguy) for all instances of badguy, or (list shopping-cart), to list the content of a shopping cart instance. ;; modification, are permitted provided that the following conditions are
;; met:
;; Maybe hack together a functional interface for request with macrolet. Probably not a good idea. ;;
;; - Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;; for class level stuff, I can first calculate the precedence-list, then do something similiar like ordinary instance method. ;;
;; - Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in the
;; documentation and/or other materials provided with the distribution.
;;
;; - Neither the name of Howard Yeh, nor the names of its
;; contributors may be used to endorse or promote products derived
;; from this software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :wisp-mvc) (in-package :wisp-mvc)
...@@ -17,6 +36,8 @@ ...@@ -17,6 +36,8 @@
(defmacro defwethod (name (&rest arglist) &body body) (defmacro defwethod (name (&rest arglist) &body body)
;; TODO probably need to add a render at the end, so all wethods at least output something
;; ;; Maybe the render macrolet wrapper belongs in view.lisp?
`(macrolet ((render (&rest args) `(macrolet ((render (&rest args)
`(respond-with-html `(respond-with-html
(with-foo-output (*html-output-stream*) (with-foo-output (*html-output-stream*)
...@@ -30,112 +51,9 @@ ...@@ -30,112 +51,9 @@
(progn (defmethod ,name ,arglist ,@body) (progn (defmethod ,name ,arglist ,@body)
(setf (gethash ,(string-invert (symbol-name name)) (setf (gethash ,(string-invert (symbol-name name))
*defined-wethods*) *defined-wethods*)
(symbol-function ',name))))) (symbol-function ',name)))))
(defun find-generic-wethod (function-name)
(gethash function-name *defined-wethods*))
(defparameter *wethod-arglist-init-fns* (make-hash-table :test #'equal))
(defun get-wethod-signature (req)
(delimited-string-to-list (request-query-value "specializers" req)
#\,))
(defun get-wethod-arguments (req)
(delimited-string-to-list (request-query-value "wethod-args" req)
#\,))
(defun make-wethod-arglist (specializer-names query-arguments)
(aif (gethash specializer-names *wethod-arglist-init-fns*)
(multiple-value-list (funcall it query-arguments))
(mapcar (fn (class arg)
(if (equal class "") arg ;; no specializer for this argument
(aif (retrieve class arg)
it
(error 'wisp-no-wobject-with-id :class class :id arg))))
specializer-names query-arguments)))
(defun apply-instance-wethod (req)
(let* ((signature (get-wethod-signature req))
(function (find-generic-wethod (request-query-value "wethod-name" req)))
(query-arguments (get-wethod-arguments req)))
(apply function
(make-wethod-arglist signature query-arguments))))
(defun apply-class-wethod (req)
(let* ((class-name (^class-name (request-query-value "class-name")))
(signature (get-wethod-signature req))
(function (find-generic-wethod (request-query-value "wethod-name" req)))
(query-arguments (get-wethod-arguments req)))
(apply function
(cons class-name (make-wethod-arglist signature query-arguments)))))
(defmacro defclass-wethod (name (&rest class-list) &body body)
;; TODO wrapper for defining class wethod
;; The defmethod-like mapper is good when we want something specific. Not so good
;; if I want something general about a class.
;;
;; Maybe all I need is a "class" control?
;; ;; Nah, just keep it simple.
;; ;; Map URL to method signature.
;; ;; /method-name/specializer1/arg1-id/specializer2/arg2-id.../?key1=?;key2=?...
;; (defgeneric find-instances (class request &key :gt :lt :eq)
;; ;; return list of all classes
;; )
(def-control list (standard-class &key (limit 100))
;; url: /list/standard-class/<arg-class>/limit/<arg-limit>
;;find all instances of the class
;;list all the instances
) )
;; Straight parm mapping
(def-control show (friend-id foe-id)
(let* ((friend-id (request 'friend-id))
(foe-id (request 'foe-id))
(friend (retrieve 'friend friend-id))
(foe (retrieve 'foe friend-id)))
(display-flame-war friend foe :severity 'bitter)))
;; Class-oriented dispatch
;; ;; Common lisp doesn't have class methods. I need some kind of class oriented dispatcher.
;; Map to: /<class-name>/<method-name>/
(def-class-wethod list ((class wobject-class))
(display-instances (find-instances class)))
;; instance-oriented dispatch
;; ;; When we want only one object.
;; Map to: /<method-name>/<arg-name1>/<arg-val1>/<arg-name1>/<arg-val1>...?key1=val1&key2=val2...
(defwethod-args show (friend foe)
(let ((friend-id (request 'friend-id))
(foe-id (request 'foe-id)))
(call-wethod (retrieve 'friend friend-id)
(retrieve 'foe friend-id))))
(defwethod show ((friend friend) (foe foe))
(display-flame-war friend foe :severity 'bitter))
;; It might be interesting to use Cell for its constraint passing programming style. ;;; Copyright (c) 2006 Howard Yeh
;; All rights reserved.
#| ;;
How should I deal with inheritance? ;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
It would be nice if I can list a class, and I'll get all the sub classes as well. ;; met:
;;
;; - Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;;
;; - Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in the
;; documentation and/or other materials provided with the distribution.
;;
;; - Neither the name of Howard Yeh, nor the names of its
;; contributors may be used to endorse or promote products derived
;; from this software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Well... I could save the metaclass information. But that's not very helpful.
Or I can list the direct instances then link over the subclasses? ;; It might be interesting to use Cell for its constraint passing programming style.
|#
(in-package :wisp-mvc) (in-package :wisp-mvc)
......
(in-package :wisp-mvc)
;;;; urlmap.lisp
(scan-to-strings (make-url-handler-regex "abc_:foo/momo_:bar") "abc_fo_o/momo_bar")
NIL
(scan-to-strings (make-url-handler-regex "abc_:foo/momo_:bar") "abc_fo_o/momo_mo_bar")
NIL
(scan-to-strings (make-url-handler-regex "abc_:foo/momo_:bar") "abc_o/momo_bar")
"abc_o/momo_bar"
#("o" "bar")
(scan-to-strings (make-url-handler-regex ":arg1/:arg2") "21_fe/llaf2213")
NIL
(scan-to-strings (make-url-handler-regex ":arg1/:arg2") "21fe/llaf_2213")
NIL
(scan-to-strings (make-url-handler-regex ":arg1/:arg2") "21fe/llaf2213/")
NIL
(scan-to-strings (make-url-handler-regex ":arg1/:arg2") "21fe/llaf2213")
"21fe/llaf2213"
#("21fe" "llaf2213")
(scan-to-strings (make-handler-url-regex "abc_:fo_o/momo_:bar") "abc_21fe/momo_llaf2213/boo")
"abc_21fe/momo_llaf2213"
#("21fe" "llaf2213")
(extract-url-fnlist "/abc__:d_ef/efg_:h")
(("abc_" "d_ef") ("efg" "h"))
(extract-url-fnlist "/:a/:b")
(("" "a") ("" "b"))
(defurlmap wisp
("" :class-wethod show
(class1 class2)
(class3 class4))
("" :wethod show
(t t)
(class1 t)
(t class2)
(class1 class2))
;; ("a" :instance-wethod show (t t))
("show/class1" :handler (fn () (show (find-class 'class1) (find-class 'class2))))
("show/:class1/:class2" :handler (fn (a b) (show (find-class a) (find-class b))))
)
;; error, because undefined classes are used in wethod signatures.
(defclass class1 () ((a :initform 0)
(b :initform 1)))
(defclass class2 () ((c :initform 3)
(d :initform 4)))
(defclass class3 (class1) ((a :initform 30)))
(defclass class4 (class2) ())
(defgeneric foo (a b))
(defmethod foo (a b)
(list 'foo a b))
(defmethod foo ((arg1 class1) arg2)
(list 'foo
(with-slots (a b) arg1
(list arg1 a b))
arg2))
(defmethod ^wisp-arg ((type (eql (find-class 'class1))) arg)
(make-instance 'class1))
(defmethod ^wisp-arg ((type (eql (find-class 'class2))) arg)
(make-instance 'class2))
(defurlmap wisp
("" :class-wethod foo
(class1 class2)
(class3 class4))
("" :wethod foo
(t t)
(class1 t)
(t class2)
(class1 class2))
;; ("a" :instance-wethod show (t t))
("foo/class1" :handler (fn () (foo (find-class 'class1) (find-class 'class2))))
("foo/:class1/:class2" :handler (fn (a b) (foo (find-class a) (find-class b))))
)
(attach-urlmap "/wisp" 'wisp)
(match-url-dispatch "abc_21fe/momo_llaf2213/boo" (get-urlmap 'wisp))
(match-url-dispatch "abc21fe/momollaf2213" (get-urlmap 'wisp))
(match-url-dispatch "class1_abc21fe/momollaf2213" (get-urlmap 'wisp))
(match-url-dispatch "class1_abc21fe/class2_momollaf2213" (get-urlmap 'wisp))
(defmethod foo (a b)
(render-html (:html (:print (list 'foo a b)))))
(defmethod foo ((arg1 class1) arg2)
(render-html (:html (:print
(list 'foo
(with-slots (a b) arg1
(list arg1 a b))
arg2)))))
(defpackage :wisp-util (:use :cl :cl-interpol :kmrcl) ; :it.bese.fiveam) ;;; Copyright (c) 2006 Howard Yeh
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;;
;; - Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;;
;; - Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in the
;; documentation and/or other materials provided with the distribution.
;;
;; - Neither the name of Howard Yeh, nor the names of its
;; contributors may be used to endorse or promote products derived
;; from this software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(defpackage :wisp-util (:use :cl :cl-ppcre :cl-interpol :kmrcl) ; :it.bese.fiveam)
(:export (:export
:split-by-separators :split-by-separators
:^string :^string
:^symbol :^symbol
;; :until
:fn :fn
:mklst :mklst
:cat-syms
:strcat :strcat
:symcat ;; renamed cat-syms :symcat ;; renamed cat-syms
...@@ -19,19 +46,25 @@ ...@@ -19,19 +46,25 @@
:mvsetq :mvsetq
:dbind :dbind
;;anaphoric macros :last1
;;anaphoric macros
:self :self
:afn :afn
:split-if :split-if
:=~
:$
:$b
:$m
:$a
:fmt)) :fmt))
(defpackage :wisp-mvc
;; wow, the dependency is getting pretty big. (defpackage :wisp-mvc
(:use :wisp-util :cl :com.gigamonkeys.foo :elephant :net.aserve :kmrcl :mop) (:use :wisp-util :cl :com.gigamonkeys.foo :elephant :net.aserve :kmrcl :mop :cl-ppcre)
(:export :find-instances (:export :find-instances
:find-instances* :find-instances*
...@@ -39,9 +72,16 @@ ...@@ -39,9 +72,16 @@
:destroy :destroy
:retrieve :retrieve
:print-object-content :print-object-content
;; wethod, wisplay, wobject. Hahaha... ;; wethod, wisplay, wobject. Hahaha...
) )
(:import-from :elephant defpclass)) (:import-from :elephant defpclass)
\ No newline at end of file (:import-from :arnesi :curry :rcurry :conjoin))
;; These functions are from KMRCL for displaying a list of symbol values in a package. Don't want them.
(shadow 'show :wisp-mvc)
(shadow 'show-variables :wisp-mvc)
(shadow 'show-functions :wisp-mvc)
;;; Copyright (c) 2006 Howard Yeh
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;;
;; - Redistributions of source code must retain the above copyright
;; notice, this list of conditions and the following disclaimer.
;;
;; - Redistributions in binary form must reproduce the above copyright
;; notice, this list of conditions and the following disclaimer in the
;; documentation and/or other materials provided with the distribution.
;;
;; - Neither the name of Howard Yeh, nor the names of its
;; contributors may be used to endorse or promote products derived
;; from this software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
(in-package :wisp-mvc)
(defparameter *urlmaps* (make-hash-table :test #'equal))
(defclass urlmap ()
((name :initarg :name)
(url-prefixes :initform nil :accessor urls)
(wethods :initarg :wethods)
(class-wethods :initarg :class-wethods)
(handlers :initarg :handlers)))
(defclass url-spec ()
((url :initarg :url :reader url)
(url-regex :reader url-regex)
(dispatch :initarg :dispatch :reader dispatch)))
(defclass url-handler (url-spec)
((url-args :initarg :url-args :reader url-args)
(url-specializers :initarg :url-specializers :reader url-specializers)))
(defclass url-class-wethod (url-spec) ())
(defclass url-wethod (url-handler) ())
(defmethod initialize-instance :after ((url-spec url-spec) &key)
(with-slots (url url-regex) url-spec
(setf url-regex (create-scanner url))))
(defmethod initialize-instance :after ((url-spec url-handler) &key)
(with-slots (url url-regex url-args url-specializers) url-spec
(setf url-regex (make-url-handler-regex url))
(loop for (arg-specializer arg-name) in (extract-url-fnlist url)
collect (aif (equal arg-specializer "")
(find-class t)
(find-class (^symbol arg-specializer))) into ass
collect arg-name into ans
finally (setf url-specializers ass
url-args ans))))
(defun make-url-handler-regex (url-spec-string)
;; #\_ is not allowed inside the argument.
;; The actual value of the argument may not contain #\_ either.
;; ;; This is to prevent confusion between urls like: "abc_def_:foo" and "abc_:foo"
;; By the greediness of the regex, it is asummed that all #\_ except the last are part of the class name.
(create-scanner (strcat "^" (regex-replace-all "([^/:]+_)?:[^/_]+" url-spec-string "\\1([^/_]+)") "$")))
#+(or)(defun make-url-handler-regex (url-spec-string)
;; for easier debugging
(strcat "^" (regex-replace-all "([^/:]+_)?:[^/_]+" url-spec-string "\\1([^/_]+)") "$"))
(defun extract-url-fnlist (url)
"Parses urls consisted of <specializer>_:<arg>/ into tuples to be used for wethod dispatch."
;; should "ab_c__:d/:efg/hij/_:klm" be legal?
(let ((arg-regex (create-scanner "([^/:]+_)?:[^/]+"))
(split-regex (create-scanner "_?:"))
(args nil))
(do-matches-as-strings (m arg-regex url)
(push m args))
(mapcar
(fn (arg) (split split-regex arg))
(nreverse args))))
;;;; defurlmap
(defmacro defurlmap (map-name &rest url-specs)
;; Will signal error if the method signature uses a non-existing class
`(register-urlmap ',map-name
,(cons 'list
(apply 'nconc
(mapcar (fn (url-spec)
(normalize-url-spec url-spec))
url-specs)))))
(defun get-urlmap (map-name)
(gethash map-name *urlmaps*))
(defun register-urlmap (map-name url-specs)
(let* (wethods class-wethods handlers)
(dolist (url-spec url-specs)
(destructuring-bind (url type function) url-spec
(ecase type
(:wethod
(push (^url-spec 'url-wethod url function) wethods))
(:class-wethod
(push (^url-spec 'url-class-wethod url function) class-wethods))
(:handler
(push (^url-spec 'url-handler url function) handlers)))))
(setf (gethash map-name *urlmaps*)
(make-instance 'urlmap
:name map-name
:wethods wethods
:class-wethods (nreverse class-wethods)
:handlers (nreverse handlers)))))
(defun ^url-spec (type url dispatch)
(make-instance type :url url :dispatch dispatch))
(defun ^wethod-url-frag (wethod-name specializers)
(list-to-delimited-string
(let ((counter 0))
(mapcar (fn (specializer)
(if (eql specializer t)
(strcat ":arg" (^string (incf counter)))
(strcat (^string specializer) "_:arg" (^string (incf counter)))))
specializers))
#\/))
(defun ^class-wethod-url-frag (wethod-name class-specializers)
(list-to-delimited-string (mapcar '^string class-specializers) #\/))
(defun normalize-url-spec (url-spec)
(let* ((handler-designator (third url-spec))
(handler (if (consp handler-designator)
(macroexpand handler-designator)
`(symbol-function ',handler-designator))))
(flet ((^handler-spec (url)
`(list ,(strcat (first url-spec) url)
,(second url-spec)
,handler)))
(ecase (second url-spec)
(:wethod
(mapcar
(fn (specializers)
(^handler-spec (^wethod-url-frag handler
(aif specializers it
'(t t)))))
(nthcdr 3 url-spec)))
(:class-wethod
(mapcar
(fn (class-specializers)
(^handler-spec (^class-wethod-url-frag handler class-specializers)))
(nthcdr 3 url-spec)))
(:handler (list (^handler-spec "")))))))
;;;; url-dispatch
(defun match-url-dispatch (request-url urlmap)
"Matches the request url against urlmap, then apply the dispatch function."
(multiple-value-bind (match url-spec args)
(with-slots (handlers wethods class-wethods) urlmap
(loop
for url-spec in (append handlers wethods class-wethods)
for (match regs) = (multiple-value-list (scan-to-strings (url-regex url-spec) request-url))
until match
finally (return (values match url-spec regs))))
(if match
(apply-url-dispatch url-spec args)
(error 'wisp-no-dispatch-for-url :url request-url))))
(defgeneric apply-url-dispatch ((url-spec url-spec) args)
(:documentation "Applies args (converted to lisp data) found in the url to the url dispatch function."))
(defmethod apply-url-dispatch ((url-spec url-spec) args)
(apply (dispatch url-spec)
(loop for arg across args collect arg)))
(defmethod apply-url-dispatch ((url-spec url-handler) args)
(apply (dispatch url-spec)
(map 'list
(fn (specializer url-arg)
(^wisp-arg specializer url-arg))
(url-specializers url-spec)
args)))
(defgeneric ^wisp-arg (specializer url-arg)
(:documentation "Used by url dispatcher to convert url string to lisp data."))
(defmethod ^wisp-arg ((specializer t) url-arg)
"Default converstion from url-string to lisp data is the url-string itself."
url-arg)
(defun ^url-dispatcher (url-prefix urlmap)
(fn (*request* *entity*)
(declare (special *request*) (special *entity*))
;; TODO clean-up port number in url (b/c we can't leave #\: inside the request url)
(match-url-dispatch (=~ (strcat url-prefix "/" "(.*)") (net.uri::uri-path (request-uri *request*))
($ 1))
urlmap)))
(defun attach-urlmap (url-prefix map-name)
"Registers a urlmap under the provided url-prefix."
(with-slots (url-prefixes) (get-urlmap map-name)
(setf url-prefixes (adjoin url-prefix url-prefixes)))
(publish-prefix :prefix url-prefix
:content-type "text/html"
:function (^url-dispatcher url-prefix (get-urlmap map-name))))
(defun detach-urlmap (map-name)