1 ;;; 8sync --- Asynchronous programming for Guile
2 ;;; Copyright © 2017 Christopher Allan Webber <cwebber@dustycloud.org>
3 ;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
5 ;;; Code (also under the LGPL) borrowed from fibers:
6 ;;; Copyright © 2016 Andy Wingo <wingo@pobox.com>
8 ;;; Copyright © 2010, 2011, 2012, 2015 Free Software Foundation, Inc.
10 ;;; This file is part of 8sync.
12 ;;; 8sync is free software: you can redistribute it and/or modify it
13 ;;; under the terms of the GNU Lesser General Public License as
14 ;;; published by the Free Software Foundation, either version 3 of the
15 ;;; License, or (at your option) any later version.
17 ;;; 8sync is distributed in the hope that it will be useful,
18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
20 ;;; GNU Lesser General Public License for more details.
22 ;;; You should have received a copy of the GNU Lesser General Public
23 ;;; License along with 8sync. If not, see <http://www.gnu.org/licenses/>.
26 (define-module (8sync systems web)
27 #:use-module (oop goops)
28 #:use-module (ice-9 match)
29 #:use-module (ice-9 receive)
30 #:use-module (web http)
31 #:use-module (web request)
32 #:use-module (web response)
33 #:use-module (web server)
34 #:use-module (rnrs io ports)
36 #:use-module ((srfi srfi-1) #:select (assoc))
37 #:export (<web-server>
38 ;; @@: If we don't want to import these because of
39 ;; "conflicts" with other objects, we could just
40 ;; select <web-server> only.
41 ;; Alternately we could move the crux of this into
42 ;; another module and just export <web-server>, though
43 ;; that does feel a bit like overkill.
44 .host .family .port-num .addr .socket
45 .upgrade-paths .http-handler))
47 (define-actor <web-server> (<actor>)
48 ((*init* web-server-socket-loop)
49 (*cleanup* web-server-cleanup)
50 (shutdown web-server-shutdown)
51 (new-client web-server-client-loop)
52 (handle-request web-server-handle-request))
57 (family #:init-value AF_INET
58 #:init-keyword #:family
60 (port-num #:init-value 8080
63 (addr #:init-keyword #:addr
65 (socket #:init-value #f
67 (upgrade-paths #:init-value '()
68 #:allocation #:each-subclass)
69 (http-handler #:init-keyword #:http-handler
70 #:getter .http-handler))
72 ;; Define getter externally so it works even if we subclass
73 (define-method (.upgrade-paths (web-server <web-server>))
74 (slot-ref web-server 'upgrade-paths))
76 (define-method (initialize (web-server <web-server>) init-args)
78 ;; Make sure the addr is set up
79 (when (not (slot-bound? web-server 'addr))
80 (set! (.addr web-server)
81 (if (.host web-server)
82 (inet-pton (.family web-server)
87 (set! (.socket web-server)
88 (make-default-socket (.family web-server)
90 (.port-num web-server)))
92 ;; This is borrowed from Guile's web server.
93 ;; Andy Wingo added the line with this commit:
94 ;; * module/web/server/http.scm (http-open): Ignore SIGPIPE. Keeps the
95 ;; server from dying in some circumstances.
96 (sigaction SIGPIPE SIG_IGN))
98 ;; @@: Borrowed from Guile itself / Fibers
100 (define (set-nonblocking! port)
101 (fcntl port F_SETFL (logior O_NONBLOCK (fcntl port F_GETFL)))
102 (setvbuf port 'block 1024))
104 (define (make-default-socket family addr port)
105 (let ((sock (socket PF_INET SOCK_STREAM 0)))
106 (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
107 (fcntl sock F_SETFD FD_CLOEXEC)
108 (bind sock family addr port)
109 (set-nonblocking! sock)
110 ;; We use a large backlog by default. If the server is suddenly hit
111 ;; with a number of connections on a small backlog, clients won't
112 ;; receive confirmation for their SYN, leading them to retry --
113 ;; probably successfully, but with a large latency.
117 (define (web-server-socket-loop web-server message)
118 "The main loop on our socket. Keep accepting new clients as long
121 (match (accept (.socket web-server))
123 ;; From "HOP, A Fast Server for the Diffuse Web", Serrano.
124 (setsockopt client SOL_SOCKET SO_SNDBUF (* 12 1024))
125 (set-nonblocking! client)
126 ;; Always disable Nagle's algorithm, as we handle buffering
127 ;; ourselves. Ignore exceptions if it's not a TCP port, or
128 ;; TCP_NODELAY is not defined on this platform.
130 (setsockopt client IPPROTO_TCP TCP_NODELAY 0))
131 (<- (actor-id web-server) 'new-client client)))))
133 (define (keep-alive? response)
134 (let ((v (response-version response)))
135 (and (or (< (response-code response) 400)
136 (= (response-code response) 404))
140 ((1) (not (memq 'close (response-connection response))))
141 ((0) (memq 'keep-alive (response-connection response)))))
144 (define (maybe-upgrade-request web-server request body)
145 (define upgrade-paths (.upgrade-paths web-server))
146 ;; A request can specify multiple values to the "Upgrade"
147 ;; field, so we slook to see if we have an applicable option,
149 ;; Note that we'll only handle one... we *don't* "compose"
151 (let loop ((upgrades (request-upgrade request)))
152 (if (eq? upgrades '())
153 #f ; Shouldn't upgrade
154 (match (assoc (car upgrades) upgrade-paths string-ci=?)
155 ;; Yes, upgrade with this method
159 (#f (loop (cdr upgrades)))))))
161 (define (web-server-client-loop web-server message client)
162 "Read request(s) from a client and pass off to the handler."
163 (with-throw-handler #t
166 (define (respond-and-maybe-continue _ response body)
167 (write-response response client)
169 (put-bytevector client body))
170 (force-output client)
171 (if (and (keep-alive? response)
172 (not (eof-object? (peek-char client))))
174 (close-port client)))
176 ((eof-object? (lookahead-u8 client))
181 (let* ((request (read-request client))
182 (body (read-request-body request)))
184 ;; Should we "upgrade" the protocol?
185 ;; Doing so "breaks out" of this loop, possibly into a new one
186 ((maybe-upgrade-request web-server request body) =>
188 ;; TODO: this isn't great because we're in this catch,
189 ;; which doesn't make sense once we've "upgraded"
190 ;; since we might not "respond" in the same way anymore.
191 (upgrade web-server client request body)))
194 ;; TODO: Add error handling in case we get an error
196 (<-wait (actor-id web-server) 'handle-request
198 respond-and-maybe-continue)))))
200 (display "While reading request:\n" (current-error-port))
201 (print-exception (current-error-port) #f key args)
202 (respond-and-maybe-continue
203 #f ;; ignored, there is no message
204 (build-response #:version '(1 . 0) #:code 400
205 #:headers '((content-length . 0)))
209 (lambda () (close-port client))
211 (display "While closing port:\n" (current-error-port))
212 (print-exception (current-error-port) #f k args))))))
214 (define (web-server-handle-request web-server message
216 (receive (response body)
217 ((.http-handler web-server) request body)
218 (receive (response body)
219 (sanitize-response request response body)
220 (<-reply message response body))))
222 (define (web-server-cleanup web-server message)
223 ;; @@: Should we close any pending requests too?
224 (close (.socket web-server)))
226 (define (web-server-shutdown web-server message)
227 (self-destruct web-server))