diff --git a/servant-server/src/Servant/Server/Utils/CustomCombinators.hs b/servant-server/src/Servant/Server/Utils/CustomCombinators.hs index 41a40afb..ad91bd07 100644 --- a/servant-server/src/Servant/Server/Utils/CustomCombinators.hs +++ b/servant-server/src/Servant/Server/Utils/CustomCombinators.hs @@ -6,6 +6,7 @@ -- fixme: document phases -- fixme: add doctests +-- fixme: document that the req body can only be consumed once module Servant.Server.Utils.CustomCombinators ( CombinatorImplementation, diff --git a/servant-server/test/Servant/Server/Utils/CustomCombinatorsSpec.hs b/servant-server/test/Servant/Server/Utils/CustomCombinatorsSpec.hs index 4e07b27c..e2eead46 100644 --- a/servant-server/test/Servant/Server/Utils/CustomCombinatorsSpec.hs +++ b/servant-server/test/Servant/Server/Utils/CustomCombinatorsSpec.hs @@ -161,8 +161,6 @@ spec = do response <- runApp app request responseBodyLbs response `shouldReturn` "\"foobar\"" - -- fixme: reorder tests - it "allows to access the context" $ do pending @@ -171,6 +169,8 @@ spec = do type Get' = Get '[JSON] +-- * capture combinators + data StringCapture instance HasServer api context => HasServer (StringCapture :> api) context where @@ -182,6 +182,8 @@ getCapture snippet = return $ case snippet of "error" -> FailFatal $ ServantErr 418 "I'm a teapot" "" [] text -> Route $ cs text +-- * request check combinators + data CheckFooHeader instance HasServer api context => HasServer (CheckFooHeader :> api) context where @@ -194,6 +196,20 @@ checkFooHeader request = return $ Just _ -> Route () Nothing -> FailFatal err400 +-- | a combinator that tries to access the request body in an invalid way +data InvalidRequestCheckCombinator + +instance HasServer api context => HasServer (InvalidRequestCheckCombinator :> api) context where + type ServerT (InvalidRequestCheckCombinator :> api) m = ServerT api m + route = runCI $ makeRequestCheckCombinator accessReqBody + +accessReqBody :: Request -> IO (RouteResult ()) +accessReqBody request = do + body <- fromBody $ requestBody request + deepseq body (return $ Route ()) + +-- * auth combinators + data AuthCombinator data User = User String @@ -209,40 +225,6 @@ checkAuth request = return $ case lookup "Auth" (requestHeaders request) of Just _ -> FailFatal err401 Nothing -> FailFatal err400 -data FooHeader - -instance HasServer api context => HasServer (FooHeader :> api) context where - type ServerT (FooHeader :> api) m = String -> ServerT api m - route = runCI $ makeCombinator getCustom - -getCustom :: Request -> IO (RouteResult String) -getCustom request = return $ case lookup "Foo" (requestHeaders request) of - Nothing -> FailFatal err400 - Just l -> Route $ cs l - -data StreamRequest - -data Source = Source (IO SBS.ByteString) - -instance HasServer api context => HasServer (StreamRequest :> api) context where - type ServerT (StreamRequest :> api) m = Source -> ServerT api m - route = runCI $ makeReqBodyCombinator getSource - -getSource :: IO SBS.ByteString -> Source -getSource = Source - --- | a combinator that tries to access the request body in an invalid way -data InvalidRequestCheckCombinator - -instance HasServer api context => HasServer (InvalidRequestCheckCombinator :> api) context where - type ServerT (InvalidRequestCheckCombinator :> api) m = ServerT api m - route = runCI $ makeRequestCheckCombinator accessReqBody - -accessReqBody :: Request -> IO (RouteResult ()) -accessReqBody request = do - body <- fromBody $ requestBody request - deepseq body (return $ Route ()) - -- | a combinator that tries to access the request body in an invalid way data InvalidAuthCombinator @@ -255,6 +237,34 @@ authWithReqBody request = do body <- fromBody $ requestBody request deepseq body (return $ Route $ User $ cs body) +-- * general combinators + +data FooHeader + +instance HasServer api context => HasServer (FooHeader :> api) context where + type ServerT (FooHeader :> api) m = String -> ServerT api m + route = runCI $ makeCombinator getCustom + +getCustom :: Request -> IO (RouteResult String) +getCustom request = return $ case lookup "Foo" (requestHeaders request) of + Nothing -> FailFatal err400 + Just l -> Route $ cs l + +-- * streaming combinators + +data StreamRequest + +data Source = Source (IO SBS.ByteString) + +instance HasServer api context => HasServer (StreamRequest :> api) context where + type ServerT (StreamRequest :> api) m = Source -> ServerT api m + route = runCI $ makeReqBodyCombinator getSource + +getSource :: IO SBS.ByteString -> Source +getSource = Source + +-- * utils + fromBody :: IO SBS.ByteString -> IO SBS.ByteString fromBody getChunk = do chunk <- getChunk