aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorcolin <colin@cicadas.surf>2024-08-24 10:31:37 -0700
committercolin <colin@cicadas.surf>2024-08-24 10:31:37 -0700
commit71ab563b2b0f4763ac266d6359fba492514bda65 (patch)
treeb9a6a3f9a83bf81adfe131eb28a2d626951b94fc /src
parent33046c1a1cec3819245f13d960c6072aa73aee65 (diff)
Add: slot-value-mapper
Diffstat (limited to 'src')
-rw-r--r--src/endpoint.lisp12
-rw-r--r--src/package.lisp1
-rw-r--r--src/protocol.lisp25
3 files changed, 36 insertions, 2 deletions
diff --git a/src/endpoint.lisp b/src/endpoint.lisp
index 00f681f..4ec68b6 100644
--- a/src/endpoint.lisp
+++ b/src/endpoint.lisp
@@ -356,6 +356,12 @@ the ;."
:note "Error during the parsing of the body.")))))))
+
+(defun apply-slot-value-mappers (class initargs)
+ (loop :for (arg value) :on initargs :by #'cddr
+ :collect arg
+ :collect (slot-value-mapper class arg value)))
+
(defun instantiate-endpoint (class args)
"This attempts to instantiate CLASS, filling slots found in ARGS by
searching for their values in the hunchentoot:*request*.
@@ -371,8 +377,10 @@ the ;."
(body-args
(extract-initargs args (collect-body class))))
(apply #'make-instance class
- (reduce #'merge-plists
- (list extracted-args params-args body-args)))))
+ (apply-slot-value-mappers
+ class
+ (reduce #'merge-plists
+ (list extracted-args params-args body-args))))))
(defun build-handler (class)
"Create a hunchentoot dispatch function that instantiates and handles
diff --git a/src/package.lisp b/src/package.lisp
index 1563c07..094295b 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -14,6 +14,7 @@
(:export
;; HANDLER PROTOCOL
#:check-request-compliance
+ #:slot-value-mapper
#:authenticate
#:authorize
#:handle
diff --git a/src/protocol.lisp b/src/protocol.lisp
index 74019b1..6951077 100644
--- a/src/protocol.lisp
+++ b/src/protocol.lisp
@@ -112,6 +112,31 @@ on the size of request bodies.")
(check-request-compliance (find-class epclass)))
(:method ((epclass t))))
+(defgeneric slot-value-mapper (endpoint-class initarg slot-value)
+ (:documentation "Values arrive from clients in all manner of ways: in a JSON body, in
+query arguments, as form body posts. Weekend allows users to register
+body parsers, which transform post bodies according to the request's
+mimetype. However, sometimes this isn't good enough.
+
+A value may require additional alteration before it fills an endpoint
+slot.
+
+SLOT-VALUE-MAPPER is specialized on endpoints, initarg names, and slot
+value types to parse or transform values to be what they out to be for
+a slot's declared type.
+
+ENDPOINT-CLASS values MUST BE AN ENDPOINT CLASS.
+INITARG values MUST BE A KEYWORD.")
+
+ (:method :around (endpoint (initarg t) value)
+ (assert (keywordp initarg) (initarg) "Initarg is not a keyword ~a"
+ initarg)
+ (call-next-method))
+
+ (:method (endpoint initarg value)
+ value))
+
+
(defgeneric authenticate (endpoint)
(:documentation "Returns a boolean. Any protected endpoint should implement
this. Called before handling, should be used to supply