1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
|
(in-package #:routes)
(defun translate (table string)
"Replace charactes in STRING using replacement alist TABLE"
(flet ((translator (x) (or (assoc-value table x) x)))
(map 'string #'translator string)))
(defun http-response-header (content-type)
(format nil "HTTP/1.0 200 OK~C~CContent-Type: ~A~3:*~C~C~2:*~C~C"
#\Return #\Newline content-type))
(defparameter *routes-table*
'()
"")
(defun split-declarations (body)
"Extract declarations and docstring from BODY"
(flet ((declarationp (clause)
(and (listp clause) (eq (first clause) 'declare))))
(loop :with docstring = nil
:for body :on body
:for clause = (first body)
:while (or (declarationp clause)
(and (not docstring) (stringp clause)))
:collect clause :into declarations
:when (stringp clause) :do
(setf docstring t)
:finally
(return (values declarations body)))))
(defmacro define-route (name (headers &key route method 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."
(let ((route-bindings (gensym)))
(flet ((binding (name) `(,name (assoc-value ,route-bindings ',name))))
(multiple-value-bind (declarations body)
(split-declarations body)
`(progn
(let ((entry (assoc ',name *routes-table*)))
(if entry
(setf (second entry) ',(ensure-list method)
(third entry) ',route)
(push '(,name ,(ensure-list method) ,route) *routes-table*)))
(defun ,name (,headers ,route-bindings)
,@declarations
(declare (ignorable ,route-bindings))
(write-string (http-response-header ,content-type))
(let (,@(mapcar #'binding (remove-if-not #'symbolp route)))
,@body)))))))
(defun match-route (pattern route)
"Match PATTERN to ROUTE, returns alist with bindings or T if no free variables
are present. If no match is possible, NIL is returned instead"
(do ((pattern pattern (rest pattern))
(route route (rest route))
(bindings '()))
((and (null pattern) (null route))
(or bindings t))
(cond ((or (null pattern) (null route))
(return nil))
((symbolp (first pattern))
(push (cons (first pattern) (first route)) bindings))
((not (equalp (first pattern) (first route)))
(return nil)))))
(defun find-route (uri method routes-table)
"Find matching route for request inside of ROUTES-TABLE. If multiple routes are
compatible with the requests URI and METHOD, then the match with the least
amount of bindings, i.e. the most specific match, is returned."
(flet ((bind-route (route)
(destructuring-bind (route-name route-method route-uri) route
(declare (ignorable route-name))
(let ((match (and (find method route-method)
(match-route route-uri uri))))
(if match
(list route (if (eq match t) '() match))
nil))))
(match-length (match) (length (first match))))
(let ((routes (remove nil (mapcar #'bind-route routes-table))))
(if routes
(values-list (first (sort routes #'< :key #'match-length)))
nil))))
(defun read-request-length (stream)
"Get the first characters in STREAM representing the length of the request's
header."
(let ((chars (loop :for c = (read-char stream) :while (char/= c #\:)
:collect c)))
(parse-integer (coerce chars 'string))))
(defun parse-headers (string &aux headers)
"Split SCGI header inside STRING into key value alist."
(doplist (sname value (split-sequence #\Nul string) headers)
(let ((name (make-keyword (translate '((#\_ . #\-)) sname))))
(push (cons name value) headers))))
(defun request-method (headers)
(switch ((assoc-value headers :request-method) :test #'equal)
("GET" :get)
("POST" :post)))
(defun request-uri (headers)
(quri:uri (assoc-value headers :request-uri)))
(defun request-route (headers)
(let ((uri (request-uri headers)))
(split-sequence #\/ (quri:uri-path uri) :remove-empty-subseqs t)))
(defun serve-request (stream error-handler)
"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)
(length (read-request-length stream)))
(let ((buffer (make-string (1- length))))
(read-sequence buffer stream)
;; Read trailing #\Nul
(read-char stream)
(let ((headers (parse-headers buffer)))
(let ((route (request-route headers))
(method (request-method headers)))
(multiple-value-bind (entry bindings)
(find-route route method *routes-table*)
(if entry
(funcall (first entry) headers bindings)
(funcall error-handler headers)))))))
(t (e)
(format *error-output* "Error: ~A~%" e))))
(defun default-error-handler (headers)
(declare (ignorable headers))
(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 server (address port &optional (error-handler #'default-error-handler))
(usocket:socket-server address port
#'(lambda (stream)
(funcall 'serve-request stream error-handler))))
|
