Commit d63ad243 authored by hayeah via gmail com's avatar hayeah via gmail com

url mapping stuff

parent 9cfcbb28
......@@ -39,7 +39,27 @@
(defparameter *defined-wethods* (make-hash-table :test #'equal))
(defparameter *package-wethods* (make-hash-table :test #'equal))
(defun save-wethod (wethod-symbol &optional (package *package*))
(let ((wethods-in-package (gethash (^keyword package) *package-wethods*)))
(setf wethods-in-package (adjoin wethod-symbol wethods-in-package))
(setf (gethash (^keyword package) *package-wethods*) wethods-in-package)))
(defun get-direct-wethods (&optional (package *package*))
(gethash (^keyword package) *package-wethods*))
(defun accessible? (symbol)
(find-symbol (symbol-name symbol)))
(defun get-accessible-wethods (&optional (package *package*))
(let ((packages (mapcar #'^keyword (cons package (package-use-list package)))))
(mappend (fn (package) (filter #'accessible? (get-direct-wethods package)))
(defmacro defwethod (name fn-list &body body)
;; TODO combine this with defwethod
......@@ -61,13 +81,32 @@
`(render-view ,',name ,@args))))))
(setf (gethash ,(string-invert (symbol-name name))
(symbol-function ',name))))
(save-wethod ',name)))
;; (defclass-wethod foo (class1 class2) ((a class1) (b class2) &key mu)
;; (list class1 class2 a b mu))
;; (defmacro defclass-wethod (name classes fn-list &body body)
;; (when (null classes) (error "Defining class-wethod on a null class list"))
;; (let* (;; the class list is allowed to be a single symbol
;; (classes (mklst classes))
;; (wethod-name (apply #'symcat
;; (mapcar (fn (class) (symcat class "-"))
;; (mklst classes))
;; (list name))))
;; ;; is it good to define class-wethod as wethods?
;; `(defwethod ,wethod-name ,fn-list
;; (let (,(mapcar (fn (class) `(,class (find-class ',class)))
;; classes))
;; ,@body))))
(defmacro defclass-wethod (name (&rest class-list) &body body)
;; TODO wrapper for defining class wethod
(in-package :wisp-mvc)
(defun attach-urlmap (url-prefix map-name)
"Registers a urlmap under the provided url-prefix."
(let ((map (get-urlmap map-name)))
(detect-circular-map-nesting map)
(with-slots (url-prefixes) map
(setf url-prefixes (adjoin url-prefix url-prefixes)))
(publish-prefix :prefix url-prefix
:content-type "text/html"
:function (^url-dispatcher url-prefix map))))
(defun detect-circular-map-nesting (urlmap)
"Detects circular and undefined url mappings."
(let ((*all-maps* (make-hash-table)))
(labels ((rec-test (urlmap2)
(if urlmap2
(dolist (map-name (get-nest-map-names urlmap2))
(let ((nested-urlmap (get-urlmap map-name)))
(cond ((null nested-urlmap)
(error 'wisp-undefined-nested-urlmap
:nested-map map-name
:root-map urlmap))
((gethash nested-urlmap *all-maps*)
(error 'wisp-circular-nested-urlmap
:circular-map nested-urlmap
:parent-map urlmap2
:root-map urlmap))
(t (setf (gethash nested-urlmap *all-maps*) t)
;; recursively test for cicularity
(dolist (map-name (get-nest-map-names nested-urlmap))
(aif (get-urlmap map-name)
(rec-test it)
(error 'wisp-undefined-nested-urlmap
:nested-map map-name
:root-map nested-urlmap))))))))))
(setf (gethash urlmap *all-maps*) t)
(rec-test urlmap))))
(defun get-nest-map-names (urlmap)
(mapcar #'url-nested-map-name
(slot-value urlmap 'nested-maps)))
(defun detach-urlmap (map-name)
;; Don't know how to remove a published handler
(dolist (url (urls (get-urlmap map-name)))
(publish-prefix :prefix url
:function nil)))
(defun ^url-dispatcher (url-prefix urlmap)
(fn (*request* *entity*)
(declare (special *request*) (special *entity*))
;; setup the dynamic enviornment that allows functional interface to http request.
;; *cookies*
;; *parameters*
;; *session*
(let ((*parameters*) (parse-request-parameters (request-query *request*)))
(declare (special *parameters*))
;; get rid of the heading `/'
(remove-url-prefix (net.uri:uri-path (request-uri *request*)) url-prefix)
(defun remove-url-prefix (url url-prefix)
(=~ url-prefix url $a))
(defparameter *parameters* nil)
(defun parse-request-parameters (alist)
(defun param (key)
;; this is awful...
(cdr (assoc (^string key) *parameters*)))
;; Shit. I just realized that I am a complete retard. The matching
;; process has linear runtime wrt to the number of possible matches...
;; TODO Fix linear run-time.
(in-package :wisp-mvc)
(defun match-url-dispatch (request-url urlmap &key (nested? nil))
"Matches the request url against urlmap, then apply the dispatch function."
;; expects the request-url not be prepended with `/'
(with-slots (handlers wethods class-wethods packages nested-maps) urlmap
((match-url-handlers request-url handlers) (values it t))
((match-url-methods request-url (append class-wethods wethods)) (values it t))
((match-url-packages request-url packages) (values it t))
((match-nested-urlmaps request-url nested-maps :nested? nested?) (values it t))
((not nested?) (error 'wisp-no-dispatch-for-url :url request-url)))))
(defun match-url-handlers (request-url url-handlers)
;; if no match, returns nil, which is the same as (values nil nil),
;; so it works just fine for acond2 in `match-url-dispatch'.
for url-handler in url-handlers
for (match args) = (multiple-value-list (scan-to-strings (url-regex url-handler) request-url))
when match do (return (values (apply-url-handler url-handler args) t))))
(defun match-url-methods (request-url url-methods)
for url-method in url-methods
for (match args discriminator) = (match-url-method (=~ (url-regex url-method) request-url $a) url-method)
when match do(return (values (apply-url-method url-method args discriminator)))))
(defun match-url-method (request-url url-method)
;; discriminators and wethod-url-regexes should be the same length.
for discriminator in (discriminators url-method)
for wethod-url-regex in (wethod-url-regexes url-method)
for (match args) = (multiple-value-list (scan-to-strings wethod-url-regex request-url))
when match do (return (list match args discriminator))))
(defun match-url-packages (request-url url-packages)
;; to make my life easier, don't try to dynamically update a package map yet.
;; Though this would be nice to have.
for url-package in url-packages
for (val match?) =
(with-slots (url-regex urlmap) url-package
(match-url-dispatch (=~ url-regex request-url $a) urlmap :nested? t)))
when match? do (return (values val t))))
(defun match-nested-urlmaps (request-url url-nested-maps &key (nested? nil))
(flet ((match-rec (map &key nested?)
(with-slots (url-regex nested-map-name) map
(awhen (=~ url-regex request-url $a)
(match-url-dispatch it (get-urlmap nested-map-name) :nested? nested?)))))
(dolist (map (butlast url-nested-maps))
(awhen2 (match-rec map :nested? t)
(return-from match-nested-urlmap (values it t))))
;; tail-recurse to the last nested urlmap
(aand (last1 url-nested-maps) (match-rec it :nested? nested?))))
(defun apply-url-handler (url-handler args)
(apply (dispatch url-handler) (map 'list #'identity args)))
(defgeneric apply-url-method (url-method args discriminator)
(:documentation "Applies args (converted to lisp data by `^wisp-arg') found in the url to the method function."))
(defmethod apply-url-method ((url-method url-wethod) args discriminator)
(apply (dispatch url-method)
(map 'list
(fn (type arg) (^wisp-arg type arg))
discriminator args)))
;; No idea how to implement class wethods yet.
;; (defmethod apply-url-method ((url-method url-class-wethod) args discriminator)
;; (apply (dispatch url-method)
;; (map 'list
;; (fn (type arg) (^wisp-arg
;; ;; the specializer of class-wethod is stored in the form (eql <class-symbol>)
;; (find-class (second type))
;; arg))
;; discriminator args)))
(defgeneric ^wisp-arg (type url-arg)
(:documentation "Used by url dispatcher to convert url string to lisp data."))
(defmethod ^wisp-arg ((type t) url-arg)
"Default converstion from url-string to lisp data is the url-string itself."
This diff is collapsed.
This diff is collapsed.
......@@ -2,17 +2,18 @@
(defpackage :wisp-util
(:use :cl :cl-ppcre :cl-interpol :arnesi :kmrcl) ; :it.bese.fiveam)
(:shadowing-import-from :arnesi
:it :copy-file :random-string
:quit :awhen :aand :acond :aif
:copy-file :random-string
(:shadowing-import-from :cl-ppcre :quote-meta-chars)
(:import-from :kmrcl :awhen :aand :acond :aif :awhen2 :aif2 :acond2 )
......@@ -20,15 +21,21 @@
;; list
;;anaphoric macros
;; rkr/macro
......@@ -75,8 +82,12 @@
(defpackage :wisp-sys
(:use :cl :wisp-util)
(:export :*wisp-debug*))
(defpackage :wisp-mvc
(:use :cl :wisp-util
(:use :cl :wisp-util :wisp-sys
;; :ele-bdb
(in-package :wisp-mvc)
;;;; urlmap.lisp
(def-suite urlmap)
(in-suite urlmap)
(test make-url-handler-regex
(is (eql (scan-to-strings (make-url-handler-regex "abc_:foo/momo_:bar") "abc_fo_o/momo_bar")
(is (eql (scan-to-strings (make-url-handler-regex "abc_:foo/momo_:bar") "abc_fo_o/momo_mo_bar")
(is (equal
(^string (multiple-value-list (scan-to-strings (make-url-handler-regex "abc_:foo/momo_:bar") "abc_o/momo_bar")))
(^string '("abc_o/momo_bar" #("o" "bar")))))
(is (eql (scan-to-strings (make-url-handler-regex ":arg1/:arg2") "21_fe/llaf2213")
(is (eql (scan-to-strings (make-url-handler-regex ":arg1/:arg2") "21fe/llaf_2213")
(is (eql
(scan-to-strings (make-url-handler-regex ":arg1/:arg2") "21fe/llaf2213/")
(is (equal
(^string (multiple-value-list (scan-to-strings (make-url-handler-regex ":arg1/:arg2") "21fe/llaf2213")))
(^string '("21fe/llaf2213" #("21fe" "llaf2213")))))
(test extract-url-fnlist
(is (equal
(^string (extract-url-fnlist "/abc__:d_ef/efg_:h") )
(^string '(("abc_" "d_ef") ("efg" "h")))))
(is (equal
(^string (extract-url-fnlist "/:a/:b"))
(^string '(("" "a") ("" "b")))))
(test normalize-url-spec
(is (equal
(^string (normalize-url-spec '("show/class1" :handler (fn () (show (find-class 'class1) (find-class 'class2))))))
(^string '((list "show/class1" :handler
#'(lambda nil
(show (find-class 'class1) (find-class 'class2))))))
(is (equal
(^string (normalize-url-spec '("show/:class1/:class2" :handler (fn (a b) (show (find-class a) (find-class b))))))
(^string '((list "show/:class1/:class2" :handler
#'(lambda (a b) (show (find-class a) (find-class b))))))
(is (equal
(^string (normalize-url-spec '("" :wethod foo
(t t)
(class1 t)
(t class2)
(class1 class2))))
(^string '((list ":arg1/:arg2" :wethod (symbol-function 'foo))
(list "class1_:arg1/:arg2" :wethod (symbol-function 'foo))
(list ":arg1/class2_:arg2" :wethod (symbol-function 'foo))
(list "class1_:arg1/class2_:arg2" :wethod (symbol-function 'foo))))
(is (equal
(^string (normalize-url-spec '("" :class-wethod show
(class1 class2)
(class3 class4))))
(^string '((list "class1/class2" :class-wethod (symbol-function 'show))
(list "class3/class4" :class-wethod (symbol-function 'show))))
(is (equal
(^string (normalize-url-spec '("some" :map silly-map)))
(^string '((list "some" :map 'silly-map)))
(defurlmap foo
("" :map bar))
(defurlmap bar
("" :map qux))
(defurlmap qux
;; signals an error because qux refering to foo causes a circular definition.
("" :map foo))
(defurlmap foo2
;; signals an error because foo3 refers to undefined map
("" :map foo3))
(test urlmap-definitional-errors
(signals wisp-circular-nested-urlmap
(attach-urlmap "/" 'foo))
(signals wisp-undefined-nested-urlmap
(attach-urlmap "/" 'foo2)))
(defclass class1 () ((a :initform 1)
(b :initform 2)))
(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 (class-name (class-of arg1)) a b))
(defmethod foo ((arg1 class1) (arg2 class2))
(list 'foo
(with-slots (a b) arg1
(list (class-name (class-of arg1)) a b))
(with-slots (c d) arg2
(list (class-name (class-of arg2)) c d))))
(defmethod ^wisp-arg ((type (eql (find-class 'class1))) arg)
(make-instance 'class1))
(defmethod ^wisp-arg ((type (eql (find-class 'class2))) arg)
(make-instance 'class2))
(defmethod ^wisp-arg ((type (eql (find-class 'class3))) arg)
(make-instance 'class3))
(defmethod ^wisp-arg ((type (eql (find-class 'class4))) arg)
(make-instance 'class4))
(defurlmap wisp
("" :class-wethod foo
(class1 class2))
("" :wethod foo
(t t)
(class1 t)
(t class2)
(class1 class2)
(class3 class4))
("wisp2" :map wisp2)
;; ("a" :instance-wethod show (t t))
("foo/:arg1/:arg2" :handler (fn (a b) (list 'wisp a b)))
(defurlmap wisp2
("foo/:arg1/:arg2" :handler (fn (a b) (list 'wisp2 a b)))
("" :map wisp3)
(defurlmap wisp3
; this should not shadow wisp2
("foo/:arg1/:arg2" :handler (fn (a b) (list 'wisp3 a b)))
("foo2/:arg1/:arg2" :handler (fn (a b) (list 'wisp3 a b)))
(attach-urlmap "/wisp" 'wisp)
;; (get-effective-urls 'wisp)
(test match-url-dispatch-for-url
(signals wisp-no-dispatch-for-url
(match-url-dispatch "abc_21fe/momo_llaf2213/boo" (get-urlmap 'wisp)))
(is (equal
(^string (match-url-dispatch "abc21fe/momollaf2213" (get-urlmap 'wisp)))
(^string '(foo "abc21fe" "momollaf2213"))
(is (equal
(^string (match-url-dispatch "class1_abc21fe/momollaf2213" (get-urlmap 'wisp)))
(^string '(foo (class1 1 2) "momollaf2213"))
(is (equal
(^string (match-url-dispatch "class1_abc21fe/class2_momollaf2213" (get-urlmap 'wisp)))
(^string '(foo (class1 1 2) (class2 3 4)))
(is (equal
(^string (match-url-dispatch "class3_abc21fe/class4_momollaf2213" (get-urlmap 'wisp)))
(^string '(foo (class3 30 2) (class4 3 4)))
(is (equal
(^string (match-url-dispatch "foo/abc/def" (get-urlmap 'wisp)))
(^string '(wisp "abc" "def"))
(is (equal
(^string (match-url-dispatch "wisp2/foo/abc/def" (get-urlmap 'wisp)))
(^string '(wisp2 "abc" "def"))
(is (equal
(^string (match-url-dispatch "wisp2/foo/abc/def" (get-urlmap 'wisp)))
(^string '(wisp2 "abc" "def"))
(is (equal
(^string (match-url-dispatch "wisp2/foo/abc/def" (get-urlmap 'wisp)))
(^string '(wisp2 "abc" "def"))
(is (equal
(^string (match-url-dispatch "wisp2/foo2/abc/def" (get-urlmap 'wisp)))
(^string '(wisp3 "abc" "def"))
(run! 'urlmap)
;; (defmethod foo (a b)
;; (render-html (:html (:print (list 'foo a b)))))
......@@ -27,6 +27,15 @@
(fmt :> s
"No dispatch is associated with " url)))))
(define-condition wisp-undefined-wethod-discriminator (werror)
((discriminator :initarg :discriminator)
(valid-discriminators :initarg :valid-discriminators)
(wethod-name :initarg :wethod-name))
(:report (lambda (c s)
(with-slots (discriminator wethod-name valid-discriminators) c
(fmt :> s "Discriminator " discriminator " is not available to wethod " wethod-name "."
:% "The valid discriminators are " valid-discriminators)))))
(define-condition wisp-undefined-nested-urlmap (werror)
((nested-map :initarg :nested-map)
(root-map :initarg :root-map))
......@@ -2,6 +2,7 @@
(in-package :wisp-util)
(defun mac (body n)
(do ((body body (macroexpand-1 body))
(n n (1- n)))
......@@ -82,14 +83,20 @@ Return:
(defun ^keyword (symbol-thing)
(etypecase symbol-thing
(symbol (intern (symbol-name symbol-thing) :keyword))
(string (intern (string-invert symbol-thing) :keyword))))
(string (intern (string-invert symbol-thing) :keyword))
(package (^keyword (intern (package-name symbol-thing))))))
(defun ^package (symbol-thing)
(etypecase symbol-thing
(symbol (find-package (^keyword symbol-thing)))
(string (find-package string))))
(defun unquote (form)
;; ugly hack sometimes useful for defining macros.
;; Short of using eval...
(if (and (consp form) (eql (car form) 'quote))
(unquote (second form))
(eval-when (:compile-toplevel :load-toplevel :execute)
......@@ -150,7 +157,7 @@ Return:
(defun symcat (&rest symbols)
(intern (apply 'strcat (mapcar 'symbol-name symbols))))
(intern (string-invert (apply 'strcat (mapcar #'^string symbols)))))
......@@ -36,7 +36,8 @@
((:file "utils")
(:file "rkr-macro")
(:file "fmt")
(:file "condition"))
(:file "condition")
(:file "wisp-sys"))
:serial t)
(:module :foo-patch :components
((:file "foo-packages")
......@@ -52,7 +53,9 @@
(:file "view")
(:file "control")
(:file "form")
(:file "urlmap")
(:file "url-map")
(:file "url-dispatch" :depends-on ("url-map"))
(:file "url-attach" :depends-on ("url-dispatch"))
(:file "wisp-tags"))
:depends-on ("packages" :utils :foo-patch)))
:depends-on (
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment