aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--examples/dice-roller.lisp39
-rw-r--r--src/defendpoint.lisp205
-rw-r--r--src/endpoint.lisp215
3 files changed, 251 insertions, 208 deletions
diff --git a/examples/dice-roller.lisp b/examples/dice-roller.lisp
new file mode 100644
index 0000000..403ed55
--- /dev/null
+++ b/examples/dice-roller.lisp
@@ -0,0 +1,39 @@
+(defpackage #:dice-roller
+ (:use #:cl)
+ (:import-from #:weekend #:endpoint #:handle))
+
+(in-package #:dice-roller)
+
+(defconstant +digits+ "([0-9]+)")
+
+(defclass roller ()
+ ((rolls
+ :reader rolls
+ :initarg :rolls
+ :type integer
+ :documentation "The number of rolls")
+ (sides
+ :reader sides
+ :initarg :sides
+ :type integer
+ :documentation "The number of sides"))
+ (:documentation "")
+ (:metaclass endpoint)
+ (:method . :get)
+ (:route-parts "roll" +digits+ "d" +digits+)
+ (:extractors (:rolls parse-integer) (:sides parse-integer))
+ (:content-type . "text/plain"))
+
+(defmethod handle ((req roller))
+ (with-slots (rolls sides) req
+ (format nil "~ad~a ... rolled a ~a"
+ rolls sides
+ (loop :repeat rolls :sum (1+ (random sides))))))
+
+(defvar *server* (make-instance 'hunchentoot:easy-acceptor
+ :port 8080))
+
+(hunchentoot:start *server*)
+
+;; now visit http://localhost:8080/roll/10/d/4
+
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."))