commit a15c72ebd5262d776fc0b77fab60c9bde6c1f07e Author: Eitaro Fukamachi Date: Thu Oct 23 15:07:44 2014 +0900 Initial commit. diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..7d8d59e --- /dev/null +++ b/.gitignore @@ -0,0 +1,8 @@ +*.fasl +*.dx32fsl +*.dx64fsl +*.lx32fsl +*.lx64fsl +*.x86f +*~ +.#* \ No newline at end of file diff --git a/README.markdown b/README.markdown new file mode 100644 index 0000000..9499afc --- /dev/null +++ b/README.markdown @@ -0,0 +1,78 @@ +# My Way + +My Way is a Sinatra-compatible URL routing library. This was originally written as Clack.Util.Route, a part of [Clack](http://clacklisp.org/). + +## Usage + +```common-lisp +(use-package :myway) + +(defvar *mapper* (make-mapper)) + +(connect *mapper* "/" "Welcome to My Way.") + +(connect *mapper* "/hello/?:name?" + (lambda (params) + (format nil "Hello, ~A" (or (getf params :name) + "Guest")))) + +(dispatch *mapper* "/") +;=> "Welcome to My Way." +; T + +(dispatch *mapper* "/hello") +;=> "Hello, Guest" +; T + +(dispatch *mapper* "/hello/Eitaro") +;=> "Hello, Eitaro" +; T + +(dispatch *mapper* "/hello/Eitaro" :method :POST) +;=> NIL +; NIL +``` + +### next-route + +```common-lisp +(connect *mapper* "/guess/:who" + (lambda (params) + (if (string= (getf params :who) "Eitaro") + "You got me!" + (next-route)))) + +(connect *mapper* "/guess/*" + (lambda (params) + (declare (ignore params)) + "You missed!")) +``` + +### to-app + +`to-app` makes a Clack app from `mapper`. + +```common-lisp +(to-app *mapper*) +;=> # + +(clack:clackup (to-app *mapper*)) +``` + +## Installation + +```common-lisp +(ql:quickload :myway) +``` + +## Author + +* Eitaro Fukamachi (e.arrows@gmail.com) + +## Copyright + +Copyright (c) 2014 Eitaro Fukamachi (e.arrows@gmail.com) + +## License + +Licensed under the LLGPL License. diff --git a/myway-test.asd b/myway-test.asd new file mode 100644 index 0000000..e0520b8 --- /dev/null +++ b/myway-test.asd @@ -0,0 +1,24 @@ +#| + This file is a part of myway project. + Copyright (c) 2014 Eitaro Fukamachi (e.arrows@gmail.com) +|# + +(in-package :cl-user) +(defpackage myway-test-asd + (:use :cl :asdf)) +(in-package :myway-test-asd) + +(defsystem myway-test + :author "Eitaro Fukamachi" + :license "LLGPL" + :depends-on (:myway + :prove) + :components ((:module "t" + :components + ((:test-file "rule") + (:test-file "myway")))) + + :defsystem-depends-on (:prove-asdf) + :perform (test-op :after (op c) + (funcall (intern #.(string :run-test-system) :prove-asdf) c) + (asdf:clear-system c))) diff --git a/myway.asd b/myway.asd new file mode 100644 index 0000000..16f300d --- /dev/null +++ b/myway.asd @@ -0,0 +1,47 @@ +#| + This file is a part of myway project. + Copyright (c) 2014 Eitaro Fukamachi (e.arrows@gmail.com) +|# + +#| + Sinatra-compatible routing library. + + Author: Eitaro Fukamachi (e.arrows@gmail.com) +|# + +(in-package :cl-user) +(defpackage myway-asd + (:use :cl :asdf)) +(in-package :myway-asd) + +(defsystem myway + :version "0.1.0" + :author "Eitaro Fukamachi" + :license "LLGPL" + :depends-on (:cl-ppcre + :trivial-types + :do-urlencode + :map-set + :alexandria + :cl-utilities) + :components ((:module "src" + :components + ((:file "myway" :depends-on ("route" "mapper" "util")) + (:file "rule") + (:file "route" :depends-on ("rule")) + (:file "mapper" :depends-on ("route" "util")) + (:file "util")))) + :description "Sinatra-compatible routing library." + :long-description + #.(with-open-file (stream (merge-pathnames + #p"README.markdown" + (or *load-pathname* *compile-file-pathname*)) + :if-does-not-exist nil + :direction :input) + (when stream + (let ((seq (make-array (file-length stream) + :element-type 'character + :fill-pointer t))) + (setf (fill-pointer seq) (read-sequence seq stream)) + seq))) + :in-order-to ((test-op (test-op myway-test)))) diff --git a/src/mapper.lisp b/src/mapper.lisp new file mode 100644 index 0000000..9363e66 --- /dev/null +++ b/src/mapper.lisp @@ -0,0 +1,61 @@ +(in-package :cl-user) +(defpackage myway.mapper + (:use :cl) + (:import-from :myway.route + :route-rule + :route-handler + :equal-route + :match-route) + (:import-from :myway.rule + :rule-methods + :rule-url) + (:import-from :myway.util + :make-collector) + (:import-from :map-set + :map-set-index) + (:export :mapper + :make-mapper + :mapper-routes + :member-route + :add-route + :next-route + :dispatch)) +(in-package :myway.mapper) + +(defstruct mapper + (%routes (make-collector))) + +(defun mapper-routes (mapper) + (funcall (mapper-%routes mapper))) + +(defun member-route (mapper route) + (member route + (mapper-routes mapper) + :test #'equal-route)) + +(defun add-route (mapper route) + (let ((routes (member-route mapper route))) + (if routes + (progn + (warn "Redefining a route for ~S ~A." + (rule-url (route-rule route)) + (map-set-index (rule-methods (route-rule route)))) + (rplaca routes route)) + (funcall (mapper-%routes mapper) route)))) + +(defparameter *next-route-function* nil) +(defun next-route () + (funcall *next-route-function*)) + +(defun dispatch (mapper url-string &key (method :GET) (allow-head T)) + (check-type mapper mapper) + (labels ((dispatch-with-rules (routes) + (loop for (route . routes) on routes + do (multiple-value-bind (matchp params) + (match-route route method url-string :allow-head allow-head) + (when matchp + (let ((*next-route-function* (lambda () (dispatch-with-rules routes)))) + (return + (values (funcall (route-handler route) params) T))))) + finally (return (values nil nil))))) + (dispatch-with-rules (mapper-routes mapper)))) diff --git a/src/myway.lisp b/src/myway.lisp new file mode 100644 index 0000000..57c7add --- /dev/null +++ b/src/myway.lisp @@ -0,0 +1,58 @@ +(in-package :cl-user) +(defpackage myway + (:use :cl) + (:import-from :myway.mapper + :mapper + :make-mapper + :member-route + :add-route + :next-route + :dispatch) + (:import-from :myway.route + :route + :make-route) + (:import-from :myway.util + :function-name) + (:export :make-mapper + :connect + :next-route + :dispatch + + :*env* + :to-app + + :route + :mapper + :add-route + :find-route + :make-route)) +(in-package :myway) + +(defun connect (mapper url fn &key (method '(:GET)) regexp (name (when (functionp fn) + (function-name fn)))) + (add-route mapper + (make-route url + :method method + :regexp regexp + :name name + :handler (typecase fn + (function fn) + (T (lambda (params) + (declare (ignore params)) + fn)))))) + +(defun find-route (mapper url &key (method '(:GET)) regexp name) + (car + (member-route mapper + (make-route url + :method method + :regexp regexp + :name name)))) + +(defparameter *env* nil) + +(defun to-app (mapper) + (lambda (env) + (let ((*env* env)) + (destructuring-bind (&key method path-info &allow-other-keys) env + (dispatch mapper path-info :method method))))) diff --git a/src/route.lisp b/src/route.lisp new file mode 100644 index 0000000..803256e --- /dev/null +++ b/src/route.lisp @@ -0,0 +1,33 @@ +(in-package :cl-user) +(defpackage myway.route + (:use :cl) + (:import-from :myway.rule + :make-rule + :match-rule + :equal-rule) + (:export :route + :route-name + :route-rule + :route-handler + :make-route + :match-route + :equal-route)) +(in-package :myway.route) + +(defstruct (route (:constructor %make-route)) + name + rule + handler) + +(defun make-route (url &key (method '(:GET)) regexp name handler) + (%make-route :name name + :rule (make-rule url :method method :regexp regexp) + :handler handler)) + +(defun equal-route (route1 route2) + (and (eq (route-name route1) (route-name route2)) + (equal-rule (route-rule route1) (route-rule route2)))) + +(defun match-route (route method url-string &key allow-head) + (check-type route route) + (match-rule (route-rule route) method url-string :allow-head allow-head)) diff --git a/src/rule.lisp b/src/rule.lisp new file mode 100644 index 0000000..a84a42b --- /dev/null +++ b/src/rule.lisp @@ -0,0 +1,120 @@ +(in-package :cl-user) +(defpackage myway.rule + (:use :cl) + (:import-from :trivial-types + :proper-list) + (:import-from :do-urlencode + :urlencode) + (:import-from :map-set + :map-set + :make-map-set + :ms-insert + :ms-member-p + :map-set-index) + (:import-from :alexandria + :ensure-list) + (:export :rule + :regex-rule + :make-rule + :match-rule + :equal-rule)) +(in-package :myway.rule) + +(defun list-to-map-set (elements) + (let ((ms (make-map-set))) + (dolist (el elements ms) + (ms-insert ms el)))) + +(defvar *default-rule-methods* + (list-to-map-set '(:GET))) + +(defstruct (rule (:constructor %make-rule)) + (methods *default-rule-methods* :type map-set) + url + regex + format-string + param-keys) + +(defstruct (regex-rule (:include rule) + (:constructor %make-regex-rule))) + +(defun make-rule (url &key (method :GET) regexp) + (let ((rule (if regexp + (%make-regex-rule :methods (list-to-map-set (ensure-list method)) :url url) + (%make-rule :methods (list-to-map-set (ensure-list method)) :url url)))) + (if regexp + (setf (rule-regex rule) (rule-url rule) + (rule-format-string rule) (ppcre:regex-replace-all "\\(.+?\\)" (rule-regex rule) "~A")) + (compile-rule rule)) + rule)) + +(defun compile-rule (rule) + (check-type rule rule) + (loop with list = (ppcre:split "(?::([\\w-]+)|(\\*))" (rule-url rule) + :with-registers-p t :omit-unmatched-p t) + for (prefix name) on list by #'cddr + collect (ppcre:regex-replace-all + "[^\\?\\/\\w-]" prefix + #'escape-special-char + :simple-calls t) into re + collect prefix into cs + if (string= name "*") + collect :splat into names + and collect "(.*?)" into re + and collect "~A" into cs + else if name + collect (read-from-string (concatenate 'string ":" name)) into names + and collect "([^/?]+)" into re + and collect "~A" into cs + finally + (setf (rule-regex rule) (format nil "^~{~A~}$" re) + (rule-format-string rule) (ppcre:regex-replace-all "~A\\?" (format nil "~{~A~}" cs) + "~:[~;~:*~A~]") + (rule-param-keys rule) names))) + +(defun escape-special-char (char) + (let ((enc (urlencode (string char)))) + (cond + ((string= char " ") (format nil "(?:~A|~A)" enc (escape-special-char #\+))) + ((string= enc char) (ppcre:quote-meta-chars enc)) + (t enc)))) + +(defun match-method-p (rule method &key allow-head) + (check-type rule rule) + (check-type method keyword) + (flet ((method-equal (rule-method) + (or (eq :ANY rule-method) + (eq method rule-method) + (and (eq method :HEAD) + allow-head + (string= :GET rule-method))))) + (some #'method-equal (map-set-index (rule-methods rule))))) + +(defun match-rule (rule method url-string &key allow-head) + (check-type rule rule) + (check-type method keyword) + (check-type url-string string) + (when (match-method-p rule method :allow-head allow-head) + (multiple-value-bind (matchp values) + (ppcre:scan-to-strings (rule-regex rule) url-string) + (when matchp + (values matchp + (if (regex-rule-p rule) + `(:captures ,(coerce values 'list)) + (loop for key in (rule-param-keys rule) + for val across values + if (eq key :splat) + collect val into splat + else if val + append (list key val) into result + finally + (return (if splat + `(:splat ,splat ,@result) + result))))))))) + +(defun equal-rule (rule1 rule2) + (and (let ((rule2-methods (rule-methods rule2))) + (every (lambda (rule) + (ms-member-p rule2-methods rule)) + (map-set-index (rule-methods rule1)))) + (string= (rule-url rule1) (rule-url rule2)))) diff --git a/src/util.lisp b/src/util.lisp new file mode 100644 index 0000000..30a1a6b --- /dev/null +++ b/src/util.lisp @@ -0,0 +1,35 @@ +(in-package :cl-user) +(defpackage myway.util + (:use :cl) + (:import-from :cl-utilities + :with-collectors) + (:export :make-collector + :function-name)) +(in-package :myway.util) + +(defun make-collector () + (let ((none '#:none)) + (declare (dynamic-extent none)) + (with-collectors (buffer) + (return-from make-collector + (lambda (&optional (data none)) + (unless (eq data none) + (buffer data)) + buffer))))) + +(defun function-name (fn) + (when (symbolp fn) + (return-from function-name fn)) + #+ccl (ccl:function-name fn) + #-ccl + (multiple-value-bind (lambda closurep name) (function-lambda-expression fn) + (declare (ignore closurep)) + (cond + (lambda nil) + ((and (listp name) + (or (eq (car name) 'labels) + (eq (car name) 'flet))) + (cadr name)) + ((and (listp name) + (eq (car name) 'lambda)) nil) + (T name)))) diff --git a/t/myway.lisp b/t/myway.lisp new file mode 100644 index 0000000..caebc69 --- /dev/null +++ b/t/myway.lisp @@ -0,0 +1,62 @@ +(in-package :cl-user) +(defpackage myway-test + (:use :cl + :myway + :prove)) +(in-package :myway-test) + +(plan nil) + +(defparameter *mapper* (make-mapper)) + +(is (find-route *mapper* "/") nil) +(is-values (dispatch *mapper* "/" :method :GET) '(nil nil)) + +(connect *mapper* "/" + (lambda (params) + (declare (ignore params)) + "Hello, World!")) + +(ok (find-route *mapper* "/")) +(is (find-route *mapper* "/" :method :POST) nil) +(is (dispatch *mapper* "/" :method :GET) "Hello, World!") + +(connect *mapper* "/post" + (lambda (params) + (declare (ignore params)) + "posted") + :method :POST) + +(is (find-route *mapper* "/post") nil) +(ok (find-route *mapper* "/post" :method :POST)) +(is-values (dispatch *mapper* "/post" :method :GET) '(nil nil)) +(is (dispatch *mapper* "/post" :method :POST) "posted") + +(connect *mapper* "/new" + (lambda (params) + (declare (ignore params)) + "new")) + +(is (dispatch *mapper* "/new" :method :GET) "new") + +(is (funcall (to-app *mapper*) + '(:method :GET :path-info "/")) + "Hello, World!") + +(connect *mapper* "/id/:n" + (lambda (params) + (if (oddp (parse-integer (getf params :n))) + "odd" + (next-route))) + :name 'odd-id) + +(connect *mapper* "/id/*" + (lambda (params) + (declare (ignore params)) + "even") + :name 'even-id) + +(is (dispatch *mapper* "/id/1") "odd") +(is (dispatch *mapper* "/id/2") "even") + +(finalize) diff --git a/t/rule.lisp b/t/rule.lisp new file mode 100644 index 0000000..5688f04 --- /dev/null +++ b/t/rule.lisp @@ -0,0 +1,131 @@ +(in-package :cl-user) +(defpackage myway-test.rule + (:use :cl + :myway.rule + :prove)) +(in-package :myway-test.rule) + +(plan nil) + +(subtest "method" + (ok (match-rule (make-rule "/hello") + :GET "/hello") + "GET") + + (ok (match-rule (make-rule "/hello" :method :GET) + :GET "/hello") + "GET") + + (ok (match-rule (make-rule "/hello" :method :GET) + :HEAD "/hello" :allow-head t) + "HEAD is allowed for GET rule") + + (ok (match-rule (make-rule "/new" :method :POST) + :POST "/new")) + + (is (match-rule (make-rule "/new" :method :POST) + :GET "/new") + nil + "GET fails for POST rule") + + (ok (match-rule (make-rule "/new" :method '(:GET :POST)) + :GET "/new") + "GET or POST") + + (ok (match-rule (make-rule "/new" :method '(:GET :POST)) + :POST "/new") + "GET or POST") + + (ok (match-rule (make-rule "/new" :method '(:ANY)) + :POST "/new") + "ANY")) + +(subtest "with named parameters" + (is-values (match-rule (make-rule "/hello/:name" :method :GET) + :GET "/hello/fukamachi") + '("/hello/fukamachi" (:name "fukamachi")) + "match") + (is-values (match-rule (make-rule "/hello/:name" :method :GET) + :GET "/hello/fukamachi/eitaro") + '(nil) + "containing a slash") + (is-values (match-rule (make-rule "/hello/:name" :method :GET) + :GET "/bye/fukamachi") + '(nil) + "not match") + (is-values (match-rule (make-rule "/blog/:post-id" :method :GET) + :GET "/blog/10") + '("/blog/10" (:post-id "10"))) + (is-values (match-rule (make-rule "/tag/:tag" :method :GET) + :GET "/tag/#lisp") + '("/tag/#lisp" (:tag "#lisp"))) + (is-values (match-rule (make-rule "/hello/?:name?" :method :GET) + :GET "/hello/Eitaro") + '("/hello/Eitaro" (:name "Eitaro"))) + (is-values (match-rule (make-rule "/hello/?:name?" :method :GET) + :GET "/hello/") + '("/hello/" nil)) + (is-values (match-rule (make-rule "/hello/?:name?" :method :GET) + :GET "/hello") + '("/hello" nil)) + (is-values (match-rule (make-rule "/say/:hello/to/:name" :method :GET) + :GET "/say/hello/to/fukamachi") + '("/say/hello/to/fukamachi" (:hello "hello" :name "fukamachi")) + "multiple named parameters")) + +(subtest "splat" + (is-values (match-rule (make-rule "/say/*/to/*" :method :GET) + :GET "/say/hello/to/world") + '("/say/hello/to/world" (:splat ("hello" "world"))))) + +(subtest "regex rules" + (is-values (match-rule (make-rule "/hello/([\\w]+)" :method :GET :regexp t) + :GET "/hello/world") + '("/hello/world" (:captures ("world"))))) + +(subtest "optional parameters" + (is-values (match-rule (make-rule "/?:foo?/?:bar?" :method :GET) + :GET "/hello/world") + '("/hello/world" (:foo "hello" :bar "world"))) + (is-values (match-rule (make-rule "/?:foo?/?:bar?" :method :GET) + :GET "/hello") + '("/hello" (:foo "hello"))) + (is-values (match-rule (make-rule "/?:foo?/?:bar?" :method :GET) + :GET "/") + '("/" nil)) + (is-values (match-rule (make-rule "/hello/?:name?" :method :GET) + :GET "/hello") + '("/hello" nil))) + +(subtest "splat and normal cases" + (is-values (match-rule (make-rule "/:foo/*" :method :GET) + :GET "/foo/bar/baz") + '("/foo/bar/baz" (:splat ("bar/baz") :foo "foo")))) + +(subtest "escape" + (is-values (match-rule (make-rule "/te+st/" :method :GET) + :GET "/te%2Bst/") + '("/te%2Bst/" nil) + "escape +") + (is-values (match-rule (make-rule "/te st/" :method :GET) + :GET "/te%2Bst/") + '("/te%2Bst/" nil) + "escape space") + (is-values (match-rule (make-rule "/test$/" :method :GET) + :GET "/test%24/") + '("/test%24/" nil) + "escape $") + (is-values (match-rule (make-rule "/te.st/" :method :GET) + :GET "/te.st/") + '("/te.st/" nil) + "escape .") + (is-values (match-rule (make-rule "/te.st/" :method :GET) + :GET "/te0st/") + '(nil) + "escape .") + (is-values (match-rule (make-rule "/test(bar)/" :method :GET) + :GET "/test%28bar%29/") + '("/test%28bar%29/" nil) + "escape ()")) + +(finalize)