module Darcs.Repository.Test
( getTest
, runPosthook
, runPrehook
, testTentative
)
where
import Darcs.Prelude
import System.Exit ( ExitCode(..) )
import System.Process ( system )
import System.IO ( hPutStrLn, stderr )
import Control.Monad ( when )
import Darcs.Repository.Flags
( LeaveTestDir(..)
, Verbosity(..)
, SetScriptsExecutable(..)
, RunTest (..)
, HookConfig (..)
)
import Darcs.Repository.InternalTypes ( Repository, repoLocation )
import Darcs.Repository.Prefs ( getPrefval )
import Darcs.Repository.Pristine ( withTentative )
import Darcs.Repository.Working ( setScriptsExecutable )
import Darcs.Util.File ( withCurrentDirectory )
import Darcs.Util.Lock ( withTempDir, withPermDir )
import Darcs.Util.Path ( AbsolutePath )
import Darcs.Util.Progress ( debugMessage )
import Darcs.Util.Prompt ( askUser )
getTest :: Verbosity -> IO (IO ExitCode)
getTest :: Verbosity -> IO (IO ExitCode)
getTest Verbosity
verb =
let putInfo :: String -> IO ()
putInfo String
s = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verb Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
/= Verbosity
Quiet) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
s
in do
Maybe String
testline <- String -> IO (Maybe String)
getPrefval String
"test"
IO ExitCode -> IO (IO ExitCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (IO ExitCode -> IO (IO ExitCode))
-> IO ExitCode -> IO (IO ExitCode)
forall a b. (a -> b) -> a -> b
$
case Maybe String
testline of
Maybe String
Nothing -> ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess
Just String
testcode -> do
String -> IO ()
putInfo String
"Running test...\n"
String -> (String -> IO ()) -> IO ExitCode
runTest String
testcode String -> IO ()
putInfo
runPosthook :: HookConfig -> Verbosity -> AbsolutePath -> IO ExitCode
runPosthook :: HookConfig -> Verbosity -> AbsolutePath -> IO ExitCode
runPosthook (HookConfig Maybe String
mPostHook Bool
askPostHook) Verbosity
verb AbsolutePath
repodir
= do Maybe String
ph <- Maybe String -> Bool -> IO (Maybe String)
getPosthook Maybe String
mPostHook Bool
askPostHook
AbsolutePath -> IO ExitCode -> IO ExitCode
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory AbsolutePath
repodir (IO ExitCode -> IO ExitCode) -> IO ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> Maybe String -> IO ExitCode
runHook Verbosity
verb String
"Posthook" Maybe String
ph
getPosthook :: Maybe String -> Bool -> IO (Maybe String)
getPosthook :: Maybe String -> Bool -> IO (Maybe String)
getPosthook Maybe String
mPostHookCmd Bool
askPostHook =
case Maybe String
mPostHookCmd of
Maybe String
Nothing -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
Just String
command ->
if Bool
askPostHook
then do String -> IO ()
putStr (String
"\nThe following command is set to execute.\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"Execute the following command now (yes or no)?\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
commandString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n")
String
yorn <- String -> IO String
askUser String
""
case String
yorn of
(Char
'y':String
_) -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
command
String
_ -> String -> IO ()
putStrLn String
"Posthook cancelled..." IO () -> IO (Maybe String) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
else Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
command
runPrehook :: HookConfig -> Verbosity -> AbsolutePath -> IO ExitCode
runPrehook :: HookConfig -> Verbosity -> AbsolutePath -> IO ExitCode
runPrehook (HookConfig Maybe String
mPreHookCmd Bool
askPreHook) Verbosity
verb AbsolutePath
repodir =
do Maybe String
ph <- Maybe String -> Bool -> IO (Maybe String)
getPrehook Maybe String
mPreHookCmd Bool
askPreHook
AbsolutePath -> IO ExitCode -> IO ExitCode
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory AbsolutePath
repodir (IO ExitCode -> IO ExitCode) -> IO ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ Verbosity -> String -> Maybe String -> IO ExitCode
runHook Verbosity
verb String
"Prehook" Maybe String
ph
getPrehook :: Maybe String -> Bool -> IO (Maybe String)
getPrehook :: Maybe String -> Bool -> IO (Maybe String)
getPrehook Maybe String
mPreHookCmd Bool
askPreHook=
case Maybe String
mPreHookCmd of
Maybe String
Nothing -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
Just String
command ->
if Bool
askPreHook
then do String -> IO ()
putStr (String
"\nThe following command is set to execute.\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"Execute the following command now (yes or no)?\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
commandString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n")
String
yorn <- String -> IO String
askUser String
""
case String
yorn of
(Char
'y':String
_) -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
command
String
_ -> String -> IO ()
putStrLn String
"Prehook cancelled..." IO () -> IO (Maybe String) -> IO (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
else Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
command
runHook :: Verbosity -> String -> Maybe String -> IO ExitCode
runHook :: Verbosity -> String -> Maybe String -> IO ExitCode
runHook Verbosity
_ String
_ Maybe String
Nothing = ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess
runHook Verbosity
verb String
cname (Just String
command) =
do ExitCode
ec <- String -> IO ExitCode
system String
command
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verb Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
/= Verbosity
Quiet) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
if ExitCode
ec ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
cnameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" ran successfully."
else Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
cnameString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" failed!"
ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ec
testTentative :: Repository rt p wR wU wT
-> RunTest
-> LeaveTestDir
-> SetScriptsExecutable
-> Verbosity
-> IO ExitCode
testTentative :: Repository rt p wR wU wT
-> RunTest
-> LeaveTestDir
-> SetScriptsExecutable
-> Verbosity
-> IO ExitCode
testTentative = (Repository rt p wR wU wT
-> ((AbsolutePath -> IO ExitCode) -> IO ExitCode)
-> (AbsolutePath -> IO ExitCode)
-> IO ExitCode)
-> Repository rt p wR wU wT
-> RunTest
-> LeaveTestDir
-> SetScriptsExecutable
-> Verbosity
-> IO ExitCode
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(Repository rt p wR wU wT
-> ((AbsolutePath -> IO ExitCode) -> IO ExitCode)
-> (AbsolutePath -> IO ExitCode)
-> IO ExitCode)
-> Repository rt p wR wU wT
-> RunTest
-> LeaveTestDir
-> SetScriptsExecutable
-> Verbosity
-> IO ExitCode
testAny Repository rt p wR wU wT
-> ((AbsolutePath -> IO ExitCode) -> IO ExitCode)
-> (AbsolutePath -> IO ExitCode)
-> IO ExitCode
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT a.
Repository rt p wR wU wT
-> ((AbsolutePath -> IO a) -> IO a)
-> (AbsolutePath -> IO a)
-> IO a
withTentative
runTest :: String -> (String -> IO ()) -> IO ExitCode
runTest :: String -> (String -> IO ()) -> IO ExitCode
runTest String
testcode String -> IO ()
putInfo = do
ExitCode
ec <- String -> IO ExitCode
system String
testcode
if ExitCode
ec ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then String -> IO ()
putInfo String
"Test ran successfully.\n"
else String -> IO ()
putInfo String
"Test failed!\n"
ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ec
testAny :: (Repository rt p wR wU wT
-> ((AbsolutePath -> IO ExitCode) -> IO ExitCode)
-> (AbsolutePath -> IO ExitCode) -> IO ExitCode
)
-> Repository rt p wR wU wT
-> RunTest
-> LeaveTestDir
-> SetScriptsExecutable
-> Verbosity
-> IO ExitCode
testAny :: (Repository rt p wR wU wT
-> ((AbsolutePath -> IO ExitCode) -> IO ExitCode)
-> (AbsolutePath -> IO ExitCode)
-> IO ExitCode)
-> Repository rt p wR wU wT
-> RunTest
-> LeaveTestDir
-> SetScriptsExecutable
-> Verbosity
-> IO ExitCode
testAny Repository rt p wR wU wT
-> ((AbsolutePath -> IO ExitCode) -> IO ExitCode)
-> (AbsolutePath -> IO ExitCode)
-> IO ExitCode
withD Repository rt p wR wU wT
repository RunTest
doRunTest LeaveTestDir
ltd SetScriptsExecutable
sse Verbosity
verb =
String -> IO ()
debugMessage String
"Considering whether to test..." IO () -> IO ExitCode -> IO ExitCode
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
if RunTest
doRunTest RunTest -> RunTest -> Bool
forall a. Eq a => a -> a -> Bool
== RunTest
NoRunTest
then ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess
else String -> IO ExitCode -> IO ExitCode
forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory (Repository rt p wR wU wT -> String
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> String
repoLocation Repository rt p wR wU wT
repository) (IO ExitCode -> IO ExitCode) -> IO ExitCode -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ do
let putInfo :: String -> IO ()
putInfo = if Verbosity
verb Verbosity -> Verbosity -> Bool
forall a. Eq a => a -> a -> Bool
== Verbosity
Quiet then IO () -> String -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) else String -> IO ()
putStrLn
String -> IO ()
debugMessage String
"About to run test if it exists."
Maybe String
testline <- String -> IO (Maybe String)
getPrefval String
"test"
case Maybe String
testline of
Maybe String
Nothing -> ExitCode -> IO ExitCode
forall (m :: * -> *) a. Monad m => a -> m a
return ExitCode
ExitSuccess
Just String
testcode ->
Repository rt p wR wU wT
-> ((AbsolutePath -> IO ExitCode) -> IO ExitCode)
-> (AbsolutePath -> IO ExitCode)
-> IO ExitCode
withD Repository rt p wR wU wT
repository (String -> (AbsolutePath -> IO ExitCode) -> IO ExitCode
forall a. String -> (AbsolutePath -> IO a) -> IO a
wd String
"testing") ((AbsolutePath -> IO ExitCode) -> IO ExitCode)
-> (AbsolutePath -> IO ExitCode) -> IO ExitCode
forall a b. (a -> b) -> a -> b
$ \AbsolutePath
_ ->
do String -> IO ()
putInfo String
"Running test...\n"
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SetScriptsExecutable
sse SetScriptsExecutable -> SetScriptsExecutable -> Bool
forall a. Eq a => a -> a -> Bool
== SetScriptsExecutable
YesSetScriptsExecutable) IO ()
setScriptsExecutable
String -> (String -> IO ()) -> IO ExitCode
runTest String
testcode String -> IO ()
putInfo
where wd :: String -> (AbsolutePath -> IO a) -> IO a
wd = if LeaveTestDir
ltd LeaveTestDir -> LeaveTestDir -> Bool
forall a. Eq a => a -> a -> Bool
== LeaveTestDir
YesLeaveTestDir then String -> (AbsolutePath -> IO a) -> IO a
forall a. String -> (AbsolutePath -> IO a) -> IO a
withPermDir else String -> (AbsolutePath -> IO a) -> IO a
forall a. String -> (AbsolutePath -> IO a) -> IO a
withTempDir