{-# LANGUAGE CPP, OverloadedStrings, ExtendedDefaultRules, RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Darcs.Test.Shell
( Format(..)
, DiffAlgorithm(..)
, UseIndex(..)
, UseCache(..)
, findShell
) where
import Darcs.Prelude
import Control.Exception ( SomeException )
import Data.Data ( Data, Typeable )
import Data.Text ( Text, pack, unpack )
import qualified Data.Text as T
import qualified Shelly ( FilePath, run )
import Shelly
( Sh
, catch_sh
, cd
, cp
, fromText
, get_env_text
, initOutputHandles
, lastExitCode
, lastStderr
, mkdir
, mkdir_p
, onCommandHandles
, pwd
, setenv
, shelly
, silently
, sub
, toTextIgnore
, withTmpDir
, writefile
, (</>)
)
import qualified System.FilePath as Native ( searchPathSeparator, splitSearchPath )
import System.FilePath ( makeRelative, takeBaseName, takeDirectory )
import qualified System.FilePath.Posix as Posix ( searchPathSeparator )
import System.IO ( hSetBinaryMode )
import Test.Framework.Providers.API
( Test(..)
, TestResultlike(..)
, Testlike(..)
, liftIO
, runImprovingIO
, yieldImprovement
)
data Format = Darcs1 | Darcs2 | Darcs3 deriving (Show, Eq, Typeable, Data)
data DiffAlgorithm = Myers | Patience deriving (Show, Eq, Typeable, Data)
data UseIndex = NoIndex | WithIndex deriving (Show, Eq, Typeable, Data)
data UseCache = NoCache | WithCache deriving (Show, Eq, Typeable, Data)
data ShellTest = ShellTest
{ format :: Format
, testfile :: FilePath
, testdir :: Maybe FilePath -- ^ only if you want to set it explicitly
, darcspath :: FilePath
, ghcflags :: String
, diffalgorithm :: DiffAlgorithm
, useindex :: UseIndex
, usecache :: UseCache
} deriving (Typeable)
data Running = Running deriving Show
data Result = Success | Skipped | Failed String
instance Show Result where
show Success = "Success"
show Skipped = "Skipped"
show (Failed f) = unlines (map ("| " ++) $ lines f)
instance TestResultlike Running Result where
testSucceeded Success = True
testSucceeded Skipped = True
testSucceeded _ = False
instance Testlike Running Result ShellTest where
testTypeName _ = "Shell"
runTest _ test =
runImprovingIO $ do
yieldImprovement Running
liftIO (shelly $ runtest test)
-- | Environment variable values may need translating depending on whether we
-- are setting them directly or writing out a shell script to set them, and
-- depending on the kind of value and the platform. This type captures the
-- different kinds of values.
data EnvItem
= EnvString String
-- ^ A normal string that won't need conversion
| EnvFilePath Shelly.FilePath
-- ^ A path on disk that may need conversion for the platform
| EnvSearchPath [Shelly.FilePath]
-- ^ A list of paths on disk, for the PATH variable
runtest' :: ShellTest -> Text -> Sh Result
runtest' ShellTest{..} srcdir =
do
wd <- pwd
p <- unpack <$> get_env_text "PATH"
let pathToUse =
map (fromText . pack) $ takeDirectory darcspath : Native.splitSearchPath p
let env =
[ ("HOME" , EnvFilePath wd)
-- in case someone has XDG_CACHE_HOME set:
, ("XDG_CACHE_HOME" , EnvFilePath (wd </> ".cache"))
, ("TESTDATA", EnvFilePath (srcdir </> "tests" </> "data"))
, ("TESTBIN", EnvFilePath (srcdir </> "tests" </> "bin"))
, ("DARCS_TESTING_PREFS_DIR" , EnvFilePath $ wd </> ".darcs")
, ("EMAIL" , EnvString "tester")
, ("GIT_AUTHOR_NAME" , EnvString "tester")
, ("GIT_AUTHOR_EMAIL" , EnvString "tester")
, ("GIT_COMMITTER_NAME" , EnvString "tester")
, ("GIT_COMMITTER_EMAIL" , EnvString "tester")
, ("DARCS_DONT_COLOR" , EnvString "1")
, ("DARCS_DONT_ESCAPE_ANYTHING", EnvString "1")
, ("PATH" , EnvSearchPath pathToUse)
-- the DARCS variable is passed to the tests purely so they can
-- double-check that the darcs on the path is the expected one,
-- so is passed as a string directly without any translation
, ("DARCS" , EnvString darcspath)
, ("GHC_FLAGS" , EnvString ghcflags)
, ("GHC_VERSION", EnvString $ show (__GLASGOW_HASKELL__ :: Int))
-- https://www.joshkel.com/2018/01/18/symlinks-in-windows/
, ("MSYS" , EnvString "winsymlinks:nativestrict")
]
-- we write the variables to a shell script and source them from there in
-- ./lib, so that it's easy to reproduce a test failure after running the
-- harness with -d.
writefile "env" $ T.unlines $ map
(\(k, v) -> T.concat ["export ", k, "=", envItemForScript v])
env
-- just in case the test script doesn't source ./lib:
mapM_ (\(k, v) -> setenv k (envItemForEnv v)) env
mkdir ".darcs"
writefile ".darcs/defaults" defaults
_ <-
onCommandHandles (initOutputHandles (\h -> hSetBinaryMode h True))
$ Shelly.run "bash" ["test"]
return Success
`catch_sh` \(_ :: SomeException) -> do
code <- lastExitCode
case code of
200 -> return Skipped
_ -> Failed <$> unpack <$> lastStderr
where
defaults =
pack
$ unlines
$ [ "ALL " ++ fmtstr
, "send no-edit-description"
, "ALL " ++ uif
, "ALL " ++ daf
]
++ ucf
fmtstr = case format of
Darcs3 -> "darcs-3"
Darcs2 -> "darcs-2"
Darcs1 -> "darcs-1"
daf = case diffalgorithm of
Patience -> "patience"
Myers -> "myers"
uif = case useindex of
WithIndex -> "no-ignore-times"
NoIndex -> "ignore-times"
ucf = case usecache of
WithCache -> []
NoCache -> ["ALL no-cache"]
-- convert an 'EnvItem' to a string you can put in the environment directly
envItemForEnv :: EnvItem -> Text
envItemForEnv (EnvString v) = pack v
envItemForEnv (EnvFilePath v) = toTextIgnore v
envItemForEnv (EnvSearchPath vs) =
T.intercalate (T.singleton Native.searchPathSeparator) $ map toTextIgnore vs
-- convert an 'EnvItem' to a string that will evaluate to the right value
-- when embedded in a bash script
envItemForScript :: EnvItem -> Text
envItemForScript (EnvString v) = quoteForShell (pack v)
envItemForScript (EnvFilePath v) = filePathForScript v
envItemForScript (EnvSearchPath vs) =
-- note the use of the Posix search path separator (':') regardless of platform
T.intercalate (T.singleton Posix.searchPathSeparator)
$ map filePathForScript vs
-- add quotes around a 'Shelly.FilePath'
quotedFilePath :: Shelly.FilePath -> Text
quotedFilePath = quoteForShell . toTextIgnore
quoteForShell :: Text -> Text
quoteForShell = surround '\'' . T.replace "'" "'\\''"
where surround c t = T.cons c $ T.snoc t c
-- convert a 'Shelly.FilePath' into a string that will evaluate to the right
-- value when put in a bash script
filePathForScript :: Shelly.FilePath -> Text
#ifdef WIN32
-- we have a native Windows path, but we are going to put it in an bash
-- script run in an environment like msys2 which works with an illusion
-- of a Unix style filesystem. Calling cygpath at runtime does the
-- necessary translation.
filePathForScript v = T.concat ["$(cygpath ", quotedFilePath v, ")"]
#else
filePathForScript v = quotedFilePath v
#endif
runtest :: ShellTest -> Sh Result
runtest test@ShellTest{..} =
withTmp $ \dir -> do
cp "tests/lib" dir
cp "tests/network/sshlib" dir
cp "tests/network/httplib" dir
cp (fromText $ pack $ testfile) (dir </> "test")
srcdir <- pwd
silently $ sub $ cd dir >> runtest' test (toTextIgnore srcdir)
where
withTmp =
case testdir of
Just dir ->
\job -> do
let d =
dir </> show format </> show diffalgorithm </>
show useindex </>
show usecache </>
takeTestName testfile
mkdir_p d
job d
Nothing -> withTmpDir
findShell
:: FilePath
-> [FilePath]
-> Maybe FilePath
-> String
-> [DiffAlgorithm]
-> [Format]
-> [UseIndex]
-> [UseCache]
-> IO [Test]
findShell dp files tdir ghcflags diffAlgorithms repoFormats useindexs usecaches =
do
return
[ shellTest
ShellTest
{ format = fmt
, testfile = file
, testdir = tdir
, darcspath = dp
, ghcflags = ghcflags
, diffalgorithm = da
, useindex = ui
, usecache = uc
}
| file <- files
, fmt <- repoFormats
, da <- diffAlgorithms
, ui <- useindexs
, uc <- usecaches
]
shellTest :: ShellTest -> Test
shellTest test@ShellTest{..} = Test name test
where
name =
concat
[ unpack (toTextIgnore (takeTestName testfile))
, " ("
, show format
, ","
, show diffalgorithm
, ","
, show useindex
, ","
, show usecache
, ")"
]
takeTestName :: FilePath -> Shelly.FilePath
takeTestName n =
let n' = makeRelative "tests" n
in takeBaseName (takeDirectory n') </> takeBaseName n'