1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: DRAKMA; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/drakma/read.lisp,v 1.17 2008/05/25 11:35:20 edi Exp $
;;; Copyright (c) 2006-2012, 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)
(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 (or (read-line* stream log-stream)
(error 'drakma-simple-error
:format-control "No status line - probably network error.")))
(first-space-pos (or (position #\Space line :test #'char=)
(syntax-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 (syntax-error "Unknown protocol in ~S." line)))
(or (ignore-errors (parse-integer line
:start (1+ first-space-pos)
:end second-space-pos))
(syntax-error "Status code in ~S is not an integer." line))
(and second-space-pos (subseq line (1+ 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-sequence-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 (peek-char* stream nil) #\,)
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-sequence-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))
|
