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