[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-47-g19
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-47-g190fa72 |
|
Date: |
Fri, 12 Nov 2010 16:14:20 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=190fa72a8f7013b864c1e9196d54c8344e4d0a59
The branch, master has been updated
via 190fa72a8f7013b864c1e9196d54c8344e4d0a59 (commit)
via 347ba27e4bd7861e61e90b7b7eac6b892411ce8b (commit)
via 79ef79ee348401917e220170454b0d2c502060b9 (commit)
via d4b6200a0a2f18bdad6d6e9d54c5213748a3b34d (commit)
via 13b7e2a6e6c46cb4f3f0125ab5155b226664ff10 (commit)
via 67d655849aab96113e51bc1f6b1dadb033f0f8ce (commit)
via 4eb7c8f004843c0b2a8cacb7462d49d7f3c9264b (commit)
from f25e1b6713f06ddbe6d084e6ffb2e80e099d77f6 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 190fa72a8f7013b864c1e9196d54c8344e4d0a59
Author: Andy Wingo <address@hidden>
Date: Fri Nov 12 17:18:08 2010 +0100
NUL vs NULL fix
* libguile/read.c (scm_i_scan_for_encoding): Fix NUL rather than NULL.
commit 347ba27e4bd7861e61e90b7b7eac6b892411ce8b
Author: Andy Wingo <address@hidden>
Date: Fri Nov 12 12:16:26 2010 +0100
remove (web toy-server)
* module/Makefile.am
* module/web/toy-server.scm: Remove. It's not so much that the new (web
server) stuff is not a toy, it's that users are expected to use the
new backends (mod-lisp, etc) in "production".
commit 79ef79ee348401917e220170454b0d2c502060b9
Author: Andy Wingo <address@hidden>
Date: Fri Nov 12 12:07:24 2010 +0100
add generic web server with http-over-tcp backend
* module/web/server.scm: New generic web server module, with support for
different backends. An HTTP-over-TCP backend is the only one included
with Guile, though one can imagine FastCGI, mod-lisp, mongrel2/0mq etc
backends as well.
* module/web/server/http.scm: The aforementioned HTTP backend.
commit d4b6200a0a2f18bdad6d6e9d54c5213748a3b34d
Author: Andy Wingo <address@hidden>
Date: Fri Nov 12 12:12:34 2010 +0100
add request-meta
* module/web/request.scm (<request>): Add `meta' field and accessor, for
metadata like the server IP, the client IP, CGI environment variables,
etc.
(build-request): Add meta kwarg.
(read-request): Add meta optional arg.
(write-request): Adapt.
commit 13b7e2a6e6c46cb4f3f0125ab5155b226664ff10
Author: Andy Wingo <address@hidden>
Date: Fri Nov 12 12:10:44 2010 +0100
more (web http) exports for parsing request components
* module/web/http.scm (lookup-header-decl): New exported function.
(parse-http-version, parse-http-method, parse-request-uri): Export
these functions.
commit 67d655849aab96113e51bc1f6b1dadb033f0f8ce
Author: Andy Wingo <address@hidden>
Date: Fri Nov 12 12:08:54 2010 +0100
call-with-error-handling pass-keys w/ procedural handlers fix
* module/system/repl/error-handling.scm (call-with-error-handling):
Respect the pass-keys set for procedural on-error and post-error
handlers.
commit 4eb7c8f004843c0b2a8cacb7462d49d7f3c9264b
Author: Andy Wingo <address@hidden>
Date: Mon Nov 8 16:06:50 2010 +0100
unparse-uri avoids serializing e.g. :80 in http:// uris
* module/web/uri.scm (declare-default-port!): New function, declares a
default port for a scheme. Predeclare default ports for http and
https.
(unparse-uri): If the port is the default port for the given scheme,
don't serialize the port part of the URI.
-----------------------------------------------------------------------
Summary of changes:
libguile/read.c | 2 +-
module/Makefile.am | 3 +-
module/system/repl/error-handling.scm | 6 +-
module/web/http.scm | 20 ++-
module/web/request.scm | 18 ++-
module/web/server.scm | 242 +++++++++++++++++++++++++++++++++
module/web/server/http.scm | 123 +++++++++++++++++
module/web/toy-server.scm | 157 ---------------------
module/web/uri.scm | 19 ++-
9 files changed, 415 insertions(+), 175 deletions(-)
create mode 100644 module/web/server.scm
create mode 100644 module/web/server/http.scm
delete mode 100644 module/web/toy-server.scm
diff --git a/libguile/read.c b/libguile/read.c
index 07a4ffd..52ec20d 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -1646,7 +1646,7 @@ scm_i_scan_for_encoding (SCM port)
return NULL;
bytes_read = scm_c_read (port, header, SCM_ENCODING_SEARCH_SIZE);
- header[bytes_read] = NULL;
+ header[bytes_read] = '\0';
scm_seek (port, scm_from_int (0), scm_from_int (SEEK_SET));
diff --git a/module/Makefile.am b/module/Makefile.am
index f17e225..d2a44b8 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -352,7 +352,8 @@ WEB_SOURCES = \
web/http.scm \
web/request.scm \
web/response.scm \
- web/toy-server.scm \
+ web/server.scm \
+ web/server/http.scm \
web/uri.scm
EXTRA_DIST += oop/ChangeLog-2008
diff --git a/module/system/repl/error-handling.scm
b/module/system/repl/error-handling.scm
index 737eadf..7d30bf0 100644
--- a/module/system/repl/error-handling.scm
+++ b/module/system/repl/error-handling.scm
@@ -125,7 +125,8 @@
(apply throw key args))))
(else
(if (procedure? post-error)
- post-error ; a handler proc
+ (lambda (k . args)
+ (apply (if (memq k pass-keys) throw post-error) k args))
(error "Unknown post-error strategy" post-error))))
(case on-error
@@ -158,7 +159,8 @@
#t))
(else
(if (procedure? on-error)
- on-error ; pre-unwind handler
+ (lambda (k . args)
+ (apply (if (memq k pass-keys) throw on-error) k args))
(error "Unknown on-error strategy" on-error)))))))
(define-syntax with-error-handling
diff --git a/module/web/http.scm b/module/web/http.scm
index 6d06a35..5245cca 100644
--- a/module/web/http.scm
+++ b/module/web/http.scm
@@ -34,6 +34,7 @@
header-decl-parser
header-decl-validator
header-decl-writer
+ lookup-header-decl
declare-header!
read-header
@@ -44,6 +45,10 @@
read-headers
write-headers
+ parse-http-method
+ parse-http-version
+ parse-request-uri
+
read-request-line
write-request-line
read-response-line
@@ -122,6 +127,11 @@
port
(string-trim-both line char-whitespace? (1+ delim))))))))
+(define (lookup-header-decl name)
+ (if (string? name)
+ (hash-ref *declared-headers-by-name* (string-downcase name))
+ (hashq-ref *declared-headers* name)))
+
(define (parse-header name val)
(let* ((down (string-downcase name))
(decl (hash-ref *declared-headers-by-name* down)))
@@ -605,7 +615,7 @@
(define *known-versions* '())
-(define (parse-http-version str start end)
+(define* (parse-http-version str #:optional (start 0) (end (string-length
str)))
(or (let lp ((known *known-versions*))
(and (pair? known)
(if (string= str (caar known) start end)
@@ -639,7 +649,7 @@
;; because we don't expect people to implement CONNECT, we save
;; ourselves the trouble of that case, and disallow the CONNECT method.
;;
-(define (parse-method str start end)
+(define* (parse-http-method str #:optional (start 0) (end (string-length str)))
(cond
((string= str "GET" start end) 'GET)
((string= str "HEAD" start end) 'HEAD)
@@ -650,7 +660,7 @@
((string= str "TRACE" start end) 'TRACE)
(else (bad-request "Invalid method: ~a" (substring str start end)))))
-(define (parse-uri-path str start end)
+(define* (parse-request-uri str #:optional (start 0) (end (string-length str)))
(cond
((= start end)
(bad-request "Missing Request-URI"))
@@ -673,8 +683,8 @@
(d0 (string-index line char-whitespace?)) ; "delimiter zero"
(d1 (string-rindex line char-whitespace?)))
(if (and d0 d1 (< d0 d1))
- (values (parse-method line 0 d0)
- (parse-uri-path line (skip-whitespace line (1+ d0) d1) d1)
+ (values (parse-http-method line 0 d0)
+ (parse-request-uri line (skip-whitespace line (1+ d0) d1) d1)
(parse-http-version line (1+ d1) (string-length line)))
(bad-request "Bad Request-Line: ~s" line))))
diff --git a/module/web/request.scm b/module/web/request.scm
index 8e29589..78cf0ee 100644
--- a/module/web/request.scm
+++ b/module/web/request.scm
@@ -31,6 +31,7 @@
request-uri
request-version
request-headers
+ request-meta
request-port
read-request
@@ -121,12 +122,13 @@
;;;
(define-record-type <request>
- (make-request method uri version headers port)
+ (make-request method uri version headers meta port)
request?
(method request-method)
(uri request-uri)
(version request-version)
(headers request-headers)
+ (meta request-meta)
(port request-port))
(define (bad-request message . args)
@@ -152,7 +154,8 @@
(bad-request "Headers not a list: ~a" headers))))
(define* (build-request #:key (method 'GET) uri (version '(1 . 1))
- (headers '()) port (validate-headers? #t))
+ (headers '()) port (meta '())
+ (validate-headers? #t))
(cond
((not (and (pair? version)
(non-negative-integer? (car version))
@@ -162,17 +165,20 @@
(bad-request "Bad uri: ~a" uri))
((and (not port) (memq method '(POST PUT)))
(bad-request "Missing port for message ~a" method))
+ ((not (list? meta))
+ (bad-request "Bad metadata alist" meta))
(else
(if validate-headers?
(validate-headers headers))))
- (make-request method uri version headers port))
+ (make-request method uri version headers meta port))
-(define (read-request port)
+(define* (read-request port #:optional (meta '()))
(set-port-encoding! port "ISO-8859-1")
(call-with-values (lambda () (read-request-line port))
(lambda (method uri version)
- (make-request method uri version (read-headers port) port))))
+ (make-request method uri version (read-headers port) meta port))))
+;; FIXME: really return a new request?
(define (write-request r port)
(write-request-line (request-method r) (request-uri r)
(request-version r) port)
@@ -181,7 +187,7 @@
(if (eq? port (request-port r))
r
(make-request (request-method r) (request-uri r) (request-version r)
- (request-headers r) port)))
+ (request-headers r) (request-meta r) port)))
;; Probably not what you want to use "in production". Relies on one byte
;; per char because we are in latin-1 encoding.
diff --git a/module/web/server.scm b/module/web/server.scm
new file mode 100644
index 0000000..2e7ad0c
--- /dev/null
+++ b/module/web/server.scm
@@ -0,0 +1,242 @@
+;;; Web server
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;; 02110-1301 USA
+
+;;; Commentary:
+;;;
+;;; (web server) is a generic web server interface, along with a main
+;;; loop implementation for web servers controlled by Guile.
+;;;
+;;; The lowest layer is the <server-impl> object, which defines a set of
+;;; hooks to open a server, read a request from a client, write a
+;;; response to a client, and close a server. These hooks -- open,
+;;; read, write, and close, respectively -- are bound together in a
+;;; <server-impl> object. Procedures in this module take a
+;;; <server-impl> object, if needed.
+;;;
+;;; A <server-impl> may also be looked up by name. If you pass the
+;;; `http' symbol to `run-server', Guile looks for a variable named
+;;; `http' in the `(web server http)' module, which should be bound to a
+;;; <server-impl> object. Such a binding is made by instantiation of
+;;; the `define-server-impl' syntax. In this way the run-server loop can
+;;; automatically load other backends if available.
+;;;
+;;; The life cycle of a server goes as follows:
+;;;
+;;; * The `open' hook is called, to open the server. `open' takes 0 or
+;;; more arguments, depending on the backend, and returns an opaque
+;;; server socket object, or signals an error.
+;;;
+;;; * The `read' hook is called, to read a request from a new client.
+;;; The `read' hook takes two arguments: the server socket, and a
+;;; list of keep-alive clients. It should return four values: the
+;;; new list of keep-alive clients, an opaque client socket, the
+;;; request, and the request body. The request should be a
+;;; `<request>' object, from `(web request)'. The body should be a
+;;; string or a bytevector, or `#f' if there is no body.
+;;;
+;;; The keep-alive list is used when selecting a new request. You
+;;; can either serve an old client or serve a new client; and some
+;;; old clients might close their connections while you are waiting.
+;;; The `read' hook returns a new keep-alive set to account for old
+;;; clients going away, and for read errors on old clients.
+;;;
+;;; If the read failed, the `read' hook may return #f for the client
+;;; socket, request, and body.
+;;;
+;;; * A user-provided handler procedure is called, with the request
+;;; and body as its arguments. The handler should return two
+;;; values: the response, as a `<response>' record from `(web
+;;; response)', and the response body as a string, bytevector, or
+;;; `#f' if not present. We also allow the reponse to be simply an
+;;; alist of headers, in which case a default response object is
+;;; constructed with those headers.
+;;;
+;;; * The `write' hook is called with three arguments: the client
+;;; socket, the response, and the body. The `write' hook may return
+;;; #f to indicate that the connection was closed. If `write'
+;;; returns a true value, it will be consed onto the keep-alive
+;;; list.
+;;;
+;;; * At this point the request handling is complete. For a loop, we
+;;; loop back with the new keep-alive list, and try to read a new
+;;; request.
+;;;
+;;; * If the user interrupts the loop, the `close' hook is called on
+;;; the server socket.
+;;;
+;;; Code:
+
+(define-module (web server)
+ #:use-module (srfi srfi-9)
+ #:use-module (rnrs bytevectors)
+ #:use-module (web request)
+ #:use-module (web response)
+ #:use-module (system repl error-handling)
+ #:use-module (ice-9 control)
+ #:export (define-server-impl
+ lookup-server-impl
+ open-server
+ read-client
+ handle-request
+ sanitize-response
+ write-client
+ close-server
+ serve-one-client
+ run-server))
+
+(define-record-type server-impl
+ (make-server-impl name open read write close)
+ server-impl?
+ (name server-impl-name)
+ (open server-impl-open)
+ (read server-impl-read)
+ (write server-impl-write)
+ (close server-impl-close))
+
+(define-syntax define-server-impl
+ (syntax-rules ()
+ ((_ name open read write close)
+ (define name
+ (make-server-impl 'name open read write close)))))
+
+(define (lookup-server-impl impl)
+ (cond
+ ((server-impl? impl) impl)
+ ((symbol? impl)
+ (let ((impl (module-ref (resolve-module `(web server ,impl)) impl)))
+ (if (server-impl? impl)
+ impl
+ (error "expected a server impl in module" `(web server ,impl)))))
+ (else
+ (error "expected a server-impl or a symbol" impl))))
+
+;; -> server
+(define (open-server impl open-params)
+ (apply (server-impl-open impl) open-params))
+
+;; -> (keep-alive client request body | keep-alive #f #f #f)
+(define (read-client impl server keep-alive)
+ (call-with-error-handling
+ (lambda ()
+ ((server-impl-read impl) server keep-alive))
+ #:pass-keys '(quit interrupt)
+ #:on-error (if (batch-mode?) 'pass 'debug)
+ #:post-error
+ (lambda (k . args)
+ (warn "Error while accepting client" k args)
+ (values keep-alive #f #f #f #f))))
+
+;; -> response body state ...
+(define (handle-request handler request body . state)
+ (call-with-error-handling
+ (lambda ()
+ (with-stack-and-prompt
+ (lambda ()
+ (apply handler request body state))))
+ #:pass-keys '(quit interrupt)
+ #:on-error (if (batch-mode?) 'pass 'debug)
+ #:post-error
+ (lambda (k . args)
+ (warn "Error handling request" k args)
+ (apply values (build-response #:code 500) #f state))))
+
+;; -> response body
+(define (sanitize-response request response body)
+ (values response body))
+
+;; -> (#f | client)
+(define (write-client impl server client response body)
+ (call-with-error-handling
+ (lambda ()
+ ((server-impl-write impl) server client response body))
+ #:pass-keys '(quit interrupt)
+ #:on-error (if (batch-mode?) 'pass 'debug)
+ #:post-error
+ (lambda (k . args)
+ (warn "Error while writing response" k args)
+ #f)))
+
+;; -> unspecified values
+(define (close-server impl server)
+ ((server-impl-close impl) server))
+
+(define call-with-sigint
+ (if (not (provided? 'posix))
+ (lambda (thunk handler-thunk) (thunk))
+ (lambda (thunk handler-thunk)
+ (let ((handler #f))
+ (catch 'interrupt
+ (lambda ()
+ (dynamic-wind
+ (lambda ()
+ (set! handler
+ (sigaction SIGINT (lambda (sig) (throw 'interrupt)))))
+ thunk
+ (lambda ()
+ (if handler
+ ;; restore Scheme handler, SIG_IGN or SIG_DFL.
+ (sigaction SIGINT (car handler) (cdr handler))
+ ;; restore original C handler.
+ (sigaction SIGINT #f)))))
+ (lambda (k . _) (handler-thunk)))))))
+
+(define (with-stack-and-prompt thunk)
+ (call-with-prompt (default-prompt-tag)
+ (lambda () (start-stack #t (thunk)))
+ (lambda (k proc)
+ (with-stack-and-prompt (lambda () (proc k))))))
+
+(define (and-cons x xs)
+ (if x (cons x xs) xs))
+
+;; -> new keep-alive new-state
+(define (serve-one-client handler impl server keep-alive state)
+ (call-with-values
+ (lambda ()
+ (read-client impl server keep-alive))
+ (lambda (keep-alive client request body)
+ (if client
+ (call-with-values
+ (lambda ()
+ (apply handle-request handler request body state))
+ (lambda (response body . state)
+ (call-with-values (lambda ()
+ (sanitize-response request response body))
+ (lambda (response body)
+ (values
+ (and-cons (write-client impl server client response body)
+ keep-alive)
+ state)))))
+ (values keep-alive state)))))
+
+(define* (run-server handler #:optional (impl 'http) (open-params '())
+ . state)
+ (let* ((impl (lookup-server-impl impl))
+ (server (open-server impl open-params)))
+ (call-with-sigint
+ (lambda ()
+ (let lp ((keep-alive '()) (state state))
+ (call-with-values
+ (lambda ()
+ (serve-one-client handler impl server keep-alive state))
+ (lambda (new-keep-alive new-state)
+ (lp new-keep-alive new-state)))))
+ (lambda ()
+ (close-server impl server)
+ (values)))))
diff --git a/module/web/server/http.scm b/module/web/server/http.scm
new file mode 100644
index 0000000..373017e
--- /dev/null
+++ b/module/web/server/http.scm
@@ -0,0 +1,123 @@
+;;; Web I/O: HTTP
+
+;; Copyright (C) 2010 Free Software Foundation, Inc.
+
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;; 02110-1301 USA
+
+;;; Code:
+
+(define-module (web server http)
+ #:use-module ((srfi srfi-1) #:select (fold))
+ #:use-module (rnrs bytevectors)
+ #:use-module (web request)
+ #:use-module (web response)
+ #:use-module (web server)
+ #:use-module (system repl error-handling))
+
+
+(define (make-default-socket family addr port)
+ (let ((sock (socket PF_INET SOCK_STREAM 0)))
+ (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+ (bind sock family addr port)
+ sock))
+
+;; -> server
+(define* (http-open #:key
+ (host #f)
+ (family AF_INET)
+ (addr (if host
+ (inet-pton family host)
+ INADDR_LOOPBACK))
+ (port 8080)
+ (socket (make-default-socket family addr port)))
+ (listen socket 5)
+ socket)
+
+;; -> (keep-alive client request body | keep-alive #f #f #f)
+(define (http-read server keep-alive)
+ (call-with-values (lambda ()
+ (let ((ports (cons server keep-alive)))
+ (apply values (select ports '() ports))))
+ (lambda (readable writable except)
+ (cond
+ ((pair? except)
+ (values (fold (lambda (p keep-alive)
+ (close-port p)
+ (if (eq? p server)
+ (throw 'interrupt)
+ (delq p keep-alive)))
+ keep-alive
+ except)
+ #f #f #f))
+ ((memq server readable)
+ ;; FIXME: meta to read-request
+ (let* ((client (accept server))
+ (req (read-request (car client)))
+ (body-str (read-request-body/latin-1 req)))
+ (values keep-alive (car client) req body-str)))
+ ((pair? readable)
+ ;; FIXME: preserve meta for keep-alive
+ (let* ((p (car readable))
+ (keep-alive (delq p keep-alive)))
+ (if (eof-object? (peek-char p))
+ (begin
+ (close-port p)
+ (values keep-alive #f #f #f))
+ (call-with-error-handling
+ (lambda ()
+ (let* ((req (read-request p))
+ (body-str (read-request-body/latin-1 req)))
+ (values keep-alive p req body-str)))
+ #:pass-keys '(quit interrupt)
+ #:on-error (if (batch-mode?) 'pass 'debug)
+ #:post-error
+ (lambda (k . args)
+ (warn "Error while reading request" k args)
+ (values keep-alive #f #f #f #f))))))
+ (else
+ (values keep-alive #f #f #f))))))
+
+(define (keep-alive? response)
+ #t)
+
+;; -> (#f | client)
+(define (http-write server client response body)
+ (let ((response (write-response response client)))
+ (cond
+ ((not body)) ; pass
+ ((string? body)
+ (write-response-body/latin-1 response body))
+ ((bytevector? body)
+ (write-response-body/bytevector response body))
+ (else
+ (error "Expected a string or bytevector for body" body)))
+ (force-output (response-port response))
+ (if (keep-alive? response)
+ (response-port response)
+ (begin
+ (close-port (response-port response))
+ #f))))
+
+;; -> unspecified values
+(define (http-close server)
+ (shutdown server 2)
+ (close-port server))
+
+(define-server-impl http
+ http-open
+ http-read
+ http-write
+ http-close)
diff --git a/module/web/toy-server.scm b/module/web/toy-server.scm
deleted file mode 100644
index bf182fe..0000000
--- a/module/web/toy-server.scm
+++ /dev/null
@@ -1,157 +0,0 @@
-;;; Toy web server
-
-;; Copyright (C) 2010 Free Software Foundation, Inc.
-
-;; This library is free software; you can redistribute it and/or
-;; modify it under the terms of the GNU Lesser General Public
-;; License as published by the Free Software Foundation; either
-;; version 3 of the License, or (at your option) any later version.
-;;
-;; This library is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;; Lesser General Public License for more details.
-;;
-;; You should have received a copy of the GNU Lesser General Public
-;; License along with this library; if not, write to the Free Software
-;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
-;; 02110-1301 USA
-
-;;; Code:
-
-(define-module (web toy-server)
- #:use-module (rnrs bytevectors)
- #:use-module (web request)
- #:use-module (web response)
- #:use-module (system repl error-handling)
- #:use-module (ice-9 control)
- #:export (run-server simple-get-handler))
-
-(define (make-default-socket family addr port)
- (let ((sock (socket PF_INET SOCK_STREAM 0)))
- (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
- (bind sock family addr port)
- sock))
-
-(define call-with-sigint
- (if (not (provided? 'posix))
- (lambda (thunk) (thunk))
- (lambda (thunk)
- (let ((handler #f))
- (dynamic-wind
- (lambda ()
- (set! handler
- (sigaction SIGINT (lambda (sig) (throw 'interrupt)))))
- thunk
- (lambda ()
- (if handler
- ;; restore Scheme handler, SIG_IGN or SIG_DFL.
- (sigaction SIGINT (car handler) (cdr handler))
- ;; restore original C handler.
- (sigaction SIGINT #f))))))))
-
-(define (accept-new-client server-socket)
- (catch #t
- (lambda () (call-with-sigint (lambda () (accept server-socket))))
- (lambda (k . args)
- (cond
- ((port-closed? server-socket)
- ;; Shutting down.
- #f)
- ((eq? k 'interrupt)
- ;; Interrupt.
- (close-port server-socket)
- #f)
- (else
- (warn "Error accepting client" k args)
- ;; Retry after a timeout.
- (sleep 1)
- (accept-new-client server-socket))))))
-
-(define* (simple-get-handler handler #:optional (content-type '("text"
"plain")))
- (lambda (request request-body)
- (if (eq? (request-method request) 'GET)
- (let* ((x (handler (request-absolute-uri request)))
- (bv (cond ((bytevector? x) x)
- ((string? x) (string->utf8 x))
- (else
- (error "unexpected val from simple get handler"
x)))))
- (values (build-response
- #:headers `((content-type . ,content-type)
- (content-length . ,(bytevector-length bv))))
- bv))
- (build-response #:code 405))))
-
-(define (with-stack-and-prompt thunk)
- (call-with-prompt (default-prompt-tag)
- (lambda () (start-stack #t (thunk)))
- (lambda (k proc)
- (with-stack-and-prompt (lambda () (proc k))))))
-
-(define (serve-client handler sock addr)
- (define *on-toy-server-error* (if (batch-mode?) 'pass 'debug))
- (define *on-handler-error* (if (batch-mode?) 'pass 'debug))
-
- (call-with-values
- (lambda ()
- (call-with-error-handling
- (lambda ()
- (let* ((req (read-request sock))
- (body-str (read-request-body/latin-1 req)))
- (call-with-error-handling
- (lambda ()
- (with-stack-and-prompt
- (lambda ()
- (handler req body-str))))
- #:pass-keys '(quit interrupt)
- #:on-error *on-handler-error*
- #:post-error
- (lambda (k . args)
- (warn "Error while serving client" k args)
- (build-response #:code 500)))))
- #:pass-keys '(quit interrupt)
- #:on-error *on-toy-server-error*
- #:post-error
- (lambda (k . args)
- (warn "Error reading request" k args)
- (build-response #:code 400))))
- (lambda* (response #:optional body)
- (call-with-error-handling
- (lambda ()
- (let ((response (write-response response sock)))
- (cond
- ((not body)) ; pass
- ((string? body)
- (write-response-body/latin-1 response body))
- ((bytevector? body)
- (write-response-body/bytevector response body))
- (else
- (error "Expected a string or bytevector for body" body)))))
- #:on-error *on-toy-server-error*
- #:pass-keys '(quit interrupt))))
- (close-port sock)) ; FIXME: keep socket alive. requires select?
-
-(define* (run-server handler
- #:key
- (host #f)
- (family AF_INET)
- (addr (if host
- (inet-pton family host)
- INADDR_LOOPBACK))
- (port 8080)
- (server-socket (make-default-socket family addr port)))
- (listen server-socket 5)
- (let lp ((client (accept-new-client server-socket)))
- ;; If client is false, we are shutting down.
- (if client
- (let ((client-socket (car client))
- (client-addr (cdr client)))
- (catch 'interrupt
- (lambda ()
- (call-with-sigint
- (lambda ()
- (serve-client handler client-socket client-addr))))
- (lambda (k . args)
- (warn "Interrupt while serving client")
- (close-port client-socket)))
- (lp (accept-new-client server-socket))))))
diff --git a/module/web/uri.scm b/module/web/uri.scm
index 519c691..6ea3219 100644
--- a/module/web/uri.scm
+++ b/module/web/uri.scm
@@ -29,6 +29,7 @@
uri-path uri-query uri-fragment
build-uri
+ declare-default-port!
parse-uri unparse-uri
uri-decode uri-encode
split-and-decode-uri-path
@@ -174,6 +175,18 @@
(lambda (k)
#f)))
+(define *default-ports* (make-hash-table))
+
+(define (declare-default-port! scheme port)
+ (hashq-set! *default-ports* scheme port))
+
+(define (default-port? scheme port)
+ (or (not port)
+ (eqv? port (hashq-ref *default-ports* scheme))))
+
+(declare-default-port! 'http 80)
+(declare-default-port! 'https 443)
+
(define (unparse-uri uri)
(let* ((scheme-str (string-append
(symbol->string (uri-scheme uri)) ":"))
@@ -190,9 +203,9 @@
(if userinfo (string-append userinfo "@")
"")
host
- (if port
- (string-append ":" (number->string port))
- ""))
+ (if (default-port? (uri-scheme uri) port)
+ ""
+ (string-append ":" (number->string port))))
"")
path
(if query
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-13-47-g190fa72,
Andy Wingo <=