reorder test code

This commit is contained in:
Sönke Hahn 2016-10-23 22:20:31 -04:00
parent ea43025d65
commit f9085b6b7a
2 changed files with 47 additions and 36 deletions

View file

@ -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,

View file

@ -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