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 (define-module (8sync systems web)
  26   #:use-module (web server)
  27   #:use-module (web request)
  28   #:use-module (web response)
  29   #:use-module (web uri)
  30   #:use-module (8sync agenda)
  31   #:use-module (8sync repl)
  32   #:use-module (ice-9 receive)
  33   #:use-module (ice-9 match)
  34   #:export (http-server-socket
  35             receive-http-conn
  36             simple-webdemo
  37             make-web-demo-cli))
  38
  39 (define (hello-world-handler request request-body)
  40   (values '((content-type . (text/plain)))
  41           "Hello world!"))
  42
  43 (define* (http-server-socket #:key
  44                              (host #f)
  45                              (family AF_INET)
  46                              (addr (if host
  47                                        (inet-pton family host)
  48                                        INADDR_LOOPBACK))
  49                              (port 8080)
  50                              (socket
  51                               ((@@ (web server http) make-default-socket)
  52                                family addr port)))
  53   (listen socket 128)
  54   ;;; This is used in Guile's http server under the commit:
  55   ;;; commit a0ad8ad16c14adbf13e0ead3dafd833fb3c8f0d3
  56   ;;; Author: Andy Wingo <wingo@pobox.com>
  57   ;;; Date:   Mon Nov 29 13:00:43 2010 +0100
  58   ;;;
  59   ;;;     http web server impl ignores SIGPIPE
  60   ;;;
  61   ;;;     * module/web/server/http.scm (http-open): Ignore SIGPIPE. Keeps the
  62   ;;;       server from dying in some circumstances.
  63   ;; (sigaction SIGPIPE SIG_IGN)
  64   ;;; Will this break other things that use pipes for us though?
  65
  66   ;; Throw a system-error rather than block on an (accept)
  67   ;; that has nothing to do
  68   (fcntl socket F_SETFL
  69          (logior O_NONBLOCK
  70                  (fcntl socket F_GETFL)))
  71   socket)
  72
  73
  74 (define* (accept-connection-gracefully socket #:key complain)
  75   "Try to accept a connection, but if there's nothing there,
  76 don't totally failboat"
  77   (catch 'system-error
  78     (lambda () (accept socket))
  79     ;; Maybe should catch the more specific error:
  80     ;;   (system-error "accept" "~A" ("Resource temporarily unavailable") (11))
  81     (lambda args
  82       (if complain
  83           (display "Gracefully handled no connection to accept\n"
  84                    (current-error-port)))
  85       #f)))
  86
  87 (define (receive-http-conn handler)
  88   (lambda (server-socket)
  89     (let ((conn-pair (accept-connection-gracefully
  90                       server-socket #:complain #t)))
  91       (match conn-pair
  92         ((client-conn . socket-address)
  93          (define (close-and-dequeue)
  94            (close client-conn)
  95            (8sync-port-remove client-conn))
  96
  97          (catch
  98            #t
  99            (lambda ()
 100              (let* ((request (read-request client-conn))
 101                     (request-body (read-request-body request)))
 102                (call-with-values
 103                    (lambda ()
 104                      (call-with-values
 105                          (lambda ()
 106                            ;; @@: Is it useful to wrap this in 8sync-run?
 107                            ;;  It's more indirection but might give breathing
 108                            ;;  room to other requests...
 109                            (handler request request-body))
 110                        (lambda return-values
 111                          (match return-values
 112                            ((response response-body)
 113                             (sanitize-response request response response-body))
 114                            (_ (throw 'invalid-http-response
 115                                      "Expected values of (response response-body) but didn't get 'em"
 116                                      return-values))))))
 117                  (lambda (response response-body)
 118                    (begin
 119                      (write-response-body
 120                       (write-response response client-conn)
 121                       response-body)
 122                      ;; TODO: We might NOT want to close here!
 123                      ;;   Eg, keep-alive requests.  See keep-alive? in guile's
 124                      ;;   (@@ (web server http) http-write)
 125                      (close-and-dequeue))))))
 126            (lambda (key . args)
 127              (display ":(\n")
 128              (close-and-dequeue)
 129              ;; re-raise exception
 130              (apply throw key args))))
 131         ;; If we get a #f back, there was nothing to do
 132         (#f #f)))))
 133
 134 (define (install-http-socket socket handler)
 135   (make-port-request socket #:read (receive-http-conn handler)))
 136
 137 ;; Kinda junky since dynamic-wind and delimited continuations
 138 ;; seem to not really get along...
 139
 140 (define-syntax-rule (with-socket-as make-socket socket-name
 141                                     body ...)
 142   (let ((socket-name make-socket))
 143     (dynamic-wind
 144       (const #f)
 145       (lambda ()
 146         body ...)
 147       (lambda ()
 148         (close socket-name)))))
 149
 150 (define default-handler (wrap-apply hello-world-handler))
 151
 152 (define* (run-simple-webserver #:key
 153                                (handler default-handler)
 154                                (coop-repl #f))
 155   (display "Running on http://127.0.0.1:8080/\n")
 156   (with-socket-as
 157    (http-server-socket) server-socket
 158    (let* ((q (make-q*
 159               (wrap (install-http-socket server-socket
 160                                          handler))))
 161           (agenda (make-agenda
 162                    #:queue q
 163                    #:pre-unwind-handler print-error-and-continue)))
 164      (if coop-repl
 165          (spawn-and-queue-repl-server! agenda))
 166      (start-agenda agenda))))
 167
 168 (define* (make-web-demo-cli #:key
 169                             (listen #t)
 170                             (handler default-handler))
 171   (define (main args)
 172     (run-simple-webserver #:coop-repl listen
 173                           #:handler handler))
 174   main)
 175
 176 (define main (make-web-demo-cli))