]> Git — Sourcephile - haskell/symantic-http.git/blob - Symantic/HTTP/Server.hs
Rename stuffs and init client testing
[haskell/symantic-http.git] / Symantic / HTTP / Server.hs
1 {-# LANGUAGE DataKinds #-}
2 {-# LANGUAGE DeriveFunctor #-}
3 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
4 {-# LANGUAGE InstanceSigs #-}
5 {-# LANGUAGE OverloadedStrings #-}
6 {-# LANGUAGE TypeFamilies #-}
7 {-# LANGUAGE TypeOperators #-}
8 module Symantic.HTTP.Server where
9
10 import Control.Arrow (first)
11 import Control.Monad (Monad(..), unless, sequence, guard)
12 import Control.Monad.Trans.Class (MonadTrans(..))
13 import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
14 import Data.Bool
15 import Data.Either (Either(..))
16 import Data.Eq (Eq(..))
17 import Data.Function (($), (.), id)
18 import Data.Functor (Functor, (<$>))
19 import Data.Int (Int)
20 import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
21 import Data.Proxy (Proxy(..))
22 import Data.Semigroup (Semigroup(..))
23 import Data.String (String, IsString(..))
24 import Data.Text (Text)
25 import Prelude ((+))
26 import System.IO (IO)
27 import Text.Show (Show(..))
28 import qualified Control.Monad.Classes as MC
29 import qualified Control.Monad.Trans.State as S
30 import qualified Data.ByteString as BS
31 import qualified Data.ByteString.Base64 as BS64
32 import qualified Data.ByteString.Lazy as BSL
33 import qualified Data.List as List
34 import qualified Data.Text.Encoding as Text
35 import qualified Data.Word8 as Word8
36 import qualified Network.HTTP.Media as Media
37 import qualified Network.HTTP.Types as HTTP
38 import qualified Network.HTTP.Types.Header as HTTP
39 import qualified Network.Wai as Wai
40 import qualified Web.HttpApiData as Web
41
42 import Symantic.HTTP.API
43 import Symantic.HTTP.Mime
44
45 -- * Type 'Server'
46 -- | @Server f k@ is a recipe to produce an 'Wai.Application'
47 -- from handlers 'f' (one per number of alternative routes).
48 --
49 -- 'Server' is analogous to a scanf using a format customized for HTTP routing.
50 --
51 -- The multiple monad transformers are there to prioritize the errors
52 -- according to the type of check raising them,
53 -- instead of the order of the combinators within an actual API specification.
54 newtype Server f k = Server { unServer ::
55 S.StateT ServerState
56 (ServerCheckT [ServerErrorBody] -- 8th check, 400 error
57 (ServerCheckT [ServerErrorHeader] -- 7th check, 400 error
58 (ServerCheckT [ServerErrorQuery] -- 6th check, 400 error
59 (ServerCheckT [ServerErrorContentType] -- 5th check, 415 error
60 (ServerCheckT [ServerErrorAccept] -- 4th check, 406 error
61 (ServerCheckT [ServerErrorBasicAuth] -- 3rd check, 401 error
62 (ServerCheckT [ServerErrorMethod] -- 2nd check, 405 error
63 (ServerCheckT [ServerErrorPath] -- 1st check, 404 error
64 IO))))))))
65 (f -> k)
66 } deriving (Functor)
67
68 -- | @'server' api handlers@ returns a 'Wai.Application'
69 -- ready to be given to @Warp.run 80@.
70 server ::
71 Server handlers ServerResponse ->
72 handlers ->
73 Wai.Application
74 server (Server api) handlers rq re = do
75 lrPath <- runServerChecks api $ ServerState 0 rq
76 case lrPath of
77 Left err -> respondError status404 [] err
78 Right lrMethod ->
79 case lrMethod of
80 Left err -> respondError status405 [] err
81 Right lrBasicAuth ->
82 case lrBasicAuth of
83 Left (Fail _st (ServerErrorBasicAuth realm err:_)) ->
84 case err of
85 BasicAuth_Unauthorized -> respondError status403 [] err
86 _ -> respondError status401 [(HTTP.hWWWAuthenticate, "Basic realm=\""<>realm<>"\"")] err
87 Right lrAccept ->
88 case lrAccept of
89 Left err -> respondError status406 [] err
90 Right lrContentType ->
91 case lrContentType of
92 Left err -> respondError status415 [] err
93 Right lrQuery ->
94 case lrQuery of
95 Left err -> respondError status400 [] err
96 Right lrHeader ->
97 case lrHeader of
98 Left err -> respondError status400 [] err
99 Right lrBody ->
100 case lrBody of
101 Left err -> respondError status400 [] err
102 Right (a2k, _st) ->
103 let ServerResponse app = a2k handlers in
104 app rq re
105 where
106 respondError ::
107 Show err =>
108 HTTP.Status ->
109 [(HTTP.HeaderName, HeaderValue)] ->
110 err -> IO Wai.ResponseReceived
111 respondError st hs err =
112 -- Trace.trace (show err) $
113 re $ Wai.responseLBS st
114 ( (HTTP.hContentType, Media.renderHeader $ mimeType mimePlainText)
115 : hs
116 ) (fromString $ show err) -- TODO: see what to return in the body
117
118
119 -- | Unwrap the 'ExceptT' constructors to reach the 'Either' constructors.
120 runServerChecks ::
121 S.StateT ServerState (ExceptT e1 (ExceptT e2 (ExceptT e3 (ExceptT e4 (ExceptT e5 (ExceptT e6 (ExceptT e7 (ExceptT e8 IO)))))))) a ->
122 ServerState -> IO (Either e8 (Either e7 (Either e6 (Either e5 (Either e4 (Either e3 (Either e2 (Either e1 (a, ServerState)))))))))
123 runServerChecks s st =
124 runExceptT $
125 runExceptT $
126 runExceptT $
127 runExceptT $
128 runExceptT $
129 runExceptT $
130 runExceptT $
131 runExceptT $
132 S.runStateT s st
133
134 -- ** Type 'ServerCheckT'
135 type ServerCheckT e = ExceptT (Fail e)
136
137 -- *** Type 'RouteResult'
138 type RouteResult e = Either (Fail e)
139
140 -- *** Type 'Fail'
141 data Fail e
142 = Fail ServerState e -- ^ Keep trying other paths. 404, 405 or 406.
143 | FailFatal !ServerState !e -- ^ Don't try other paths.
144 deriving (Show)
145 failState :: Fail e -> ServerState
146 failState (Fail st _) = st
147 failState (FailFatal st _) = st
148 instance Semigroup e => Semigroup (Fail e) where
149 Fail _ x <> Fail st y = Fail st (x<>y)
150 FailFatal _ x <> Fail st y = FailFatal st (x<>y)
151 Fail _ x <> FailFatal st y = FailFatal st (x<>y)
152 FailFatal _ x <> FailFatal st y = FailFatal st (x<>y)
153
154 -- ** Type 'ServerState'
155 data ServerState = ServerState
156 { serverState_offset :: Offset -- TODO: remove
157 , serverState_request :: Wai.Request
158 } -- deriving (Show)
159 type Offset = Int
160
161 instance Show ServerState where
162 show _ = "ServerState"
163
164 type instance HttpApiData Server = Web.FromHttpApiData
165 instance Cat Server where
166 (<.>) ::
167 forall a b c repr.
168 repr ~ Server =>
169 repr a b -> repr b c -> repr a c
170 -- NOTE: if x fails, run y to see if it fails on a more prioritized check.
171 -- And if so, fail with y instead of x.
172 --
173 -- This long spaghetti code may probably be avoided
174 -- with a more sophisticated 'Server' using a binary tree
175 -- instead of nested 'Either's, so that its 'Monad' instance
176 -- would do the right thing. But to my mind,
177 -- with the very few priorities of checks currently needed,
178 -- this is not worth the cognitive pain to design it.
179 -- A copy/paste/adapt will do for now.
180 Server x <.> Server y = Server $
181 S.StateT $ \st -> do
182 xPath <- liftIO $ runServerChecks x st
183 case xPath of
184 Left xe -> MC.throw xe
185 Right xMethod ->
186 case xMethod of
187 Left xe -> do
188 yPath <- liftIO $ runServerChecks y (failState xe)
189 case yPath of
190 Left ye -> MC.throw ye
191 Right _yMethod -> MC.throw xe
192 Right xBasicAuth ->
193 case xBasicAuth of
194 Left xe -> do
195 yPath <- liftIO $ runServerChecks y (failState xe)
196 case yPath of
197 Left ye -> MC.throw ye
198 Right yMethod ->
199 case yMethod of
200 Left ye -> MC.throw ye
201 Right _yBasicAuth -> MC.throw xe
202 Right xAccept ->
203 case xAccept of
204 Left xe -> do
205 yPath <- liftIO $ runServerChecks y (failState xe)
206 case yPath of
207 Left ye -> MC.throw ye
208 Right yMethod ->
209 case yMethod of
210 Left ye -> MC.throw ye
211 Right yBasicAuth ->
212 case yBasicAuth of
213 Left ye -> MC.throw ye
214 Right _yAccept -> MC.throw xe
215 Right xContentType ->
216 case xContentType of
217 Left xe -> do
218 yPath <- liftIO $ runServerChecks y (failState xe)
219 case yPath of
220 Left ye -> MC.throw ye
221 Right yMethod ->
222 case yMethod of
223 Left ye -> MC.throw ye
224 Right yBasicAuth ->
225 case yBasicAuth of
226 Left ye -> MC.throw ye
227 Right yAccept ->
228 case yAccept of
229 Left ye -> MC.throw ye
230 Right _yQuery -> MC.throw xe
231 Right xQuery ->
232 case xQuery of
233 Left xe -> do
234 yPath <- liftIO $ runServerChecks y (failState xe)
235 case yPath of
236 Left ye -> MC.throw ye
237 Right yMethod ->
238 case yMethod of
239 Left ye -> MC.throw ye
240 Right yBasicAuth ->
241 case yBasicAuth of
242 Left ye -> MC.throw ye
243 Right yAccept ->
244 case yAccept of
245 Left ye -> MC.throw ye
246 Right yQuery ->
247 case yQuery of
248 Left ye -> MC.throw ye
249 Right _yHeader -> MC.throw xe
250 Right xHeader ->
251 case xHeader of
252 Left xe -> do
253 yPath <- liftIO $ runServerChecks y (failState xe)
254 case yPath of
255 Left ye -> MC.throw ye
256 Right yMethod ->
257 case yMethod of
258 Left ye -> MC.throw ye
259 Right yBasicAuth ->
260 case yBasicAuth of
261 Left ye -> MC.throw ye
262 Right yAccept ->
263 case yAccept of
264 Left ye -> MC.throw ye
265 Right yQuery ->
266 case yQuery of
267 Left ye -> MC.throw ye
268 Right yHeader ->
269 case yHeader of
270 Left ye -> MC.throw ye
271 Right _yBody -> MC.throw xe
272 Right xBody ->
273 case xBody of
274 Left xe -> do
275 yPath <- liftIO $ runServerChecks y (failState xe)
276 case yPath of
277 Left ye -> MC.throw ye
278 Right yMethod ->
279 case yMethod of
280 Left ye -> MC.throw ye
281 Right yBasicAuth ->
282 case yBasicAuth of
283 Left ye -> MC.throw ye
284 Right yAccept ->
285 case yAccept of
286 Left ye -> MC.throw ye
287 Right yQuery ->
288 case yQuery of
289 Left ye -> MC.throw ye
290 Right yHeader ->
291 case yHeader of
292 Left ye -> MC.throw ye
293 Right _yBody -> MC.throw xe
294 Right (a2b, st') ->
295 (first (. a2b)) <$> S.runStateT y st'
296 instance Alt Server where
297 Server x <!> Server y = Server $
298 S.StateT $ \st -> do
299 xPath <- liftIO $ runServerChecks x st
300 yPath <- liftIO $ runServerChecks y st
301 let fy = (first (\b2k (_a:!:b) -> b2k b) <$>)
302 case xPath of
303 Left xe | FailFatal{} <- xe -> MC.throw xe
304 | otherwise ->
305 case yPath of
306 Left ye -> MC.throw (xe<>ye)
307 Right yMethod ->
308 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
309 return $ Right yMethod
310 Right xMethod ->
311 case xMethod of
312 Left xe | FailFatal{} <- xe -> MC.throw xe
313 | otherwise ->
314 case yPath of
315 Left _ye -> MC.throw xe
316 Right yMethod ->
317 case yMethod of
318 Left ye -> MC.throw (xe<>ye)
319 Right yBasicAuth ->
320 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
321 return $ Right $ yBasicAuth
322 Right xBasicAuth ->
323 case xBasicAuth of
324 Left xe | FailFatal{} <- xe -> MC.throw xe
325 | otherwise ->
326 case yPath of
327 Left _ye -> MC.throw xe
328 Right yMethod ->
329 case yMethod of
330 Left _ye -> MC.throw xe
331 Right yBasicAuth ->
332 case yBasicAuth of
333 Left ye -> MC.throw (xe<>ye)
334 Right yAccept ->
335 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
336 return $ Right yAccept
337 Right xAccept ->
338 case xAccept of
339 Left xe | FailFatal{} <- xe -> MC.throw xe
340 | otherwise ->
341 case yPath of
342 Left _ye -> MC.throw xe
343 Right yMethod ->
344 case yMethod of
345 Left _ye -> MC.throw xe
346 Right yBasicAuth ->
347 case yBasicAuth of
348 Left _ye -> MC.throw xe
349 Right yAccept ->
350 case yAccept of
351 Left ye -> MC.throw (xe<>ye)
352 Right yContentType ->
353 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
354 return $ Right yContentType
355 Right xContentType ->
356 case xContentType of
357 Left xe | FailFatal{} <- xe -> MC.throw xe
358 | otherwise ->
359 case yPath of
360 Left _ye -> MC.throw xe
361 Right yMethod ->
362 case yMethod of
363 Left _ye -> MC.throw xe
364 Right yBasicAuth ->
365 case yBasicAuth of
366 Left _ye -> MC.throw xe
367 Right yAccept ->
368 case yAccept of
369 Left _ye -> MC.throw xe
370 Right yContentType ->
371 case yContentType of
372 Left ye -> MC.throw (xe<>ye)
373 Right yQuery ->
374 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
375 return $ Right yQuery
376 Right xQuery ->
377 case xQuery of
378 Left xe | FailFatal{} <- xe -> MC.throw xe
379 | otherwise ->
380 case yPath of
381 Left _ye -> MC.throw xe
382 Right yMethod ->
383 case yMethod of
384 Left _ye -> MC.throw xe
385 Right yBasicAuth ->
386 case yBasicAuth of
387 Left _ye -> MC.throw xe
388 Right yAccept ->
389 case yAccept of
390 Left _ye -> MC.throw xe
391 Right yContentType ->
392 case yContentType of
393 Left _ye -> MC.throw xe
394 Right yQuery ->
395 case yQuery of
396 Left ye -> MC.throw (xe<>ye)
397 Right yHeader ->
398 fy $ ExceptT $ ExceptT $ ExceptT $
399 return $ Right yHeader
400 Right xHeader ->
401 case xHeader of
402 Left xe | FailFatal{} <- xe -> MC.throw xe
403 | otherwise ->
404 case yPath of
405 Left _ye -> MC.throw xe
406 Right yMethod ->
407 case yMethod of
408 Left _ye -> MC.throw xe
409 Right yBasicAuth ->
410 case yBasicAuth of
411 Left _ye -> MC.throw xe
412 Right yAccept ->
413 case yAccept of
414 Left _ye -> MC.throw xe
415 Right yContentType ->
416 case yContentType of
417 Left _ye -> MC.throw xe
418 Right yQuery ->
419 case yQuery of
420 Left _ye -> MC.throw xe
421 Right yHeader ->
422 case yHeader of
423 Left ye -> MC.throw (xe<>ye)
424 Right yBody ->
425 fy $ ExceptT $ ExceptT $
426 return $ Right yBody
427 Right xBody ->
428 case xBody of
429 Left xe | FailFatal{} <- xe -> MC.throw xe
430 | otherwise ->
431 case yPath of
432 Left _ye -> MC.throw xe
433 Right yMethod ->
434 case yMethod of
435 Left _ye -> MC.throw xe
436 Right yBasicAuth ->
437 case yBasicAuth of
438 Left _ye -> MC.throw xe
439 Right yAccept ->
440 case yAccept of
441 Left _ye -> MC.throw xe
442 Right yContentType ->
443 case yContentType of
444 Left _ye -> MC.throw xe
445 Right yQuery ->
446 case yQuery of
447 Left _ye -> MC.throw xe
448 Right yHeader ->
449 case yHeader of
450 Left _ye -> MC.throw xe
451 Right yBody ->
452 case yBody of
453 Left ye -> MC.throw (xe<>ye)
454 Right yr ->
455 fy $ ExceptT $
456 return $ Right yr
457 Right xr ->
458 return $ first (\a2k (a:!:_b) -> a2k a) xr
459 instance Pro Server where
460 dimap a2b _b2a (Server r) = Server $ (\k b2k -> k (b2k . a2b)) <$> r
461
462 -- ** Type 'ServerErrorPath'
463 data ServerErrorPath = ServerErrorPath Offset Text
464 deriving (Eq, Show)
465 instance HTTP_Path Server where
466 segment expSegment = Server $ do
467 st@ServerState
468 { serverState_offset = o
469 , serverState_request = req
470 } <- S.get
471 case Wai.pathInfo req of
472 [] -> MC.throw $ Fail st [ServerErrorPath o "segment: empty"]
473 [""] -> MC.throw $ Fail st [ServerErrorPath o "trailing slash"]
474 curr:next
475 | curr /= expSegment ->
476 MC.throw $ Fail st [ServerErrorPath o $ "expected: "<>expSegment<>" but got: "<>curr]
477 | otherwise -> do
478 S.put st
479 { serverState_offset = o+1
480 , serverState_request = req{ Wai.pathInfo = next }
481 }
482 return id
483 capture' :: forall a k. HttpApiData Server a => Name -> Server (a -> k) k
484 capture' name = Server $ do
485 st@ServerState
486 { serverState_offset = o
487 , serverState_request = req
488 } <- S.get
489 case Wai.pathInfo req of
490 [] -> MC.throw $ Fail st [ServerErrorPath o "empty"]
491 [""] -> MC.throw $ Fail st [ServerErrorPath o "trailing slash"]
492 curr:next ->
493 case Web.parseUrlPiece curr of
494 Left err -> MC.throw $ Fail st [ServerErrorPath o $ "capture: "<>fromString name<>": "<>err]
495 Right a -> do
496 S.put st
497 { serverState_offset = o+1
498 , serverState_request = req{ Wai.pathInfo = next }
499 }
500 return ($ a)
501 captureAll = Server $ do
502 req <- S.gets serverState_request
503 return ($ Wai.pathInfo req)
504
505 -- ** Type 'ServerErrorMethod'
506 data ServerErrorMethod = ServerErrorMethod
507 deriving (Eq, Show)
508
509 -- | TODO: add its own error?
510 instance HTTP_Version Server where
511 version exp = Server $ do
512 st <- S.get
513 let got = Wai.httpVersion $ serverState_request st
514 if got == exp
515 then return id
516 else MC.throw $ Fail st [ServerErrorMethod] -- FIXME: ServerErrorVersion
517
518 -- ** Type 'ServerErrorAccept'
519 data ServerErrorAccept =
520 ServerErrorAccept
521 MediaType
522 (Maybe (Either BS.ByteString MediaType))
523 deriving (Eq, Show)
524
525 -- ** Type 'ServerErrorContentType'
526 data ServerErrorContentType = ServerErrorContentType
527 deriving (Eq, Show)
528
529 -- ** Type 'ServerErrorQuery'
530 newtype ServerErrorQuery = ServerErrorQuery Text
531 deriving (Show)
532 instance HTTP_Query Server where
533 queryParams' name = Server $ do
534 st <- S.get
535 lift $ ExceptT $ ExceptT $ ExceptT $ return $
536 let qs = Wai.queryString $ serverState_request st in
537 let vals = catMaybes $ (<$> qs) $ \(n,v) ->
538 if n == name
539 then Web.parseQueryParam . Text.decodeUtf8 <$> v
540 else Nothing in
541 case sequence vals of
542 Left err -> Left $ Fail st [ServerErrorQuery err]
543 Right vs -> Right $ Right $ Right ($ vs)
544
545 -- ** Type 'ServerErrorHeader'
546 data ServerErrorHeader = ServerErrorHeader
547 deriving (Eq, Show)
548 instance HTTP_Header Server where
549 header n = Server $ do
550 st <- S.get
551 lift $ ExceptT $ ExceptT $ return $
552 let hs = Wai.requestHeaders $ serverState_request st in
553 case List.lookup n hs of
554 Nothing -> Left $ Fail st [ServerErrorHeader]
555 Just v -> Right $ Right ($ v)
556
557 -- ** Type 'ServerErrorBasicAuth'
558 data ServerErrorBasicAuth =
559 ServerErrorBasicAuth BasicAuthRealm (BasicAuth ())
560 deriving (Show)
561
562 -- ** Class 'ServerBasicAuthable'
563 class ServerBasicAuthable context a where
564 serverBasicAuthable ::
565 context ->
566 BasicAuthName ->
567 BasicAuthPass ->
568 IO (BasicAuth a)
569
570 -- | WARNING: current implementation of Basic Access Authentication
571 -- is not immune to certian kinds of timing attacks.
572 -- Decoding payloads does not take a fixed amount of time.
573 instance HTTP_BasicAuth Server where
574 type BasicAuthable Server = ServerBasicAuthable
575 basicAuth' realm context = Server $ do
576 st <- S.get
577 let err e = MC.throw $ Fail st [ServerErrorBasicAuth realm e]
578 case decodeAuthorization $ serverState_request st of
579 Nothing -> err BasicAuth_BadPassword
580 Just (user, pass) -> do
581 liftIO (serverBasicAuthable context user pass) >>= \case
582 BasicAuth_BadPassword -> err BasicAuth_BadPassword
583 BasicAuth_NoSuchUser -> err BasicAuth_NoSuchUser
584 BasicAuth_Unauthorized -> err BasicAuth_Unauthorized
585 BasicAuth_Authorized a -> return ($ a)
586 where
587 -- | Find and decode an 'Authorization' header from the request as a Basic Auth
588 decodeAuthorization :: Wai.Request -> Maybe (BasicAuthName, BasicAuthPass)
589 decodeAuthorization req = do
590 hAuthorization <- List.lookup "Authorization" $ Wai.requestHeaders req
591 let (basic, rest) = BS.break Word8.isSpace hAuthorization
592 guard (BS.map Word8.toLower basic == "basic")
593 let decoded = BS64.decodeLenient (BS.dropWhile Word8.isSpace rest)
594 let (user, colon_pass) = BS.break (== Word8._colon) decoded
595 (_, pass) <- BS.uncons colon_pass
596 return (user, pass)
597
598 -- ** Type 'ServerErrorBody'
599 newtype ServerErrorBody = ServerErrorBody String
600 deriving (Eq, Show)
601
602 -- *** Type 'ServerBodyArg'
603 newtype ServerBodyArg mt a = ServerBodyArg a
604
605 instance HTTP_Body Server where
606 type BodyArg Server = ServerBodyArg
607 body' ::
608 forall mt a k repr.
609 MimeUnserialize a mt =>
610 MimeSerialize a mt =>
611 repr ~ Server =>
612 repr (BodyArg repr mt a -> k) k
613 body'= Server $ do
614 st <- S.get
615 lift $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ do
616 let hs = Wai.requestHeaders $ serverState_request st
617 let expContentType = (Proxy::Proxy mt)
618 let reqContentType =
619 -- DOC: http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
620 -- DOC: http://www.w3.org/2001/tag/2002/0129-mime
621 fromMaybe "application/octet-stream" $
622 List.lookup HTTP.hContentType hs
623 case Media.mapContentMedia
624 [ ( mimeType expContentType
625 , mimeUnserialize expContentType )
626 ] reqContentType of
627 Nothing -> return $ Left $ Fail st [ServerErrorContentType]
628 Just unSerialize -> do
629 bodyBS <- liftIO $ Wai.requestBody $ serverState_request st
630 return $ Right $ Right $ Right $
631 -- NOTE: delay unSerialize after all checks
632 case unSerialize $ BSL.fromStrict bodyBS of
633 Left err -> Left $ Fail st [ServerErrorBody err]
634 Right a -> Right ($ ServerBodyArg a)
635
636 -- ** Type 'ServerResponse'
637 newtype ServerResponse = ServerResponse
638 ( -- the request made to the server
639 Wai.Request ->
640 -- the continuation for the server to respond
641 (Wai.Response -> IO Wai.ResponseReceived) ->
642 IO Wai.ResponseReceived
643 )
644 instance Show ServerResponse where
645 show _ = "ServerResponse"
646
647 -- *** Type 'ServerResponseArg'
648 newtype ServerResponseArg mt a =
649 ServerResponseArg
650 (HTTP.Status ->
651 HTTP.ResponseHeaders ->
652 a -> Wai.Response)
653
654 instance HTTP_Response Server where
655 type Response Server = ServerResponse
656 type ResponseArg Server = ServerResponseArg
657 response ::
658 forall a mt k repr.
659 MimeUnserialize a mt =>
660 MimeSerialize a mt =>
661 k ~ Response repr =>
662 repr ~ Server =>
663 HTTP.Method ->
664 repr (ResponseArg repr mt a -> k) k
665 response expMethod = Server $ do
666 st@ServerState
667 { serverState_offset = o
668 , serverState_request = req
669 } <- S.get
670
671 -- Check the path has been fully consumed
672 unless (List.null $ Wai.pathInfo req) $
673 MC.throw $ Fail st [ServerErrorPath o "path is longer"]
674
675 -- Check the method
676 let reqMethod = Wai.requestMethod $ serverState_request st
677 unless (reqMethod == expMethod
678 || reqMethod == HTTP.methodHead
679 && expMethod == HTTP.methodGet) $
680 MC.throw $ Fail st [ServerErrorMethod]
681
682 -- Check the Accept header
683 let reqHeaders = Wai.requestHeaders $ serverState_request st
684 let expAccept = (Proxy::Proxy mt)
685 reqAccept <- do
686 case List.lookup HTTP.hAccept reqHeaders of
687 Nothing -> return expAccept
688 Just h ->
689 case Media.parseAccept h of
690 Nothing -> MC.throw $ Fail st
691 [ServerErrorAccept (mimeType expAccept) (Just (Left h))]
692 Just gotAccept
693 | mimeType expAccept`Media.matches`gotAccept -> return expAccept
694 -- FIXME: return gotAccept, maybe with GADTs
695 | otherwise -> MC.throw $ Fail st
696 [ServerErrorAccept (mimeType expAccept) (Just (Right gotAccept))]
697
698 -- Respond
699 return ($ ServerResponseArg $ \s hs a ->
700 Wai.responseLBS s
701 ((HTTP.hContentType, Media.renderHeader $ mimeType reqAccept):hs)
702 (if reqMethod == HTTP.methodHead
703 then ""
704 else mimeSerialize reqAccept a))
705
706 -- * Status
707 status200 :: HTTP.Status
708 status200 = HTTP.mkStatus 200 "Success"
709 status400 :: HTTP.Status
710 status400 = HTTP.mkStatus 400 "Bad Request"
711 status401 :: HTTP.Status
712 status401 = HTTP.mkStatus 401 "Unauthorized"
713 status403 :: HTTP.Status
714 status403 = HTTP.mkStatus 403 "Forbidden"
715 status404 :: HTTP.Status
716 status404 = HTTP.mkStatus 404 "Not Found"
717 status405 :: HTTP.Status
718 status405 = HTTP.mkStatus 405 "Method Not Allowed"
719 status406 :: HTTP.Status
720 status406 = HTTP.mkStatus 406 "Not Acceptable"
721 status415 :: HTTP.Status
722 status415 = HTTP.mkStatus 415 "Unsupported Media Type"
723
724 -- * Utils
725 liftIO :: MC.MonadExec IO m => IO a -> m a
726 liftIO = MC.exec
727 {-# INLINE liftIO #-}