{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE CPP #-}

module System.Taffybar.Test.UtilSpec
  ( spec
  -- * Mock commands
  , withMockCommand
  , writeScript
  -- * Environment setup
  , withEnv
  , withSetEnv
  , prependPath
  -- ** Running subprocesses
  , withService
  , setStdoutCond
  , setStderrCond
  , setServiceDefaults
  , makeServiceDefaults
  -- * Concurrency
  , listLiveThreads
  , diffLiveThreads
  -- * OS Resources
  , listFds
  -- * Other test helpers
  , tryIOMaybe
  , laxTimeout
  , laxTimeout'
  , DodgyEq(..)
  -- ** Logging for tests
  , logSetup
  , specLogSetup
  , specLogSetupPrio
  , specLog
  , specLogAt
  , getSpecLogPriority
  , Priority(..)
  ) where

import Control.Applicative ((<|>))
import Control.Monad (guard, join, void, (<=<))
import Control.Monad.IO.Unlift
import Data.Bifunctor (second)
import qualified Data.ByteString.Char8 as B8
import Data.Either.Extra (eitherToMaybe, isLeft)
import Data.Function (on, (&))
import Data.List (deleteFirstsBy, uncons)
import Data.Maybe (catMaybes, fromMaybe)
#if MIN_VERSION_base(4,18,0)
import GHC.Conc.Sync (ThreadId(..), ThreadStatus(..), listThreads, threadStatus, threadLabel)
#else
import GHC.Conc.Sync (ThreadId(..), ThreadStatus(..))
#endif
import System.Exit (ExitCode(..))
import System.FilePath (isRelative, takeFileName, (</>))
import System.IO (Handle, BufferMode(..), hSetBuffering, stderr, hClose)
import System.Log.Logger (Priority(..), updateGlobalLogger, setLevel, logM, getLevel, getLogger, removeHandler, setHandlers)
import System.Log.Handler.Simple (GenericHandler(..))
import System.Process.Typed (readProcess, proc, ProcessConfig, Process, withProcessTerm, waitExitCode, ExitCodeException (..), setStdin, nullStream, setStdout, setStderr, StreamSpec, setCloseFds, inherit, createPipe, getStdin)
import System.Posix.Files (readSymbolicLink)
import Test.Hspec
import Text.Printf (printf)
import Text.Read (readMaybe)
import UnliftIO.Async (race)
import UnliftIO.Concurrent (forkFinally, threadDelay)
import UnliftIO.Directory (Permissions (..), findExecutable, getPermissions, setPermissions, listDirectory)
import UnliftIO.Environment (lookupEnv, setEnv, unsetEnv)
import UnliftIO.Exception (bracket, evaluateDeep, throwIO, throwString, tryIO, StringException (..), try)
import qualified UnliftIO.MVar as MV
import UnliftIO.Temporary (withSystemTempDirectory)
import UnliftIO.Timeout (timeout)

import System.Taffybar.LogFormatter (taffyLogHandler)

-- | Run the given 'IO' action with the @PATH@ environment variable
-- set up so that executing the given command name will run a
-- script.
withMockCommand
  :: FilePath -- ^ Name of command - should not contain slashes
  -> String -- ^ Contents of script
  -> IO a -- ^ Action to run with command available in search path
  -> IO a
withMockCommand :: forall a. [Char] -> [Char] -> IO a -> IO a
withMockCommand [Char]
name [Char]
content IO a
action =
  [Char] -> ([Char] -> IO a) -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
[Char] -> ([Char] -> m a) -> m a
withSystemTempDirectory [Char]
"specutil" (([Char] -> IO a) -> IO a) -> ([Char] -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \[Char]
dir -> do
    [Char] -> [Char] -> Expectation
writeScript ([Char]
dir [Char] -> [Char] -> [Char]
</> [Char] -> [Char]
takeFileName [Char]
name) [Char]
content
    [([Char], Maybe [Char] -> Maybe [Char])] -> IO a -> IO a
forall a. [([Char], Maybe [Char] -> Maybe [Char])] -> IO a -> IO a
withEnv [([Char]
"PATH", [Char] -> Maybe [Char] -> Maybe [Char]
prependPath [Char]
dir)] IO a
action

-- | Write a text file, make it executable.
-- It ought to have a shebang line.
writeScript :: FilePath -> String -> IO ()
writeScript :: [Char] -> [Char] -> Expectation
writeScript [Char]
scriptFile [Char]
content = do
  content' <- [Char] -> IO [Char]
patchShebangs [Char]
content
  writeFile scriptFile content'
  p <- getPermissions scriptFile
  setPermissions scriptFile (p { executable = True })

-- | Given the text of a shell script, this replaces any relative path
-- in the shebang with an absolute path, according to the current
-- environment's @PATH@ variable.
--
-- The only reason this exists is so that we can generate shell
-- scripts containing @#!/usr/bin/env bash@ and then be able to
-- execute them within a Nix build sandbox (which does not allow
-- @/usr/bin/env@).
patchShebangs :: String -> IO String
patchShebangs :: [Char] -> IO [Char]
patchShebangs = ([Char] -> IO (Maybe [Char])) -> [Char] -> IO [Char]
forall (m :: * -> *).
Applicative m =>
([Char] -> m (Maybe [Char])) -> [Char] -> m [Char]
patchShebangs' [Char] -> IO (Maybe [Char])
findExe
  where
    findExe :: [Char] -> IO (Maybe [Char])
findExe = (Maybe (Maybe [Char]) -> Maybe [Char])
-> IO (Maybe (Maybe [Char])) -> IO (Maybe [Char])
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (Maybe [Char]) -> Maybe [Char]
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (IO (Maybe (Maybe [Char])) -> IO (Maybe [Char]))
-> ([Char] -> IO (Maybe (Maybe [Char])))
-> [Char]
-> IO (Maybe [Char])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> IO (Maybe [Char]))
-> Maybe [Char] -> IO (Maybe (Maybe [Char]))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse [Char] -> IO (Maybe [Char])
forall (m :: * -> *). MonadIO m => [Char] -> m (Maybe [Char])
findExecutable (Maybe [Char] -> IO (Maybe (Maybe [Char])))
-> ([Char] -> Maybe [Char]) -> [Char] -> IO (Maybe (Maybe [Char]))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe [Char]
takeRelativeFileName

    takeRelativeFileName :: FilePath -> Maybe FilePath
    takeRelativeFileName :: [Char] -> Maybe [Char]
takeRelativeFileName [Char]
fp = Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([Char] -> Bool
isRelative [Char]
fp) Maybe () -> Maybe [Char] -> Maybe [Char]
forall a b. Maybe a -> Maybe b -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> Maybe [Char]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> [Char]
takeFileName [Char]
fp)

patchShebangs' :: Applicative m => (FilePath -> m (Maybe FilePath)) -> String -> m String
patchShebangs' :: forall (m :: * -> *).
Applicative m =>
([Char] -> m (Maybe [Char])) -> [Char] -> m [Char]
patchShebangs' [Char] -> m (Maybe [Char])
replaceExe [Char]
script = case [Char] -> Maybe ([Char], [Char])
parseInterpreter [Char]
script of
  Just ([Char]
interpreter, [Char]
rest) -> do
    let unparse :: [Char] -> [Char]
unparse [Char]
exe = [Char]
"#! " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
exe [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
rest
    [Char] -> ([Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
script [Char] -> [Char]
unparse (Maybe [Char] -> [Char]) -> m (Maybe [Char]) -> m [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> m (Maybe [Char])
replaceExe [Char]
interpreter
  Maybe ([Char], [Char])
Nothing -> [Char] -> m [Char]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char]
script

parseInterpreter :: String -> Maybe (String, String)
parseInterpreter :: [Char] -> Maybe ([Char], [Char])
parseInterpreter ([Char] -> [[Char]]
lines -> [[Char]]
content) = do
  (header, rest) <- [[Char]] -> Maybe ([Char], [[Char]])
forall a. [a] -> Maybe (a, [a])
uncons [[Char]]
content
  (interpreter, args) <- parseShebang header
  pure (interpreter, unlines (args:rest))

  where
    parseShebang :: String -> Maybe (String, String)
    parseShebang :: [Char] -> Maybe ([Char], [Char])
parseShebang (Char
'#':Char
'!':([Char] -> Maybe ([Char], [[Char]])
findInterpreter -> Maybe ([Char], [[Char]])
shebang)) =
      let catArgs :: [[Char]] -> [Char]
catArgs [[Char]]
args = [[Char]] -> [Char]
unwords ([Char]
""[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:[[Char]]
args)
      in ([[Char]] -> [Char]) -> ([Char], [[Char]]) -> ([Char], [Char])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [[Char]] -> [Char]
catArgs (([Char], [[Char]]) -> ([Char], [Char]))
-> Maybe ([Char], [[Char]]) -> Maybe ([Char], [Char])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ([Char], [[Char]])
shebang
    parseShebang [Char]
_ = Maybe ([Char], [Char])
forall a. Maybe a
Nothing

    findInterpreter :: [Char] -> Maybe ([Char], [[Char]])
findInterpreter = [[Char]] -> Maybe ([Char], [[Char]])
forall a. [a] -> Maybe (a, [a])
uncons ([[Char]] -> Maybe ([Char], [[Char]]))
-> ([Char] -> [[Char]]) -> [Char] -> Maybe ([Char], [[Char]])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"env") ([Char] -> Bool) -> ([Char] -> [Char]) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
takeFileName) ([[Char]] -> [[Char]])
-> ([Char] -> [[Char]]) -> [Char] -> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [[Char]]
words

-- | Run an 'IO' action with the given environment variables set up
-- according to their current value. 'Nothing' denotes an unset
-- environment variable. After the 'IO' action completes, environment
-- variables are restored to their previous state.
withEnv :: [(String, Maybe String -> Maybe String)] -> IO a -> IO a
withEnv :: forall a. [([Char], Maybe [Char] -> Maybe [Char])] -> IO a -> IO a
withEnv [([Char], Maybe [Char] -> Maybe [Char])]
mods = IO [([Char], Maybe [Char])]
-> ([([Char], Maybe [Char])] -> IO [()])
-> ([([Char], Maybe [Char])] -> IO a)
-> IO a
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket IO [([Char], Maybe [Char])]
setup [([Char], Maybe [Char])] -> IO [()]
teardown (([([Char], Maybe [Char])] -> IO a) -> IO a)
-> (IO a -> [([Char], Maybe [Char])] -> IO a) -> IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> [([Char], Maybe [Char])] -> IO a
forall a b. a -> b -> a
const
  where
    setup :: IO [([Char], Maybe [Char])]
setup = (([Char], Maybe [Char] -> Maybe [Char])
 -> IO ([Char], Maybe [Char]))
-> [([Char], Maybe [Char] -> Maybe [Char])]
-> IO [([Char], Maybe [Char])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (([Char]
 -> (Maybe [Char] -> Maybe [Char]) -> IO ([Char], Maybe [Char]))
-> ([Char], Maybe [Char] -> Maybe [Char])
-> IO ([Char], Maybe [Char])
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char]
-> (Maybe [Char] -> Maybe [Char]) -> IO ([Char], Maybe [Char])
changeEnv) [([Char], Maybe [Char] -> Maybe [Char])]
mods
    teardown :: [([Char], Maybe [Char])] -> IO [()]
teardown = (([Char], Maybe [Char]) -> Expectation)
-> [([Char], Maybe [Char])] -> IO [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (([Char] -> Maybe [Char] -> Expectation)
-> ([Char], Maybe [Char]) -> Expectation
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char] -> Maybe [Char] -> Expectation
putEnv) ([([Char], Maybe [Char])] -> IO [()])
-> ([([Char], Maybe [Char])] -> [([Char], Maybe [Char])])
-> [([Char], Maybe [Char])]
-> IO [()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([Char], Maybe [Char])] -> [([Char], Maybe [Char])]
forall a. [a] -> [a]
reverse

    changeEnv :: [Char]
-> (Maybe [Char] -> Maybe [Char]) -> IO ([Char], Maybe [Char])
changeEnv [Char]
name Maybe [Char] -> Maybe [Char]
f = do
      old <- [Char] -> IO (Maybe [Char])
forall (m :: * -> *). MonadIO m => [Char] -> m (Maybe [Char])
lookupEnv [Char]
name
      putEnv name (f old)
      pure (name, old)

    putEnv :: String -> Maybe String -> IO ()
    putEnv :: [Char] -> Maybe [Char] -> Expectation
putEnv [Char]
name = Expectation
-> ([Char] -> Expectation) -> Maybe [Char] -> Expectation
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Expectation
forall (m :: * -> *). MonadIO m => [Char] -> m ()
unsetEnv [Char]
name) ([Char] -> [Char] -> Expectation
forall (m :: * -> *). MonadIO m => [Char] -> [Char] -> m ()
setEnv [Char]
name)

withSetEnv :: [(String, String)] -> IO a -> IO a
withSetEnv :: forall a. [([Char], [Char])] -> IO a -> IO a
withSetEnv = [([Char], Maybe [Char] -> Maybe [Char])] -> IO a -> IO a
forall a. [([Char], Maybe [Char] -> Maybe [Char])] -> IO a -> IO a
withEnv ([([Char], Maybe [Char] -> Maybe [Char])] -> IO a -> IO a)
-> ([([Char], [Char])] -> [([Char], Maybe [Char] -> Maybe [Char])])
-> [([Char], [Char])]
-> IO a
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char], [Char]) -> ([Char], Maybe [Char] -> Maybe [Char]))
-> [([Char], [Char])] -> [([Char], Maybe [Char] -> Maybe [Char])]
forall a b. (a -> b) -> [a] -> [b]
map (([Char] -> Maybe [Char] -> Maybe [Char])
-> ([Char], [Char]) -> ([Char], Maybe [Char] -> Maybe [Char])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Maybe [Char] -> Maybe [Char] -> Maybe [Char]
forall a b. a -> b -> a
const (Maybe [Char] -> Maybe [Char] -> Maybe [Char])
-> ([Char] -> Maybe [Char])
-> [Char]
-> Maybe [Char]
-> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just))

-- | Use this as a modifier function argument of 'withEnv' to ensure
-- that the given directory is prepended to a search path variable.
prependPath :: FilePath -> Maybe String -> Maybe String
prependPath :: [Char] -> Maybe [Char] -> Maybe [Char]
prependPath [Char]
p = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char])
-> (Maybe [Char] -> [Char]) -> Maybe [Char] -> Maybe [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":/usr/bin") ([Char] -> [Char])
-> (Maybe [Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
p [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) ([Char] -> [Char])
-> (Maybe [Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ([Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ([Char]
":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)

listFds :: MonadIO m => m [(Int, FilePath)]
listFds :: forall (m :: * -> *). MonadIO m => m [(Int, [Char])]
listFds = [Maybe (Int, [Char])] -> [(Int, [Char])]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Int, [Char])] -> [(Int, [Char])])
-> m [Maybe (Int, [Char])] -> m [(Int, [Char])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> m [[Char]]
forall (m :: * -> *). MonadIO m => [Char] -> m [[Char]]
listDirectory [Char]
fdPath m [[Char]]
-> ([[Char]] -> m [Maybe (Int, [Char])]) -> m [Maybe (Int, [Char])]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Char] -> m (Maybe (Int, [Char])))
-> [[Char]] -> m [Maybe (Int, [Char])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Char] -> m (Maybe (Int, [Char]))
forall (m :: * -> *).
MonadIO m =>
[Char] -> m (Maybe (Int, [Char]))
readEntry)
  where
    fdPath :: [Char]
fdPath = [Char]
"/proc/self/fd"

    readEntry :: MonadIO m => FilePath -> m (Maybe (Int, FilePath))
    readEntry :: forall (m :: * -> *).
MonadIO m =>
[Char] -> m (Maybe (Int, [Char]))
readEntry [Char]
fd = do
      t <- IO (Maybe [Char]) -> m (Maybe [Char])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe [Char]) -> m (Maybe [Char]))
-> IO (Maybe [Char]) -> m (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ IO [Char] -> IO (Maybe [Char])
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Maybe a)
tryIOMaybe (IO [Char] -> IO (Maybe [Char])) -> IO [Char] -> IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> IO [Char]
readSymbolicLink ([Char]
fdPath [Char] -> [Char] -> [Char]
</> [Char]
fd)
      pure $ (,) <$> readMaybe fd <*> t

listLiveThreads :: IO [(ThreadId, (String, Maybe ThreadStatus))]
#if MIN_VERSION_base(4,18,0)
listLiveThreads :: IO [(ThreadId, ([Char], Maybe ThreadStatus))]
listLiveThreads = do
  threadIds <- IO [ThreadId]
listThreads
  labels <- mapM (fmap (fromMaybe "" . join) . tryIOMaybe . threadLabel) threadIds
  statuses <- mapM (tryIOMaybe . threadStatus) threadIds
  let isAlive ThreadStatus
s = ThreadStatus
s ThreadStatus -> ThreadStatus -> Bool
forall a. Eq a => a -> a -> Bool
/= ThreadStatus
ThreadFinished Bool -> Bool -> Bool
&& ThreadStatus
s ThreadStatus -> ThreadStatus -> Bool
forall a. Eq a => a -> a -> Bool
/= ThreadStatus
ThreadDied
  pure $ filter (maybe True isAlive . snd . snd) $ zip threadIds (zip labels statuses)
#else
listLiveThreads = pure []
#endif

diffLiveThreads :: Eq a => [(a, b)] -> [(a, b)] -> [(a, b)]
diffLiveThreads :: forall a b. Eq a => [(a, b)] -> [(a, b)] -> [(a, b)]
diffLiveThreads = ((a, b) -> (a, b) -> Bool) -> [(a, b)] -> [(a, b)] -> [(a, b)]
forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
deleteFirstsBy (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
(==) (a -> a -> Bool) -> ((a, b) -> a) -> (a, b) -> (a, b) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (a, b) -> a
forall a b. (a, b) -> a
fst)

tryIOMaybe :: MonadUnliftIO m => m a -> m (Maybe a)
tryIOMaybe :: forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Maybe a)
tryIOMaybe = (Either IOException a -> Maybe a)
-> m (Either IOException a) -> m (Maybe a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either IOException a -> Maybe a
forall a b. Either a b -> Maybe b
eitherToMaybe (m (Either IOException a) -> m (Maybe a))
-> (m a -> m (Either IOException a)) -> m a -> m (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> m (Either IOException a)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
tryIO

laxTimeout' :: (HasCallStack, MonadUnliftIO m) => Int -> m a -> m a
laxTimeout' :: forall (m :: * -> *) a.
(HasCallStack, MonadUnliftIO m) =>
Int -> m a -> m a
laxTimeout' Int
n m a
action = Int -> m a -> m (Maybe a)
forall (m :: * -> *) a.
(HasCallStack, MonadUnliftIO m) =>
Int -> m a -> m (Maybe a)
laxTimeout Int
n m a
action m (Maybe a) -> (Maybe a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Just a
a -> a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
  Maybe a
Nothing -> [Char] -> m a
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => [Char] -> m a
expectationFailure' ([Char] -> m a) -> [Char] -> m a
forall a b. (a -> b) -> a -> b
$ [Char] -> Int -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"Timed out after %dusec" Int
n

expectationFailure' :: (HasCallStack, MonadIO m) => String -> m a
expectationFailure' :: forall (m :: * -> *) a. (HasCallStack, MonadIO m) => [Char] -> m a
expectationFailure' [Char]
msg = Expectation -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HasCallStack => [Char] -> Expectation
[Char] -> Expectation
expectationFailure [Char]
msg) m () -> m a -> m a
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Char] -> m a
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString [Char]
msg

laxTimeout :: (HasCallStack, MonadUnliftIO m) => Int -> m a -> m (Maybe a)
laxTimeout :: forall (m :: * -> *) a.
(HasCallStack, MonadUnliftIO m) =>
Int -> m a -> m (Maybe a)
laxTimeout Int
n m a
action = do
  result <- m (MVar (Either SomeException (Maybe a)))
forall (m :: * -> *) a. MonadIO m => m (MVar a)
MV.newEmptyMVar
  void $ forkFinally (timeout n action) (MV.putMVar result)
  join <$> timeout n (MV.takeMVar result >>= either throwIO pure)

-- | A wrapper to provide 'Eq' for types which only have 'Show'.
newtype DodgyEq a = DodgyEq { forall a. DodgyEq a -> a
unDodgyEq :: a }
  deriving Int -> DodgyEq a -> [Char] -> [Char]
[DodgyEq a] -> [Char] -> [Char]
DodgyEq a -> [Char]
(Int -> DodgyEq a -> [Char] -> [Char])
-> (DodgyEq a -> [Char])
-> ([DodgyEq a] -> [Char] -> [Char])
-> Show (DodgyEq a)
forall a. Int -> DodgyEq a -> [Char] -> [Char]
forall a. [DodgyEq a] -> [Char] -> [Char]
forall a. DodgyEq a -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: forall a. Int -> DodgyEq a -> [Char] -> [Char]
showsPrec :: Int -> DodgyEq a -> [Char] -> [Char]
$cshow :: forall a. DodgyEq a -> [Char]
show :: DodgyEq a -> [Char]
$cshowList :: forall a. [DodgyEq a] -> [Char] -> [Char]
showList :: [DodgyEq a] -> [Char] -> [Char]
Show via (DodgyEq a)

instance Eq (DodgyEq a) where
  DodgyEq a
a == :: DodgyEq a -> DodgyEq a -> Bool
== DodgyEq a
b = DodgyEq a -> [Char]
forall a. Show a => a -> [Char]
show DodgyEq a
a [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== DodgyEq a -> [Char]
forall a. Show a => a -> [Char]
show DodgyEq a
b

------------------------------------------------------------------------

-- | Logger name for messages originating from specs.
specLoggerName :: String
specLoggerName :: [Char]
specLoggerName = [Char]
"Test"

-- | Log a test message.
specLog :: MonadIO m => String -> m ()
specLog :: forall (m :: * -> *). MonadIO m => [Char] -> m ()
specLog = Priority -> [Char] -> m ()
forall (m :: * -> *). MonadIO m => Priority -> [Char] -> m ()
specLogAt Priority
INFO

-- | Log a test message at the given level.
specLogAt :: MonadIO m => Priority -> String -> m ()
specLogAt :: forall (m :: * -> *). MonadIO m => Priority -> [Char] -> m ()
specLogAt Priority
level = Expectation -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Expectation -> m ()) -> ([Char] -> Expectation) -> [Char] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Priority -> [Char] -> Expectation
logM [Char]
specLoggerName Priority
level

-- | Setup logging before running the specs.
logSetup :: HasCallStack => SpecWith a -> SpecWith a
logSetup :: forall a. HasCallStack => SpecWith a -> SpecWith a
logSetup = Expectation -> SpecWith a -> SpecWith a
forall a. HasCallStack => Expectation -> SpecWith a -> SpecWith a
beforeAll_ Expectation
specLogSetup

-- | Get log levels from environment variables and set up formatters.
specLogSetup :: IO ()
specLogSetup :: Expectation
specLogSetup = Priority -> Expectation
specLogSetupPrio Priority
WARNING

-- | Like 'specLogSetup', but with a default minimum priority.
specLogSetupPrio :: Priority -> IO ()
specLogSetupPrio :: Priority -> Expectation
specLogSetupPrio Priority
defaultPriority = do
  [Char] -> (Logger -> Logger) -> Expectation
updateGlobalLogger [Char]
"" Logger -> Logger
removeHandler
  Handle -> BufferMode -> Expectation
hSetBuffering Handle
stderr BufferMode
LineBuffering
  [Char] -> [Char] -> IO (GenericHandler Handle) -> Expectation
forall {a}. LogHandler a => [Char] -> [Char] -> IO a -> Expectation
setup [Char]
"System.Taffybar" [Char]
"TAFFYBAR_VERBOSE" IO (GenericHandler Handle)
taffyLogHandler
  [Char] -> [Char] -> IO (GenericHandler Handle) -> Expectation
forall {a}. LogHandler a => [Char] -> [Char] -> IO a -> Expectation
setup [Char]
specLoggerName [Char]
"TAFFYBAR_TEST_VERBOSE" (GenericHandler Handle -> IO (GenericHandler Handle)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure GenericHandler Handle
specLogHandler)
  where
    setup :: [Char] -> [Char] -> IO a -> Expectation
setup [Char]
loggerName [Char]
envVar IO a
getHandler = do
      p <- Priority -> Maybe Priority -> Priority
forall a. a -> Maybe a -> a
fromMaybe Priority
defaultPriority (Maybe Priority -> Priority) -> IO (Maybe Priority) -> IO Priority
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe Priority)
getEnvPriority [Char]
envVar
      h <- getHandler
      updateGlobalLogger loggerName (setLevel p . setHandlers [h])

-- | A plain looking log handler, to contrast with 'taffyLogFormatter'.
specLogHandler :: GenericHandler Handle
specLogHandler :: GenericHandler Handle
specLogHandler = GenericHandler
  { priority :: Priority
priority = Priority
DEBUG
  , formatter :: LogFormatter (GenericHandler Handle)
formatter =  \GenericHandler Handle
_ (Priority
level, [Char]
msg) [Char]
_name -> [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Priority -> [Char]
forall a. Show a => a -> [Char]
show Priority
level [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
msg)
  , privData :: Handle
privData = Handle
stderr
  , writeFunc :: Handle -> [Char] -> Expectation
writeFunc = \Handle
h -> Handle -> ByteString -> Expectation
B8.hPutStrLn Handle
h (ByteString -> Expectation)
-> ([Char] -> ByteString) -> [Char] -> Expectation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString
B8.pack ([Char] -> Expectation)
-> ([Char] -> IO [Char]) -> [Char] -> Expectation
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [Char] -> IO [Char]
forall (m :: * -> *) a. (MonadIO m, NFData a) => a -> m a
evaluateDeep
  , closeFunc :: Handle -> Expectation
closeFunc = \Handle
_ -> () -> Expectation
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  }

-- | Find out the configured log level for specs.
getSpecLogPriority :: MonadIO m => m Priority
getSpecLogPriority :: forall (m :: * -> *). MonadIO m => m Priority
getSpecLogPriority = Priority -> Maybe Priority -> Priority
forall a. a -> Maybe a -> a
fromMaybe Priority
WARNING (Maybe Priority -> Priority)
-> (Logger -> Maybe Priority) -> Logger -> Priority
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logger -> Maybe Priority
getLevel (Logger -> Priority) -> m Logger -> m Priority
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Logger -> m Logger
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([Char] -> IO Logger
getLogger [Char]
specLoggerName)

-- | Converts an environment variable value to a 'Priority'.
-- Numeric or textual levels are supported.
getEnvPriority :: String -> IO (Maybe Priority)
getEnvPriority :: [Char] -> IO (Maybe Priority)
getEnvPriority = (Maybe [Char] -> Maybe Priority)
-> IO (Maybe [Char]) -> IO (Maybe Priority)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe [Char] -> ([Char] -> Maybe Priority) -> Maybe Priority
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> Maybe Priority
toPriority) (IO (Maybe [Char]) -> IO (Maybe Priority))
-> ([Char] -> IO (Maybe [Char])) -> [Char] -> IO (Maybe Priority)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> IO (Maybe [Char])
forall (m :: * -> *). MonadIO m => [Char] -> m (Maybe [Char])
lookupEnv
  where
    toPriority :: [Char] -> Maybe Priority
toPriority [Char]
s = [Char] -> Maybe Priority
forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
s Maybe Priority -> Maybe Priority -> Maybe Priority
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Int -> Priority) -> Maybe Int -> Maybe Priority
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Priority
fromInt ([Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
readMaybe [Char]
s)

    fromInt :: Int -> Priority
    fromInt :: Int -> Priority
fromInt Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 = Priority
DEBUG
              | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = Priority
WARNING
              | Bool
otherwise = Priority
INFO

-- | Like 'withProcessTerm_', except that if the process exits -- for
-- whatever reason -- before the action completes, then it's an
-- error. It will immediately cancel the action and throw an
-- 'ExitCodeException'.
withService :: MonadUnliftIO m => ProcessConfig stdin stdout stderr -> (Process stdin stdout stderr -> m a) -> m a
withService :: forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withService ProcessConfig stdin stdout stderr
cfg Process stdin stdout stderr -> m a
action = ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withProcessTerm ProcessConfig stdin stdout stderr
cfg ((Process stdin stdout stderr -> m a) -> m a)
-> (Process stdin stdout stderr -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Process stdin stdout stderr
p -> do
  (ExitCode -> m a) -> (a -> m a) -> Either ExitCode a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ExitCode -> m a
forall {m :: * -> *} {a}. MonadIO m => ExitCode -> m a
throwEarlyExitException a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ExitCode a -> m a) -> m (Either ExitCode a) -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m ExitCode -> m a -> m (Either ExitCode a)
forall (m :: * -> *) a b.
MonadUnliftIO m =>
m a -> m b -> m (Either a b)
race (Process stdin stdout stderr -> m ExitCode
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
Process stdin stdout stderr -> m ExitCode
waitExitCode Process stdin stdout stderr
p) (Process stdin stdout stderr -> m a
action Process stdin stdout stderr
p)
  where
    throwEarlyExitException :: ExitCode -> m a
throwEarlyExitException ExitCode
c = ExitCodeException -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (ExitCodeException -> m a) -> ExitCodeException -> m a
forall a b. (a -> b) -> a -> b
$ ExitCode
-> ProcessConfig () () ()
-> ByteString
-> ByteString
-> ExitCodeException
ExitCodeException ExitCode
c ProcessConfig () () ()
cfg' ByteString
"" ByteString
""
    cfg' :: ProcessConfig () () ()
cfg' = ProcessConfig stdin stdout stderr
cfg ProcessConfig stdin stdout stderr
-> (ProcessConfig stdin stdout stderr
    -> ProcessConfig () stdout stderr)
-> ProcessConfig () stdout stderr
forall a b. a -> (a -> b) -> b
& StreamSpec 'STInput ()
-> ProcessConfig stdin stdout stderr
-> ProcessConfig () stdout stderr
forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin StreamSpec 'STInput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
nullStream ProcessConfig () stdout stderr
-> (ProcessConfig () stdout stderr -> ProcessConfig () () stderr)
-> ProcessConfig () () stderr
forall a b. a -> (a -> b) -> b
& StreamSpec 'STOutput ()
-> ProcessConfig () stdout stderr -> ProcessConfig () () stderr
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
nullStream ProcessConfig () () stderr
-> (ProcessConfig () () stderr -> ProcessConfig () () ())
-> ProcessConfig () () ()
forall a b. a -> (a -> b) -> b
& StreamSpec 'STOutput ()
-> ProcessConfig () () stderr -> ProcessConfig () () ()
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr StreamSpec 'STOutput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
nullStream

streamSpecCond :: Priority -> Priority -> StreamSpec any ()
streamSpecCond :: forall (any :: StreamType).
Priority -> Priority -> StreamSpec any ()
streamSpecCond Priority
level Priority
verbosity = if Priority
level Priority -> Priority -> Bool
forall a. Ord a => a -> a -> Bool
>= Priority
verbosity then StreamSpec any ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
inherit else StreamSpec any ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
nullStream

setStdoutCond :: Priority -> ProcessConfig i o e -> ProcessConfig i () e
setStdoutCond :: forall i o e.
Priority -> ProcessConfig i o e -> ProcessConfig i () e
setStdoutCond = StreamSpec 'STOutput ()
-> ProcessConfig i o e -> ProcessConfig i () e
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout (StreamSpec 'STOutput ()
 -> ProcessConfig i o e -> ProcessConfig i () e)
-> (Priority -> StreamSpec 'STOutput ())
-> Priority
-> ProcessConfig i o e
-> ProcessConfig i () e
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Priority -> Priority -> StreamSpec 'STOutput ()
forall (any :: StreamType).
Priority -> Priority -> StreamSpec any ()
streamSpecCond Priority
DEBUG

setStderrCond :: Priority -> ProcessConfig i o e -> ProcessConfig i o ()
setStderrCond :: forall i o e.
Priority -> ProcessConfig i o e -> ProcessConfig i o ()
setStderrCond = StreamSpec 'STOutput ()
-> ProcessConfig i o e -> ProcessConfig i o ()
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr (StreamSpec 'STOutput ()
 -> ProcessConfig i o e -> ProcessConfig i o ())
-> (Priority -> StreamSpec 'STOutput ())
-> Priority
-> ProcessConfig i o e
-> ProcessConfig i o ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Priority -> Priority -> StreamSpec 'STOutput ()
forall (any :: StreamType).
Priority -> Priority -> StreamSpec any ()
streamSpecCond Priority
INFO

makeServiceDefaults :: FilePath -> [String] -> IO (ProcessConfig () () ())
makeServiceDefaults :: [Char] -> [[Char]] -> IO (ProcessConfig () () ())
makeServiceDefaults [Char]
prog [[Char]]
args =
  (Priority -> ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () () -> Priority -> ProcessConfig () () ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Priority -> ProcessConfig () () () -> ProcessConfig () () ()
forall i o e.
Priority -> ProcessConfig i o e -> ProcessConfig () () ()
setServiceDefaults ([Char] -> [[Char]] -> ProcessConfig () () ()
proc [Char]
prog [[Char]]
args) (Priority -> ProcessConfig () () ())
-> IO Priority -> IO (ProcessConfig () () ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Priority
forall (m :: * -> *). MonadIO m => m Priority
getSpecLogPriority

setServiceDefaults :: Priority -> ProcessConfig i o e -> ProcessConfig () () ()
setServiceDefaults :: forall i o e.
Priority -> ProcessConfig i o e -> ProcessConfig () () ()
setServiceDefaults Priority
logLevel = Bool -> ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdout stderr.
Bool
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setCloseFds Bool
True
  (ProcessConfig () () () -> ProcessConfig () () ())
-> (ProcessConfig i o e -> ProcessConfig () () ())
-> ProcessConfig i o e
-> ProcessConfig () () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StreamSpec 'STInput ()
-> ProcessConfig i () () -> ProcessConfig () () ()
forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin StreamSpec 'STInput ()
forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
nullStream
  (ProcessConfig i () () -> ProcessConfig () () ())
-> (ProcessConfig i o e -> ProcessConfig i () ())
-> ProcessConfig i o e
-> ProcessConfig () () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Priority -> ProcessConfig i o () -> ProcessConfig i () ()
forall i o e.
Priority -> ProcessConfig i o e -> ProcessConfig i () e
setStdoutCond Priority
logLevel
  (ProcessConfig i o () -> ProcessConfig i () ())
-> (ProcessConfig i o e -> ProcessConfig i o ())
-> ProcessConfig i o e
-> ProcessConfig i () ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Priority -> ProcessConfig i o e -> ProcessConfig i o ()
forall i o e.
Priority -> ProcessConfig i o e -> ProcessConfig i o ()
setStderrCond Priority
logLevel

------------------------------------------------------------------------

spec :: Spec
spec :: Spec
spec = do
  [Char] -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
[Char] -> a -> SpecWith (Arg a)
it [Char]
"withMockCommand" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ Expectation -> Expectation
example (Expectation -> Expectation) -> Expectation -> Expectation
forall a b. (a -> b) -> a -> b
$
    [Char] -> [Char] -> Expectation -> Expectation
forall a. [Char] -> [Char] -> IO a -> IO a
withMockCommand [Char]
"blah" [Char]
"#!/usr/bin/env bash\necho hello \"$@\"\n" (Expectation -> Expectation) -> Expectation -> Expectation
forall a b. (a -> b) -> a -> b
$ do
      (code, out, err) <- ProcessConfig () () () -> IO (ExitCode, ByteString, ByteString)
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ExitCode, ByteString, ByteString)
readProcess ([Char] -> [[Char]] -> ProcessConfig () () ()
proc [Char]
"blah" [[Char]
"arstd"])
      code `shouldBe` ExitSuccess
      out `shouldBe` "hello arstd\n"
      err `shouldBe` ""

  [Char] -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
[Char] -> a -> SpecWith (Arg a)
it [Char]
"laxTimeout" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ Expectation -> Expectation
example (Expectation -> Expectation) -> Expectation -> Expectation
forall a b. (a -> b) -> a -> b
$ do
    let t :: Int
t = Int
50_000
    Int -> Expectation -> IO (Maybe ())
forall (m :: * -> *) a.
(HasCallStack, MonadUnliftIO m) =>
Int -> m a -> m (Maybe a)
laxTimeout Int
t (Int -> Expectation
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int
t Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2)) IO (Maybe ()) -> Maybe () -> Expectation
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation
`shouldReturn` Maybe ()
forall a. Maybe a
Nothing

  [Char] -> Spec -> Spec
forall a. HasCallStack => [Char] -> SpecWith a -> SpecWith a
describe [Char]
"withService" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ (Expectation -> Expectation) -> Spec -> Spec
forall a. (Expectation -> Expectation) -> SpecWith a -> SpecWith a
around_ (Int -> Expectation -> Expectation
forall (m :: * -> *) a.
(HasCallStack, MonadUnliftIO m) =>
Int -> m a -> m a
laxTimeout' Int
100_000) (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    let wait :: b -> Expectation
wait = Expectation -> b -> Expectation
forall a b. a -> b -> a
const (Expectation -> b -> Expectation)
-> Expectation -> b -> Expectation
forall a b. (a -> b) -> a -> b
$ Int -> Expectation
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay Int
forall a. Bounded a => a
maxBound
    [Char] -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
[Char] -> a -> SpecWith (Arg a)
it [Char]
"normal" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ Expectation -> Expectation
example (Expectation -> Expectation) -> Expectation -> Expectation
forall a b. (a -> b) -> a -> b
$
      ProcessConfig () () ()
-> (Process () () () -> Expectation) -> Expectation
forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withService ([Char] -> [[Char]] -> ProcessConfig () () ()
proc [Char]
"sleep" [[Char]
"60"]) (Expectation -> Process () () () -> Expectation
forall a b. a -> b -> a
const (Expectation -> Process () () () -> Expectation)
-> Expectation -> Process () () () -> Expectation
forall a b. (a -> b) -> a -> b
$ () -> Expectation
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
        Expectation -> () -> Expectation
forall a. (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation
`shouldReturn` ()
    [Char] -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
[Char] -> a -> SpecWith (Arg a)
it [Char]
"exc" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ Expectation -> Expectation
example (Expectation -> Expectation) -> Expectation -> Expectation
forall a b. (a -> b) -> a -> b
$
      ProcessConfig () () ()
-> (Process () () () -> IO (ZonkAny 0)) -> IO (ZonkAny 0)
forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withService ([Char] -> [[Char]] -> ProcessConfig () () ()
proc [Char]
"sleep" [[Char]
"60"]) (IO (ZonkAny 0) -> Process () () () -> IO (ZonkAny 0)
forall a b. a -> b -> a
const (IO (ZonkAny 0) -> Process () () () -> IO (ZonkAny 0))
-> IO (ZonkAny 0) -> Process () () () -> IO (ZonkAny 0)
forall a b. (a -> b) -> a -> b
$ [Char] -> IO (ZonkAny 0)
forall (m :: * -> *) a. (MonadIO m, HasCallStack) => [Char] -> m a
throwString [Char]
"hello")
        IO (ZonkAny 0) -> Selector StringException -> Expectation
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> Expectation
`shouldThrow` \(StringException [Char]
msg CallStack
_) -> [Char]
msg [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"hello"
    [Char] -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
[Char] -> a -> SpecWith (Arg a)
it [Char]
"early exit" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ Expectation -> Expectation
example (Expectation -> Expectation) -> Expectation -> Expectation
forall a b. (a -> b) -> a -> b
$
      ProcessConfig () () ()
-> (Process () () () -> Expectation) -> Expectation
forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withService ProcessConfig () () ()
"true" Process () () () -> Expectation
forall {b}. b -> Expectation
wait Expectation -> Selector ExitCodeException -> Expectation
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> Expectation
`shouldThrow`
        \ExitCodeException
exc -> ExitCodeException -> ExitCode
eceExitCode ExitCodeException
exc ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
    [Char] -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
[Char] -> a -> SpecWith (Arg a)
it [Char]
"manual exit" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ Expectation -> Expectation
example (Expectation -> Expectation) -> Expectation -> Expectation
forall a b. (a -> b) -> a -> b
$
      ProcessConfig Handle () ()
-> (Process Handle () () -> Expectation) -> Expectation
forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withService
        ([Char] -> [[Char]] -> ProcessConfig () () ()
proc [Char]
"cat" [] ProcessConfig () () ()
-> (ProcessConfig () () () -> ProcessConfig Handle () ())
-> ProcessConfig Handle () ()
forall a b. a -> (a -> b) -> b
& StreamSpec 'STInput Handle
-> ProcessConfig () () () -> ProcessConfig Handle () ()
forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin StreamSpec 'STInput Handle
forall (anyStreamType :: StreamType).
StreamSpec anyStreamType Handle
createPipe)
        (\Process Handle () ()
p -> Handle -> Expectation
hClose (Process Handle () () -> Handle
forall stdin stdout stderr. Process stdin stdout stderr -> stdin
getStdin Process Handle () ()
p) Expectation -> Expectation -> Expectation
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Process Handle () () -> Expectation
forall {b}. b -> Expectation
wait Process Handle () ()
p)
        Expectation -> Selector ExitCodeException -> Expectation
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> Expectation
`shouldThrow` \ExitCodeException
exc -> ExitCodeException -> ExitCode
eceExitCode ExitCodeException
exc ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
    [Char] -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
[Char] -> a -> SpecWith (Arg a)
it [Char]
"failure" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ Expectation -> Expectation
example (Expectation -> Expectation) -> Expectation -> Expectation
forall a b. (a -> b) -> a -> b
$
      ProcessConfig () () ()
-> (Process () () () -> Expectation) -> Expectation
forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withService ProcessConfig () () ()
"false" Process () () () -> Expectation
forall {b}. b -> Expectation
wait Expectation -> Selector ExitCodeException -> Expectation
forall e a.
(HasCallStack, Exception e) =>
IO a -> Selector e -> Expectation
`shouldThrow`
        \ExitCodeException
exc -> ExitCodeException -> ExitCode
eceExitCode ExitCodeException
exc ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
/= ExitCode
ExitSuccess
    [Char] -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
[Char] -> a -> SpecWith (Arg a)
it [Char]
"error message" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ Expectation -> Expectation
example (Expectation -> Expectation) -> Expectation -> Expectation
forall a b. (a -> b) -> a -> b
$ do
      res <- Expectation -> IO (Either ExitCodeException ())
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try (ProcessConfig () () ()
-> (Process () () () -> Expectation) -> Expectation
forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withService ([Char] -> [[Char]] -> ProcessConfig () () ()
proc [Char]
"false" [[Char]
"arg1", [Char]
"arg2"]) Process () () () -> Expectation
forall {b}. b -> Expectation
wait)
      res `shouldSatisfy` isLeft
      either (show . eceProcessConfig) show res
        `shouldBe` "Raw command: false arg1 arg2\n"