servant-snap-0.8.3.2: test/Servant/ServerSpec.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# 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.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.Lazy as TL
import qualified Data.Text.Encoding as T
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.CORS
import Snap.Snaplet
import qualified Snap.Snaplet.Test as SST
import qualified Snap.Test as ST
-------------------------------------------------------------------------------
import Test.Hspec
import Test.Hspec.Snap hiding (NotFound)
import qualified Test.Hspec.Snap as THS
import qualified Test.HUnit as HU
import Servant.API ((:<|>) (..), (:>),
addHeader, BasicAuth, Capture,
CaptureAll, Header (..), Headers,
IsSecure(..), JSON, NoContent(..),
PlainText, QueryFlag, QueryParam,
QueryParams, Raw, RemoteHost,
ReqBody)
import Servant.API.Verbs (Verb, Get, Post, Put, Delete,
Patch)
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 Snap.Snaplet.Auth
import Snap.Snaplet.Auth.Backends.JsonFile
import qualified Snap.Util.CORS as CORS
import Snap.Snaplet.Session
import Snap.Snaplet.Session.Backends.CookieSession
-------------------------------------------------------------------------------
-- * test data types
data App = App { _auth :: Snaplet (AuthManager App)
, _sess :: Snaplet SessionManager}
makeLenses 'App
type AppHandler = Handler App App
app :: SnapletInit App App
app = app' []
app' :: [(B8.ByteString, AppHandler ())] -> SnapletInit App App
app' rs = makeSnaplet "servantsnap" "A test app for servant-snap" Nothing $ do
s <- nestSnaplet "sess" sess $
initCookieSessionManager "site_key.txt" "sess" Nothing (Just 3600)
a <- nestSnaplet "auth" auth $ initJsonFileAuthManager defAuthSettings sess "users.json"
addRoutes rs
wrapSite (\h -> createTestUserIfMissing >> CORS.applyCORS CORS.defaultOptions h)
return (App a s)
createTestUserIfMissing :: Handler App App ()
createTestUserIfMissing =
with auth $ usernameExists testLogin >>= \case
True -> return ()
False -> void $ createUser testLogin testPassword
testLogin = "greg"
testPassword = "p@ssword"
-------------------------------------------------------------------------------
-- * 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
)
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")
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 = 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")]
it "returs CORS headers" $ do
(_, snapm, _) <- runSnaplet Nothing sInit
resp <- fmap Right $ ST.runHandler (mkRequest method "/noContent" "" [("Origin", "http://example.com")] "") snapm
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"
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
------------------------------------------------------------------------------
-- * hspec helpers
------------------------------------------------------------------------------
shouldHaveBody :: Either T.Text Response -> T.Text -> IO ()
shouldHaveBody (Left e) _ = HU.assertFailure $
"Failed to respond: " ++ T.unpack e
shouldHaveBody (Right r) a = do
bod <- ST.getResponseBody r
bod `shouldBe` T.encodeUtf8 a
shouldHaveStatus :: Either T.Text Response -> Int -> IO ()
shouldHaveStatus (Left e) _ = HU.assertFailure $
"Failed to respond: " ++ T.unpack e
shouldHaveStatus (Right r) a = do
SC.rspStatus r `shouldBe` a
shouldDecodeTo :: (FromJSON a, Eq a, Show a)
=> Either T.Text Response
-> a
-> IO ()
shouldDecodeTo (Left e) _ = HU.assertFailure $
"Failed to respond: " ++ T.unpack e
shouldDecodeTo (Right resp) a = do
bod <- ST.getResponseBody resp
case A.decode' $ BL.fromStrict bod of
Just x | x == a -> return ()
Just _ -> HU.assertFailure $
"Failed to decode response to " ++ show a ++
" from body: " ++ B8.unpack bod
Nothing -> HU.assertFailure $ "Failed to decode respone from body: " ++
B8.unpack bod ++ "\nResponse: " ++ show resp
shouldHaveHeaders :: Either T.Text Response
-> [(B8.ByteString, B8.ByteString)]
-> Expectation
shouldHaveHeaders (Left e) _ = expectationFailure $ T.unpack e
shouldHaveHeaders (Right resp) hs = do
let respHs = Set.fromList $ SC.listHeaders resp
hs' = Set.fromList $ (\(k,v) -> (mk k,v)) <$> hs
missing = Set.toList $ Set.difference hs' respHs
case missing of
[] -> return ()
_ -> expectationFailure $
"These expected headers and values were missing: " ++ show missing ++
" from the response's: " ++ show (Set.toList respHs)
------------------------------------------------------------------------------
-- * Assorted Snap helpers
------------------------------------------------------------------------------
mkInitAndServer :: (HasServer api context m, m ~ AppHandler)
=> Proxy (api :: *)
-> Context context
-> Server api context AppHandler
-> (SnapletInit App App, AppHandler ())
mkInitAndServer api ctx serv =
let sRoute = serveSnapWithContext api ctx serv
in (app' [("", sRoute)], sRoute)
mkRequest :: Method
-> B8.ByteString
-> B8.ByteString
-> [Network.HTTP.Types.Header]
-> B8.ByteString
-> ST.RequestBuilder IO ()
mkRequest mth pth qs hds bdy = do
let ct = fromMaybe "" (Prelude.lookup hContentType hds)
ST.postRaw pth ct bdy
ST.setQueryStringRaw qs
unless (mth == SC.POST) $ ST.setRequestType (ST.RequestWithRawBody mth bdy)
forM_ hds (\(k, v) -> unless (k == hContentType) $ ST.addHeader k v)
-- req <- State.get -- Useful for debugging
-- liftIO $ print req
runReqOnApi :: (HasServer api context m, m ~ AppHandler)
=> Proxy (api :: *)
-> Context context
-> Server api context AppHandler
-> Method
-> B8.ByteString
-> B8.ByteString
-> [Network.HTTP.Types.Header]
-> B8.ByteString
-> IO (Either T.Text Response)
runReqOnApi api ctx serv method route qs hds bod =
let (sInit, serv') = mkInitAndServer api ctx serv
in SST.runHandler Nothing (mkRequest method route qs hds bod) serv' sInit
routes :: (HasServer api context m, m ~ AppHandler)
=> Proxy (api :: *)
-> Context context
-> Server api context AppHandler
-> [(B8.ByteString, AppHandler ())]
routes p ctx s = [("", serveSnapWithContext p ctx s)]