Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

checkpoint

  • Loading branch information...
commit 13126960fb6a0bf9cba1bc1d8b55a869b965f888 1 parent 342652b
jkf authored
Showing with 169 additions and 20 deletions.
  1. +169 −20 client.cl
View
189 client.cl
@@ -22,7 +22,7 @@
;; Suite 330, Boston, MA 02111-1307 USA
;;
;;
-;; $Id: client.cl,v 1.1.2.1 2000/03/15 23:06:53 jkf Exp $
+;; $Id: client.cl,v 1.1.2.2 2000/03/16 17:17:17 jkf Exp $
;; Description:
;; http client code.
@@ -606,9 +606,68 @@
:accessor client-request-response-code)
(socket ; the socket through which we'll talk to the server
:initarg :socket
- :accessor client-request-socket)))
+ :accessor client-request-socket)
+ (protocol
+ ; the protocol value returned by the web server
+ ; note, even if the request is for http/1.0, apache will return
+ ; http/1.1. I'm not sure this is kosher.
+ :accessor client-request-protocol)
+ (response-comment ;; comment passed back with the response
+ :accessor client-request-response-comment)
+ ))
+(defmacro with-better-scan-macros (&rest body)
+ ;; define the macros for scanning characters in a string
+ `(macrolet ((collect-to (ch buffer i max &optional downcasep)
+ ;; return a string containing up to the given char
+ `(let ((start ,i))
+ (loop
+ (if* (>= ,i ,max) then (fail))
+ (if* (eql ,ch (schar ,buffer ,i))
+ then (return (buf-substr start i ,buffer ,downcasep)))
+ (incf ,i)
+ )))
+
+ (collect-to-eol (buffer i max)
+ ;; return a string containing up to the given char
+ `(let ((start ,i))
+ (loop
+ (if* (>= ,i ,max)
+ then (return (buf-substr start ,i ,buffer)))
+ (let ((thisch (schar ,buffer ,i)))
+ (if* (eq thisch #\return)
+ then (let ((ans (buf-substr start ,i ,buffer)))
+ (incf ,i) ; skip to newline
+ (return ans))
+ elseif (eq thisch #\newline)
+ then (return (buf-substr start ,i ,buffer))))
+ (incf ,i)
+ )))
+
+ (skip-to-not (ch buffer i max)
+ ;; skip to first char not ch
+ `(loop
+ (if* (>= ,i ,max) then (fail))
+ (if* (not (eq ,ch (schar buffer ,i)))
+ then (return))
+ (incf ,i)))
+
+ (buf-substr (from to buffer &optional downcasep)
+ ;; create a string containing [from to }
+ ;;
+ `(let ((res (make-string (- ,to ,from))))
+ (do ((ii ,from (1+ ii))
+ (ind 0 (1+ ind)))
+ ((>= ii ,to))
+ (setf (schar res ind)
+ ,(if* downcasep
+ then `(char-downcase (schar ,buffer ii))
+ else `(schar ,buffer ii))))
+ res)))
+
+ ,@body))
+
(defun make-http-client-request (uri &key
(method :get) ; :get, :post, ....
@@ -666,28 +725,118 @@
(defmethod read-client-response-headers ((creq client-response))
;; read the response and the headers
- (let ((buffer (get-response-buffer))
- (i 0)
- (sock (client-request-socket creq)))
- (with-scan-macros
- (if* (zerop (read-socket-line creq buff (length buff)))
+ (let ((buff (get-header-line-buffer))
+ (buff2 (get-header-line-buffer))
+ (pos 0)
+ (len)
+ (sock (client-request-socket creq))
+ (headers)
+ protcol
+ response
+ comment
+ saveheader
+ saveheader-len
+ )
+ (with-better-scan-macros
+ (if* (null (setq len (read-socket-line creq buff (length buff))))
then ; eof getting response
(error "premature eof from server"))
- (let (protcol
- response
- comment)
- (setq protocol (collect-to #\space))
- (skip-to-not #\space)
- (setq response (collect-to #\space))
- (skip-to-not #\space)
- (setq comment (collect-to-eol))
-
- ; now read the header lines
- ))))
-
+ (macrolet ((fail ()
+ (let ((i 0))
+ (error "illegal response from web server: ~s"
+ (collect-to-eol buff i len)))))
+ (setq protocol (collect-to #\space buff pos len))
+ (skip-to-not #\space buff pos len)
+ (setq response (collect-to #\space buff pos len))
+ (skip-to-not #\space buff pos len)
+ (setq comment (collect-to-eol buff pos len)))
+
+ (if* (equalp protocol "HTTP/1.0")
+ then (setq protocol :http/1.0)
+ elseif (equalp protocol "HTTP/1.1")
+ else (error "unknown protocol: ~s" protocol))
+
+ (setf (client-request-protocol creq) protocol)
+
+ (setf (client-request-response-code creq)
+ (quick-convert-to-integer respone))
+
+ (setf (client-request-response-comment creq) comment)
+
+
+ ; now read the header lines
+ (loop
+ (if* saveheader
+ then ; buff2 has the saved header we should work on next
+ (exch buff buff2)
+ (setq len len2
+ saveheader nil)
+ elseif (null (setq len (read-socket-line creq buff (length buff))))
+ then ; eof before header lines
+ (error "premature eof in headers")
+ elseif (eql len 0)
+ then ; last header line
+ (return))
+
+ ; got header line. Must get next one to see if it's a continuation
+ (if* (null (setq len2 (read-socket-line creq buff2 (length buff2))))
+ then ; eof before crlf ending the headers
+ (error "premature eof in headers")
+ elseif (and (> len2 0)
+ (eq #\space (schar buff2 0)))
+ then ; a continuation line
+ (if* (< (length buff) (+ len len2))
+ then (let ((buff3 (make-array (+ len len2 50)
+ :element-type 'character)))
+ (dotimes (i len)
+ (setf (schar buff3 i) (schar buff i))
+ (put-header-line-buffer buff)
+ (setq buff buff3))))
+ ; can all fit in buff
+ (do ((to len (1+ to))
+ (from 0 (1+ from)))
+ ((>= from len2))
+ (setf (schar buff to) (schar buff2 from))
+ )
+ else ; must be a new header line
+ (setq saveheader t))
+
+ ; parse header
+ (let ((pos 0)
+ (headername)
+ (headervalue))
+ (macrolet ((fail ()
+ (let ((i 0))
+ `(error "header line missing a colon: ~s"
+ (collect-to-eol buff i len)))))
+ (setq headername (collect-to #\: buff pos len)))
+
+ (incf pos) ; past colon
+ (skip-to-not #\space buff pos len)
+ (setq headervalue (collect-to-eol buff pos len))
+
+ (push (cons headername headervalue) headers))))))
+
+
+(defun quick-convert-to-integer (str)
+ ; take the simple string and convert it to an integer
+ ; it's assumed to be a positive number
+ ; no error checking is done.
+ (let ((res 0))
+ (dotimes (i (length str))
+ (let ((chn (- (char-code (schar str i)) #.(char-code #\0))))
+ (if* (<= 0 chn 9)
+ then (setq res (+ (* 10 res) chn)))))
+ res))
+
-
+;; buffer pool for string buffers of the right size for a header
+;; line
+
+(defvar *response-header-buffers* nil)
+
+
Please sign in to comment.
Something went wrong with that request. Please try again.