[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-28-ge4
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-13-28-ge414bf2 |
|
Date: |
Thu, 04 Nov 2010 23:31: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=e414bf2178bc2144d0bbe5948f8f858ad656e192
The branch, master has been updated
via e414bf2178bc2144d0bbe5948f8f858ad656e192 (commit)
via a9eeb2f4615564a2ae9f1a1fe7477fbc79d3f976 (commit)
via ad05d4e8c6ccd17a826af3a4df38f055eb3fc9b9 (commit)
via 440840c113c744082b7892315049a4704517215a (commit)
via 5a2f7fb3156bbcba5ee5ac818526bf40ed43cfe1 (commit)
from b215e5b2439a9fbb8189a7b4028c68273b46c4df (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 e414bf2178bc2144d0bbe5948f8f858ad656e192
Author: Andy Wingo <address@hidden>
Date: Fri Oct 22 01:07:27 2010 +0200
add toy web server
* module/web/toy-server.scm: New module, a toy web server.
* module/Makefile.am: Adapt.
commit a9eeb2f4615564a2ae9f1a1fe7477fbc79d3f976
Author: Andy Wingo <address@hidden>
Date: Fri Oct 22 01:06:54 2010 +0200
add HTTP response module
* module/web/response.scm: New module, for HTTP responses.
* test-suite/tests/web-response.test: Test suite.
* module/Makefile.am:
* test-suite/Makefile.am: Adapt.
commit ad05d4e8c6ccd17a826af3a4df38f055eb3fc9b9
Author: Andy Wingo <address@hidden>
Date: Fri Oct 22 00:06:32 2010 +0200
add HTTP request module
* module/web/request.scm: Add HTTP request module.
* test-suite/tests/web-request.test: Test cases.
* module/Makefile.am:
* test-suite/Makefile.am: Adapt.
commit 440840c113c744082b7892315049a4704517215a
Author: Andy Wingo <address@hidden>
Date: Sun Oct 24 12:36:17 2010 +0200
add HTTP module
* module/web/http.scm: New module, declares known HTTP headers, and
their parsers and unparsers.
* test-suite/tests/web-http.test: Add test suite.
* module/Makefile.am:
* test-suite/Makefile.am: Adapt.
commit 5a2f7fb3156bbcba5ee5ac818526bf40ed43cfe1
Author: Andy Wingo <address@hidden>
Date: Sat Oct 23 15:23:42 2010 +0200
URI parsing errors throw to `uri-error'
* module/web/uri.scm (uri-error): New proc, throws to 'uri-error.
(validate-uri, uri-decode, uri-encode): Use uri-error.
* test-suite/tests/web-uri.test: Update for uri-error.
-----------------------------------------------------------------------
Summary of changes:
module/Makefile.am | 4 +
module/web/http.scm | 1464 ++++++++++++++++++++++++++++++++++++
module/web/request.scm | 294 ++++++++
module/web/response.scm | 242 ++++++
module/web/toy-server.scm | 137 ++++
module/web/uri.scm | 24 +-
test-suite/Makefile.am | 3 +
test-suite/tests/web-http.test | 202 +++++
test-suite/tests/web-request.test | 84 ++
test-suite/tests/web-response.test | 99 +++
test-suite/tests/web-uri.test | 48 +-
11 files changed, 2572 insertions(+), 29 deletions(-)
create mode 100644 module/web/http.scm
create mode 100644 module/web/request.scm
create mode 100644 module/web/response.scm
create mode 100644 module/web/toy-server.scm
create mode 100644 test-suite/tests/web-http.test
create mode 100644 test-suite/tests/web-request.test
create mode 100644 test-suite/tests/web-response.test
diff --git a/module/Makefile.am b/module/Makefile.am
index b86123f..f17e225 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -349,6 +349,10 @@ LIB_SOURCES = \
texinfo/serialize.scm
WEB_SOURCES = \
+ web/http.scm \
+ web/request.scm \
+ web/response.scm \
+ web/toy-server.scm \
web/uri.scm
EXTRA_DIST += oop/ChangeLog-2008
diff --git a/module/web/http.scm b/module/web/http.scm
new file mode 100644
index 0000000..6d06a35
--- /dev/null
+++ b/module/web/http.scm
@@ -0,0 +1,1464 @@
+;;; HTTP messages
+
+;; 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 http)
+ #:use-module ((srfi srfi-1) #:select (append-map! map!))
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-19)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 rdelim)
+ #:use-module (web uri)
+ #:export (header-decl?
+ make-header-decl
+ header-decl-sym
+ header-decl-name
+ header-decl-multiple?
+ header-decl-parser
+ header-decl-validator
+ header-decl-writer
+ declare-header!
+
+ read-header
+ parse-header
+ valid-header?
+ write-header
+
+ read-headers
+ write-headers
+
+ read-request-line
+ write-request-line
+ read-response-line
+ write-response-line))
+
+
+;;; TODO
+;;;
+;;; Look at quality lists with more insight.
+;;; Think about `accept' a bit more.
+;;;
+
+
+(define-record-type <header-decl>
+ (make-header-decl sym name multiple? parser validator writer)
+ header-decl?
+ (sym header-decl-sym)
+ (name header-decl-name)
+ (multiple? header-decl-multiple?)
+ (parser header-decl-parser)
+ (validator header-decl-validator)
+ (writer header-decl-writer))
+
+;; sym -> header
+(define *declared-headers* (make-hash-table))
+;; downcased name -> header
+(define *declared-headers-by-name* (make-hash-table))
+
+(define* (declare-header! sym name #:key
+ multiple?
+ parser
+ validator
+ writer)
+ (if (and (symbol? sym) (string? name) parser validator writer)
+ (let ((decl (make-header-decl sym name
+ multiple? parser validator writer)))
+ (hashq-set! *declared-headers* sym decl)
+ (hash-set! *declared-headers-by-name* (string-downcase name) decl)
+ decl)
+ (error "bad header decl" sym name multiple? parser validator writer)))
+
+(define (read-line* port)
+ (let* ((pair (%read-line port))
+ (line (car pair))
+ (delim (cdr pair)))
+ (if (and (string? line) (char? delim))
+ (let ((orig-len (string-length line)))
+ (let lp ((len orig-len))
+ (if (and (> len 0)
+ (char-whitespace? (string-ref line (1- len))))
+ (lp (1- len))
+ (if (= len orig-len)
+ line
+ (substring line 0 len)))))
+ (bad-header '%read line))))
+
+(define (read-continuation-line port val)
+ (if (or (eqv? (peek-char port) #\space)
+ (eqv? (peek-char port) #\tab))
+ (read-continuation-line port
+ (string-append val
+ (begin
+ (read-line* port))))
+ val))
+
+(define (read-header port)
+ (let ((line (read-line* port)))
+ (if (or (string-null? line)
+ (string=? line "\r"))
+ (values #f #f)
+ (let ((delim (or (string-index line #\:)
+ (bad-header '%read line))))
+ (parse-header
+ (substring line 0 delim)
+ (read-continuation-line
+ port
+ (string-trim-both line char-whitespace? (1+ delim))))))))
+
+(define (parse-header name val)
+ (let* ((down (string-downcase name))
+ (decl (hash-ref *declared-headers-by-name* down)))
+ (if decl
+ (values (header-decl-sym decl)
+ ((header-decl-parser decl) val))
+ (values down val))))
+
+(define (valid-header? sym val)
+ (let ((decl (hashq-ref *declared-headers* sym)))
+ (if (not decl)
+ (error "Unknown header" sym)
+ ((header-decl-validator decl) val))))
+
+(define (write-header name val port)
+ (if (string? name)
+ ;; assume that it's a header we don't know about...
+ (begin
+ (display name port)
+ (display ": " port)
+ (display val port)
+ (display "\r\n" port))
+ (let ((decl (hashq-ref *declared-headers* name)))
+ (if (not decl)
+ (error "Unknown header" name)
+ (begin
+ (display (header-decl-name decl) port)
+ (display ": " port)
+ ((header-decl-writer decl) val port)
+ (display "\r\n" port))))))
+
+(define (read-headers port)
+ (let lp ((headers '()))
+ (call-with-values (lambda () (read-header port))
+ (lambda (k v)
+ (if k
+ (lp (acons k v headers))
+ (reverse! headers))))))
+
+;; Doesn't write the final \r\n, as the user might want to add another
+;; header.
+(define (write-headers headers port)
+ (let lp ((headers headers))
+ (if (pair? headers)
+ (begin
+ (write-header (caar headers) (cdar headers) port)
+ (lp (cdr headers))))))
+
+
+
+
+;;;
+;;; Utilities
+;;;
+
+(define (bad-header sym val)
+ (throw 'bad-header sym val))
+(define (bad-header-component sym val)
+ (throw 'bad-header sym val))
+
+(define (parse-opaque-string str)
+ str)
+(define (validate-opaque-string val)
+ (string? val))
+(define (write-opaque-string val port)
+ (display val port))
+
+(define not-separator
+ "[^][()<>@,;:\\\"/?= \t]")
+(define media-type-re
+ (make-regexp (format #f "^(~a+)/(~a+)$" not-separator not-separator)))
+(define (parse-media-type str)
+ (let ((m (regexp-exec media-type-re str)))
+ (if m
+ (values (match:substring m 1) (match:substring m 2))
+ (bad-header-component 'media-type str))))
+
+(define* (skip-whitespace str #:optional (start 0) (end (string-length str)))
+ (let lp ((i start))
+ (if (and (< i end) (char-whitespace? (string-ref str i)))
+ (lp (1+ i))
+ i)))
+
+(define* (trim-whitespace str #:optional (start 0) (end (string-length str)))
+ (let lp ((i end))
+ (if (and (< start i) (char-whitespace? (string-ref str (1- i))))
+ (lp (1- i))
+ i)))
+
+(define* (split-and-trim str #:optional (delim #\,)
+ (start 0) (end (string-length str)))
+ (let lp ((i start))
+ (if (< i end)
+ (let* ((idx (string-index str delim i end))
+ (tok (string-trim-both str char-whitespace? i (or idx end))))
+ (cons tok (split-and-trim str delim (if idx (1+ idx) end) end)))
+ '())))
+
+(define (collect-escaped-string from start len escapes)
+ (let ((to (make-string len)))
+ (let lp ((start start) (i 0) (escapes escapes))
+ (if (null? escapes)
+ (begin
+ (substring-move! from start (+ start (- len i)) to i)
+ to)
+ (let* ((e (car escapes))
+ (next-start (+ start (- e i) 2)))
+ (substring-move! from start (- next-start 2) to i)
+ (string-set! to e (string-ref from (- next-start 1)))
+ (lp next-start (1+ e) (cdr escapes)))))))
+
+;; in incremental mode, returns two values: the string, and the index at
+;; which the string ended
+(define* (parse-qstring str #:optional
+ (start 0) (end (trim-whitespace str start))
+ #:key incremental?)
+ (if (and (< start end) (eqv? (string-ref str start) #\"))
+ (let lp ((i (1+ start)) (qi 0) (escapes '()))
+ (if (< i end)
+ (case (string-ref str i)
+ ((#\\)
+ (lp (+ i 2) (1+ qi) (cons qi escapes)))
+ ((#\")
+ (let ((out (collect-escaped-string str (1+ start) qi escapes)))
+ (if incremental?
+ (values out (1+ i))
+ (if (= (1+ i) end)
+ out
+ (bad-header-component 'qstring str)))))
+ (else
+ (lp (1+ i) (1+ qi) escapes)))
+ (bad-header-component 'qstring str)))
+ (bad-header-component 'qstring str)))
+
+(define (write-list l port write-item delim)
+ (if (pair? l)
+ (let lp ((l l))
+ (write-item (car l) port)
+ (if (pair? (cdr l))
+ (begin
+ (display delim port)
+ (lp (cdr l)))))))
+
+(define (write-qstring str port)
+ (display #\" port)
+ (if (string-index str #\")
+ ;; optimize me
+ (write-list (string-split str #\") port display "\\\"")
+ (display str port))
+ (display #\" port))
+
+(define* (parse-quality str #:optional (start 0) (end (string-length str)))
+ (define (char->decimal c)
+ (let ((i (- (char->integer c) (char->integer #\0))))
+ (if (and (<= 0 i) (< i 10))
+ i
+ (bad-header-component 'quality str))))
+ (cond
+ ((not (< start end))
+ (bad-header-component 'quality str))
+ ((eqv? (string-ref str start) #\1)
+ (if (or (string= str "1" start end)
+ (string= str "1." start end)
+ (string= str "1.0" start end)
+ (string= str "1.00" start end)
+ (string= str "1.000" start end))
+ 1000
+ (bad-header-component 'quality str)))
+ ((eqv? (string-ref str start) #\0)
+ (if (or (string= str "0" start end)
+ (string= str "0." start end))
+ 0
+ (if (< 2 (- end start) 6)
+ (let lp ((place 1) (i (+ start 4)) (q 0))
+ (if (= i (1+ start))
+ (if (eqv? (string-ref str (1+ start)) #\.)
+ q
+ (bad-header-component 'quality str))
+ (lp (* 10 place) (1- i)
+ (if (< i end)
+ (+ q (* place (char->decimal (string-ref str i))))
+ q))))
+ (bad-header-component 'quality str))))
+ (else
+ (bad-header-component 'quality str))))
+
+(define (valid-quality? q)
+ (and (non-negative-integer? q) (<= 1000 q)))
+
+(define (write-quality q port)
+ (define (digit->char d)
+ (integer->char (+ (char->integer #\0) d)))
+ (display (digit->char (modulo (quotient q 1000) 10)) port)
+ (display #\. port)
+ (display (digit->char (modulo (quotient q 100) 10)) port)
+ (display (digit->char (modulo (quotient q 10) 10)) port)
+ (display (digit->char (modulo q 10)) port))
+
+(define (list-of? val pred)
+ (or (null? val)
+ (and (pair? val)
+ (pred (car val))
+ (list-of? (cdr val) pred))))
+
+(define* (parse-quality-list str)
+ (map (lambda (part)
+ (cond
+ ((string-rindex part #\;)
+ => (lambda (idx)
+ (let ((qpart (string-trim-both part char-whitespace? (1+
idx))))
+ (if (string-prefix? "q=" qpart)
+ (cons (parse-quality qpart 2)
+ (string-trim-both part char-whitespace? 0 idx))
+ (bad-header-component 'quality qpart)))))
+ (else
+ (cons 1000 (string-trim-both part char-whitespace?)))))
+ (string-split str #\,)))
+
+(define (validate-quality-list l)
+ (list-of? l
+ (lambda (elt)
+ (and (pair? elt)
+ (valid-quality? (car elt))
+ (string? (cdr elt))))))
+
+(define (write-quality-list l port)
+ (write-list l port
+ (lambda (x port)
+ (let ((q (car x))
+ (str (cdr x)))
+ (display str port)
+ (if (< q 1000)
+ (begin
+ (display ";q=" port)
+ (write-quality q port)))))
+ ","))
+
+(define* (parse-non-negative-integer val #:optional (start 0)
+ (end (string-length val)))
+ (define (char->decimal c)
+ (let ((i (- (char->integer c) (char->integer #\0))))
+ (if (and (<= 0 i) (< i 10))
+ i
+ (bad-header-component 'non-negative-integer val))))
+ (if (not (< start end))
+ (bad-header-component 'non-negative-integer val)
+ (let lp ((i start) (out 0))
+ (if (< i end)
+ (lp (1+ i)
+ (+ (* out 10) (char->decimal (string-ref val i))))
+ out))))
+
+(define (non-negative-integer? code)
+ (and (number? code) (>= code 0) (exact? code) (integer? code)))
+
+(define (default-kons k val)
+ (if val
+ (cons k val)
+ k))
+
+(define (default-kv-validator k val)
+ #t)
+
+(define (default-val-writer k val port)
+ (if (or (string-index val #\;)
+ (string-index val #\,)
+ (string-index val #\"))
+ (write-qstring val port)
+ (display val port)))
+
+(define* (parse-key-value-list str #:optional (kproc identity)
+ (kons default-kons)
+ (start 0) (end (string-length str)))
+ (let lp ((i start) (out '()))
+ (if (not (< i end))
+ (reverse! out)
+ (let* ((i (skip-whitespace str i end))
+ (eq (string-index str #\= i end))
+ (comma (string-index str #\, i end))
+ (delim (min (or eq end) (or comma end)))
+ (k (kproc (substring str i (trim-whitespace str i delim)))))
+ (call-with-values
+ (lambda ()
+ (if (and eq (or (not comma) (< eq comma)))
+ (let ((i (skip-whitespace str (1+ eq) end)))
+ (if (and (< i end) (eqv? (string-ref str i) #\"))
+ (parse-qstring str i end #:incremental? #t)
+ (values (substring str i
+ (trim-whitespace str i
+ (or comma end)))
+ (or comma end))))
+ (values #f delim)))
+ (lambda (v-str next-i)
+ (let ((i (skip-whitespace str next-i end)))
+ (if (or (= i end) (eqv? (string-ref str i) #\,))
+ (lp (1+ i) (cons (kons k v-str) out))
+ (bad-header-component 'key-value-list
+ (substring str start end))))))))))
+
+(define* (key-value-list? list #:optional
+ (valid? default-kv-validator))
+ (list-of? list
+ (lambda (elt)
+ (cond
+ ((pair? elt)
+ (let ((k (car elt))
+ (v (cdr elt)))
+ (and (or (string? k) (symbol? k))
+ (valid? k v))))
+ ((or (string? elt) (symbol? elt))
+ (valid? elt #f))
+ (else #f)))))
+
+(define* (write-key-value-list list port #:optional
+ (val-writer default-val-writer) (delim ", "))
+ (write-list
+ list port
+ (lambda (x port)
+ (let ((k (if (pair? x) (car x) x))
+ (v (if (pair? x) (cdr x) #f)))
+ (display k port)
+ (if v
+ (begin
+ (display #\= port)
+ (val-writer k v port)))))
+ delim))
+
+;; param-component = token [ "=" (token | quoted-string) ] \
+;; *(";" token [ "=" (token | quoted-string) ])
+;;
+(define* (parse-param-component str #:optional (kproc identity)
+ (kons default-kons)
+ (start 0) (end (string-length str)))
+ (let lp ((i start) (out '()))
+ (if (not (< i end))
+ (values (reverse! out) end)
+ (let ((delim (string-index str
+ (lambda (c) (memq c '(#\, #\; #\=)))
+ i)))
+ (let ((k (kproc
+ (substring str i (trim-whitespace str i (or delim end)))))
+ (delimc (and delim (string-ref str delim))))
+ (case delimc
+ ((#\=)
+ (call-with-values
+ (lambda ()
+ (let ((i (skip-whitespace str (1+ delim) end)))
+ (if (and (< i end) (eqv? (string-ref str i) #\"))
+ (parse-qstring str i end #:incremental? #t)
+ (let ((delim
+ (or (string-index
+ str
+ (lambda (c)
+ (or (eqv? c #\;)
+ (eqv? c #\,)
+ (char-whitespace? c)))
+ i end)
+ end)))
+ (values (substring str i delim)
+ delim)))))
+ (lambda (v-str next-i)
+ (let ((x (kons k v-str))
+ (i (skip-whitespace str next-i end)))
+ (case (and (< i end) (string-ref str i))
+ ((#f)
+ (values (reverse! (cons x out)) end))
+ ((#\;)
+ (lp (skip-whitespace str (1+ i) end)
+ (cons x out)))
+ (else ; including #\,
+ (values (reverse! (cons x out)) i)))))))
+ ((#\;)
+ (lp (skip-whitespace str (1+ delim) end)
+ (cons (kons k #f) out)))
+
+ (else ;; either the end of the string or a #\,
+ (values (reverse! (cons (kons k #f) out))
+ (or delim end)))))))))
+
+(define* (parse-param-list str #:optional
+ (kproc identity) (kons default-kons)
+ (start 0) (end (string-length str)))
+ (let lp ((i start) (out '()))
+ (call-with-values
+ (lambda () (parse-param-component str kproc kons i end))
+ (lambda (item i)
+ (if (< i end)
+ (if (eqv? (string-ref str i) #\,)
+ (lp (skip-whitespace str (1+ i) end)
+ (cons item out))
+ (bad-header-component 'param-list str))
+ (reverse! (cons item out)))))))
+
+(define* (validate-param-list list #:optional
+ (valid? default-kv-validator))
+ (list-of? list
+ (lambda (elt)
+ (key-value-list? list valid?))))
+
+(define* (write-param-list list port #:optional
+ (val-writer default-val-writer))
+ (write-list
+ list port
+ (lambda (item port)
+ (write-key-value-list item port val-writer ";"))
+ ","))
+
+(define (list-of-strings? val)
+ (list-of? val string?))
+
+(define (write-list-of-strings val port)
+ (write-list val port display ", "))
+
+(define (parse-date str)
+ ;; Unfortunately, there is no way to make string->date parse out the
+ ;; "GMT" bit, so we play string games to append a format it will
+ ;; understand (the +0000 bit).
+ (string->date
+ (if (string-suffix? " GMT" str)
+ (string-append (substring str 0 (- (string-length str) 4))
+ " +0000")
+ (bad-header-component 'date str))
+ "~a, ~d ~b ~Y ~H:~M:~S ~z"))
+
+(define (write-date date port)
+ (display (date->string date "~a, ~d ~b ~Y ~H:~M:~S GMT") port))
+
+(define (write-uri uri port)
+ (display (unparse-uri uri) port))
+
+(define (parse-entity-tag val)
+ (if (string-prefix? "W/" val)
+ (cons (parse-qstring val 2) #f)
+ (cons (parse-qstring val) #t)))
+
+(define (entity-tag? val)
+ (and (pair? val)
+ (string? (car val))))
+
+(define (write-entity-tag val port)
+ (if (cdr val)
+ (display "W/" port))
+ (write-qstring (car val) port))
+
+(define* (parse-entity-tag-list val #:optional
+ (start 0) (end (string-length val)))
+ (let ((strong? (not (string-prefix? "W/" val 0 2 start end))))
+ (call-with-values (lambda ()
+ (parse-qstring val (if strong? start (+ start 2))
+ end #:incremental? #t))
+ (lambda (tag next)
+ (acons tag strong?
+ (let ((next (skip-whitespace val next end)))
+ (if (< next end)
+ (if (eqv? (string-ref val next) #\,)
+ (parse-entity-tag-list
+ val
+ (skip-whitespace val (1+ next) end)
+ end)
+ (bad-header-component 'entity-tag-list val))
+ '())))))))
+
+(define (entity-tag-list? val)
+ (list-of? val entity-tag?))
+
+(define (write-entity-tag-list val port)
+ (write-list val port write-entity-tag ", "))
+
+
+
+
+;;;
+;;; Request-Line and Response-Line
+;;;
+
+;; Hmm.
+(define (bad-request message . args)
+ (throw 'bad-request message args))
+(define (bad-response message . args)
+ (throw 'bad-response message args))
+
+(define *known-versions* '())
+
+(define (parse-http-version str start end)
+ (or (let lp ((known *known-versions*))
+ (and (pair? known)
+ (if (string= str (caar known) start end)
+ (cdar known)
+ (lp (cdr known)))))
+ (let ((dot-idx (string-index str #\. start end)))
+ (if (and (string-prefix? "HTTP/" str 0 5 start end)
+ dot-idx
+ (= dot-idx (string-rindex str #\. start end)))
+ (cons (parse-non-negative-integer str (+ start 5) dot-idx)
+ (parse-non-negative-integer str (1+ dot-idx) end))
+ (bad-header-component 'http-version (substring str start end))))))
+
+(define (write-http-version val port)
+ (display "HTTP/" port)
+ (display (car val) port)
+ (display #\. port)
+ (display (cdr val) port))
+
+(for-each
+ (lambda (v)
+ (set! *known-versions*
+ (acons v (parse-http-version v 0 (string-length v))
+ *known-versions*)))
+ '("HTTP/1.0" "HTTP/1.1"))
+
+
+;; Request-URI = "*" | absoluteURI | abs_path | authority
+;;
+;; The `authority' form is only permissible for the CONNECT method, so
+;; 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)
+ (cond
+ ((string= str "GET" start end) 'GET)
+ ((string= str "HEAD" start end) 'HEAD)
+ ((string= str "POST" start end) 'POST)
+ ((string= str "PUT" start end) 'PUT)
+ ((string= str "DELETE" start end) 'DELETE)
+ ((string= str "OPTIONS" start end) 'OPTIONS)
+ ((string= str "TRACE" start end) 'TRACE)
+ (else (bad-request "Invalid method: ~a" (substring str start end)))))
+
+(define (parse-uri-path str start end)
+ (cond
+ ((= start end)
+ (bad-request "Missing Request-URI"))
+ ((string= str "*" start end)
+ #f)
+ ((eq? (string-ref str start) #\/)
+ (let* ((q (string-index str #\? start end))
+ (f (string-index str #\# start end))
+ (q (and q (or (not f) (< q f)) q)))
+ (build-uri 'http
+ #:path (substring str start (or q f end))
+ #:query (and q (substring str (1+ q) (or f end)))
+ #:fragment (and f (substring str (1+ f) end)))))
+ (else
+ (or (parse-uri (substring str start end))
+ (bad-request "Invalid URI: ~a" (substring str start end))))))
+
+(define (read-request-line port)
+ (let* ((line (read-line* port))
+ (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)
+ (parse-http-version line (1+ d1) (string-length line)))
+ (bad-request "Bad Request-Line: ~s" line))))
+
+(define (write-uri uri port)
+ (if (uri-host uri)
+ (begin
+ (display (uri-scheme uri) port)
+ (display "://" port)
+ (if (uri-userinfo uri)
+ (begin
+ (display (uri-userinfo uri) port)
+ (display #\@ port)))
+ (display (uri-host uri) port)
+ (let ((p (uri-port uri)))
+ (if (and p (not (eqv? p 80)))
+ (begin
+ (display #\: port)
+ (display p port))))))
+ (let* ((path (uri-path uri))
+ (len (string-length path)))
+ (cond
+ ((and (> len 0) (not (eqv? (string-ref path 0) #\/)))
+ (bad-request "Non-absolute URI path: ~s" path))
+ ((and (zero? len) (not (uri-host uri)))
+ (bad-request "Empty path and no host for URI: ~s" uri))
+ (else
+ (display path port))))
+ (if (uri-query uri)
+ (begin
+ (display #\? port)
+ (display (uri-query uri) port))))
+
+(define (write-request-line method uri version port)
+ (display method port)
+ (display #\space port)
+ (write-uri uri port)
+ (display #\space port)
+ (write-http-version version port)
+ (display "\r\n" port))
+
+(define (read-response-line port)
+ (let* ((line (read-line* port))
+ (d0 (string-index line char-whitespace?)) ; "delimiter zero"
+ (d1 (and d0 (string-index line char-whitespace?
+ (skip-whitespace line d0)))))
+ (if (and d0 d1)
+ (values (parse-http-version line 0 d0)
+ (parse-non-negative-integer line (skip-whitespace line d0 d1)
+ d1)
+ (string-trim-both line char-whitespace? d1))
+ (bad-response "Bad Response-Line: ~s" line))))
+
+(define (write-response-line version code reason-phrase port)
+ (write-http-version version port)
+ (display #\space port)
+ (display code port)
+ (display #\space port)
+ (display reason-phrase port)
+ (display "\r\n" port))
+
+
+
+
+;;;
+;;; Syntax for declaring headers
+;;;
+
+;; emacs: (put 'declare-header 'scheme-indent-function 1)
+(define-syntax declare-header
+ (syntax-rules ()
+ ((_ sym name parser validator writer arg ...)
+ (declare-header!
+ 'sym name
+ #:parser parser #:validator validator #:writer writer
+ arg ...))))
+
+;; emacs: (put 'declare-opaque-header 'scheme-indent-function 1)
+(define-syntax declare-opaque-header
+ (syntax-rules ()
+ ((_ sym name)
+ (declare-header sym
+ name
+ parse-opaque-string validate-opaque-string write-opaque-string))))
+
+;; emacs: (put 'declare-date-header 'scheme-indent-function 1)
+(define-syntax declare-date-header
+ (syntax-rules ()
+ ((_ sym name)
+ (declare-header sym
+ name
+ parse-date date? write-date))))
+
+;; emacs: (put 'declare-string-list-header 'scheme-indent-function 1)
+(define-syntax declare-string-list-header
+ (syntax-rules ()
+ ((_ sym name)
+ (declare-header sym
+ name
+ split-and-trim list-of-strings? write-list-of-strings))))
+
+;; emacs: (put 'declare-integer-header 'scheme-indent-function 1)
+(define-syntax declare-integer-header
+ (syntax-rules ()
+ ((_ sym name)
+ (declare-header sym
+ name
+ parse-non-negative-integer non-negative-integer? display))))
+
+;; emacs: (put 'declare-uri-header 'scheme-indent-function 1)
+(define-syntax declare-uri-header
+ (syntax-rules ()
+ ((_ sym name)
+ (declare-header sym
+ name
+ (lambda (str) (or (parse-uri str) (bad-header-component 'uri str)))
+ uri?
+ write-uri))))
+
+;; emacs: (put 'declare-quality-list-header 'scheme-indent-function 1)
+(define-syntax declare-quality-list-header
+ (syntax-rules ()
+ ((_ sym name)
+ (declare-header sym
+ name
+ parse-quality-list validate-quality-list write-quality-list))))
+
+;; emacs: (put 'declare-param-list-header 'scheme-indent-function 1)
+(define-syntax declare-param-list-header
+ (syntax-rules ()
+ ((_ sym name)
+ (declare-param-list-header sym name identity default-kons
+ default-kv-validator default-val-writer))
+ ((_ sym name kproc)
+ (declare-param-list-header sym name kproc default-kons
+ default-kv-validator default-val-writer))
+ ((_ sym name kproc kons val-validator val-writer)
+ (declare-header sym
+ name
+ (lambda (str) (parse-param-list str kproc kons))
+ (lambda (val) (validate-param-list val val-validator))
+ (lambda (val port) (write-param-list val port val-writer))))))
+
+;; emacs: (put 'declare-key-value-list-header 'scheme-indent-function 1)
+(define-syntax declare-key-value-list-header
+ (syntax-rules ()
+ ((_ sym name)
+ (declare-key-value-list-header sym name identity default-kons
+ default-kv-validator default-val-writer))
+ ((_ sym name kproc)
+ (declare-key-value-list-header sym name kproc default-kons
+ default-kv-validator default-val-writer))
+ ((_ sym name kproc kons val-validator val-writer)
+ (declare-header sym
+ name
+ (lambda (str) (parse-key-value-list str kproc kons))
+ (lambda (val) (key-value-list? val val-validator))
+ (lambda (val port) (write-key-value-list val port val-writer))))))
+
+;; emacs: (put 'declare-entity-tag-list-header 'scheme-indent-function 1)
+(define-syntax declare-entity-tag-list-header
+ (syntax-rules ()
+ ((_ sym name)
+ (declare-header sym
+ name
+ (lambda (str) (if (string=? str "*") '* (parse-entity-tag-list str)))
+ (lambda (val) (or (eq? val '*) (entity-tag-list? val)))
+ (lambda (val port)
+ (if (eq? val '*)
+ (display "*" port)
+ (write-entity-tag-list val port)))))))
+
+
+
+
+;;;
+;;; General headers
+;;;
+
+;; Cache-Control = 1#(cache-directive)
+;; cache-directive = cache-request-directive | cache-response-directive
+;; cache-request-directive =
+;; "no-cache" ; Section 14.9.1
+;; | "no-store" ; Section 14.9.2
+;; | "max-age" "=" delta-seconds ; Section 14.9.3, 14.9.4
+;; | "max-stale" [ "=" delta-seconds ] ; Section 14.9.3
+;; | "min-fresh" "=" delta-seconds ; Section 14.9.3
+;; | "no-transform" ; Section 14.9.5
+;; | "only-if-cached" ; Section 14.9.4
+;; | cache-extension ; Section 14.9.6
+;; cache-response-directive =
+;; "public" ; Section 14.9.1
+;; | "private" [ "=" <"> 1#field-name <"> ] ; Section 14.9.1
+;; | "no-cache" [ "=" <"> 1#field-name <"> ]; Section 14.9.1
+;; | "no-store" ; Section 14.9.2
+;; | "no-transform" ; Section 14.9.5
+;; | "must-revalidate" ; Section 14.9.4
+;; | "proxy-revalidate" ; Section 14.9.4
+;; | "max-age" "=" delta-seconds ; Section 14.9.3
+;; | "s-maxage" "=" delta-seconds ; Section 14.9.3
+;; | cache-extension ; Section 14.9.6
+;; cache-extension = token [ "=" ( token | quoted-string ) ]
+;;
+(declare-key-value-list-header cache-control
+ "Cache-Control"
+ (let ((known-directives (make-hash-table)))
+ (for-each (lambda (s)
+ (hash-set! known-directives s (string->symbol s)))
+ '("no-cache" "no-store" "max-age" "max-stale" "min-fresh"
+ "no-transform" "only-if-cached" "public" "private"
+ "must-revalidate" "proxy-revalidate" "s-maxage"))
+ (lambda (k-str)
+ (hash-ref known-directives k-str k-str)))
+ (lambda (k v-str)
+ (case k
+ ((max-age max-stale min-fresh s-maxage)
+ (cons k (parse-non-negative-integer v-str)))
+ ((private no-cache)
+ (cons k (if v-str (split-and-trim v-str) #t)))
+ (else (if v-str (cons k v-str) k))))
+ default-kv-validator
+ (lambda (k v port)
+ (cond
+ ((string? v) (display v port))
+ ((pair? v)
+ (write-qstring (string-join v ", ") port))
+ ((integer? v)
+ (display v port))
+ (else
+ (bad-header-component 'cache-control v)))))
+
+;; Connection = "Connection" ":" 1#(connection-token)
+;; connection-token = token
+;; e.g.
+;; Connection: close, foo-header
+;;
+(declare-string-list-header connection
+ "Connection")
+
+;; Date = "Date" ":" HTTP-date
+;; e.g.
+;; Date: Tue, 15 Nov 1994 08:12:31 GMT
+;;
+(declare-date-header date
+ "Date")
+
+;; Pragma = "Pragma" ":" 1#pragma-directive
+;; pragma-directive = "no-cache" | extension-pragma
+;; extension-pragma = token [ "=" ( token | quoted-string ) ]
+;;
+(declare-key-value-list-header pragma
+ "Pragma"
+ (lambda (k) (if (equal? k "no-cache") 'no-cache k)))
+
+;; Trailer = "Trailer" ":" 1#field-name
+;;
+(declare-string-list-header trailer
+ "Trailer")
+
+;; Transfer-Encoding = "Transfer-Encoding" ":" 1#transfer-coding
+;;
+(declare-param-list-header transfer-encoding
+ "Transfer-Encoding"
+ (lambda (k)
+ (if (equal? k "chunked") 'chunked k)))
+
+;; Upgrade = "Upgrade" ":" 1#product
+;;
+(declare-string-list-header upgrade
+ "Upgrade")
+
+;; Via = "Via" ":" 1#( received-protocol received-by [ comment ] )
+;; received-protocol = [ protocol-name "/" ] protocol-version
+;; protocol-name = token
+;; protocol-version = token
+;; received-by = ( host [ ":" port ] ) | pseudonym
+;; pseudonym = token
+;;
+(declare-header via
+ "Via"
+ split-and-trim
+ list-of-strings?
+ write-list-of-strings
+ #:multiple? #t)
+
+;; Warning = "Warning" ":" 1#warning-value
+;;
+;; warning-value = warn-code SP warn-agent SP warn-text
+;; [SP warn-date]
+;;
+;; warn-code = 3DIGIT
+;; warn-agent = ( host [ ":" port ] ) | pseudonym
+;; ; the name or pseudonym of the server adding
+;; ; the Warning header, for use in debugging
+;; warn-text = quoted-string
+;; warn-date = <"> HTTP-date <">
+(declare-header warning
+ "Warning"
+ (lambda (str)
+ (let ((len (string-length str)))
+ (let lp ((i (skip-whitespace str 0)))
+ (let* ((idx1 (string-index str #\space i))
+ (idx2 (string-index str #\space (1+ idx1))))
+ (if (and idx1 idx2)
+ (let ((code (parse-non-negative-integer str i idx1))
+ (agent (substring str (1+ idx1) idx2)))
+ (call-with-values
+ (lambda () (parse-qstring str (1+ idx2) #:incremental? #t))
+ (lambda (text i)
+ (call-with-values
+ (lambda ()
+ (let ((c (and (< i len) (string-ref str i))))
+ (case c
+ ((#\space)
+ ;; we have a date.
+ (call-with-values
+ (lambda () (parse-qstring str (1+ i)
+ #:incremental?
#t))
+ (lambda (date i)
+ (values text (parse-date date) i))))
+ (else
+ (values text #f i)))))
+ (lambda (text date i)
+ (let ((w (list code agent text date))
+ (c (and (< i len) (string-ref str i))))
+ (case c
+ ((#f) (list w))
+ ((#\,) (cons w (lp (skip-whitespace str (1+ i)))))
+ (else (bad-header 'warning str))))))))))))))
+ (lambda (val)
+ (list-of? val
+ (lambda (elt)
+ (and (list? elt)
+ (= (length elt) 4)
+ (apply (lambda (code host text date)
+ (and (non-negative-integer? code) (< code 1000)
+ (string? host)
+ (string? text)
+ (or (not date) (date? date))))
+ elt)))))
+ (lambda (val port)
+ (write-list
+ val port
+ (lambda (w port)
+ (apply
+ (lambda (code host text date)
+ (display code port)
+ (display #\space port)
+ (display host port)
+ (display #\space port)
+ (write-qstring text port)
+ (if date
+ (begin
+ (display #\space port)
+ (write-date date port))))
+ w))
+ ", "))
+ #:multiple? #t)
+
+
+
+
+;;;
+;;; Entity headers
+;;;
+
+;; Allow = #Method
+;;
+(declare-string-list-header allow
+ "Allow")
+
+;; Content-Encoding = 1#content-coding
+;;
+(declare-string-list-header content-encoding
+ "Content-Encoding")
+
+;; Content-Language = 1#language-tag
+;;
+(declare-string-list-header content-language
+ "Content-Language")
+
+;; Content-Length = 1*DIGIT
+;;
+(declare-integer-header content-length
+ "Content-Length")
+
+;; Content-Location = ( absoluteURI | relativeURI )
+;;
+(declare-uri-header content-location
+ "Content-Location")
+
+;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864>
+;;
+(declare-opaque-header content-md5
+ "Content-MD5")
+
+;; Content-Range = content-range-spec
+;; content-range-spec = byte-content-range-spec
+;; byte-content-range-spec = bytes-unit SP
+;; byte-range-resp-spec "/"
+;; ( instance-length | "*" )
+;; byte-range-resp-spec = (first-byte-pos "-" last-byte-pos)
+;; | "*"
+;; instance-length = 1*DIGIT
+;;
+(declare-header content-range
+ "Content-Range"
+ (lambda (str)
+ (let ((dash (string-index str #\-))
+ (slash (string-index str #\/)))
+ (if (and (string-prefix? "bytes " str) slash)
+ (list 'bytes
+ (cond
+ (dash
+ (cons
+ (parse-non-negative-integer str 6 dash)
+ (parse-non-negative-integer str (1+ dash) slash)))
+ ((string= str "*" 6 slash)
+ '*)
+ (else
+ (bad-header 'content-range str)))
+ (if (string= str "*" (1+ slash))
+ '*
+ (parse-non-negative-integer str (1+ slash))))
+ (bad-header 'content-range str))))
+ (lambda (val)
+ (and (list? val) (= (length val) 3)
+ (symbol? (car val))
+ (let ((x (cadr val)))
+ (or (eq? x '*)
+ (and (pair? x)
+ (non-negative-integer? (car x))
+ (non-negative-integer? (cdr x)))))
+ (let ((x (caddr val)))
+ (or (eq? x '*)
+ (non-negative-integer? x)))))
+ (lambda (val port)
+ (display (car val) port)
+ (display #\space port)
+ (if (eq? (cadr val) '*)
+ (display #\* port)
+ (begin
+ (display (caadr val) port)
+ (display #\- port)
+ (display (caadr val) port)))
+ (if (eq? (caddr val) '*)
+ (display #\* port)
+ (display (caddr val) port))))
+
+;; Content-Type = media-type
+;;
+(declare-header content-type
+ "Content-Type"
+ (lambda (str)
+ (let ((parts (string-split str #\;)))
+ (call-with-values (lambda () (parse-media-type (car parts)))
+ (lambda (type subtype)
+ (cons* type subtype
+ (map (lambda (x)
+ (let ((eq (string-index x #\=)))
+ (if (and eq (= eq (string-rindex x #\=)))
+ (cons (string-trim x 0 eq)
+ (string-trim-right x (1+ eq)))
+ (bad-header 'content-type str))))
+ (cdr parts)))))))
+ (lambda (val)
+ (and (list-of? val string?)
+ (let ((len (length val)))
+ (and (>= len 2)
+ (even? len)))))
+ (lambda (val port)
+ (display (car val) port)
+ (display #\/ port)
+ (display (cadr val) port)
+ (write-list
+ (cddr val) port
+ (lambda (pair port)
+ (display (car pair) port)
+ (display #\= port)
+ (display (cdr pair) port))
+ ";")))
+
+;; Expires = HTTP-date
+;;
+(declare-date-header expires
+ "Expires")
+
+;; Last-Modified = HTTP-date
+;;
+(declare-date-header last-modified
+ "Last-Modified")
+
+
+
+
+;;;
+;;; Request headers
+;;;
+
+;; Accept = #( media-range [ accept-params ] )
+;; media-range = ( "*/*" | ( type "/" "*" ) | ( type "/" subtype ) )
+;; *( ";" parameter )
+;; accept-params = ";" "q" "=" qvalue *( accept-extension )
+;; accept-extension = ";" token [ "=" ( token | quoted-string ) ]
+;;
+(declare-param-list-header accept
+ "Accept"
+ ;; -> ("type/subtype" (str-prop . str-val) ...) ...)
+ ;;
+ ;; with the exception of prop = "q", in which case the prop will be
+ ;; the symbol 'q, and the val will be a valid quality value
+ ;;
+ (lambda (k) (if (string=? k "q") 'q k))
+ (lambda (k v)
+ (if (eq? k 'q)
+ (cons k (parse-quality v))
+ (default-kons k v)))
+ (lambda (k v)
+ (if (eq? k 'q)
+ (valid-quality? v)
+ (default-kv-validator k v)))
+ (lambda (k v port)
+ (if (eq? k 'q)
+ (write-quality v port)
+ (default-val-writer k v port))))
+
+;; Accept-Charset = 1#( ( charset | "*" )[ ";" "q" "=" qvalue ] )
+;;
+(declare-quality-list-header accept-charset
+ "Accept-Charset")
+
+;; Accept-Encoding = 1#( codings [ ";" "q" "=" qvalue ] )
+;; codings = ( content-coding | "*" )
+;;
+(declare-quality-list-header accept-encoding
+ "Accept-Encoding")
+
+;; Accept-Language = 1#( language-range [ ";" "q" "=" qvalue ] )
+;; language-range = ( ( 1*8ALPHA *( "-" 1*8ALPHA ) ) | "*" )
+;;
+(declare-quality-list-header accept-language
+ "Accept-Language")
+
+;; Authorization = credentials
+;;
+;; Authorization is basically opaque to this HTTP stack, we just pass
+;; the string value through.
+;;
+(declare-opaque-header authorization
+ "Authorization")
+
+;; Expect = 1#expectation
+;; expectation = "100-continue" | expectation-extension
+;; expectation-extension = token [ "=" ( token | quoted-string )
+;; *expect-params ]
+;; expect-params = ";" token [ "=" ( token | quoted-string ) ]
+;;
+(declare-param-list-header expect
+ "Expect"
+ (lambda (k)
+ (if (equal? k "100-continue")
+ '100-continue
+ k)))
+
+;; From = mailbox
+;;
+;; Should be an email address; we just pass on the string as-is.
+;;
+(declare-opaque-header from
+ "From")
+
+;; Host = host [ ":" port ]
+;;
+(declare-header host
+ "Host"
+ (lambda (str)
+ (let ((colon (string-index str #\:)))
+ (if colon
+ (cons (substring str 0 colon)
+ (parse-non-negative-integer str (1+ colon)))
+ (cons str #f))))
+ (lambda (val)
+ (and (pair? val)
+ (string? (car val))
+ (or (not (cdr val))
+ (non-negative-integer? (cdr val)))))
+ (lambda (val port)
+ (display (car val) port)
+ (if (cdr val)
+ (begin
+ (display #\: port)
+ (display (cdr val) port)))))
+
+;; If-Match = ( "*" | 1#entity-tag )
+;;
+(declare-entity-tag-list-header if-match
+ "If-Match")
+
+;; If-Modified-Since = HTTP-date
+;;
+(declare-date-header if-modified-since
+ "If-Modified-Since")
+
+;; If-None-Match = ( "*" | 1#entity-tag )
+;;
+(declare-entity-tag-list-header if-none-match
+ "If-None-Match")
+
+;; If-Range = ( entity-tag | HTTP-date )
+;;
+(declare-header if-range
+ "If-Range"
+ (lambda (str)
+ (if (or (string-prefix? "\"" str)
+ (string-prefix? "W/" str))
+ (parse-entity-tag str)
+ (parse-date str)))
+ (lambda (val)
+ (or (date? val) (entity-tag? val)))
+ (lambda (val port)
+ (if (date? val)
+ (write-date val port)
+ (write-entity-tag val port))))
+
+;; If-Unmodified-Since = HTTP-date
+;;
+(declare-date-header if-unmodified-since
+ "If-Unmodified-Since")
+
+;; Max-Forwards = 1*DIGIT
+;;
+(declare-integer-header max-forwards
+ "Max-Forwards")
+
+;; Proxy-Authorization = credentials
+;;
+(declare-opaque-header proxy-authorization
+ "Proxy-Authorization")
+
+;; Range = "Range" ":" ranges-specifier
+;; ranges-specifier = byte-ranges-specifier
+;; byte-ranges-specifier = bytes-unit "=" byte-range-set
+;; byte-range-set = 1#( byte-range-spec | suffix-byte-range-spec )
+;; byte-range-spec = first-byte-pos "-" [last-byte-pos]
+;; first-byte-pos = 1*DIGIT
+;; last-byte-pos = 1*DIGIT
+;; suffix-byte-range-spec = "-" suffix-length
+;; suffix-length = 1*DIGIT
+;;
+(declare-header range
+ "Range"
+ (lambda (str)
+ (if (string-prefix? "bytes=" str)
+ (cons
+ 'bytes
+ (map (lambda (x)
+ (let ((dash (string-index x #\-)))
+ (cond
+ ((not dash)
+ (bad-header 'range str))
+ ((zero? dash)
+ (cons #f (parse-non-negative-integer x 1)))
+ ((= dash (1- (string-length x)))
+ (cons (parse-non-negative-integer x 0 dash) #f))
+ (else
+ (cons (parse-non-negative-integer x 0 dash)
+ (parse-non-negative-integer x (1+ dash)))))))
+ (string-split (substring str 6) #\,)))
+ (bad-header 'range str)))
+ (lambda (val)
+ (and (pair? val)
+ (symbol? (car val))
+ (list-of? (cdr val)
+ (lambda (elt)
+ (and (pair? elt)
+ (let ((x (car elt)) (y (cdr elt)))
+ (and (or x y)
+ (or (not x) (non-negative-integer? x))
+ (or (not y) (non-negative-integer? y)))))))))
+ (lambda (val port)
+ (display (car val) port)
+ (display #\= port)
+ (write-list
+ (cdr val) port
+ (lambda (pair port)
+ (if (car pair)
+ (display (car pair) port))
+ (display #\- port)
+ (if (cdr pair)
+ (display (cdr pair) port)))
+ ",")))
+
+;; Referer = ( absoluteURI | relativeURI )
+;;
+(declare-uri-header referer
+ "Referer")
+
+;; TE = #( t-codings )
+;; t-codings = "trailers" | ( transfer-extension [ accept-params ] )
+;;
+(declare-param-list-header te
+ "TE"
+ (lambda (k) (if (equal? k "trailers") 'trailers k)))
+
+;; User-Agent = 1*( product | comment )
+;;
+(declare-opaque-header user-agent
+ "User-Agent")
+
+
+
+
+;;;
+;;; Reponse headers
+;;;
+
+;; Accept-Ranges = acceptable-ranges
+;; acceptable-ranges = 1#range-unit | "none"
+;;
+(declare-string-list-header accept-ranges
+ "Accept-Ranges")
+
+;; Age = age-value
+;; age-value = delta-seconds
+;;
+(declare-integer-header age
+ "Age")
+
+;; ETag = entity-tag
+;;
+(declare-header etag
+ "ETag"
+ parse-entity-tag
+ entity-tag?
+ write-entity-tag)
+
+;; Location = absoluteURI
+;;
+(declare-uri-header location
+ "Location")
+
+;; Proxy-Authenticate = 1#challenge
+;;
+;; FIXME: split challenges ?
+(declare-opaque-header proxy-authenticate
+ "Proxy-Authenticate")
+
+;; Retry-After = ( HTTP-date | delta-seconds )
+;;
+(declare-header retry-after
+ "Retry-After"
+ (lambda (str)
+ (if (and (not (string-null? str))
+ (char-numeric? (string-ref str 0)))
+ (parse-non-negative-integer str)
+ (parse-date str)))
+ (lambda (val)
+ (or (date? val) (non-negative-integer? val)))
+ (lambda (val port)
+ (if (date? val)
+ (write-date val port)
+ (display val port))))
+
+;; Server = 1*( product | comment )
+;;
+(declare-opaque-header server
+ "Server")
+
+;; Vary = ( "*" | 1#field-name )
+;;
+(declare-header vary
+ "Vary"
+ (lambda (str)
+ (if (equal? str "*")
+ '*
+ (split-and-trim str)))
+ (lambda (val)
+ (or (eq? val '*) (list-of-strings? val)))
+ (lambda (val port)
+ (if (eq? val '*)
+ (display "*" port)
+ (write-list-of-strings val port))))
+
+;; WWW-Authenticate = 1#challenge
+;;
+;; Hum.
+(declare-opaque-header www-authenticate
+ "WWW-Authenticate")
diff --git a/module/web/request.scm b/module/web/request.scm
new file mode 100644
index 0000000..8e29589
--- /dev/null
+++ b/module/web/request.scm
@@ -0,0 +1,294 @@
+;;; HTTP request objects
+
+;; 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 request)
+ #:use-module (rnrs bytevectors)
+ #:use-module (rnrs io ports)
+ #:use-module (ice-9 rdelim)
+ #:use-module (srfi srfi-9)
+ #:use-module (web uri)
+ #:use-module (web http)
+ #:export (request?
+ request-method
+ request-uri
+ request-version
+ request-headers
+ request-port
+
+ read-request
+ build-request
+ write-request
+
+ read-request-body/latin-1
+ write-request-body/latin-1
+
+ read-request-body/bytevector
+ write-request-body/bytevector
+
+ ;; General headers
+ ;;
+ request-cache-control
+ request-connection
+ request-date
+ request-pragma
+ request-trailer
+ request-transfer-encoding
+ request-upgrade
+ request-via
+ request-warning
+
+ ;; Entity headers
+ ;;
+ request-allow
+ request-content-encoding
+ request-content-language
+ request-content-length
+ request-content-location
+ request-content-md5
+ request-content-range
+ request-content-type
+ request-expires
+ request-last-modified
+
+ ;; Request headers
+ ;;
+ request-accept
+ request-accept-charset
+ request-accept-encoding
+ request-accept-language
+ request-authorization
+ request-expect
+ request-from
+ request-host
+ request-if-match
+ request-if-modified-since
+ request-if-none-match
+ request-if-range
+ request-if-unmodified-since
+ request-max-forwards
+ request-proxy-authorization
+ request-range
+ request-referer
+ request-te
+ request-user-agent
+
+ ;; Misc
+ request-absolute-uri))
+
+
+;;; {Character Encodings, Strings, and Bytevectors}
+;;;
+;;; Requests are read from over the wire, and as such have to be treated
+;;; very carefully.
+;;;
+;;; The header portion of the message is defined to be in a subset of
+;;; ASCII, and may be processed either byte-wise (using bytevectors and
+;;; binary I/O) or as characters in a single-byte ASCII-compatible
+;;; encoding.
+;;;
+;;; We choose the latter, processing as strings in the latin-1
+;;; encoding. This allows us to use all the read-delimited machinery,
+;;; character sets, and regular expressions, shared substrings, etc.
+;;;
+;;; The characters in the header values may themselves encode other
+;;; bytes or characters -- basically each header has its own parser. We
+;;; leave that as a header-specific topic.
+;;;
+;;; The body is present if the content-length header is present. Its
+;;; format and, if textual, encoding is determined by the headers, but
+;;; its length is encoded in bytes. So we just slurp that number of
+;;; characters in latin-1, knowing that the number of characters
+;;; corresponds to the number of bytes, and then convert to a
+;;; bytevector, perhaps for later decoding.
+;;;
+
+(define-record-type <request>
+ (make-request method uri version headers port)
+ request?
+ (method request-method)
+ (uri request-uri)
+ (version request-version)
+ (headers request-headers)
+ (port request-port))
+
+(define (bad-request message . args)
+ (throw 'bad-request message args))
+
+(define (non-negative-integer? n)
+ (and (number? n) (>= n 0) (exact? n) (integer? n)))
+
+(define (validate-headers headers)
+ (if (pair? headers)
+ (let ((h (car headers)))
+ (if (pair? h)
+ (let ((k (car h)) (v (cdr h)))
+ (if (symbol? k)
+ (if (not (valid-header? k v))
+ (bad-request "Bad value for header ~a: ~s" k v))
+ (if (not (and (string? k) (string? v)))
+ (bad-request "Unknown header not a pair of strings: ~s"
+ h)))
+ (validate-headers (cdr headers)))
+ (bad-request "Header not a pair: ~a" h)))
+ (if (not (null? headers))
+ (bad-request "Headers not a list: ~a" headers))))
+
+(define* (build-request #:key (method 'GET) uri (version '(1 . 1))
+ (headers '()) port (validate-headers? #t))
+ (cond
+ ((not (and (pair? version)
+ (non-negative-integer? (car version))
+ (non-negative-integer? (cdr version))))
+ (bad-request "Bad version: ~a" version))
+ ((not (uri? uri))
+ (bad-request "Bad uri: ~a" uri))
+ ((and (not port) (memq method '(POST PUT)))
+ (bad-request "Missing port for message ~a" method))
+ (else
+ (if validate-headers?
+ (validate-headers headers))))
+ (make-request method uri version headers port))
+
+(define (read-request port)
+ (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))))
+
+(define (write-request r port)
+ (write-request-line (request-method r) (request-uri r)
+ (request-version r) port)
+ (write-headers (request-headers r) port)
+ (display "\r\n" port)
+ (if (eq? port (request-port r))
+ r
+ (make-request (request-method r) (request-uri r) (request-version r)
+ (request-headers r) port)))
+
+;; Probably not what you want to use "in production". Relies on one byte
+;; per char because we are in latin-1 encoding.
+;;
+(define (read-request-body/latin-1 r)
+ (let ((nbytes (request-content-length r)))
+ (and nbytes
+ (let ((buf (make-string nbytes)))
+ (read-delimited! "" buf (request-port r))
+ buf))))
+
+;; Likewise, assumes that body can be written in the latin-1 encoding,
+;; and that the latin-1 encoding is what is expected by the server.
+;;
+(define (write-request-body/latin-1 r body)
+ (display body (request-port r)))
+
+(define (read-request-body/bytevector r)
+ (let ((nbytes (request-content-length r)))
+ (and nbytes
+ (let ((bv (get-bytevector-n (request-port r) nbytes)))
+ (if (= (bytevector-length bv) nbytes)
+ bv
+ (bad-request "EOF while reading request body: ~a bytes of ~a"
+ (bytevector-length bv) nbytes))))))
+
+(define (write-request-body/bytevector r bv)
+ (put-bytevector (request-port r) bv))
+
+(define-syntax define-request-accessor
+ (lambda (x)
+ (syntax-case x ()
+ ((_ field)
+ #'(define-request-accessor field #f))
+ ((_ field def) (identifier? #'field)
+ #`(define* (#,(datum->syntax
+ #'field
+ (symbol-append 'request- (syntax->datum #'field)))
+ request
+ #:optional (default def))
+ (cond
+ ((assq 'field (request-headers request)) => cdr)
+ (else default)))))))
+
+;; General headers
+;;
+(define-request-accessor cache-control '())
+(define-request-accessor connection '())
+(define-request-accessor date #f)
+(define-request-accessor pragma '())
+(define-request-accessor trailer '())
+(define-request-accessor transfer-encoding '())
+(define-request-accessor upgrade '())
+(define-request-accessor via '())
+(define-request-accessor warning '())
+
+;; Entity headers
+;;
+(define-request-accessor allow '())
+(define-request-accessor content-encoding '())
+(define-request-accessor content-language '())
+(define-request-accessor content-length #f)
+(define-request-accessor content-location #f)
+(define-request-accessor content-md5 #f)
+(define-request-accessor content-range #f)
+(define-request-accessor content-type #f)
+(define-request-accessor expires #f)
+(define-request-accessor last-modified #f)
+
+;; Request headers
+;;
+(define-request-accessor accept '())
+(define-request-accessor accept-charset '())
+(define-request-accessor accept-encoding '())
+(define-request-accessor accept-language '())
+(define-request-accessor authorization #f)
+(define-request-accessor expect '())
+(define-request-accessor from #f)
+(define-request-accessor host #f)
+;; Absence of an if-directive appears to be different from `*'.
+(define-request-accessor if-match #f)
+(define-request-accessor if-modified-since #f)
+(define-request-accessor if-none-match #f)
+(define-request-accessor if-range #f)
+(define-request-accessor if-unmodified-since #f)
+(define-request-accessor max-forwards #f)
+(define-request-accessor proxy-authorization #f)
+(define-request-accessor range #f)
+(define-request-accessor referer #f)
+(define-request-accessor te '())
+(define-request-accessor user-agent #f)
+
+;; Misc accessors
+(define* (request-absolute-uri r #:optional default-host default-port)
+ (let ((uri (request-uri r)))
+ (if (uri-host uri)
+ uri
+ (let ((host
+ (or (request-host r)
+ (if default-host
+ (cons default-host default-port)
+ (bad-request
+ "URI not absolute, no Host header, and no default: ~s"
+ uri)))))
+ (build-uri (uri-scheme uri)
+ #:host (car host)
+ #:port (cdr host)
+ #:path (uri-path uri)
+ #:query (uri-query uri)
+ #:fragment (uri-fragment uri))))))
diff --git a/module/web/response.scm b/module/web/response.scm
new file mode 100644
index 0000000..c205485
--- /dev/null
+++ b/module/web/response.scm
@@ -0,0 +1,242 @@
+;;; HTTP response objects
+
+;; 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 response)
+ #:use-module (rnrs bytevectors)
+ #:use-module (rnrs io ports)
+ #:use-module (ice-9 rdelim)
+ #:use-module (srfi srfi-9)
+ #:use-module (web http)
+ #:export (response?
+ response-version
+ response-code
+ response-reason-phrase
+ response-headers
+ response-port
+ read-response
+ build-response
+ write-response
+
+ read-response-body/latin-1
+ write-response-body/latin-1
+
+ read-response-body/bytevector
+ write-response-body/bytevector
+
+ ;; General headers
+ ;;
+ response-cache-control
+ response-connection
+ response-date
+ response-pragma
+ response-trailer
+ response-transfer-encoding
+ response-upgrade
+ response-via
+ response-warning
+
+ ;; Entity headers
+ ;;
+ response-allow
+ response-content-encoding
+ response-content-language
+ response-content-length
+ response-content-location
+ response-content-md5
+ response-content-range
+ response-content-type
+ response-expires
+ response-last-modified
+
+ ;; Response headers
+ ;;
+ response-accept-ranges
+ response-age
+ response-etag
+ response-location
+ response-proxy-authenticate
+ response-retry-after
+ response-server
+ response-vary
+ response-www-authenticate))
+
+
+(define-record-type <response>
+ (make-response version code reason-phrase headers port)
+ response?
+ (version response-version)
+ (code response-code)
+ (reason-phrase %response-reason-phrase)
+ (headers response-headers)
+ (port response-port))
+
+(define (bad-response message . args)
+ (throw 'bad-response message args))
+
+(define* (build-response #:key (version '(1 . 1)) (code 200) reason-phrase
+ (headers '()) port)
+ (make-response version code reason-phrase headers port))
+
+(define *reason-phrases*
+ '((100 . "Continue")
+ (101 . "Switching Protocols")
+ (200 . "OK")
+ (201 . "Created")
+ (202 . "Accepted")
+ (203 . "Non-Authoritative Information")
+ (204 . "No Content")
+ (205 . "Reset Content")
+ (206 . "Partial Content")
+ (300 . "Multiple Choices")
+ (301 . "Moved Permanently")
+ (302 . "Found")
+ (303 . "See Other")
+ (304 . "Not Modified")
+ (305 . "Use Proxy")
+ (307 . "Temporary Redirect")
+ (400 . "Bad Request")
+ (401 . "Unauthorized")
+ (402 . "Payment Required")
+ (403 . "Forbidden")
+ (404 . "Not Found")
+ (405 . "Method Not Allowed")
+ (406 . "Not Acceptable")
+ (407 . "Proxy Authentication Required")
+ (408 . "Request Timeout")
+ (409 . "Conflict")
+ (410 . "Gone")
+ (411 . "Length Required")
+ (412 . "Precondition Failed")
+ (413 . "Request Entity Too Large")
+ (414 . "Request-URI Too Long")
+ (415 . "Unsupported Media Type")
+ (416 . "Requested Range Not Satisfiable")
+ (417 . "Expectation Failed")
+ (500 . "Internal Server Error")
+ (501 . "Not Implemented")
+ (502 . "Bad Gateway")
+ (503 . "Service Unavailable")
+ (504 . "Gateway Timeout")
+ (505 . "HTTP Version Not Supported")))
+
+(define (code->reason-phrase code)
+ (or (assv-ref *reason-phrases* code)
+ "(Unknown)"))
+
+(define (response-reason-phrase response)
+ (or (%response-reason-phrase response)
+ (code->reason-phrase (response-code response))))
+
+(define (read-response port)
+ (set-port-encoding! port "ISO-8859-1")
+ (call-with-values (lambda () (read-response-line port))
+ (lambda (version code reason-phrase)
+ (make-response version code reason-phrase (read-headers port) port))))
+
+(define (write-response r port)
+ (write-response-line (response-version r) (response-code r)
+ (response-reason-phrase r) port)
+ (write-headers (response-headers r) port)
+ (display "\r\n" port)
+ (if (eq? port (response-port r))
+ r
+ (make-response (response-version r) (response-code r)
+ (response-reason-phrase r) (response-headers r) port)))
+
+;; Probably not what you want to use "in production". Relies on one byte
+;; per char because we are in latin-1 encoding.
+;;
+(define (read-response-body/latin-1 r)
+ (let ((nbytes (response-content-length r)))
+ (and nbytes
+ (let ((buf (make-string nbytes)))
+ (read-delimited! "" buf (response-port r))
+ buf))))
+
+;; Likewise, assumes that body can be written in the latin-1 encoding,
+;; and that the latin-1 encoding is what is expected by the server.
+;;
+(define (write-response-body/latin-1 r body)
+ (display body (response-port r)))
+
+(define (read-response-body/bytevector r)
+ (let ((nbytes (response-content-length r)))
+ (and nbytes
+ (let ((bv (get-bytevector-n (response-port r) nbytes)))
+ (if (= (bytevector-length bv) nbytes)
+ bv
+ (bad-response "EOF while reading response body: ~a bytes of ~a"
+ (bytevector-length bv) nbytes))))))
+
+(define (write-response-body/bytevector r bv)
+ (put-bytevector (response-port r) bv))
+
+(define-syntax define-response-accessor
+ (lambda (x)
+ (syntax-case x ()
+ ((_ field)
+ #'(define-response-accessor field #f))
+ ((_ field def) (identifier? #'field)
+ #`(define* (#,(datum->syntax
+ #'field
+ (symbol-append 'response- (syntax->datum #'field)))
+ response
+ #:optional (default def))
+ (cond
+ ((assq 'field (response-headers response)) => cdr)
+ (else default)))))))
+
+;; General headers
+;;
+(define-response-accessor cache-control '())
+(define-response-accessor connection '())
+(define-response-accessor date #f)
+(define-response-accessor pragma '())
+(define-response-accessor trailer '())
+(define-response-accessor transfer-encoding '())
+(define-response-accessor upgrade '())
+(define-response-accessor via '())
+(define-response-accessor warning '())
+
+;; Entity headers
+;;
+(define-response-accessor allow '())
+(define-response-accessor content-encoding '())
+(define-response-accessor content-language '())
+(define-response-accessor content-length #f)
+(define-response-accessor content-location #f)
+(define-response-accessor content-md5 #f)
+(define-response-accessor content-range #f)
+(define-response-accessor content-type #f)
+(define-response-accessor expires #f)
+(define-response-accessor last-modified #f)
+
+;; Response headers
+;;
+(define-response-accessor accept-ranges #f)
+(define-response-accessor age #f)
+(define-response-accessor etag #f)
+(define-response-accessor location #f)
+(define-response-accessor proxy-authenticate #f)
+(define-response-accessor retry-after #f)
+(define-response-accessor server #f)
+(define-response-accessor vary '())
+(define-response-accessor www-authenticate #f)
diff --git a/module/web/toy-server.scm b/module/web/toy-server.scm
new file mode 100644
index 0000000..cfef455
--- /dev/null
+++ b/module/web/toy-server.scm
@@ -0,0 +1,137 @@
+;;; 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)
+ #: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))))
+
+;; This abuses the definition of "toy", because it's really
+;; terrible. Not even fit for children. The FIXME is to handle errors
+;; while reading the request and writing the response, not only errors
+;; in the handler.
+;;
+(define (serve-client handler sock addr)
+ (let* ((req (read-request sock))
+ (body-str (read-request-body/latin-1 req)))
+ (call-with-values (lambda ()
+ (catch #t
+ (lambda ()
+ (handler req body-str))
+ (lambda (k . args)
+ (if (eq? k 'interrupt)
+ (apply throw k args)
+ (begin
+ (warn "Error while serving client" k args)
+ (build-response #:code 500))))))
+ (lambda* (response #:optional body)
+ (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)))))))
+ (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)
+ #f))
+ (lp (accept-new-client server-socket))))))
diff --git a/module/web/uri.scm b/module/web/uri.scm
index 600e19a..519c691 100644
--- a/module/web/uri.scm
+++ b/module/web/uri.scm
@@ -50,26 +50,29 @@
(query uri-query)
(fragment uri-fragment))
+(define (uri-error message . args)
+ (throw 'uri-error message args))
+
(define (positive-exact-integer? port)
(and (number? port) (exact? port) (integer? port) (positive? port)))
(define (validate-uri scheme userinfo host port path query fragment)
(cond
((not (symbol? scheme))
- (error "expected a symbol for the URI scheme" scheme))
+ (uri-error "Expected a symbol for the URI scheme: ~s" scheme))
((and (or userinfo port) (not host))
- (error "expected host, given userinfo or port"))
+ (uri-error "Expected a host, given userinfo or port"))
((and port (not (positive-exact-integer? port)))
- (error "expected integer port" port))
+ (uri-error "Expected port to be an integer: ~s" port))
((and host (or (not (string? host)) (not (valid-host? host))))
- (error "expected valid host" host))
+ (uri-error "Expected valid host: ~s" host))
((and userinfo (not (string? userinfo)))
- (error "expected string for userinfo" userinfo))
+ (uri-error "Expected string for userinfo: ~s" userinfo))
((not (string? path))
- (error "expected string for path" path))
+ (uri-error "Expected string for path: ~s" path))
((and host (not (string-null? path))
(not (eqv? (string-ref path 0) #\/)))
- (error "expected path of absolute URI to start with a /" path))))
+ (uri-error "Expected path of absolute URI to start with a /: ~a" path))))
(define* (build-uri scheme #:key userinfo host port (path "") query fragment
(validate? #t))
@@ -222,7 +225,7 @@
((case charset
((utf-8) utf8->string)
((#f) (lambda (x) x)) ; raw bytevector
- (else (error "unknown charset" charset)))
+ (else (uri-error "Unknown charset: ~s" charset)))
(get-bytevector))
(let ((ch (string-ref str i)))
(cond
@@ -242,7 +245,8 @@
(put-u8 port (char->integer ch))
(lp (1+ i)))
(else
- (error "invalid character in encoded URI" str ch))))))))))
+ (uri-error "Invalid character in encoded URI ~a: ~s"
+ str ch))))))))))
(define ascii-alnum-chars
(string->char-set
@@ -272,7 +276,7 @@
((case charset
((utf-8) utf8->string)
((#f) (lambda (x) x)) ; raw bytevector
- (else (error "unknown charset" charset)))
+ (else (uri-error "Unknown charset: ~s" charset)))
(call-with-values open-bytevector-output-port
(lambda (port get-bytevector)
(string-for-each
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 0fe9c85..7ca4c54 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -150,6 +150,9 @@ SCM_TESTS = tests/00-initial-env.test \
tests/version.test \
tests/vlist.test \
tests/weaks.test \
+ tests/web-http.test \
+ tests/web-request.test \
+ tests/web-response.test \
tests/web-uri.test
EXTRA_DIST = \
diff --git a/test-suite/tests/web-http.test b/test-suite/tests/web-http.test
new file mode 100644
index 0000000..dfc181c
--- /dev/null
+++ b/test-suite/tests/web-http.test
@@ -0,0 +1,202 @@
+;;;; web-uri.test --- URI library -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;; 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
+
+
+(define-module (test-suite web-http)
+ #:use-module (web uri)
+ #:use-module (web http)
+ #:use-module (ice-9 regex)
+ #:use-module (ice-9 control)
+ #:use-module (srfi srfi-19)
+ #:use-module (test-suite lib))
+
+
+(define-syntax pass-if-named-exception
+ (syntax-rules ()
+ ((_ name k pat exp)
+ (pass-if name
+ (catch 'k
+ (lambda () exp (error "expected exception" 'k))
+ (lambda (k message args)
+ (if (string-match pat message)
+ #t
+ (error "unexpected exception" message args))))))))
+
+(define-syntax pass-if-parse
+ (syntax-rules ()
+ ((_ sym str val)
+ (pass-if (format #f "~a: ~s -> ~s" 'sym str val)
+ (call-with-values (lambda () (parse-header (symbol->string 'sym) str))
+ (lambda (k v)
+ (equal? v val)))))))
+
+(define-syntax pass-if-any-error
+ (syntax-rules ()
+ ((_ sym str)
+ (pass-if (format #f "~a: ~s -> any error" 'sym str)
+ (% (catch #t
+ (lambda ()
+ (parse-header (symbol->string 'sym) str)
+ (abort (lambda () (error "expected exception"))))
+ (lambda (k . args)
+ #t))
+ (lambda (k thunk)
+ (thunk)))))))
+
+(define-syntax pass-if-parse-error
+ (syntax-rules ()
+ ((_ sym str expected-component)
+ (pass-if (format #f "~a: ~s -> ~a error" 'sym str 'expected-component)
+ (catch 'bad-header
+ (lambda ()
+ (parse-header (symbol->string 'sym) str)
+ (error "expected exception" 'expected-component))
+ (lambda (k component arg)
+ (if (or (not 'expected-component)
+ (eq? 'expected-component component))
+ #t
+ (error "unexpected exception" component arg))))))))
+
+(with-test-prefix "general headers"
+
+ (pass-if-parse cache-control "no-transform" '(no-transform))
+ (pass-if-parse cache-control "no-transform,foo" '(no-transform "foo"))
+ (pass-if-parse cache-control "no-cache" '((no-cache . #t)))
+ (pass-if-parse cache-control "no-cache,max-age=10"
+ '((no-cache . #t) (max-age . 10)))
+
+ (pass-if-parse connection "close" '("close"))
+ (pass-if-parse connection "close, foo" '("close" "foo"))
+
+ (pass-if-parse date "Tue, 15 Nov 1994 08:12:31 GMT"
+ (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
+ "~a, ~d ~b ~Y ~H:~M:~S ~z"))
+ (pass-if-parse-error date "Tue, 15 Nov 1994 08:12:31 EST" date)
+ (pass-if-any-error date "Tue, 15 Qux 1994 08:12:31 EST")
+
+ (pass-if-parse pragma "no-cache" '(no-cache))
+ (pass-if-parse pragma "no-cache, foo" '(no-cache "foo"))
+
+ (pass-if-parse trailer "foo, bar" '("foo" "bar"))
+
+ (pass-if-parse transfer-encoding "foo, chunked" '(("foo") (chunked)))
+
+ (pass-if-parse upgrade "qux" '("qux"))
+
+ (pass-if-parse via "xyzzy" '("xyzzy"))
+
+ (pass-if-parse warning "123 foo \"core breach imminent\""
+ '((123 "foo" "core breach imminent" #f)))
+ (pass-if-parse
+ warning
+ "123 foo \"core breach imminent\" \"Tue, 15 Nov 1994 08:12:31 GMT\""
+ `((123 "foo" "core breach imminent"
+ ,(string->date "Tue, 15 Nov 1994 08:12:31 +0000"
+ "~a, ~d ~b ~Y ~H:~M:~S ~z")))))
+
+(with-test-prefix "entity headers"
+ (pass-if-parse allow "foo, bar" '("foo" "bar"))
+ (pass-if-parse content-encoding "qux, baz" '("qux" "baz"))
+ (pass-if-parse content-language "qux, baz" '("qux" "baz"))
+ (pass-if-parse content-length "100" 100)
+ (pass-if-parse content-length "0" 0)
+ (pass-if-parse content-length "010" 10)
+ (pass-if-parse content-location "http://foo/";
+ (build-uri 'http #:host "foo" #:path "/"))
+ (pass-if-parse content-range "bytes 10-20/*" '(bytes (10 . 20) *))
+ (pass-if-parse content-range "bytes */*" '(bytes * *))
+ (pass-if-parse content-range "bytes */30" '(bytes * 30))
+ (pass-if-parse expires "Tue, 15 Nov 1994 08:12:31 GMT"
+ (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
+ "~a, ~d ~b ~Y ~H:~M:~S ~z"))
+ (pass-if-parse last-modified "Tue, 15 Nov 1994 08:12:31 GMT"
+ (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
+ "~a, ~d ~b ~Y ~H:~M:~S ~z")))
+
+#;
+(parse-header "accept" "text/*;q=0.3, text/html;q=0.7, text/html;level=1")
+
+#;
+(parse-header "expect" "100-continue")
+
+(with-test-prefix "request headers"
+ (pass-if-parse accept "text/*;q=0.3, text/html;q=0.7, text/html;level=1"
+ '(("text/*" (q . 300))
+ ("text/html" (q . 700))
+ ("text/html" ("level" . "1"))))
+ (pass-if-parse accept-charset "iso-8859-5, unicode-1-1;q=0.8"
+ '((1000 . "iso-8859-5") (800 . "unicode-1-1")))
+ (pass-if-parse accept-encoding "gzip;q=1.0, identity; q=0.5, *;q=0"
+ '((1000 . "gzip")
+ (500 . "identity")
+ (0 . "*")))
+ (pass-if-parse accept-language "da, en-gb;q=0.8, en;q=0.7"
+ '((1000 . "da") (800 . "en-gb") (700 . "en")))
+ (pass-if-parse authorization "foo" "foo")
+ (pass-if-parse expect "100-continue, foo" '((100-continue) ("foo")))
+ (pass-if-parse from "address@hidden" "address@hidden")
+ (pass-if-parse host "qux" '("qux" . #f))
+ (pass-if-parse host "qux:80" '("qux" . 80))
+ (pass-if-parse if-match "\"xyzzy\", W/\"qux\""
+ '(("xyzzy" . #t) ("qux" . #f)))
+ (pass-if-parse if-match "*" '*)
+ (pass-if-parse if-modified-since "Tue, 15 Nov 1994 08:12:31 GMT"
+ (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
+ "~a, ~d ~b ~Y ~H:~M:~S ~z"))
+ (pass-if-parse if-none-match "\"xyzzy\", W/\"qux\""
+ '(("xyzzy" . #t) ("qux" . #f)))
+ (pass-if-parse if-none-match "*" '*)
+ (pass-if-parse if-range "\"foo\"" '("foo" . #t))
+ (pass-if-parse if-range "Tue, 15 Nov 1994 08:12:31 GMT"
+ (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
+ "~a, ~d ~b ~Y ~H:~M:~S ~z"))
+ (pass-if-parse if-unmodified-since "Tue, 15 Nov 1994 08:12:31 GMT"
+ (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
+ "~a, ~d ~b ~Y ~H:~M:~S ~z"))
+ (pass-if-parse max-forwards "10" 10)
+ (pass-if-parse max-forwards "00" 0)
+ (pass-if-parse proxy-authorization "foo" "foo")
+ (pass-if-parse range "bytes=10-20" '(bytes (10 . 20)))
+ (pass-if-parse range "bytes=10-" '(bytes (10 . #f)))
+ (pass-if-parse range "bytes=-20" '(bytes (#f . 20)))
+ (pass-if-parse range "bytes=-20,-30" '(bytes (#f . 20) (#f . 30)))
+ (pass-if-parse referer "http://foo/bar?baz";
+ (build-uri 'http #:host "foo" #:path "/bar" #:query "baz"))
+ (pass-if-parse te "trailers" '((trailers)))
+ (pass-if-parse te "trailers,foo" '((trailers) ("foo")))
+ (pass-if-parse user-agent "guile" "guile"))
+
+
+;; Response headers
+;;
+(with-test-prefix "response headers"
+ (pass-if-parse accept-ranges "foo,bar" '("foo" "bar"))
+ (pass-if-parse age "30" 30)
+ (pass-if-parse etag "\"foo\"" '("foo" . #t))
+ (pass-if-parse etag "W/\"foo\"" '("foo" . #f))
+ (pass-if-parse location "http://other-place";
+ (build-uri 'http #:host "other-place"))
+ (pass-if-parse proxy-authenticate "ho-hum" "ho-hum")
+ (pass-if-parse retry-after "Tue, 15 Nov 1994 08:12:31 GMT"
+ (string->date "Tue, 15 Nov 1994 08:12:31 +0000"
+ "~a, ~d ~b ~Y ~H:~M:~S ~z"))
+ (pass-if-parse retry-after "20" 20)
+ (pass-if-parse server "guile!" "guile!")
+ (pass-if-parse vary "*" '*)
+ (pass-if-parse vary "foo, bar" '("foo" "bar"))
+ (pass-if-parse www-authenticate "secret" "secret"))
diff --git a/test-suite/tests/web-request.test
b/test-suite/tests/web-request.test
new file mode 100644
index 0000000..82759bd
--- /dev/null
+++ b/test-suite/tests/web-request.test
@@ -0,0 +1,84 @@
+;;;; web-request.test --- HTTP requests -*- mode: scheme; coding: utf-8;
-*-
+;;;;
+;;;; 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
+
+
+(define-module (test-suite web-request)
+ #:use-module (web uri)
+ #:use-module (web request)
+ #:use-module (test-suite lib))
+
+
+;; The newlines are equivalent to \n.
+(define example-1
+ "GET /qux HTTP/1.1\r
+Host: localhost:8080\r
+User-Agent: Mozilla/5.0 (X11; U; Linux x86_64; en-us) AppleWebKit/531.2+
(KHTML, like Gecko) Safari/531.2+ Epiphany/2.30.2\r
+Accept:
application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5\r
+Accept-Encoding: gzip\r
+Accept-Language: en-gb, en;q=0.9\r
+\r
+")
+
+(define (requests-equal? r1 r2)
+ (and (equal? (request-method r1) (request-method r2))
+ (equal? (request-uri r1) (request-uri r2))
+ (equal? (request-version r1) (request-version r2))
+ (equal? (request-headers r1) (request-headers r2))))
+
+(with-test-prefix "example-1"
+ (let ((r #f))
+ (pass-if "read-request"
+ (begin
+ (set! r (read-request (open-input-string example-1)))
+ (request? r)))
+
+ (pass-if (equal? (request-method r) 'GET))
+
+ (pass-if (equal? (request-uri r) (build-uri 'http #:path "/qux")))
+
+ (pass-if (equal? (read-request-body/latin-1 r) #f))
+ ;; Since it's #f, should be an idempotent read, so we can try
+ ;; bytevectors too
+ (pass-if (equal? (read-request-body/bytevector r) #f))
+
+ (pass-if "checking all headers"
+ (equal?
+ (request-headers r)
+ '((host . ("localhost" . 8080))
+ (user-agent . "Mozilla/5.0 (X11; U; Linux x86_64; en-us)
AppleWebKit/531.2+ (KHTML, like Gecko) Safari/531.2+ Epiphany/2.30.2")
+ (accept . (("application/xml")
+ ("application/xhtml+xml")
+ ("text/html" (q . 900))
+ ("text/plain" (q . 800))
+ ("image/png")
+ ("*/*" (q . 500))))
+ (accept-encoding . ((1000 . "gzip")))
+ (accept-language . ((1000 . "en-gb") (900 . "en"))))))
+
+ ;; works because there is no body
+ (pass-if "write then read"
+ (requests-equal? (with-input-from-string
+ (with-output-to-string
+ (lambda ()
+ (write-request r (current-output-port))))
+ (lambda ()
+ (read-request (current-input-port))))
+ r))
+
+ (pass-if "by accessor"
+ (equal? (request-accept-encoding r) '((1000 . "gzip"))))))
diff --git a/test-suite/tests/web-response.test
b/test-suite/tests/web-response.test
new file mode 100644
index 0000000..540e16d
--- /dev/null
+++ b/test-suite/tests/web-response.test
@@ -0,0 +1,99 @@
+;;;; web-response.test --- HTTP responses -*- mode: scheme; coding:
utf-8; -*-
+;;;;
+;;;; 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
+
+
+(define-module (test-suite web-response)
+ #:use-module (web uri)
+ #:use-module (web response)
+ #:use-module (srfi srfi-19)
+ #:use-module (test-suite lib))
+
+
+;; The newlines are equivalent to \n. From www.gnu.org.
+(define example-1
+ "HTTP/1.1 200 OK\r
+Date: Wed, 03 Nov 2010 22:27:07 GMT\r
+Server: Apache/2.0.55\r
+Accept-Ranges: bytes\r
+Cache-Control: max-age=543234\r
+Expires: Thu, 28 Oct 2010 15:33:13 GMT\r
+Vary: Accept-Encoding\r
+Content-Encoding: gzip\r
+Content-Length: 36\r
+Content-Type: text/html\r
+\r
+abcdefghijklmnopqrstuvwxyz0123456789")
+
+(define (responses-equal? r1 body1 r2 body2)
+ (and (equal? (response-version r1) (response-version r2))
+ (equal? (response-code r1) (response-code r2))
+ (equal? (response-reason-phrase r1) (response-reason-phrase r2))
+ (equal? (response-headers r1) (response-headers r2))
+ (equal? body1 body2)))
+
+(with-test-prefix "example-1"
+ (let ((r #f) (body #f))
+ (pass-if "read-response"
+ (begin
+ (set! r (read-response (open-input-string example-1)))
+ (response? r)))
+
+ (pass-if "read-response-body/latin-1"
+ (begin
+ (set! body (read-response-body/latin-1 r))
+ #t))
+
+ (pass-if (equal? (response-version r) '(1 . 1)))
+
+ (pass-if (equal? (response-code r) 200))
+
+ (pass-if (equal? (response-reason-phrase r) "OK"))
+
+ (pass-if (equal? body "abcdefghijklmnopqrstuvwxyz0123456789"))
+
+ (pass-if "checking all headers"
+ (equal?
+ (response-headers r)
+ `((date . ,(string->date "Wed, 03 Nov 2010 22:27:07 +0000"
+ "~a, ~d ~b ~Y ~H:~M:~S ~z"))
+ (server . "Apache/2.0.55")
+ (accept-ranges . ("bytes"))
+ (cache-control . ((max-age . 543234)))
+ (expires . ,(string->date "Thu, 28 Oct 2010 15:33:13 GMT +0000"
+ "~a, ~d ~b ~Y ~H:~M:~S ~z"))
+ (vary . ("Accept-Encoding"))
+ (content-encoding . ("gzip"))
+ (content-length . 36)
+ (content-type . ("text" "html")))))
+
+ (pass-if "write then read"
+ (call-with-values
+ (lambda ()
+ (with-input-from-string
+ (with-output-to-string
+ (lambda ()
+ (let ((r (write-response r (current-output-port))))
+ (write-response-body/latin-1 r body))))
+ (lambda ()
+ (let ((r (read-response (current-input-port))))
+ (values r (read-response-body/latin-1 r))))))
+ (lambda (r* body*)
+ (responses-equal? r body r* body*))))
+
+ (pass-if "by accessor"
+ (equal? (response-content-encoding r) '("gzip")))))
diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test
index c410a7c..832bccf 100644
--- a/test-suite/tests/web-uri.test
+++ b/test-suite/tests/web-uri.test
@@ -19,6 +19,7 @@
(define-module (test-web-uri)
#:use-module (web uri)
+ #:use-module (ice-9 regex)
#:use-module (test-suite lib))
@@ -35,7 +36,16 @@
(equal? (uri-query uri) query)
(equal? (uri-fragment uri) fragment)))
-(define ex:expected '(misc-error . "expected"))
+(define-syntax pass-if-uri-exception
+ (syntax-rules ()
+ ((_ name pat exp)
+ (pass-if name
+ (catch 'uri-error
+ (lambda () exp (error "expected uri-error exception"))
+ (lambda (k message args)
+ (if (string-match pat message)
+ #t
+ (error "unexpected uri-error exception" message args))))))))
(with-test-prefix "build-uri"
(pass-if "ftp:"
@@ -68,33 +78,33 @@
#:port 22
#:path "/baz"))
- (pass-if-exception "non-symbol scheme"
- ex:expected
- (build-uri "nonsym"))
+ (pass-if-uri-exception "non-symbol scheme"
+ "Expected.*symbol"
+ (build-uri "nonsym"))
- (pass-if-exception "http://bad.host.1";
- ex:expected
- (build-uri 'http #:host "bad.host.1"))
+ (pass-if-uri-exception "http://bad.host.1";
+ "Expected.*host"
+ (build-uri 'http #:host "bad.host.1"))
(pass-if "http://bad.host.1 (no validation)"
(uri=? (build-uri 'http #:host "bad.host.1" #:validate? #f)
#:scheme 'http #:host "bad.host.1" #:path ""))
- (pass-if-exception "http://foo:not-a-port";
- ex:expected
- (build-uri 'http #:host "foo" #:port "not-a-port"))
+ (pass-if-uri-exception "http://foo:not-a-port";
+ "Expected.*port"
+ (build-uri 'http #:host "foo" #:port "not-a-port"))
- (pass-if-exception "http://foo:10 but port as string"
- ex:expected
- (build-uri 'http #:host "foo" #:port "10"))
+ (pass-if-uri-exception "http://foo:10 but port as string"
+ "Expected.*port"
+ (build-uri 'http #:host "foo" #:port "10"))
- (pass-if-exception "http://:10";
- ex:expected
- (build-uri 'http #:port 10))
+ (pass-if-uri-exception "http://:10";
+ "Expected.*host"
+ (build-uri 'http #:port 10))
- (pass-if-exception "http://foo@";
- ex:expected
- (build-uri 'http #:userinfo "foo")))
+ (pass-if-uri-exception "http://foo@";
+ "Expected.*host"
+ (build-uri 'http #:userinfo "foo")))
(with-test-prefix "parse-uri"
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-13-28-ge414bf2,
Andy Wingo <=