From 57afcdd8b437b3ca9b66126db966d07ed751ed15 Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Sat, 4 May 2024 22:09:46 -0700
Subject: dropped defendpoint; added example

---
 src/defendpoint.lisp | 205 ++++++++++++++++++++++++++++++++++++++++++++++++
 src/endpoint.lisp    | 215 ++-------------------------------------------------
 2 files changed, 212 insertions(+), 208 deletions(-)
 create mode 100644 src/defendpoint.lisp

(limited to 'src')

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."))
diff --git a/src/endpoint.lisp b/src/endpoint.lisp
index c0b89da..a0d8f1d 100644
--- a/src/endpoint.lisp
+++ b/src/endpoint.lisp
@@ -160,7 +160,11 @@ Check your spelling or call
 
 (defun route-matching-regex (parts)
   "Joins route part strings into a route-matching regular expression."
-  (format nil "^/~{~a~^/~}$" parts))
+  (format nil "^/~{~a~^/~}$" (loop :for part :in parts
+                                   :if (symbolp part)
+                                     :collect (symbol-value part)
+                                   :else
+                                     :collect part)))
 
 (defun resolve-route-spec (class)
   "If CLASS has a route spec, then it is transfomred into a route
@@ -193,9 +197,9 @@ matching regex."
             (t
              (error "Cannot build route-builder. 
 
-Non-literal, non-line-boundary regex patterns must be surrounded by
+Non-literal, non-line-boundary regex patterns (~s) must be surrounded by
 parens. There must be exactly as many patterns as there are
-extractors."))))
+extractors." part))))
     (setf build-parts (nreverse build-parts))
     (setf (route-builder class)
           (lambda (kwargs)
@@ -382,208 +386,3 @@ Good for indicating that you've got a  bonkers class option syntax"
   (funcall (route-builder (if (symbolp class) (find-class class) class)) kwargs))
 
 
-;;; 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)
-                      (assert (fboundp parser) (parser)
-                              "No parser bound to ~s for route initarg ~s"
-                              parser key)))))))
-
-(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
-       supers
-       parameters
-       properties
-       metaclass
-       var
-       doc
-       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))
-            (when extractors
-              (list (list* :extractors extractors)))
-            (when doc
-              (list (list :documentation doc)))))) 
-    `(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>)
-                (:@ params (:? <parameters>))
-                (:@ props (:? <properties>))
-                (:@ metaclass (:? <metaclass>))
-                (:@ doc (:? <doc>))
-                (:@ var (:? <var>))
-                (:@ authenticate (:? <authenticate>))
-                (:@ authorize (:? <authorize>))
-                (:@ handle <handle>)
-                (:eof))
-   :then (expand-endpoint-class
-          name
-          method
-          pathspec
-          handle
-          :supers supers
-          :parameters params
-          :properties props
-          :metaclass metaclass
-          :var var
-          :authenticate authenticate
-          :authorize authorize))
-  (<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)")
-  (<doc>
-   :match (:seq (:or= :doc :documentation) (:@ doc (:item)))
-   :if (stringp doc)
-   :then second
-   :note "STRING")
-  (<metaclass>
-   :match (:seq (:= :custom) <classname>)
-   :if (mop:subclassp (second <metaclass>) 'endpoint)
-   :then second
-   :note "SYMBOL naming a subclass of ENDPOINT")
-  (<var>
-   :match (:seq (:= :var) (:item))
-   :if (symbolp (second <var>))
-   :then second
-   :note "SYMBOL bound to the instance during the handler protocol.")
-  (<authenticate>
-   :match (:seq (:= :authenticate) (:item))
-   :then second
-   :note "Body form of authenticate method.")
-  (<authorize>
-   :match (:seq (:= :authorize) (:item))
-   :then second
-   :note "Body form of authorize method.")
-  (<handle>
-   :match (:seq (:= :handle) (:item))
-   :then second
-   :note "Body form of handle method."))
-- 
cgit v1.2.3