@@ -20,6 +20,10 @@ module PureStack.Server
2020 , serveQuery
2121 , class ParsePathPiece
2222 , parsePathPiece
23+ , class FromHeaders
24+ , fromHeaders
25+ , class FromHeader
26+ , fromHeader
2327 ) where
2428
2529import Prelude
@@ -49,6 +53,8 @@ import Foreign.Object as Object
4953import Prim.Row as Row
5054import Prim.RowList (class RowToList, RowList)
5155import Prim.RowList as RowList
56+import PureStack.Cookie (Cookie)
57+import PureStack.Cookie as Cookie
5258import Record as Record
5359import Record.Builder (Builder)
5460import Record.Builder as Builder
@@ -103,31 +109,23 @@ else instance (ServeRoute rest handler m, ParsePathPiece t) => ServeRoute (t / r
103109 t <- parsePathPiece @t h
104110 serveRoute @rest route { path = tail } <#> (\f nt handler req -> f nt (handler t) req)
105111
106−else instance ToResponse resp => ServeRoute (GET resp) (m resp) m where
112+else instance MethodName (meth Unit Unit) => ServeRoute (meth Unit Unit) (m Unit) m where
107113 serveRoute { path, verb } = do
108− assert $ verb == "GET"
109− assert $ path == []
110− pure $ \(Nt nt) handler _req -> do
111− resp <- nt handler
112− pure $ toResponse resp
113−
114−else instance ServeRoute (POST Unit Unit) (m Unit) m where
115− serveRoute { path, verb } = do
116− assert $ verb == "POST"
114+ assert $ verb == methodName @(meth Unit Unit)
117115 assert $ path == []
118116 pure $ \(Nt nt) handler _req -> do
119117 nt handler
120118 pure $ ok
121−else instance (ToResponse resp) => ServeRoute (POST Unit resp) (m resp) m where
119+else instance (ToResponse resp, MethodName (meth Unit resp)) => ServeRoute (meth Unit resp) (m resp) m where
122120 serveRoute { path, verb } = do
123− assert $ verb == "POST"
121+ assert $ verb == methodName @(meth Unit resp)
124122 assert $ path == []
125123 pure $ \(Nt nt) handler _req -> do
126124 resp <- nt handler
127125 pure $ toResponse resp
128−else instance (FromRequest req) => ServeRoute (POST resp Unit) (req -> m Unit) m where
126+else instance (FromRequest req, MethodName (meth resp Unit)) => ServeRoute (meth resp Unit) (req -> m Unit) m where
129127 serveRoute { path, verb } = do
130− assert $ verb == "POST"
128+ assert $ verb == methodName @(meth resp Unit)
131129 assert $ path == []
132130 pure $ \(Nt nt) handler req -> do
133131 liftAff (fromRequest req) >>= case _ of
@@ -135,114 +133,9 @@ else instance (FromRequest req) => ServeRoute (POST resp Unit) (req -> m Unit) m
135133 Just r -> do
136134 nt $ handler r
137135 pure $ ok
138−else instance (FromRequest req, ToResponse resp) => ServeRoute (POST req resp) (req -> m resp) m where
136+else instance (FromRequest req, ToResponse resp, MethodName (meth req resp)) => ServeRoute (meth req resp) (req -> m resp) m where
139137 serveRoute { path, verb } = do
140− assert $ verb == "POST"
141− assert $ path == []
142− pure $ \(Nt nt) handler req -> do
143− liftAff (fromRequest req) >>= case _ of
144− Nothing -> pure $ badRequest
145− Just r -> do
146− resp <- nt $ handler r
147− pure $ toResponse resp
148−
149−else instance ServeRoute (DELETE Unit Unit) (m Unit) m where
150− serveRoute { path, verb } = do
151− assert $ verb == "DELETE"
152− assert $ path == []
153− pure $ \(Nt nt) handler _req -> do
154− nt handler
155− pure $ ok
156−else instance (ToResponse resp) => ServeRoute (DELETE Unit resp) (m resp) m where
157− serveRoute { path, verb } = do
158− assert $ verb == "DELETE"
159− assert $ path == []
160− pure $ \(Nt nt) handler _req -> do
161− resp <- nt handler
162− pure $ toResponse resp
163−else instance (FromRequest req) => ServeRoute (DELETE resp Unit) (req -> m Unit) m where
164− serveRoute { path, verb } = do
165− assert $ verb == "DELETE"
166− assert $ path == []
167− pure $ \(Nt nt) handler req -> do
168− liftAff (fromRequest req) >>= case _ of
169− Nothing -> pure $ badRequest
170− Just r -> do
171− nt $ handler r
172− pure $ ok
173−else instance (FromRequest req, ToResponse resp) => ServeRoute (DELETE req resp) (req -> m resp) m where
174− serveRoute { path, verb } = do
175− assert $ verb == "DELETE"
176− assert $ path == []
177− pure $ \(Nt nt) handler req -> do
178− liftAff (fromRequest req) >>= case _ of
179− Nothing -> pure $ badRequest
180− Just r -> do
181− resp <- nt $ handler r
182− pure $ toResponse resp
183−
184−else instance ServeRoute (PUT Unit Unit) (m Unit) m where
185− serveRoute { path, verb } = do
186− assert $ verb == "PUT"
187− assert $ path == []
188− pure $ \(Nt nt) handler _req -> do
189− nt handler
190− pure $ ok
191−else instance (ToResponse resp) => ServeRoute (PUT Unit resp) (m resp) m where
192− serveRoute { path, verb } = do
193− assert $ verb == "PUT"
194− assert $ path == []
195− pure $ \(Nt nt) handler _req -> do
196− resp <- nt handler
197− pure $ toResponse resp
198−else instance (FromRequest req) => ServeRoute (PUT resp Unit) (req -> m Unit) m where
199− serveRoute { path, verb } = do
200− assert $ verb == "PUT"
201− assert $ path == []
202− pure $ \(Nt nt) handler req -> do
203− liftAff (fromRequest req) >>= case _ of
204− Nothing -> pure $ badRequest
205− Just r -> do
206− nt $ handler r
207− pure $ ok
208−else instance (FromRequest req, ToResponse resp) => ServeRoute (PUT req resp) (req -> m resp) m where
209− serveRoute { path, verb } = do
210− assert $ verb == "PUT"
211− assert $ path == []
212− pure $ \(Nt nt) handler req -> do
213− liftAff (fromRequest req) >>= case _ of
214− Nothing -> pure $ badRequest
215− Just r -> do
216− resp <- nt $ handler r
217− pure $ toResponse resp
218−
219−else instance ServeRoute (PATCH Unit Unit) (m Unit) m where
220− serveRoute { path, verb } = do
221− assert $ verb == "PATCH"
222− assert $ path == []
223− pure $ \(Nt nt) handler _req -> do
224− nt handler
225− pure $ ok
226−else instance (ToResponse resp) => ServeRoute (PATCH Unit resp) (m resp) m where
227− serveRoute { path, verb } = do
228− assert $ verb == "PATCH"
229− assert $ path == []
230− pure $ \(Nt nt) handler _req -> do
231− resp <- nt handler
232− pure $ toResponse resp
233−else instance (FromRequest req) => ServeRoute (PATCH resp Unit) (req -> m Unit) m where
234− serveRoute { path, verb } = do
235− assert $ verb == "PATCH"
236− assert $ path == []
237− pure $ \(Nt nt) handler req -> do
238− liftAff (fromRequest req) >>= case _ of
239− Nothing -> pure $ badRequest
240− Just r -> do
241− nt $ handler r
242− pure $ ok
243−else instance (FromRequest req, ToResponse resp) => ServeRoute (PATCH req resp) (req -> m resp) m where
244− serveRoute { path, verb } = do
245− assert $ verb == "PATCH"
138+ assert $ verb == methodName @(meth req resp)
246139 assert $ path == []
247140 pure $ \(Nt nt) handler req -> do
248141 liftAff (fromRequest req) >>= case _ of
@@ -342,6 +235,84 @@ instance DecodeJson (Record row) => FromRequest (Record row) where
342235instance FromRequest Request where
343236 fromRequest req = pure $ Just req
344237
238+instance FromRequest Unit where
239+ fromRequest _ = pure $ Just unit
240+
241+instance
242+ ( FromRequest req
243+ , FromHeader header
244+ ) =>
245+ FromRequest (Headers (Object header) req) where
246+ fromRequest req = do
247+ r <- fromRequest req
248+ pure $ do
249+ headers <- traverse fromHeader (Request.headers req)
250+ r' <- r
251+ pure $ Headers headers r'
252+
253+instance
254+ ( RowToList headers headersList
255+ , FromRequest req
256+ , FromHeaders headers headersList
257+ ) =>
258+ FromRequest (Headers (Record headers) req) where
259+ fromRequest req = do
260+ r <- fromRequest req
261+ pure $ do
262+ headers <- fromHeaders @headers @headersList (Request.headers req)
263+ r' <- r
264+ pure $ Headers (Builder.buildFromScratch headers) r'
265+
266+class FromHeader t where
267+ fromHeader :: String -> Maybe t
268+
269+instance FromHeader Cookie where
270+ fromHeader = Cookie.parse >>> case _ of
271+ Left _ -> Nothing
272+ Right x -> Just x
273+
274+instance FromHeader String where
275+ fromHeader = Just
276+
277+instance FromHeader Int where
278+ fromHeader = Int.fromString
279+
280+class FromHeaders :: Row Type -> RowList Type -> Constraint
281+class FromHeaders row list | list -> row where
282+ fromHeaders :: Object String -> Maybe (Builder {} (Record row))
283+
284+instance FromHeaders () RowList.Nil where
285+ fromHeaders _ = Just $ identity
286+
287+instance
288+ ( FromHeader t
289+ , IsSymbol field
290+ , FromHeaders tail rest
291+ , Row.Cons field (Maybe t) tail row
292+ , Row.Lacks field tail
293+ ) =>
294+ FromHeaders row (RowList.Cons field (Maybe t) rest) where
295+ fromHeaders headers = do
296+ r <- fromHeaders @tail @rest headers
297+ case Object.lookup (reflectSymbol @field Proxy) headers of
298+ Nothing -> pure $ Builder.insert (Proxy @field) Nothing <<< r
299+ Just t -> do
300+ v <- fromHeader t
301+ pure $ Builder.insert (Proxy @field) (Just v) <<< r
302+
303+else instance
304+ ( FromHeader t
305+ , IsSymbol field
306+ , FromHeaders tail rest
307+ , Row.Cons field t tail row
308+ , Row.Lacks field tail
309+ ) =>
310+ FromHeaders row (RowList.Cons field t rest) where
311+ fromHeaders headers = do
312+ t <- Object.lookup (reflectSymbol @field Proxy) headers >>= fromHeader
313+ r <- fromHeaders @tail @rest headers
314+ pure $ Builder.insert (Proxy @field) t <<< r
315+
345316class ParsePathPiece t where
346317 parsePathPiece :: String -> Maybe t
347318
@@ -406,10 +377,10 @@ run
406377 . RowToList row list
407378 => ServeAPI row list handlers m
408379 => (forall x. m x -> Server x)
409− -> Record handlers
380+ -> { handlers :: Record handlers }
410381 -> Request
411382 -> Aff Bun.Response.Response
412−run nt handlers req = do
383+run nt { handlers } req = do
413384 Response { body, headers, status, statusText } <-
414385 map (either identity identity) $ runExceptT $ serveAPI @row @list @handlers (Nt nt) handlers (routeFromRequest req) req
415386 let opts = { headers, status, statusText }