Hooks.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RecordWildCards #-}
-- | Stability: provisional
module Test.Hspec.Core.Hooks (
-- * Types
  Spec
, SpecWith
, ActionWith
-- * Hooks
, before
, before_
, beforeWith
, beforeAll
, beforeAll_
, beforeAllWith
, after
, after_
, afterAll
, afterAll_
, around
, around_
, aroundWith
, aroundAll
, aroundAll_
, aroundAllWith

, mapSubject
, ignoreSubject

#ifdef TEST
, decompose
#endif
) where

import           Prelude ()
import           Test.Hspec.Core.Compat

import           Control.Concurrent

import           Test.Hspec.Core.Example
import           Test.Hspec.Core.Tree
import           Test.Hspec.Core.Spec.Monad

-- | Run a custom action before every spec item.
before :: IO a -> SpecWith a -> Spec
before action = around (action >>=)

-- | Run a custom action before every spec item.
before_ :: IO () -> SpecWith a -> SpecWith a
before_ action = around_ (action >>)

-- | Run a custom action before every spec item.
beforeWith :: (b -> IO a) -> SpecWith a -> SpecWith b
beforeWith action = aroundWith $ \e x -> action x >>= e

-- | Run a custom action before the first spec item.
beforeAll :: HasCallStack => IO a -> SpecWith a -> Spec
beforeAll action spec = do
  mvar <- runIO (newMVar Empty)
  before (memoize mvar action) spec

-- | Run a custom action before the first spec item.
beforeAll_ :: HasCallStack => IO () -> SpecWith a -> SpecWith a
beforeAll_ action spec = do
  mvar <- runIO (newMVar Empty)
  before_ (memoize mvar action) spec

-- | Run a custom action with an argument before the first spec item.
beforeAllWith :: HasCallStack => (b -> IO a) -> SpecWith a -> SpecWith b
beforeAllWith action spec = do
  mvar <- runIO (newMVar Empty)
  beforeWith (memoize mvar . action) spec

data Memoized a =
    Empty
  | Memoized a
  | Failed SomeException

memoize :: HasCallStack => MVar (Memoized a) -> IO a -> IO a
memoize mvar action = do
  result <- modifyMVar mvar $ \ma -> case ma of
    Empty -> do
      a <- try action
      return (either Failed Memoized a, a)
    Memoized a -> return (ma, Right a)
    Failed _ -> throwIO (Pending Nothing (Just $ "exception in " <> maybe "beforeAll" fst callSite <> "-hook (see previous failure)"))
  either throwIO return result

-- | Run a custom action after every spec item.
after :: ActionWith a -> SpecWith a -> SpecWith a
after action = aroundWith $ \e x -> e x `finally` action x

-- | Run a custom action after every spec item.
after_ :: IO () -> SpecWith a -> SpecWith a
after_ action = after $ \_ -> action

-- | Run a custom action before and/or after every spec item, supplying it with
-- an argument obtained via IO.
--
-- This is useful for tasks like creating a file handle or similar resource
-- before a test and destroying it after the test.
around
  :: (ActionWith a -> IO ())
  -- ^ Function provided with an action to run the spec item as argument. It
  -- should return the action to actually execute the item.
  -> SpecWith a
  -- ^ Spec to modify
  -> Spec
around action = aroundWith $ \e () -> action e

-- | Run a custom action after the last spec item.
afterAll :: HasCallStack => ActionWith a -> SpecWith a -> SpecWith a
afterAll action = aroundAllWith (\ hook a -> hook a >> action a)

-- | Run a custom action after the last spec item.
afterAll_ :: HasCallStack => IO () -> SpecWith a -> SpecWith a
afterAll_ action = mapSpecForest (return . NodeWithCleanup callSite action)

-- | Run a custom action before and/or after every spec item.
around_ :: (IO () -> IO ()) -> SpecWith a -> SpecWith a
around_ action = aroundWith $ \e a -> action (e a)

-- | Run a custom action before and/or after every spec item.
aroundWith :: (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b
aroundWith = mapSpecItem_ . modifyHook

modifyHook :: (ActionWith a -> ActionWith b) -> Item a -> Item b
modifyHook action Item{..} = Item {
    itemExample = \ params hook -> itemExample params (hook . action)
  , ..
  }

-- | Wrap an action around the given spec.
aroundAll :: HasCallStack => (ActionWith a -> IO ()) -> SpecWith a -> Spec
aroundAll action = aroundAllWith $ \ e () -> action e

-- | Wrap an action around the given spec.
aroundAll_ :: HasCallStack => (IO () -> IO ()) -> SpecWith a -> SpecWith a
aroundAll_ action spec = do
  (acquire, release) <- runIO $ decompose (action .)
  beforeAll_ (acquire ()) $ afterAll_ release spec

-- | Wrap an action around the given spec. Changes the arg type inside.
aroundAllWith :: forall a b. HasCallStack => (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b
aroundAllWith action spec = do
  (acquire, release) <- runIO $ decompose action
  beforeAllWith acquire $ afterAll_ release spec

data Acquired a = Acquired a | ExceptionDuringAcquire SomeException
data Released   = Released   | ExceptionDuringRelease SomeException

decompose :: forall a b. ((a -> IO ()) -> b -> IO ()) -> IO (b -> IO a, IO ())
decompose action = do
  doCleanupNow <- newEmptyMVar
  acquired <- newEmptyMVar
  released <- newEmptyMVar

  let
    notify :: Either SomeException () -> IO ()
    -- `notify` is guaranteed to run without being interrupted by an async
    -- exception for the following reasons:
    --
    -- 1. `forkFinally` runs the final action within `mask`
    -- 2. `tryPutMVar` is guaranteed not to be interruptible
    -- 3. `putMVar` is guaranteed not to be interruptible on an empty `MVar`
    notify r = case r of
      Left err -> do
        exceptionDuringAcquire <- tryPutMVar acquired (ExceptionDuringAcquire err)
        putMVar released $ if exceptionDuringAcquire then Released else ExceptionDuringRelease err
      Right () -> do
        putMVar released Released

    forkWorker :: b -> IO ()
    forkWorker b = void . flip forkFinally notify $ do
      flip action b $ \ a -> do
        putMVar acquired (Acquired a)
        waitFor doCleanupNow

    acquire :: b -> IO a
    acquire b = do
      forkWorker b
      r <- readMVar acquired -- This does not work reliably with base < 4.7
      case r of
        Acquired a -> return a
        ExceptionDuringAcquire err -> throwIO err

    release :: IO ()
    release = do
      acquireHasNotBeenCalled <- isEmptyMVar acquired -- NOTE: This can happen if an outer beforeAll fails
      unless acquireHasNotBeenCalled $ do
        signal doCleanupNow
        r <- takeMVar released
        case r of
          Released -> pass
          ExceptionDuringRelease err -> throwIO err

  return (acquire, release)

type BinarySemaphore = MVar ()

signal :: BinarySemaphore -> IO ()
signal = flip putMVar ()

waitFor :: BinarySemaphore -> IO ()
waitFor = takeMVar

-- | Modify the subject under test.
--
-- Note that this resembles a contravariant functor on the first type parameter
-- of `SpecM`.  This is because the subject is passed inwards, as an argument
-- to the spec item.
mapSubject :: (b -> a) -> SpecWith a -> SpecWith b
mapSubject f = aroundWith (. f)

-- | Ignore the subject under test for a given spec.
ignoreSubject :: SpecWith () -> SpecWith a
ignoreSubject = mapSubject (const ())