8sync/systems/web.scm

   1 #!/usr/bin/guile \
   2 -e main -s
   3 !#
   4
   5 ;;; 8sync --- Asynchronous programming for Guile
   6 ;;; Copyright (C) 2015 Christopher Allan Webber <cwebber@dustycloud.org>
   7 ;;;
   8 ;;; This file is part of 8sync.
   9 ;;;
  10 ;;; 8sync is free software: you can redistribute it and/or modify it
  11 ;;; under the terms of the GNU Lesser General Public License as
  12 ;;; published by the Free Software Foundation, either version 3 of the
  13 ;;; License, or (at your option) any later version.
  14 ;;;
  15 ;;; 8sync is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU Lesser General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU Lesser General Public
  21 ;;; License along with 8sync.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;; This is a very preliminary web module.
  24
  25 ;;; TODO: This is using deprecated code and needs a rewrite after the
  26 ;;; suspendable-ports merge.
  27
  28 (define-module (8sync systems web)
  29   #:use-module (web server)
  30   #:use-module (web request)
  31   #:use-module (web response)
  32   #:use-module (web uri)
  33   #:use-module (8sync agenda)
  34   #:use-module (8sync repl)
  35   #:use-module (ice-9 receive)
  36   #:use-module (ice-9 match)
  37   #:export (http-server-socket
  38             receive-http-conn
  39             simple-webdemo
  40             make-web-demo-cli))
  41
  42 (define (hello-world-handler request request-body)
  43   (values '((content-type . (text/plain)))
  44           "Hello world!"))
  45
  46 (define* (http-server-socket #:key
  47                              (host #f)
  48                              (family AF_INET)
  49                              (addr (if host
  50                                        (inet-pton family host)
  51                                        INADDR_LOOPBACK))
  52                              (port 8080)
  53                              (socket
  54                               ((@@ (web server http) make-default-socket)
  55                                family addr port)))
  56   (listen socket 128)
  57   ;;; This is used in Guile's http server under the commit:
  58   ;;; commit a0ad8ad16c14adbf13e0ead3dafd833fb3c8f0d3
  59   ;;; Author: Andy Wingo <wingo@pobox.com>
  60   ;;; Date:   Mon Nov 29 13:00:43 2010 +0100
  61   ;;;
  62   ;;;     http web server impl ignores SIGPIPE
  63   ;;;
  64   ;;;     * module/web/server/http.scm (http-open): Ignore SIGPIPE. Keeps the
  65   ;;;       server from dying in some circumstances.
  66   ;; (sigaction SIGPIPE SIG_IGN)
  67   ;;; Will this break other things that use pipes for us though?
  68
  69   ;; Throw a system-error rather than block on an (accept)
  70   ;; that has nothing to do
  71   (fcntl socket F_SETFL
  72          (logior O_NONBLOCK
  73                  (fcntl socket F_GETFL)))
  74   socket)
  75
  76
  77 (define* (accept-connection-gracefully socket #:key complain)
  78   "Try to accept a connection, but if there's nothing there,
  79 don't totally failboat"
  80   (catch 'system-error
  81     (lambda () (accept socket))
  82     ;; Maybe should catch the more specific error:
  83     ;;   (system-error "accept" "~A" ("Resource temporarily unavailable") (11))
  84     (lambda args
  85       (if complain
  86           (display "Gracefully handled no connection to accept\n"
  87                    (current-error-port)))
  88       #f)))
  89
  90 (define (receive-http-conn handler)
  91   (lambda (server-socket)
  92     (let ((conn-pair (accept-connection-gracefully
  93                       server-socket #:complain #t)))
  94       (match conn-pair
  95         ((client-conn . socket-address)
  96          (define (close-and-dequeue)
  97            (close client-conn)
  98            (8sync-port-remove client-conn))
  99
 100          (catch
 101            #t
 102            (lambda ()
 103              (let* ((request (read-request client-conn))
 104                     (request-body (read-request-body request)))
 105                (call-with-values
 106                    (lambda ()
 107                      (call-with-values
 108                          (lambda ()
 109                            ;; @@: Is it useful to wrap this in 8sync-run?
 110                            ;;  It's more indirection but might give breathing
 111                            ;;  room to other requests...
 112                            (handler request request-body))
 113                        (lambda return-values
 114                          (match return-values
 115                            ((response response-body)
 116                             (sanitize-response request response response-body))
 117                            (_ (throw 'invalid-http-response
 118                                      "Expected values of (response response-body) but didn't get 'em"
 119                                      return-values))))))
 120                  (lambda (response response-body)
 121                    (begin
 122                      (write-response-body
 123                       (write-response response client-conn)
 124                       response-body)
 125                      ;; TODO: We might NOT want to close here!
 126                      ;;   Eg, keep-alive requests.  See keep-alive? in guile's
 127                      ;;   (@@ (web server http) http-write)
 128                      (close-and-dequeue))))))
 129            (lambda (key . args)
 130              (display ":(\n")
 131              (close-and-dequeue)
 132              ;; re-raise exception
 133              (apply throw key args))))
 134         ;; If we get a #f back, there was nothing to do
 135         (#f #f)))))
 136
 137 (define (install-http-socket socket handler)
 138   (make-port-request socket #:read (receive-http-conn handler)))
 139
 140 ;; Kinda junky since dynamic-wind and delimited continuations
 141 ;; seem to not really get along...
 142
 143 (define-syntax-rule (with-socket-as make-socket socket-name
 144                                     body ...)
 145   (let ((socket-name make-socket))
 146     (dynamic-wind
 147       (const #f)
 148       (lambda ()
 149         body ...)
 150       (lambda ()
 151         (close socket-name)))))
 152
 153 (define default-handler (wrap-apply hello-world-handler))
 154
 155 (define* (run-simple-webserver #:key
 156                                (handler default-handler)
 157                                (coop-repl #f))
 158   (display "Running on http://127.0.0.1:8080/\n")
 159   (with-socket-as
 160    (http-server-socket) server-socket
 161    (let* ((q (make-q*
 162               (wrap (install-http-socket server-socket
 163                                          handler))))
 164           (agenda (make-agenda
 165                    #:queue q
 166                    #:pre-unwind-handler print-error-and-continue)))
 167      (if coop-repl
 168          (spawn-and-queue-repl-server! agenda))
 169      (start-agenda agenda))))
 170
 171 (define* (make-web-demo-cli #:key
 172                             (listen #t)
 173                             (handler default-handler))
 174   (define (main args)
 175     (run-simple-webserver #:coop-repl listen
 176                           #:handler handler))
 177   main)
 178
 179 (define main (make-web-demo-cli))