-#!/usr/bin/guile \
--e main -s
-!#
-
;;; 8sync --- Asynchronous programming for Guile
-;;; Copyright (C) 2015 Christopher Allan Webber <cwebber@dustycloud.org>
+;;; Copyright © 2017 Christopher Allan Webber <cwebber@dustycloud.org>
+;;;
+;;; Code (also under the LGPL) borrowed from fibers:
+;;; Copyright © 2016 Andy Wingo <wingo@pobox.com>
+;;; and Guile:
+;;; Copyright © 2010, 2011, 2012, 2015 Free Software Foundation, Inc.
;;;
;;; This file is part of 8sync.
;;;
;;; You should have received a copy of the GNU Lesser General Public
;;; License along with 8sync. If not, see <http://www.gnu.org/licenses/>.
-;; This is a very preliminary web module.
(define-module (8sync systems web)
- #:use-module (web server)
+ #:use-module (oop goops)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 receive)
+ #:use-module (web http)
#:use-module (web request)
#:use-module (web response)
- #:use-module (web uri)
- #:use-module (8sync agenda)
- #:use-module (8sync repl)
- #:use-module (ice-9 receive)
- #:use-module (ice-9 match)
- #:export (http-server-socket
- receive-http-conn
- simple-webdemo
- make-web-demo-cli))
-
-(define (hello-world-handler request request-body)
- (values '((content-type . (text/plain)))
- "Hello world!"))
-
-(define* (http-server-socket #:key
- (host #f)
- (family AF_INET)
- (addr (if host
- (inet-pton family host)
- INADDR_LOOPBACK))
- (port 8080)
- (socket
- ((@@ (web server http) make-default-socket)
- family addr port)))
- (listen socket 128)
- ;;; This is used in Guile's http server under the commit:
- ;;; commit a0ad8ad16c14adbf13e0ead3dafd833fb3c8f0d3
- ;;; Author: Andy Wingo <wingo@pobox.com>
- ;;; Date: Mon Nov 29 13:00:43 2010 +0100
- ;;;
- ;;; http web server impl ignores SIGPIPE
- ;;;
- ;;; * module/web/server/http.scm (http-open): Ignore SIGPIPE. Keeps the
- ;;; server from dying in some circumstances.
- ;; (sigaction SIGPIPE SIG_IGN)
- ;;; Will this break other things that use pipes for us though?
-
- ;; Throw a system-error rather than block on an (accept)
- ;; that has nothing to do
- (fcntl socket F_SETFL
- (logior O_NONBLOCK
- (fcntl socket F_GETFL)))
- socket)
-
-
-(define* (accept-connection-gracefully socket #:key complain)
- "Try to accept a connection, but if there's nothing there,
-don't totally failboat"
- (catch 'system-error
- (lambda () (accept socket))
- ;; Maybe should catch the more specific error:
- ;; (system-error "accept" "~A" ("Resource temporarily unavailable") (11))
- (lambda args
- (if complain
- (display "Gracefully handled no connection to accept\n"
- (current-error-port)))
- #f)))
-
-(define (receive-http-conn handler)
- (lambda (server-socket)
- (let ((conn-pair (accept-connection-gracefully
- server-socket #:complain #t)))
- (match conn-pair
- ((client-conn . socket-address)
- (define (close-and-dequeue)
- (close client-conn)
- (8sync-port-remove client-conn))
-
- (catch
- #t
- (lambda ()
- (let* ((request (read-request client-conn))
- (request-body (read-request-body request)))
- (call-with-values
- (lambda ()
- (call-with-values
- (lambda ()
- ;; @@: Is it useful to wrap this in 8sync-run?
- ;; It's more indirection but might give breathing
- ;; room to other requests...
- (handler request request-body))
- (lambda return-values
- (match return-values
- ((response response-body)
- (sanitize-response request response response-body))
- (_ (throw 'invalid-http-response
- "Expected values of (response response-body) but didn't get 'em"
- return-values))))))
- (lambda (response response-body)
- (begin
- (write-response-body
- (write-response response client-conn)
- response-body)
- ;; TODO: We might NOT want to close here!
- ;; Eg, keep-alive requests. See keep-alive? in guile's
- ;; (@@ (web server http) http-write)
- (close-and-dequeue))))))
- (lambda (key . args)
- (display ":(\n")
- (close-and-dequeue)
- ;; re-raise exception
- (apply throw key args))))
- ;; If we get a #f back, there was nothing to do
- (#f #f)))))
-
-(define (install-http-socket socket handler)
- (make-port-request socket #:read (receive-http-conn handler)))
-
-;; Kinda junky since dynamic-wind and delimited continuations
-;; seem to not really get along...
-
-(define-syntax-rule (with-socket-as make-socket socket-name
- body ...)
- (let ((socket-name make-socket))
- (dynamic-wind
- (const #f)
- (lambda ()
- body ...)
- (lambda ()
- (close socket-name)))))
-
-(define default-handler (wrap-apply hello-world-handler))
-
-(define* (run-simple-webserver #:key
- (handler default-handler)
- (coop-repl #f))
- (display "Running on http://127.0.0.1:8080/\n")
- (with-socket-as
- (http-server-socket) server-socket
- (let* ((q (make-q*
- (wrap (install-http-socket server-socket
- handler))))
- (agenda (make-agenda
- #:queue q
- #:pre-unwind-handler print-error-and-continue)))
- (if coop-repl
- (spawn-and-queue-repl-server! agenda))
- (start-agenda agenda))))
-
-(define* (make-web-demo-cli #:key
- (listen #t)
- (handler default-handler))
- (define (main args)
- (run-simple-webserver #:coop-repl listen
- #:handler handler))
- main)
-
-(define main (make-web-demo-cli))
+ #:use-module (web server)
+ #:use-module (rnrs io ports)
+ #:use-module (8sync)
+ #:export (<web-server>
+ ;; @@: If we don't want to import these because of
+ ;; "conflicts" with other objects, we could just
+ ;; select <web-server> only.
+ ;; Alternately we could move the crux of this into
+ ;; another module and just export <web-server>, though
+ ;; that does feel a bit like overkill.
+ .host .family .port-num .addr .socket
+ .upgrade-paths .http-handler))
+
+(define-actor <web-server> (<actor>)
+ ((*init* web-server-socket-loop)
+ (*cleanup* web-server-cleanup)
+ (shutdown web-server-shutdown)
+ (new-client web-server-client-loop)
+ (handle-request web-server-handle-request))
+
+ (host #:init-value #f
+ #:init-keyword #:host
+ #:getter .host)
+ (family #:init-value AF_INET
+ #:init-keyword #:family
+ #:getter .family)
+ (port-num #:init-value 8080
+ #:init-keyword #:port
+ #:getter .port-num)
+ (addr #:init-keyword #:addr
+ #:accessor .addr)
+ (socket #:init-value #f
+ #:accessor .socket)
+ (upgrade-paths #:init-value '()
+ #:allocation #:each-subclass)
+ (http-handler #:init-keyword #:http-handler
+ #:getter .http-handler))
+
+;; Define getter externally so it works even if we subclass
+(define-method (.upgrade-paths (web-server <web-server>))
+ (slot-ref web-server 'upgrade-paths))
+
+(define-method (initialize (web-server <web-server>) init-args)
+ (next-method)
+ ;; Make sure the addr is set up
+ (when (not (slot-bound? web-server 'addr))
+ (set! (.addr web-server)
+ (if (.host web-server)
+ (inet-pton (.family web-server)
+ (.host web-server))
+ INADDR_LOOPBACK)))
+
+ ;; Set up the socket
+ (set! (.socket web-server)
+ (make-default-socket (.family web-server)
+ (.addr web-server)
+ (.port-num web-server)))
+
+ ;; This is borrowed from Guile's web server.
+ ;; Andy Wingo added the line with this commit:
+ ;; * module/web/server/http.scm (http-open): Ignore SIGPIPE. Keeps the
+ ;; server from dying in some circumstances.
+ (sigaction SIGPIPE SIG_IGN))
+
+;; @@: Borrowed from Guile itself / Fibers
+
+(define (set-nonblocking! port)
+ (fcntl port F_SETFL (logior O_NONBLOCK (fcntl port F_GETFL)))
+ (setvbuf port 'block 1024))
+
+(define (make-default-socket family addr port)
+ (let ((sock (socket PF_INET SOCK_STREAM 0)))
+ (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+ (fcntl sock F_SETFD FD_CLOEXEC)
+ (bind sock family addr port)
+ (set-nonblocking! sock)
+ ;; We use a large backlog by default. If the server is suddenly hit
+ ;; with a number of connections on a small backlog, clients won't
+ ;; receive confirmation for their SYN, leading them to retry --
+ ;; probably successfully, but with a large latency.
+ (listen sock 1024)
+ sock))
+
+(define (web-server-socket-loop web-server message)
+ "The main loop on our socket. Keep accepting new clients as long
+as we're alive."
+ (while #t
+ (match (accept (.socket web-server))
+ ((client . sockaddr)
+ ;; From "HOP, A Fast Server for the Diffuse Web", Serrano.
+ (setsockopt client SOL_SOCKET SO_SNDBUF (* 12 1024))
+ (set-nonblocking! client)
+ ;; Always disable Nagle's algorithm, as we handle buffering
+ ;; ourselves. Ignore exceptions if it's not a TCP port, or
+ ;; TCP_NODELAY is not defined on this platform.
+ (false-if-exception
+ (setsockopt client IPPROTO_TCP TCP_NODELAY 0))
+ (<- (actor-id web-server) 'new-client client)))))
+
+(define (keep-alive? response)
+ (let ((v (response-version response)))
+ (and (or (< (response-code response) 400)
+ (= (response-code response) 404))
+ (case (car v)
+ ((1)
+ (case (cdr v)
+ ((1) (not (memq 'close (response-connection response))))
+ ((0) (memq 'keep-alive (response-connection response)))))
+ (else #f)))))
+
+(define (maybe-upgrade-request web-server request body)
+ (define upgrade-paths (.upgrade-paths web-server))
+ ;; A request can specify multiple values to the "Upgrade"
+ ;; field, so we slook to see if we have an applicable option,
+ ;; in order.
+ ;; Note that we'll only handle one... we *don't* "compose"
+ ;; upgrades.
+ (let loop ((upgrades (request-upgrade request)))
+ (if (eq? upgrades '())
+ #f ; Shouldn't upgrade
+ (match (assoc (car upgrades) upgrade-paths)
+ ;; Yes, upgrade with this method
+ ((_ . upgrade-proc)
+ upgrade-proc)
+ ;; Keep looking...
+ (#f (loop (cdr upgrades)))))))
+
+(define (web-server-client-loop web-server message client)
+ "Read request(s) from a client and pass off to the handler."
+ (with-throw-handler #t
+ (lambda ()
+ (let loop ()
+ (define (respond-and-maybe-continue _ response body)
+ (write-response response client)
+ (when body
+ (put-bytevector client body))
+ (force-output client)
+ (if (and (keep-alive? response)
+ (not (eof-object? (peek-char client))))
+ (loop)
+ (close-port client)))
+ (cond
+ ((eof-object? (lookahead-u8 client))
+ (close-port client))
+ (else
+ (catch #t
+ (lambda ()
+ (let* ((request (read-request client))
+ (body (read-request-body request)))
+ (cond
+ ;; Should we "upgrade" the protocol?
+ ;; Doing so "breaks out" of this loop, possibly into a new one
+ ((maybe-upgrade-request web-server request body) =>
+ (lambda (upgrade)
+ ;; TODO: this isn't great because we're in this catch,
+ ;; which doesn't make sense once we've "upgraded"
+ ;; since we might not "respond" in the same way anymore.
+ (upgrade web-server client request body)))
+ (else
+ (call-with-message
+ ;; TODO: Add error handling in case we get an error
+ ;; response
+ (<-wait (actor-id web-server) 'handle-request
+ request body)
+ respond-and-maybe-continue)))))
+ (lambda (key . args)
+ (display "While reading request:\n" (current-error-port))
+ (print-exception (current-error-port) #f key args)
+ (respond-and-maybe-continue
+ #f ;; ignored, there is no message
+ (build-response #:version '(1 . 0) #:code 400
+ #:headers '((content-length . 0)))
+ #vu8())))))))
+ (lambda (k . args)
+ (catch #t
+ (lambda () (close-port client))
+ (lambda (k . args)
+ (display "While closing port:\n" (current-error-port))
+ (print-exception (current-error-port) #f k args))))))
+
+(define (web-server-handle-request web-server message
+ request body)
+ (receive (response body)
+ ((.http-handler web-server) request body)
+ (receive (response body)
+ (sanitize-response request response body)
+ (<-reply message response body))))
+
+(define (web-server-cleanup web-server message)
+ ;; @@: Should we close any pending requests too?
+ (close (.socket web-server)))
+
+(define (web-server-shutdown web-server message)
+ (self-destruct web-server))
projects / 8sync.git / blobdiff