1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
|
(in-package :weekend)
;;; DEFENDPOINT
(defun path-part-p (part)
"Returns T if PART is a a valid route path part.
PART is either
STRING
(KEYWORD STRING)
(KEYWORD STRING FUNCTION-NAME)"
(or (stringp part)
(and (listp part)
(or (and (= 2 (length part))
(do>
(key regex) :match= part
:when (keywordp key)
:when (or (stringp regex)
(and (symbolp regex)
(stringp (symbol-value regex))))))
(and (= 3 (length part))
(do>
(key regex parser) :match= part
:when (keywordp key)
:when (or (stringp regex)
(and (symbolp regex)
(stringp (symbol-value regex))))
:when (symbolp parser)
(fboundp parser)))))))
(defun parameter-spec-p (spec)
"Returns T if SPEC is a valid parameter spec for a DEFENDPOINT form.
(NAME TYPE &OPTIONAL DOC)"
(and (listp spec)
(symbolp (first spec))
(symbolp (second spec))
(or (not (third spec))
(stringp (third spec)))))
(defun property-spec-p (spec)
"Returns T if SPEC is a valid property spec for a DEFENDPOINT form.
(NAME TYPE &KEY DEFAULT DOC)"
(and (listp spec)
(symbolp (first spec))
(symbolp (second spec))))
(defun params-to-slotdefs (endpoint specs)
(loop :for (name type . doc) :in specs
:collect `(,name
:accessor ,name
:initarg ,(a:make-keyword name)
:initform (slot-required ',endpoint ',name)
:type ,type
:documentation ,(or (first doc) ""))))
(defun props-to-slotdefs (specs)
(loop :for (name type . kwargs) :in specs
:collect `(,name
:accessor ,name
:initform ,(getf kwargs :default)
:type (or null ,type)
:documentation ,(or (getf kwargs :doc "")
(getf kwargs :documentation "")))))
(defun expand-endpoint-class
(name method pathspec handle
&key
return
supers
parameters
properties
metaclass
var
documentation
authenticate
authorize)
(loop :for super :in supers :do (mop:ensure-finalized (find-class super)))
(setf var (or var (gensym "REQ-")))
(setf metaclass (or metaclass 'endpoint))
(let* ((slot-defs
(nconc (params-to-slotdefs name parameters)
(props-to-slotdefs properties)))
(all-slots
(nconc (mapcar #'first slot-defs)
(reduce #'union supers :key #'class-slot-names :initial-value nil)))
(route-parts
(loop :for part :in pathspec
:when (stringp part)
:collect part
:else
:collect (second part)))
(extractors
(loop :for part :in pathspec
:when (listp part)
:collect (if (third part)
(list (first part) (third part))
(first part))))
(class-options
(nconc
(list (list :metaclass metaclass))
(list (cons :method method))
(list (list* :route-parts route-parts))
(when return
(list (cons :content-type return)))
(when extractors
(list (list* :extractors extractors)))
(when documentation
(list (cons :documentation documentation))))))
`(progn
(defclass ,name ,supers
,slot-defs
,@class-options)
(defmethod handle ((,var ,name))
(with-slots ,all-slots ,var
,handle))
,@(when authenticate
(list
`(defmethod authenticate ((,var ,name))
(with-slots ,all-slots ,var
,authenticate))))
,@(when authorize
(list
`(defmethod authorize ((,var ,name))
(with-slots ,all-slots ,var
,authorize)))))))
(argot:deflanguage defendpoint ()
(<class>
:match (:seq (:@ name <classname>)
(:@ supers (:? <supers>))
(:@ method <method>)
(:@ pathspec <pathspec>)
(:@ options (:* <option>))
(:@ handle <handle>)
(:eof))
:then (apply #'expand-endpoint-class
name
method
pathspec
handle
:supers supers
(a:alist-plist options)))
(<supers>
:match (:seq (:or= :using :extends) (:+ <classname>))
:then second)
(<classname>
:match (:item)
:if (and (symbolp <classname>) (not (keywordp <classname>))))
(<method>
:match (:or= :get :post :put :patch :head :delete))
(<pathspec>
:match (:seq (:or= :to :route) (:+ <pathpart>))
:then second)
(<pathpart>
:match (:item)
:if path-part-p
:note "REGEX or (KWD REGEX &optional PARSER)")
(<parameters>
:match (:seq (:= :parameters) (:+ <param>))
:then (cons :parameters (second <parameters>))
:note "Request parameters - will signal an error if missing from the user request")
(<param>
:match (:item)
:if parameter-spec-p
:note "(NAME TYPE &optional DOCSTRING)")
(<properties>
:match (:seq (:= :properties) (:+ <prop>))
:then (cons :properties (second <properties>))
:note "Values that should be filled-in during authentication or authorization")
(<prop>
:match (:item)
:if property-spec-p
:note "(NAME TYPE &key DEFAULT DOCSTRING)")
(<option>
:match (:or <return> <parameters> <properties>
<doc> <metaclass> <var>
<authenticate> <authorize>))
(<return>
:match (:seq (:= :returns) (:@ mimetype (:item)))
:if (stringp mimetype)
:then (cons :return (second <return>))
:note "The mimetype returned from this endpoint.")
(<doc>
:match (:seq (:= :documentation) (:@ doc (:item)))
:if (stringp doc)
:then (list :documentation doc)
:note "STRING")
(<metaclass>
:match (:seq (:= :custom) <classname>)
:if (mop:subclassp (second <metaclass>) 'endpoint)
:then (list :metaclass (second <metaclass>))
:note "SYMBOL naming a subclass of ENDPOINT")
(<var>
:match (:seq (:= :var) (:item))
:if (symbolp (second <var>))
:then (cons :var (second <var>))
:note "SYMBOL bound to the instance during the handler protocol.")
(<authenticate>
:match (:seq (:= :authenticate) (:item))
:then (cons :authenticate (second <authenticate>))
:note "Body form of authenticate method.")
(<authorize>
:match (:seq (:= :authorize) (:item))
:then (cons :authorize (second <authorize>))
:note "Body form of authorize method.")
(<handle>
:match (:seq (:= :handle) (:item))
:then second
:note "Body form of handle method."))
|
