servant/test/Servant/ServerSpec.hs

450 lines
14 KiB
Haskell
Raw Normal View History

2014-12-10 16:10:57 +01:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Servant.ServerSpec where
2015-02-24 14:48:17 +01:00
import Control.Monad (when)
2015-01-06 17:34:03 +01:00
import Control.Monad.Trans.Either (EitherT, left)
import Data.Aeson (ToJSON, FromJSON, encode, decode')
import Data.Char (toUpper)
import Data.Monoid ((<>))
2015-01-06 17:34:03 +01:00
import Data.Proxy (Proxy(Proxy))
import Data.String (fromString)
import Data.String.Conversions (cs)
import GHC.Generics (Generic)
2015-02-24 14:48:17 +01:00
import Network.HTTP.Types ( parseQuery, ok200, status409, methodPost
, methodDelete, hContentType)
2015-01-13 20:40:41 +01:00
import Network.Wai ( Application, Request, responseLBS, pathInfo
, queryString, rawQueryString )
import Network.Wai.Test (runSession, defaultRequest, simpleBody, request)
2015-01-06 17:34:03 +01:00
import Test.Hspec (Spec, describe, it, shouldBe)
2015-01-13 20:40:41 +01:00
import Test.Hspec.Wai ( liftIO, with, get, post, shouldRespondWith
, matchStatus, request )
2015-01-06 17:34:03 +01:00
2015-02-24 14:48:17 +01:00
import Servant.API (JSON, Capture, Get, ReqBody, Post, QueryParam
, QueryParams, QueryFlag, MatrixParam, MatrixParams
, MatrixFlag, Raw, (:>), (:<|>)(..), Header, Delete )
2015-01-06 17:34:03 +01:00
import Servant.Server (Server, serve)
import Servant.Server.Internal (RouteMismatch(..))
2014-12-10 16:10:57 +01:00
-- * test data types
data Person = Person {
name :: String,
age :: Integer
}
deriving (Eq, Show, Generic)
instance ToJSON Person
instance FromJSON Person
alice :: Person
alice = Person "Alice" 42
data Animal = Animal {
species :: String,
numberOfLegs :: Integer
}
deriving (Eq, Show, Generic)
instance ToJSON Animal
instance FromJSON Animal
jerry :: Animal
jerry = Animal "Mouse" 4
tweety :: Animal
tweety = Animal "Bird" 2
-- * specs
spec :: Spec
spec = do
captureSpec
getSpec
queryParamSpec
2014-12-28 23:07:14 +01:00
matrixParamSpec
2014-12-10 16:10:57 +01:00
postSpec
2015-02-24 14:48:17 +01:00
headerSpec
2014-12-10 16:10:57 +01:00
rawSpec
unionSpec
errorsSpec
2014-12-10 16:10:57 +01:00
2015-01-12 15:08:41 +01:00
type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
2014-12-10 16:10:57 +01:00
captureApi :: Proxy CaptureApi
captureApi = Proxy
captureServer :: Integer -> EitherT (Int, String) IO Animal
captureServer legs = case legs of
4 -> return jerry
2 -> return tweety
_ -> left (404, "not found")
captureSpec :: Spec
captureSpec = do
describe "Servant.API.Capture" $ do
with (return (serve captureApi captureServer)) $ do
it "can capture parts of the 'pathInfo'" $ do
response <- get "/2"
liftIO $ do
decode' (simpleBody response) `shouldBe` Just tweety
with (return (serve
(Proxy :: Proxy (Capture "captured" String :> Raw))
2015-01-06 17:26:37 +01:00
(\ "captured" request_ respond ->
respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
2014-12-10 16:10:57 +01:00
it "strips the captured path snippet from pathInfo" $ do
get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
2015-01-12 15:08:41 +01:00
type GetApi = Get '[JSON] Person
2014-12-10 16:10:57 +01:00
getApi :: Proxy GetApi
getApi = Proxy
getSpec :: Spec
getSpec = do
describe "Servant.API.Get" $ do
with (return (serve getApi (return alice))) $ do
it "allows to GET a Person" $ do
response <- get "/"
return response `shouldRespondWith` 200
liftIO $ do
decode' (simpleBody response) `shouldBe` Just alice
it "throws 405 (wrong method) on POSTs" $ do
post "/" "" `shouldRespondWith` 405
2015-01-12 15:08:41 +01:00
type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
:<|> "a" :> QueryParams "names" String :> Get '[JSON] Person
:<|> "b" :> QueryFlag "capitalize" :> Get '[JSON] Person
2014-12-10 16:10:57 +01:00
queryParamApi :: Proxy QueryParamApi
queryParamApi = Proxy
qpServer :: Server QueryParamApi
qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize
where qpNames (_:name2:_) = return alice { name = name2 }
qpNames _ = return alice
qpCapitalize False = return alice
qpCapitalize True = return alice { name = map toUpper (name alice) }
2015-01-06 17:26:37 +01:00
queryParamServer (Just name_) = return alice{name = name_}
2014-12-10 16:10:57 +01:00
queryParamServer Nothing = return alice
queryParamSpec :: Spec
queryParamSpec = do
describe "Servant.API.QueryParam" $ do
it "allows to retrieve simple GET parameters" $
(flip runSession) (serve queryParamApi qpServer) $ do
let params1 = "?name=bob"
response1 <- Network.Wai.Test.request defaultRequest{
rawQueryString = params1,
queryString = parseQuery params1
}
liftIO $ do
decode' (simpleBody response1) `shouldBe` Just alice{
name = "bob"
}
it "allows to retrieve lists in GET parameters" $
(flip runSession) (serve queryParamApi qpServer) $ do
let params2 = "?names[]=bob&names[]=john"
response2 <- Network.Wai.Test.request defaultRequest{
rawQueryString = params2,
queryString = parseQuery params2,
pathInfo = ["a"]
}
liftIO $
decode' (simpleBody response2) `shouldBe` Just alice{
name = "john"
}
2015-01-13 20:40:41 +01:00
2014-12-10 16:10:57 +01:00
it "allows to retrieve value-less GET parameters" $
(flip runSession) (serve queryParamApi qpServer) $ do
let params3 = "?capitalize"
response3 <- Network.Wai.Test.request defaultRequest{
rawQueryString = params3,
queryString = parseQuery params3,
pathInfo = ["b"]
}
liftIO $
decode' (simpleBody response3) `shouldBe` Just alice{
name = "ALICE"
}
let params3' = "?capitalize="
response3' <- Network.Wai.Test.request defaultRequest{
rawQueryString = params3',
queryString = parseQuery params3',
pathInfo = ["b"]
}
liftIO $
decode' (simpleBody response3') `shouldBe` Just alice{
name = "ALICE"
}
2014-12-28 23:07:14 +01:00
let params3'' = "?unknown="
response3' <- Network.Wai.Test.request defaultRequest{
rawQueryString = params3'',
queryString = parseQuery params3'',
pathInfo = ["b"]
}
liftIO $
decode' (simpleBody response3') `shouldBe` Just alice{
name = "Alice"
}
type MatrixParamApi = "a" :> MatrixParam "name" String :> Get '[JSON] Person
:<|> "b" :> MatrixParams "names" String :> "bsub" :> MatrixParams "names" String :> Get '[JSON] Person
:<|> "c" :> MatrixFlag "capitalize" :> Get '[JSON] Person
:<|> "d" :> Capture "foo" Integer :> MatrixParam "name" String :> MatrixFlag "capitalize" :> "dsub" :> Get '[JSON] Person
2014-12-28 23:07:14 +01:00
matrixParamApi :: Proxy MatrixParamApi
matrixParamApi = Proxy
mpServer :: Server MatrixParamApi
mpServer = matrixParamServer :<|> mpNames :<|> mpCapitalize alice :<|> mpComplex
where mpNames (_:name2:_) _ = return alice { name = name2 }
mpNames _ _ = return alice
mpCapitalize p False = return p
mpCapitalize p True = return p { name = map toUpper (name p) }
matrixParamServer (Just name) = return alice{name = name}
matrixParamServer Nothing = return alice
mpAge age p = return p { age = age }
mpComplex capture name cap = matrixParamServer name >>= flip mpCapitalize cap >>= mpAge capture
matrixParamSpec :: Spec
matrixParamSpec = do
describe "Servant.API.MatrixParam" $ do
it "allows to retrieve simple matrix parameters" $
(flip runSession) (serve matrixParamApi mpServer) $ do
response1 <- Network.Wai.Test.request defaultRequest{
pathInfo = ["a;name=bob"]
}
liftIO $ do
decode' (simpleBody response1) `shouldBe` Just alice{
name = "bob"
}
it "allows to retrieve lists in matrix parameters" $
(flip runSession) (serve matrixParamApi mpServer) $ do
response2 <- Network.Wai.Test.request defaultRequest{
pathInfo = ["b;names=bob;names=john", "bsub;names=anna;names=sarah"]
}
liftIO $
decode' (simpleBody response2) `shouldBe` Just alice{
name = "john"
}
it "allows to retrieve value-less matrix parameters" $
(flip runSession) (serve matrixParamApi mpServer) $ do
response3 <- Network.Wai.Test.request defaultRequest{
pathInfo = ["c;capitalize"]
}
liftIO $
decode' (simpleBody response3) `shouldBe` Just alice{
name = "ALICE"
}
response3' <- Network.Wai.Test.request defaultRequest{
pathInfo = ["c;capitalize="]
}
liftIO $
decode' (simpleBody response3') `shouldBe` Just alice{
name = "ALICE"
}
it "allows to retrieve matrix parameters on captured segments" $
(flip runSession) (serve matrixParamApi mpServer) $ do
response4 <- Network.Wai.Test.request defaultRequest{
pathInfo = ["d", "12;name=stephen;capitalize", "dsub"]
}
liftIO $
decode' (simpleBody response4) `shouldBe` Just alice{
name = "STEPHEN",
age = 12
}
response4' <- Network.Wai.Test.request defaultRequest{
pathInfo = ["d;ignored=1", "5", "dsub"]
}
liftIO $
decode' (simpleBody response4') `shouldBe` Just alice{
name = "Alice",
age = 5
}
type PostApi =
2015-01-13 20:40:41 +01:00
ReqBody '[JSON] Person :> Post '[JSON] Integer
:<|> "bla" :> ReqBody '[JSON] Person :> Post '[JSON] Integer
2014-12-10 16:10:57 +01:00
postApi :: Proxy PostApi
postApi = Proxy
postSpec :: Spec
postSpec = do
describe "Servant.API.Post and .ReqBody" $ do
with (return (serve postApi (return . age :<|> return . age))) $ do
2015-01-13 20:40:41 +01:00
let post' x = Test.Hspec.Wai.request methodPost x [(hContentType
2015-01-13 22:40:41 +01:00
, "application/json;charset=utf-8")]
2015-01-13 20:40:41 +01:00
2014-12-10 16:10:57 +01:00
it "allows to POST a Person" $ do
2015-01-13 20:40:41 +01:00
post' "/" (encode alice) `shouldRespondWith` "42"{
2014-12-10 16:10:57 +01:00
matchStatus = 201
}
it "allows alternative routes if all have request bodies" $ do
2015-01-13 20:40:41 +01:00
post' "/bla" (encode alice) `shouldRespondWith` "42"{
matchStatus = 201
}
it "handles trailing '/' gracefully" $ do
2015-01-13 20:40:41 +01:00
post' "/bla/" (encode alice) `shouldRespondWith` "42"{
matchStatus = 201
}
2014-12-10 16:10:57 +01:00
it "correctly rejects invalid request bodies with status 400" $ do
2015-01-13 20:40:41 +01:00
post' "/" "some invalid body" `shouldRespondWith` 400
2014-12-10 16:10:57 +01:00
it "responds with 415 if the requested media type is unsupported" $ do
let post'' x = Test.Hspec.Wai.request methodPost x [(hContentType
, "application/nonsense")]
post'' "/" "anything at all" `shouldRespondWith` 415
2015-02-24 14:48:17 +01:00
type HeaderApi a = Header "MyHeader" a :> Delete
headerApi :: Proxy (HeaderApi a)
headerApi = Proxy
headerSpec :: Spec
headerSpec = describe "Servant.API.Header" $ do
let expectsInt :: Maybe Int -> EitherT (Int,String) IO ()
expectsInt (Just x) = when (x /= 5) $ error "Expected 5"
expectsInt Nothing = error "Expected an int"
let expectsString :: Maybe String -> EitherT (Int,String) IO ()
expectsString (Just x) = when (x /= "more from you") $ error "Expected more from you"
expectsString Nothing = error "Expected a string"
with (return (serve headerApi expectsInt)) $ do
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"5")]
it "passes the header to the handler (Int)" $
delete' "/" "" `shouldRespondWith` 204
with (return (serve headerApi expectsString)) $ do
let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader" ,"more from you")]
it "passes the header to the handler (String)" $
delete' "/" "" `shouldRespondWith` 204
2014-12-10 16:10:57 +01:00
type RawApi = "foo" :> Raw
rawApi :: Proxy RawApi
rawApi = Proxy
rawApplication :: Show a => (Request -> a) -> Application
2015-01-06 17:26:37 +01:00
rawApplication f request_ respond = respond $ responseLBS ok200 [] (cs $ show $ f request_)
2014-12-10 16:10:57 +01:00
rawSpec :: Spec
rawSpec = do
describe "Servant.API.Raw" $ do
it "runs applications" $ do
(flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do
response <- Network.Wai.Test.request defaultRequest{
pathInfo = ["foo"]
}
liftIO $ do
simpleBody response `shouldBe` "42"
it "gets the pathInfo modified" $ do
(flip runSession) (serve rawApi (rawApplication pathInfo)) $ do
response <- Network.Wai.Test.request defaultRequest{
pathInfo = ["foo", "bar"]
}
liftIO $ do
simpleBody response `shouldBe` cs (show ["bar" :: String])
type AlternativeApi =
2015-01-12 15:08:41 +01:00
"foo" :> Get '[JSON] Person
:<|> "bar" :> Get '[JSON] Animal
2014-12-10 16:10:57 +01:00
unionApi :: Proxy AlternativeApi
unionApi = Proxy
unionServer :: Server AlternativeApi
unionServer =
return alice
:<|> return jerry
unionSpec :: Spec
unionSpec = do
describe "Servant.API.Alternative" $ do
with (return $ serve unionApi unionServer) $ do
it "unions endpoints" $ do
response <- get "/foo"
liftIO $ do
decode' (simpleBody response) `shouldBe`
Just alice
2015-01-06 17:26:37 +01:00
response_ <- get "/bar"
2014-12-10 16:10:57 +01:00
liftIO $ do
2015-01-06 17:26:37 +01:00
decode' (simpleBody response_) `shouldBe`
2014-12-10 16:10:57 +01:00
Just jerry
-- | Test server error functionality.
errorsSpec :: Spec
errorsSpec = do
let he = HttpError status409 (Just "A custom error")
let ib = InvalidBody "The body is invalid"
let wm = WrongMethod
let nf = NotFound
2015-01-13 20:40:41 +01:00
describe "Servant.Server.Internal.RouteMismatch" $ do
it "HttpError > *" $ do
ib <> he `shouldBe` he
wm <> he `shouldBe` he
nf <> he `shouldBe` he
he <> ib `shouldBe` he
he <> wm `shouldBe` he
he <> nf `shouldBe` he
it "HE > InvalidBody > (WM,NF)" $ do
he <> ib `shouldBe` he
wm <> ib `shouldBe` ib
nf <> ib `shouldBe` ib
ib <> he `shouldBe` he
ib <> wm `shouldBe` ib
ib <> nf `shouldBe` ib
it "HE > IB > WrongMethod > NF" $ do
he <> wm `shouldBe` he
ib <> wm `shouldBe` ib
nf <> wm `shouldBe` wm
wm <> he `shouldBe` he
wm <> ib `shouldBe` ib
wm <> nf `shouldBe` wm
it "* > NotFound" $ do
he <> nf `shouldBe` he
ib <> nf `shouldBe` ib
wm <> nf `shouldBe` wm
nf <> he `shouldBe` he
nf <> ib `shouldBe` ib
nf <> wm `shouldBe` wm