Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Tree: bf469c265b
Fetching contributors…

Cannot retrieve contributors at this time

1132 lines (916 sloc) 34.476 kB
;; -*- mode: common-lisp; package: net.aserve -*-
;;
;; headers.cl
;;
;; copyright (c) 1986-2005 Franz Inc, Berkeley, CA - All rights reserved.
;; copyright (c) 2000-2012 Franz Inc, Oakland, CA - All rights reserved.
;;
;; This code is free software; you can redistribute it and/or
;; modify it under the terms of the version 2.1 of
;; the GNU Lesser General Public License as published by
;; the Free Software Foundation, as clarified by the AllegroServe
;; prequel found in license-allegroserve.txt.
;;
;; This code 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.
;;
;; Version 2.1 of the GNU Lesser General Public License is in the file
;; license-lgpl.txt that was distributed with this file.
;; If it is not present, you can access it from
;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
;; version) or write to the Free Software Foundation, Inc., 59 Temple Place,
;; Suite 330, Boston, MA 02111-1307 USA
;;
;;
;; $Id: headers.cl,v 1.31 2008/01/28 17:52:21 jkf Exp $
;; Description:
;; header parsing
;;- This code in this file obeys the Lisp Coding Standard found in
;;- http://www.franz.com/~jkf/coding_standards.html
;;-
(in-package :net.aserve)
(defvar *header-byte-array*
;; unsigned-byte 8 vector contains the characters referenced by
;; the *header-lookup-array* . All characters are downcased.
)
(defvar *header-lookup-array*
;; indexed by the length of the header name.
;; value is list of (hba-index header-number) for all headers
;; that have a name this length
;; hba index is the index in the *header-byte-array* where the header
;; name begins.
;; the header-number is in index into..
)
;; *header-keyword-array* defvar'ed in main.cl
;; indexed by header-number, holds the keyword naming this header
(defvar *header-name-array*
;; indexed by header-number, holds the string containing the 'pretty'
;; version of this header
)
(defvar *header-client-array*
;; indexed by header number, contains a kwd symbol specifying how
;; to treat his header when proxying a client request to a server
)
(defvar *header-server-array*
;; indexed by header number, contains a kwd symbol specifying how
;; to treat his header when proxying a server response to a client
)
#+ignore
(defvar *header-cache-match-array*
;; indexed by header number. contains a kwd symbol or nil
;; describing how matching should be done
)
(defvar *header-count*
;; the number of headers we're tracking
)
(defconstant *header-block-size* 4096) ; bytes in a header block
(defconstant *header-block-used-size-index*
;; where the size of lower part of the buffer is kept
(- *header-block-size* 2))
(defconstant *header-block-data-start-index*
;; where the start of the lowest data block is stored
(- *header-block-size* 4))
(defmacro header-block-header-index (index)
;; where in the buffer the 2byte entry for header 'index' is located
`(- *header-block-size* 6 (ash ,index 1)))
(eval-when (compile eval)
;; the headers from the http spec
;; Following the header name we specify how to
;; 1. transfer client request headers and
;; 2 server response headers
;; (header-name client server)
;; client/server
;; :p - pass this header on
;; :np - don't pass this header on verbatim
;; :nf - this header won't be found
;; 3. how the proxy-cache compares a new request-header against
;; the request header stored with a cached response.
;; :mx - need exact match
;; :mp - either exact match or no value for new request-header
;; nil - no match needed
;;
;;***** note well: adding something to this table must be accompanied
;; by modifying *headers-count* above and then removing all caches
;; if we're using a proxy cache.
(defparameter *http-headers*
'(("Accept" :p :nf :mp)
("Accept-Charset" :p :nf :mp)
("Accept-Encoding" :p :nf :mp)
("Accept-Language" :p :nf :mp)
("Accept-Ranges" :p :nf :mx)
("Age" :nf :p nil)
("Allow" :nf :p nil)
("Authorization" :p :nf :mx)
("Cache-control" :p :p :mp)
("Connection" :np :np nil)
("Content-Disposition" :nf :nf nil) ; in multipart/form-data bodies
("Content-Encoding" :p :p :mx)
("Content-Language" :p :p :mx)
("Content-Length" :np :np nil)
("Content-Location" :p :p :mx)
("Content-Md5" :p :p :mx)
("Content-Range" :p :p :mx)
("Content-Type" :p :p :mx)
("Cookie" :p :p :mx)
("Date" :p :p nil)
("Etag" :nf :p nil)
("Expect" :p :nf :mx)
("Expires" :nf :p nil)
("From" :p :nf :mp) ; mp?
("Host" :np :nf :mx)
("If-Match" :p :nf :mx)
("If-Modified-Since" :p :n nil)
("If-None-Match" :p :nf :mx)
("If-Range" :p :nf :mx)
("If-Unmodified-Since" :p :nf nil)
("Last-Modified" :nf :p nil)
("Location" :nf :p nil)
("Max-Forwards" :np :nf nil)
("Pragma" :p :p nil) ; on reloads browsers add pragms
("Proxy-Authenticate" :nf :p nil)
("Proxy-Authorization" :p :nf :mx)
("Range" :p :nf :mx)
("Referer" :p :nf nil) ; should we match? who cares..
("Retry-After" :nf :p nil )
("Server" :nf :p nil)
("Set-Cookie" :nf :p nil)
("Status" :nf :nf nil) ; not real header but found in cgi responses
("TE" :p :nf :mx)
("Trailer" :np :np nil)
("Transfer-Encoding" :np :np nil)
("Upgrade" :np :nf nil)
("User-Agent" :p :nf :mp)
("Vary" :nf :p nil)
("Via" :np :np nil) ; modified by proxy both dierctions
("Warning" :p :p :mx)
("WWW-Authenticate" :nf :p nil)
)))
;; number of headers.
;; we take advantage of this being a constant in the code below and
;; in the proxy caches. If this number should change all proxy caches
;; should be removed.
(defconstant *headers-count* #.(length *http-headers*))
(defmacro header-block-data-start ()
;; return index right above the first data index object stored
`(- *header-block-size* 4 (* *headers-count* 2)))
(eval-when (compile eval)
(defmacro build-header-lookup-table ()
(let ((max-length 0)
(total-length 0))
; compute max and total length
(dolist (header *http-headers*)
(setq header (car header))
(let ((len (length header)))
(setq max-length (max max-length len))
(incf total-length len)))
(let ((header-byte-array (make-array total-length
:element-type '(unsigned-byte 8)))
(header-lookup-array (make-array (1+ max-length))))
(let ((hba -1)
(header-number -1)
(header-kwds)
(plists)
)
(dolist (header *http-headers*)
(setq header (car header))
(let ((len (length header)))
(setq header (string-downcase header))
(let ((header-keyword (read-from-string
(format nil ":~a"
header))))
(push header-keyword header-kwds)
(push (list (1+ hba)
(incf header-number))
(aref header-lookup-array len))
(push (cons header-keyword header-number) plists)
)
(dotimes (i len)
(setf (aref header-byte-array (incf hba))
(char-code (schar header i))))))
`(progn (setq *header-byte-array* ',header-byte-array)
(setq *header-lookup-array* ',header-lookup-array)
(setq *header-keyword-array*
',(make-array (length header-kwds)
:initial-contents
(reverse header-kwds)))
(setq *header-name-array*
',(make-array (length *http-headers*)
:initial-contents
(mapcar #'first *http-headers*)))
(setq *header-client-array*
',(make-array (length *http-headers*)
:initial-contents
(mapcar #'second *http-headers*)))
(setq *header-server-array*
',(make-array (length *http-headers*)
:initial-contents
(mapcar #'third *http-headers*)))
#+ignore
(setq *header-cache-match-array*
',(make-array (length *http-headers*)
:initial-contents
(mapcar #'fourth *http-headers*)))
(setq *header-count*
;; number of distinct headers
,(1+ header-number))
(if* (not (eql *header-count* *headers-count*))
then (error "setq *headers-count* to ~d in headers.cl"
*header-count*))
(dolist (hkw ',plists)
(setf (get (car hkw) 'kwdi) (cdr hkw)))
))))))
(build-header-lookup-table)
(defparameter *header-block-sresource*
;; 4096 element usb8 arrays
;; used to hold header contents with index at the end
(create-sresource
:create #'(lambda (sresource &optional size)
(declare (ignore sresource))
(if* size
then (error "size can't be specifed for header blocks"))
(make-array *header-block-size*
:element-type '(unsigned-byte 8)))))
(defparameter *header-block-plus-sresource*
;; (+ 4096 100) element usb8 arrays
;; used to hold things slight larger than a header block will hold
(create-sresource
:create #'(lambda (sresource &optional size)
(declare (ignore sresource))
(if* size
then (error "size can't be specifed for header blocks"))
(make-array (+ *header-block-size* 100)
:element-type '(unsigned-byte 8)))))
(defparameter *header-index-sresource*
;; used in parsing to hold location of header info in header-block
(create-sresource
:create #'(lambda (sresource &optional size)
(declare (ignore sresource))
(if* size
then (error "size can't be specifed for header index"))
(make-array *header-count*))
:init #'(lambda (sresource buffer)
(declare (ignore sresource))
(dotimes (i (length buffer))
(setf (svref buffer i) nil)))))
(defun get-header-block ()
(get-sresource *header-block-sresource*))
(defun free-header-blocks (blocks)
;; free a list of blocks
(dolist (block blocks)
(free-sresource *header-block-sresource* block)))
(defun free-header-block (block)
(if* (and block (atom block))
then (free-sresource *header-block-sresource* block)
elseif block
then (error "bad value passed to free-header-block ~s" block)))
(defun get-header-plus-block ()
(get-sresource *header-block-plus-sresource*))
(defun free-header-plus-block (block)
(if* block then (free-sresource *header-block-plus-sresource* block)))
;; parsed header array
;; We have to work with headers and to reduce consing we work with
;; them in place in a structure called a parsed header block
;; This is stored in a 4096 byte usb8 vector.
;; The layout is:
;; headers and values .. empty .. data-block header-index-block min-db size
;;
;; The headers and values are exactly what's read from the web client/server.
;; they end in a crlf after the last value.
;;
;; The size is a 2 byte value specifying the index after the last
;; header value. It says where we can add new headers if we want.
;; All values greater than 2 bytes are stored in big endian form.
;;
;; min-db is a 2 byte value telling where the lowest data-block entry starts
;;
;; The header-index-block is 2 bytes per entry and specifies an index
;; into the data-block where a descriptor for the value associated with
;; this header are located. This file lists the headers we know about
;; and each is given an index. The header-index-block is stored
;; so that index 0 is closest to the end of the array
;; The data blocks have the format
;; count(1) start1(2) end1(2) ... ... startN(2) endN(2)
;; which describes how many header values there are and where they
;; are. end is one byte beyond the header value.
(defmacro unsigned-16-value (array index)
(let ((gindex (gensym)))
`(let ((,gindex ,index))
(declare (fixnum ,gindex))
(the fixnum
(+ (the fixnum (ash (aref ,array ,gindex) 8))
(aref ,array (1+ ,gindex)))))))
(defsetf unsigned-16-value (array index) (value)
(let ((gindex (gensym))
(gvalue (gensym)))
`(let ((,gindex ,index)
(,gvalue ,value))
(setf (aref ,array ,gindex) (hipart ,gvalue))
(setf (aref ,array (1+ ,gindex)) (lopart ,gvalue))
,gvalue)))
(defmacro hipart (x)
`(the fixnum (logand #xff (ash (the fixnum ,x) -8))))
(defmacro lopart (x)
`(the fixnum (logand #xff (the fixnum ,x))))
(defun parse-header-block-internal (buff start end ans)
;; the buff is an (unsigned-byte 8) array containing headers
;; and their values from start to just before end.
;; ans is a simple-vector large enough to hold *header-count* values.
;;
;; modify ans to store by header-number showing what, if any, values
;; are associated with this header. The values are a list
;; of cons (start . end) meaning the value is from start to end-1
;; spaces are trimmed from the sides
;;
(let ((i start)
(state 0)
beginhv
beginh
hnum
ch
otherheaders
otherheadername
)
(macrolet ((tolower-set (loc)
;; return the value at loc, convert it to lower
;; case and store back if the conversion was done
(let ((var (gensym)))
`(let ((,var ,loc))
(if* (<= #.(char-int #\A) ,var #.(char-int #\Z))
then ; must lower case
(incf ,var #.(- (char-int #\a) (char-int #\A)))
(setf ,loc ,var))
,var))))
(block done
(loop
;(format t "i: ~d, st ~d ch ~s~%" i state (code-char (aref buff i)))
(case state
(0 ; beginning a header
(if* (>= i end)
then (return))
; starting out look for something in the character range
(setq ch (tolower-set (aref buff i)))
(if* (not (<= #.(char-int #\a) ch #.(char-int #\z)))
then ; this can't be a header start
; skip to the eol
(setq state 1)
else ; got a header start, skip to the next colon
(setq beginh i)
(incf i)
(loop
(if* (>= i end) then (return-from done))
(setq ch (tolower-set (aref buff i)))
(if* (eq ch #.(char-int #\:))
then ; found a header
(setq hnum
(locate-header buff beginh i))
(incf i)
(if* (null hnum)
then ; unknown header, save specially
(setq otherheadername
(buffer-subseq-to-string
buff beginh (1- i))))
(setq state 2) ; skip to value
(return)
else (incf i)))))
(1 ; skip to eol ( a linefeed in this case)
(if* (>= i end) then (return))
(loop
(setq ch (aref buff i))
(if* (eq ch #.(char-int #\linefeed))
then (setq state 0)
(incf i)
(return)
else (incf i))
(if* (>= i end) then (return-from done))
))
(2 ; accumulate a header value
(if* (>= i end) then (return))
(if* (null beginhv) then (setq beginhv i))
(loop
(setq ch (aref buff i))
(if* (eq ch #.(char-int #\linefeed))
then (incf i)
(return))
(incf i)
(if* (>= i end) then (return-from done)))
; hit eol, but there still could be a continuation
(setq state 3))
(3 ; read a header line, now this could be a continuation
; or a new header or eo headers
(if* (or (>= i end)
(not (eq (aref buff i) #.(char-int #\space))))
then ; end of one header's value
; backup and ignore cr lf
(let ((back (1- i)))
(loop
(let ((ch (aref buff back)))
(if* (or (eq ch #.(char-code #\return))
(eq ch #.(char-code #\linefeed)))
then (decf back)
else (return))))
(incf back)
; now strip spaces from beginning
(loop
(if* (>= beginhv back)
then (return)
elseif (eq (aref buff beginhv) #.(char-code #\space))
then (incf beginhv)
else (return)))
; strip from end
(loop
(if* (>= beginhv back)
then (return)
elseif (eq (aref buff (1- back))
#.(char-code #\space))
then (decf back)
else (return)))
; must keep the header items in the same order
; they were received (according to the http spec)
(if* hnum
then ; known header
(let ((cur (svref ans hnum))
(new (list (cons beginhv back))))
(if* cur
then (setq cur (append cur new))
else (setq cur new))
(setf (svref ans hnum) cur))
else ; unknown header
(push (cons otherheadername
(buffer-subseq-to-string
buff beginhv back))
otherheaders))
(setq beginhv nil)
(setq state 0))
else (setq state 2))))))
otherheaders)))
(defun parse-header-block (buff start end)
(let ((ans (get-sresource *header-index-sresource*))
(otherheaders))
(setq otherheaders (parse-header-block-internal buff start end ans))
; store the info in ans into the buffer at the end
(let* ((table-index (header-block-header-index 0))
(data-index (header-block-data-start)))
(dotimes (i (length ans))
(let ((data (svref ans i)))
(if* data
then ; must store data and an index to it
(let* ((data-len (length data))
(size (+ 1 ; count
(ash data-len 2) ; 4 bytes per data entry
)))
(decf data-index size)
(setf (unsigned-16-value buff table-index) data-index)
(setf (aref buff data-index) data-len)
(let ((i (1+ data-index)))
(dolist (datum data)
(setf (unsigned-16-value buff i) (car datum))
(incf i 2)
(setf (unsigned-16-value buff i) (cdr datum))
(incf i 2))))
else ; nothing there, zero it out
(setf (aref buff table-index) 0)
(setf (aref buff (1+ table-index)) 0)))
(decf table-index 2))
(setf (unsigned-16-value buff *header-block-used-size-index*) end)
(setf (unsigned-16-value buff *header-block-data-start-index* )
data-index)
(if* (> end data-index)
then (error "header is too large")))
(free-sresource *header-index-sresource* ans)
otherheaders))
(defun free-req-header-block (req)
;; if the req has an associated header block, give it back
(free-sresource *header-block-sresource* (request-header-block req))
(setf (request-header-block req) nil))
(defun header-buffer-values (buff header-index)
;; the buff is a usb8 array that has been built by parse-header-block
;; we are asked to return the location of the value(s) for the header
;; with the given index
;; we return nil if the header has no value
;; otherwise we return values
;; start index
;; end index
;; list of (start-index . end-index) for the rest of the values, if any
;; be a nice guy and handle a symbolic header keyword name
(if* (symbolp header-index)
then (let ((ans (get header-index 'kwdi)))
(if* (null ans)
then (error "no such header as ~s" header-index))
(setq header-index ans)))
(let ((table-index (header-block-header-index header-index))
(data-index))
(setq data-index (unsigned-16-value buff table-index))
(if* (< 0 data-index (length buff))
then ; get values
(let ((count (aref buff data-index))
(first-start (unsigned-16-value buff (+ 1 data-index)))
(first-end (unsigned-16-value buff (+ 3 data-index))))
(if* (> count 1)
then ; must get a list of the rest
(incf data-index 5)
(let (res)
(dotimes (i (1- count))
(push (cons (unsigned-16-value buff data-index)
(unsigned-16-value buff
(+ 2 data-index)))
res)
(incf data-index 4))
(values first-start
first-end
(nreverse res)))
else (values first-start first-end))))))
(defun buffer-subseq-to-string (buff start end)
;; extract a subsequence of the usb8 buff and return it as a string
(let ((str (make-string (- end start))))
(do ((i start (1+ i))
(ii 0 (1+ ii)))
((>= i end))
(setf (schar str ii)
(code-char (aref buff i))))
str))
(defun header-buffer-req-header-value (req header)
;; see header-buffer-header-value for what this does.
(let ((buff (request-header-block req)))
; there will be no buffer for http/0.9 requests
(and buff
(header-buffer-header-value (request-header-block req) header))))
(defun header-buffer-header-value (buff header)
;; header is a number or keyword symbol.
;; return nil or the header value as a string
;;
;; according to the http spec, multiple headers with the same name
;; is only allowed when the header value is a comma separated list
;; of items, and the sequence of header values can be considered
;; as one big value separated by commas
;;
(if* (symbolp header)
then (setq header (get header 'kwdi)))
(if* (fixnump header)
then
(multiple-value-bind (start end others)
(header-buffer-values buff header)
; we only get the first value
(if* start
then (let ((ans (buffer-subseq-to-string buff start end)))
(if* others
then ; must concatente the others as well
(let (res)
(dolist (oth others)
(push (buffer-subseq-to-string buff
(car oth)
(cdr oth))
res)
(push ", " res))
(apply #'concatenate 'string ans res))
else ans))))))
(defun locate-header (buff start end)
;; find the header-index of the header between start and end in buff.
;; buffer is an usb8 array.
;; return nil if no match
(let ((size (- end start))
(hba *header-byte-array*))
(if* (< 0 size (length *header-lookup-array*))
then (dolist (header (svref *header-lookup-array* size))
(let ((begin (car header)))
(if* (dotimes (i size t)
(if* (not (eq (aref buff (+ start i))
(aref hba (+ begin i))))
then (return nil)))
then ; match
(return (cadr header))))))))
(defun compute-client-request-headers (sock)
;; for the client code we return a list of headers or signal
;; an error.
;;
(let* ((buff (get-sresource *header-block-sresource*))
(end (read-headers-into-buffer sock buff)))
(if* end
then (prog1 (parse-and-listify-header-block buff end)
(free-sresource *header-block-sresource* buff))
else (free-sresource *header-block-sresource* buff)
(error "Incomplete headers sent by server"))))
(defun parse-and-listify-header-block (buff end)
;; buff is a header-block
;; parse the headers in the block and then extract the info
;; in assoc list form
(let ((ans (get-sresource *header-index-sresource*))
(headers))
; store the non-standard headers in the header array
(setq headers (parse-header-block-internal buff 0 end ans))
; now cons up the headers
(dotimes (i *header-count*)
(let ((res (svref ans i)))
(if* res
then (let ((kwd (svref *header-keyword-array* i)))
(dolist (ent res)
(let ((start (car ent))
(end (cdr ent)))
(let ((str (make-string (- end start))))
(do ((i start (1+ i))
(ii 0 (1+ ii)))
((>= i end))
(setf (schar str ii)
(code-char
(aref buff i))))
(push (cons kwd str) headers))))))))
(free-sresource *header-index-sresource* ans)
(nreverse headers)))
(defun listify-parsed-header-block (buff)
;; the header block buff has been parsed.
;; we just extract all headers in conses
(let (res)
(dotimes (i *headers-count*)
(let ((val (header-buffer-header-value buff i)))
(if* val
then (push (cons (aref *header-keyword-array* i) val) res))))
(nreverse res)))
(defun initialize-header-block (buf)
;; set the parsed header block buf to the empty state
; clear out the indicies pointing to the values
(let ((index (header-block-header-index 0)))
(dotimes (i *header-count*)
(setf (unsigned-16-value buf index) 0)
(decf index 2)))
; no headers yet
(setf (unsigned-16-value buf *header-block-used-size-index*) 0)
; start of where to put data
(setf (unsigned-16-value buf *header-block-data-start-index*)
(header-block-data-start))
buf)
(defun copy-headers (frombuf tobuf header-array)
;; copy the headers denoted as :p (pass) in header array
;; in frombuf to the tobuf
;;
;; return the index after the last header stored.
(let ((toi 0)
(data-index (header-block-data-start))
(this-data-index)
(header-index (header-block-header-index 0)))
(dotimes (i (length header-array))
(if* (eq :p (svref header-array i))
then ; passed intact
(multiple-value-bind (start end others)
(header-buffer-values frombuf i)
(if* start
then (let ((items (1+ (length others))))
(decf data-index (1+ (* items 4)))
(setf (aref tobuf data-index) items)
(setf (unsigned-16-value tobuf header-index)
data-index)
(setq this-data-index (1+ data-index)))
(loop
(if* (null start) then (return))
(let ((name (svref *header-name-array* i)))
; copy in header name
(dotimes (j (length name))
(setf (aref tobuf toi) (char-code (schar name j)))
(incf toi))
(setf (aref tobuf toi) #.(char-code #\:))
(incf toi)
(setf (aref tobuf toi) #.(char-code #\space))
(incf toi)
; set the start address
(setf (unsigned-16-value tobuf this-data-index)
toi)
(incf this-data-index 2)
; copy in the header value
(do ((j start (1+ j)))
((>= j end))
(setf (aref tobuf toi) (aref frombuf j))
(incf toi))
; set the end address
(setf (unsigned-16-value tobuf this-data-index)
toi)
(incf this-data-index 2)
; add the obligatory crlf
(setf (aref tobuf toi) #.(char-code #\return))
(incf toi)
(setf (aref tobuf toi) #.(char-code #\linefeed))
(incf toi))
(let ((next (pop others)))
(if* next
then (setq start (car next)
end (cdr next))
else (return))))
else (setf (unsigned-16-value tobuf header-index) 0)))
else ; clear out the header index
(setf (unsigned-16-value tobuf header-index) 0))
(decf header-index 2))
(setf (unsigned-16-value tobuf *header-block-used-size-index*) toi)
(setf (unsigned-16-value tobuf *header-block-data-start-index* )
data-index)
toi))
(defun insert-header (buff header value)
;; insert the header (kwd symbol or integer) at the end of the current buffer
;; end is the index of the next buffer position to fill
;; return the index of the first unfilled spot of the buffer
;;
(if* (symbolp header)
then (let ((val (get header 'kwdi)))
(if* (null val)
then (error "no such header as ~s" header))
(setq header val)))
(let ((end (unsigned-16-value buff *header-block-used-size-index*))
(starth)
(endh))
(let ((name (svref *header-name-array* header)))
(dotimes (j (length name))
(setf (aref buff end) (char-code (schar name j)))
(incf end))
(setf (aref buff end) #.(char-code #\:))
(incf end)
(setf (aref buff end) #.(char-code #\space))
(incf end)
(setq starth end)
(dotimes (j (length value))
(setf (aref buff end) (char-code (schar value j)))
(incf end))
(setq endh end)
(setf (aref buff end) #.(char-code #\return))
(incf end)
(setf (aref buff end) #.(char-code #\linefeed))
(incf end))
; now insert the information about this header in the data list
(let ((this-data-index (unsigned-16-value buff (header-block-header-index
header)))
(data-start (unsigned-16-value buff *header-block-data-start-index*)))
(let ((count 0))
(if* (not (zerop this-data-index))
then ; must copy this one down and add to it
(setq count (aref buff this-data-index)))
(incf count) ; for our new one
(decf data-start (+ 1 (* count 4)))
(setf (unsigned-16-value buff (header-block-header-index header))
data-start)
(setf (unsigned-16-value buff *header-block-data-start-index*)
data-start)
(setf (aref buff data-start) count)
; copy in old stuff
(incf this-data-index)
(incf data-start)
(dotimes (i (* 4 (1- count)))
(setf (aref buff data-start) (aref buff this-data-index))
(incf data-start)
(incf this-data-index))
; store in new info
(setf (unsigned-16-value buff data-start) starth)
(setf (unsigned-16-value buff (+ 2 data-start)) endh)))
; new end of headers
(setf (unsigned-16-value buff *header-block-used-size-index*) end)))
(defun insert-non-standard-header (buff name value)
;; insert a header that's not known by index into the buffer
;;
(setq name (string name))
(let ((end (unsigned-16-value buff *header-block-used-size-index*)))
(if* (> (+ end (length name) (length value) 4)
(header-block-data-start))
then ; no room
(return-from insert-non-standard-header nil))
(dotimes (i (length name))
(setf (aref buff end) (char-code (aref name i)))
(incf end))
(setf (aref buff end) #.(char-code #\:))
(incf end)
(setf (aref buff end) #.(char-code #\space))
(incf end)
(dotimes (i (length value))
(setf (aref buff end) (char-code (aref value i)))
(incf end))
(setf (aref buff end) #.(char-code #\return))
(incf end)
(setf (aref buff end) #.(char-code #\linefeed))
(incf end)
(setf (unsigned-16-value buff *header-block-used-size-index*) end)))
#+ignore
(defun insert-end-of-headers (buff end)
;; put in the final crlf
(setf (aref buff end) #.(char-code #\return))
(incf end)
(setf (aref buff end) #.(char-code #\linefeed))
(incf end)
end)
(defun header-match-values (request-block cache-block i exactp)
;; compare the header value for the current request vrs the cache-block
;; they match if they are identical
;; or if (not exact) and the request-block value is not given.
;;
(multiple-value-bind (rstart rend rest)
(header-buffer-values request-block i)
(multiple-value-bind (cstart cend cest)
(header-buffer-values cache-block i)
(or (and (null rstart) (null cstart)) ; both not present
(and (null rstart) (not exactp)) ; not given in request and !exact
; check for both present and identical
(and rstart cstart
(eql (- rend rstart) (- cend cstart)) ; same size
(equal rest cest)
(loop
(do ((rr rstart (1+ rr))
(cc cstart (1+ cc)))
((>= rr rend))
(if* (not (eq (aref request-block rr)
(aref cache-block cc)))
then (return-from header-match-values nil)))
(if* rest
then (setq rstart (caar rest)
rend (cdar rest)
cstart (caar cest)
cend (cdar cest))
(pop rest)
(pop cest)
else (return t))))))))
(defun header-match-prefix-string (buff header string)
;; match the prefix of the header vlue against the given string
(if* (symbolp header)
then (let ((val (get header 'kwdi)))
(if* (null val)
then (error "no such header as ~s" header))
(setq header val)))
(multiple-value-bind (rstart rend)
(header-buffer-values buff header)
(if* (and rstart (>= (- rend rstart) (length string)))
then ; compare byte by byte
(dotimes (i (length string) t)
(if* (not (eql (ausb8 buff rstart)
(char-code (schar string i))))
then (return nil))
(incf rstart)))))
(defun header-empty-p (buff header)
;; test to see if there is no value for this header
(if* (symbolp header)
then (let ((val (get header 'kwdi)))
(if* (null val)
then (error "no such header as ~s" header))
(setq header val)))
(header-buffer-values buff header))
(defun add-trailing-crlf (buff xx)
;; buff is a parsed header block.
;; find the end of the data and add a crlf and then return the
;; index right after the linefeed
(declare (ignore xx))
(let ((size (unsigned-16-value buff *header-block-used-size-index*)))
(if* (not (<= 0 size (header-block-data-start)))
then (error "buffer likely isn't a parsed header block"))
(setf (aref buff size) #.(char-code #\return))
(setf (aref buff (1+ size)) #.(char-code #\linefeed))
(+ size 2)))
#+ignore (defun testit ()
;; test the parsing
(let ((str (format nil "Date: 12 jul 2000 ~c~%User-Agent: zipp ~c~%Host: foo.com ~c~%Via: foo~c~% bar~c~% baz~c~%User-Agent: snorter~c~%"
#\return
#\return
#\return
#\return
#\return
#\return
#\return)))
(let ((thebuf (get-sresource *header-block-sresource*)))
(dotimes (i (length str))
(setf (aref thebuf i)
(char-int (schar str i))))
(parse-header-block thebuf 0 (length str))
(setq *xx* thebuf)
(format t "original~%")
(dump-header-block thebuf)
(insert-header thebuf :last-modified "dec 11, 1945")
(insert-header thebuf :user-agent "new agent")
(format t "after mod~%")
(dump-header-block thebuf)
(let ((newbuf (get-sresource *header-block-sresource*)))
(copy-headers thebuf newbuf *header-client-array*)
(format t "after copy ~%")
(dump-header-block newbuf))
)))
(defun dump-header-block (thebuf &optional (str t))
;; debugging function to print out the contents of a block
;; buffer that has been parsed and the parse table stored in it.
(dotimes (i *header-count*)
(multiple-value-bind (start end rest)
(header-buffer-values thebuf i)
(if* start
then (push (cons start end) rest))
(dolist (res rest)
(if* res
then (format str "~d: ~a ~s '"
i
(svref *header-name-array* i)
res)
(do ((ind (car res) (1+ ind)))
((>= ind (cdr res)))
(write-char (code-char (aref thebuf ind)) str))
(format str "'")
(terpri str))))))
(defun compute-request-headers (req)
;; compute an alist of all headers from the request
;; This is slow so it's meant to be used during debugging only.
;;
(let (res)
(dotimes (i *header-count*)
(let ((val (header-buffer-req-header-value req i)))
(if* val
then (push (cons (aref *header-keyword-array* i)
val)
res))))
(nreverse res)))
Jump to Line
Something went wrong with that request. Please try again.