diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,21 +1,30 @@ # Changelog for sandwich -## Unreleased +## 0.3.0.4 +* Improve display of setup/work/teardown in TUI. +* Ultimately use sigKILL in Sandwich.Util.Process.gracefullyWaitForProcess if sigINT and sigTERM don't work. +* Exit with failure status when tests fail (#103). +* More work on test timing around setup/teardown. +* Decided not to do test timing on introduceWith for now since it can mess up timing frame nesting. +* Generate separate test timer profiles when a parallel node runs. +* Get rid of `haskell-src-exts` usage and mark getSpecWarnOnParseError as deprecated. +* Add gracefullyStopProcess', gracefullyWaitForProcess'. + ## 0.3.0.3 -* Add 'ContainerOptions' type to `Test.Sandwich.Contexts.Container` -* Improve display of setup/work/teardown in TUI +* Add 'ContainerOptions' type to `Test.Sandwich.Contexts.Container`. +* Improve display of setup/work/teardown in TUI. ## 0.3.0.2 -* Re-fix compatibility for base < 4.14.0.0 -* windows: fix Infinity -> maxBound for an Int +* Re-fix compatibility for base < 4.14.0.0. +* windows: fix Infinity -> maxBound for an Int. ## 0.3.0.1 -* Fix openFileExplorerFolderPortable on macOS -* Fix compatibility for base < 4.14.0.0 +* Fix openFileExplorerFolderPortable on macOS. +* Fix compatibility for base < 4.14.0.0. ## 0.3.0.0 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Tom McLaughlin (c) 2024 +Copyright Tom McLaughlin (c) 2025 All rights reserved. diff --git a/sandwich.cabal b/sandwich.cabal --- a/sandwich.cabal +++ b/sandwich.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0. +-- This file has been generated from package.yaml by hpack version 0.38.0. -- -- see: https://github.com/sol/hpack name: sandwich -version: 0.3.0.3 +version: 0.3.0.4 synopsis: Yet another test framework for Haskell description: Please see the . category: Testing @@ -13,7 +13,7 @@ bug-reports: https://github.com/codedownio/sandwich/issues author: Tom McLaughlin maintainer: tom@codedown.io -copyright: 2024 Tom McLaughlin +copyright: 2025 Tom McLaughlin license: BSD3 license-file: LICENSE build-type: Simple @@ -86,7 +86,6 @@ Test.Sandwich.Shutdown Test.Sandwich.Signals Test.Sandwich.TestTimer - Test.Sandwich.TH.HasMainFunction Test.Sandwich.TH.ModuleMap Test.Sandwich.Types.ArgParsing Test.Sandwich.Types.General @@ -124,7 +123,6 @@ , exceptions , filepath , free - , haskell-src-exts , microlens , microlens-th , monad-control @@ -187,7 +185,6 @@ , exceptions , filepath , free - , haskell-src-exts , microlens , microlens-th , monad-control @@ -248,7 +245,6 @@ , exceptions , filepath , free - , haskell-src-exts , microlens , microlens-th , monad-control @@ -314,7 +310,6 @@ , exceptions , filepath , free - , haskell-src-exts , microlens , microlens-th , monad-control @@ -381,7 +376,6 @@ , exceptions , filepath , free - , haskell-src-exts , microlens , microlens-th , monad-control diff --git a/src/Test/Sandwich.hs b/src/Test/Sandwich.hs --- a/src/Test/Sandwich.hs +++ b/src/Test/Sandwich.hs @@ -85,6 +85,7 @@ import Options.Applicative import qualified Options.Applicative as OA import System.Environment +import System.Exit import System.FilePath import Test.Sandwich.ArgParsing import Test.Sandwich.Contexts @@ -118,7 +119,9 @@ -- | Run the spec with the given 'Options'. runSandwich :: Options -> CoreSpec -> IO () -runSandwich options spec = void $ runSandwich' Nothing options spec +runSandwich options spec = do + (_exitReason, failures) <- runSandwich' Nothing options spec + when (0 < failures) $ exitFailure -- | Run the spec, configuring the options from the command line. runSandwichWithCommandLineArgs :: Options -> TopSpecWithOptions -> IO () @@ -198,9 +201,11 @@ -- Wrap the spec in a finalizer for the test timer, when one is present let spec = case baseContextTestTimer baseContext of NullTestTimer -> spec' - _ -> after' (defaultNodeOptions { nodeOptionsRecordTime = False - , nodeOptionsVisibilityThreshold = systemVisibilityThreshold - , nodeOptionsCreateFolder = False }) "Finalize test timer" (asks getTestTimer >>= liftIO . finalizeSpeedScopeTestTimer) spec' + _ -> after' (defaultNodeOptions { + nodeOptionsRecordTime = False + , nodeOptionsVisibilityThreshold = systemVisibilityThreshold + , nodeOptionsCreateFolder = False + }) "Finalize test timer" (asks getTestTimer >>= liftIO . finalizeSpeedScopeTestTimer) spec' rts <- startSandwichTree' baseContext options spec diff --git a/src/Test/Sandwich/ArgParsing.hs b/src/Test/Sandwich/ArgParsing.hs --- a/src/Test/Sandwich/ArgParsing.hs +++ b/src/Test/Sandwich/ArgParsing.hs @@ -129,6 +129,9 @@ commandLineWebdriverOptions :: (forall f a. Mod f a) -> Parser CommandLineWebdriverOptions commandLineWebdriverOptions maybeInternal = CommandLineWebdriverOptions <$> optional (browserToUse maybeInternal) + + <*> flag False True (long "chrome-no-sandbox" <> help "Pass the --no-sandbox flag to Chrome (useful in GitHub Actions when installing Chrome via Nix)" <> maybeInternal) + <*> optional (display maybeInternal) <*> flag False True (long "fluxbox" <> help "Launch fluxbox as window manager when using Xvfb" <> maybeInternal) <*> flag False True (long "individual-videos" <> help "Record individual videos of each test (requires ffmpeg and Xvfb)" <> maybeInternal) diff --git a/src/Test/Sandwich/Internal/Running.hs b/src/Test/Sandwich/Internal/Running.hs --- a/src/Test/Sandwich/Internal/Running.hs +++ b/src/Test/Sandwich/Internal/Running.hs @@ -161,7 +161,9 @@ where newShorthand = getShorthand taken x getShorthand :: [T.Text] -> NodeModuleInfo -> T.Text - getShorthand taken nmi = head $ filter (\x -> x `notElem` taken && x `notElem` takenMainOptions) $ getCandidates nmi + getShorthand taken nmi = case filter (\x -> x `notElem` taken && x `notElem` takenMainOptions) $ getCandidates nmi of + [] -> "unknown" + (x:_) -> x getCandidates :: NodeModuleInfo -> [T.Text] getCandidates (NodeModuleInfo {nodeModuleInfoModuleName=modName}) = candidates diff --git a/src/Test/Sandwich/Interpreters/StartTree.hs b/src/Test/Sandwich/Interpreters/StartTree.hs --- a/src/Test/Sandwich/Interpreters/StartTree.hs +++ b/src/Test/Sandwich/Interpreters/StartTree.hs @@ -12,6 +12,7 @@ import Control.Concurrent.MVar import Control.Monad import Control.Monad.IO.Class +import Control.Monad.IO.Unlift import Control.Monad.Logger import Control.Monad.Trans.Reader import Data.IORef @@ -52,7 +53,7 @@ let RunNodeCommonWithStatus {..} = runNodeCommon let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon runInAsync node ctx $ do - (timed (runExampleM runNodeBefore ctx runTreeLogs (Just [i|Exception in before '#{runTreeLabel}' handler|]))) >>= \case + (timed runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (setup)") (runExampleM runNodeBefore ctx runTreeLogs (Just [i|Exception in before '#{runTreeLabel}' handler|]))) >>= \case (result@(Failure fr@(Pending {})), _setupStartTime, setupFinishTime) -> do markAllChildrenWithResult runNodeChildren ctx (Failure fr) return (result, mkSetupTimingInfo setupFinishTime) @@ -74,7 +75,8 @@ result <- liftIO $ newIORef (Success, emptyExtraTimingInfo) finally (void $ runNodesSequentially runNodeChildren ctx) (do - (ret, teardownStartTime, _teardownFinishTime) <- timed (runExampleM runNodeAfter ctx runTreeLogs (Just [i|Exception in after '#{runTreeLabel}' handler|])) + (ret, teardownStartTime, _teardownFinishTime) <- timed runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (teardown)") $ + runExampleM runNodeAfter ctx runTreeLogs (Just [i|Exception in after '#{runTreeLabel}' handler|]) writeIORef result (ret, mkTeardownTimingInfo teardownStartTime) ) liftIO $ readIORef result @@ -86,13 +88,16 @@ bracket (do let asyncExceptionResult e = Failure $ GotAsyncException Nothing (Just [i|introduceWith #{runTreeLabel} alloc handler got async exception|]) (SomeAsyncExceptionWithEq e) flip withException (\(e :: SomeAsyncException) -> markAllChildrenWithResult runNodeChildrenAugmented ctx (asyncExceptionResult e)) $ - timed (runExampleM' runNodeAlloc ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' allocation handler|]))) + timed runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (setup)") $ + runExampleM' runNodeAlloc ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' allocation handler|]) + ) (\(ret, setupStartTime, setupFinishTime) -> case ret of Left failureReason -> writeIORef result (Failure failureReason, mkSetupTimingInfo setupStartTime) Right intro -> do teardownStartTime <- getCurrentTime addTeardownStartTimeToStatus runTreeStatus teardownStartTime - ret' <- runExampleM (runNodeCleanup intro) ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' cleanup handler|]) + (ret', _, _) <- timed runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (teardown)") $ + runExampleM (runNodeCleanup intro) ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' cleanup handler|]) writeIORef result (ret', ExtraTimingInfo (Just setupFinishTime) (Just teardownStartTime)) ) (\(ret, _setupStartTime, setupFinishTime) -> do @@ -125,24 +130,39 @@ _ -> Failure $ Reason Nothing [i|introduceWith '#{runTreeLabel}' handler threw exception|] flip withException (\e -> recordExceptionInStatus runTreeStatus e >> markAllChildrenWithResult runNodeChildrenAugmented ctx (failureResult e)) $ do beginningCleanupVar <- liftIO $ newIORef Nothing + + -- Record a start event in the test timing, if configured + -- TODO: how to do this? The speedscope viewer crashes if you don't properly nest events + -- let tt = if runTreeRecordTime then getTestTimer (getBaseContext ctx) else NullTestTimer + -- let setupLabel = runTreeLabel <> " (setup)" + -- let teardownLabel = runTreeLabel <> " (teardown)" + -- handleStartEvent tt (baseContextTestTimerProfile (getBaseContext ctx)) (T.pack setupLabel) + results <- runNodeIntroduceAction $ \intro -> do + -- Record the end event in the test timing + -- TODO: do we need to deal with exceptions here and in teardown? I think we we fail to emit the + -- end event, the time profile won't be viewable. + -- handleEndEvent tt (baseContextTestTimerProfile (getBaseContext ctx)) (T.pack setupLabel) setupFinishTime <- liftIO getCurrentTime addSetupFinishTimeToStatus runTreeStatus setupFinishTime - results <- liftIO $ runNodesSequentially runNodeChildrenAugmented ((LabelValue intro) :> ctx) + (results, _, _) <- timed runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (body)") $ + liftIO $ runNodesSequentially runNodeChildrenAugmented (LabelValue intro :> ctx) teardownStartTime <- liftIO getCurrentTime addTeardownStartTimeToStatus runTreeStatus teardownStartTime - liftIO $ writeIORef beginningCleanupVar (Just teardownStartTime) + liftIO $ writeIORef beginningCleanupVar (Just teardownStartTime) + -- handleStartEvent tt (baseContextTestTimerProfile (getBaseContext ctx)) (T.pack teardownLabel) liftIO $ writeIORef didRunWrappedAction (Right results, mkSetupTimingInfo setupFinishTime) return results liftIO (readIORef beginningCleanupVar) >>= \case Nothing -> return () - Just teardownStartTime -> - liftIO $ modifyIORef' didRunWrappedAction $ - \(ret, timingInfo) -> (ret, timingInfo { teardownStartTime = Just teardownStartTime }) + Just teardownStartTime -> do + -- handleEndEvent tt (baseContextTestTimerProfile (getBaseContext ctx)) (T.pack teardownLabel) + liftIO $ modifyIORef' didRunWrappedAction $ \(ret, timingInfo) -> + (ret, timingInfo { teardownStartTime = Just teardownStartTime }) return results @@ -184,7 +204,7 @@ startTree node@(RunNodeParallel {..}) ctx' = do let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon runInAsync node ctx $ do - ((L.length . L.filter isFailure) <$> runNodesConcurrently runNodeChildren ctx) >>= \case + ((L.length . L.filter isFailure) <$> runNodesConcurrently runNodeCommon runNodeChildren ctx) >>= \case 0 -> return (Success, emptyExtraTimingInfo) n -> return (Failure (ChildrenFailed Nothing n), emptyExtraTimingInfo) startTree node@(RunNodeIt {..}) ctx' = do @@ -198,9 +218,7 @@ runInAsync node ctx action = do let RunNodeCommonWithStatus {..} = runNodeCommon node let bc@(BaseContext {..}) = getBaseContext ctx - let timerFn = case runTreeRecordTime of - True -> timeAction' (getTestTimer bc) baseContextTestTimerProfile (T.pack runTreeLabel) - _ -> id + let timerFn = if runTreeRecordTime then timeAction' (getTestTimer bc) baseContextTestTimerProfile (T.pack runTreeLabel) else id startTime <- liftIO getCurrentTime mvar <- liftIO newEmptyMVar myAsync <- liftIO $ asyncWithUnmask $ \unmask -> do @@ -266,20 +284,33 @@ liftIO $ putMVar mvar () return myAsync -- TODO: fix race condition with writing to runTreeStatus (here and above) --- | Run a list of children sequentially, cancelling everything on async exception TODO +-- | Run a list of children sequentially, cancelling everything on async exception runNodesSequentially :: HasBaseContext context => [RunNode context] -> context -> IO [Result] runNodesSequentially children ctx = flip withException (\(e :: SomeAsyncException) -> cancelAllChildrenWith children e) $ forM (L.filter (shouldRunChild ctx) children) $ \child -> startTree child ctx >>= wait --- | Run a list of children sequentially, cancelling everything on async exception TODO -runNodesConcurrently :: HasBaseContext context => [RunNode context] -> context -> IO [Result] -runNodesConcurrently children ctx = +-- | Run a list of children concurrently, cancelling everything on async exception +runNodesConcurrently :: forall context. HasBaseContext context => RunNodeCommon -> [RunNode context] -> context -> IO [Result] +runNodesConcurrently (RunNodeCommonWithStatus {runTreeLabel, runTreeId}) children ctx = flip withException (\(e :: SomeAsyncException) -> cancelAllChildrenWith children e) $ - mapM wait =<< sequence [startTree child ctx - | child <- L.filter (shouldRunChild ctx) children] + mapM wait =<< sequence [startTree child (modifyTimingProfile ix ctx) + | (child, ix) <- L.zip runnableChildren [0..]] + where + runnableChildren = L.filter (shouldRunChild ctx) children + leftPadWithZeros :: Int -> String + leftPadWithZeros num = L.replicate (L.length (show (L.length runnableChildren)) - L.length (show num)) '0' <> show num + + modifyTimingProfile :: Int -> context -> context + modifyTimingProfile n = flip modifyBaseContext (modifyTimingProfile' n) + + modifyTimingProfile' :: Int -> BaseContext -> BaseContext + modifyTimingProfile' n bc@(BaseContext {..}) = bc { + baseContextTestTimerProfile = baseContextTestTimerProfile <> [i|-#{runTreeLabel}-#{runTreeId}-#{leftPadWithZeros n}|] + } + markAllChildrenWithResult :: (MonadIO m, HasBaseContext context') => [RunNode context] -> context' -> Result -> m () markAllChildrenWithResult children baseContext status = do now <- liftIO getCurrentTime @@ -372,9 +403,11 @@ Running {..} -> Done statusStartTime statusSetupFinishTime statusTeardownStartTime endTime ret _ -> Done endTime Nothing Nothing endTime ret -timed :: (MonadIO m) => m a -> m (a, UTCTime, UTCTime) -timed action = do +timed :: (MonadUnliftIO m) => Bool -> BaseContext -> String -> m a -> m (a, UTCTime, UTCTime) +timed recordTime bc@(BaseContext {..}) label action = do + let timerFn = if recordTime then timeAction' (getTestTimer bc) baseContextTestTimerProfile (T.pack label) else id + startTime <- liftIO getCurrentTime - ret <- action + ret <- timerFn action endTime <- liftIO getCurrentTime pure (ret, startTime, endTime) diff --git a/src/Test/Sandwich/ParallelN.hs b/src/Test/Sandwich/ParallelN.hs --- a/src/Test/Sandwich/ParallelN.hs +++ b/src/Test/Sandwich/ParallelN.hs @@ -31,7 +31,18 @@ import UnliftIO.Exception +-- * Types +parallelSemaphore :: Label "parallelSemaphore" QSem +parallelSemaphore = Label + +type HasParallelSemaphore context = HasLabel context "parallelSemaphore" QSem + +defaultParallelNodeOptions :: NodeOptions +defaultParallelNodeOptions = defaultNodeOptions { nodeOptionsVisibilityThreshold = 70 } + +-- * Functions + -- | Wrapper around 'parallel'. Introduces a semaphore to limit the parallelism to N threads. parallelN :: ( MonadUnliftIO m @@ -47,11 +58,7 @@ -> Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m () -parallelN' nodeOptions n children = introduce "Introduce parallel semaphore" parallelSemaphore (liftIO $ newQSem n) (const $ return ()) $ - parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children - where claimRunSlot f = do - s <- getContext parallelSemaphore - bracket_ (liftIO $ waitQSem s) (liftIO $ signalQSem s) (void f) +parallelN' nodeOptions n = parallelN'' nodeOptions (liftIO $ newQSem n) -- | Same as 'parallelN', but extracts the semaphore size from the command line options. parallelNFromArgs :: forall context a m. ( @@ -72,21 +79,20 @@ -> (CommandLineOptions a -> Int) -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m () -parallelNFromArgs' nodeOptions getParallelism children = introduce "Introduce parallel semaphore" parallelSemaphore getQSem (const $ return ()) $ - parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children +parallelNFromArgs' nodeOptions getParallelism = parallelN'' nodeOptions f where - getQSem = do - n <- getParallelism <$> getContext commandLineOptions - liftIO $ newQSem n + f = (getParallelism <$> getContext commandLineOptions) >>= liftIO . newQSem +parallelN'' :: ( + MonadUnliftIO m + ) + => NodeOptions + -> ExampleT context m QSem + -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () + -> SpecFree context m () +parallelN'' nodeOptions makeQSem children = introduce "Introduce parallel semaphore" parallelSemaphore makeQSem (const $ return ()) $ + parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children + where claimRunSlot f = do s <- getContext parallelSemaphore bracket_ (liftIO $ waitQSem s) (liftIO $ signalQSem s) (void f) - -parallelSemaphore :: Label "parallelSemaphore" QSem -parallelSemaphore = Label - -type HasParallelSemaphore context = HasLabel context "parallelSemaphore" QSem - -defaultParallelNodeOptions :: NodeOptions -defaultParallelNodeOptions = defaultNodeOptions { nodeOptionsVisibilityThreshold = 70 } diff --git a/src/Test/Sandwich/TH.hs b/src/Test/Sandwich/TH.hs --- a/src/Test/Sandwich/TH.hs +++ b/src/Test/Sandwich/TH.hs @@ -27,7 +27,6 @@ import Safe import System.Directory import System.FilePath as F -import Test.Sandwich.TH.HasMainFunction import Test.Sandwich.TH.ModuleMap import Test.Sandwich.Types.Spec hiding (location) @@ -41,6 +40,8 @@ , getSpecWarnOnParseError :: ShouldWarnOnParseError } +{-# DEPRECATED getSpecWarnOnParseError "Not used anymore." #-} + defaultGetSpecFromFolderOptions :: GetSpecFromFolderOptions defaultGetSpecFromFolderOptions = GetSpecFromFolderOptions { getSpecCombiner = 'describe @@ -48,6 +49,10 @@ , getSpecWarnOnParseError = WarnOnParseError } +{-# DEPRECATED ShouldWarnOnParseError "Not used anymore." #-} +data ShouldWarnOnParseError = WarnOnParseError | NoWarnOnParseError + deriving (Eq) + getSpecFromFolder :: GetSpecFromFolderOptions -> Q Exp getSpecFromFolder getSpecFromFolderOptions = do dir <- runIO getCurrentDirectory @@ -86,10 +91,7 @@ reportError [i|Couldn't find module #{fullyQualifiedModule} in #{reverseModuleMap}|] return Nothing Just importedName -> do - maybeMainFunction <- fileHasMainFunction (folder item) getSpecWarnOnParseError >>= \case - True -> [e|Just $(varE $ mkName $ importedName <> ".main")|] - False -> [e|Nothing|] - + maybeMainFunction <- getMaybeMainFunction importedName alterNodeOptionsFn <- [e|(\x -> x { nodeOptionsModuleInfo = Just ($(conE 'NodeModuleInfo) fullyQualifiedModule $(return maybeMainFunction)) })|] Just <$> [e|$(varE 'alterTopLevelNodeOptions) $(return alterNodeOptionsFn) @@ -103,14 +105,22 @@ & T.unpack maybeMainFunction <- case M.lookup currentModule reverseModuleMap of Nothing -> [e|Nothing|] - Just importedName -> fileHasMainFunction (folder <> ".hs") getSpecWarnOnParseError >>= \case - True -> [e|Just $(varE $ mkName $ importedName <> ".main")|] - False -> [e|Nothing|] + Just importedName -> getMaybeMainFunction importedName alterNodeOptionsFn <- [e|(\x -> x { nodeOptionsModuleInfo = Just ($(conE 'NodeModuleInfo) currentModule $(return maybeMainFunction)) })|] [e|$(varE 'alterTopLevelNodeOptions) $(return alterNodeOptionsFn) $ $(varE getSpecCombiner) $(stringE $ mangleFolderName folder) (L.foldl (>>) (pure ()) $(listE $ fmap return specs))|] -- * Util + +-- | Detect if a main function is present in the given module by trying to reify it, +-- using 'recover' to handle exceptions. +-- We could also look at the actual reified value to see if it looks like a function, +-- but that's probably overkill. +getMaybeMainFunction :: String -> Q Exp +getMaybeMainFunction importedName = do + let mainName = mkName (importedName <> ".main") + recover [e|Nothing|] + (reify mainName >> [e|Just $(varE mainName)|]) mangleFolderName :: String -> String mangleFolderName = T.unpack . wordify . T.pack . takeBaseName diff --git a/src/Test/Sandwich/TH/HasMainFunction.hs b/src/Test/Sandwich/TH/HasMainFunction.hs deleted file mode 100644 --- a/src/Test/Sandwich/TH/HasMainFunction.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TemplateHaskell #-} - -module Test.Sandwich.TH.HasMainFunction ( - fileHasMainFunction - , ShouldWarnOnParseError(..) - ) where - -import Control.Monad -import Data.String.Interpolate -import Language.Haskell.Exts hiding (name) -import Language.Haskell.TH (Q, runIO, reportWarning) - --- import Debug.Trace - - -data ShouldWarnOnParseError = WarnOnParseError | NoWarnOnParseError - deriving (Eq) - --- | Use haskell-src-exts to determine if a give Haskell file has an exported main function --- Parse with all extensions enabled, which will hopefully parse anything -fileHasMainFunction :: FilePath -> ShouldWarnOnParseError -> Q Bool -fileHasMainFunction path shouldWarnOnParseError = runIO (parseFileWithExts [x | x@(EnableExtension _) <- knownExtensions] path) >>= \case - x@(ParseFailed {}) -> do - when (shouldWarnOnParseError == WarnOnParseError) $ - reportWarning [i|Failed to parse #{path}: #{x}|] - return False - ParseOk (Module _ (Just moduleHead) _ _ decls) -> do - -- traceM [i|Sucessfully parsed #{path}: #{moduleHead}|] - case moduleHead of - ModuleHead _ _ _ (Just (ExportSpecList _ (any isMainFunction -> True))) -> do - -- traceM [i|FOUND MAIN FUNCTION FOR #{path}|] - return True - ModuleHead _ _ _ Nothing -> do - -- traceM [i|LOOKING FOR DECLS: #{decls}|] - return $ any isMainDecl decls - _ -> return False - ParseOk _ -> do - reportWarning [i|Successfully parsed #{path} but no module head found|] - return False - -isMainFunction :: ExportSpec l -> Bool -isMainFunction (EVar _ name) = isMainFunctionQName name -isMainFunction _ = False - -isMainFunctionQName :: QName l -> Bool -isMainFunctionQName (Qual _ _ name) = isMainFunctionName name -isMainFunctionQName (UnQual _ name) = isMainFunctionName name -isMainFunctionQName _ = False - -isMainFunctionName :: Name l -> Bool -isMainFunctionName (Ident _ "main") = True -isMainFunctionName (Symbol _ "main") = True -isMainFunctionName _ = False - -isMainDecl :: Decl l -> Bool -isMainDecl (PatBind _ (PVar _ (Ident _ "main")) _ _) = True --- isMainDecl decl = trace [i|Looking at decl: #{decl}|] False -isMainDecl _ = False diff --git a/src/Test/Sandwich/TestTimer.hs b/src/Test/Sandwich/TestTimer.hs --- a/src/Test/Sandwich/TestTimer.hs +++ b/src/Test/Sandwich/TestTimer.hs @@ -3,9 +3,21 @@ {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE TypeOperators #-} -module Test.Sandwich.TestTimer where +module Test.Sandwich.TestTimer ( + timeAction + , timeAction' + , timeActionByProfile -import Control.Concurrent + , handleStartEvent + , handleEndEvent + + , withTimingProfile + , withTimingProfile' + + , newSpeedScopeTestTimer + , finalizeSpeedScopeTestTimer + ) where + import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Reader @@ -17,6 +29,7 @@ import Data.String.Interpolate import qualified Data.Text as T import qualified Data.Text.IO as T +import Data.Time import Data.Time.Clock.POSIX import Lens.Micro import System.Directory @@ -26,6 +39,7 @@ import Test.Sandwich.Types.Spec import Test.Sandwich.Types.TestTimer import Test.Sandwich.Util (whenJust) +import UnliftIO.Concurrent import UnliftIO.Exception @@ -76,9 +90,11 @@ -- * Core timingNodeOptions :: NodeOptions -timingNodeOptions = defaultNodeOptions { nodeOptionsRecordTime = False - , nodeOptionsCreateFolder = False - , nodeOptionsVisibilityThreshold = systemVisibilityThreshold } +timingNodeOptions = defaultNodeOptions { + nodeOptionsRecordTime = False + , nodeOptionsCreateFolder = False + , nodeOptionsVisibilityThreshold = systemVisibilityThreshold + } newSpeedScopeTestTimer :: FilePath -> Bool -> IO TestTimer newSpeedScopeTestTimer path writeRawTimings = do @@ -103,38 +119,59 @@ timeAction' :: (MonadUnliftIO m) => TestTimer -> T.Text -> T.Text -> m a -> m a timeAction' NullTestTimer _ _ = id timeAction' (SpeedScopeTestTimer {..}) profileName eventName = bracket_ - (liftIO $ modifyMVar_ testTimerSpeedScopeFile $ \file -> do - now <- getPOSIXTime - handleStartEvent file now - ) - (liftIO $ modifyMVar_ testTimerSpeedScopeFile $ \file -> do - now <- getPOSIXTime - handleEndEvent file now - ) - where - handleStartEvent file time = do - whenJust testTimerHandle $ \h -> T.hPutStrLn h [i|#{time} START #{show profileName} #{eventName}|] - return $ handleSpeedScopeEvent file time SpeedScopeEventTypeOpen + (modifyMVar_ testTimerSpeedScopeFile $ \file -> liftIO getPOSIXTime >>= handleStartEvent' testTimerHandle profileName eventName file) + (modifyMVar_ testTimerSpeedScopeFile $ \file -> liftIO getPOSIXTime >>= handleEndEvent' testTimerHandle profileName eventName file) - handleEndEvent file time = do - whenJust testTimerHandle $ \h -> T.hPutStrLn h [i|#{time} END #{show profileName} #{eventName}|] - return $ handleSpeedScopeEvent file time SpeedScopeEventTypeClose +handleStartEvent :: (MonadUnliftIO m) => TestTimer -> T.Text -> T.Text -> m () +handleStartEvent NullTestTimer _profileName _eventName = return () +handleStartEvent (SpeedScopeTestTimer {..}) profileName eventName = + modifyMVar_ testTimerSpeedScopeFile $ \file -> + liftIO getPOSIXTime >>= handleStartEvent' testTimerHandle profileName eventName file - -- | TODO: maybe use an intermediate format so the frames (and possibly profiles) aren't stored as lists, - -- so we don't have to do O(N) L.length and S.findIndexL - handleSpeedScopeEvent :: SpeedScopeFile -> POSIXTime -> SpeedScopeEventType -> SpeedScopeFile - handleSpeedScopeEvent initialFile time eventType = flip execState initialFile $ do - frameID <- get >>= \f -> case S.findIndexL (== SpeedScopeFrame eventName) (f ^. shared . frames) of - Just j -> return j - Nothing -> do - modify' $ over (shared . frames) (S.|> (SpeedScopeFrame eventName)) - return $ S.length $ f ^. shared . frames +handleStartEvent' :: (MonadIO m) + => Maybe Handle + -> T.Text + -> T.Text + -> SpeedScopeFile + -> NominalDiffTime + -> m SpeedScopeFile +handleStartEvent' maybeHandle profileName eventName file time = do + whenJust maybeHandle $ \h -> liftIO $ T.hPutStrLn h [i|#{time} START #{show profileName} #{eventName}|] + return $ handleSpeedScopeEvent file time profileName eventName SpeedScopeEventTypeOpen - profileIndex <- get >>= \f -> case L.findIndex ((== profileName) . (^. name)) (f ^. profiles) of - Just j -> return j - Nothing -> do - modify' $ over profiles (\x -> x <> [newProfile profileName time]) - return $ L.length (f ^. profiles) +handleEndEvent :: (MonadUnliftIO m) => TestTimer -> T.Text -> T.Text -> m () +handleEndEvent NullTestTimer _profileName _eventName = return () +handleEndEvent (SpeedScopeTestTimer {..}) profileName eventName = + modifyMVar_ testTimerSpeedScopeFile $ \file -> + liftIO getPOSIXTime >>= handleEndEvent' testTimerHandle profileName eventName file - modify' $ over (profiles . ix profileIndex . events) (S.|> (SpeedScopeEvent eventType frameID time)) - . over (profiles . ix profileIndex . endValue) (max time) +handleEndEvent' :: (MonadIO m) + => Maybe Handle + -> T.Text + -> T.Text + -> SpeedScopeFile + -> NominalDiffTime + -> m SpeedScopeFile +handleEndEvent' maybeHandle profileName eventName file time = do + whenJust maybeHandle $ \h -> liftIO $ T.hPutStrLn h [i|#{time} END #{show profileName} #{eventName}|] + return $ handleSpeedScopeEvent file time profileName eventName SpeedScopeEventTypeClose + + +-- | TODO: maybe use an intermediate format so the frames (and possibly profiles) aren't stored as lists, +-- so we don't have to do O(N) L.length and S.findIndexL +handleSpeedScopeEvent :: SpeedScopeFile -> POSIXTime -> T.Text -> T.Text -> SpeedScopeEventType -> SpeedScopeFile +handleSpeedScopeEvent initialFile time profileName eventName eventType = flip execState initialFile $ do + frameID <- get >>= \f -> case S.findIndexL (== SpeedScopeFrame eventName) (f ^. shared . frames) of + Just j -> return j + Nothing -> do + modify' $ over (shared . frames) (S.|> (SpeedScopeFrame eventName)) + return $ S.length $ f ^. shared . frames + + profileIndex <- get >>= \f -> case L.findIndex ((== profileName) . (^. name)) (f ^. profiles) of + Just j -> return j + Nothing -> do + modify' $ over profiles (\x -> x <> [newProfile profileName time]) + return $ L.length (f ^. profiles) + + modify' $ over (profiles . ix profileIndex . events) (S.|> (SpeedScopeEvent eventType frameID time)) + . over (profiles . ix profileIndex . endValue) (max time) diff --git a/src/Test/Sandwich/Types/ArgParsing.hs b/src/Test/Sandwich/Types/ArgParsing.hs --- a/src/Test/Sandwich/Types/ArgParsing.hs +++ b/src/Test/Sandwich/Types/ArgParsing.hs @@ -133,7 +133,10 @@ deriving Show data CommandLineWebdriverOptions = CommandLineWebdriverOptions { - optFirefox :: Maybe BrowserToUse + optBrowserToUse :: Maybe BrowserToUse + + , optChromeNoSandbox :: Bool + , optDisplay :: Maybe DisplayType , optFluxbox :: Bool , optIndividualVideos :: Bool diff --git a/src/Test/Sandwich/Util/Process.hs b/src/Test/Sandwich/Util/Process.hs --- a/src/Test/Sandwich/Util/Process.hs +++ b/src/Test/Sandwich/Util/Process.hs @@ -1,7 +1,13 @@ +{-# LANGUAGE CPP #-} module Test.Sandwich.Util.Process ( gracefullyStopProcess , gracefullyWaitForProcess + + , gracefullyStopProcess' + , gracefullyWaitForProcess' + + , StopProcessResult(..) ) where import Control.Monad @@ -13,33 +19,71 @@ import System.Process import Test.Sandwich.Logging +#ifndef mingw32_HOST_OS +import System.Posix.Signals (signalProcess, sigKILL) +#endif --- | Interrupt a process and wait for it to terminate. + +data StopProcessResult = + StoppedByItself + | StoppedAfterInterrupt + | StoppedAfterTerminate + | StoppedAfterKill + | FailedToStop + deriving (Show, Eq, Ord, Enum) + +-- | Interrupt a process and wait for it to terminate, returning a 'StopProcessResult'. gracefullyStopProcess :: (MonadIO m, MonadLogger m) => ProcessHandle -> Int -> m () -gracefullyStopProcess p gracePeriodUs = do +gracefullyStopProcess p gracePeriodUs = void $ gracefullyStopProcess' p gracePeriodUs + +-- | Interrupt a process and wait for it to terminate. +gracefullyStopProcess' :: (MonadIO m, MonadLogger m) => ProcessHandle -> Int -> m StopProcessResult +gracefullyStopProcess' p gracePeriodUs = do liftIO $ interruptProcessGroupOf p - gracefullyWaitForProcess p gracePeriodUs + gracefullyWaitForProcess' p gracePeriodUs -- | Wait for a process to terminate. If it doesn't terminate within 'gracePeriodUs' microseconds, -- send it an interrupt signal and wait for another 'gracePeriodUs' microseconds. -- After this time elapses send a terminate signal and wait for the process to die. gracefullyWaitForProcess :: (MonadIO m, MonadLogger m) => ProcessHandle -> Int -> m () -gracefullyWaitForProcess p gracePeriodUs = do +gracefullyWaitForProcess p gracePeriodUs = void $ gracefullyWaitForProcess' p gracePeriodUs + +-- | Wait for a process to terminate. If it doesn't terminate within 'gracePeriodUs' microseconds, +-- send it an interrupt signal and wait for another 'gracePeriodUs' microseconds. +-- After this time elapses send a terminate signal and wait for the process to die. +gracefullyWaitForProcess' :: (MonadIO m, MonadLogger m) => ProcessHandle -> Int -> m StopProcessResult +gracefullyWaitForProcess' p gracePeriodUs = do let waitForExit = do let policy = limitRetriesByCumulativeDelay gracePeriodUs $ capDelay 200_000 $ exponentialBackoff 1_000 retrying policy (\_ x -> return $ isNothing x) $ \_ -> do liftIO $ getProcessExitCode p waitForExit >>= \case - Just _ -> return () + Just _ -> return StoppedByItself Nothing -> do - pid <- liftIO $ getPid p - warn [i|(#{pid}) Process didn't stop after #{gracePeriodUs}us; trying to interrupt|] + liftIO (getPid p) >>= \case + Nothing -> return StoppedByItself + Just pid -> do + warn [i|(#{pid}) Process didn't stop after #{gracePeriodUs}us; trying to interrupt|] - liftIO $ interruptProcessGroupOf p - waitForExit >>= \case - Just _ -> return () - Nothing -> void $ do - warn [i|(#{pid}) Process didn't stop after a further #{gracePeriodUs}us; going to kill|] - liftIO $ terminateProcess p - liftIO $ waitForProcess p + liftIO $ interruptProcessGroupOf p + waitForExit >>= \case + Just _ -> return StoppedAfterInterrupt + Nothing -> do + warn [i|(#{pid}) Process didn't stop after another sigINT and a further #{gracePeriodUs}us; going to terminate|] + liftIO $ terminateProcess p + +#ifdef mingw32_HOST_OS + waitForExit >>= \case + Just _ -> return StoppedAfterKill + Nothing -> return FailedToStop +#else + waitForExit >>= \case + Just _ -> return StoppedAfterTerminate + Nothing -> do + warn [i|(#{pid}) Process didn't stop after sigTERM and a further #{gracePeriodUs}us; going to kill|] + liftIO $ signalProcess sigKILL pid + waitForExit >>= \case + Just _ -> return StoppedAfterKill + Nothing -> return FailedToStop +#endif