;;; HTTP messages
-;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 2012, 2013 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
#: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 (ice-9 q)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (rnrs bytevectors)
#:use-module (web uri)
#:export (string->header
header->string
declare-header!
+ declare-opaque-header!
known-header?
header-parser
header-validator
read-request-line
write-request-line
read-response-line
- write-response-line))
+ write-response-line
+ make-chunked-input-port
+ make-chunked-output-port
-;;; TODO
-;;;
-;;; Look at quality lists with more insight.
-;;; Think about `accept' a bit more.
-;;;
+ http-proxy-port?
+ set-http-proxy-port?!))
(define (string->header name)
- "Parse @var{name} to a symbolic header name."
+ "Parse NAME to a symbolic header name."
(string->symbol (string-downcase name)))
(define-record-type <header-decl>
validator
writer
#:key multiple?)
- "Define a parser, validator, and writer for the HTTP header, @var{name}.
-
-@var{parser} should be a procedure that takes a string and returns a
-Scheme value. @var{validator} is a predicate for whether the given
-Scheme value is valid for this header. @var{writer} takes a value and a
-port, and writes the value to the port."
+ "Declare a parser, validator, and writer for a given header."
(if (and (string? name) parser validator writer)
(let ((decl (make-header-decl name parser validator writer multiple?)))
(hashq-set! *declared-headers* (string->header name) decl)
(error "bad header decl" name parser validator writer multiple?)))
(define (header->string sym)
- "Return the string form for the header named @var{sym}."
+ "Return the string form for the header named SYM."
(let ((decl (lookup-header-decl sym)))
(if decl
(header-decl-name decl)
(string-titlecase (symbol->string sym)))))
(define (known-header? sym)
- "Return @code{#t} if there are parsers and writers registered for this
-header, otherwise @code{#f}."
+ "Return ‘#t’ iff SYM is a known header, with associated
+parsers and serialization procedures."
(and (lookup-header-decl sym) #t))
(define (header-parser sym)
- "Returns a procedure to parse values for the given header."
+ "Return the value parser for headers named SYM. The result is a
+procedure that takes one argument, a string, and returns the parsed
+value. If the header isn't known to Guile, a default parser is returned
+that passes through the string unchanged."
(let ((decl (lookup-header-decl sym)))
(if decl
(header-decl-parser decl)
(lambda (x) x))))
(define (header-validator sym)
- "Returns a procedure to validate values for the given header."
+ "Return a predicate which returns ‘#t’ if the given value is valid
+for headers named SYM. The default validator for unknown headers
+is ‘string?’."
(let ((decl (lookup-header-decl sym)))
(if decl
(header-decl-validator decl)
string?)))
(define (header-writer sym)
- "Returns a procedure to write values for the given header to a given
-port."
+ "Return a procedure that writes values for headers named SYM to a
+port. The resulting procedure takes two arguments: a value and a port.
+The default writer is ‘display’."
(let ((decl (lookup-header-decl sym)))
(if decl
(header-decl-writer decl)
(define *eof* (call-with-input-string "" read))
(define (read-header port)
- "Reads one HTTP header from @var{port}. Returns two values: the header
+ "Read one HTTP header from PORT. Return two values: the header
name and the parsed Scheme value. May raise an exception if the header
was known but the value was invalid.
sym
(read-continuation-line
port
- (string-trim-both line char-whitespace? (1+ delim)))))))))
+ (string-trim-both line char-set:whitespace (1+ delim)))))))))
(define (parse-header sym val)
- "Parse @var{val}, a string, with the parser registered for the header
-named @var{sym}.
-
-Returns the parsed value. If a parser was not found, the value is
-returned as a string."
+ "Parse VAL, a string, with the parser registered for the header
+named SYM. Returns the parsed value."
((header-parser sym) val))
(define (valid-header? sym val)
- "Returns a true value iff @var{val} is a valid Scheme value for the
-header with name @var{sym}."
+ "Returns a true value iff VAL is a valid Scheme value for the
+header with name SYM."
(if (symbol? sym)
((header-validator sym) val)
(error "header name not a symbol" sym)))
(define (write-header sym val port)
- "Writes the given header name and value to @var{port}. If @var{sym}
-is a known header, uses the specific writer registered for that header.
-Otherwise the value is written using @var{display}."
+ "Write the given header name and value to PORT, using the writer
+from ‘header-writer’."
(display (header->string sym) port)
(display ": " port)
((header-writer sym) val port)
(display "\r\n" port))
(define (read-headers port)
- "Read an HTTP message from @var{port}, returning the headers as an
-ordered alist."
+ "Read the headers of an HTTP message from PORT, returning them
+as an ordered alist."
(let lp ((headers '()))
(call-with-values (lambda () (read-header port))
(lambda (k v)
(lp (acons k v headers)))))))
(define (write-headers headers port)
- "Write the given header alist to @var{port}. Doesn't write the final
-\\r\\n, as the user might want to add another header."
+ "Write the given header alist to PORT. Doesn't write the final
+‘\\r\\n’, as the user might want to add another header."
(let lp ((headers headers))
(if (pair? headers)
(begin
(define (bad-header sym val)
(throw 'bad-header sym val))
(define (bad-header-component sym val)
- (throw 'bad-header sym val))
+ (throw 'bad-header-component sym val))
+
+(define (bad-header-printer port key args default-printer)
+ (apply (case-lambda
+ ((sym val)
+ (format port "Bad ~a header: ~a\n" (header->string sym) val))
+ (_ (default-printer)))
+ args))
+(define (bad-header-component-printer port key args default-printer)
+ (apply (case-lambda
+ ((sym val)
+ (format port "Bad ~a header component: ~a\n" sym val))
+ (_ (default-printer)))
+ args))
+(set-exception-printer! 'bad-header bad-header-printer)
+(set-exception-printer! 'bad-header-component bad-header-component-printer)
(define (parse-opaque-string str)
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))))
+ (tok (string-trim-both str char-set:whitespace i (or idx end))))
(cons tok (split-and-trim str delim (if idx (1+ idx) end) end)))
'())))
(cond
((string-rindex part #\;)
=> (lambda (idx)
- (let ((qpart (string-trim-both part char-whitespace? (1+ idx))))
+ (let ((qpart (string-trim-both part char-set:whitespace (1+ idx))))
(if (string-prefix? "q=" qpart)
(cons (parse-quality qpart 2)
- (string-trim-both part char-whitespace? 0 idx))
+ (string-trim-both part char-set:whitespace 0 idx))
(bad-header-component 'quality qpart)))))
(else
- (cons 1000 (string-trim-both part char-whitespace?)))))
+ (cons 1000 (string-trim-both part char-set:whitespace)))))
(string-split str #\,)))
(define (validate-quality-list l)
val)
(define (default-val-validator k val)
- (string? val))
+ (or (not val) (string? val)))
(define (default-val-writer k val port)
(if (or (string-index val #\;)
((pair? elt)
(let ((k (car elt))
(v (cdr elt)))
- (and (or (string? k) (symbol? k))
+ (and (symbol? k)
(valid? k v))))
- ((or (string? elt) (symbol? elt))
+ ((symbol? elt)
(valid? elt #f))
(else #f)))))
;; param-component = token [ "=" (token | quoted-string) ] \
;; *(";" token [ "=" (token | quoted-string) ])
;;
+(define param-delimiters (char-set #\, #\; #\=))
+(define param-value-delimiters (char-set-adjoin char-set:whitespace #\, #\;))
(define* (parse-param-component str #:optional
(val-parser default-val-parser)
(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 ((delim (string-index str param-delimiters i)))
(let ((k (string->symbol
(substring str i (trim-whitespace str i (or delim end)))))
(delimc (and delim (string-ref str delim))))
(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)
+ (or (string-index str param-value-delimiters
+ i end)
end)))
(values (substring str i delim)
delim)))))
(valid? default-val-validator))
(list-of? list
(lambda (elt)
- (key-value-list? list valid?))))
+ (key-value-list? elt valid?))))
(define* (write-param-list list port #:optional
(val-writer default-val-writer))
(write-key-value-list item port val-writer ";"))
","))
+(define-syntax string-match?
+ (lambda (x)
+ (syntax-case x ()
+ ((_ str pat) (string? (syntax->datum #'pat))
+ (let ((p (syntax->datum #'pat)))
+ #`(let ((s str))
+ (and
+ (= (string-length s) #,(string-length p))
+ #,@(let lp ((i 0) (tests '()))
+ (if (< i (string-length p))
+ (let ((c (string-ref p i)))
+ (lp (1+ i)
+ (case c
+ ((#\.) ; Whatever.
+ tests)
+ ((#\d) ; Digit.
+ (cons #`(char-numeric? (string-ref s #,i))
+ tests))
+ ((#\a) ; Alphabetic.
+ (cons #`(char-alphabetic? (string-ref s #,i))
+ tests))
+ (else ; Literal.
+ (cons #`(eqv? (string-ref s #,i) #,c)
+ tests)))))
+ tests)))))))))
+
+;; "Jan" | "Feb" | "Mar" | "Apr" | "May" | "Jun"
+;; "Jul" | "Aug" | "Sep" | "Oct" | "Nov" | "Dec"
+
+(define (parse-month str start end)
+ (define (bad)
+ (bad-header-component 'month (substring str start end)))
+ (if (not (= (- end start) 3))
+ (bad)
+ (let ((a (string-ref str (+ start 0)))
+ (b (string-ref str (+ start 1)))
+ (c (string-ref str (+ start 2))))
+ (case a
+ ((#\J)
+ (case b
+ ((#\a) (case c ((#\n) 1) (else (bad))))
+ ((#\u) (case c ((#\n) 6) ((#\l) 7) (else (bad))))
+ (else (bad))))
+ ((#\F)
+ (case b
+ ((#\e) (case c ((#\b) 2) (else (bad))))
+ (else (bad))))
+ ((#\M)
+ (case b
+ ((#\a) (case c ((#\r) 3) ((#\y) 5) (else (bad))))
+ (else (bad))))
+ ((#\A)
+ (case b
+ ((#\p) (case c ((#\r) 4) (else (bad))))
+ ((#\u) (case c ((#\g) 8) (else (bad))))
+ (else (bad))))
+ ((#\S)
+ (case b
+ ((#\e) (case c ((#\p) 9) (else (bad))))
+ (else (bad))))
+ ((#\O)
+ (case b
+ ((#\c) (case c ((#\t) 10) (else (bad))))
+ (else (bad))))
+ ((#\N)
+ (case b
+ ((#\o) (case c ((#\v) 11) (else (bad))))
+ (else (bad))))
+ ((#\D)
+ (case b
+ ((#\e) (case c ((#\c) 12) (else (bad))))
+ (else (bad))))
+ (else (bad))))))
+
+;; "GMT" | "+" 4DIGIT | "-" 4DIGIT
+;;
+;; RFC 2616 requires date values to use "GMT", but recommends accepting
+;; the others as they are commonly generated by e.g. RFC 822 sources.
+(define (parse-zone-offset str start)
+ (let ((s (substring str start)))
+ (define (bad)
+ (bad-header-component 'zone-offset s))
+ (cond
+ ((string=? s "GMT")
+ 0)
+ ((string-match? s ".dddd")
+ (let ((sign (case (string-ref s 0)
+ ((#\+) +1)
+ ((#\-) -1)
+ (else (bad))))
+ (hours (parse-non-negative-integer s 1 3))
+ (minutes (parse-non-negative-integer s 3 5)))
+ (* sign 60 (+ (* 60 hours) minutes)))) ; seconds east of Greenwich
+ (else (bad)))))
+
+;; RFC 822, updated by RFC 1123
+;;
+;; Sun, 06 Nov 1994 08:49:37 GMT
+;; 01234567890123456789012345678
+;; 0 1 2
+(define (parse-rfc-822-date str space zone-offset)
+ ;; We could verify the day of the week but we don't.
+ (cond ((string-match? (substring str 0 space) "aaa, dd aaa dddd dd:dd:dd")
+ (let ((date (parse-non-negative-integer str 5 7))
+ (month (parse-month str 8 11))
+ (year (parse-non-negative-integer str 12 16))
+ (hour (parse-non-negative-integer str 17 19))
+ (minute (parse-non-negative-integer str 20 22))
+ (second (parse-non-negative-integer str 23 25)))
+ (make-date 0 second minute hour date month year zone-offset)))
+ ((string-match? (substring str 0 space) "aaa, d aaa dddd dd:dd:dd")
+ (let ((date (parse-non-negative-integer str 5 6))
+ (month (parse-month str 7 10))
+ (year (parse-non-negative-integer str 11 15))
+ (hour (parse-non-negative-integer str 16 18))
+ (minute (parse-non-negative-integer str 19 21))
+ (second (parse-non-negative-integer str 22 24)))
+ (make-date 0 second minute hour date month year zone-offset)))
+ (else
+ (bad-header 'date str) ; prevent tail call
+ #f)))
+
+;; RFC 850, updated by RFC 1036
+;; Sunday, 06-Nov-94 08:49:37 GMT
+;; 0123456789012345678901
+;; 0 1 2
+(define (parse-rfc-850-date str comma space zone-offset)
+ ;; We could verify the day of the week but we don't.
+ (let ((tail (substring str (1+ comma) space)))
+ (if (not (string-match? tail " dd-aaa-dd dd:dd:dd"))
+ (bad-header 'date str))
+ (let ((date (parse-non-negative-integer tail 1 3))
+ (month (parse-month tail 4 7))
+ (year (parse-non-negative-integer tail 8 10))
+ (hour (parse-non-negative-integer tail 11 13))
+ (minute (parse-non-negative-integer tail 14 16))
+ (second (parse-non-negative-integer tail 17 19)))
+ (make-date 0 second minute hour date month
+ (let* ((now (date-year (current-date)))
+ (then (+ now year (- (modulo now 100)))))
+ (cond ((< (+ then 50) now) (+ then 100))
+ ((< (+ now 50) then) (- then 100))
+ (else then)))
+ zone-offset))))
+
+;; ANSI C's asctime() format
+;; Sun Nov 6 08:49:37 1994
+;; 012345678901234567890123
+;; 0 1 2
+(define (parse-asctime-date str)
+ (if (not (string-match? str "aaa aaa .d dd:dd:dd dddd"))
+ (bad-header 'date str))
+ (let ((date (parse-non-negative-integer
+ str
+ (if (eqv? (string-ref str 8) #\space) 9 8)
+ 10))
+ (month (parse-month str 4 7))
+ (year (parse-non-negative-integer str 20 24))
+ (hour (parse-non-negative-integer str 11 13))
+ (minute (parse-non-negative-integer str 14 16))
+ (second (parse-non-negative-integer str 17 19)))
+ (make-date 0 second minute hour date month year 0)))
+
+;; Convert all date values to GMT time zone, as per RFC 2616 appendix C.
+(define (normalize-date date)
+ (if (zero? (date-zone-offset date))
+ date
+ (time-utc->date (date->time-utc date) 0)))
+
(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"))
+ (let* ((space (string-rindex str #\space))
+ (zone-offset (and space (false-if-exception
+ (parse-zone-offset str (1+ space))))))
+ (normalize-date
+ (if zone-offset
+ (let ((comma (string-index str #\,)))
+ (cond ((not comma) (bad-header 'date str))
+ ((= comma 3) (parse-rfc-822-date str space zone-offset))
+ (else (parse-rfc-850-date str comma space zone-offset))))
+ (parse-asctime-date str)))))
(define (write-date date port)
- (display (date->string date "~a, ~d ~b ~Y ~H:~M:~S GMT") port))
-
-(define (write-uri uri port)
- (display (uri->string uri) port))
+ (define (display-digits n digits port)
+ (define zero (char->integer #\0))
+ (let lp ((tens (expt 10 (1- digits))))
+ (if (> tens 0)
+ (begin
+ (display (integer->char (+ zero (modulo (truncate/ n tens) 10)))
+ port)
+ (lp (floor/ tens 10))))))
+ (let ((date (if (zero? (date-zone-offset date))
+ date
+ (time-tai->date (date->time-tai date) 0))))
+ (display (case (date-week-day date)
+ ((0) "Sun, ") ((1) "Mon, ") ((2) "Tue, ")
+ ((3) "Wed, ") ((4) "Thu, ") ((5) "Fri, ")
+ ((6) "Sat, ") (else (error "bad date" date)))
+ port)
+ (display-digits (date-day date) 2 port)
+ (display (case (date-month date)
+ ((1) " Jan ") ((2) " Feb ") ((3) " Mar ")
+ ((4) " Apr ") ((5) " May ") ((6) " Jun ")
+ ((7) " Jul ") ((8) " Aug ") ((9) " Sep ")
+ ((10) " Oct ") ((11) " Nov ") ((12) " Dec ")
+ (else (error "bad date" date)))
+ port)
+ (display-digits (date-year date) 4 port)
+ (display #\space port)
+ (display-digits (date-hour date) 2 port)
+ (display #\: port)
+ (display-digits (date-minute date) 2 port)
+ (display #\: port)
+ (display-digits (date-second date) 2 port)
+ (display " GMT" port)))
(define (parse-entity-tag val)
(if (string-prefix? "W/" val)
(define (write-entity-tag-list val port)
(write-list val port write-entity-tag ", "))
+;; credentials = auth-scheme #auth-param
+;; auth-scheme = token
+;; auth-param = token "=" ( token | quoted-string )
+;;
+;; That's what the spec says. In reality the Basic scheme doesn't have
+;; k-v pairs, just one auth token, so we give that token as a string.
+;;
+(define* (parse-credentials str #:optional (val-parser default-val-parser)
+ (start 0) (end (string-length str)))
+ (let* ((start (skip-whitespace str start end))
+ (delim (or (string-index str char-set:whitespace start end) end)))
+ (if (= start end)
+ (bad-header-component 'authorization str))
+ (let ((scheme (string->symbol
+ (string-downcase (substring str start (or delim end))))))
+ (case scheme
+ ((basic)
+ (let* ((start (skip-whitespace str delim end)))
+ (if (< start end)
+ (cons scheme (substring str start end))
+ (bad-header-component 'credentials str))))
+ (else
+ (cons scheme (parse-key-value-list str default-val-parser delim end)))))))
+
+(define (validate-credentials val)
+ (and (pair? val) (symbol? (car val))
+ (case (car val)
+ ((basic) (string? (cdr val)))
+ (else (key-value-list? (cdr val))))))
+
+(define (write-credentials val port)
+ (display (car val) port)
+ (if (pair? (cdr val))
+ (begin
+ (display #\space port)
+ (write-key-value-list (cdr val) port))))
+
+;; challenges = 1#challenge
+;; challenge = auth-scheme 1*SP 1#auth-param
+;;
+;; A pain to parse, as both challenges and auth params are delimited by
+;; commas, and qstrings can contain anything. We rely on auth params
+;; necessarily having "=" in them.
+;;
+(define* (parse-challenge str #:optional
+ (start 0) (end (string-length str)))
+ (let* ((start (skip-whitespace str start end))
+ (sp (string-index str #\space start end))
+ (scheme (if sp
+ (string->symbol (string-downcase (substring str start sp)))
+ (bad-header-component 'challenge str))))
+ (let lp ((i sp) (out (list scheme)))
+ (if (not (< i end))
+ (values (reverse! out) end)
+ (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)))
+ (token-end (trim-whitespace str i delim)))
+ (if (string-index str #\space i token-end)
+ (values (reverse! out) i)
+ (let ((k (string->symbol (substring str i token-end))))
+ (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 next-i)
+ (let ((i (skip-whitespace str next-i end)))
+ (if (or (= i end) (eqv? (string-ref str i) #\,))
+ (lp (1+ i) (cons (if v (cons k v) k) out))
+ (bad-header-component
+ 'challenge
+ (substring str start end)))))))))))))
+
+(define* (parse-challenges str #:optional (val-parser default-val-parser)
+ (start 0) (end (string-length str)))
+ (let lp ((i start) (ret '()))
+ (let ((i (skip-whitespace str i end)))
+ (if (< i end)
+ (call-with-values (lambda () (parse-challenge str i end))
+ (lambda (challenge i)
+ (lp i (cons challenge ret))))
+ (reverse ret)))))
+
+(define (validate-challenges val)
+ (list-of? val (lambda (x)
+ (and (pair? x) (symbol? (car x))
+ (key-value-list? (cdr x))))))
+
+(define (write-challenge val port)
+ (display (car val) port)
+ (display #\space port)
+ (write-key-value-list (cdr val) port))
+
+(define (write-challenges val port)
+ (write-list val port write-challenge ", "))
+
\f
(define *known-versions* '())
(define* (parse-http-version str #:optional (start 0) (end (string-length str)))
- "Parse an HTTP version from @var{str}, returning it as a major-minor
-pair. For example, @code{HTTP/1.1} parses as the pair of integers,
-@code{(1 . 1)}."
+ "Parse an HTTP version from STR, returning it as a major–minor
+pair. For example, ‘HTTP/1.1’ parses as the pair of integers,
+‘(1 . 1)’."
(or (let lp ((known *known-versions*))
(and (pair? known)
(if (string= str (caar known) start end)
(bad-header-component 'http-version (substring str start end))))))
(define (write-http-version val port)
- "Write the given major-minor version pair to @var{port}."
+ "Write the given major-minor version pair to PORT."
(display "HTTP/" port)
(display (car val) port)
(display #\. port)
;; ourselves the trouble of that case, and disallow the CONNECT method.
;;
(define* (parse-http-method str #:optional (start 0) (end (string-length str)))
- "Parse an HTTP method from @var{str}. The result is an upper-case
-symbol, like @code{GET}."
+ "Parse an HTTP method from STR. The result is an upper-case
+symbol, like ‘GET’."
(cond
((string= str "GET" start end) 'GET)
((string= str "HEAD" start end) 'HEAD)
(bad-request "Invalid URI: ~a" (substring str start end))))))
(define (read-request-line port)
- "Read the first line of an HTTP request from @var{port}, returning
+ "Read the first line of an HTTP request from PORT, returning
three values: the method, the URI, and the version."
(let* ((line (read-line* port))
- (d0 (string-index line char-whitespace?)) ; "delimiter zero"
- (d1 (string-rindex line char-whitespace?)))
+ (d0 (string-index line char-set:whitespace)) ; "delimiter zero"
+ (d1 (string-rindex line char-set:whitespace)))
(if (and d0 d1 (< d0 d1))
(values (parse-http-method line 0 d0)
(parse-request-uri line (skip-whitespace line (1+ d0) d1) d1)
(display (uri-query uri) port))))
(define (write-request-line method uri version port)
- "Write the first line of an HTTP request to @var{port}."
+ "Write the first line of an HTTP request to PORT."
(display method port)
(display #\space port)
- (write-uri uri port)
+ (when (http-proxy-port? port)
+ (let ((scheme (uri-scheme uri))
+ (host (uri-host uri))
+ (host-port (uri-port uri)))
+ (when (and scheme host)
+ (display scheme port)
+ (display "://" port)
+ (if (string-index host #\:)
+ (begin (display #\[ port)
+ (display host port)
+ (display #\] port))
+ (display host port))
+ (unless ((@@ (web uri) default-port?) scheme host-port)
+ (display #\: port)
+ (display host-port port)))))
+ (let ((path (uri-path uri))
+ (query (uri-query uri)))
+ (if (not (string-null? path))
+ (display path port))
+ (if query
+ (begin
+ (display "?" port)
+ (display query port)))
+ (if (and (string-null? path)
+ (not query))
+ ;; Make sure we display something.
+ (display "/" port)))
(display #\space port)
(write-http-version version port)
(display "\r\n" port))
(define (read-response-line port)
- "Read the first line of an HTTP response from @var{port}, returning
+ "Read the first line of an HTTP response from PORT, returning
three values: the HTTP version, the response code, and the \"reason
phrase\"."
(let* ((line (read-line* port))
- (d0 (string-index line char-whitespace?)) ; "delimiter zero"
- (d1 (and d0 (string-index line char-whitespace?
+ (d0 (string-index line char-set:whitespace)) ; "delimiter zero"
+ (d1 (and d0 (string-index line char-set: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))
+ (string-trim-both line char-set:whitespace d1))
(bad-response "Bad Response-Line: ~s" line))))
(define (write-response-line version code reason-phrase port)
- "Write the first line of an HTTP response to @var{port}."
+ "Write the first line of an HTTP response to PORT."
(write-http-version version port)
(display #\space port)
(display code port)
;; emacs: (put 'declare-header! 'scheme-indent-function 1)
;; emacs: (put 'declare-opaque!-header 'scheme-indent-function 1)
(define (declare-opaque-header! name)
+ "Declares a given header as \"opaque\", meaning that its value is not
+treated specially, and is just returned as a plain string."
(declare-header! name
parse-opaque-string validate-opaque-string write-opaque-string))
(declare-header! name
split-and-trim list-of-strings? write-list-of-strings))
+;; emacs: (put 'declare-symbol-list-header! 'scheme-indent-function 1)
+(define (declare-symbol-list-header! name)
+ (declare-header! name
+ (lambda (str)
+ (map string->symbol (split-and-trim str)))
+ (lambda (v)
+ (list-of? v symbol?))
+ (lambda (v port)
+ (write-list v port display ", "))))
+
;; emacs: (put 'declare-header-list-header! 'scheme-indent-function 1)
(define (declare-header-list-header! name)
(declare-header! name
(define (declare-uri-header! name)
(declare-header! name
(lambda (str) (or (string->uri str) (bad-header-component 'uri str)))
+ (@@ (web uri) absolute-uri?)
+ write-uri))
+
+;; emacs: (put 'declare-relative-uri-header! 'scheme-indent-function 1)
+(define (declare-relative-uri-header! name)
+ (declare-header! name
+ (lambda (str)
+ (or ((@@ (web uri) string->uri*) str)
+ (bad-header-component 'uri str)))
uri?
write-uri))
(display "*" port)
(write-entity-tag-list val port)))))
+;; emacs: (put 'declare-credentials-header! 'scheme-indent-function 1)
+(define (declare-credentials-header! name)
+ (declare-header! name
+ parse-credentials validate-credentials write-credentials))
+
+;; emacs: (put 'declare-challenge-list-header! 'scheme-indent-function 1)
+(define (declare-challenge-list-header! name)
+ (declare-header! name
+ parse-challenges validate-challenges write-challenges))
+
\f
(declare-key-value-list-header! "Cache-Control"
(lambda (k v-str)
(case k
- ((max-age max-stale min-fresh s-maxage)
+ ((max-age min-fresh s-maxage)
(parse-non-negative-integer v-str))
+ ((max-stale)
+ (and v-str (parse-non-negative-integer v-str)))
((private no-cache)
(and v-str (split-header-names v-str)))
(else v-str)))
- default-val-validator
+ (lambda (k v)
+ (case k
+ ((max-age min-fresh s-maxage)
+ (non-negative-integer? v))
+ ((max-stale)
+ (or (not v) (non-negative-integer? v)))
+ ((private no-cache)
+ (or (not v) (list-of-header-names? v)))
+ ((no-store no-transform only-if-cache must-revalidate proxy-revalidate)
+ (not v))
+ (else
+ (or (not v) (string? v)))))
(lambda (k v port)
(cond
- ((string? v) (display v port))
+ ((string? v) (default-val-writer k v port))
((pair? v)
(display #\" port)
(write-header-list v port)
;; Connection = "Connection" ":" 1#(connection-token)
;; connection-token = token
;; e.g.
-;; Connection: close, foo-header
+;; Connection: close, Foo-Header
;;
-(declare-string-list-header! "Connection")
+(declare-header! "Connection"
+ split-header-names
+ list-of-header-names?
+ (lambda (val port)
+ (write-list val port
+ (lambda (x port)
+ (display (if (eq? x 'close)
+ "close"
+ (header->string x))
+ port))
+ ", ")))
;; Date = "Date" ":" HTTP-date
;; e.g.
;; Allow = #Method
;;
-(declare-string-list-header! "Allow")
+(declare-symbol-list-header! "Allow")
;; Content-Encoding = 1#content-coding
;;
-(declare-string-list-header! "Content-Encoding")
+(declare-symbol-list-header! "Content-Encoding")
;; Content-Language = 1#language-tag
;;
;; Content-Location = ( absoluteURI | relativeURI )
;;
-(declare-uri-header! "Content-Location")
+(declare-relative-uri-header! "Content-Location")
;; Content-MD5 = <base64 of 128 bit MD5 digest as per RFC 1864>
;;
(map (lambda (x)
(let ((eq (string-index x #\=)))
(if (and eq (= eq (string-rindex x #\=)))
- (cons (string->symbol
- (string-trim x char-whitespace? 0 eq))
- (string-trim-right x char-whitespace? (1+ eq)))
+ (cons
+ (string->symbol
+ (string-trim x char-set:whitespace 0 eq))
+ (string-trim-right x char-set:whitespace (1+ eq)))
(bad-header 'content-type str))))
(cdr parts)))))
(lambda (val)
;; Expires = HTTP-date
;;
-(declare-date-header! "Expires")
+(define *date-in-the-past* (parse-date "Thu, 01 Jan 1970 00:00:00 GMT"))
+
+(declare-header! "Expires"
+ (lambda (str)
+ (if (member str '("0" "-1"))
+ *date-in-the-past*
+ (parse-date str)))
+ date?
+ write-date)
;; Last-Modified = HTTP-date
;;
(lambda (k v)
(if (eq? k 'q)
(valid-quality? v)
- (string? v)))
+ (or (not v) (string? v))))
(lambda (k v port)
(if (eq? k 'q)
(write-quality v port)
(declare-quality-list-header! "Accept-Language")
;; Authorization = credentials
+;; credentials = auth-scheme #auth-param
+;; auth-scheme = token
+;; auth-param = token "=" ( token | quoted-string )
;;
-;; Authorization is basically opaque to this HTTP stack, we just pass
-;; the string value through.
-;;
-(declare-opaque-header! "Authorization")
+(declare-credentials-header! "Authorization")
;; Expect = 1#expectation
;; expectation = "100-continue" | expectation-extension
;;
(declare-header! "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))))
+ (let* ((rbracket (string-index str #\]))
+ (colon (string-index str #\: (or rbracket 0)))
+ (host (cond
+ (rbracket
+ (unless (eqv? (string-ref str 0) #\[)
+ (bad-header 'host str))
+ (substring str 1 rbracket))
+ (colon
+ (substring str 0 colon))
+ (else
+ str)))
+ (port (and colon
+ (parse-non-negative-integer str (1+ colon)))))
+ (cons host port)))
(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 (string-index (car val) #\:)
+ (begin
+ (display #\[ port)
+ (display (car val) port)
+ (display #\] port))
+ (display (car val) port))
(if (cdr val)
(begin
(display #\: port)
;; Proxy-Authorization = credentials
;;
-(declare-opaque-header! "Proxy-Authorization")
+(declare-credentials-header! "Proxy-Authorization")
;; Range = "Range" ":" ranges-specifier
;; ranges-specifier = byte-ranges-specifier
;; Referer = ( absoluteURI | relativeURI )
;;
-(declare-uri-header! "Referer")
+(declare-relative-uri-header! "Referer")
;; TE = #( t-codings )
;; t-codings = "trailers" | ( transfer-extension [ accept-params ] )
;; Accept-Ranges = acceptable-ranges
;; acceptable-ranges = 1#range-unit | "none"
;;
-(declare-string-list-header! "Accept-Ranges")
+(declare-symbol-list-header! "Accept-Ranges")
;; Age = age-value
;; age-value = delta-seconds
;; Proxy-Authenticate = 1#challenge
;;
-;; FIXME: split challenges ?
-(declare-opaque-header! "Proxy-Authenticate")
+(declare-challenge-list-header! "Proxy-Authenticate")
;; Retry-After = ( HTTP-date | delta-seconds )
;;
;; WWW-Authenticate = 1#challenge
;;
-;; Hum.
-(declare-opaque-header! "WWW-Authenticate")
+(declare-challenge-list-header! "WWW-Authenticate")
+
+
+;; Chunked Responses
+(define (read-chunk-header port)
+ (let* ((str (read-line port))
+ (extension-start (string-index str (lambda (c) (or (char=? c #\;)
+ (char=? c #\return)))))
+ (size (string->number (if extension-start ; unnecessary?
+ (substring str 0 extension-start)
+ str)
+ 16)))
+ size))
+
+(define (read-chunk port)
+ (let ((size (read-chunk-header port)))
+ (read-chunk-body port size)))
+
+(define (read-chunk-body port size)
+ (let ((bv (get-bytevector-n port size)))
+ (get-u8 port) ; CR
+ (get-u8 port) ; LF
+ bv))
+
+(define* (make-chunked-input-port port #:key (keep-alive? #f))
+ "Returns a new port which translates HTTP chunked transfer encoded
+data from PORT into a non-encoded format. Returns eof when it has
+read the final chunk from PORT. This does not necessarily mean
+that there is no more data on PORT. When the returned port is
+closed it will also close PORT, unless the KEEP-ALIVE? is true."
+ (define (next-chunk)
+ (read-chunk port))
+ (define finished? #f)
+ (define (close)
+ (unless keep-alive?
+ (close-port port)))
+ (define buffer #vu8())
+ (define buffer-size 0)
+ (define buffer-pointer 0)
+ (define (read! bv idx to-read)
+ (define (loop to-read num-read)
+ (cond ((or finished? (zero? to-read))
+ num-read)
+ ((<= to-read (- buffer-size buffer-pointer))
+ (bytevector-copy! buffer buffer-pointer
+ bv (+ idx num-read)
+ to-read)
+ (set! buffer-pointer (+ buffer-pointer to-read))
+ (loop 0 (+ num-read to-read)))
+ (else
+ (let ((n (- buffer-size buffer-pointer)))
+ (bytevector-copy! buffer buffer-pointer
+ bv (+ idx num-read)
+ n)
+ (set! buffer (next-chunk))
+ (set! buffer-pointer 0)
+ (set! buffer-size (bytevector-length buffer))
+ (set! finished? (= buffer-size 0))
+ (loop (- to-read n)
+ (+ num-read n))))))
+ (loop to-read 0))
+ (make-custom-binary-input-port "chunked input port" read! #f #f close))
+
+(define* (make-chunked-output-port port #:key (keep-alive? #f))
+ "Returns a new port which translates non-encoded data into a HTTP
+chunked transfer encoded data and writes this to PORT. Data
+written to this port is buffered until the port is flushed, at which
+point it is all sent as one chunk. Take care to close the port when
+done, as it will output the remaining data, and encode the final zero
+chunk. When the port is closed it will also close PORT, unless
+KEEP-ALIVE? is true."
+ (define (q-for-each f q)
+ (while (not (q-empty? q))
+ (f (deq! q))))
+ (define queue (make-q))
+ (define (put-char c)
+ (enq! queue c))
+ (define (put-string s)
+ (string-for-each (lambda (c) (enq! queue c))
+ s))
+ (define (flush)
+ ;; It is important that we do _not_ write a chunk if the queue is
+ ;; empty, since it will be treated as the final chunk.
+ (unless (q-empty? queue)
+ (let ((len (q-length queue)))
+ (display (number->string len 16) port)
+ (display "\r\n" port)
+ (q-for-each (lambda (elem) (write-char elem port))
+ queue)
+ (display "\r\n" port))))
+ (define (close)
+ (flush)
+ (display "0\r\n" port)
+ (force-output port)
+ (unless keep-alive?
+ (close-port port)))
+ (make-soft-port (vector put-char put-string flush #f close) "w"))
+
+(define %http-proxy-port? (make-object-property))
+(define (http-proxy-port? port) (%http-proxy-port? port))
+(define (set-http-proxy-port?! port flag)
+ (set! (%http-proxy-port? port) flag))
HCoop / bpt / guile.git / blobdiff