Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 57be9afc15
Fetching contributors…

Cannot retrieve contributors at this time

202 lines (184 sloc) 9.202 kb
;;; Copyright (c) 2004-2010, Dr. Edmund Weitz. All rights reserved.
;;; Copyright (c) 2011, Peter Seibel. 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 :toot)
(defun escape-for-html (string)
"Escapes the characters #\\<, #\\>, #\\', #\\\", and #\\& for HTML output."
(with-output-to-string (out)
(with-input-from-string (in string)
(loop for char = (read-char in nil nil)
while char
do (case char
((#\<) (write-string "&lt;" out))
((#\>) (write-string "&gt;" out))
((#\") (write-string "&quot;" out))
((#\') (write-string "&#039;" out))
((#\&) (write-string "&amp;" out))
(otherwise (write-char char out)))))))
(defun rfc-1123-date (&optional (time (get-universal-time)))
"Generates a time string according to RFC 1123. Default is current time."
(multiple-value-bind
(second minute hour date month year day-of-week)
(decode-universal-time time 0)
(format nil "~A, ~2,'0d ~A ~4d ~2,'0d:~2,'0d:~2,'0d GMT"
(svref +day-names+ day-of-week)
date
(svref +month-names+ (1- month))
year
hour
minute
second)))
;; FIXME: this is lacking time zone. Should probably log on zulu time.
(defun iso-time (&optional (time (get-universal-time)))
"Returns the universal time TIME as a string in full ISO format."
(multiple-value-bind (second minute hour date month year)
(decode-universal-time time)
(format nil "~4,'0d-~2,'0d-~2,'0d ~2,'0d:~2,'0d:~2,'0d"
year month date hour minute second)))
(defun tmp-filename ()
(loop for pathname = (possible-tmp-filename)
when (not (probe-file pathname)) return pathname))
(defun possible-tmp-filename ()
(let ((n (with-lock-held (*tmp-counter-lock*) (incf *tmp-counter*))))
(make-pathname :name (format nil "toottmp-~d" n) :type nil :defaults *tmp-directory*)))
(defun quote-string (string)
"Quotes string according to RFC 2616's definition of `quoted-string'."
(with-output-to-string (out)
(with-input-from-string (in string)
(loop for char = (read-char in nil nil)
while char
unless (or (char< char #\Space)
(char= char #\Rubout))
do (case char
((#\\) (write-string "\\\\" out))
((#\") (write-string "\\\"" out))
(otherwise (write-char char out)))))))
(defmacro upgrade-vector (vector new-type &key converter)
"Returns a vector with the same length and the same elements as
VECTOR \(a variable holding a vector) but having element type
NEW-TYPE. If CONVERTER is not NIL, it should designate a function
which will be applied to each element of VECTOR before the result is
stored in the new vector. The resulting vector will have a fill
pointer set to its end.
The macro also uses SETF to store the new vector in VECTOR."
`(setf ,vector
(loop with length = (length ,vector)
with new-vector = (make-array length
:element-type ,new-type
:fill-pointer length)
for i below length
do (setf (aref new-vector i) ,(if converter
`(funcall ,converter (aref ,vector i))
`(aref ,vector i)))
finally (return new-vector))))
(defun url-decode (string &optional (external-format *default-external-format*))
"Decodes a URL-encoded STRING which is assumed to be encoded using
the external format EXTERNAL-FORMAT."
(when (zerop (length string))
(return-from url-decode ""))
(let ((vector (make-array (length string) :element-type 'octet :fill-pointer 0))
(i 0)
unicodep)
(loop
(unless (< i (length string))
(return))
(let ((char (aref string i)))
(labels ((decode-hex (length)
(prog1
(parse-integer string :start i :end (+ i length) :radix 16)
(incf i length)))
(push-integer (integer)
(vector-push integer vector))
(peek ()
(aref string i))
(advance ()
(setf char (peek))
(incf i)))
(cond
((char= #\% char)
(advance)
(cond
((char= #\u (peek))
(unless unicodep
(setf unicodep t)
(upgrade-vector vector '(integer 0 65535)))
(advance)
(push-integer (decode-hex 4)))
(t
(push-integer (decode-hex 2)))))
(t
(push-integer (char-code (case char
((#\+) #\Space)
(otherwise char))))
(advance))))))
(cond (unicodep
(upgrade-vector vector 'character :converter #'code-char))
(t (octets-to-string vector :external-format external-format)))))
(defun form-url-encoded-list-to-alist (form-url-encoded-list
&optional (external-format *default-external-format*))
"Converts a list FORM-URL-ENCODED-LIST of name/value pairs into an
alist. Both names and values are url-decoded while doing this."
(mapcar #'(lambda (entry)
(destructuring-bind (name &optional value)
(split "=" entry :limit 2)
(cons (string-trim " " (url-decode name external-format))
(url-decode (or value "") external-format))))
form-url-encoded-list))
(defun url-encode (string &optional (external-format *default-external-format*))
"URL-encodes a string using the external format EXTERNAL-FORMAT."
(with-output-to-string (s)
(loop for c across string
for index from 0
do (cond ((or (char<= #\0 c #\9)
(char<= #\a c #\z)
(char<= #\A c #\Z)
;; note that there's no comma in there - because of cookies
(find c "$-_.!*'()" :test #'char=))
(write-char c s))
(t (loop for octet across (string-to-octets string
:start index
:end (1+ index)
:external-format external-format)
do (format s "%~2,'0x" octet)))))))
(defun parse-content-type-header (content-type-header)
"Reads and parses a `Content-Type' header and returns it as three
values - the type, the subtype, and the requests' character set as
specified in the 'charset' parameter in the header, if there is one
and if the content type is \"text\". CONTENT-TYPE-HEADER is supposed
to be the corresponding header value as a string."
(with-input-from-sequence (stream (map 'list 'char-code content-type-header))
(with-character-stream-semantics
(let* ((*current-error-message* "Corrupted Content-Type header:")
(type (read-token stream))
(subtype (if (eql #\/ (read-char* stream nil))
(read-token stream)
(return-from parse-content-type-header
;; try to return something meaningful
(values "application" "octet-stream" nil))))
(parameters (read-name-value-pairs stream))
(charset (cdr (assoc "charset" parameters :test #'string=)))
(charset
(when (string-equal type "text")
charset)))
(values type subtype charset)))))
(defun sans (args &rest to-remove)
(loop for (k v) on args by #'cddr unless (member k to-remove) collect k and collect v))
Jump to Line
Something went wrong with that request. Please try again.