1 {-# LANGUAGE GADTs #-} -- for 'Router'
2 {-# LANGUAGE ConstraintKinds #-}
3 {-# LANGUAGE DefaultSignatures #-}
4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
5 {-# LANGUAGE OverloadedStrings #-}
6 {-# LANGUAGE UndecidableInstances #-} -- for nested type family application,
7 -- eg. in 'BodyStreamConstraint'
8 {-# OPTIONS_GHC -fno-warn-orphans #-}
9 -- | See <https://hackage.haskell.org/package/symantic-http-demo symantic-http-demo>
10 -- for an example of how to use this module.
11 module Symantic.HTTP.Server where
13 import Control.Arrow (first)
14 import Control.Applicative (Applicative(..))
15 import Control.Monad (Monad(..), unless, sequence, guard, (=<<))
16 import Control.Monad.Trans.Class (MonadTrans(..))
17 import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
19 import Data.Either (Either(..))
20 import Data.Eq (Eq(..))
21 import Data.Function (($), (.), id, const)
22 import Data.Functor (Functor(..), (<$>))
24 import Data.Maybe (Maybe(..), fromMaybe, catMaybes)
25 import Data.Monoid (Monoid(..))
26 import Data.Ord (Ord(..))
27 import Data.Proxy (Proxy(..))
28 import Data.Semigroup (Semigroup(..))
29 import Data.String (String, IsString(..))
30 import Data.Text (Text)
32 import Text.Show (Show(..))
33 import qualified Control.Monad.Classes as MC
34 import qualified Control.Monad.Trans.Cont as C
35 import qualified Control.Monad.Trans.Reader as R
36 import qualified Control.Monad.Trans.State.Strict as S
37 import qualified Control.Monad.Trans.Writer.Strict as W
38 import qualified Data.ByteString as BS
39 import qualified Data.ByteString.Base64 as BS64
40 import qualified Data.ByteString.Builder as BSB
41 import qualified Data.ByteString.Lazy as BSL
42 import qualified Data.List as List
43 import qualified Data.List.NonEmpty as NonEmpty
44 import qualified Data.Text as Text
45 import qualified Data.Text.Encoding as Text
46 import qualified Data.Word8 as Word8
47 import qualified Network.HTTP.Media as Media
48 import qualified Network.HTTP.Types as HTTP
49 import qualified Network.HTTP.Types.Header as HTTP
50 import qualified Network.Wai as Wai
51 import qualified Web.HttpApiData as Web
52 import qualified Data.Map.Strict as Map
53 import qualified Data.Map.Merge.Strict as Map
58 -- | (@'Server' handlers k@) is a recipe to produce an 'Wai.Application'
59 -- from given ('handlers') (one per number of alternative routes),
60 -- separated by (':!:').
62 -- 'Server' is analogous to a scanf using the API as a format customized for HTTP routing.
64 -- The multiple 'ServerCheckT' monad transformers are there
65 -- to prioritize the errors according to the type of check raising them,
66 -- instead of the order of the combinators within an actual API specification.
67 newtype Server handlers k = Server { unServer ::
69 (ServerCheckT [ServerErrorBody] -- 8th check, 400 error
70 (ServerCheckT [ServerErrorHeader] -- 7th check, 400 error
71 (ServerCheckT [ServerErrorQuery] -- 6th check, 400 error
72 (ServerCheckT [ServerErrorContentType] -- 5th check, 415 error
73 (ServerCheckT [ServerErrorAccept] -- 4th check, 406 error
74 (ServerCheckT [ServerErrorBasicAuth] -- 3rd check, 401 or 403 error
75 (ServerCheckT [ServerErrorMethod] -- 2nd check, 405 error
76 (ServerCheckT [ServerErrorPath] -- 1st check, 404 error
81 -- | (@'server' api handlers@) returns an 'Wai.Application'
82 -- ready to be given to @Warp.run 80@.
84 Router Server handlers (Response Server) ->
87 server api handlers rq re = do
88 lrPath <- runServerChecks (unServer $ unTrans $ router api) $ ServerState rq
90 Left err -> respondError HTTP.status404 [] err
93 Left err -> respondError HTTP.status405 [] err
98 [] -> respondError HTTP.status500 [] err
99 ServerErrorBasicAuth realm ba:_ ->
101 BasicAuth_Unauthorized ->
102 respondError HTTP.status403 [] err
104 respondError HTTP.status401
105 [ ( HTTP.hWWWAuthenticate
106 , "Basic realm=\""<>Web.toHeader realm<>"\""
110 Left err -> respondError HTTP.status406 [] err
111 Right lrContentType ->
112 case lrContentType of
113 Left err -> respondError HTTP.status415 [] err
116 Left err -> respondError HTTP.status400 [] err
119 Left err -> respondError HTTP.status400 [] err
122 Left err -> respondError HTTP.status400 [] err
129 [(HTTP.HeaderName, HeaderValue)] ->
130 err -> IO Wai.ResponseReceived
131 respondError st hs err =
132 -- Trace.trace (show err) $
133 re $ Wai.responseLBS st
134 ( (HTTP.hContentType, Media.renderHeader $ mediaType @PlainText)
136 ) (fromString $ show err) -- TODO: see what to return in the body
138 -- | Unwrap the 'ExceptT' constructors to reach the 'Either' constructors.
140 S.StateT ServerState (ExceptT e1 (ExceptT e2 (ExceptT e3 (ExceptT e4 (ExceptT e5 (ExceptT e6 (ExceptT e7 (ExceptT e8 IO)))))))) a ->
141 ServerState -> IO (Either e8 (Either e7 (Either e6 (Either e5 (Either e4 (Either e3 (Either e2 (Either e1 (a, ServerState)))))))))
142 runServerChecks s st =
153 -- ** Type 'ServerCheckT'
154 type ServerCheckT e = ExceptT (Fail e)
156 -- *** Type 'RouteResult'
157 type RouteResult e = Either (Fail e)
161 = Fail ServerState e -- ^ Keep trying other paths. 404, 405 or 406.
162 | FailFatal !ServerState !e -- ^ Don't try other paths.
164 failState :: Fail e -> ServerState
165 failState (Fail st _) = st
166 failState (FailFatal st _) = st
167 failError :: Fail e -> e
168 failError (Fail _st e) = e
169 failError (FailFatal _st e) = e
170 instance Semigroup e => Semigroup (Fail e) where
171 Fail _ x <> Fail st y = Fail st (x<>y)
172 FailFatal _ x <> Fail st y = FailFatal st (x<>y)
173 Fail _ x <> FailFatal st y = FailFatal st (x<>y)
174 FailFatal _ x <> FailFatal st y = FailFatal st (x<>y)
176 -- ** Type 'ServerState'
177 newtype ServerState = ServerState
178 { serverState_request :: Wai.Request
180 instance Show ServerState where
181 show _ = "ServerState"
183 instance Cat Server where
187 repr a b -> repr b c -> repr a c
188 -- NOTE: if x fails, run y to see if it fails on a more prioritized check.
189 -- And if so, fail with y instead of x.
191 -- This long spaghetti code may probably be avoided
192 -- with a more sophisticated 'Server' using a binary tree
193 -- instead of nested 'Either's, so that its 'Monad' instance
194 -- would do the right thing. But to my mind,
195 -- with the very few priorities of checks currently needed,
196 -- this is not worth the cognitive pain to design it.
197 -- Some copying/pasting/adapting will do for now.
198 Server x <.> Server y = Server $
200 xPath <- MC.exec @IO $ runServerChecks x st
202 Left xe -> MC.throw xe
206 yPath <- MC.exec @IO $ runServerChecks y (failState xe)
208 Left ye -> MC.throw ye
209 Right _yMethod -> MC.throw xe
213 yPath <- MC.exec @IO $ runServerChecks y (failState xe)
215 Left ye -> MC.throw ye
218 Left ye -> MC.throw ye
219 Right _yBasicAuth -> MC.throw xe
223 yPath <- MC.exec @IO $ runServerChecks y (failState xe)
225 Left ye -> MC.throw ye
228 Left ye -> MC.throw ye
231 Left ye -> MC.throw ye
232 Right _yAccept -> MC.throw xe
233 Right xContentType ->
236 yPath <- MC.exec @IO $ runServerChecks y (failState xe)
238 Left ye -> MC.throw ye
241 Left ye -> MC.throw ye
244 Left ye -> MC.throw ye
247 Left ye -> MC.throw ye
248 Right _yQuery -> MC.throw xe
252 yPath <- MC.exec @IO $ runServerChecks y (failState xe)
254 Left ye -> MC.throw ye
257 Left ye -> MC.throw ye
260 Left ye -> MC.throw ye
263 Left ye -> MC.throw ye
266 Left ye -> MC.throw ye
267 Right _yHeader -> MC.throw xe
271 yPath <- MC.exec @IO $ runServerChecks y (failState xe)
273 Left ye -> MC.throw ye
276 Left ye -> MC.throw ye
279 Left ye -> MC.throw ye
282 Left ye -> MC.throw ye
285 Left ye -> MC.throw ye
288 Left ye -> MC.throw ye
289 Right _yBody -> MC.throw xe
293 yPath <- MC.exec @IO $ runServerChecks y (failState xe)
295 Left ye -> MC.throw ye
298 Left ye -> MC.throw ye
301 Left ye -> MC.throw ye
304 Left ye -> MC.throw ye
307 Left ye -> MC.throw ye
310 Left ye -> MC.throw ye
311 Right _yBody -> MC.throw xe
313 (first (. a2b)) <$> S.runStateT y st'
314 instance Alt Server where
315 -- (<!>) :: repr a k -> repr b k -> repr (a:!:b) k
316 Server x <!> Server y = Server $
318 xPath <- MC.exec @IO $ runServerChecks x st
319 let fy = (first (\b2k (_a:!:b) -> b2k b) <$>)
321 Left xe | FailFatal{} <- xe -> MC.throw xe
323 yPath <- MC.exec @IO $ runServerChecks y st
325 Left ye -> MC.throw (xe<>ye)
327 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
328 return $ Right yMethod
331 Left xe | FailFatal{} <- xe -> MC.throw xe
333 yPath <- MC.exec @IO $ runServerChecks y st
335 Left _ye -> MC.throw xe
338 Left ye -> MC.throw (xe<>ye)
340 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
341 return $ Right $ yBasicAuth
344 Left xe | FailFatal{} <- xe -> MC.throw xe
346 yPath <- MC.exec @IO $ runServerChecks y st
348 Left _ye -> MC.throw xe
351 Left _ye -> MC.throw xe
354 Left ye -> MC.throw (xe<>ye)
356 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
357 return $ Right yAccept
360 Left xe | FailFatal{} <- xe -> MC.throw xe
362 yPath <- MC.exec @IO $ runServerChecks y st
364 Left _ye -> MC.throw xe
367 Left _ye -> MC.throw xe
370 Left _ye -> MC.throw xe
373 Left ye -> MC.throw (xe<>ye)
374 Right yContentType ->
375 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
376 return $ Right yContentType
377 Right xContentType ->
379 Left xe | FailFatal{} <- xe -> MC.throw xe
381 yPath <- MC.exec @IO $ runServerChecks y st
383 Left _ye -> MC.throw xe
386 Left _ye -> MC.throw xe
389 Left _ye -> MC.throw xe
392 Left _ye -> MC.throw xe
393 Right yContentType ->
395 Left ye -> MC.throw (xe<>ye)
397 fy $ ExceptT $ ExceptT $ ExceptT $ ExceptT $
398 return $ Right yQuery
401 Left xe | FailFatal{} <- xe -> MC.throw xe
403 yPath <- MC.exec @IO $ runServerChecks y st
405 Left _ye -> MC.throw xe
408 Left _ye -> MC.throw xe
411 Left _ye -> MC.throw xe
414 Left _ye -> MC.throw xe
415 Right yContentType ->
417 Left _ye -> MC.throw xe
420 Left ye -> MC.throw (xe<>ye)
422 fy $ ExceptT $ ExceptT $ ExceptT $
423 return $ Right yHeader
426 Left xe | FailFatal{} <- xe -> MC.throw xe
428 yPath <- MC.exec @IO $ runServerChecks y st
430 Left _ye -> MC.throw xe
433 Left _ye -> MC.throw xe
436 Left _ye -> MC.throw xe
439 Left _ye -> MC.throw xe
440 Right yContentType ->
442 Left _ye -> MC.throw xe
445 Left _ye -> MC.throw xe
448 Left ye -> MC.throw (xe<>ye)
450 fy $ ExceptT $ ExceptT $
454 Left xe | FailFatal{} <- xe -> MC.throw xe
456 yPath <- MC.exec @IO $ runServerChecks y st
458 Left _ye -> MC.throw xe
461 Left _ye -> MC.throw xe
464 Left _ye -> MC.throw xe
467 Left _ye -> MC.throw xe
468 Right yContentType ->
470 Left _ye -> MC.throw xe
473 Left _ye -> MC.throw xe
476 Left _ye -> MC.throw xe
479 Left ye -> MC.throw (xe<>ye)
484 return $ first (\a2k (a:!:_b) -> a2k a) xr
485 instance Pro Server where
486 dimap a2b _b2a (Server r) = Server $ (\k b2k -> k (b2k . a2b)) <$> r
488 -- ** Type 'ServerErrorPath'
489 newtype ServerErrorPath = ServerErrorPath Text
492 instance HTTP_Path Server where
493 type PathConstraint Server a = Web.FromHttpApiData a
494 segment expSegment = Server $ do
496 { serverState_request = req
498 case Wai.pathInfo req of
499 [] -> MC.throw $ Fail st [ServerErrorPath "empty path segment"]
500 [""] -> MC.throw $ Fail st [ServerErrorPath "trailing slash"]
502 | curr /= expSegment ->
503 MC.throw $ Fail st [ServerErrorPath $ "expected: "<>expSegment<>" but got: "<>curr]
506 { serverState_request = req{ Wai.pathInfo = next }
509 capture' :: forall a k. PathConstraint Server a => Name -> Server (a -> k) k
510 capture' name = Server $ do
512 { serverState_request = req
514 case Wai.pathInfo req of
515 [] -> MC.throw $ Fail st [ServerErrorPath "empty"]
516 [""] -> MC.throw $ Fail st [ServerErrorPath "trailing slash"]
518 case Web.parseUrlPiece curr of
519 Left err -> MC.throw $ Fail st [ServerErrorPath $ "capture: "<>fromString name<>": "<>err]
522 { serverState_request = req{ Wai.pathInfo = next }
525 captureAll = Server $ do
526 req <- S.gets serverState_request
527 return ($ Wai.pathInfo req)
529 -- ** Type 'ServerErrorMethod'
530 data ServerErrorMethod = ServerErrorMethod
533 -- | TODO: add its own error?
534 instance HTTP_Version Server where
535 version exp = Server $ do
537 let got = Wai.httpVersion $ serverState_request st
540 else MC.throw $ Fail st [ServerErrorMethod] -- FIXME: ServerErrorVersion
542 -- ** Type 'ServerErrorAccept'
543 data ServerErrorAccept =
546 (Maybe (Either BS.ByteString MediaType))
549 -- ** Type 'ServerErrorContentType'
550 data ServerErrorContentType = ServerErrorContentType
553 -- ** Type 'ServerErrorQuery'
554 newtype ServerErrorQuery = ServerErrorQuery Text
556 instance HTTP_Query Server where
557 type QueryConstraint Server a = Web.FromHttpApiData a
558 queryParams' name = Server $ do
560 lift $ ExceptT $ ExceptT $ ExceptT $ return $
561 let qs = Wai.queryString $ serverState_request st in
562 let vals = catMaybes $ (<$> qs) $ \(n,v) ->
564 then Web.parseQueryParam . Text.decodeUtf8 <$> v
566 case sequence vals of
567 Left err -> Left $ Fail st [ServerErrorQuery err]
568 Right vs -> Right $ Right $ Right ($ vs)
570 -- ** Type 'ServerErrorHeader'
571 data ServerErrorHeader = ServerErrorHeader
573 instance HTTP_Header Server where
574 header n = Server $ do
576 lift $ ExceptT $ ExceptT $ return $
577 let hs = Wai.requestHeaders $ serverState_request st in
578 case List.lookup n hs of
579 Nothing -> Left $ Fail st [ServerErrorHeader]
580 Just v -> Right $ Right ($ v)
582 -- ** Type 'ServerErrorBasicAuth'
583 data ServerErrorBasicAuth =
584 ServerErrorBasicAuth BasicAuthRealm (BasicAuth ())
587 -- ** Class 'ServerBasicAuth'
588 -- | Custom 'BasicAuth' check.
589 class ServerBasicAuth a where
595 -- | WARNING: current implementation of Basic Access Authentication
596 -- is not immune to certain kinds of timing attacks.
597 -- Decoding payloads does not take a fixed amount of time.
598 instance HTTP_BasicAuth Server where
599 type BasicAuthConstraint Server a = ServerBasicAuth a
600 type BasicAuthArgs Server a k = a -> k
601 basicAuth' realm = Server $ do
603 let err e = MC.throw $ Fail st [ServerErrorBasicAuth realm e]
604 case decodeAuthorization $ serverState_request st of
605 Nothing -> err BasicAuth_BadPassword
606 Just (user, pass) -> do
607 MC.exec @IO (serverBasicAuth user pass) >>= \case
608 BasicAuth_BadPassword -> err BasicAuth_BadPassword
609 BasicAuth_NoSuchUser -> err BasicAuth_NoSuchUser
610 BasicAuth_Unauthorized -> err BasicAuth_Unauthorized
611 BasicAuth_Authorized u -> return ($ u)
613 -- | Find and decode an 'Authorization' header from the request as a Basic Auth
614 decodeAuthorization :: Wai.Request -> Maybe (BasicAuthUser, BasicAuthPass)
615 decodeAuthorization req = do
616 hAuthorization <- List.lookup "Authorization" $ Wai.requestHeaders req
617 let (basic, rest) = BS.break Word8.isSpace hAuthorization
618 guard (BS.map Word8.toLower basic == "basic")
619 let decoded = BS64.decodeLenient (BS.dropWhile Word8.isSpace rest)
620 let (user, colon_pass) = BS.break (== Word8._colon) decoded
621 (_, pass) <- BS.uncons colon_pass
622 return (Text.decodeUtf8 user, Text.decodeUtf8 pass)
624 -- ** Type 'ServerErrorBody'
625 newtype ServerErrorBody = ServerErrorBody String
628 -- *** Type 'ServerBodyArg'
629 newtype ServerBodyArg (ts::[*]) a = ServerBodyArg a
631 instance HTTP_Body Server where
632 type BodyConstraint Server a ts = MimeTypes ts (MimeDecodable a)
633 type BodyArg Server a ts = ServerBodyArg ts a
636 BodyConstraint repr a ts =>
638 repr (BodyArg repr a ts -> k) k
641 lift $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ do
642 let hs = Wai.requestHeaders $ serverState_request st
644 -- DOC: http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
645 -- DOC: http://www.w3.org/2001/tag/2002/0129-mime
646 fromMaybe "application/octet-stream" $
647 List.lookup HTTP.hContentType hs
648 case matchContent @ts @(MimeDecodable a) reqContentType of
649 Nothing -> return $ Left $ Fail st [ServerErrorContentType]
650 Just (MimeType mt) -> do
651 bodyBS <- MC.exec @IO $ Wai.requestBody $ serverState_request st
652 return $ Right $ Right $ Right $
653 -- NOTE: delay 'mimeDecode' after all checks
654 case mimeDecode mt $ BSL.fromStrict bodyBS of
655 Left err -> Left $ Fail st [ServerErrorBody err]
656 Right a -> Right ($ ServerBodyArg a)
658 -- *** Type 'ServerBodyStreamArg'
659 newtype ServerBodyStreamArg as (ts::[*]) framing
660 = ServerBodyStreamArg as
661 instance HTTP_BodyStream Server where
662 type BodyStreamConstraint Server as ts framing =
663 ( FramingDecode framing as
664 , MC.MonadExec IO (FramingMonad as)
665 , MimeTypes ts (MimeDecodable (FramingYield as))
667 type BodyStreamArg Server as ts framing =
668 ServerBodyStreamArg as ts framing
670 forall as ts framing k repr.
671 BodyStreamConstraint repr as ts framing =>
673 repr (BodyStreamArg repr as ts framing -> k) k
674 bodyStream'= Server $ do
676 lift $ ExceptT $ ExceptT $ ExceptT $ ExceptT $ do
677 let hs = Wai.requestHeaders $ serverState_request st
679 -- DOC: http://www.w3.org/Protocols/rfc2616/rfc2616-sec7.html#sec7.2.1
680 -- DOC: http://www.w3.org/2001/tag/2002/0129-mime
681 fromMaybe "application/octet-stream" $
682 List.lookup HTTP.hContentType hs
683 case matchContent @ts @(MimeDecodable (FramingYield as)) reqContentType of
684 Nothing -> return $ Left $ Fail st [ServerErrorContentType]
685 Just (MimeType mt) -> do
686 let bodyBS = Wai.requestBody $ serverState_request st
687 return $ Right $ Right $ Right $
688 Right ($ ServerBodyStreamArg $
689 framingDecode (Proxy @framing) (mimeDecode mt) $
693 -- * Type 'ServerResponse'
694 -- | A continuation for 'server''s users to respond.
696 -- This newtype has two uses :
698 -- * Carrying the 'ts' type variable to 'server'.
699 -- * Providing a 'return' for the simple response case
700 -- of 'HTTP.status200' and no extra headers.
701 newtype ServerRes (ts::[*]) m a
703 { unServerResponse :: m a
704 } deriving (Functor, Applicative, Monad)
705 type ServerResponse ts m = ServerRes ts
706 (R.ReaderT Wai.Request
707 (W.WriterT HTTP.ResponseHeaders
708 (W.WriterT HTTP.Status
709 (C.ContT Wai.Response m))))
710 instance MonadTrans (ServerRes ts) where
711 lift = ServerResponse
712 -- | All supported effects are handled by nested 'Monad's.
713 type instance MC.CanDo (ServerResponse ts m) eff = 'False
714 type instance MC.CanDo (C.ContT ts m) (MC.EffExec eff) = 'False
716 instance HTTP_Response Server where
717 type ResponseConstraint Server a ts = MimeTypes ts (MimeEncodable a)
718 type ResponseArgs Server a ts = ServerResponse ts IO a
719 type Response Server =
721 (Wai.Response -> IO Wai.ResponseReceived) ->
722 IO Wai.ResponseReceived
725 ResponseConstraint repr a ts =>
728 repr (ResponseArgs repr a ts)
730 response expMethod = Server $ do
732 { serverState_request = req
735 -- Check the path has been fully consumed
736 unless (List.null $ Wai.pathInfo req) $
737 MC.throw $ Fail st [ServerErrorPath "path is longer"]
740 let reqMethod = Wai.requestMethod $ serverState_request st
741 unless (reqMethod == expMethod
742 || reqMethod == HTTP.methodHead
743 && expMethod == HTTP.methodGet) $
744 MC.throw $ Fail st [ServerErrorMethod]
746 -- Check the Accept header
747 let reqHeaders = Wai.requestHeaders $ serverState_request st
748 MimeType reqAccept <- do
749 case List.lookup HTTP.hAccept reqHeaders of
751 return $ NonEmpty.head $ mimeTypes @ts @(MimeEncodable a)
753 case matchAccept @ts @(MimeEncodable a) h of
754 Nothing -> MC.throw $ Fail st [ServerErrorAccept (mediaTypes @ts @(MimeEncodable a)) (Just (Left h))]
757 return $ \(ServerResponse k) rq re -> re =<< do
758 C.runContT (W.runWriterT $ W.runWriterT $ R.runReaderT k rq) $ \((a,hs),sta) ->
761 ((HTTP.hContentType, Media.renderHeader $ mediaTypeFor reqAccept):hs)
762 (if reqMethod == HTTP.methodHead
764 else mimeEncode reqAccept a)
766 -- * Type 'ServerResponseStream'
768 -- This newtype has three uses :
770 -- * Carrying the 'framing' type variable to 'server'.
771 -- * Carrying the 'ts' type variable to 'server'.
772 -- * Providing a 'return' for the simple response case
773 -- of 'HTTP.status200' and no extra headers.
774 newtype ServerResStream framing (ts::[*]) m as
775 = ServerResponseStream
776 { unServerResponseStream :: m as
777 } deriving (Functor, Applicative, Monad)
778 instance MonadTrans (ServerResStream framing ts) where
779 lift = ServerResponseStream
780 type ServerResponseStream framing ts m = ServerResStream framing ts
781 (R.ReaderT Wai.Request
782 (W.WriterT HTTP.ResponseHeaders
783 (W.WriterT HTTP.Status
784 (C.ContT Wai.Response m))))
785 -- | All supported effects are handled by nested 'Monad's.
786 type instance MC.CanDo (ServerResponseStream framing ts m) eff = 'False
788 instance HTTP_ResponseStream Server where
789 type ResponseStreamConstraint Server as ts framing =
790 ( FramingEncode framing as
791 , MimeTypes ts (MimeEncodable (FramingYield as))
793 type ResponseStreamArgs Server as ts framing =
794 ServerResponseStream framing ts IO as
795 type ResponseStream Server =
797 (Wai.Response -> IO Wai.ResponseReceived) ->
798 IO Wai.ResponseReceived
800 forall as ts framing repr.
801 ResponseStreamConstraint repr as ts framing =>
804 repr (ResponseStreamArgs repr as ts framing)
805 (ResponseStream repr)
806 responseStream expMethod = Server $ do
808 { serverState_request = req
811 -- Check the path has been fully consumed
812 unless (List.null $ Wai.pathInfo req) $
813 MC.throw $ Fail st [ServerErrorPath "path is longer"]
816 let reqMethod = Wai.requestMethod $ serverState_request st
817 unless (reqMethod == expMethod
818 || reqMethod == HTTP.methodHead
819 && expMethod == HTTP.methodGet) $
820 MC.throw $ Fail st [ServerErrorMethod]
822 -- Check the Accept header
823 let reqHeaders = Wai.requestHeaders $ serverState_request st
824 MimeType reqAccept <- do
825 case List.lookup HTTP.hAccept reqHeaders of
827 return $ NonEmpty.head $ mimeTypes @ts @(MimeEncodable (FramingYield as))
829 case matchAccept @ts @(MimeEncodable (FramingYield as)) h of
830 Nothing -> MC.throw $ Fail st [ServerErrorAccept (mediaTypes @ts @(MimeEncodable (FramingYield as))) (Just (Left h))]
833 return $ \(ServerResponseStream k) rq re -> re =<< do
834 C.runContT (W.runWriterT $ W.runWriterT $ R.runReaderT k rq) $ \((as,hs),sta) ->
836 Wai.responseStream sta
837 ( (HTTP.hContentType, Media.renderHeader $ mediaTypeFor reqAccept)
840 if reqMethod == HTTP.methodHead
843 let enc = framingEncode (Proxy @framing) (mimeEncode reqAccept) in
847 Right (bsl, next) -> do
848 unless (BSL.null bsl) $ do
849 write (BSB.lazyByteString bsl)
854 -- | Return worse 'HTTP.Status'.
855 instance Semigroup HTTP.Status where
857 if rank (HTTP.statusCode x) < rank (HTTP.statusCode y)
862 rank 404 = 0 -- Not Found
863 rank 405 = 1 -- Method Not Allowed
864 rank 401 = 2 -- Unauthorized
865 rank 415 = 3 -- Unsupported Media Type
866 rank 406 = 4 -- Not Acceptable
867 rank 400 = 5 -- Bad Request
869 -- | Useful when 'HTTP.Status' is within a 'W.WriterT'.
870 instance Monoid HTTP.Status where
871 mempty = HTTP.status200
876 -- | 'Trans'form a 'Server' to merge 'Alt'ernative 'segment's into a 'routing'.
877 data Router repr a b where
878 -- | Lift any @(repr)@ into 'Router', those not useful to segregate
879 -- wrt. the 'Trans'formation performed, aka. 'noTrans'.
880 Router_Any :: repr a b -> Router repr a b
881 -- | Represent 'segment'.
882 Router_Seg :: PathSegment -> Router repr a a
883 -- | Represent ('<.>').
884 Router_Cat :: Router repr a b -> Router repr b c -> Router repr a c
885 -- | Represent 'routing'.
886 Router_Map :: Map.Map PathSegment (Router repr a k) -> Router repr a k
887 -- | Represent ('<!>').
888 Router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
889 -- | Used to transform 'Router_Alt' into 'Router_Map',
890 -- while following the way ('<!>') combinators are associated in the API.
891 -- Use 'router_AltL' to insert it correctly.
892 Router_AltL :: Router repr a k -> Router repr (a:!:b) k
893 -- | Used to transform 'Router_Alt' into 'Router_Map'
894 -- while following the way ('<!>') combinators are associated in the API.
895 -- Use 'router_AltR' to insert it correctly.
896 Router_AltR :: Router repr b k -> Router repr (a:!:b) k
897 -- Router_AltB :: Router repr (a:!:a) k -> Router repr a k
899 instance Trans (Router Server) where
900 type UnTrans (Router Server) = Server
902 unTrans (Router_Any x) = x
903 unTrans (Router_Seg s) = segment s
904 unTrans (Router_Cat x y) = unTrans x <.> unTrans y
905 unTrans (Router_Alt x y) = unTrans x <!> unTrans y
906 unTrans (Router_AltL x) = Server $ (\a2k (a:!:_b) -> a2k a) <$> unServer (unTrans x)
907 unTrans (Router_AltR x) = Server $ (\b2k (_a:!:b) -> b2k b) <$> unServer (unTrans x)
908 unTrans (Router_Map ms) = routing (unTrans <$> ms)
909 -- unTrans (Router_AltB x) = Server $ (\a2k a -> a2k (a:!:a)) <$> unServer (unTrans x)
911 -- | Traverse a 'Router' to transform 'Router_Alt'
912 -- into 'Router_Map' when possible.
913 -- Used in 'server' on the 'Router' inferred from the given API.
914 router :: Router repr a b -> Router repr a b
918 Router_Cat x y -> router x `Router_Cat` router y
919 Router_Alt x y -> router_Alt x y
920 Router_AltL x -> Router_AltL (router x)
921 Router_AltR x -> Router_AltR (router x)
922 Router_Map xs -> Router_Map (router <$> xs)
924 -- | Insert a 'Router_Alt' or a 'Router_Map' if possible.
925 router_Alt :: Router repr a k -> Router repr b k -> Router repr (a:!:b) k
926 router_Alt (Router_Seg x `Router_Cat` xt) (Router_Seg y `Router_Cat` yt) =
927 Router_Map $ Map.fromListWith
928 (\_xt _yt -> xt `router_Alt` yt)
929 [ (x, router_AltL xt)
930 , (y, router_AltR yt)
932 router_Alt (Router_Seg x `Router_Cat` xt) (Router_Map ys) =
935 (Map.traverseMissing $ const $ return . router_AltL)
936 (Map.traverseMissing $ const $ return . router_AltR)
937 (Map.zipWithAMatched $ const $ \a b -> return $ a`router_Alt`b)
938 (Map.singleton x xt) ys
939 router_Alt (Router_Map xs) (Router_Seg y `Router_Cat` yt) =
942 (Map.traverseMissing $ const $ return . router_AltL)
943 (Map.traverseMissing $ const $ return . router_AltR)
944 (Map.zipWithAMatched $ const $ \a b -> return $ a`router_Alt`b)
945 xs (Map.singleton y yt)
946 router_Alt (Router_Map xs) (Router_Map ys) =
949 (Map.traverseMissing $ const $ return . router_AltL)
950 (Map.traverseMissing $ const $ return . router_AltR)
951 (Map.zipWithAMatched $ const $ \a b -> return $ a`router_Alt`b)
953 router_Alt (Router_Cat (Router_Cat x y) z) w = router_Alt (Router_Cat x (Router_Cat y z)) w
954 router_Alt w (Router_Cat (Router_Cat x y) z) = router_Alt w (Router_Cat x (Router_Cat y z))
955 router_Alt x (Router_Alt y z) = router_Alt x (router_Alt y z)
956 router_Alt (Router_Alt x y) z = router_Alt (router_Alt x y) z
957 router_Alt x y = Router_Alt x y
959 -- | Insert a 'Router_AltL' as deep as possible
960 -- in order to not prevent the transformation
961 -- of 'Router_Alt' into 'Router_Map' in 'router_Alt'.
962 router_AltL :: Router repr a k -> Router repr (a:!:b) k
964 Router_Cat (Router_Seg x) y -> Router_Cat (Router_Seg x) (router_AltL y)
965 Router_Cat x y -> Router_Cat (router_AltL x) y
966 Router_Alt x y -> router_AltL (router_Alt x y)
967 Router_Map xs -> Router_Map (router_AltL <$> xs)
970 -- | Like 'router_AltL' but for 'Router_AltR'.
971 router_AltR :: Router repr b k -> Router repr (a:!:b) k
973 Router_Cat (Router_Seg x) y -> Router_Cat (Router_Seg x) (router_AltR y)
974 Router_Cat x y -> Router_Cat (router_AltR x) y
975 Router_Alt x y -> router_AltR (router_Alt x y)
976 Router_Map xs -> Router_Map (router_AltR <$> xs)
979 instance Cat (Router Server) where
981 instance Alt (Router Server) where
983 instance HTTP_Path (Router Server) where
985 instance HTTP_Routing (Router Server) where
987 instance Pro (Router Server)
988 instance HTTP_Query (Router Server)
989 instance HTTP_Header (Router Server)
990 instance HTTP_Body (Router Server)
991 instance HTTP_BodyStream (Router Server)
992 instance HTTP_BasicAuth (Router Server)
993 instance HTTP_Response (Router Server)
994 instance HTTP_ResponseStream (Router Server)
996 -- ** Class 'HTTP_Routing'
997 class HTTP_Routing repr where
998 routing :: Map.Map PathSegment (repr a k) -> repr a k
1002 HTTP_Routing (UnTrans repr) =>
1003 Map.Map PathSegment (repr a k) -> repr a k
1004 routing = noTrans . routing . (unTrans <$>)
1006 instance HTTP_Routing Server where
1007 routing ms = Server $ do
1009 { serverState_request = req
1011 case Wai.pathInfo req of
1012 [] -> MC.throw $ Fail st [ServerErrorPath "empty path segment"]
1013 [""] -> MC.throw $ Fail st [ServerErrorPath "trailing slash"]
1015 case Map.lookup curr ms of
1016 Nothing -> MC.throw $ Fail st [ServerErrorPath $ "expected: "<>Text.pack (show (Map.keys ms))<>" but got: "<>curr]
1019 { serverState_request = req{ Wai.pathInfo = next }
1024 -- ** Class 'ReprEq'
1025 class ReprEq repr where
1026 reprEq :: repr a b -> repr c d -> Maybe ((a,b):~:(c,d))
1027 instance ReprEq repr => ReprEq (Router repr) where
1030 (Router_Any y) = reprEq x y
1032 (Router_Seg x `Router_Cat` xt)
1033 (Router_Seg y `Router_Cat` yt)
1035 , Just Refl <- reprEq xt yt
1040 go (Map.toList xs) (Map.toList ys)
1043 [(PathSegment, Router repr a b)] ->
1044 [(PathSegment, Router repr c d)] ->
1045 Maybe ((a,b):~:(c,d))
1046 go ((ak,at):[]) ((bk,bt):[])
1048 , Just Refl <- reprEq at bt
1050 go ((ak,at):as) ((bk,bt):bs)
1052 , Just Refl <- reprEq at bt
1055 -- NOTE: if the routing is empty there is no way to return the Refl proof.
1057 (Router_Cat xa2b xb2c)
1058 (Router_Cat ya2b yb2c)
1059 | Just Refl <- reprEq xa2b ya2b
1060 , Just Refl <- reprEq xb2c yb2c
1065 | Just Refl <- reprEq xl yl
1066 , Just Refl <- reprEq xr yr
1072 | Just Refl <- reprEq x y
1076 Router_Map xs == Router_Map ys = xs == ys
1077 Router_Cat xa2b xb2c == Router_Cat ya2b yb2c =
1078 | Just Refl <- testEquality