Initial commit.

.gitignore

@@ -0,0 +1,8 @@
+*.fasl
+*.dx32fsl
+*.dx64fsl
+*.lx32fsl
+*.lx64fsl
+*.x86f
+*~
+.#*

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*)
+;=> #<CLOSURE (LAMBDA (MYWAY::ENV) :IN TO-APP) {100E24F13B}>
+
+(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.

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)))

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))))

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))))

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)))))

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))

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))))

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))))

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)

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)