content: {-# 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\"}"
  