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 control)
  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   #:export (<web-server>
  37             ;; @@: If we don't want to import these because of
  38             ;;   "conflicts" with other objects, we could just
  39             ;;   select <web-server> only.
  40             ;;   Alternately we could move the crux of this into
  41             ;;   another module and just export <web-server>, though
  42             ;;   that does feel a bit like overkill.
  43             .host .family .port-num .addr .socket
  44             .upgrade-paths .http-handler))
  45
  46 (define-actor <web-server> (<actor>)
  47   ((main-loop web-server-socket-loop)
  48    (shutdown web-server-shutdown)
  49    (new-client web-server-client-loop)
  50    (handle-request web-server-handle-request))
  51
  52   (host #:init-value #f
  53         #:init-keyword #:host
  54         #:getter .host)
  55   (family #:init-value AF_INET
  56           #:init-keyword #:family
  57           #:getter .family)
  58   (port-num #:init-value 8080
  59             #:init-keyword #:port
  60             #:getter .port-num)
  61   (addr #:init-keyword #:addr
  62         #:accessor .addr)
  63   (socket #:init-value #f
  64           #:accessor .socket)
  65   (upgrade-paths #:init-value '()
  66                  #:allocation #:each-subclass)
  67   (http-handler #:init-keyword #:http-handler
  68                 #:getter .http-handler))
  69
  70 ;; Define getter externally so it works even if we subclass
  71 (define-method (.upgrade-paths (web-server <web-server>))
  72   (slot-ref web-server 'upgrade-paths))
  73
  74 (define-method (initialize (web-server <web-server>) init-args)
  75   (next-method)
  76   ;; Make sure the addr is set up
  77   (when (not (slot-bound? web-server 'addr))
  78     (set! (.addr web-server)
  79           (if (.host web-server)
  80               (inet-pton (.family web-server)
  81                          (.host web-server))
  82               INADDR_LOOPBACK)))
  83
  84   ;; Set up the socket
  85   (set! (.socket web-server)
  86         (make-default-socket (.family web-server)
  87                              (.addr web-server)
  88                              (.port-num web-server)))
  89
  90   ;; This is borrowed from Guile's web server.
  91   ;; Andy Wingo added the line with this commit:
  92   ;; * module/web/server/http.scm (http-open): Ignore SIGPIPE. Keeps the
  93   ;;   server from dying in some circumstances.
  94   (sigaction SIGPIPE SIG_IGN))
  95
  96 ;; @@: Borrowed from Guile itself / Fibers
  97
  98 (define (set-nonblocking! port)
  99   (fcntl port F_SETFL (logior O_NONBLOCK (fcntl port F_GETFL)))
 100   (setvbuf port 'block 1024))
 101
 102 (define (make-default-socket family addr port)
 103   (let ((sock (socket PF_INET SOCK_STREAM 0)))
 104     (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
 105     (fcntl sock F_SETFD FD_CLOEXEC)
 106     (bind sock family addr port)
 107     (set-nonblocking! sock)
 108     ;; We use a large backlog by default.  If the server is suddenly hit
 109     ;; with a number of connections on a small backlog, clients won't
 110     ;; receive confirmation for their SYN, leading them to retry --
 111     ;; probably successfully, but with a large latency.
 112     (listen sock 1024)
 113     sock))
 114
 115 (define-method (actor-init! (web-server <web-server>))
 116   (<- (actor-id web-server) 'main-loop))
 117
 118 (define-method (actor-cleanup! (web-server <web-server>))
 119   ;; @@: Should we close any pending requests too?
 120   (close (.socket web-server)))
 121
 122 (define (web-server-socket-loop web-server message)
 123   "The main loop on our socket.  Keep accepting new clients as long
 124 as we're alive."
 125   (with-actor-nonblocking-ports
 126    (lambda ()
 127      (while #t
 128        (match (accept (.socket web-server))
 129          ((client . sockaddr)
 130           ;; From "HOP, A Fast Server for the Diffuse Web", Serrano.
 131           (setsockopt client SOL_SOCKET SO_SNDBUF (* 12 1024))
 132           (set-nonblocking! client)
 133           ;; Always disable Nagle's algorithm, as we handle buffering
 134           ;; ourselves.  Ignore exceptions if it's not a TCP port, or
 135           ;; TCP_NODELAY is not defined on this platform.
 136           (false-if-exception
 137            (setsockopt client IPPROTO_TCP TCP_NODELAY 0))
 138           (<- (actor-id web-server) 'new-client client)))))))
 139
 140 (define (keep-alive? response)
 141   (let ((v (response-version response)))
 142     (and (or (< (response-code response) 400)
 143              (= (response-code response) 404))
 144          (case (car v)
 145            ((1)
 146             (case (cdr v)
 147               ((1) (not (memq 'close (response-connection response))))
 148               ((0) (memq 'keep-alive (response-connection response)))))
 149            (else #f)))))
 150
 151 (define (maybe-upgrade-request web-server request body)
 152   (define upgrade-paths (.upgrade-paths web-server))
 153   ;; A request can specify multiple values to the "Upgrade"
 154   ;; field, so we slook to see if we have an applicable option,
 155   ;; in order.
 156   ;; Note that we'll only handle one... we *don't* "compose"
 157   ;; upgrades.
 158   (let loop ((upgrades (request-upgrade request)))
 159     (if (eq? upgrades '())
 160         #f ; Shouldn't upgrade
 161         (match (assoc (car upgrades) upgrade-paths)
 162           ;; Yes, upgrade with this method
 163           ((_ . upgrade-proc)
 164            upgrade-proc)
 165           ;; Keep looking...
 166           (#f (loop (cdr upgrades)))))))
 167
 168 (define (web-server-client-loop web-server message client)
 169   "Read request(s) from a client and pass off to the handler."
 170   (with-actor-nonblocking-ports
 171    (lambda ()
 172      (with-throw-handler #t
 173        (lambda ()
 174          (let loop ()
 175            (define (respond-and-maybe-continue response body)
 176              (write-response response client)
 177              (when body
 178                (put-bytevector client body))
 179              (force-output client)
 180              (if (and (keep-alive? response)
 181                       (not (eof-object? (peek-char client))))
 182                  (loop)
 183                  (close-port client)))
 184            (cond
 185             ((eof-object? (lookahead-u8 client))
 186              (close-port client))
 187             (else
 188              (call/ec
 189               (lambda (return)
 190                 (define (read-with-catch thunk)
 191                   (catch #t
 192                     thunk
 193                     (lambda _
 194                       (return
 195                        (false-if-exception
 196                         (respond-and-maybe-continue
 197                          (build-response #:version '(1 . 0) #:code 400
 198                                          #:headers '((content-length . 0)))
 199                          #vu8()))))
 200                     (let ((err (current-error-port)))
 201                       (lambda (key . args)
 202                         (false-if-exception
 203                          (let ((stack (make-stack #t 4)))
 204                            (display "While reading request:\n" err)
 205                            ;; @@: Maybe comment this out or make it optional?
 206                            (display-backtrace stack err)
 207                            (print-exception err (stack-ref stack 0) key args)
 208                            (newline err)))))))
 209                 (let* ((request (read-with-catch
 210                                  (lambda () (read-request client))))
 211                        (body (read-with-catch
 212                               (lambda () (read-request-body request)))))
 213                   (cond
 214                    ;; Should we "upgrade" the protocol?
 215                    ;; Doing so "breaks out" of this loop, possibly into a new one
 216                    ((maybe-upgrade-request web-server request body) =>
 217                     (lambda (upgrade)
 218                       (upgrade web-server client request body)))
 219                    (else
 220                     (call-with-values
 221                         (lambda ()
 222                           ;; TODO: Add error handling in case we get an error
 223                           ;;   response
 224                           (<-wait (actor-id web-server) 'handle-request
 225                                   request body))
 226                       respond-and-maybe-continue))))))))))
 227        (lambda (k . args)
 228          (catch #t
 229            (lambda () (close-port client))
 230            (lambda (k . args)
 231              (display "While closing port:\n" (current-error-port))
 232              (print-exception (current-error-port) #f k args))))))))
 233
 234 (define (web-server-handle-request web-server message
 235                                    request body)
 236   (receive (response body)
 237       ((.http-handler web-server) request body)
 238     (receive (response body)
 239         (sanitize-response request response body)
 240       (values response body))))
 241
 242 (define (web-server-shutdown web-server message)
 243   (self-destruct web-server))