aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/routes.lisp174
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)))