(in-package #:weekend)

;;; CONDITIONS

(defvar *debugging* nil
  "If T, the debugger will be evoked.")

(define-condition protocol-error (error)
  ((raw-request
    :reader raw-request
    :initarg :raw-request
    :documentation "The server backend's request object, if available")
   (class
    :reader endpoint-class
    :initarg :class
    :documentation "The class registered to handle the raw-request.")
   (note
    :reader note
    :initform nil
    :initarg :note
    :type (or null string))
   (status-code
    :reader status-code
    :initform nil
    :initarg :status-code
    :type (or nil (integer 100 599))))
  (:documentation "Conditions signalled during the request handling protocol."))

(defmethod status-code ((err error)) 500)

(define-condition cannot-authenticate (protocol-error) ()
  (:default-initargs :status-code 401)
  (:documentation "Signalled when a endpoint's AUTHENTICATE method returns NIL,
indicating that the user's identity is required but cannot be determined."))

(define-condition not-authorized (protocol-error) ()
  (:default-initargs :status-code 403)
  (:documentation "Signalled when an endpoint's AUTHORIZE method returns NIL, indiating
that the request has insufficient permissions to evoke the endpoint handler. "))

(define-condition bad-body-error (protocol-error)
  ((wrapped
    :reader wrapped
    :initarg :error
    :initform nil
    :documentation "A root error that may have caused this error to be signalled."))
  (:default-initargs :status-code 400)
  (:documentation "Signalled when the body of a request cannot be deserialized, for any reason.."))

(define-condition slot-required (protocol-error)
  ((mising-slot
    :reader missing-slot
    :initarg :slot))
  (:default-initargs :status-code 400)
  (:documentation "Signalled whenever a required slot is missing from a endpoint
   instance object."))

(define-condition not-found (protocol-error) ()
  (:default-initargs :status-code 404))

(defgeneric protocol-error-result (err)
  (:documentation "The content and mimetype to returned to the client having encountered
    an error.")
  (:method ((err error)) (values nil nil)))

(defun abort-on-error (err)
  "Assign a return code based on the type of error encountered and
   immediately reply."
  (setf (http:return-code*) (status-code err))
  (multiple-value-bind (content type) (protocol-error-result err) 
    (cond ((and content type)
           (setf (http:content-type*) type)
           (http:abort-request-handler content))
          (t
           (http:abort-request-handler)))))

(defvar *debugging* nil
  "If T, conditions signalled during request handling will invoke the
  debugger.")

(defmethod http:acceptor-dispatch-request :around ((acceptor http:acceptor) request)
  (handler-case (call-next-method)

    (error (err)
      (if *debugging*
          (invoke-debugger err)
          (abort-on-error err)))))

(defun protocol-error (error-class ep &rest kwargs)
  (apply #'error
         error-class
         :raw-request (and (boundp 'http:*request*) http:*request*)
         :class ep
         kwargs))


(defun slot-required (ep slot)
  "Signals a SLOT-REQUIRED condition"
  (protocol-error 'slot-required ep :missing-slot slot))


;;; HANDLER PROTOCOL

(defgeneric check-request-compliance (endpoint-instance-class)
  (:documentation "This function is called before instances the endpoint class are
created; This occurrs before the HTTP request's body has been
read. All request headers are available for inspection.  

This is meant to enforce higher-level or server-wide policies, such as
on the size of request bodies.")
  (:method ((epclass symbol))
    (check-request-compliance (find-class epclass)))
  (:method ((epclass t))))

(defgeneric slot-value-mapper (endpoint-class initarg slot-value)
  (:documentation "Values arrive from clients in all manner of ways: in a JSON body, in
query arguments, as form body posts. Weekend allows users to register
body parsers, which transform post bodies according to the request's
mimetype.  However, sometimes this isn't good enough.

A value may require additional alteration before it fills an endpoint
slot.  

SLOT-VALUE-MAPPER is specialized on endpoints, initarg names, and slot
value types to parse or transform values to be what they out to be for
a slot's declared type.  

ENDPOINT-CLASS values MUST BE AN ENDPOINT CLASS.
INITARG values MUST BE A KEYWORD.")

  (:method :around (endpoint (initarg t) value)
    (assert (keywordp initarg) (initarg) "Initarg is not a keyword ~a"
            initarg)
    (call-next-method))

  (:method (endpoint initarg value)
    value))


(defgeneric authenticate (endpoint)
  (:documentation "Returns a boolean. Any protected endpoint should implement
this. Called before handling, should be used to supply
user-identifying data to the endpoint instance that might be needed by
the handle function.")
  (:method ((ep t)) t))

(defgeneric authorize (endpoint)
  (:documentation "Returns a boolean. Any endpoint requiring special ownership
permissions should implement this.  Called before handling and after
authenticate.")
  (:method ((ep t)) t))

(defgeneric handle (endpoint)
  (:documentation "The beef of the endpoint handling protocol.


                           _(__)_        V
                          '-e e -'__,--.__)
                           (o_o)        ) 
                              \. /___.  |
                              ||| _)/_)/
                             //_(/_(/_( 

By the time this has been called, both AUTHENTICATE and AUTHORIZE have
been called. This method can be defined with the assumption that any
work done by AUTHORIZE and AUTHENTICATE has been accomplished
successfully.

This method should return data to be sent back to the client and
MUST be implemented for every endpoint class.")
  (:method :before ((endpoint t))
    ;; The default before method checks that the endpoint is
    ;; authenticated, authorized, default, each of these is T.
    (unless (authenticate endpoint)
      (protocol-error 'cannot-authenticate endpoint))
    (unless (authorize endpoint)
      (protocol-error 'not-authorized endpoint))))

;;; HANDLER TOOLS

(defun not-found (ep)
  "Signals a NOT-FOUND condition. Usually called within HANDLE or
AUTHORIZE while handling endpoint-class instance EP."
  (protocol-error 'not-found ep))

(defun redirect (url)
  "Redirect to URL."
  (http:redirect url :code http:+http-see-other+))

(defun endpoint-redirect (class &rest kwargs)
  "Redirect to another endpoint. CLASS can be either a symbol or a
   class. KWARGS is a PLIST of keyword arguments supplied to the
   CLASS' route builder function."
  (redirect (apply #'route-to class kwargs)))

(defun get-cookie (name)
  "Returns the cookie with name NAME the actively"
  (http:cookie-in name))

(defun get-header (name)
  "Returns the string value of the header named NAME, which can be a
string or keyword."
  (http:header-in* name))

(define-condition request-error (error)
  ((content :reader error-content :initarg :content :initform "Bad Request")
   (mimetype :reader error-content-mimetype :initarg :mimetype :initform "text/plain")
   (code :reader status-code :initarg :code :initform 400)))

(defmethod protocol-error-result ((err request-error))
  (values (error-content err) (error-content-mimetype err)))

(defun err (&key (code 400) (content "Bad Request") (mimetype "text/plain")) 
  "Signal an error and abort request."
  (error 'request-error :code code :content content :mimetype mimetype))

(defun set-response-type (mimetype)
  "Set the Content-Type header of the response."
  (setf (http:content-type*) mimetype))