5 ;;; 8sync --- Asynchronous programming for Guile
6 ;;; Copyright (C) 2015 Christopher Allan Webber <cwebber@dustycloud.org>
8 ;;; This file is part of 8sync.
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.
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.
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/>.
23 ;; This is a very preliminary web module.
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
39 (define (hello-world-handler request request-body)
40 (values '((content-type . (text/plain)))
43 (define* (http-server-socket #:key
47 (inet-pton family host)
51 ((@@ (web server http) make-default-socket)
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
59 ;;; http web server impl ignores SIGPIPE
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?
66 ;; Throw a system-error rather than block on an (accept)
67 ;; that has nothing to do
70 (fcntl socket F_GETFL)))
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"
78 (lambda () (accept socket))
79 ;; Maybe should catch the more specific error:
80 ;; (system-error "accept" "~A" ("Resource temporarily unavailable") (11))
83 (display "Gracefully handled no connection to accept\n"
84 (current-error-port)))
87 (define (receive-http-conn handler)
88 (lambda (server-socket)
89 (let ((conn-pair (accept-connection-gracefully
90 server-socket #:complain #t)))
92 ((client-conn . socket-address)
93 (define (close-and-dequeue)
95 (%8sync-port-remove client-conn))
100 (let* ((request (read-request client-conn))
101 (request-body (read-request-body request)))
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
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"
117 (lambda (response response-body)
120 (write-response response client-conn)
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))))))
129 ;; re-raise exception
130 (apply throw key args))))
131 ;; If we get a #f back, there was nothing to do
134 (define (install-http-socket socket handler)
135 (make-port-request socket #:read (receive-http-conn handler)))
137 ;; Kinda junky since dynamic-wind and delimited continuations
138 ;; seem to not really get along...
140 (define-syntax-rule (with-socket-as make-socket socket-name
142 (let ((socket-name make-socket))
148 (close socket-name)))))
150 (define default-handler (wrap-apply hello-world-handler))
152 (define* (run-simple-webserver #:key
153 (handler default-handler)
155 (display "Running on http://127.0.0.1:8080/\n")
157 (http-server-socket) server-socket
159 (wrap (install-http-socket server-socket
163 #:pre-unwind-handler print-error-and-continue)))
165 ;; (spawn-and-queue-repl-server! agenda))
166 (start-agenda agenda))))
168 (define* (make-web-demo-cli #:key
170 (handler default-handler))
172 (run-simple-webserver #:coop-repl listen
176 (define main (make-web-demo-cli))