1 ;;; 8sync --- Asynchronous programming for Guile
2 ;;; Copyright © 2017 Christopher Allan Webber <cwebber@dustycloud.org>
4 ;;; Code (also under the LGPL) borrowed from fibers:
5 ;;; Copyright © 2016 Andy Wingo <wingo@pobox.com>
7 ;;; Copyright © 2010, 2011, 2012, 2015 Free Software Foundation, Inc.
9 ;;; This file is part of 8sync.
11 ;;; 8sync is free software: you can redistribute it and/or modify it
12 ;;; under the terms of the GNU Lesser General Public License as
13 ;;; published by the Free Software Foundation, either version 3 of the
14 ;;; License, or (at your option) any later version.
16 ;;; 8sync is distributed in the hope that it will be useful,
17 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;;; GNU Lesser General Public License for more details.
21 ;;; You should have received a copy of the GNU Lesser General Public
22 ;;; License along with 8sync. If not, see <http://www.gnu.org/licenses/>.
25 (define-module (8sync systems web)
26 #:use-module (oop goops)
27 #:use-module (ice-9 match)
28 #:use-module (ice-9 receive)
29 #:use-module (web http)
30 #:use-module (web request)
31 #:use-module (web response)
32 #:use-module (web server)
33 #:use-module (rnrs io ports)
35 #:export (<web-server>
36 ;; @@: If we don't want to import these because of
37 ;; "conflicts" with other objects, we could just
38 ;; select <web-server> only.
39 ;; Alternately we could move the crux of this into
40 ;; another module and just export <web-server>, though
41 ;; that does feel a bit like overkill.
42 .host .family .port-num .addr .socket
43 .upgrade-paths .http-handler))
45 (define-actor <web-server> (<actor>)
46 ((main-loop web-server-socket-loop)
47 (shutdown web-server-shutdown)
48 (new-client web-server-client-loop)
49 (handle-request web-server-handle-request))
54 (family #:init-value AF_INET
55 #:init-keyword #:family
57 (port-num #:init-value 8080
60 (addr #:init-keyword #:addr
62 (socket #:init-value #f
64 (upgrade-paths #:init-value '()
65 #:allocation #:each-subclass)
66 (http-handler #:init-keyword #:http-handler
67 #:getter .http-handler))
69 ;; Define getter externally so it works even if we subclass
70 (define-method (.upgrade-paths (web-server <web-server>))
71 (slot-ref web-server 'upgrade-paths))
73 (define-method (initialize (web-server <web-server>) init-args)
75 ;; Make sure the addr is set up
76 (when (not (slot-bound? web-server 'addr))
77 (set! (.addr web-server)
78 (if (.host web-server)
79 (inet-pton (.family web-server)
84 (set! (.socket web-server)
85 (make-default-socket (.family web-server)
87 (.port-num web-server)))
89 ;; This is borrowed from Guile's web server.
90 ;; Andy Wingo added the line with this commit:
91 ;; * module/web/server/http.scm (http-open): Ignore SIGPIPE. Keeps the
92 ;; server from dying in some circumstances.
93 (sigaction SIGPIPE SIG_IGN))
95 ;; @@: Borrowed from Guile itself / Fibers
97 (define (set-nonblocking! port)
98 (fcntl port F_SETFL (logior O_NONBLOCK (fcntl port F_GETFL)))
99 (setvbuf port 'block 1024))
101 (define (make-default-socket family addr port)
102 (let ((sock (socket PF_INET SOCK_STREAM 0)))
103 (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
104 (fcntl sock F_SETFD FD_CLOEXEC)
105 (bind sock family addr port)
106 (set-nonblocking! sock)
107 ;; We use a large backlog by default. If the server is suddenly hit
108 ;; with a number of connections on a small backlog, clients won't
109 ;; receive confirmation for their SYN, leading them to retry --
110 ;; probably successfully, but with a large latency.
114 (define-method (actor-init! (web-server <web-server>))
115 (<- (actor-id web-server) 'main-loop))
117 (define-method (actor-cleanup! (web-server <web-server>))
118 ;; @@: Should we close any pending requests too?
119 (close (.socket web-server)))
121 (define (web-server-socket-loop web-server message)
122 "The main loop on our socket. Keep accepting new clients as long
124 (with-actor-nonblocking-ports
127 (match (accept (.socket web-server))
129 (pk 'a-client client sockaddr)
130 ;; From "HOP, A Fast Server for the Diffuse Web", Serrano.
131 (setsockopt client SOL_SOCKET SO_SNDBUF (* 12 1024))
132 (set-nonblocking! client)
133 ;; Always disable Nagle's algorithm, as we handle buffering
134 ;; ourselves. Ignore exceptions if it's not a TCP port, or
135 ;; TCP_NODELAY is not defined on this platform.
137 (setsockopt client IPPROTO_TCP TCP_NODELAY 0))
138 (<- (actor-id web-server) 'new-client client)))))))
140 (define (keep-alive? response)
141 (let ((v (response-version response)))
142 (and (or (< (response-code response) 400)
143 (= (response-code response) 404))
147 ((1) (not (memq 'close (response-connection response))))
148 ((0) (memq 'keep-alive (response-connection response)))))
151 (define (maybe-upgrade-request web-server request body)
152 (define upgrade-paths (.upgrade-paths web-server))
153 ;; A request can specify multiple values to the "Upgrade"
154 ;; field, so we slook to see if we have an applicable option,
156 ;; Note that we'll only handle one... we *don't* "compose"
158 (let loop ((upgrades (request-upgrade request)))
159 (if (eq? upgrades '())
160 #f ; Shouldn't upgrade
161 (match (assoc (car upgrades) upgrade-paths)
162 ;; Yes, upgrade with this method
166 (#f (loop (cdr upgrades)))))))
168 (define (web-server-client-loop web-server message client)
169 "Read request(s) from a client and pass off to the handler."
170 (with-actor-nonblocking-ports
172 (with-throw-handler #t
175 (define (respond-and-maybe-continue response body)
176 (write-response response client)
178 (put-bytevector client body))
179 (force-output client)
180 (if (and (keep-alive? response)
181 (not (eof-object? (peek-char client))))
183 (close-port client)))
185 ((eof-object? (lookahead-u8 client))
190 (let* ((request (read-request client))
191 (body (read-request-body request)))
193 ;; Should we "upgrade" the protocol?
194 ;; Doing so "breaks out" of this loop, possibly into a new one
195 ((maybe-upgrade-request web-server request body) =>
197 ;; TODO: this isn't great because we're in this catch,
198 ;; which doesn't make sense once we've "upgraded"
199 ;; since we might not "respond" in the same way anymore.
200 (upgrade web-server client request body)))
204 ;; TODO: Add error handling in case we get an error
206 (<-wait (actor-id web-server) 'handle-request
208 respond-and-maybe-continue)))))
210 (display "While reading request:\n" (current-error-port))
211 (print-exception (current-error-port) #f key args)
212 (respond-and-maybe-continue
213 (build-response #:version '(1 . 0) #:code 400
214 #:headers '((content-length . 0)))
218 (lambda () (close-port client))
220 (display "While closing port:\n" (current-error-port))
221 (print-exception (current-error-port) #f k args))))))))
223 (define (web-server-handle-request web-server message
225 (receive (response body)
226 ((.http-handler web-server) request body)
227 (receive (response body)
228 (sanitize-response request response body)
229 (values response body))))
231 (define (web-server-shutdown web-server message)
232 (self-destruct web-server))