source: project/release/4/intarweb/trunk/intarweb.scm @ 11983

;;
;; Intarweb is an improved HTTP library for Chicken
;;
; Copyright (c) 2008, Peter Bex
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions
; are met:
;
; 1. Redistributions of source code must retain the above copyright
;    notice, this list of conditions and the following disclaimer.
; 2. Redistributions in binary form must reproduce the above copyright
;    notice, this list of conditions and the following disclaimer in the
;    documentation and/or other materials provided with the distribution.
; 3. Neither the name of the author nor the names of its
;    contributors may be used to endorse or promote products derived
;    from this software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
; OF THE POSSIBILITY OF SUCH DAMAGE.
;
; Please report bugs, suggestions and ideas to the Chicken Trac
; ticket tracking system (assign tickets to user 'sjamaan'):
; http://trac.callcc.org

(module intarweb
  (read-line-limit replace-header-contents replace-header-contents!
   update-header-contents update-header-contents! headers single-headers
   string->header-name header-name->string
   header-parsers header-unparsers unparse-headers
   http-0.9-request-parser http-1.x-request-parser
   http-0.9-request-unparser http-1.x-request-unparser
   
   make-request request? request-major request-major-set!
   request-minor request-minor-set!
   request-method request-method-set! request-uri request-uri-set!
   request-headers request-headers-set! request-port request-port-set!
   update-request
   
   request-parsers read-request request-unparsers write-request read-headers
   
   make-response response? response-major response-major-set!
   response-minor response-minor-set!
   response-code response-code-set! response-reason response-reason-set!
   response-headers response-headers-set! response-port response-port-set!
   update-response
   
   write-response response-parsers read-response

   ;; http-header-parsers
   split-multi-header unknown-header-parser single multiple parse-token
   header-contents header-values header-value header-list-ref
   get-quality get-value get-params get-param
   natnum-parser symbol-parser-ci symbol-parser
   quote-string unparse-token default-header-unparser etag-unparser
   )

  (import scheme chicken)
  
  (require-library srfi-1 srfi-13 regex regex-case base64 defstruct uri-generic)

  (import extras ports data-structures
          srfi-1 srfi-13 srfi-14 regex regex-case (prefix base64 base64:)
          defstruct uri-generic)

(define read-line-limit (make-parameter 1024)) ; #f if you want no limit

;; Make headers a new type, to force the use of the HEADERS procedure
;; and ensure only proper header values are passed to all procedures
;; that deal with headers.
(define-record headers v)

(define-record-printer (headers h out)
  (fprintf out "#(headers: ~S)"
           (headers-v h)))

(define (replace-header-contents! name contents headers)
  (let loop ((h (headers-v headers)))
    (cond
     ((null? h)
      (headers-v-set!
       headers (cons (cons name contents) (headers-v headers)))
      headers)
     ((eq? name (caar h))
      (set-cdr! (car h) contents)
      headers)
     (else (loop (cdr h))))))

(define (replace-header-contents name contents headers)
  (make-headers
   (let loop ((h (headers-v headers)))
     (cond
      ((null? h) (cons (cons name contents) (headers-v headers)))
      ((eq? name (caar h))
       (cons (cons (caar h) contents) (cdr h)))
      (else (cons (car h) (loop (cdr h))))))))

(define (make-updater replacer)
  (lambda (name contents headers)
    (let ((old (header-contents name headers '())))
      (replacer name
                (if (member name (single-headers))
                    (list (last contents))
                    (append old contents))
                headers))))

(define update-header-contents  (make-updater replace-header-contents))
(define update-header-contents! (make-updater replace-header-contents!))

(define (string->header-name s) (string->symbol (string-downcase! s)))
(define (header-name->string h) (string-titlecase (symbol->string h)))

;; Make a header set from a literal expression by folding in the headers
;; with any previous ones
(define (headers headers-to-be #!optional (old-headers (make-headers '())))
  (fold (lambda (h new-headers)
          (update-header-contents
           (car h)
           (map (lambda (v)
                  (if (vector? v) v (vector v '()))) ; normalize to vector
                (cdr h))
           new-headers))
        old-headers
        headers-to-be))

(include "header-parsers") ; Also includes header unparsers

;; Any unknown headers are considered to be multi-headers, always
(define single-headers
  (make-parameter '(accept-ranges age authorization content-length
                    content-location content-md5 content-type date etag
                    expect expires host if-modified-since if-unmodified-since
                    last-modified location max-forwards proxy-authorization
                    range referer retry-after server transfer-encoding
                    user-agent www-authenticate)))

(define string->http-method string->symbol)
(define http-method->string symbol->string)

;; Hack to insert trailer in chunked ports
(define *end-of-transfer-object* (list 'eot))

;; Make an output port automatically "chunked"
(define (chunked-output-port port)
  (make-output-port (lambda (s) ; write
                      (if (eq? *end-of-transfer-object* s)
                          (fprintf port "0\r\n\r\n") ; trailer?
                          (fprintf port "~X\r\n~A\r\n" (string-length s) s)))
                    (lambda ()  ; close
                      (close-output-port port))
                    (lambda ()  ; flush
                      (flush-output port))))

;; Make an input port automatically "chunked"
(define (chunked-input-port port)
  (let* ((chunk-length 0)
         (position 0)
         (check-position (lambda ()
                           (when (and position (>= position chunk-length))
                             (unless (zero? chunk-length)
                                     (read-line port)) ; read \r\n data trailer
                             (let* ((line (read-line port)))
                               (if (eof-object? line)
                                   (set! position #f)
                                   (begin
                                     (set! chunk-length (string->number line 16))
                                     (if chunk-length
                                         (set! position 0)
                                         (set! position #f)))))))))
    (make-input-port (lambda ()         ; read
                       (check-position)
                       (if position
                           (let ((char (read-char port)))
                             (if (not (eof-object? char))
                                 (set! position (add1 position)))
                             char)
                           #!eof))
                     (lambda ()          ; ready?
                       (check-position)
                       (and position (char-ready? port)))
                     (lambda ()          ; close
                       (close-input-port port))
                     (lambda ()          ; peek
                       (check-position)
                       (if position
                           (peek-char port)
                           #!eof)))))

;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Request parsing ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;

;; This includes parsers for all RFC-defined headers
(define header-parsers
  (make-parameter
   `((accept . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
     (accept-charset . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
     (accept-encoding . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
     (accept-language . ,(multiple symbol-parser-ci `((q . ,quality-parser))))
     (accept-ranges . ,(single symbol-parser-ci))
     (age . ,(single natnum-parser))
     (allow . ,(multiple symbol-parser))
     (authorization . ,(single symbol-parser-ci))
     (cache-control . ,cache-control-parser)
     (connection . ,(multiple symbol-parser-ci))
     (content-encoding . ,(multiple symbol-parser-ci))
     (content-language . ,(multiple symbol-parser-ci))
     (content-length . ,(single natnum-parser))
     (content-location . ,(single uri-reference))
     (content-md5 . ,(single md5-parser))
     (content-range . ,(single range-parser))
     (content-type . ,(single symbol-parser-ci))
     (date . ,(single http-time-parser))
     (etag . ,entity-tag-parser)
     (expect . ,(single key/values))
     (expires . ,(single rfc822-time-parser))
     (from . ,(multiple mailbox-parser))
     (host . ,(single host-parser))
     (if-match . ,(multiple entity-tag-parser))
     (if-modified-since . ,(single rfc822-time-parser))
     (if-none-match . ,(multiple entity-tag-parser))
     (if-range . ,(multiple if-range-parser))
     (if-unmodified-since . ,(single rfc822-time-parser))
     (last-modified . ,(single rfc822-time-parser))
     (location . ,(single uri-reference))
     (max-forwards . ,(single natnum-parser))
     (pragma . ,pragma-parser)
     (proxy-authenticate . ,(multiple symbol-parser-ci))
     (proxy-authorization . ,(single symbol-parser-ci))
     (range . ,range-parser)
     (referer . ,(single uri-reference))
     (retry-after . ,retry-after-parser)
     (server . ,(single identity))
     (te . ,te-parser)
     (trailer . ,(multiple symbol-parser-ci))
     (transfer-encoding . ,(single symbol-parser-ci))
     (upgrade . ,(multiple update-header-contents!))
     (user-agent . ,(single identity))
     (vary . ,(multiple symbol-parser-ci))
     (via . ,via-parser)
     (warning . ,warning-parser)
     (www-authenticate . ,(single symbol-parser-ci))
     ;; RFC 2109
     (set-cookie . ,set-cookie-parser)
     (cookie . ,cookie-parser)
     ;; RFC 2965?
     )))

;; The parser is supposed to return the new (possibly modified) headers list
(define (parse-header name contents headers)
  (let* ((default unknown-header-parser)
         (parser (alist-ref name (header-parsers) eq? default)))
    (parser name contents headers)))

(define (parse-header-line line headers)
  (or
   (and-let* ((colon-idx   (string-index line #\:))
              (header-name (string->header-name (string-take line colon-idx)))
              (contents    (string-trim-both (string-drop line (add1 colon-idx)))))
             (parse-header header-name contents headers))
   (signal-http-condition "Bad header line" 'header-error 'contents line)))

(define (read-headers port)
  (let ((first-line (read-line port)))
    (if (or (eof-object? first-line) (string-null? first-line))
        (make-headers '())
        (let loop ((prev-line first-line)
                   (line      (read-line port))
                   (headers   (make-headers '())))
          (if (or (eof-object? line) (string-null? line))
              (if (string-null? prev-line)
                  headers
                  (parse-header-line prev-line headers))
              (if (char-whitespace? (string-ref line 0)) ; Continuation char?
                  (loop (string-append prev-line line)
                        (read-line port)
                        headers)
                  (if (string=? (string-take-right prev-line 1) "\\") ; escaped?
                      ;; XXX Test if this works with all combinations of \r\n
                      ;; with prepended backslashes. We don't care about
                      ;; malformed stuff like "foo\\\\\n" or \ with missing "
                      (loop (string-append prev-line "\n" line)
                            (read-line port)
                            headers)
                      (loop line (read-line port)
                            (parse-header-line prev-line headers)))))))))

(define (signal-http-condition msg type . more-info)
  (signal (make-composite-condition
           (make-property-condition 'http)
           (apply make-property-condition type more-info)
           (make-property-condition 'exn 'message msg))))

(defstruct request
  (method 'GET) uri (major 1) (minor 1) (headers (make-headers '())) port)

;; Perhaps we should have header parsers indexed by version or
;; something like that, so you can define the maximum version. Useful
;; for when expecting a response. Then we group request/response parsers
;; together, as with request/response unparsers.
(define (http-0.9-request-parser line in)
  (regex-case line
    ("[Gg][Ee][Tt] +([^ \t]+)"
     (_ uri)
     (make-request method: 'GET uri: (uri-reference uri)
                   major: 0 minor: 9
                   port: in))
    (else #f)))

;; XXX This actually parses anything >= HTTP/1.0
(define (http-1.x-request-parser line in)
  (regex-case line
   ("([a-zA-Z]+) +([^ \t]+) +[Hh][Tt][Tt][Pp]/([0-9]+)\\.([0-9]+)"
    (_ method uri major minor)
    (make-request method: (string->http-method method) uri: (uri-reference uri)
                  major: (string->number major)
                  minor: (string->number minor)
                  headers: (read-headers in)
     port: in))
   (else #f)))

(define request-parsers   ; order matters here
  (make-parameter (list http-1.x-request-parser http-0.9-request-parser)))

(define (read-request inport)
  (let* ((line (read-line inport (read-line-limit)))
         ;; A bit ugly, but simpler than the alternatives
         (line (if (eof-object? line) "" line)))
    ;; Try each parser in turn to process the request-line.
    ;; A parser returns either #f or a request object
    (let loop ((parsers (request-parsers)))
      (if (null? parsers)
          (signal-http-condition "Unknown protocol" 'unknown-protocol-line
                                 'line line)
          (or ((car parsers) line inport) (loop (cdr parsers)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Request unparsing ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define header-unparsers
  (make-parameter
   `((etag . ,etag-unparser)
     (host . ,host-unparser))))

(define (unparse-headers headers out)
  (for-each
     (lambda (h)
       (let* ((name (car h))
              (contents (cdr h))
              (def default-header-unparser)
              (unparser (alist-ref name (header-unparsers) eq? def)))
         (display (unparser name contents) out)))
     (headers-v headers)))

(define (write-request-line request)
  (fprintf (request-port request)
           "~A ~A HTTP/~A.~A\r\n"
           (request-method request)
           (uri->string (request-uri request))
           (request-major request)
           (request-minor request)))

(define (http-0.9-request-unparser request)
  (fprintf (request-port request)
           "GET ~A\r\n"
           (uri->string (request-uri request)))
  request)

(define (http-1.0-request-unparser request)
  (and-let* (((= (request-major request) 1))
             ((= (request-minor request) 0))
             (o (request-port request)))
    (write-request-line request)
    (unparse-headers (request-headers request) o)
    (display "\r\n" o)
    request))

;; XXX This actually unparses anything >= HTTP/1.1
(define (http-1.x-request-unparser request)
  (and-let* (((or (> (request-major request) 1)
                  (and (= (request-major request) 1)
                       (> (request-minor request) 0))))
             (o (request-port request)))
    (write-request-line request)
    (unparse-headers (request-headers request) o)
    (display "\r\n" o)
    (if (memq 'chunked (header-values 'transfer-encoding
                                      (request-headers request)))
        (update-request request
                        port: (chunked-output-port (request-port request)))
        request)))

(define request-unparsers  ; order matters here
  (make-parameter (list http-1.x-request-unparser
                        http-1.0-request-unparser
                        http-0.9-request-unparser)))

(define (write-request request)
  ;; Try each unparser in turn to write the request-line.
  ;; An unparser returns either #f or a new request object.
  (let loop ((unparsers (request-unparsers)))
    (if (null? unparsers)
        (signal-http-condition "Unknown protocol" 'unknown-protocol
                               'major (request-major request)
                               'minor (request-minor request))
        (or ((car unparsers) request) (loop (cdr unparsers))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Response unparsing ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defstruct response
  (code 200) (reason "OK") (major 1) (minor 1) (headers (make-headers '())) port)

(define (http-0.9-response-unparser response)
  response) ;; The response-body will just follow

(define (write-response-line response)
  (fprintf (response-port response)
           "HTTP/~A.~A ~A ~A\r\n"
           (response-major response)
           (response-minor response)
           (response-code response)
           (response-reason response)))

(define (http-1.0-response-unparser response)
  (and-let* (((= (response-major response) 1))
             ((= (response-minor response) 0))
             (o (response-port response)))
    (write-response-line response)
    (unparse-headers (response-headers response) o)
    (display "\r\n" o)
    response))

;; XXX This actually unparses anything >= HTTP/1.1
(define (http-1.x-response-unparser response)
  (and-let* (((or (> (response-major response) 1)
                  (and (= (response-major response) 1)
                       (> (response-minor response) 0))))
             (o (response-port response)))
    (write-response-line response)
    (unparse-headers (response-headers response) o)
    (display "\r\n" o)
    (if (memq 'chunked (header-values 'transfer-encoding
                                      (response-headers response)))
        (update-response response
                         port: (chunked-output-port (response-port response)))
        response)))

(define response-unparsers
  (make-parameter (list http-1.x-response-unparser
                        http-1.0-response-unparser
                        http-0.9-response-unparser)))

(define (write-response response)
  ;; Try each unparser in turn to write the response-line.
  ;; An unparser returns either #f or a new response object.
  (let loop ((unparsers (response-unparsers)))
    (if (null? unparsers)
        (signal-http-condition "Unknown protocol" 'unknown-protocol
                               'major (response-major response)
                               'minor (response-minor response))
        (or ((car unparsers) response) (loop (cdr unparsers))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Response parsing ;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;

;; I don't like this code. Clean it up!
(define (http-1.x-response-parser line in)
  (regex-case line
    ("[Hh][Tt][Tt][Pp]/([0-9]+)\\.([0-9]+) +([0-9]+) +(.*)"
     (_ major minor code reason)
     (let ((major (string->number major))
           (minor (string->number minor)))
      (and (or (> major 1)
               (and (= major 1)
                    (> minor 0)))
           (let ((response (make-response code: (string->number code)
                                          reason: reason
                                          major: major
                                          minor: minor
                                          headers: (read-headers in)
                                          port: in)))
             (if (memq 'chunked (header-values 'transfer-encoding
                                               (response-headers response)))
                 (update-response response
                                  port: (chunked-input-port
                                         (response-port response)))
                 response)))))
    (else #f)))

(define (http-1.0-response-parser line in)
  (regex-case line
    ("[Hh][Tt][Tt][Pp]/1\\.0 +([0-9]+) +(.*)"
     (_ code reason)
     (let ((response (make-response code: (string->number code) reason: reason
                                    major: 1 minor: 0
                                    headers: (read-headers in)
                                    port: in)))
       response))
    (else #f)))

;; You can't "detect" a 0.9 response, because there is no response line.
;; It will simply output the body directly, so we will just assume that
;; if we can't recognise the output string, we just got a 0.9 response.
;; If this is not desired, just change response-parsers to exclude this one.
(define (http-0.9-response-parser line in)
  (make-response code: 200 reason: "OK"
                 major: 0 minor: 9
                 ;; XXX This is wrong, it re-inserts \r\n, while it may have
                 ;; been a \n only. To work around this, we'd have to write
                 ;; a custom read-line procedure.
                 ;; However, it does not matter much because HTTP 0.9 is only
                 ;; defined to ever return text/html, no binary or any other
                 ;; content type.
                 port: (call-with-input-string (string-append line "\r\n")
                         (lambda (str)
                           (make-concatenated-port str in)))))

(define response-parsers ;; order matters here
  (make-parameter (list http-1.x-response-parser http-1.0-response-parser http-0.9-response-parser)))

(define (read-response inport)
  (let* ((line (read-line inport (read-line-limit)))
         (line (if (eof-object? line) "" line)))
    (let loop ((parsers (response-parsers)))
      (if (null? parsers)
          (signal-http-condition "Unknown protocol" 'unknown-protocol-line
                                 'line line)
          (or ((car parsers) line inport) (loop (cdr parsers)))))))

)