(in-package :http)

(defclass request ()
  ((method :initarg :method :initform :get)
   (uri :initarg :uri :initform nil)
   (query :initarg :query :initform nil)
   action
   (cookies :initarg :cookies :initform nil)
   (reply-code :initarg :reply-code :initform nil)
   (reply-content-type :initarg :reply-content-type :initform nil)))

(defvar *request*
  nil)

(defun request-method (&optional (request *request*))
  (slot-value request 'method))

(defun request-uri (&optional (request *request*))
  (slot-value request 'uri))

(defun request-query (&optional (request *request*))
  (slot-value request 'query))

(defun request-query-value (name &optional (type 'string) (request *request*))
  (if (eq type 'string)
      (cdr (assoc name (request-query request) :test #'string-equal))
      (parse-parameter name type)))

(defun request-action (&optional (request *request*))
  (with-caching-slot (request 'action)
    (when (eq (request-method request) :post)
      (loop for (name . value) in (request-query request)
	    when (and (>= (length name) 2) (char= (char name 0) #\:))
	    return (intern (string-upcase (subseq name 1)) :keyword)))))

(defun cookies (&optional (request *request*))
  (slot-value request 'cookies))

(defun cookie (name &optional (type 'string) (request *request*))
  (whereas ((string (cdr (assoc name (cookies request) :test #'string-equal))))
    (if (eq type 'string)
	string
	(string->type string type))))

(defun request-reply-code (&optional (request *request*))
  (slot-value request 'reply-code))

(defsetf request-reply-code (&optional (request '*request*)) (code)
  `(setf (slot-value ,request 'reply-code) ,code))

(defun request-reply-content-type (&optional (request *request*))
  (slot-value request 'reply-content-type))

(defsetf request-reply-content-type (&optional (request '*request*)) (content-type)
  `(setf (slot-value ,request 'reply-content-type) ,content-type))

(defun parse-request ()
  (let* ((method (if (string-equal (system:getenv "REQUEST_METHOD") "post") :post :get))
         (path-info (system:getenv "PATH_INFO"))
         (uri (parse-uri (or (and (plusp (length path-info))
                                  (char= (char path-info 0) #\/)
                                  path-info)
                             "/")))
         (query (decode-alist (system:getenv "QUERY_STRING")))
         (cookies (decode-alist (system:getenv "HTTP_COOKIE"))))
    (setf (uri-query uri) (system:getenv "QUERY_STRING"))
    (when (eq method :post)
      (setf query (nconc (parse-post-request) query)))
    (make-instance 'request
		   :method method
		   :uri uri
		   :query query
		   :cookies cookies)))

(defmethod parse-parameter (name (type t))
  (whereas ((string (request-query-value name)))
    (string->type string type)))

(defmethod parse-parameter (name (type (eql 'boolean)))
  (if (request-query-value name) t nil))

(defun parse-parameter-spec (form)
  (if (consp form)
      (destructuring-bind (form &optional (type 'string) default) form
	(if (consp form)
	    (values (string (first form)) (rest form) type default)
	    (values (string form) (list form) type default)))
      (values (string form) (list form) 'string nil)))

(defun expand-query-parsing-form (bindings body param-fn)
  (labels ((expand (bindings)
	     (if bindings
		 (multiple-value-bind (name vars type default) (parse-parameter-spec (pop bindings))
		   (let ((param (funcall param-fn name vars type)))
		     `(multiple-value-bind ,vars ,(if default `(or ,param ,default) param)
		        ,(expand bindings))))
		 `(progn
		    ,@body))))
    (expand bindings)))

(defmacro with-query (bindings &body body)
  (expand-query-parsing-form
   bindings
   body
   (lambda (name vars type)
     (declare (ignore vars))
     `(request-query-value ,name ',type))))

(defun plist-parsed-value (plist name &optional (type 'string))
  (whereas ((string (getf plist name)))
    (cond ((eq type 'string) string)
	  ((stringp string) (string->type string type))
	  (t string))))

(defmacro with-property-list (bindings plist &body body)
  (rebinding (plist)
    (expand-query-parsing-form
     bindings
     body
     (lambda (name vars type)
       (declare (ignore vars))
       `(plist-parsed-value ,plist ,name ',type)))))

(defmethod query-setf-form (place name (type t) default)
  `(setf ,place (or (request-query-value ,name ',type) ,default)))

(defmacro setf-accessors-from-query (instance &rest parameters)
  (rebinding (instance)
    `(progn
       ,@(loop for parameter in parameters
	       collect (multiple-value-bind (name vars type default) (parse-parameter-spec parameter)
			 (query-setf-form (list (first vars) instance) name type default))))))

(defun set-cookie (&rest pairs)
  (flet ((token (object)
	   (when object
	     (uri-encode
	      (typecase object
		(string object)
		(t (princ-to-string object)))))))
    (loop for (name value) on pairs by #'cddr
	  do (format t
		     "Set-Cookie: ~a=~a; path=/; domain=.~a; expires=Thu, 31-Dec-~d 00:00:00 GMT~%"
		     (token name)
		     (token value)
		     (uri-host *base-uri*)
		     (if value 2050 2000)))))