(in-package :araneida)

(defvar *araneida-mode* :standard
  "Defines what mode Araneida operates in. Controls things
such as how headers are handled.

:standard - default. Araneida-like operation
:tbnl     - suitable for use as a TBNL frontend. TBNL will automatically put
            Araneida into this mode on load.")

(defun read-http-line (stream &optional eof-error eof-value)
  ;; read a line terminated with a LF, even under old MacOS
  (with-output-to-string (o)
    (loop for char = (read-char stream eof-error eof-value)
          while (and (not (eql char eof-value))
                     (not (eql char #.(code-char 10))))
          do (write-char char o))))

(defun parse-protocol-version (string)
  (let ((f (position #\/ string))
	(d (position #\. string))
	(l (length string)))
    (+ (parse-integer string :start (1+ f) :end d)
       (if d
	   (/ (parse-integer string :start (1+ d))
	      (expt 10 (- l d 1)))
	   0))))

(defun read-request-from-stream (listener stream)
  (destructuring-bind (method url-string &optional protocol)
      (split (read-http-line stream t) 3 '(#\Space))
    (let ((headers (and protocol (read-headers stream))))
      (ecase *araneida-mode*
	(:standard
	 (let* ((http-version
		 (or (and protocol (parse-protocol-version protocol)) 0.9))
		(content-length (parse-integer
				 (or (header-value :content-length headers) "0")))
		(body (and (> content-length 0)
		     ;; The make-array form sounds good but breaks on
                     ;; streams (like Allegro's multivalent sockets)
                     ;; that do not have some kind of character
                     ;; element type, because parse-body (and other
                     ;; code) assumes it gets a string, not a vector
                     ;; of character codes. So I replaced it by
                     ;; make-string (Arthur Lemmens). (merged by Alan Shields [14 November 2005])
		     ;;
		     ;; doesn't seem to break SBCL or CMUCL -- Alan Shields [14 November 2005]
			   (make-string content-length)))
		(len (and (> content-length 0)
			  (read-sequence body stream)))
		(url (merge-url 
		      ;; it may be argued that we're going to hell for this, but
		      ;; (header-value :host) may in fact be host:port and I'm
		      ;; not about to pick it apart now just so we can use
		      ;; make-url instead 
		      (parse-urlstring
		       (format nil "http://~A/"
			       (or (header-value :host headers)
				   (http-listener-default-hostname listener))))
		      url-string)))
	   (make-instance 'request 
			  :url url
			  :urlstring (urlstring url)
			  :method (intern (nstring-upcase method) 'keyword)
			  :http-version http-version
			  :unparsed-body body
                          :unparsed-body-length len
			  :stream stream :headers headers )))
	(:tbnl
	 (values method url-string protocol headers))))))

(defun parse-body (body-string &optional (delimiters '(#\&)) end)
  "Parse BODY-STRING returning list of (var val) pairs"
  (mapcar (lambda (x)
            (mapcar #'urlstring-unescape (split-sequence #\= x :count 2)))
          (split-sequence-if (lambda (x) (member x delimiters))
			     body-string :end end)))

(defun read-folded-line (stream &optional eof-error-p eof-value)
  "Read a complete logical header line, including folded continuation lines."
  (with-output-to-string (o)
    (loop
     (let* ((l (read-http-line stream eof-error-p eof-value))
	    (end (position-if (lambda (x) (or (eql x (code-char 10))
					      (eql x (code-char 13))))
			      l))
	    (next (and (if end (> end 0) t)
		       (> (length l) 0)
		       (peek-char nil stream nil nil))))
       (write-sequence l o :end end)
       (unless (or (eql next #\Space) (eql next #\Tab)) (return))))))

;;; Unless you're me (and probably not even then), you should be
;;; using REQUEST-HEADER not this:

(defun header-value (name header-list)
  "Get the value of the header named NAME in HEADER-LIST"
  (cadr (assoc name header-list)))

(defun read-headers (stream)
  (let ((headers nil))
    (do ((line (read-folded-line stream t) (read-folded-line stream t)))
        ((or (not line) (zerop (length line))) headers)
      
      ;; RFC 1945: "Each header field consists of a name followed
      ;; immediately by a colon (":"), a single space (SP) character,
      ;; and the field value. Field names are case- insensitive."
      (let* ((colon-pos (position #\: line))
	     (keyword (subseq line 0 colon-pos))
	     (value (subseq line (+ 2 colon-pos)))
	     (keyword-symbol (intern (string-upcase keyword) :keyword))
	     (keyword-value (assoc keyword-symbol  headers)))
	(ecase *araneida-mode*
	  (:standard (if keyword-value
			 (setf (cdr (last keyword-value)) (list value))
			 (setf headers (acons keyword-symbol (list value) headers))))
	  (:tbnl     (let ((name (if (stringp keyword)
				     keyword
				     (format nil "~a" keyword)))
			   (val  (if (stringp value)
				     value
				     (format nil "~a" value))))
		       (if keyword-value
			   (rplacd (assoc name headers) val)
			   (push (cons name val) headers)))))))
    headers))