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>))
37 (define-actor <web-server> (<actor>)
38 ((*init* web-server-socket-loop)
39 (*cleanup* web-server-cleanup)
40 (shutdown web-server-shutdown)
41 (new-client web-server-client-loop)
42 (handle-request web-server-handle-request))
47 (family #:init-value AF_INET
48 #:init-keyword #:family
50 (port-num #:init-value 8080
53 (addr #:init-keyword #:addr
55 (socket #:init-value #f
57 (upgrade #:init-value '()
58 #:allocation #:each-subclass)
59 (http-handler #:init-keyword #:http-handler
60 #:getter .http-handler))
62 (define-method (initialize (web-server <web-server>) init-args)
64 ;; Make sure the addr is set up
65 (when (not (slot-bound? web-server 'addr))
66 (set! (.addr web-server)
67 (if (.host web-server)
68 (inet-pton (.family web-server)
73 (set! (.socket web-server)
74 (make-default-socket (.family web-server)
76 (.port-num web-server)))
78 ;; This is borrowed from Guile's web server.
79 ;; Andy Wingo added the line with this commit:
80 ;; * module/web/server/http.scm (http-open): Ignore SIGPIPE. Keeps the
81 ;; server from dying in some circumstances.
82 (sigaction SIGPIPE SIG_IGN))
84 ;; @@: Borrowed from Guile itself / Fibers
86 (define (set-nonblocking! port)
87 (fcntl port F_SETFL (logior O_NONBLOCK (fcntl port F_GETFL)))
88 (setvbuf port 'block 1024))
90 (define (make-default-socket family addr port)
91 (let ((sock (socket PF_INET SOCK_STREAM 0)))
92 (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
93 (fcntl sock F_SETFD FD_CLOEXEC)
94 (bind sock family addr port)
95 (set-nonblocking! sock)
96 ;; We use a large backlog by default. If the server is suddenly hit
97 ;; with a number of connections on a small backlog, clients won't
98 ;; receive confirmation for their SYN, leading them to retry --
99 ;; probably successfully, but with a large latency.
103 (define (web-server-socket-loop web-server message)
104 "The main loop on our socket. Keep accepting new clients as long
107 (match (accept (.socket web-server))
109 ;; From "HOP, A Fast Server for the Diffuse Web", Serrano.
110 (setsockopt client SOL_SOCKET SO_SNDBUF (* 12 1024))
111 (set-nonblocking! client)
112 ;; Always disable Nagle's algorithm, as we handle buffering
113 ;; ourselves. Ignore exceptions if it's not a TCP port, or
114 ;; TCP_NODELAY is not defined on this platform.
116 (setsockopt client IPPROTO_TCP TCP_NODELAY 0))
117 (<- (actor-id web-server) 'new-client client)))))
119 (define (keep-alive? response)
120 (let ((v (response-version response)))
121 (and (or (< (response-code response) 400)
122 (= (response-code response) 404))
126 ((1) (not (memq 'close (response-connection response))))
127 ((0) (memq 'keep-alive (response-connection response)))))
130 (define (web-server-client-loop web-server message client)
131 "Read request(s) from a client and pass off to the handler."
132 (with-throw-handler #t
135 (define (respond-and-maybe-continue _ response body)
136 (write-response response client)
138 (put-bytevector client body))
139 (force-output client)
140 (if (and (keep-alive? response)
141 (not (eof-object? (peek-char client))))
143 (close-port client)))
145 ((eof-object? (lookahead-u8 client))
150 (let* ((request (read-request client))
151 (body (read-request-body request)))
153 ;; TODO: Add error handling in case we get an error
155 (<-wait (actor-id web-server) 'handle-request
157 respond-and-maybe-continue)))
159 (display "While reading request:\n" (current-error-port))
160 (print-exception (current-error-port) #f key args)
161 (respond-and-maybe-continue
162 #f ;; ignored, there is no message
163 (build-response #:version '(1 . 0) #:code 400
164 #:headers '((content-length . 0)))
168 (lambda () (close-port client))
170 (display "While closing port:\n" (current-error-port))
171 (print-exception (current-error-port) #f k args))))))
173 (define (web-server-handle-request web-server message
175 (receive (response body)
176 ((.http-handler web-server) request body)
177 (receive (response body)
178 (sanitize-response request response body)
179 (<-reply message response body))))
181 (define (web-server-cleanup web-server message)
182 ;; @@: Should we close any pending requests too?
183 (close (.socket web-server)))
185 (define (web-server-shutdown web-server message)
186 (self-destruct web-server))