(in-package :araneida)


(defgeneric request-path-info (request)
  (:documentation "Returns portion of the requested URL after the base-url"))
(defmethod request-path-info ((r request))
  (let ((path (url-path (request-url r)))
        (ppath (url-path (request-base-url r))))
    (subseq path (length ppath) nil)))

(defgeneric request-unhandled-part (request)
  (:documentation "Returns portion of request unhandled (??)"))
(defmethod request-unhandled-part ((request request))
  (let* ((handled-by (request-handled-by request))
	 (offset (or (second (first handled-by)) 0))
	 (urlstring (request-urlstring request)))
    (subseq urlstring offset)))

(defgeneric request-header (request name)
  (:documentation "Returns a list containing the values of all header lines in REQUEST given by the keyword NAME"))

(defmethod request-header ((r request) name)
  (cdr (assoc name (request-headers r) :test #'string=)))

(defgeneric request-if-modified-since (request &optional default)
  (:documentation "Retrieve and parse the date in the If-Modified-Since header field.  Return DEFAULT if the header is absent or unparseable"))
(defmethod request-if-modified-since ((request request)
                                      &optional (default nil))
  (let ((if-mod-since (car (request-header request :if-modified-since))))
    (if if-mod-since
             (or (date:parse-time (car (split if-mod-since 2 '(#\;))))
                 default)
      default)))

(define-condition cookie-not-found (serious-condition)
  ((cookie-name :initarg :cookie-name
		:reader cookie-not-found-cookie-name))
  (:report (lambda (condition stream)
	     (format stream "Cookie ~A was not found"
		     (cookie-not-found-cookie-name condition)))))

(defgeneric request-cookie (request cookie-name &key on-fail)
  (:documentation "Returns the value of the cookie named COOKIE-NAME
If the cookie is not found, the default is to return nil. :on-fail can also
be set to :signal-condition, whereupon it will signal a cookie-not-found condition.

Valid values for on-fail:
  :return-nil
  :signal-condition"))
(defmethod request-cookie ((request request) name &key (on-fail :return-nil))
  (let ((cookie (find-if (lambda (c) (string-equal (rfc2109:cookie-name c) name))
			  (request-cookies request))))
    (if cookie
	(rfc2109:cookie-value cookie)
	(ecase on-fail
	  (:return-nil nil)
	  (:signal-condition (error 'cookie-not-found :cookie-name name))))))

(defgeneric request-safe-cookie (request cookie-name domain-restrict &key on-fail)
  (:documentation "Returns the value of the cookie named COOKIE-NAME, guarding against spoofing attacks.
The cookie will only be used if its domain matches domain-restrict (a string), or if its domain is blank.
If the cookie is not found, the default is to return nil. :on-fail can also
be set to :signal-condition, whereupon it will signal a cookie-not-found condition.

Valid values for on-fail:
  :return-nil
  :signal-condition"))
(defmethod request-safe-cookie ((request request) name domain-restrict &key (on-fail :return-nil))
  (let ((cookie (find-if (lambda (c) (string-equal (rfc2109:cookie-name c) name))
			  (request-safe-cookies request domain-restrict))))
    (if cookie
	(rfc2109:cookie-value cookie)
	(ecase on-fail
	  (:return-nil nil)
	  (:signal-condition (error 'cookie-not-found :cookie-name name))))))
	
  
(defgeneric request-cookies (request)
  (:documentation "Returns cookie-structs for all cookies returned (see rfc2109 package for details)
This is rarely used directly. REQUEST-COOKIE is the better choice for most uses."))
(defmethod request-cookies ((request request))
  (loop for cookie-string in (request-header request :cookie)
	appending (rfc2109:parse-cookies cookie-string)))

(defgeneric request-safe-cookies (request domain-restriction)
  (:documentation "Returns cookie-structs for all cookies returned, avoiding spoofing attacks
domain-restriction is a string such as 'my.test.domain' which should match your website's domain
See the RFC2109 package for details
This is rarely used directly. REQUEST-SAFE-COOKIE is the better choice for most uses."))
(defmethod request-safe-cookies ((request request) domain-restriction)
  (loop for cookie-string in (request-header request :cookie)
	appending (rfc2109:safe-parse-cookies cookie-string domain-restriction)))

(defun cookie-string (name value &key comment domain max-age path secure)
  "Returns a cookie string suitable for setting
See documentation for RFC2109:COOKIE-STRING for details."
  (rfc2109:cookie-string name value :comment comment :domain domain :max-age max-age :path path :secure secure))


;; this takes an alist not a request, hence the name
(defun body-param (name alist)
  "Look in the request body ALIST for the value of the parameter NAME"
  (cadr (assoc name alist :test #'string=)))

(defun body-params (name alist &key (case-sensitive nil))
  "Look in the request body ALIST for the values of the parameters starting NAME, returning a list of KEY VALUE pairs"
  ;; find all parameters starting NAME
  (let ((equal (if case-sensitive #'string= #'string-equal))
        (len (length name)))
    (flet ((starts-with-name (string)
             (and (>= (length string) len)
                  (funcall equal string name :end1 len))))
      (remove-if-not #'starts-with-name alist :key #'car))))

(defgeneric dispatch-request (request handlers &optional discriminator)
  (:documentation "Find the best match for REQUEST in the list HANDLERS"))
(defmethod dispatch-request ((request request) handlers &optional discriminator)
  (unless discriminator (setf discriminator (request-url request)))
  (destructuring-bind
        (method match prefix func &optional needs-discriminator)
      (find-export (urlstring discriminator) handlers (request-method request))
    (declare (ignore match))
    (unless method (return-from dispatch-request nil))
    (setf (request-base-url request) (parse-urlstring prefix))
    (let ((rest-of-url
           (subseq (urlstring discriminator)
                   (length (urlstring (request-base-url request)))
                   nil)))
      (cond ((and needs-discriminator (consp func))
             (apply (car func) request handlers discriminator
                    rest-of-url (cdr func)))
            ((consp func)
             (apply (car func) request rest-of-url (cdr func)))
            (needs-discriminator
             (funcall func request handlers discriminator rest-of-url))
            (t
             (funcall func request rest-of-url))))))

;;; rfc 1945 p26
(defvar *http-error-codes*
  '((400 . "Bad Request")
    (401 . "Unauthorized")
    (402 . "Payment required")
    (403 . "Forbidden")
    (404 . "Not Found")
    (500 . "Internal Server Error")
    (501 . "Not Implemented")
    (502 . "Bad Gateway")
    (503 . "Service Unavailable")))

(defgeneric request-send-headers (request &key
                                 content-type
                                 content-length
                                 expires
				 cache-control
				 location
				 refresh
				 pragma
				 set-cookie
				 conditional
				 www-authenticate
                                 extra-http-headers
                                 last-modified
                                 response-text
                                 response-code)
  (:documentation "Send HTTP/1.0 headers in response to REQUEST.  If the request HTTP version
is less than 1.0, do nothing.  If CONDITIONAL is true, may signal RESPONSE-SENT
instead of returning normally."))
(defmethod request-send-headers ((request request) &key
                                 (content-type "text/html")
                                 content-length
                                 expires
				 cache-control
				 location
				 refresh
				 pragma
				 set-cookie
				 conditional
				 www-authenticate
                                 extra-http-headers
                                 (last-modified (get-universal-time))
                                 (response-text "OK")
                                 (response-code 200))
  (when (< (request-http-version request) 1.0)
    (return-from request-send-headers response-code))
  (let ((stream (request-stream request))
        (cr (code-char 13))
        (lf (code-char 10)))
    (labels ((perhaps (if name &optional then)
	       (if if (princ (s. name ": " (or then if)  (format nil "~C~C" cr lf))
			     stream)))
	     (date (d) 
	       (if (numberp d) (date:universal-time-to-http-date d) d)))
      (when (and conditional
		 (<= last-modified
		     (request-if-modified-since request 0)))
	(setf response-code 304 response-text "Not modified"))
      (when (eql response-code 304)
	;;  "the response {SHOULD,MUST} NOT include other
	;;  entity-headers; this prevents inconsistencies between
	;;  cached entity-bodies and updated headers.
	(setf content-length nil content-type nil))
      (format stream "HTTP/1.0 ~D ~A~C~C~
Date: ~A~C~C~
Server: ~A~C~C~
Connection: close~C~C"
	      response-code response-text cr lf
	      (date:universal-time-to-http-date (get-universal-time)) cr lf
	      *araneida-product-tokens* cr lf cr lf)
      (perhaps content-type "Content-Type")
      (perhaps last-modified "Last-Modified" (date last-modified))
      (perhaps content-length "Content-Length")
      (if set-cookie
	  (let ((cookies (if (listp set-cookie) set-cookie (list set-cookie))))
	    (dolist (cookie cookies) (perhaps cookie "Set-Cookie"))))
      (perhaps cache-control "Cache-Control" )
      (perhaps refresh "Refresh" )
      (perhaps location "Location" )
      (perhaps pragma "Pragma" )
      (perhaps expires "Expires"  (date expires))
      (perhaps www-authenticate "WWW-Authenticate")
      (mapc #'(lambda (header)
                (format stream "~A: ~A~C~C" (car header) (cdr header) cr lf))
            extra-http-headers)
      (format stream "~C~C" cr lf)
      (when (eql response-code 304)
	;; "The 304 response MUST NOT contain a message-body" (rfc2616)
	(signal 'response-sent)))
    response-code))

(defgeneric request-send-error (request error-code &key log-message client-message)
  (:documentation "Send the client HTTP headers and HTML body for an error message
with numeric code ERROR-CODE. LOG-MESSAGE is sent to *log-stream*, while CLIENT-MESSAGE
is sent on to the user - replacing the default text. CLIENT-MESSAGE is passed to format,
so it should not be an HTML list"))
(defmethod request-send-error ((request request) error-code &key log-message client-message)
  (let ((stream (request-stream request))
        (error-text (cdr (assoc error-code *http-error-codes*))))
    (when *log-stream*
      (format *log-stream* "~&Logged error: ~A ~A ~@[~A~] while processing URL <~A>~%" 
	      error-code error-text log-message (urlstring (request-url request))))
    (request-send-headers request
                          :response-code error-code :response-text error-text)
    (html-stream stream
		 `(html (head (title ,(s. error-code) " " ,error-text))
		   (body
		    (h2 ,error-text)
		    (p "Was asked for URL "
		     (tt ,(urlstring (request-url request)))
		     ", but it didn't happen for us.  Sorry")
		    ,@(when client-message
			    `((H3 "Additional information: ")
			      (pre ,(html-escape (format nil "~a" client-message))))))))
  (signal 'response-sent)))

(defgeneric request-redirect (request new-url &rest headers)
  (:documentation "Redirects request to NEW-URL, appending HEADERS to the redirect"))
(defmethod request-redirect ((request request) new-url &rest headers)  
  (let ((urlstring (urlstring
                    (if (typep new-url 'url)
			new-url
			(merge-url (request-url request) new-url)))))
    (apply #'request-send-headers
	   request
	   :location urlstring
	   :expires "Fri, 30 Oct 1998 14:19:41 GMT"
	   :pragma "no-cache"
	   :response-code 302 :response-text "Redirected"
	   headers)
    (format (request-stream request)
	    "~%<h1>Redirected</h1><p>Continue <a href=\"~A\">~A</a>"
	    urlstring urlstring)
    (signal 'response-sent)))

(defun copy-request (from)
  (let ((to (make-instance 'request)))
    (labels ((set-slot (name)
	       (if (slot-boundp from name)
		   (setf (slot-value to name)  (slot-value from name))
		   (slot-makunbound to name))))
      (dolist (i '(url urlstring http-version handled-by user 
		   method stream headers body unparsed-body condition))
	(set-slot i)))
    to))