aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorcolin <colin@cicadas.surf>2024-05-28 07:15:48 -0700
committercolin <colin@cicadas.surf>2024-05-28 07:15:48 -0700
commitf069b37946186c43dff1c4aecb803b916d8758b9 (patch)
tree6e8778d0c34693ce3c51e565e83c96416510b6d6
parent4cb4248c6c7655c51639c16afabfa0d2a778f530 (diff)
Add: parenscript request api function generation
-rw-r--r--src/client/ps/generate.lisp56
-rw-r--r--src/endpoint.lisp48
-rw-r--r--src/package.lisp9
-rw-r--r--weekend.asd9
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")))