{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
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.Wai (Application)
import Servant ((:<|>), (:>), Capture, Get, Handler, JSON, ServerT, serve)
import Test.Hspec.Wai (get, shouldRespondWith, with)
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.Hspec (testSpec, it)
import Test.Tasty.HUnit ((@?=), assertFailure, testCase)
import Servant.Checked.Exceptions
(Envelope, 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
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
]
------------------
-- Server tests --
------------------
type TestApi = Capture "foobar" Double :> Throws Int :> Get '[JSON] String
server :: ServerT TestApi Handler
server = helloWorldGet
helloWorldGet :: Double -> Handler (Envelope '[Int] String)
helloWorldGet double =
if double < 0
then pureErrEnvelope (0 :: Int)
else pureSuccEnvelope "success"
app :: Application
app = serve (Proxy :: Proxy TestApi) server
serverTestsIO :: IO TestTree
serverTestsIO =
testSpec "server" $
with (pure app) $ do
it "handler can return error envelope" $
get "/-5" `shouldRespondWith` "{\"err\":0}"
it "handler can return success envelope" $
get "/10" `shouldRespondWith` "{\"data\":\"success\"}"