;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: DRAKMA; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/drakma/read.lisp,v 1.12 2006/09/01 21:29:54 edi Exp $

;;; Copyright (c) 2006, Dr. Edmund Weitz.  All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * 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.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; 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 AUTHOR 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.

(in-package :drakma)

(defmacro ignore-eof (&body body)
  "This macro is similar to IGNORE-ERRORS but it only ignores
conditions of type END-OF-FILE."
  `(handler-case
       (progn ,@body)
     (end-of-file () nil)))

(defun read-status-line (stream &optional log-stream)
  "Reads one line from STREAM \(using Chunga's READ-LINE*) and
interprets it as a HTTP status line.  Returns a list of two or
three values - the protocol \(HTTP version) as a keyword, the
status code as an integer, and optionally the reason phrase."
  (let* ((*current-error-message* "While reading status line:")
         (line (read-line* stream log-stream))
         (first-space-pos (or (position #\Space line :test #'char=)
                              (error "No space in status line ~S." line)))
         (second-space-pos (position #\Space line
                                     :test #'char=
                                     :start (1+ first-space-pos))))
    (list (cond ((string-equal line "HTTP/1.0" :end1 first-space-pos) :http/1.0)
                ((string-equal line "HTTP/1.1" :end1 first-space-pos) :http/1.1)
                (t (error "Unknown protocol in ~S." line)))
          (or (ignore-errors (parse-integer line
                                            :start (1+ first-space-pos)
                                            :end second-space-pos))
              (error "Status code in ~S is not an integer." line))
          (and second-space-pos (subseq line second-space-pos)))))

(defun get-content-type (headers)
  "Reads and parses a `Content-Type' header and returns it as
three values - the type, the subtype, and an alist \(possibly
empty) of name/value pairs for the optional parameters.  HEADERS
is supposed to be an alist of headers as returned by
HTTP-REQUEST.  Returns NIL if there is no such header amongst
HEADERS."
  (when-let (content-type (header-value :content-type headers))
    (with-input-from-string (stream content-type)
      (let* ((*current-error-message* "Corrupted Content-Type header:")
             (type (read-token stream))
             (subtype (and (assert-char stream #\/)
                           (read-token stream)))
             (parameters (read-name-value-pairs stream)))
        (values type subtype parameters)))))

(defun read-token-and-parameters (stream)
  "Reads and returns \(as a two-element list) from STREAM a token
and an optional list of parameters \(attribute/value pairs)
following the token."
  (skip-whitespace stream)
  (list (read-token stream)
        (read-name-value-pairs stream)))

(defun skip-more-commas (stream)
  "Reads and consumes from STREAM any number of commas and
whitespace.  Returns the following character or NIL in case of
END-OF-FILE."
  (loop while (eql (ignore-eof (peek-char nil stream)) #\,)
        do (read-char stream) (skip-whitespace stream))
  (skip-whitespace stream))

(defun read-tokens-and-parameters (string &key (value-required-p t))
  "Reads a comma-separated list of tokens from the string STRING.
Each token can be followed by an optional, semicolon-separated
list of attribute/value pairs where the attributes are tokens
followed by a #\\= character and a token or a quoted string.
Returned is a list where each element is either a string \(for a
simple token) or a cons of a string \(the token) and an alist
\(the attribute/value pairs).  If VALUE-REQUIRED-P is NIL, the
value part \(including the #\\= character) of each attribute/value
pair is optional."
  (with-input-from-string (stream string)
    (loop with *current-error-message* = (format nil "While parsing ~S:" string)
          for first = t then nil
          for next = (and (skip-whitespace stream)
                          (or first (assert-char stream #\,))
                          (skip-whitespace stream)
                          (skip-more-commas stream))
          for token = (and next (read-token stream))
          for parameters = (and token
                                (read-name-value-pairs stream
                                                       :value-required-p value-required-p))
          while token
          collect (if parameters (cons token parameters) token))))

(defun split-tokens (string)
  "Splits the string STRING into a list of substrings separated
by commas and optional whitespace.  Empty substrings are
ignored."
  (loop for old-position = -1 then position
        for position = (and old-position
                            (position #\, string :test #'char= :start (1+ old-position)))
        for substring = (and old-position
                             (trim-whitespace (subseq string (1+ old-position) position)))
        while old-position
        when (plusp (length substring))
        collect substring))