8sync/systems/web.scm

   1 ;;; 8sync --- Asynchronous programming for Guile
   2 ;;; Copyright © 2017 Christopher Allan Webber <cwebber@dustycloud.org>
   3 ;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   4 ;;;
   5 ;;; Code (also under the LGPL) borrowed from fibers:
   6 ;;;   Copyright © 2016 Andy Wingo <wingo@pobox.com>
   7 ;;; and Guile:
   8 ;;;   Copyright © 2010, 2011, 2012, 2015 Free Software Foundation, Inc.
   9 ;;;
  10 ;;; This file is part of 8sync.
  11 ;;;
  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.
  16 ;;;
  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.
  21 ;;;
  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/>.
  24
  25
  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)
  35   #:use-module (8sync)
  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))
  46
  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))
  53
  54   (host #:init-value #f
  55         #:init-keyword #:host
  56         #:getter .host)
  57   (family #:init-value AF_INET
  58           #:init-keyword #:family
  59           #:getter .family)
  60   (port-num #:init-value 8080
  61             #:init-keyword #:port
  62             #:getter .port-num)
  63   (addr #:init-keyword #:addr
  64         #:accessor .addr)
  65   (socket #:init-value #f
  66           #:accessor .socket)
  67   (upgrade-paths #:init-value '()
  68                  #:allocation #:each-subclass)
  69   (http-handler #:init-keyword #:http-handler
  70                 #:getter .http-handler))
  71
  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))
  75
  76 (define-method (initialize (web-server <web-server>) init-args)
  77   (next-method)
  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)
  83                          (.host web-server))
  84               INADDR_LOOPBACK)))
  85
  86   ;; Set up the socket
  87   (set! (.socket web-server)
  88         (make-default-socket (.family web-server)
  89                              (.addr web-server)
  90                              (.port-num web-server)))
  91
  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))
  97
  98 ;; @@: Borrowed from Guile itself / Fibers
  99
 100 (define (set-nonblocking! port)
 101   (fcntl port F_SETFL (logior O_NONBLOCK (fcntl port F_GETFL)))
 102   (setvbuf port 'block 1024))
 103
 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.
 114     (listen sock 1024)
 115     sock))
 116
 117 (define (web-server-socket-loop web-server message)
 118   "The main loop on our socket.  Keep accepting new clients as long
 119 as we're alive."
 120   (while #t
 121     (match (accept (.socket web-server))
 122       ((client . sockaddr)
 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.
 129        (false-if-exception
 130         (setsockopt client IPPROTO_TCP TCP_NODELAY 0))
 131        (<- (actor-id web-server) 'new-client client)))))
 132
 133 (define (keep-alive? response)
 134   (let ((v (response-version response)))
 135     (and (or (< (response-code response) 400)
 136              (= (response-code response) 404))
 137          (case (car v)
 138            ((1)
 139             (case (cdr v)
 140               ((1) (not (memq 'close (response-connection response))))
 141               ((0) (memq 'keep-alive (response-connection response)))))
 142            (else #f)))))
 143
 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,
 148   ;; in order.
 149   ;; Note that we'll only handle one... we *don't* "compose"
 150   ;; upgrades.
 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
 156           ((_ . upgrade-proc)
 157            upgrade-proc)
 158           ;; Keep looking...
 159           (#f (loop (cdr upgrades)))))))
 160
 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
 164     (lambda ()
 165       (let loop ()
 166         (define (respond-and-maybe-continue _ response body)
 167           (write-response response client)
 168           (when body
 169             (put-bytevector client body))
 170           (force-output client)
 171           (if (and (keep-alive? response)
 172                    (not (eof-object? (peek-char client))))
 173               (loop)
 174               (close-port client)))
 175         (cond
 176          ((eof-object? (lookahead-u8 client))
 177           (close-port client))
 178          (else
 179           (catch #t
 180             (lambda ()
 181               (let* ((request (read-request client))
 182                      (body (read-request-body request)))
 183                 (cond
 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) =>
 187                   (lambda (upgrade)
 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)))
 192                  (else
 193                   (call-with-message
 194                    ;; TODO: Add error handling in case we get an error
 195                    ;;   response
 196                    (<-wait (actor-id web-server) 'handle-request
 197                            request body)
 198                    respond-and-maybe-continue)))))
 199             (lambda (key . args)
 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)))
 206                #vu8())))))))
 207     (lambda (k . args)
 208       (catch #t
 209         (lambda () (close-port client))
 210         (lambda (k . args)
 211           (display "While closing port:\n" (current-error-port))
 212           (print-exception (current-error-port) #f k args))))))
 213
 214 (define (web-server-handle-request web-server message
 215                                    request body)
 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))))
 221
 222 (define (web-server-cleanup web-server message)
 223   ;; @@: Should we close any pending requests too?
 224   (close (.socket web-server)))
 225
 226 (define (web-server-shutdown web-server message)
 227   (self-destruct web-server))