module Test.Sandwich.Shutdown where

import Control.Concurrent.Async
import Control.Concurrent.STM
import Data.Time
import Test.Sandwich.Types.RunTree
import Test.Sandwich.Types.Spec


cancelNode :: RunNode context -> IO ()
cancelNode :: forall context. RunNode context -> IO ()
cancelNode RunNode context
node = TVar Status -> IO Status
forall a. TVar a -> IO a
readTVarIO (RunNodeCommonWithStatus
  (TVar Status) (Var (Seq LogEntry)) (Var Bool)
-> TVar Status
forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeStatus (RunNodeCommonWithStatus
   (TVar Status) (Var (Seq LogEntry)) (Var Bool)
 -> TVar Status)
-> RunNodeCommonWithStatus
     (TVar Status) (Var (Seq LogEntry)) (Var Bool)
-> TVar Status
forall a b. (a -> b) -> a -> b
$ RunNode context
-> RunNodeCommonWithStatus
     (TVar Status) (Var (Seq LogEntry)) (Var Bool)
forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon RunNode context
node) IO Status -> (Status -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Running {Maybe UTCTime
UTCTime
Async Result
statusStartTime :: UTCTime
statusSetupFinishTime :: Maybe UTCTime
statusTeardownStartTime :: Maybe UTCTime
statusAsync :: Async Result
statusStartTime :: Status -> UTCTime
statusSetupFinishTime :: Status -> Maybe UTCTime
statusTeardownStartTime :: Status -> Maybe UTCTime
statusAsync :: Status -> Async Result
..} -> Async Result -> IO ()
forall a. Async a -> IO ()
cancel Async Result
statusAsync
  Status
NotStarted -> do
    UTCTime
now <- IO UTCTime
getCurrentTime
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Status -> Status -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (RunNodeCommonWithStatus
  (TVar Status) (Var (Seq LogEntry)) (Var Bool)
-> TVar Status
forall s l t. RunNodeCommonWithStatus s l t -> s
runTreeStatus (RunNodeCommonWithStatus
   (TVar Status) (Var (Seq LogEntry)) (Var Bool)
 -> TVar Status)
-> RunNodeCommonWithStatus
     (TVar Status) (Var (Seq LogEntry)) (Var Bool)
-> TVar Status
forall a b. (a -> b) -> a -> b
$ RunNode context
-> RunNodeCommonWithStatus
     (TVar Status) (Var (Seq LogEntry)) (Var Bool)
forall s l t context.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon RunNode context
node) (UTCTime
-> Maybe UTCTime -> Maybe UTCTime -> UTCTime -> Result -> Status
Done UTCTime
now Maybe UTCTime
forall a. Maybe a
Nothing Maybe UTCTime
forall a. Maybe a
Nothing UTCTime
now Result
Cancelled)
  Done {} -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()