;;; HTTP messages
-;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2010, 2011, 2012 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 (web uri)
#:export (string->header
(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}."
+Otherwise the value is written using @code{display}."
(display (header->string sym) port)
(display ": " port)
((header-writer sym) val port)
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)))))
(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))))))
+
+;; RFC 822, updated by RFC 1123
+;;
+;; Sun, 06 Nov 1994 08:49:37 GMT
+;; 01234567890123456789012345678
+;; 0 1 2
+(define (parse-rfc-822-date str)
+ ;; We could verify the day of the week but we don't.
+ (cond ((string-match? str "aaa, dd aaa dddd dd:dd:dd GMT")
+ (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 0)))
+ ((string-match? str "aaa, d aaa dddd dd:dd:dd GMT")
+ (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 0)))
+ (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)
+ ;; We could verify the day of the week but we don't.
+ (let ((tail (substring str (1+ comma))))
+ (if (not (string-match? tail " dd-aaa-dd dd:dd:dd GMT"))
+ (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)))
+ 0))))
+
+;; 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)))
+
(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"))
+ (if (string-suffix? " GMT" str)
+ (let ((comma (string-index str #\,)))
+ (cond ((not comma) (bad-header 'date str))
+ ((= comma 3) (parse-rfc-822-date str))
+ (else (parse-rfc-850-date str comma))))
+ (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-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
"Write the first line of an HTTP request to @var{port}."
(display method port)
(display #\space port)
- (write-uri uri 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))
(lambda (str)
(map string->symbol (split-and-trim str)))
(lambda (v)
- (list-of? symbol? v))
+ (list-of? v symbol?))
(lambda (v port)
(write-list v port display ", "))))
(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)
;; 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
;; Proxy-Authorization = credentials
;;
-(declare-opaque-header! "Proxy-Authorization")
+(declare-credentials-header! "Proxy-Authorization")
;; Range = "Range" ":" ranges-specifier
;; ranges-specifier = byte-ranges-specifier
;; 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")
HCoop / bpt / guile.git / blobdiff