diff options
Diffstat (limited to 'src/defendpoint.lisp')
| -rw-r--r-- | src/defendpoint.lisp | 205 |
1 files changed, 205 insertions, 0 deletions
diff --git a/src/defendpoint.lisp b/src/defendpoint.lisp new file mode 100644 index 0000000..2e87874 --- /dev/null +++ b/src/defendpoint.lisp @@ -0,0 +1,205 @@ +;;; 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 return + &key + supers + parameters + properties + metaclass + var + documentation + authenticate + authorize) + (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)) + (list (cons :content-type return)) + (when extractors + (list (list* :extractors extractors))) + (when documentation + (list (list :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 (:item)) + (:@ 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 + options)) + (<supers> + :match (:seq (:= :extends) (:+ <classname>)) + :then second) + (<classname> + :match (:item) + :if find-class) + (<method> + :match (:or= :get :post :put :patch :head :delete)) + (<pathspec> + :match (:seq (:or= :to :from :at) (:+ <pathpart>)) + :then second) + (<pathpart> + :match (:item) + :if path-part-p + :note "REGEX or (KWD REGEX &optional PARSER)") + (<parameters> + :match (:seq (:= :parameters) (:+ <param>)) + :then second) + (<param> + :match (:item) + :if parameter-spec-p + :note "(NAME TYPE &optional DOCSTRING)") + (<properties> + :match (:seq (:= :properties) (:+ <prop>)) + :then second) + (<prop> + :match (:item) + :if property-spec-p + :note "(NAME TYPE &key DEFAULT DOCSTRING)") + (<option> + :match (:or <doc> <metaclass> <var> + <authenticate> <authorize>)) + (<return> + :match (:seq (:= :returns) (:@ mimetype (:item))) + :if (stringp mimetype) + :then second + :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 (list :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.")) |