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 ((*init* web-server-socket-loop)
47 (*cleanup* web-server-cleanup)
48 (shutdown web-server-shutdown)
49 (new-client web-server-client-loop)
50 (handle-request web-server-handle-request))
55 (family #:init-value AF_INET
56 #:init-keyword #:family
58 (port-num #:init-value 8080
61 (addr #:init-keyword #:addr
63 (socket #:init-value #f
65 (upgrade-paths #:init-value '()
66 #:allocation #:each-subclass)
67 (http-handler #:init-keyword #:http-handler
68 #:getter .http-handler))
70 ;; Define getter externally so it works even if we subclass
71 (define-method (.upgrade-paths (web-server <web-server>))
72 (slot-ref web-server 'upgrade-paths))
74 (define-method (initialize (web-server <web-server>) init-args)
76 ;; Make sure the addr is set up
77 (when (not (slot-bound? web-server 'addr))
78 (set! (.addr web-server)
79 (if (.host web-server)
80 (inet-pton (.family web-server)
85 (set! (.socket web-server)
86 (make-default-socket (.family web-server)
88 (.port-num web-server)))
90 ;; This is borrowed from Guile's web server.
91 ;; Andy Wingo added the line with this commit:
92 ;; * module/web/server/http.scm (http-open): Ignore SIGPIPE. Keeps the
93 ;; server from dying in some circumstances.
94 (sigaction SIGPIPE SIG_IGN))
96 ;; @@: Borrowed from Guile itself / Fibers
98 (define (set-nonblocking! port)
99 (fcntl port F_SETFL (logior O_NONBLOCK (fcntl port F_GETFL)))
100 (setvbuf port 'block 1024))
102 (define (make-default-socket family addr port)
103 (let ((sock (socket PF_INET SOCK_STREAM 0)))
104 (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
105 (fcntl sock F_SETFD FD_CLOEXEC)
106 (bind sock family addr port)
107 (set-nonblocking! sock)
108 ;; We use a large backlog by default. If the server is suddenly hit
109 ;; with a number of connections on a small backlog, clients won't
110 ;; receive confirmation for their SYN, leading them to retry --
111 ;; probably successfully, but with a large latency.
115 (define (web-server-socket-loop web-server message)
116 "The main loop on our socket. Keep accepting new clients as long
119 (match (accept (.socket web-server))
121 ;; From "HOP, A Fast Server for the Diffuse Web", Serrano.
122 (setsockopt client SOL_SOCKET SO_SNDBUF (* 12 1024))
123 (set-nonblocking! client)
124 ;; Always disable Nagle's algorithm, as we handle buffering
125 ;; ourselves. Ignore exceptions if it's not a TCP port, or
126 ;; TCP_NODELAY is not defined on this platform.
128 (setsockopt client IPPROTO_TCP TCP_NODELAY 0))
129 (<- (actor-id web-server) 'new-client client)))))
131 (define (keep-alive? response)
132 (let ((v (response-version response)))
133 (and (or (< (response-code response) 400)
134 (= (response-code response) 404))
138 ((1) (not (memq 'close (response-connection response))))
139 ((0) (memq 'keep-alive (response-connection response)))))
142 (define (maybe-upgrade-request web-server request body)
143 (define upgrade-paths (.upgrade-paths web-server))
144 ;; A request can specify multiple values to the "Upgrade"
145 ;; field, so we slook to see if we have an applicable option,
147 ;; Note that we'll only handle one... we *don't* "compose"
149 (let loop ((upgrades (request-upgrade request)))
150 (if (eq? upgrades '())
151 #f ; Shouldn't upgrade
152 (match (assoc (car upgrades) upgrade-paths)
153 ;; Yes, upgrade with this method
157 (#f (loop (cdr upgrades)))))))
159 (define (web-server-client-loop web-server message client)
160 "Read request(s) from a client and pass off to the handler."
161 (with-throw-handler #t
164 (define (respond-and-maybe-continue _ response body)
165 (write-response response client)
167 (put-bytevector client body))
168 (force-output client)
169 (if (and (keep-alive? response)
170 (not (eof-object? (peek-char client))))
172 (close-port client)))
174 ((eof-object? (lookahead-u8 client))
179 (let* ((request (read-request client))
180 (body (read-request-body request)))
182 ;; Should we "upgrade" the protocol?
183 ;; Doing so "breaks out" of this loop, possibly into a new one
184 ((maybe-upgrade-request web-server request body) =>
186 ;; TODO: this isn't great because we're in this catch,
187 ;; which doesn't make sense once we've "upgraded"
188 ;; since we might not "respond" in the same way anymore.
189 (upgrade web-server client request body)))
192 ;; TODO: Add error handling in case we get an error
194 (<-wait (actor-id web-server) 'handle-request
196 respond-and-maybe-continue)))))
198 (display "While reading request:\n" (current-error-port))
199 (print-exception (current-error-port) #f key args)
200 (respond-and-maybe-continue
201 #f ;; ignored, there is no message
202 (build-response #:version '(1 . 0) #:code 400
203 #:headers '((content-length . 0)))
207 (lambda () (close-port client))
209 (display "While closing port:\n" (current-error-port))
210 (print-exception (current-error-port) #f k args))))))
212 (define (web-server-handle-request web-server message
214 (receive (response body)
215 ((.http-handler web-server) request body)
216 (receive (response body)
217 (sanitize-response request response body)
218 (<-reply message response body))))
220 (define (web-server-cleanup web-server message)
221 ;; @@: Should we close any pending requests too?
222 (close (.socket web-server)))
224 (define (web-server-shutdown web-server message)
225 (self-destruct web-server))