servant-snap-0.8.4: test/Servant/ServerSpec.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Servant.ServerSpec where
-------------------------------------------------------------------------------
import Control.Lens (makeLenses)
import Control.Monad (forM_, unless,
void, when)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as A
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as BL
import Data.CaseInsensitive (mk)
import Data.Char (toUpper)
import Data.Functor ((<$>))
import Data.List (foldl')
import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.Proxy (Proxy (Proxy))
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import GHC.Generics (Generic)
import Network.HTTP.Types (hAccept,
hContentType)
import qualified Network.HTTP.Types
import Snap.Core hiding (Headers,
addHeader)
import qualified Snap.Core as SC
import Snap.Snaplet
import qualified Snap.Snaplet.Test as SST
import qualified Snap.Test as ST
import qualified Snap.Util.CORS as CORS
-------------------------------------------------------------------------------
import Servant.API ((:<|>) (..), (:>),
BasicAuth,
Capture,
CaptureAll,
Header (..),
Headers,
IsSecure (..),
JSON,
NoContent (..),
NoFraming,
OctetStream,
PlainText,
QueryFlag,
QueryParam,
QueryParams, Raw,
RemoteHost,
ReqBody, SourceIO,
Stream, addHeader)
import Servant.API.Verbs (Delete, Get,
Patch, Post, Put,
Verb)
import qualified Servant.API.Verbs as V
import Servant.Server hiding (route)
import Servant.Server.Internal (HasServer)
import Servant.Server.Internal.BasicAuth
import Servant.Server.Internal.Context
import qualified Servant.Types.SourceT as S
import Servant.Utils.SnapTestUtils
import Snap.Snaplet.Auth
import Snap.Snaplet.Auth.Backends.JsonFile
import Snap.Snaplet.Session
import Snap.Snaplet.Session.Backends.CookieSession
import qualified Snap.Util.CORS as CORS
import Test.Hspec
import Test.Hspec.Snap hiding (NotFound)
import qualified Test.Hspec.Snap as THS
import qualified Test.HUnit as HU
-- * Specs
spec :: Spec
spec = do
verbSpec
captureSpec
captureAllSpec
queryParamSpec
reqBodySpec
headerSpec
rawSpec
alternativeSpec
responseHeadersSpec
miscCombinatorSpec
fallthroughSpec
basicAuthSpec
------------------------------------------------------------------------------
-- * verbSpec {{{
------------------------------------------------------------------------------
type VerbApi method status
= Verb method status '[JSON] Person
:<|> "noContent" :> Verb method status '[JSON] NoContent
:<|> "header" :> Verb method status '[JSON] (Headers '[Header "H" Int] Person)
:<|> "headerNC" :> Verb method status '[JSON] (Headers '[Header "H" Int] NoContent)
:<|> "accept" :> ( Verb method status '[JSON] Person
:<|> Verb method status '[PlainText] String
)
:<|> "stream" :> Stream method status NoFraming OctetStream (SourceIO B8.ByteString)
verbSpec :: Spec
verbSpec = do
let server :: Server (VerbApi method status) '[] AppHandler
server = return alice
:<|> return NoContent
:<|> return (addHeader 5 alice)
:<|> return (addHeader 10 NoContent)
:<|> (return alice :<|> return "B")
:<|> return (S.source ["bytestring"])
get200 = Proxy :: Proxy (VerbApi 'V.GET 200)
post210 = Proxy :: Proxy (VerbApi 'V.POST 210)
put203 = Proxy :: Proxy (VerbApi 'V.PUT 203)
delete280 = Proxy :: Proxy (VerbApi 'V.DELETE 280)
patch214 = Proxy :: Proxy (VerbApi 'V.PATCH 214)
wrongMethod m = if m == SC.PUT then SC.POST else SC.PUT
test (desc :: String) api verbRoutes (method :: SC.Method) (status :: Int) =
describe ("Servant.API.Verb " ++ desc) $ do
-- This group is run with hspec-snap
snap (route verbRoutes) app $ do
-- HEAD should not return body
when (method == SC.HEAD) $
it "HEAD returns no content body" $ do
response <- runRequest $ mkRequest method "/" "" [] ""
liftIO $ bodyIs response "" `shouldBe` True
it "throws 405 on wrong method " $ do
response <- runRequest $ mkRequest (wrongMethod method) "/" "" [] ""
liftIO $ statusIs response 405 `shouldBe` True
it "handles trailing '/' gracefully" $ do
response <- runRequest $ mkRequest method "/headerNC/" "" [] ""
liftIO $ statusIs response status `shouldBe` True
it "returns 406 if the Accept header is not supported" $ do
response <- runRequest $ mkRequest method "" ""
[(hAccept, "crazy/mime")] ""
liftIO $ statusIs response 406 `shouldBe` True
it "responds if the Accept header is supported" $ do
response <- runRequest $ mkRequest method "" ""
[(hAccept, "application/json;charset=utf-8")] ""
liftIO $ statusIs response status `shouldBe` True
let sInit = app' verbRoutes
runUrl p = testSnaplet sInit (mkRequest method p "" [] "")
-- runUrl p = SST.runHandler Nothing
-- (mkRequest method p "" [] "")
-- (serveSnap api server) sInit
-- This group is run with hspec directly
-- HEAD and 214/215 need not return bodies
unless (status `elem` [214, 215] || method == SC.HEAD) $
it "returns the person" $ do
resp <- runUrl "/"
resp `shouldDecodeTo` alice
resp `shouldHaveStatus` status
it "returns no content on NoContent" $ do
resp <- runUrl "/noContent"
resp `shouldHaveStatus` status
resp `shouldHaveBody` ""
it "returs headers" $ do
resp <- SST.runHandler Nothing
(mkRequest method "/header" "" [] "")
(serveSnap api server) sInit
shouldHaveHeaders resp [("H","5")]
-- TODO: Why doesn't this test pass?
it "returs CORS headers" $ do
resp <- testSnaplet sInit (mkRequest method "/noContent" "" [("Origin", "http://example.com")] "")
shouldHaveHeaders resp [("access-control-allow-origin"
,"http://example.com")]
it "sets the content-type header" $ do
resp <- SST.runHandler Nothing (mkRequest method "" "" [] "")
(serveSnap api server) sInit
resp `shouldHaveHeaders` [("Content-Type", "application/json;charset=utf-8")]
unless (status `elem` [214, 215] || method == SC.HEAD) $
it "allows modular specification of supported content types" $ do
resp <- SST.runHandler Nothing
(mkRequest method "/accept" ""
[(hAccept, "text/plain")] "")
(serveSnap api server) sInit
resp `shouldHaveStatus` status
resp `shouldHaveBody` "B"
unless (method == SC.HEAD) $ it "works for Stream as for Result" $ do
resp <- SST.runHandler Nothing
(mkRequest method "/stream" "" [] "")
(serveSnap api server) sInit
resp `shouldHaveStatus` status
resp `shouldHaveBody` "bytestring"
test "GET 200" get200 (routes get200 EmptyContext server) SC.GET 200
test "POST 210" post210 (routes post210 EmptyContext server) SC.POST 210
test "PUT 203" put203 (routes put203 EmptyContext server) SC.PUT 203
test "DELETE 280" delete280 (routes delete280 EmptyContext server) SC.DELETE 280
test "PATCH 214" patch214 (routes patch214 EmptyContext server) SC.PATCH 214
test "GET 200 with HEAD" get200 (routes get200 EmptyContext server) SC.HEAD 200
-- }}}
------------------------------------------------------------------------------
-- * captureSpec {{{
------------------------------------------------------------------------------
type CaptureApi = Capture "legs" Integer :> Get '[JSON] Animal
captureApi :: Proxy CaptureApi
captureApi = Proxy
captureServer :: Integer -> AppHandler Animal
captureServer legs = case legs of
4 -> return jerry
2 -> return tweety
_ -> throwError err404
type CaptureApi2 = Capture "captured" String :> Raw
captureApi2 :: Proxy CaptureApi2
captureApi2 = Proxy
captureServer2 :: Server CaptureApi2 '[] AppHandler
captureServer2 _ = do
rq <- getRequest
writeBS (SC.rqPathInfo rq)
captureSpec :: Spec
captureSpec = do -- snap (route (routes captureApi captureServer)) app $
let ( sInit , _ ) = mkInitAndServer captureApi EmptyContext captureServer
( sInit2, _ ) = mkInitAndServer captureApi2 EmptyContext captureServer2
runReq r method api serv i =
SST.runHandler Nothing (mkRequest method r "" [] "")
(serveSnap api serv) i
describe "Servant.API.Capture" $ do
it "can capture parts of the 'pathInfo'" $ do
runReq "/2" SC.GET captureApi captureServer sInit >>=
(`shouldDecodeTo` tweety)
it "returns 400 if the decoding fails" $ do
runReq "/notAnInt" SC.GET captureApi captureServer sInit >>=
(`shouldHaveStatus` 400)
it "strips the captured path snippet from pathInfo" $ do
runReq "/captured/foo" SC.GET captureApi2 captureServer2 sInit2 >>=
(`shouldHaveBody` "foo")
-- }}}
------------------------------------------------------------------------------
-- * captureAllSpec {{{
------------------------------------------------------------------------------
type CaptureAllApi = CaptureAll "legs" Integer :> Get '[JSON] Animal
captureAllApi :: Proxy CaptureAllApi
captureAllApi = Proxy
captureAllServer :: [Integer] -> AppHandler Animal
captureAllServer legs = case sum legs of
4 -> return jerry
2 -> return tweety
0 -> return beholder
_ -> throwError err404
captureAllSpec :: Spec
captureAllSpec = do
describe "Servant.API.CaptureAll" $ do
let runUrl u = runReqOnApi captureAllApi EmptyContext captureAllServer SC.GET u "" [] ""
it "can capture a single element of the 'pathInfo'" $ do
runUrl "/2" >>= (`shouldDecodeTo` tweety)
-- liftIO $ decodesTo response tweety `shouldBe` True
it "can capture multiple elements of the 'pathInfo'" $ do
runUrl "/2/2" >>= (`shouldDecodeTo` jerry)
-- liftIO $ decodesTo response jerry `shouldBe` True
it "can capture arbitrarily many elements of the 'pathInfo'" $ do
runUrl "/1/1/0/1/0/1" >>= (`shouldDecodeTo` jerry)
-- liftIO $ decodesTo response jerry `shouldBe` True
it "can capture when there are no elements in 'pathInfo'" $ do
runUrl "/" >>= (`shouldDecodeTo` beholder)
-- liftIO $ decodesTo response jerry `shouldBe` True
it "returns 400 if the decoding fails" $ do
runUrl "/notAnInt" >>= (`shouldHaveStatus` 400)
-- liftIO $ statusIs response 400 `shouldBe` True
it "returns 400 if the decoding fails, regardless of which element" $ do
runUrl "/1/0/0/notAnInt/3/" >>= (`shouldHaveStatus` 400)
-- liftIO $ statusIs response 400 `shouldBe` True
it "returns 400 if the decoding fails, even when it's multiple elements" $ do
runUrl "/1/0/0/notAnInt/3/orange/" >>= (`shouldHaveStatus` 400)
-- liftIO $ statusIs response 400 `shouldBe` True
it "consumes everything from pathInfo" $ do
let api' = (Proxy :: Proxy (CaptureAll "segments" String :> Raw))
srv' = (\_ -> getRequest >>= writeBS . rqPathInfo)
req <- runReqOnApi api' EmptyContext srv' SC.GET "/captured/foo/bar/baz" "" [] ""
req `shouldHaveBody` ""
-- (\ _captured request_ respond ->
-- respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
-- get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))
-- }}}
------------------------------------------------------------------------------
-- * queryParamSpec {{{
------------------------------------------------------------------------------
type QueryParamApi = QueryParam "name" String :> Get '[JSON] Person
:<|> "a" :> QueryParams "names" String :> Get '[JSON] Person
:<|> "b" :> QueryFlag "capitalize" :> Get '[JSON] Person
queryParamApi :: Proxy QueryParamApi
queryParamApi = Proxy
qpServer :: Server QueryParamApi '[] AppHandler
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) }
queryParamServer (Just name_) = return alice{name = name_}
queryParamServer Nothing = return alice
queryParamSpec :: Spec
queryParamSpec = do
describe "Servant.API.QueryParam" $ do
let runTest :: B8.ByteString -> B8.ByteString -> IO (Either T.Text Response)
runTest p qs = runReqOnApi queryParamApi EmptyContext qpServer SC.GET p qs [(hContentType,"application/json;charset=utf-8")] ""
it "allows retrieving simple GET parameters" $
runTest "" "?name=bob" >>= (`shouldDecodeTo` alice {name="bob"})
{-
(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 retrieving lists in GET parameters" $
runTest "a" "?names[]=bob&names[]=john" >>= (`shouldDecodeTo` alice{name="john"})
{-
(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"
}
-}
it "allows retrieving value-less GET parameters" $ do
runTest "b" "?capitalize" >>= (`shouldDecodeTo` alice{name="ALICE"})
{-
(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="
runTest "b" "?capitalize=" >>= (`shouldDecodeTo` alice{name="ALICE"})
{-
response3' <- Network.Wai.Test.request defaultRequest{
rawQueryString = params3',
queryString = parseQuery params3',
pathInfo = ["b"]
}
liftIO $
decode' (simpleBody response3') `shouldBe` Just alice{
name = "ALICE"
}
-}
-- let params3'' = "?unknown="
runTest "b" "?unknown=" >>= (`shouldDecodeTo` alice{name="Alice"})
{-
response3'' <- Network.Wai.Test.request defaultRequest{
rawQueryString = params3'',
queryString = parseQuery params3'',
pathInfo = ["b"]
}
liftIO $
decode' (simpleBody response3'') `shouldBe` Just alice{
name = "Alice"
}
-}
-- }}}
------------------------------------------------------------------------------
-- * reqBodySpec {{{
------------------------------------------------------------------------------
type ReqBodyApi = ReqBody '[JSON] Person :> Post '[JSON] Person
:<|> "blah" :> ReqBody '[JSON] Person :> Put '[JSON] Integer
reqBodyApi :: Proxy ReqBodyApi
reqBodyApi = Proxy
reqBodySpec :: Spec
reqBodySpec = do
describe "Servant.API.ReqBody" $ do
let runTest m p ct bod = runReqOnApi reqBodyApi EmptyContext server m p "" [(hContentType,ct)] bod
goodCT = "application/json;charset=utf-8"
-- "application/json"
badCT = "application/nonsense"
it "passes the argument to the handler" $ do
-- response <- mkReq post "" (encode alice)
runTest SC.POST "" goodCT (BL.toStrict $ A.encode alice) >>=
(`shouldDecodeTo` alice)
-- liftIO $ decodesTo response alice `shouldBe` True
it "rejects invalid request bodies with status 400" $ do
-- runReqOnApi reqBodyApi server SC.PUT "/blah"
runTest SC.PUT "/blah" goodCT "some invalid body" >>= (`shouldHaveStatus` 400)
-- mkReq methodPut "/blah" "some invalid body" `shouldRespondWith` 400
it "responds with 415 if the request body media type is unsupported" $ do
runTest SC.POST "/" badCT ""
>>= (`shouldHaveStatus` 415)
-- post "/"
-- [(hContentType, "application/nonsense")] "" `shouldRespondWith` 415
where server :: Server ReqBodyApi '[] AppHandler
server = return :<|> return . age
-- mkReq handler method x = mkRequest x
-- [(hContentType, "application/json;charset=utf-8")] ""
-- }}}
------------------------------------------------------------------------------
-- * headerSpec {{{
------------------------------------------------------------------------------
type HeaderApi a = Header "MyHeader" a :> Delete '[JSON] NoContent
headerApi :: Proxy (HeaderApi a)
headerApi = Proxy
headerSpec :: Spec
headerSpec = describe "Servant.API.Header" $ do
let expectsInt :: Maybe Int -> AppHandler NoContent
expectsInt (Just x) = do
when (x /= 5) $ error "Expected 5"
return NoContent
expectsInt Nothing = error "Expected an int"
let expectsString :: Maybe String -> AppHandler NoContent
expectsString (Just x) = do
when (x /= "more from you") $ error "Expected more from you"
return NoContent
expectsString Nothing = error "Expected a string"
--with (return (serve headerApi expectsInt)) $ do
-- let delete' x = delete x [("MyHeader", "5")]
-- TODO: Fix this
-- it "passes the header to the handler (Int)" $ do
-- runReqOnApi headerApi EmptyContext expectsInt SC.DELETE "/" "" [("MyHeader","5")] "" >>= (`shouldHaveStatus` 200)
-- --delete' "/" "" `shouldRespondWith` 200
-- with (return (serve headerApi expectsString)) $ do
-- let delete' x = delete x [("MyHeader", "more from you")]
-- TODO: Fix this
-- it "passes the header to the handler (String)" $ do
-- runReqOnApi headerApi EmptyContext expectsString SC.DELETE "/" "" [("MyHeader","more from you")] "" >>= (`shouldHaveStatus` 200)
-- -- delete' "/" "" `shouldRespondWith` 200
return ()
-- }}}
------------------------------------------------------------------------------
-- * rawSpec {{{
------------------------------------------------------------------------------
type RawApi = "foo" :> Raw
rawApi :: Proxy RawApi
rawApi = Proxy
rawServer :: Show a => (Request -> a) -> AppHandler ()
rawServer f = do
(writeBS . B8.pack . show . f) =<< getRequest
rawSpec :: Spec
rawSpec = do
describe "Servant.API.Raw" $ do
it "runs applications" $ do
runReqOnApi rawApi EmptyContext (rawServer (const (42 :: Integer))) SC.GET "foo" "" [] "" >>= (`shouldHaveBody` "42")
{-
(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
runReqOnApi rawApi EmptyContext (rawServer rqPathInfo) SC.GET "foo/bar" "" [] "" >>=
(`shouldHaveBody` (T.pack (show ("bar" :: B8.ByteString))))
{-
(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])
-}
-- }}}
------------------------------------------------------------------------------
-- * alternativeSpec {{{
------------------------------------------------------------------------------
type AlternativeApi =
"foo" :> Get '[JSON] Person
:<|> "bar" :> Get '[JSON] Animal
:<|> "foo" :> Get '[PlainText] T.Text
:<|> "bar" :> Post '[JSON] Animal
:<|> "bar" :> Put '[JSON] Animal
:<|> "bar" :> Delete '[JSON] NoContent
alternativeApi :: Proxy AlternativeApi
alternativeApi = Proxy
alternativeServer :: Server AlternativeApi '[] AppHandler
alternativeServer =
return alice
:<|> return jerry
:<|> return "a string"
:<|> return jerry
:<|> return jerry
:<|> return NoContent
alternativeSpec :: Spec
alternativeSpec = do
describe "Servant.API.Alternative" $ do
it "unions endpoints" $ do
-- response <- get "/foo"
response <- runReqOnApi alternativeApi EmptyContext alternativeServer SC.GET "/foo" "" [] ""
response `shouldDecodeTo` alice
-- liftIO $ do
-- decodesTo response alice `shouldBe` True
-- response_ <- get "/bar"
response_ <- runReqOnApi alternativeApi EmptyContext alternativeServer SC.GET "/bar" "" [] ""
response_ `shouldDecodeTo` jerry
-- liftIO $ do
-- decodesTo response_ jerry `shouldBe`
-- True
it "checks all endpoints before returning 415" $ do
-- response <- get "/foo"
response <- runReqOnApi alternativeApi EmptyContext alternativeServer SC.GET "/foo" "" [] ""
response `shouldHaveStatus` 200
-- liftIO $ statusIs response 200 `shouldBe` True
it "returns 404 if the path does not exist" $ do
-- response <- get "/nonexistent"
response <- runReqOnApi alternativeApi EmptyContext alternativeServer SC.GET "/nonexistent" "" [] ""
response `shouldHaveStatus` 404
-- liftIO $ statusIs response 404 `shouldBe` True
-- }}}
------------------------------------------------------------------------------
-- * responseHeaderSpec {{{
------------------------------------------------------------------------------
type ResponseHeadersApi =
Get '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
:<|> Post '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
:<|> Put '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
:<|> Patch '[JSON] (Headers '[Header "H1" Int, Header "H2" String] String)
responseHeadersApi :: Proxy ResponseHeadersApi
responseHeadersApi = Proxy
responseHeadersServer :: Server ResponseHeadersApi '[] AppHandler
responseHeadersServer = let h = return $ addHeader 5 $ addHeader "kilroy" "hi"
in h :<|> h :<|> h :<|> h
responseHeadersSpec :: Spec
responseHeadersSpec = describe "ResponseHeaders" $ do
let methods = [SC.GET, SC.POST, SC.PUT, SC.PATCH]
it "includes the headers in the response" $
forM_ methods $ \method -> do
req <- runReqOnApi responseHeadersApi EmptyContext responseHeadersServer method "/" "" [] ""
req `shouldHaveStatus` 200
req `shouldHaveHeaders` [("H1","5"),("H2","kilroy")]
{-
method "/" [] ""
`shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"]
, matchStatus = 200
}
-}
it "responds with not found for non-existent endpoints" $
forM_ methods $ \method ->
runReqOnApi responseHeadersApi EmptyContext responseHeadersServer method "blahblah" "" [] "" >>= (`shouldHaveStatus` 404)
-- method "blahblah" [] ""
-- `shouldRespondWith` 404
it "returns 406 if the Accept header is not supported" $
forM_ methods $ \method ->
runReqOnApi responseHeadersApi EmptyContext responseHeadersServer method "" "" [(hAccept, "crazy/mime")] "" >>= (`shouldHaveStatus` 406)
-- method "" [(hAccept, "crazy/mime")] ""
-- `shouldRespondWith` 406
-- }}}
------------------------------------------------------------------------------
-- * miscCombinatorSpec {{{
------------------------------------------------------------------------------
type MiscCombinatorsAPI
= "version" :> HttpVersion :> Get '[JSON] HttpVersion
:<|> "secure" :> IsSecure :> Get '[JSON] String
:<|> "host" :> RemoteHost :> Get '[PlainText] String
miscApi :: Proxy MiscCombinatorsAPI
miscApi = Proxy
miscServ :: Server MiscCombinatorsAPI '[] AppHandler
miscServ = versionHandler
:<|> secureHandler
:<|> hostHandler
where versionHandler = return :: HttpVersion -> AppHandler HttpVersion
secureHandler :: IsSecure -> AppHandler String
secureHandler Secure = return "secure"
secureHandler NotSecure = return "not secure"
hostHandler = return . B8.unpack :: B8.ByteString -> AppHandler String
miscCombinatorSpec :: Spec
miscCombinatorSpec = do
describe "Misc. combinators for request inspection" $ do
it "Successfully gets the HTTP version specified in the request" $
go "/version" (T.decodeUtf8 . BL.toStrict $
A.encode ((1,1) :: HttpVersion))
it "Checks that hspec-wai uses HTTP, not HTTPS" $
go "/secure" "\"not secure\""
it "Checks that hspec-wai issues request from 0.0.0.0" $
go "/host" "localhost"
where go path res = do
runReqOnApi miscApi EmptyContext miscServ SC.GET path "" [] "" >>=
(`shouldHaveBody` res)
-- }}}
type FFApi1 = "1" :> Get '[JSON] Int
p1 = Proxy :: Proxy FFApi1
ffServe1 = return 1
type FFApi2 = "2" :> Get '[JSON] Int
p2 = Proxy :: Proxy FFApi2
ffServe2 = return 2
fallthroughSpec :: Spec
fallthroughSpec = do
describe "Allow multiple servant apis in the same snap router" $ do
let rts = [("", serveSnap p1 ffServe1)
,("", serveSnap p2 ffServe2)
]
sInit = makeSnaplet "servantsnap" "test" Nothing $ do
addRoutes rts
return App
expectRoute r b =
SST.runHandler Nothing (mkRequest GET r "" [] "") (route rts) sInit
>>= b
it "Successfully matches" $ expectRoute "1" (`shouldHaveBody` "1")
it "Successfully falls through" $ expectRoute "2" (`shouldHaveBody` "2")
it "404s when expected" $ expectRoute "3" (`shouldHaveStatus` 404)
------------------------------------------------------------------------------
-- * BasicAuthCombinatorSpec {{{
------------------------------------------------------------------------------
type BasicAuthAPI = "secret" :> BasicAuth "realm" () :> Get '[JSON] Int
baApi :: Proxy BasicAuthAPI
baApi = Proxy
baServ :: Server BasicAuthAPI '[BasicAuthCheck AppHandler ()] AppHandler
baServ () = return 1337
basicAuthSpec :: Spec
basicAuthSpec = do
let baCheck :: BasicAuthCheck AppHandler ()
baCheck = BasicAuthCheck $ \_ -> return (Authorized ())
getSecret :: () -> AppHandler Int
getSecret () = return 1337
authHeader un pw = "Basic " <> B64.encode (T.encodeUtf8 un <> ":" <> pw)
describe "Checks auth" $ do
it "returns 401 when not logged in" $ do
response <- runReqOnApi baApi (baCheck :. EmptyContext) getSecret SC.GET "/secret" "" [] ""
response `shouldHaveStatus` 401
it "returns 200 when logged in" $ do
response <- runReqOnApi baApi (baCheck :. EmptyContext) getSecret SC.GET "/secret" ""
[("Authorization", authHeader testLogin testPassword)] ""
response `shouldHaveBody` "1337"
-- }}}
------------------------------------------------------------------------------
-- * 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
beholder :: Animal
beholder = Animal "Beholder" 0
-- }}}
------------------------------------------------------------------------------
-- * hspec-snap helpers
------------------------------------------------------------------------------
getStatus :: TestResponse -> Maybe Int
getStatus (Html (RespCode s) _) = Just s
getStatus (Json (RespCode s) _) = Just s
getStatus THS.NotFound = Nothing
getStatus (Redirect (RespCode s) _) = Just s
getStatus (Other (RespCode s)) = Just s
getStatus Empty = Nothing
statusIs :: TestResponse -> Int -> Bool
statusIs r s = getStatus r == Just s
decodesTo :: (FromJSON a, Eq a) => TestResponse -> a -> Bool
decodesTo (Json _ bs) a = A.decode' bs == Just a
decodesTo _ _ = False
bodyIs :: TestResponse -> TL.Text -> Bool
bodyIs (Html _ t) target = t == TL.toStrict target
bodyIs (Json _ b) target = b == TL.encodeUtf8 target
bodyIs _ _ = False