Add: parenscript request api function generation

1 files changed, 56 insertions, 0 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)))))))
+