;;; HTTP messages

;; Copyright (C)  2010-2017 Free Software Foundation, Inc.

;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 3 of the License, or (at your option) any later version.
;;
;; This library is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
;; 02110-1301 USA

;;; Commentary:
;;;
;;; This module has a number of routines to parse textual
;;; representations of HTTP data into native Scheme data structures.
;;;
;;; It tries to follow RFCs fairly strictly---the road to perdition
;;; being paved with compatibility hacks---though some allowances are
;;; made for not-too-divergent texts (like a quality of .2 which should
;;; be 0.2, etc).
;;;
;;; 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 rdelim)
  #:use-module (ice-9 match)
  #:use-module (ice-9 q)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 textual-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
            header-writer

            read-header
            parse-header
            valid-header?
            write-header

            read-headers
            write-headers

            parse-http-method
            parse-http-version
            parse-request-uri

            read-request-line
            write-request-line
            read-response-line
            write-response-line

            make-chunked-input-port
            make-chunked-output-port

            http-proxy-port?
            set-http-proxy-port?!))


(define (put-symbol port sym)
  (put-string port (symbol->string sym)))

(define (put-non-negative-integer port i)
  (put-string port (number->string i)))

(define (string->header name)
  "Parse NAME to a symbolic header name."
  (string->symbol (string-downcase name)))

(define-record-type <header-decl>
  (make-header-decl name parser validator writer multiple?)
  header-decl?
  (name header-decl-name)
  (parser header-decl-parser)
  (validator header-decl-validator)
  (writer header-decl-writer)
  (multiple? header-decl-multiple?))

;; sym -> header
(define *declared-headers* (make-hash-table))

(define (lookup-header-decl sym)
  (hashq-ref *declared-headers* sym))

(define* (declare-header! name
                          parser
                          validator
                          writer
                          #:key multiple?)
  "Declare a parser, validator, and writer for a given header."
  (unless (and (string? name) parser validator writer)
    (error "bad header decl" name parser validator writer multiple?))
  (let ((decl (make-header-decl name parser validator writer multiple?)))
    (hashq-set! *declared-headers* (string->header name) decl)
    decl))

(define (header->string 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 ‘#t’ iff SYM is a known header, with associated
parsers and serialization procedures."
  (and (lookup-header-decl sym) #t))

(define (header-parser sym)
  "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)
  "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)
  "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 will call ‘put-string’."
  (let ((decl (lookup-header-decl sym)))
    (if decl
        (header-decl-writer decl)
        (lambda (val port)
          (put-string port val)))))

(define (read-header-line port)
  "Read an HTTP header line and return it without its final CRLF or LF.
Raise a 'bad-header' exception if the line does not end in CRLF or LF,
or if EOF is reached."
  (match (%read-line port)
    (((? string? line) . #\newline)
     ;; '%read-line' does not consider #\return a delimiter; so if it's
     ;; there, remove it.  We are more tolerant than the RFC in that we
     ;; tolerate LF-only endings.
     (if (string-suffix? "\r" line)
         (string-drop-right line 1)
         line))
    ((line . _)                                ;EOF or missing delimiter
     (bad-header 'read-header-line line))))

(define (read-continuation-line port val)
  (match (peek-char port)
    ((or #\space #\tab)
     (read-continuation-line port
                             (string-append val (read-header-line port))))
    (_ val)))

(define *eof* (call-with-input-string "" read))

(define (read-header port)
  "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.

Returns the end-of-file object for both values if the end of the message
body was reached (i.e., a blank line)."
  (let ((line (read-header-line port)))
    (if (or (string-null? line)
            (string=? line "\r"))
        (values *eof* *eof*)
        (let* ((delim (or (string-index line #\:)
                          (bad-header '%read line)))
               (sym (string->header (substring line 0 delim))))
          (values
           sym
           (parse-header
            sym
            (read-continuation-line
             port
             (string-trim-both line char-set:whitespace (1+ delim)))))))))

(define (parse-header sym val)
  "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 VAL is a valid Scheme value for the
header with name SYM."
  (unless (symbol? sym)
    (error "header name not a symbol" sym))
  ((header-validator sym) val))

(define (write-header sym val port)
  "Write the given header name and value to PORT, using the writer
from ‘header-writer’."
  (put-string port (header->string sym))
  (put-string port ": ")
  ((header-writer sym) val port)
  (put-string port "\r\n"))

(define (read-headers port)
  "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)
        (if (eof-object? k)
            (reverse! headers)
            (lp (acons k v headers)))))))

(define (write-headers headers port)
  "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))
    (match headers
      (((k . v) . headers)
       (write-header k v port)
       (lp headers))
      (()
       (values)))))