{-# LANGUAGE DataKinds #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main where
import Control.Exception (Exception, SomeException, catch)
import Data.Proxy (Proxy(Proxy))
import Data.Type.Equality ((:~:)(Refl))
import Data.Typeable (Typeable)
import Network.HTTP.Types (status404)
import Network.Wai (Application)
import Servant
( (:<|>)((:<|>))
, (:>)
, Capture
, Get
, Handler
, JSON
, ServerT
, serve
)
import Test.Hspec (describe, it)
import Test.Hspec.Wai
( ResponseMatcher(matchStatus)
, get
, shouldRespondWith
, with
)
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.Hspec (testSpec)
import Test.Tasty.HUnit ((@?=), assertFailure, testCase)
import Servant.Checked.Exceptions
( Envelope
, ErrStatus(toErrStatus)
, NoThrow
, Status
, Throws
, pureErrEnvelope
, pureSuccEnvelope
)
main :: IO ()
main = do
tests <- testsIO
defaultMain tests
testsIO :: IO TestTree
testsIO = do
serverTests <- serverTestsIO
pure $
testGroup
"tests"
[ hasServerInstanceTests
, serverTests
]
-------------
-- Helpers --
-------------
type Selector e = e -> Bool
anyException :: Selector SomeException
anyException _ = True
-- | Extra HUnit assertion to make sure an expression throws an exception.
assertThrows
:: forall e a.
(Exception e, Typeable e)
=> IO a -> Selector e -> IO ()
assertThrows ioAction selector = do
didCatch <- catch (ioAction *> pure False) (pure . selector)
case didCatch of
False ->
assertFailure "expecting an exception, but no exception occurred"
True -> pure ()
-- | Infix version of 'assertThrows'.
(@!)
:: (Exception e, Typeable e)
=> IO a -> Selector e -> IO ()
(@!) = assertThrows
infix 1 @!
------------------------------
-- HasServer instance tests --
------------------------------
type ApiThrows = Throws String :> Get '[JSON] Int
checkApiThrows :: ServerT ApiThrows m :~: m (Envelope '[String] Int)
checkApiThrows = Refl
type ApiDoubleThrows = Throws String :> Throws Double :> Get '[JSON] Int
checkApiDoubleThrows
:: ServerT ApiDoubleThrows m :~: m (Envelope '[String, Double] Int)
checkApiDoubleThrows = Refl
type ApiThrowsBeforeCapture =
Throws String :> Capture "foobar" Double :> Get '[JSON] Int
checkApiThrowsBeforeCapture
:: ServerT ApiThrowsBeforeCapture m :~: (Double -> m (Envelope '[String] Int))
checkApiThrowsBeforeCapture = Refl
type ApiThrowsBeforeMulti =
Throws String :> (Get '[JSON] Int :<|> Get '[JSON] Double)
checkApiThrowsBeforeMulti
:: ServerT ApiThrowsBeforeMulti m :~:
(m (Envelope '[String] Int) :<|> m (Envelope '[String] Double))
checkApiThrowsBeforeMulti = Refl
type ApiNoThrow = NoThrow :> Get '[JSON] Int
checkApiNoThrows :: ServerT ApiNoThrow m :~: m (Envelope '[] Int)
checkApiNoThrows = Refl
type ApiNoThrowBeforeCapture =
NoThrow :> Capture "foobar" Double :> Get '[JSON] Int
checkApiNoThrowBeforeCapture
:: ServerT ApiNoThrowBeforeCapture m :~: (Double -> m (Envelope '[] Int))
checkApiNoThrowBeforeCapture = Refl
type ApiNoThrowBeforeMulti =
NoThrow :> (Get '[JSON] Int :<|> Get '[JSON] Double)
checkApiNoThrowBeforeMulti
:: ServerT ApiNoThrowBeforeMulti m :~:
(m (Envelope '[] Int) :<|> m (Envelope '[] Double))
checkApiNoThrowBeforeMulti = Refl
hasServerInstanceTests :: TestTree
hasServerInstanceTests =
testGroup
"HasServer instances"
[ testCase "single Throws" $ checkApiThrows @?= Refl
, testCase "double Throws" $ checkApiDoubleThrows @?= Refl
, testCase "Throws before Capture" $ checkApiThrowsBeforeCapture @?= Refl
, testCase "Throws before (:<|>)" $ checkApiThrowsBeforeMulti @?= Refl
, testCase "single NoThrows" $ checkApiNoThrows @?= Refl
, testCase "NoThrow before Capture" $ checkApiNoThrowBeforeCapture @?= Refl
, testCase "NoThrow before (:<|>)" $ checkApiNoThrowBeforeMulti @?= Refl
]
------------------
-- Server tests --
------------------
instance ErrStatus Int where
toErrStatus :: Int -> Status
toErrStatus _ = status404
type TestThrows = "throws" :> Capture "foobar" Double :> Throws Int :> Get '[JSON] String
type TestNoThrow = "nothrow" :> NoThrow :> Get '[JSON] String
type TestApi = TestThrows :<|> TestNoThrow
server :: ServerT TestApi Handler
server = testThrowsGet :<|> testNoThrowsGet
testThrowsGet :: Double -> Handler (Envelope '[Int] String)
testThrowsGet double =
if double < 0
then pureErrEnvelope (0 :: Int)
else pureSuccEnvelope "successThrows"
testNoThrowsGet :: Handler (Envelope '[] String)
testNoThrowsGet = pureSuccEnvelope "successNoThrow"
app :: Application
app = serve (Proxy :: Proxy TestApi) server
serverTestsIO :: IO TestTree
serverTestsIO =
testSpec "server" $
with (pure app) $ do
describe "Throws" $ do
it "handler can return error envelope" $
get "/throws/-5" `shouldRespondWith` "{\"err\":0}" { matchStatus = 404 }
it "handler can return success envelope" $
get "/throws/10" `shouldRespondWith` "{\"data\":\"successThrows\"}"
describe "NoThrow" $ do
it "handler can return success envelope" $
get "/nothrow" `shouldRespondWith` "{\"data\":\"successNoThrow\"}"