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