{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}

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 :: 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 context s l t.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon RunNode context
node) IO Status -> (Status -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Running {UTCTime
Async Result
statusAsync :: Status -> Async Result
statusStartTime :: Status -> UTCTime
statusAsync :: Async Result
statusStartTime :: UTCTime
..} -> 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 context s l t.
RunNodeWithStatus context s l t -> RunNodeCommonWithStatus s l t
runNodeCommon RunNode context
node) (UTCTime -> UTCTime -> Result -> Status
Done UTCTime
now UTCTime
now Result
Cancelled)
  Done {} -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()