-
Notifications
You must be signed in to change notification settings - Fork 2
/
server.scm
279 lines (242 loc) · 8.33 KB
/
server.scm
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
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
(load "httpio.scm")
(load "http-client.scm")
(load "middleware.scm")
(load "utils.scm")
(load "json-update.scm")
#|
Initializes our web server.
|#
(define (create-server)
;;; Local variables
(define error-handlers '())
(define handlers '())
;;; Dispatchable procedures
(define (add-handler handler #!optional path method)
(let ((entry (create-entry handler path method)))
(set! handlers
(append-element handlers entry))))
(define (add-error-handler handler #!optional path method)
(let ((entry (create-entry handler path method)))
(set! error-handlers
(append-element error-handlers entry))))
(define (listen tcp-port)
(let ((socket (open-tcp-server-socket
tcp-port
(host-address-loopback))))
(printf "Listening to port: ~A" tcp-port)
(dynamic-wind
(lambda () unspecific)
(lambda ()
(do () ((channel-closed? socket))
(let ((port (tcp-server-connection-accept socket #t #f)))
(dynamic-wind
(lambda () unspecific)
(lambda () (serve-request port))
(lambda () (close-port port))))))
(lambda () (channel-close socket)))))
;;; Private helper procedures
(define (serve-request port)
(let ((request (read-http-request port)))
(define (catch-error err)
(log "-> error in request ~A: ~A" request err)
(handle-request
(append-element error-handlers
(create-entry 500-handler))
request port err))
(define (try-request)
(handle-request
(append-element handlers (create-entry 404-handler))
request port))
(if INTERNAL-DEBUG-ERRORS
;; for debugging we don't want the error to be handled:
(try-request)
(call-with-current-continuation
(lambda (cont)
(bind-condition-handler
(list condition-type:error)
;; if the request processing errored, run it again,
;; but this time with the error handlers:
(lambda (err)
(catch-error err)
(cont '()))
;; try processing it normally first though:
try-request))))))
(define (create-entry handler #!optional path method)
(make-middleware method path handler))
(define (404-handler req params)
'(404 () "Page Not Found"))
(define (500-handler req params err)
`(500 () ,(string-append
"Something went wrong: "
;; TODO: should probably not leak this in production:
(condition/report-string err))))
(define (create-response result)
(receive
(status headers body)
(apply values result)
(make-http-response HTTP/1.1 status
(http-status-description status)
headers body)))
;;; Checks if the two given parts match, and returns a list of the
;;; matched parameter if it does (#f otherwise).
(define (match-path-part request-part handler-part)
(cond
((equal? request-part handler-part) '())
((eq? handler-part 'number-arg)
(let ((number (string->number request-part)))
(if (number? number)
(list number)
#f)))
((eq? handler-part 'string-arg) (list request-part))
(else #f)))
;;; Attempts to match the request URL with the handler path.
;;; returns a list of matched parameters or #f if there's no match.
(define (match-path request-url full-handler-path)
(let loop ((request-path (cdr (uri-path request-url)))
(handler-path full-handler-path)
(params '()))
(cond
;; /hi should be matched by /hi/there:
((null? handler-path) params)
((null? request-path) #f)
(else
(let ((matched (match-path-part
(car request-path)
(car handler-path))))
(and matched
(loop
(cdr request-path)
(cdr handler-path)
(append params matched))))))))
;;; Check if the given middleware matches the request,
;;; if it does it returns a list of matched params, otherwise #f.
(define (match-middleware request middleware)
(let ((method (get-method middleware))
(url (get-path middleware))
(handler (get-handler middleware))
(request-url (http-request-uri request))
(request-method (http-request-method request)))
(let ((matched-method
(or (default-object? method)
(equal? method request-method)))
(matched-path
(if (default-object? url)
'()
(match-path request-url url))))
(and matched-method matched-path))))
;;; Wraps the results from simple response handlers (i.e. ones that
;;; return strings) in a (200 '() body) list
(define (wrap-result result)
(if (string? result)
`(200 () ,result)
result))
(define (evaluate-handler handler request params #!optional err)
(wrap-result
(if (default-object? err)
(handler request params)
(handler request params err))))
(define (write-response result port)
(let ((response (create-response result)))
(log "-> writing response: ~A" response)
(write-http-response response port)))
(define (handle-request handler-list request port #!optional err)
(let loop ((rest handler-list) (should-respond #t))
(if (null? rest)
'done
(let ((params (match-middleware request (car rest))))
(if (list? params)
(let* ((middleware (car rest))
(handler (get-handler middleware)))
(log "-> evaluating handler: ~A" handler)
(let ((result (evaluate-handler handler request
params err)))
;; only write a response if we haven't
;; done so before:
(if (and should-respond (list? result))
(begin
(write-response result port)
(loop (cdr rest) #f))
;; go through the rest of the middleware, even if we've
;; sent out a response:
(loop (cdr rest) should-respond))))
;; this handler didn't match, so try the next one:
(loop (cdr rest) should-respond))))))
;;; Dispatch on public procedures:
(define (dispatch op)
(case op
((listen) listen)
((add-handler) add-handler)
((add-error-handler) add-error-handler)
(else (error "Unknown method: " op))))
dispatch)
(define HTTP/1.1 (cons 1 1))
(define INTERNAL-DEBUG-ERRORS #f)
(define ENABLE-LOGGING #t)
;;; Public API
(define (listen server port)
((server 'listen) port))
(define (add-handler server handler #!optional path method)
((server 'add-handler) handler path method))
(define (add-error-handler server handler #!optional path method)
((server 'add-error-handler) handler path method))
(define (post server handler #!optional path)
(add-handler server handler path "POST"))
(define (get server handler #!optional path)
(add-handler server handler path "GET"))
(define (put server handler #!optional path)
(add-handler server handler path "PUT"))
(define (delete server handler #!optional path)
(add-handler server handler path "DELETE"))
(define (serve-file path)
(let ((content (read-file path)))
`(200 () ,content)))
;;; create a redirect response, only supports
;;; absolute paths at the moment.
(define (redirect path #!optional status)
(let ((redirect-status (if (default-object? status) 302 status))
(location (make-http-header 'location path)))
(list
redirect-status
(list location)
(string-append "Redirecting to: " path))))
;;; creates a middleware that serves static files
;;; at the folder at `path`
(define (serve-static path)
(lambda (req params)
(let* ((static-path (uri-path (string->uri path)))
(full-request-path (uri-path (http-request-uri req)))
;; if we get a request for /static/file.txt and path is
;; /static, we only care about file.txt - so find that:
(request-path (sublist
full-request-path
(+ (length static-path) 1)
(length full-request-path))))
(let* ((filename (path->file request-path))
(file-path (string-append path filename))
(content
(call-with-current-continuation
(lambda (cont)
(bind-condition-handler
(list condition-type:file-error)
;; we don't want to blow up the server
;; for not found files etc., so pass it on to the
;; next middleware.
(lambda (err)
(log "-> error serving file ~A: ~A" file-path err)
(cont '()))
(lambda ()
(read-file file-path)))))))
(if (string? content)
`(200 () ,content))))))
;;; Helper procedures
(define (log str . elements)
;; TODO: config option instead, see #9
(if ENABLE-LOGGING
(apply printf str elements)))
(define (path->file path)
(string-append "/" (string-join path "/")))
;;; reads the string content at the given file path:
(define (read-file filename)
(call-with-input-file filename
(lambda (port)
(read-string (char-set) port))))