diff options
| -rw-r--r-- | src/routes.lisp | 174 |
1 files changed, 98 insertions, 76 deletions
diff --git a/src/routes.lisp b/src/routes.lisp index 0de0307..6a9ec14 100644 --- a/src/routes.lisp +++ b/src/routes.lisp @@ -22,26 +22,29 @@ ((name :accessor route-name :initarg :name :type symbol - :documentation "") + :documentation "Function name of this route's hanlder") (method :accessor route-method :initarg :method :type route-method - :documentation "") + :documentation "HTTP method or methods handled by this route") (path :accessor route-path :initarg :path :type list - :documentation "") + :documentation "Path given as a list of strings. Symbols represent +wildcards.") (query :accessor route-query :initarg :query :type list - :documentation "") + :documentation "List of variables to map from the query") (fragmentp :accessor route-fragment-p - :initarg :fragmentp - :type boolean - :documentation "If route uses the fragment"))) + :initarg :fragmentp + :type boolean + :documentation "If route uses the fragment"))) -(define-condition match-error () - ()) +(define-condition match-error (error) + ((headers :reader match-error-headers + :initarg :headers + :documentation ""))) (defun translate (table string) "Replace charactes in STRING using replacement alist TABLE" @@ -54,7 +57,7 @@ (defparameter *routes-table* '() - "") + "Table of all routes") (defun split-declarations (body) "Extract declarations and docstring from BODY" @@ -110,16 +113,21 @@ headers content-type) &body body) - "Define function NAME with BODY, which takes HEADERS and URI-BINDINGS and handles -a SCGI request. Also add entry to *ROUTES-TABLE* with the URI path of the route -and the METHOD it handles. METHOD may be a keyword or a list of keywords if the -route handles different methods." - ;; QUERY may be a SYMBOL or a LIST of the form (BINDINGS) where each BINDINGS is either (VARIABLE &optional DEFAULT &key TEXT-FORM SETP) or VARIABLE - ;; FRAGMENT is either as SYMBOL or (SYMBOL &optional DEFAULT SETP) - ;; 2 routes are different only if they have either different paths or methods - ;; using same path and method but different query or fragment results in the route being overwritten + "Define function NAME with BODY to handle SCGI requests. The function is added to +*ROUTES-TABLE* and called if a SCGI request uses METHOD and matches PATH. METHOD + is either a keyword or a list of keywords from +HTTP-METHODS+. PATH is a list + of strings specifying the path part of an uri. A symbol inside PATH denotes a + wildcard. QUERY is a list either symbols or lists (VARIABLE &optional DEFAULT + &key TEXT-FORM SETP) specifying the bindings in the query part of the uri. + FRAGMENT is either a SYMBOL or (SYMBOL &optional DEFAULT SETP) and is bound to + the fragment of the uri. HEADERS is bound to the alist of request headers. If + CONTENT-TYPE is non-NIL, then the handler automatically generates a + content-type line in the HTTP response, otherwise the function has to do this + manually." (check-type method http-method "a valid http method") - (check-type content-type string) + (check-type path list "a list") + (when content-type + (check-type content-type string)) (let ((path-alist (gensym)) (query-alist (gensym)) (fragment-value (gensym)) @@ -207,6 +215,18 @@ header." ("GET" :get) ("POST" :post))) +(defun ensure-uri (uri) + "If URI is an instance QURI:URI, it is returned. Otherwise parse URI into a valid +QURI:URI object." + (etypecase uri + (string (quri:uri uri)) + (quri:uri uri))) + +(defun route-path-from-uri (uri) + "Split the path of an URI for route pattern matching." + (let ((path (quri:uri-path uri))) + (split-sequence #\/ path :remove-empty-subseqs t))) + (defun parse-headers (string &aux headers) "Split SCGI header inside STRING into key value alist." (doplist (sname value (split-sequence #\Nul string) headers) @@ -225,37 +245,23 @@ header." (read-char stream) ; Read trailing #\Nul (parse-headers buffer))) -(defun uri-route (uri) - "Split the path of an URI for route pattern matching." - (let ((path (quri:uri-path uri))) - (split-sequence #\/ path :remove-empty-subseqs t))) - -(defun serve-request (stream error-handler) +(defun serve-request (stream) "Read SCGI header from STREAM and look for and call function handling matching -route. If no route matches, then ERROR-HANDLER is called." - (handler-case - (let ((*standard-output* stream) - (headers (read-headers stream))) - (let* ((method (assoc-value headers :request-uri)) - (uri (assoc-value headers :request-uri)) - (query-bindings (quri:uri-query-params uri)) - (route (uri-route uri)) - (fragment (quri:uri-fragment uri))) - (multiple-value-bind (entry path-bindings) - (find-route route method *routes-table*) - (if entry - (funcall (route-name entry) headers path-bindings query-bindings - fragment) - (funcall error-handler headers))))) - (t (e) - (format *error-output* "ROUTES: Error: ~A~%" e)))) - -(defun ensure-uri (uri) - "If URI is an instance QURI:URI, it is returned. Otherwise parse URI into a valid -QURI:URI object." - (etypecase uri - (string (quri:uri uri)) - (quri:uri uri))) +route." + (let* ((headers (read-headers stream)) + (uri (assoc-value headers :request-uri))) + (multiple-value-bind (entry path-bindings) + (find-route (route-path-from-uri uri) + (assoc-value headers :request-method) + *routes-table*) + (unless entry + (error 'match-error :headers headers)) + (let ((*standard-output* stream)) + (funcall (route-name entry) + headers + path-bindings + (quri:uri-query-params uri) + (quri:uri-fragment uri)))))) (defun test-route (method uri &optional expected-route) "Find route handler for METHOD request URI, compare if route resolves to @@ -263,38 +269,54 @@ EXPECTED-ROUTE and test the route handler without running a server. Used for writing possibly offline tests for route handlers" (check-type method http-method) (setf uri (ensure-uri uri)) - (let ((route (uri-route uri)) + (let ((path (route-path-from-uri uri)) (headers `((:request-uri . ,uri) (:request-method . ,method)))) (multiple-value-bind (entry path-bindings) - (find-route route method *routes-table*) - (with-accessors ((name route-name)) - entry - (cond ((and expected-route (not (eq expected-route name))) - (error "Unexpected match ~A" name)) - (name - (funcall name headers - path-bindings - (quri:uri-query-params uri) - (quri:uri-fragment uri))) - (t - (error "No match"))))))) + (find-route path method *routes-table*) + (when (and expected-route (not (eq expected-route name))) + (error "Unexpected match ~A" name)) + (unless entry + (error 'match-error :headers headers)) + (funcall (route-name entry) + headers + path-bindings + (quri:uri-query-params uri) + (quri:uri-fragment uri))))) -(defun default-error-handler (headers) +(defun default-error-handler (stream condition) + (declare (ignorable condition)) + (let ((*standard-output* stream)) + (write-string (http-response-header "text/html")) + (write-string "<!DOCTYPE html> +<html> + <head><title>404 Not Found</title></head> + <body><h1>404 Not Found</h1></body> +</html>"))) + +(defun default-internal-error-handler (stream condition) (declare (ignorable headers)) - (write-string (http-response-header "text/html")) - (write-string "<!DOCTYPE html> + (let ((*standard-output* stream)) + (write-string (http-response-header "text/html")) + (write-string "<!DOCTYPE html> <html> - <head> - <title>404 Not Found</title> - </head> + <head><title>500 Internal Server Error</title></head> + <body><h1>500 Internal Server Error</h1></body> +</html>"))) - <body> - <h1>404 Not Found</h1> - </body> -</html>")) +(defun socket-function (stream match-error-handler internal-error-handler) + (handler-case + (serve-request stream) + (match-error (c) + (funcall match-error-handler stream c)) + (t (c) + (funcall internal-error-handler stream c) + (format *error-output* "~&ROUTES: Unhandled error:~%~A~%" c)))) -(defun server (address port &optional (error-handler 'default-error-handler)) - (usocket:socket-server address port - (lambda (stream) - (funcall 'serve-request stream error-handler)))) +(defun server (address port + &optional + (match-error-handler 'default-error-handler) + (internal-error-handler 'default-internal-error-handler)) + (usocket:socket-server address port (rcurry #'socket-function + match-error-handler + internal-error-handler))) |