haxl-2.4.0.0: tests/ExceptionStackTests.hs

-- Copyright (c) 2014-present, Facebook, Inc.
-- All rights reserved.
--
-- This source code is distributed under the terms of a BSD license,
-- found in the LICENSE file.

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

module ExceptionStackTests (tests) where

import Prelude ()
import Haxl.Core
import Haxl.Prelude

import Test.HUnit

import qualified ExampleDataSource

testEnv :: ReportFlags -> IO (Env () ())
testEnv report = do
  exstate <- ExampleDataSource.initGlobalState
  let st = stateSet exstate stateEmpty
  env <- initEnv st ()
  return env{ flags = (flags env){ report = report } }

reportFlags :: ReportFlags
reportFlags = setReportFlag ReportExceptionLabelStack defaultReportFlags

runHaxlTest
  :: ReportFlags
  -> String
  -> (Int -> Int -> GenHaxl () () Int)
  -> IO (Maybe [Text])
runHaxlTest report str func = do
  env <- testEnv report
  result <- runHaxl env $
    withLabel "try" $ tryToHaxlException $ withLabel "test" $ do
      x <- withLabel "dummy" $ pure 1
      y <- withLabel "fetch" $ ExampleDataSource.countAardvarks str
      withLabel "func" $ func x y
  case result of
    Left (HaxlException stk _) -> return stk
    Right{} -> assertFailure "expected: HaxlException"

fetchException :: Test
fetchException = TestCase $ do
  result <- runHaxlTest reportFlags "BANG4" $ \i j -> return $ i + j
  assertEqual "stack" (Just ["fetch", "test", "try", "MAIN"]) result

userException :: Test
userException = TestCase $ do
  result <- runHaxlTest reportFlags "aaa" $ \_ _ -> withLabel "throw" $
    throw $ InvalidParameter "throw"
  assertEqual "stack" (Just ["throw", "func", "test", "try", "MAIN"]) result

#ifndef PROFILING
disabledExceptionStack :: Test
disabledExceptionStack = TestCase $ do
  result <- runHaxlTest defaultReportFlags "BANG4" $ \i j -> return $ i + j
  assertEqual "stack" Nothing result
#endif

tests :: Test
tests = TestList
  [ TestLabel "FetchException" fetchException
  , TestLabel "UserException" userException
#ifndef PROFILING
  , TestLabel "DisabledExceptionStack"  disabledExceptionStack
#endif
  ]