sandwich-0.1.0.4: test/Introduce.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module Introduce where


import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception.Safe
import Control.Monad.IO.Class
import Control.Monad.Trans.Writer
import Data.Foldable
import GHC.Stack
import Test.Sandwich
import Test.Sandwich.Internal

import TestUtil

tests :: MonadIO m => WriterT [SomeException] m ()
tests = do
  run introduceCleansUpOnTestException
  run introduceDoesNotCleanUpOnAllocateException
  run introduceFailsOnCleanUpException
  run introduceCleansUpOnCancelDuringTest

main = mainWith tests

-- * Tests

introduceCleansUpOnTestException :: (HasCallStack) => IO ()
introduceCleansUpOnTestException = do
  (results, msgs) <- runAndGetResultsAndLogs $ introduce "introduce" fakeDatabaseLabel (return FakeDatabase) (\_ -> debug "doing cleanup") $ do
    it "does thing 1" $ throwSomeUserError

  msgs `mustBe` [["doing cleanup"], []]
  results `mustBe` [Success
                   , Failure (GotException Nothing Nothing someUserErrorWrapped)]

introduceDoesNotCleanUpOnAllocateException :: (HasCallStack) => IO ()
introduceDoesNotCleanUpOnAllocateException = do
  (results, msgs) <- runAndGetResultsAndLogs $ introduce "introduce" fakeDatabaseLabel (throwSomeUserError >> return FakeDatabase) (\_ -> debug "doing cleanup") $ do
    it "does thing 1" $ return ()

  msgs `mustBe` [[], []]
  results `mustBe` [Failure (GotException Nothing (Just "Failure in introduce 'introduce' allocation handler") someUserErrorWrapped)
                   , Failure (GetContextException Nothing (SomeExceptionWithEq (SomeException (GotException Nothing (Just "Failure in introduce 'introduce' allocation handler") someUserErrorWrapped))))]

introduceFailsOnCleanUpException :: (HasCallStack) => IO ()
introduceFailsOnCleanUpException = do
  (results, msgs) <- runAndGetResultsAndLogs $ introduce "introduce" fakeDatabaseLabel (return FakeDatabase) (\_ -> throwSomeUserError) $ do
    it "does thing 1" $ return ()

  msgs `mustBe` [[], []]
  results `mustBe` [Failure (GotException Nothing (Just "Failure in introduce 'introduce' cleanup handler") someUserErrorWrapped)
                   , Success]

introduceCleansUpOnCancelDuringTest :: (HasCallStack) => IO ()
introduceCleansUpOnCancelDuringTest = do
  mvar <- newEmptyMVar

  rts <- startSandwichTree defaultOptions $ introduce "introduce" fakeDatabaseLabel (return FakeDatabase) (\_ -> debug "doing cleanup") $ do
    it "does thing 1" $ do
      liftIO $ putMVar mvar ()
      liftIO $ threadDelay 999999999999999

  let [topNode@(RunNodeIntroduce {runNodeChildrenAugmented=[RunNodeIt {}]})] = rts

  -- Wait until we get into the actual test example, then cancel the top level async
  takeMVar mvar
  cancelNode topNode

  -- Waiting for the tree should not throw an exception
  _ <- mapM waitForTree rts

  fixedTree <- atomically $ mapM fixRunTree rts
  let results = fmap statusToResult $ concatMap getStatuses fixedTree
  let msgs = fmap (toList . (fmap logEntryStr)) $ concatMap getLogs fixedTree

  msgs `mustBe` [["doing cleanup"], []]
  results `mustBe` [Failure (GotAsyncException Nothing Nothing (SomeAsyncExceptionWithEq $ SomeAsyncException AsyncCancelled))
                   , Failure (GotAsyncException Nothing Nothing (SomeAsyncExceptionWithEq $ SomeAsyncException AsyncCancelled))]