diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/client/ps/generate.lisp | 56 | ||||
| -rw-r--r-- | src/endpoint.lisp | 48 | ||||
| -rw-r--r-- | src/package.lisp | 9 |
3 files changed, 91 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 + )) |