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 ;;; TODO: This is using deprecated code and needs a rewrite after the
26 ;;; suspendable-ports merge.
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
42 (define (hello-world-handler request request-body)
43 (values '((content-type . (text/plain)))
46 (define* (http-server-socket #:key
50 (inet-pton family host)
54 ((@@ (web server http) make-default-socket)
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
62 ;;; http web server impl ignores SIGPIPE
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?
69 ;; Throw a system-error rather than block on an (accept)
70 ;; that has nothing to do
73 (fcntl socket F_GETFL)))
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"
81 (lambda () (accept socket))
82 ;; Maybe should catch the more specific error:
83 ;; (system-error "accept" "~A" ("Resource temporarily unavailable") (11))
86 (display "Gracefully handled no connection to accept\n"
87 (current-error-port)))
90 (define (receive-http-conn handler)
91 (lambda (server-socket)
92 (let ((conn-pair (accept-connection-gracefully
93 server-socket #:complain #t)))
95 ((client-conn . socket-address)
96 (define (close-and-dequeue)
98 (8sync-port-remove client-conn))
103 (let* ((request (read-request client-conn))
104 (request-body (read-request-body request)))
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
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"
120 (lambda (response response-body)
123 (write-response response client-conn)
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))))))
132 ;; re-raise exception
133 (apply throw key args))))
134 ;; If we get a #f back, there was nothing to do
137 (define (install-http-socket socket handler)
138 (make-port-request socket #:read (receive-http-conn handler)))
140 ;; Kinda junky since dynamic-wind and delimited continuations
141 ;; seem to not really get along...
143 (define-syntax-rule (with-socket-as make-socket socket-name
145 (let ((socket-name make-socket))
151 (close socket-name)))))
153 (define default-handler (wrap-apply hello-world-handler))
155 (define* (run-simple-webserver #:key
156 (handler default-handler)
158 (display "Running on http://127.0.0.1:8080/\n")
160 (http-server-socket) server-socket
162 (wrap (install-http-socket server-socket
166 #:pre-unwind-handler print-error-and-continue)))
168 (spawn-and-queue-repl-server! agenda))
169 (start-agenda agenda))))
171 (define* (make-web-demo-cli #:key
173 (handler default-handler))
175 (run-simple-webserver #:coop-repl listen
179 (define main (make-web-demo-cli))