8sync/systems/web.scm

   1 ;;; 8sync --- Asynchronous programming for Guile
   2 ;;; Copyright © 2017 Christopher Allan Webber <cwebber@dustycloud.org>
   3 ;;;
   4 ;;; Code (also under the LGPL) borrowed from fibers:
   5 ;;;   Copyright © 2016 Andy Wingo <wingo@pobox.com>
   6 ;;; and Guile:
   7 ;;;   Copyright © 2010, 2011, 2012, 2015 Free Software Foundation, Inc.
   8 ;;;
   9 ;;; This file is part of 8sync.
  10 ;;;
  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.
  15 ;;;
  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.
  20 ;;;
  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/>.
  23
  24
  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)
  34   #:use-module (8sync)
  35   #:export (<web-server>))
  36
  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))
  43
  44   (host #:init-value #f
  45         #:init-keyword #:host
  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
  51             #:init-keyword #:port
  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   (upgrade #:init-value '()
  58            #:allocation #:each-subclass)
  59   (http-handler #:init-keyword #:http-handler
  60                 #:getter web-server-http-handler))
  61
  62 (define-method (initialize (web-server <web-server>) init-args)
  63   (next-method)
  64   ;; Make sure the addr is set up
  65   (when (not (slot-bound? web-server 'addr))
  66     (set! (web-server-addr web-server)
  67           (if (web-server-host web-server)
  68               (inet-pton (web-server-family web-server)
  69                          (web-server-host web-server))
  70               INADDR_LOOPBACK)))
  71
  72   ;; Set up the socket
  73   (set! (web-server-socket web-server)
  74         (make-default-socket (web-server-family web-server)
  75                              (web-server-addr web-server)
  76                              (web-server-port-num web-server)))
  77
  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))
  83
  84 ;; @@: Borrowed from Guile itself / Fibers
  85
  86 (define (set-nonblocking! port)
  87   (fcntl port F_SETFL (logior O_NONBLOCK (fcntl port F_GETFL)))
  88   (setvbuf port 'block 1024))
  89
  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.
 100     (listen sock 1024)
 101     sock))
 102
 103 (define (web-server-socket-loop web-server message)
 104   "The main loop on our socket.  Keep accepting new clients as long
 105 as we're alive."
 106   (while #t
 107     (match (accept (web-server-socket web-server))
 108       ((client . sockaddr)
 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.
 115        (false-if-exception
 116         (setsockopt client IPPROTO_TCP TCP_NODELAY 0))
 117        (<- (actor-id web-server) 'new-client client)))))
 118
 119 (define (keep-alive? response)
 120   (let ((v (response-version response)))
 121     (and (or (< (response-code response) 400)
 122              (= (response-code response) 404))
 123          (case (car v)
 124            ((1)
 125             (case (cdr v)
 126               ((1) (not (memq 'close (response-connection response))))
 127               ((0) (memq 'keep-alive (response-connection response)))))
 128            (else #f)))))
 129
 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
 133     (lambda ()
 134       (let loop ()
 135         (define (respond-and-maybe-continue _ response body)
 136           (write-response response client)
 137           (when body
 138             (put-bytevector client body))
 139           (force-output client)
 140           (if (and (keep-alive? response)
 141                    (not (eof-object? (peek-char client))))
 142               (loop)
 143               (close-port client)))
 144         (cond
 145          ((eof-object? (lookahead-u8 client))
 146           (close-port client))
 147          (else
 148           (catch #t
 149             (lambda ()
 150               (let* ((request (read-request client))
 151                      (body (read-request-body request)))
 152                 (call-with-message
 153                  ;; TODO: Add error handling in case we get an error
 154                  ;;   response
 155                  (<-wait (actor-id web-server) 'handle-request
 156                          request body)
 157                  respond-and-maybe-continue)))
 158             (lambda (key . args)
 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)))
 165                #vu8())))))))
 166     (lambda (k . args)
 167       (catch #t
 168         (lambda () (close-port client))
 169         (lambda (k . args)
 170           (display "While closing port:\n" (current-error-port))
 171           (print-exception (current-error-port) #f k args))))))
 172
 173 (define (web-server-handle-request web-server message
 174                                    request body)
 175   (receive (response body)
 176       ((web-server-http-handler web-server) request body)
 177     (receive (response body)
 178         (sanitize-response request response body)
 179       (<-reply message response body))))
 180
 181 (define (web-server-cleanup web-server message)
 182   ;; @@: Should we close any pending requests too?
 183   (close (web-server-socket web-server)))
 184
 185 (define (web-server-shutdown web-server message)
 186   (self-destruct web-server))