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 (when (defined? 'SIGPIPE)
97 (sigaction SIGPIPE SIG_IGN)))
99 ;; @@: Borrowed from Guile itself / Fibers
101 (define (set-nonblocking! port)
102 (fcntl port F_SETFL (logior O_NONBLOCK (fcntl port F_GETFL)))
103 (setvbuf port 'block 1024))
105 (define (make-default-socket family addr port)
106 (let ((sock (socket PF_INET SOCK_STREAM 0)))
107 (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
108 (fcntl sock F_SETFD FD_CLOEXEC)
109 (bind sock family addr port)
110 (set-nonblocking! sock)
111 ;; We use a large backlog by default. If the server is suddenly hit
112 ;; with a number of connections on a small backlog, clients won't
113 ;; receive confirmation for their SYN, leading them to retry --
114 ;; probably successfully, but with a large latency.
118 (define (web-server-socket-loop web-server message)
119 "The main loop on our socket. Keep accepting new clients as long
122 (match (accept (.socket web-server))
124 ;; From "HOP, A Fast Server for the Diffuse Web", Serrano.
125 (setsockopt client SOL_SOCKET SO_SNDBUF (* 12 1024))
126 (set-nonblocking! client)
127 ;; Always disable Nagle's algorithm, as we handle buffering
128 ;; ourselves. Ignore exceptions if it's not a TCP port, or
129 ;; TCP_NODELAY is not defined on this platform.
131 (setsockopt client IPPROTO_TCP TCP_NODELAY 0))
132 (<- (actor-id web-server) 'new-client client)))))
134 (define (keep-alive? response)
135 (let ((v (response-version response)))
136 (and (or (< (response-code response) 400)
137 (= (response-code response) 404))
141 ((1) (not (memq 'close (response-connection response))))
142 ((0) (memq 'keep-alive (response-connection response)))))
145 (define (maybe-upgrade-request web-server request body)
146 (define upgrade-paths (.upgrade-paths web-server))
147 ;; A request can specify multiple values to the "Upgrade"
148 ;; field, so we slook to see if we have an applicable option,
150 ;; Note that we'll only handle one... we *don't* "compose"
152 (let loop ((upgrades (request-upgrade request)))
153 (if (eq? upgrades '())
154 #f ; Shouldn't upgrade
155 (match (assoc (car upgrades) upgrade-paths string-ci=?)
156 ;; Yes, upgrade with this method
160 (#f (loop (cdr upgrades)))))))
162 (define (web-server-client-loop web-server message client)
163 "Read request(s) from a client and pass off to the handler."
164 (with-throw-handler #t
167 (define (respond-and-maybe-continue _ response body)
168 (write-response response client)
170 (put-bytevector client body))
171 (force-output client)
172 (if (and (keep-alive? response)
173 (not (eof-object? (peek-char client))))
175 (close-port client)))
177 ((eof-object? (lookahead-u8 client))
182 (let* ((request (read-request client))
183 (body (read-request-body request)))
185 ;; Should we "upgrade" the protocol?
186 ;; Doing so "breaks out" of this loop, possibly into a new one
187 ((maybe-upgrade-request web-server request body) =>
189 ;; TODO: this isn't great because we're in this catch,
190 ;; which doesn't make sense once we've "upgraded"
191 ;; since we might not "respond" in the same way anymore.
192 (upgrade web-server client request body)))
195 ;; TODO: Add error handling in case we get an error
197 (<-wait (actor-id web-server) 'handle-request
199 respond-and-maybe-continue)))))
201 (display "While reading request:\n" (current-error-port))
202 (print-exception (current-error-port) #f key args)
203 (respond-and-maybe-continue
204 #f ;; ignored, there is no message
205 (build-response #:version '(1 . 0) #:code 400
206 #:headers '((content-length . 0)))
210 (lambda () (close-port client))
212 (display "While closing port:\n" (current-error-port))
213 (print-exception (current-error-port) #f k args))))))
215 (define (web-server-handle-request web-server message
217 (receive (response body)
218 ((.http-handler web-server) request body)
219 (receive (response body)
220 (sanitize-response request response body)
221 (<-reply message response body))))
223 (define (web-server-cleanup web-server message)
224 ;; @@: Should we close any pending requests too?
225 (close (.socket web-server)))
227 (define (web-server-shutdown web-server message)
228 (self-destruct web-server))