From 144e4b3208cbc7f08f2fd8aa4064c80211db6183 Mon Sep 17 00:00:00 2001 From: Bruno Dias Date: Sat, 12 Oct 2024 11:03:15 -0300 Subject: [PATCH] more stuff. --- routing/dsl.lisp | 79 +++++++------ routing/match.lisp | 33 ++++++ routing/package.lisp | 47 +++----- routing/routes.lisp | 91 +++++++-------- routing/static.lisp | 1 - routing/test.lisp | 257 +++++++++++++++++++++++-------------------- routing/types.lisp | 60 ++++++++++ routing/woo.lisp | 32 +++--- tests-runner.lisp | 2 - wst.routing.asd | 19 ++-- 10 files changed, 355 insertions(+), 266 deletions(-) create mode 100644 routing/match.lisp create mode 100644 routing/types.lisp diff --git a/routing/dsl.lisp b/routing/dsl.lisp index b87c869..fd34e8b 100644 --- a/routing/dsl.lisp +++ b/routing/dsl.lisp @@ -1,18 +1,18 @@ (defpackage #:wst.routing.dsl (:use #:cl) (:import-from #:cl-hash-util - #:hash - #:with-keys) + #:hash + #:with-keys) (:import-from #:wst.routing - #:any-route-handler) + #:any-route-handler) (:import-from #:alexandria - #:ensure-list) + #:ensure-list) (:import-from #:wst.routing - #:add-route) + #:add-route) (:import-from #:wst.routing - #:remove-route) + #:remove-route) (:import-from #:str - #:join) + #:join) (:export #:build-webserver #:wrap @@ -27,37 +27,37 @@ (with-keys ((bfs "befores") (paths "paths") (afs "afters")) stack (destructuring-bind (method &rest rest) -api + api (let ((actions (append (reduce #'append bfs) - rest - (reduce #'append afs)))) - (any-route-handler - method - (lambda (request response) - (loop :for fn :in actions - :do (funcall fn request response) - :finally (return response)))))))) + rest + (reduce #'append afs)))) + (any-route-handler + method + (lambda (request response) + (loop :for fn :in actions + :do (funcall fn request response) + :finally (return response)))))))) (defun %create-route (api stack) "Execute `route` is found take the API and build with the STACK." (with-keys ((bfs "befores") (paths "paths") (afs "afters")) stack (destructuring-bind (method route-name path &rest rest) -api + api (let* ((onstack (join "" paths)) - (route-path (if (stringp path) path "")) - (the-path (concatenate 'string onstack route-path)) - (the-action (if (not (stringp path)) path (car rest))) - (actions (append - (reduce #'append bfs) - (ensure-list the-action) - (reduce #'append afs)))) - (remove-route route-name) - (add-route route-name the-path method - (lambda (request response) - (loop :for fn :in actions - :do (funcall fn request response) - :finally (return response)))))))) + (route-path (if (stringp path) path "")) + (the-path (concatenate 'string onstack route-path)) + (the-action (if (not (stringp path)) path (car rest))) + (actions (append + (reduce #'append bfs) + (ensure-list the-action) + (reduce #'append afs)))) + (remove-route route-name) + (add-route route-name the-path method + (lambda (request response) + (loop :for fn :in actions + :do (funcall fn request response) + :finally (return response)))))))) (defun %wrap-routes (api stack) "Execute when `wrap is found. @@ -70,28 +70,27 @@ api stack (progn (setf bfs (append bfs (list (ensure-list (getf api :before nil)))) -afs (append afs (list (ensure-list (getf api :after nil))))) + afs (append afs (list (ensure-list (getf api :after nil))))) (%build-webserver (getf api :route) stack) (setf bfs (butlast bfs) - afs (butlast afs))))) + afs (butlast afs))))) (defun %build-webserver (api stack) "Build from a API definition" (let ((item (car api)) -(routes (cdr api))) + (routes (cdr api))) (case item (wrap (%wrap-routes routes stack)) (any-route (%any-route routes stack)) (route (%create-route routes stack)) (group (map nil (lambda (api) (%build-webserver api stack)) routes)) (resource (destructuring-bind (path &rest rest) - (cdr api) - (setf (gethash "paths" stack) - (append (gethash "paths" stack) (list path))) - (map nil (lambda (item) (%build-webserver item stack)) rest) - (setf (gethash "paths" stack) - (butlast (gethash "paths" stack))))) - (t (error (format nil "not handled ~a" item)))))) + (cdr api) + (setf (gethash "paths" stack) + (append (gethash "paths" stack) (list path))) + (map nil (lambda (item) (%build-webserver item stack)) rest) + (setf (gethash "paths" stack) + (butlast (gethash "paths" stack)))))))) (defun build-webserver (api) "Build web server from a API definition." diff --git a/routing/match.lisp b/routing/match.lisp new file mode 100644 index 0000000..8ba4c9d --- /dev/null +++ b/routing/match.lisp @@ -0,0 +1,33 @@ +(in-package :wst.routing) + +(declaim (ftype (function (matcher symbol list integer) list) + match)) +(defun match (matcher method segments count) + "Run the MATCHER for METHOD, SEGMENTS and COUNT." + (if (or (not (= count (matcher-segments-count matcher))) + (not (equal method (matcher-method matcher)))) + (list :skip nil) + (list :params (loop :for x :in (matcher-segments matcher) + :for y :in segments + :if (str:starts-with? ":" x) + :collect (cons (str:substring 1 (length x) x) y) + :else :if (not (equal x y)) + :do (return-from match (list :skip nil)))))) + +(declaim (ftype (function (route symbol list integer) list) + do-matcher)) +(defun do-matcher (route method segments count) + (destructuring-bind (action params) + (match (route-matcher route) method segments count) + (when (equal action :params) + (cons route params)))) + +(defun match-route (path method &optional (routes *routes*)) + "Find a route by PATH and METHOD." + (let* ((segments + (remove-if (lambda (p) (or (null p) (= 0 (length p)))) + (cdr (str:split "/" path)))) + (count (length segments))) + (loop :for route :in routes + :do (alexandria:when-let ((match-data (do-matcher route method segments count))) + (return match-data))))) diff --git a/routing/package.lisp b/routing/package.lisp index e97fc7b..708ab2b 100644 --- a/routing/package.lisp +++ b/routing/package.lisp @@ -1,20 +1,20 @@ (defpackage #:wst.routing (:use #:cl) (:import-from #:cl-hash-util - #:hash-create - #:hash - #:with-keys) + #:hash-create + #:hash + #:with-keys) (:import-from #:alexandria - #:ensure-list) + #:ensure-list) (:import-from #:str - #:split - #:join) + #:split + #:join) (:import-from #:flexi-streams - #:make-flexi-stream) + #:make-flexi-stream) (:import-from #:com.inuoe.jzon - #:parse) + #:parse) (:import-from #:uiop - #:read-file-string) + #:read-file-string) (:export #:request #:response @@ -37,6 +37,7 @@ #:make-response #:request-data #:request-uri + #:request-query #:request-method #:request-headers #:request-content @@ -48,26 +49,12 @@ #:request-content-length #:write-response #:unprocessable-entity - #:parse-uri)) + #:parse-uri + #:dispatch-route-by-route + #:route-uri-of + #:route-path + #:with-request-params + #:with-response-data + #:with-request-data)) (in-package :wst.routing) - -(defstruct request - "Request object." - (uri "" :type string) - (method :GET :type symbol) - (headers (hash-create nil) :type hash-table) - (content-type nil :type (or string null)) - (content-length 0 :type integer) - content - (data nil :type list)) - -(defstruct response - "Response object." - (status 0 :type integer) - (headers nil :type list) - (content "" :type string) - (data nil :type list)) - -(defvar *routes* nil - "Hash to hold all routes.") diff --git a/routing/routes.lisp b/routing/routes.lisp index 653088a..80d2949 100644 --- a/routing/routes.lisp +++ b/routing/routes.lisp @@ -90,40 +90,6 @@ *routes*)) t) -(declaim (ftype (function (matcher symbol list integer) list) - match)) -(defun match (matcher method segments count) - "Run the MATCHER for METHOD, SEGMENTS and COUNT." - (if (or (not (= count (matcher-segments-count matcher))) - (not (equal method (matcher-method matcher)))) - (list :skip nil) - (list :params (loop :for x :in (matcher-segments matcher) - :for y :in segments - :if (str:starts-with? ":" x) - :collect (cons (str:substring 1 (length x) x) y) - :else :if (not (equal x y)) - :do (return-from match (list :skip nil)))))) - -(declaim (ftype (function (route symbol list integer) list) - do-matcher)) -(defun do-matcher (route method segments count) - (destructuring-bind (action params) - (match (route-matcher route) method segments count) - (when (equal action :params) - (cons route params)))) - -(declaim (ftype (function (string symbol &optional list) list) - match-route)) -(defun match-route (path method &optional (routes *routes*)) - "Find a route by PATH and METHOD." - (let* ((segments - (remove-if (lambda (p) (or (null p) (= 0 (length p)))) - (cdr (str:split "/" path)))) - (count (length segments))) - (loop :for route :in routes - :do (alexandria:when-let ((match-data (do-matcher route method segments count))) - (return match-data))))) - (declaim (ftype (function (string) hash-table) parse-cookies-string)) (defun parse-cookies-string (cookies) @@ -148,11 +114,12 @@ (list :cookies nil))) t)) -(declaim (ftype (function (symbol) (or route null)) +(declaim (ftype (function (symbol &optional list) (or route null)) find-route-by-name)) -(defun find-route-by-name (name) +(defun find-route-by-name (name &optional (routes *routes*)) "Find a route by NAME." - (find name *routes* :test 'equal :key 'route-name)) + (let ((sname (symbol-name name))) + (find-if (lambda (route) (string-equal sname (symbol-name (route-name route)))) routes))) (defun %dispatcher (route request response) "The dispatcher for any kind of dispatch. ROUTE-DATA is a pair of a route and the params and a request object." @@ -162,7 +129,6 @@ (rs (funcall fn request response))) rs) (t (err) - (log:error "unhandled error ~a" err) (or (and *condition-handler* (funcall *condition-handler* request response err)) (funcall #'default-internal-server-error-resounse response))))) @@ -172,9 +138,9 @@ request (let* ((response (make-response)) (found (or (match-route uri method) - (and *any-route-handler* - (equal (request-method request) (route-method *any-route-handler*)) - (cons *any-route-handler* nil))))) + (and *any-route-handler* + (equal (request-method request) (route-method *any-route-handler*)) + (cons *any-route-handler* nil))))) (parse-cookies headers request response) (if (not found) (%dispatcher nil request response) @@ -185,19 +151,35 @@ (append (request-data request) (list :params params))) (%dispatcher route request response))))))) -(defun dispatch-route-by-name (name request &optional params) +(defun dispatch-route-by-name (name request &optional old-params) "Dispatch a route by its PATH and METHOD. Pass REQUEST to it." + (declare (ignorable old-params)) (with-slots (method headers) request (let* ((response (make-response)) - (route (or (find-if (lambda (route) (equal name (route-name route))) *routes*) - (and *any-route-handler* - (eql method (route-method *any-route-handler*)) - *any-route-handler*)))) - (log:info *routes* route) - (parse-cookies headers request response) - (setf (request-data request) (append (request-data request) (list :params params))) - (%dispatcher route request response)))) + (route (or (find-route-by-name name *routes*) + (and *any-route-handler* + (eql method (route-method *any-route-handler*)) + *any-route-handler*))) + (found (or (match-route (request-uri request) (request-method request)) (cons route nil)))) + (destructuring-bind (route . params) + found + (parse-cookies headers request response) + (setf (request-data request) (append (request-data request) (list :params params))) + (%dispatcher route request response))))) + +(defun dispatch-route-by-route (route request) + "Dispatch a route by its PATH and METHOD. Pass REQUEST to it." + (with-slots (method headers) + request + (let* ((response (make-response)) + (found (or (match-route (request-uri request) (request-method request) (list route)) + (cons route nil)))) + (destructuring-bind (route . params) + found + (parse-cookies headers request response) + (setf (request-data request) (append (request-data request) (list :params params))) + (%dispatcher route request response))))) (defmacro route (name method path args &body body) "Define a route with NAME for its function name, PATH to be requested and @@ -207,3 +189,12 @@ (defun ,name ,args ,@body) (add-route ',name ,path ,method #',name))) + +(defun route-uri-of (route &optional args) + "Generate the uri of a ROUTE applying ARGS as parameters." + (concatenate 'string "/" + (str:join "/" (loop :for segment :in (matcher-segments (route-matcher route)) + :if (char-equal #\: (aref segment 0)) + :collect (format nil "~a" (pop args)) + :else + :collect segment)))) diff --git a/routing/static.lisp b/routing/static.lisp index f52be04..8776718 100644 --- a/routing/static.lisp +++ b/routing/static.lisp @@ -16,7 +16,6 @@ (declare (ignorable request response)) (let* ((serving (concatenate 'string (namestring ,*static-path*) ,path)) (content (read-file-string serving))) - (log:info serving content) (write-response response :status 200 :content-type ,mime diff --git a/routing/test.lisp b/routing/test.lisp index 795c79e..831b0f5 100644 --- a/routing/test.lisp +++ b/routing/test.lisp @@ -1,20 +1,21 @@ (defpackage #:wst.routing.test (:use #:cl) (:import-from #:cl-hash-util - #:hash-create) + #:hash-create) (:import-from #:wst.routing - #:response-headers - #:write-response - #:ok-response - #:dispatch-route-by-name - #:response-data - #:response-content - #:make-request - #:add-route - #:remove-route - #:dispatch-route - #:response - #:route)) + #:response-status + #:response-headers + #:write-response + #:ok-response + #:dispatch-route-by-name + #:response-data + #:response-content + #:make-request + #:add-route + #:remove-route + #:dispatch-route + #:response + #:route)) (in-package :wst.routing.test) @@ -29,48 +30,53 @@ (5am:def-test route-should-respond-when-dispatched () (let ((rs (dispatch-route (wst.routing:make-request :uri "/testing-route" - :method :GET)))) + :method :GET)))) (5am:is (equal "ok" (response-content rs))))) (5am:def-test route-should-respond-with-404-when-dispatched-with-wrong-method () (let ((response (dispatch-route (wst.routing:make-request :uri "/" - :method :POST)))) + :method :POST)))) (5am:is (equal "not found" (response-content response))))) (5am:def-test removing-test-route () (add-route 'to-be-remove "/to-be-removed" :GET (lambda (a b) (declare (ignorable a b)) t)) (remove-route 'to-be-remove) (let ((rs (dispatch-route (wst.routing:make-request :uri "/to-be-removed" - :method :GET)))) + :method :GET)))) (5am:is (equal "not found" (response-content rs))))) (5am:def-test allow-parameters-on-path () (add-route 'route-with-id - "/r/:id" - :GET - (lambda (request r) - (declare (ignore r)) - (getf (wst.routing:request-data request) :params))) - + "/r/:id" + :GET + (lambda (request r) + (declare (ignore r)) + (getf (wst.routing:request-data request) :params))) (let* ((request (make-request :uri "/r/6" :method :GET))) (dispatch-route request) (5am:is (equalp '(("id" . "6")) (getf (wst.routing:request-data request) :params)))) (remove-route 'route-with-id)) (5am:def-test route-should-respond-when-dispatched () - - (let ((rs (dispatch-route (wst.routing:make-request :uri "/testing-route" - :method :GET)))) + (let ((rs (dispatch-route (wst.routing:make-request + :uri "/testing-route" + :method :GET)))) (5am:is (equal "ok" (response-content rs))))) +(5am:def-test route-should-respond-with-default-not-found () + (let ((rs (dispatch-route (wst.routing:make-request + :uri "/x" + :method :GET)))) + (5am:is (= 404 (response-status rs))) + (5am:is (equal "not found" (response-content rs))))) (5am:def-test return-internal-server-error-if-exception-is-thrown () (add-route 'throw-exception "/throw-exception" :GET (lambda (request response) - (declare (ignorable request response)) - (error "something bad happened."))) + (declare (ignorable request response)) + (error "something bad happened."))) (let ((rs (dispatch-route (wst.routing:make-request :uri "/throw-exception" - :method :GET)))) + :method :GET)))) (5am:is (equal "internal server error" (response-content rs))) (remove-route 'throw-exception))) @@ -87,9 +93,9 @@ (5am:def-test build-with-just-route-is-the-same-of-just-route-using-the-dsl () (setf wst.routing::*routes* nil) (let* ((count 0) - (must-be-called (lambda (req res) - (declare (ignore req res)) - (setf count (1+ count))))) + (must-be-called (lambda (req res) + (declare (ignore req res)) + (setf count (1+ count))))) (wst.routing.dsl:build-webserver `(wst.routing.dsl:wrap :route (wst.routing.dsl:route :GET index "/" ,must-be-called))) @@ -99,9 +105,9 @@ (5am:def-test build-route-with-just-before () (setf wst.routing::*routes* nil) (let* ((count 0) - (must-be-called (lambda (req res) - (declare (ignore req res)) - (setf count (1+ count))))) + (must-be-called (lambda (req res) + (declare (ignore req res)) + (setf count (1+ count))))) (wst.routing.dsl:build-webserver `(wst.routing.dsl:wrap :before ,must-be-called @@ -112,9 +118,9 @@ (5am:def-test build-route-with-just-after () (setf wst.routing::*routes* nil) (let* ((count 0) - (must-be-called (lambda (req res) - (declare (ignore req res)) - (setf count (1+ count))))) + (must-be-called (lambda (req res) + (declare (ignore req res)) + (setf count (1+ count))))) (wst.routing.dsl:build-webserver `(wst.routing.dsl:wrap :route (wst.routing.dsl:route :GET index "/" ,must-be-called) @@ -125,9 +131,9 @@ (5am:def-test build-a-route-wrapped-using-the-dsl () (setf wst.routing::*routes* nil) (let* ((count 0) - (must-be-called (lambda (req res) - (declare (ignore req res)) - (setf count (1+ count))))) + (must-be-called (lambda (req res) + (declare (ignore req res)) + (setf count (1+ count))))) (wst.routing.dsl:build-webserver `(wst.routing.dsl:wrap :before ,must-be-called @@ -139,9 +145,9 @@ (5am:def-test build-group-of-routes-using-the-dsl () (setf wst.routing::*routes* nil) (let* ((count 0) - (must-be-called (lambda (req res) - (declare (ignore req res)) - (setf count (1+ count))))) + (must-be-called (lambda (req res) + (declare (ignore req res)) + (setf count (1+ count))))) (wst.routing.dsl:build-webserver `(wst.routing.dsl:group (wst.routing.dsl:route :GET route-a "/a" ,must-be-called) @@ -153,27 +159,38 @@ (5am:def-test build-a-resource-routes-using-the-dsl () (setf wst.routing::*routes* nil) (let* ((count 0) - (must-be-called (lambda (req res) - (declare (ignore req res)) - (setf count (1+ count))))) + (must-be-called (lambda (req res) + (declare (ignore req res)) + (setf count (1+ count))))) (wst.routing.dsl:build-webserver `(wst.routing.dsl:resource "/base" - (wst.routing.dsl:route :GET route-a "/a" ,must-be-called) - (wst.routing.dsl:route :GET route-b ,must-be-called))) + (wst.routing.dsl:route :GET route-a "/a" ,must-be-called) + (wst.routing.dsl:route :GET route-b ,must-be-called))) (wst.routing:dispatch-route (make-request :uri "/base/a" :method :GET)) (wst.routing:dispatch-route (make-request :uri "/base" :method :GET)) (5am:is (= 2 count)))) +(5am:def-test build-an-any-route-using-the-dsl () + (setf wst.routing::*routes* nil) + (let* ((count 0) + (must-be-called (lambda (req res) + (declare (ignore req res)) + (setf count (1+ count))))) + (wst.routing.dsl:build-webserver + `(wst.routing.dsl:any-route :GET ,must-be-called)) + (wst.routing:dispatch-route (make-request :uri "/mimimimimimimimi" :method :GET)) + (5am:is (= 1 count)))) + (5am:def-test parse-request-cookies () (add-route 'cookies "/" :GET (lambda (request response) - (declare (ignorable response)) - (let ((cookies (getf (wst.routing:request-data request) :cookies))) - (5am:is (= 2 (length (hu:hash-keys cookies)))) - response))) + (declare (ignorable response)) + (let ((cookies (getf (wst.routing:request-data request) :cookies))) + (5am:is (= 2 (length (hu:hash-keys cookies)))) + response))) (dispatch-route (wst.routing:make-request - :uri "/" - :method :GET - :headers (cl-hash-util:hash ("cookie" "first=a; second=b")))) + :uri "/" + :method :GET + :headers (cl-hash-util:hash ("cookie" "first=a; second=b")))) (remove-route 'cookies)) (5am:def-test customize-condition-handler () @@ -181,21 +198,21 @@ (lambda (request response err) (declare (ignorable request)) (5am:is (string-equal (simple-condition-format-control err) - "something went wrong.")) + "something went wrong.")) (setf (wst.routing:response-data response) - '("meh")) + '("meh")) response)) (add-route 'customize-condition-handler - "/" - :GET - (lambda (request response) - (declare (ignorable request response)) - (error "something went wrong."))) + "/" + :GET + (lambda (request response) + (declare (ignorable request response)) + (error "something went wrong."))) (let ((rs (dispatch-route (wst.routing:make-request - :uri "/" - :method :GET)))) + :uri "/" + :method :GET)))) (5am:is (string-equal (car (response-data rs)) - "meh")) + "meh")) (remove-route 'customize-condition-handler) (wst.routing:condition-handler nil))) @@ -204,125 +221,125 @@ (lambda (request response err) (declare (ignorable request response err)))) (add-route 'unhandler-customized-condition-handler - "/" - :GET - (lambda (request response) - (declare (ignorable request response)) - (error "something went wrong."))) + "/" + :GET + (lambda (request response) + (declare (ignorable request response)) + (error "something went wrong."))) (let ((rs (dispatch-route (wst.routing:make-request - :uri "/" - :method :GET)))) + :uri "/" + :method :GET)))) (5am:is (= 500 (wst.routing:response-status rs))) (remove-route 'unhandler-customized-condition-handler) (wst.routing:condition-handler nil))) (5am:def-test any-route-with-method () (wst.routing:any-route-handler :GET (lambda (request response) - (declare (ignorable request)) - (setf (response-content response) "ok") - response)) + (declare (ignorable request)) + (setf (response-content response) "ok") + response)) (let ((a (dispatch-route (wst.routing:make-request :uri "/a" - :method :GET))) - (b (dispatch-route (wst.routing:make-request :uri "/b" - :method :GET)))) + :method :GET))) + (b (dispatch-route (wst.routing:make-request :uri "/b" + :method :GET)))) (5am:is (equal (response-content a) - (response-content b))) + (response-content b))) (setf wst.routing::*any-route-handler* nil))) (5am:def-test dispatch-by-name-any-route () (let ((count 0)) (wst.routing:any-route-handler :GET (lambda (request response) - (declare (ignorable request)) - (setf count (1+ count)) - response)) + (declare (ignorable request)) + (setf count (1+ count)) + response)) (dispatch-route-by-name 'a (wst.routing:make-request :uri "/a" - :method :GET)) + :method :GET)) (dispatch-route-by-name 'b (wst.routing:make-request :uri "/b" - :method :GET)) + :method :GET)) (5am:is (= count 2)) (setf wst.routing::*any-route-handler* nil))) (5am:def-test dont-dispatch-by-name-any-route-with-method-is-different () (let ((count 0)) (wst.routing:any-route-handler :GET (lambda (request response) - (declare (ignorable request)) - (setf count (1+ count)) - response)) + (declare (ignorable request)) + (setf count (1+ count)) + response)) (dispatch-route-by-name 'a (wst.routing:make-request :uri "/a" - :method :POST)) + :method :POST)) (5am:is (= count 0)) (setf wst.routing::*any-route-handler* nil))) (5am:def-test respond-with-internal-server-error () (wst.routing:any-route-handler :GET (lambda (request response) - (declare (ignorable request)) - (wst.routing:internal-server-error-response t response) - response)) + (declare (ignorable request)) + (wst.routing:internal-server-error-response t response) + response)) (5am:is (= 500 (wst.routing:response-status - (dispatch-route-by-name 'a (wst.routing:make-request :uri "/" :method :GET))))) + (dispatch-route-by-name 'a (wst.routing:make-request :uri "/" :method :GET))))) (setf wst.routing::*any-route-handler* nil)) (5am:def-test respond-with-unauthorized () (wst.routing:any-route-handler :GET (lambda (request response) - (declare (ignorable request)) - (wst.routing:unauthorized-response t response) - response)) + (declare (ignorable request)) + (wst.routing:unauthorized-response t response) + response)) (5am:is (= 401 (wst.routing:response-status - (dispatch-route-by-name 'a (wst.routing:make-request :uri "/" :method :GET))))) + (dispatch-route-by-name 'a (wst.routing:make-request :uri "/" :method :GET))))) (setf wst.routing::*any-route-handler* nil)) (5am:def-test respond-with-forbidden () (wst.routing:any-route-handler :GET (lambda (request response) - (declare (ignorable request)) - (wst.routing:forbidden-response t response) - response)) + (declare (ignorable request)) + (wst.routing:forbidden-response t response) + response)) (5am:is (= 403 (wst.routing:response-status - (dispatch-route-by-name 'a (wst.routing:make-request :uri "/" :method :GET))))) + (dispatch-route-by-name 'a (wst.routing:make-request :uri "/" :method :GET))))) (setf wst.routing::*any-route-handler* nil)) (5am:def-test respond-with-bad-request () (wst.routing:any-route-handler :GET (lambda (request response) - (declare (ignorable request)) - (wst.routing:bad-request-response t response) - response)) + (declare (ignorable request)) + (wst.routing:bad-request-response t response) + response)) (5am:is (= 400 (wst.routing:response-status - (dispatch-route-by-name 'a (wst.routing:make-request :uri "/" :method :GET))))) + (dispatch-route-by-name 'a (wst.routing:make-request :uri "/" :method :GET))))) (setf wst.routing::*any-route-handler* nil)) (5am:def-test respond-with-redirect-see-other () (wst.routing:any-route-handler :GET (lambda (request response) - (declare (ignorable request)) - (wst.routing:redirect-see-other-response t response "/redirect") - response)) + (declare (ignorable request)) + (wst.routing:redirect-see-other-response t response "/redirect") + response)) (let ((rs (dispatch-route-by-name 'a (wst.routing:make-request :uri "/" :method :GET)))) (5am:is (= 303 (wst.routing:response-status rs))) (5am:is (string-equal (getf (wst.routing:response-headers rs) :location) - "/redirect")) + "/redirect")) (setf wst.routing::*any-route-handler* nil))) (defmethod wst.routing:ok-response ((ty (eql :sexp)) response &key headers content) (declare (ignorable headers)) (write-response response :status 200 - :content-type "application/s-expression" - :headers headers - :content (format nil "~a" content))) + :content-type "application/s-expression" + :headers headers + :content (format nil "~a" content))) (5am:def-test respond-with-custom-responder () (wst.routing:any-route-handler :GET (lambda (request response) - (declare (ignorable request)) - (ok-response :sexp response :content (list 1 2 3)) - response)) + (declare (ignorable request)) + (ok-response :sexp response :content (list 1 2 3)) + response)) (let ((rs (dispatch-route-by-name 'a (wst.routing:make-request :uri "/" :method :GET)))) (5am:is (= 200 (wst.routing:response-status rs))) (5am:is (string-equal (getf (response-headers rs) :content-type) - "application/s-expression")) + "application/s-expression")) (5am:is (equal (response-content rs) "(1 2 3)")) (setf wst.routing::*any-route-handler* nil))) (5am:def-test parse-request-uri-just-path () (let ((uri "/a/b/c")) (multiple-value-bind (uri query-string hash) - (wst.routing:parse-uri uri) + (wst.routing:parse-uri uri) (5am:is (string-equal uri "/a/b/c")) (5am:is (string-equal query-string "")) (5am:is (string-equal hash ""))))) @@ -330,7 +347,7 @@ (5am:def-test parse-request-uri-with-just-query () (let ((uri "/a/b/c?ok=1")) (multiple-value-bind (uri query-string hash) - (wst.routing:parse-uri uri) + (wst.routing:parse-uri uri) (5am:is (string-equal uri "/a/b/c")) (5am:is (string-equal query-string "ok=1")) (5am:is (string-equal hash ""))))) @@ -338,7 +355,7 @@ (5am:def-test parse-request-uri-with-just-hash () (let ((uri "/a/b/c#anchor")) (multiple-value-bind (uri query-string hash) - (wst.routing:parse-uri uri) + (wst.routing:parse-uri uri) (5am:is (string-equal uri "/a/b/c")) (5am:is (string-equal query-string "")) (5am:is (string-equal hash "anchor"))))) @@ -346,7 +363,7 @@ (5am:def-test parse-request-uri-with-query-and-hash () (let ((uri "/a/b/c?ok=1#anchor")) (multiple-value-bind (uri query-string hash) - (wst.routing:parse-uri uri) + (wst.routing:parse-uri uri) (5am:is (string-equal uri "/a/b/c")) (5am:is (string-equal query-string "ok=1")) (5am:is (string-equal hash "anchor"))))) @@ -354,7 +371,7 @@ (5am:def-test parse-request-root-uri-with-query-and-hash () (let ((uri "/?ok=1#anchor")) (multiple-value-bind (uri query-string hash) - (wst.routing:parse-uri uri) + (wst.routing:parse-uri uri) (5am:is (string-equal uri "/")) (5am:is (string-equal query-string "ok=1")) (5am:is (string-equal hash "anchor"))))) diff --git a/routing/types.lisp b/routing/types.lisp new file mode 100644 index 0000000..4f30016 --- /dev/null +++ b/routing/types.lisp @@ -0,0 +1,60 @@ +(in-package :wst.routing) + +(defstruct request + "Request object." + (uri "" :type string) + (query "" :type string) + (hash "" :type string) + (method :GET :type symbol) + (headers (hash-create nil) :type hash-table) + (content-type nil :type (or string null)) + (content-length 0 :type integer) + content + (data nil :type list)) + +(defstruct response + "Response object." + (status 0 :type integer) + (headers nil :type list) + (content "" :type string) + (data nil :type list)) + +(defvar *routes* nil + "Hash to hold all routes.") + +(defmacro with-request-data (keys request &body body) + (let ((ref (gensym "DATA"))) + `(let* ((,ref (request-data ,request)) + ,@(mapcar (lambda (item) + (list (intern (string-upcase (string item))) + `(getf ,ref ,(intern (string item) :keyword)))) + keys)) + ,@body))) + +(defmacro with-response-data (keys response &body body) + (let ((ref (gensym "DATA"))) + `(let* ((,ref (response-data ,response)) + ,@(mapcar (lambda (item) + (list (intern (string-upcase (string item))) + `(getf ,ref ,(intern (string item) :keyword)))) + keys)) + ,@body))) + +(defmacro with-request-params (keys params &body body) + (let ((ref (gensym "PARAMS"))) + `(let* ((,ref ,params) + ,@(mapcar (lambda (item) + (etypecase item + (symbol (list (intern (string item)) + `(alexandria:assoc-value ,ref + ,(string-downcase (string item)) + :test + #'string-equal))) + (cons (list (intern (string (car item))) + `(let ((value (alexandria:assoc-value ,ref + ,(string-downcase (string (car item))) + :test + #'string-equal))) + (if value (funcall ,(cdr item) value) value)))))) + keys)) + ,@body))) diff --git a/routing/woo.lisp b/routing/woo.lisp index 02a718c..8ce7da8 100644 --- a/routing/woo.lisp +++ b/routing/woo.lisp @@ -1,10 +1,11 @@ (defpackage #:wst.routing.woo (:use #:cl) (:import-from #:wst.routing - #:response-content - #:response-headers - #:response-status - #:make-request) + #:parse-uri + #:response-content + #:response-headers + #:response-status + #:make-request) (:export #:woo-env->request #:response->woo-response)) @@ -12,16 +13,19 @@ (in-package :wst.routing.woo) (defun woo-env->request (env) - (make-request :uri (getf env :request-uri) - :headers (getf env :headers) - :method (getf env :request-method) - :content-type (getf env :content-type) - :content-length (or (getf env :content-length) - 0) - :content (getf env :raw-body) - :data (list :env env))) + (multiple-value-bind (path query hash) + (parse-uri (getf env :request-uri)) + (make-request :uri path + :query query + :hash hash + :headers (getf env :headers) + :method (getf env :request-method) + :content-type (getf env :content-type) + :content-length (or (getf env :content-length) 0) + :content (getf env :raw-body) + :data (list :env env)))) (defun response->woo-response (response) (list (response-status response) - (response-headers response) - (list (response-content response)))) + (response-headers response) + (list (response-content response)))) diff --git a/tests-runner.lisp b/tests-runner.lisp index 17dd0d0..086f410 100644 --- a/tests-runner.lisp +++ b/tests-runner.lisp @@ -10,8 +10,6 @@ (when coverage (sb-cover:report #P"./coverage/"))) -(log:config :off) - (setf *debugger-hook* (lambda (c h) (declare (ignore c h)) diff --git a/wst.routing.asd b/wst.routing.asd index 9214027..5ea2879 100644 --- a/wst.routing.asd +++ b/wst.routing.asd @@ -1,14 +1,15 @@ (asdf:defsystem #:wst.routing :depends-on (#:alexandria - #:str - #:cl-hash-util - #:flexi-streams - #:serapeum - #:com.inuoe.jzon - #:log4cl) + #:str + #:cl-hash-util + #:flexi-streams + #:serapeum + #:com.inuoe.jzon) :pathname "routing" :serial t :components ((:file "package") - (:file "responses") - (:file "routes") - (:file "static"))) + (:file "types") + (:file "responses") + (:file "match") + (:file "routes") + (:file "static")))