servant/servant-server/test/Servant/Server/UsingContextSpec.hs
2016-03-07 23:12:24 +08:00

125 lines
3.6 KiB
Haskell

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module Servant.Server.UsingContextSpec where
import Control.Monad.Trans.Except
import Network.Wai
import Test.Hspec (Spec, describe, it)
import Test.Hspec.Wai
import Servant
import Servant.Server.UsingContextSpec.TestCombinators
spec :: Spec
spec = do
spec1
spec2
spec3
spec4
-- * API
type OneEntryAPI =
ExtractFromContext :> Get '[JSON] String
testServer :: String -> ExceptT ServantErr IO String
testServer s = return s
oneEntryApp :: Application
oneEntryApp =
serveWithContext (Proxy :: Proxy OneEntryAPI) context testServer
where
context :: Context '[String]
context = "contextEntry" :. EmptyContext
type OneEntryTwiceAPI =
"foo" :> ExtractFromContext :> Get '[JSON] String :<|>
"bar" :> ExtractFromContext :> Get '[JSON] String
oneEntryTwiceApp :: Application
oneEntryTwiceApp = serveWithContext (Proxy :: Proxy OneEntryTwiceAPI) context $
testServer :<|>
testServer
where
context :: Context '[String]
context = "contextEntryTwice" :. EmptyContext
-- * tests
spec1 :: Spec
spec1 = do
describe "accessing context entries from custom combinators" $ do
with (return oneEntryApp) $ do
it "allows retrieving a ContextEntry" $ do
get "/" `shouldRespondWith` "\"contextEntry\""
with (return oneEntryTwiceApp) $ do
it "allows retrieving the same ContextEntry twice" $ do
get "/foo" `shouldRespondWith` "\"contextEntryTwice\""
get "/bar" `shouldRespondWith` "\"contextEntryTwice\""
type InjectAPI =
InjectIntoContext :> "untagged" :> ExtractFromContext :>
Get '[JSON] String :<|>
InjectIntoContext :> "tagged" :> ExtractFromContext :>
Get '[JSON] String
injectApp :: Application
injectApp = serveWithContext (Proxy :: Proxy InjectAPI) context $
(\ s -> return s) :<|>
(\ s -> return ("tagged: " ++ s))
where
context = EmptyContext
spec2 :: Spec
spec2 = do
with (return injectApp) $ do
describe "inserting context entries with custom combinators" $ do
it "allows to inject context entries" $ do
get "/untagged" `shouldRespondWith` "\"injected\""
it "allows to inject tagged context entries" $ do
get "/tagged" `shouldRespondWith` "\"tagged: injected\""
type WithBirdfaceAPI =
"foo" :> ExtractFromContext :> Get '[JSON] String :<|>
NamedContextWithBirdface "sub" '[String] :>
"bar" :> ExtractFromContext :> Get '[JSON] String
withBirdfaceApp :: Application
withBirdfaceApp = serveWithContext (Proxy :: Proxy WithBirdfaceAPI) context $
testServer :<|>
testServer
where
context :: Context '[String, (NamedContext "sub" '[String])]
context =
"firstEntry" :.
(NamedContext ("secondEntry" :. EmptyContext)) :.
EmptyContext
spec3 :: Spec
spec3 = do
with (return withBirdfaceApp) $ do
it "allows retrieving different ContextEntries for the same combinator" $ do
get "/foo" `shouldRespondWith` "\"firstEntry\""
get "/bar" `shouldRespondWith` "\"secondEntry\""
type NamedContextAPI =
WithNamedContext "sub" '[String] (
ExtractFromContext :> Get '[JSON] String)
namedContextApp :: Application
namedContextApp = serveWithContext (Proxy :: Proxy NamedContextAPI) context return
where
context :: Context '[NamedContext "sub" '[String]]
context = NamedContext ("descend" :. EmptyContext) :. EmptyContext
spec4 :: Spec
spec4 = do
with (return namedContextApp) $ do
describe "WithNamedContext" $ do
it "allows descending into a subcontext for a given api" $ do
get "/" `shouldRespondWith` "\"descend\""