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
|
;;; Web I/O: Non-blocking HTTP
;; SPDX-License-Identifier: LGPL-3.0-or-later
;; Copyright (C) 2012, 2018 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;; 02110-1301 USA
;;; Commentary:
;;;
;;; This is the non-blocking HTTP implementation of the (web server)
;;; interface.
;;;
;;; It is a modified version of (web server fibers) from Fibers 1.0.0 that
;;; does not create new threads and does not call 'run-fibers'. Instead it
;;; expects to be running directly in a fiberized program.
;;;
;;; (Modifications by Ludovic Courtès, 2018-01.)
;;;
;;; More commentary: Cuirass code has been removed
;;;
;;;
;;; Code:
(define-module (web server fiberized)
#:use-module ((srfi srfi-1) #:select (fold
alist-delete
alist-cons))
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (web http)
#:use-module (web request)
#:use-module (web response)
#:use-module (web server)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 match)
#:use-module (fibers)
#:use-module (fibers channels))
(define (make-default-socket family addr port)
(let ((sock (socket PF_INET SOCK_STREAM 0)))
(setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
(fcntl sock F_SETFD FD_CLOEXEC)
(bind sock family addr port)
(fcntl sock F_SETFL (logior O_NONBLOCK (fcntl sock F_GETFL)))
sock))
(define-record-type <server>
(make-server request-channel)
server?
(request-channel server-request-channel))
;; -> server
(define* (open-server #:key
(host #f)
(family AF_INET)
(addr (if host
(inet-pton family host)
INADDR_LOOPBACK))
(port 8080)
(socket (make-default-socket family addr port)))
;; We use a large backlog by default. If the server is suddenly hit
;; with a number of connections on a small backlog, clients won't
;; receive confirmation for their SYN, leading them to retry --
;; probably successfully, but with a large latency.
(listen socket 1024)
(fcntl socket F_SETFL (logior O_NONBLOCK (fcntl socket F_GETFL)))
(sigaction SIGPIPE SIG_IGN)
(let ((request-channel (make-channel)))
(spawn-fiber
(lambda ()
(socket-loop socket request-channel)))
(make-server request-channel)))
(define (bad-request msg . args)
(throw 'bad-request msg args))
(define (keep-alive? response)
(let ((v (response-version response)))
(and (or (< (response-code response) 400)
(= (response-code response) 404))
(case (car v)
((1)
(case (cdr v)
((1) (not (memq 'close (response-connection response))))
((0) (memq 'keep-alive (response-connection response)))))
(else #f)))))
;; This procedure and the next one are copied from (guix scripts publish).
(define (strip-headers response)
"Return RESPONSE's headers minus 'Content-Length' and our internal headers."
(fold alist-delete
(response-headers response)
'(content-length x-raw-file x-nar-compression)))
(define (with-content-length response length)
"Return RESPONSE with a 'content-length' header set to LENGTH."
(set-field response (response-headers)
(alist-cons 'content-length length
(strip-headers response))))
(define (client-loop client have-request)
;; Always disable Nagle's algorithm, as we handle buffering
;; ourselves.
(setsockopt client IPPROTO_TCP TCP_NODELAY 1)
(setvbuf client 'block 1024)
(catch #t
(lambda ()
(let ((response-channel (make-channel)))
(let loop ()
(cond
((eof-object? (lookahead-u8 client))
(close-port client))
(else
(call-with-values
(lambda ()
(catch #t
(lambda ()
(let* ((request (read-request client))
(body (read-request-body request)))
(have-request response-channel request body)))
(lambda (key . args)
(display "While reading request:\n"
(current-error-port))
(print-exception (current-error-port) #f key args)
(values (build-response #:version '(1 . 0) #:code 400
#:headers
'((content-length . 0)))
#vu8()))))
(lambda (response body)
(match (assoc-ref (response-headers response) 'x-raw-file)
((? string? file)
(non-blocking
(call-with-input-file file
(lambda (input)
(let* ((size (stat:size (stat input)))
(response (write-response
(with-content-length response size)
client))
(output (response-port response)))
(setsockopt client SOL_SOCKET SO_SNDBUF
(* 128 1024))
(if (file-port? output)
(sendfile output input size)
(dump-port input output))
(close-port output)
(values))))))
(#f (begin
(write-response response client)
(when body
(put-bytevector client body))
(force-output client))
(if (and (keep-alive? response)
(not (eof-object? (peek-char client))))
(loop)
(close-port client)))))))))))
(lambda args
;; Ignore premature client disconnections.
(unless (memv (system-error-errno args)
(list EPIPE ECONNRESET))
(apply throw args)))
(lambda (k . args)
(catch #t
(lambda () (close-port client))
(lambda (k . args)
(display "While closing port:\n" (current-error-port))
(print-exception (current-error-port) #f k args))))))
(define (socket-loop socket request-channel)
(define (have-request response-channel request body)
(put-message request-channel (vector response-channel request body))
(match (get-message response-channel)
(#(response body)
(values response body))))
(let loop ()
(match (accept socket (logior SOCK_NONBLOCK SOCK_CLOEXEC))
((client . sockaddr)
(spawn-fiber (lambda () (client-loop client have-request))
#:parallel? #t)
(loop)))))
;; -> (client request body | #f #f #f)
(define (server-read server)
(match (get-message (server-request-channel server))
(#(response-channel request body)
(let ((client response-channel))
(values client request body)))))
;; -> 0 values
(define (server-write server client response body)
(let ((response-channel client))
(put-message response-channel (vector response body)))
(values))
;; -> unspecified values
(define (close-server server)
;; FIXME: We should terminate the 'socket-loop' fiber somehow.
*unspecified*)
(define-server-impl fiberized
open-server
server-read
server-write
close-server)
|
