(in-package :weekend)

;;; DEFENDPOINT

(defun path-part-p (part)
  "Returns T if PART is a a valid route path part.

PART is either
  STRING 
  (KEYWORD STRING) 
  (KEYWORD STRING FUNCTION-NAME)"
  (or (stringp part)
      (and (listp part)
           (or (and (= 2 (length part))
                    (do>
                      (key str) :match= part
                      :when (keywordp key)
                      :when (stringp str)))
               (and (= 3 (length part))
                    (do>
                      (key str parser) :match= part
                      :when (keywordp key)
                      :when (string str)
                      :when (symbolp parser)
                      (fboundp parser)))))))

(defun parameter-spec-p (spec)
  "Returns T if SPEC is a valid parameter spec for a DEFENDPOINT form.

(NAME TYPE &OPTIONAL DOC)"
  (and (listp spec)
       (symbolp (first spec))
       (symbolp (second spec))
       (or (not (third spec))
           (stringp (third spec)))))

(defun property-spec-p (spec)
  "Returns T if SPEC is a valid property spec for a DEFENDPOINT form.

(NAME TYPE &KEY DEFAULT DOC)"
  (and (listp spec)
       (symbolp (first spec))
       (symbolp (second spec))))

(defun params-to-slotdefs (specs)
  (loop :for (name type . doc) :in specs
        :collect `(,name
                   :accessor ,name
                   :initarg ,(a:make-keyword name)
                   :type ,type
                   :documentation ,(or (first doc) ""))))

(defun props-to-slotdefs (specs)
  (loop :for (name type . kwargs) :in specs
        :collect `(,name
                   :accessor ,name
                   :initform ,(getf kwargs :default)
                   :type (or null ,type)
                   :documentation ,(or (getf kwargs :doc "")
                                       (getf kwargs :documentation "")))))

(defun expand-endpoint-class
    (name method pathspec handle
     &key
       return       
       supers
       parameters
       properties
       metaclass
       var
       documentation
       authenticate
       authorize)
  (loop :for super :in supers :do (mop:ensure-finalized (find-class super)))
  (setf var (or var (gensym "REQ-")))
  (setf metaclass (or metaclass 'endpoint))
  (let* ((slot-defs
           (nconc (params-to-slotdefs parameters)
                  (props-to-slotdefs properties)))
         (all-slots
           (nconc (mapcar #'first slot-defs)
                  (reduce #'union supers :key #'class-slot-names :initial-value nil)))
         (route-parts
           (loop :for part :in pathspec
                 :when (stringp part)
                   :collect part
                 :else
                   :collect (second part)))
         (extractors
           (loop :for part :in pathspec
                 :when (listp part)
                   :collect (if (third part)
                                (list (first part) (third part))
                                (first part))))
         (class-options
           (nconc
            (list (list :metaclass metaclass))
            (list (cons :method method))
            (list (list* :route-parts route-parts))
            (when return
              (list (cons :content-type return)))
            (when extractors
              (list (list* :extractors extractors)))
            (when documentation
              (list (cons :documentation documentation)))))) 
    `(progn
       (defclass ,name ,supers
         ,slot-defs
         ,@class-options)

       (defmethod handle ((,var ,name))
         (with-slots ,all-slots ,var
           ,handle))

       ,@(when authenticate
           (list
            `(defmethod authenticate ((,var ,name))
               (with-slots ,all-slots ,var
                 ,authenticate))))

       ,@(when authorize
           (list
            `(defmethod authorize ((,var ,name))
               (with-slots ,all-slots ,var
                 ,authorize)))))))

(argot:deflanguage defendpoint ()
  (<class>
   :match (:seq (:@ name <classname>)
                (:@ supers (:? <supers>))
                (:@ method <method>)
                (:@ pathspec <pathspec>)
 ;               (:@ return (:? <return>))
;                (:@ params (:? <parameters>))
;                (:@ props (:? <properties>))
                (:@ options (:* <option>))
                (:@ handle <handle>)
                (:eof))
   :then (apply #'expand-endpoint-class
                name
                method
                pathspec
                handle
;                return
                :supers supers
;                :parameters params
;                :properties props
                (a:alist-plist options)))
  (<supers>
   :match (:seq (:or= :using :extends) (:+ <classname>))
   :then second)
  (<classname>
   :match (:item)
   :if (and (symbolp <classname>) (not (keywordp <classname>))))
  (<method>
   :match (:or= :get :post :put :patch :head :delete))
  (<pathspec>
   :match (:seq (:or= :to :route) (:+ <pathpart>))
   :then second)
  (<pathpart>
   :match (:item)
   :if path-part-p
   :note "REGEX or (KWD REGEX &optional PARSER)")
  (<parameters>
   :match (:seq (:= :parameters) (:+ <param>))
   :then (cons :parameters (second <parameters>)))
  (<param>
   :match (:item)
   :if parameter-spec-p
   :note "(NAME TYPE &optional DOCSTRING)")
  (<properties>
   :match (:seq (:= :properties) (:+ <prop>))
   :then (cons :properties (second <properties>)))
  (<prop>
   :match (:item)
   :if property-spec-p
   :note "(NAME TYPE &key DEFAULT DOCSTRING)")
  (<option>
   :match (:or <return> <parameters> <properties>
               <doc> <metaclass> <var>
               <authenticate> <authorize>))
  (<return>
   :match (:seq (:= :returns) (:@ mimetype (:item)))
   :if (stringp mimetype)
   :then (cons :return (second <return>))
   :note "The mimetype returned from this endpoint.")
  (<doc>
   :match (:seq (:= :documentation) (:@ doc (:item)))
   :if (stringp doc)
   :then (list :documentation doc)
   :note "STRING")
  (<metaclass>
   :match (:seq (:= :custom) <classname>)
   :if (mop:subclassp (second <metaclass>) 'endpoint)
   :then (list :metaclass (second <metaclass>))
   :note "SYMBOL naming a subclass of ENDPOINT")
  (<var>
   :match (:seq (:= :var) (:item))
   :if (symbolp (second <var>))
   :then (cons :var (second <var>))
   :note "SYMBOL bound to the instance during the handler protocol.")
  (<authenticate>
   :match (:seq (:= :authenticate) (:item))
   :note "Body form of authenticate method.")
  (<authorize>
   :match (:seq (:= :authorize) (:item))
   :note "Body form of authorize method.")
  (<handle>
   :match (:seq (:= :handle) (:item))
   :then second
   :note "Body form of handle method."))