Add: parenscript request api function generation

4 files changed, 100 insertions, 22 deletions

diff --git a/src/client/ps/generate.lisp b/src/client/ps/generate.lisp
new file mode 100644
index 0000000..11b0c53
--- /dev/null
+++ b/src/client/ps/generate.lisp
@@ -0,0 +1,56 @@
+(defpackage #:weekend.client.ps
+  (:use #:cl)
+  (:import-from #:flatbind #:do>)
+  (:local-nicknames
+   (#:wknd #:weekend)
+   (#:a #:alexandria-2))
+  (:export #:parenscript))
+
+(in-package #:weekend.client.ps)
+
+
+;; this function largely mirrors the implementation of construct-route-builder
+(defun generate-endpoint-client (class)
+  (when (symbolp class) (setf class (find-class class)))
+
+  (let*
+      ((args
+         (mapcar (a:compose #'intern #'string)
+                 (wknd:class-initargs class)))
+       (parts
+         (loop
+           :for part :in (wknd:route-builder-parts class)
+           :when (or (stringp part) (characterp part))
+             :collect part
+           :else
+             :collect (intern (string part))))
+       (method
+         (wknd:request-method class))
+       (body
+         (when (wknd:body-expected-p method)
+           `(ps:chain -J-S-O-N
+                      (stringify
+                       (ps:create
+                        ,@(loop :for arg :in args
+                                :collect arg :collect arg))))))
+       (url-param-names
+         (unless (wknd:body-expected-p method)
+           (set-difference args parts :test 'eq)))
+       (url-params
+         (when url-param-names
+           (cons "?"
+                 (loop :for (param . more) :on url-param-names
+                       :collect (string param)
+                       :collect "="
+                       :collect param
+                       :when more
+                         :collect "&")))))
+    `(defun ,(class-name class) ,args
+       (fetch (+ ,@parts ,@url-params)
+              (ps:create
+               method ,(string method)
+               cache "no-cache"
+               headers (ps:create "Content-Type" "application/json")
+               redirect follow
+               ,@(when body (list 'body body)))))))
+
diff --git a/src/endpoint.lisp b/src/endpoint.lisp
index 223c24a..c827036 100644
--- a/src/endpoint.lisp
+++ b/src/endpoint.lisp
@@ -205,29 +205,35 @@ matching regex."
       ":ROUTE-PARTS must be supplied to the defintion of class ~a"
       (class-name class)))))
 
-(defun construct-route-builder (class)
+(defun route-builder-parts (class)
+  "Given a list whose route is /a/b/(y)/c/(z)/(w) with extractors for slots
+:Y, :Z, and :W, returns a list '(\"a\" \"b\" :Y \"c\" :Z \"/\" :W)"
   (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 
-            ((or (stringp part) (characterp 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. 
+  (loop
+    :with build-parts := nil
+    :with extractors := (copy-seq (route-extractors class))
+    :for part :in (ppcre:parse-string (route class))
+    :do (cond 
+          ((or (stringp part) (characterp 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 (~s) must be surrounded by
 parens. There must be exactly as many patterns as there are
-extractors." part))))
-    (setf build-parts (nreverse build-parts))
+extractors." part)))
+    :finally (return (nreverse build-parts))))
+
+(defun construct-route-builder (class)
+  (assert (slot-boundp class 'route))
+  (let ((build-parts (route-builder-parts class)))
     (setf (route-builder class)
           (lambda (kwargs)
             (format nil "~{~a~}"
@@ -317,8 +323,8 @@ Good for indicating that you've got a bonkers class option syntax"
 (defparameter +hunchentoot-methods-with-body+
   '(:post :put :patch))
 
-(defun body-expected-p ()
-  (member (http:request-method*) +hunchentoot-methods-with-body+))
+(defun body-expected-p (&optional (method http:request-method*))
+  (member method +hunchentoot-methods-with-body+ :test #'eq))
 
 (defun extract-mimetype (str)
   "Expects a string that looks like text/plain;encoding=utf8 where
diff --git a/src/package.lisp b/src/package.lisp
index e71c71b..d6d29d0 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -36,5 +36,12 @@
    
    ;; DOCGEN
    #:print-route-documentation
-   #:print-all-route-documentation))
+   #:print-all-route-documentation
+
+   ;; ENDPOINT CLASS UTILITY FUNCTIONS
+   #:route-builder-parts
+   #:class-initargs
+   #:body-expected-p
+   #:request-method
+   ))
 
diff --git a/weekend.asd b/weekend.asd
index c844f7b..9fa9120 100644
--- a/weekend.asd
+++ b/weekend.asd
@@ -12,3 +12,12 @@
                (:file "protocol")
                (:file "endpoint")
                (:file "defendpoint")))
+
+(asdf:defsystem #:weekend/psclient
+  :description "Generate parenscript code for weekend endpoint classes."
+  :author "colin <colin@cicadas.surf>"
+  :license "AGPLv3.0"
+  :version "0.0.1"
+  :depends-on (#:weekend #:parenscript)
+  :pathname "src/client/ps/"
+  :components ((:file "generate")))