--  Copyright (C) 2002-2005 David Roundy
--
--  This program is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2, or (at your option)
--  any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program; see the file COPYING.  If not, write to
--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
--  Boston, MA 02110-1301, USA.

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