added defendpoint macro

5 files changed, 306 insertions, 21 deletions

diff --git a/src/endpoint.lisp b/src/endpoint.lisp
index 9ec1937..c0b89da 100644
--- a/src/endpoint.lisp
+++ b/src/endpoint.lisp
@@ -27,7 +27,13 @@
   "Return the list of all INITARG symbols that can be supplied as
 keyword arguments to make-instance for CLASS."
   (reduce #'append (mop:class-slots class)
-          :key #'mop:slot-definition-initargs))
+          :key #'mop:slot-definition-initargs
+          :initial-value nil))
+
+(defun class-slot-names (class)
+  (mapcar
+   #'closer-mop:slot-definition-name
+   (closer-mop:class-slots (find-class class))))
 
 ;;; ENDPOINT METACLASS
 
@@ -60,6 +66,12 @@ keyword arguments to make-instance for CLASS."
       consisting in an INITARG and a function to parse a regex group
       match.  There should be the same number of extractors as there
       are regex groups in ROUTE.")
+   (route-builder
+    :accessor route-builder
+    :type function
+    :documentation
+    "A function that generates a route to this endpoint. It is constructed
+    from the route and stored here.")
    (method
     :reader request-method
     :initarg :method
@@ -118,6 +130,13 @@ the request's POST-PARAMETERS slot."
   (gethash type *mimetype-parsers*))
 
 (defun register-body-parser (type function)
+  "TYPE should be a string naming a mimetype. FUNCTION should be a
+designator for a function that accepts a string and returns an
+association list keyed by strings."
+  (when (pre-parsed-body-p type)
+    (warn "You are registering a body parser for ~s but it will be ignored
+           because Hunchentoot pre-parses request bodies of that
+           type." type))
   (setf (gethash type *mimetype-parsers*) function))
 
 (define-condition unregistered-body-type (warning)
@@ -147,18 +166,47 @@ Check your spelling or call
   "If CLASS has a route spec, then it is transfomred into a route
 matching regex."
   (cond
-    ((and (slot-boundp class 'route) (not (slot-boundp class 'route-parts)))
-     ;; we don't want to set anything, but it can't hurt to check the value
-     (unless (stringp (route class))
-       (error "Route should be a string representing a valid regular expression.")))
-    ((and (not (slot-boundp class 'route)) (slot-boundp class 'route-parts))
+    ((slot-boundp class 'route-parts)
      (setf (slot-value class 'route)
            (route-matching-regex (route-parts class))))
     (t
      (error
-      "Exactly one of :RAW-ROUTE or :ROUTE-PARTS must be supplied to the defintion of class ~a"
+      ":ROUTE-PARTS must be supplied to the defintion of class ~a"
       (class-name class)))))
 
+(defun construct-route-builder (class)
+  (assert (slot-boundp class 'route))
+  (let ((build-parts nil))
+    (loop
+      :with extractors := (copy-seq (route-extractors class))
+      :for part :in (ppcre:parse-string (route class))
+      :do (cond 
+            ((stringp part)
+             (push part build-parts))
+            ((symbolp part) nil)
+            ((and (listp part)
+                  (eq :register (first part))
+                  extractors)
+             (let ((ex (pop extractors)))
+               (push (if (listp ex) (first ex) ex)
+                     build-parts)))
+            (t
+             (error "Cannot build route-builder. 
+
+Non-literal, non-line-boundary regex patterns must be surrounded by
+parens. There must be exactly as many patterns as there are
+extractors."))))
+    (setf build-parts (nreverse build-parts))
+    (setf (route-builder class)
+          (lambda (kwargs)
+            (apply #'concatenate 'string
+                   (loop :for part :in build-parts
+                         :when (keywordp part)
+                           :do (assert (getf kwargs part) () "path needs ~s" part)
+                           :and :collect (getf kwargs part)
+                         :else
+                           :collect part))))))
+
 (defun check-endpoint-class (class)
   "Signals an error if any slot values are malformed. 
 
@@ -317,14 +365,225 @@ Good for indicating that you've got a  bonkers class option syntax"
 (defmethod initialize-instance :after ((class endpoint) &key)
   (mop:ensure-finalized class)
   (resolve-route-spec class)
+  (construct-route-builder class)
   (check-endpoint-class class)
   (update-dispatch-function class))
 
 (defmethod reinitialize-instance :after ((class endpoint) &key)
   (mop:ensure-finalized class)
   (resolve-route-spec class)
+  (construct-route-builder class)
   (check-endpoint-class class)
   (update-dispatch-function class))
 
-
-
+;;; TOOLS
+
+(defun route-to (class &rest kwargs)
+  (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."))
diff --git a/src/package.lisp b/src/package.lisp
index c60d03b..a9ab69f 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -5,4 +5,16 @@
   (:local-nicknames
    (#:http #:hunchentoot)
    (#:a #:alexandria-2)
-   (#:mop #:closer-mop)))
+   (#:mop #:closer-mop))
+  (:export
+   ;; HANDLER PROTOCOL
+   #:authenticate
+   #:authorize
+   #:handle
+   #:not-found
+   #:slot-required
+
+   ;; METACLASS
+   #:endpoint
+   #:register-body-parser))
+
diff --git a/src/protocol.lisp b/src/protocol.lisp
index 19a4791..d25aa22 100644
--- a/src/protocol.lisp
+++ b/src/protocol.lisp
@@ -52,7 +52,7 @@ that the request has insufficient permissions to evoke the endpoint handler. "))
   (:documentation "Signalled whenever a required slot is missing from a endpoint
    instance object."))
 
-(define-condition not-found (protocol-error)
+(define-condition not-found (protocol-error) ()
   (:default-initargs :status-code 404))
 
 (defgeneric protocol-error-result (err)
@@ -88,15 +88,18 @@ that the request has insufficient permissions to evoke the endpoint handler. "))
           (invoke-debugger err)
           (http:abort-request-handler)))))
 
-(defun protocol-error (error-class req &rest kwargs)
+(defun protocol-error (error-class ep &rest kwargs)
   (apply #'error
          error-class
          :raw-request http:*request*
-         :class (class-of req)
+         :class (class-of ep)
          kwargs))
 
-(defun not-found (req)
-  (protocol-error 'not-found req))
+
+(defun slot-required (ep slot)
+  "Signals a SLOT-REQUIRED condition"
+  (protocol-error 'slot-required ep :missing-slot slot))
+
 
 ;;; HANDLER PROTOCOL
 
@@ -105,13 +108,13 @@ that the request has insufficient permissions to evoke the endpoint handler. "))
 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 ((req t)) t))
+  (: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 ((req t)) t))
+  (:method ((ep t)) t))
 
 (defgeneric handle (endpoint)
   (:documentation "The beef of the endpoint handling protocol.
@@ -139,6 +142,19 @@ MUST be implemented for every endpoint class.")
     (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 redirect-to (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)))
diff --git a/src/server.lisp b/src/server.lisp
deleted file mode 100644
index e69de29..0000000
--- a/src/server.lisp
+++ /dev/null
diff --git a/weekend.asd b/weekend.asd
index 6e7f833..e48b022 100644
--- a/weekend.asd
+++ b/weekend.asd
@@ -1,7 +1,7 @@
 ;;;; weekend.asd
 
 (asdf:defsystem #:weekend
-  :description "A Metaclass and Protocol for Defining Webservers."
+  :description "A Metaclass and Protocol for Defining Webservers on Hunchentoot."
   :author "colin <colin@cicadas.surf>"
   :license  "AGPLv3.0"
   :version "0.0.1"
@@ -10,6 +10,4 @@
   :serial t
   :components ((:file "package")
                (:file "protocol")
-               (:file "endpoint")
- ;              (:file "server")
-               ))
+               (:file "endpoint")))