{-# LANGUAGE OverloadedStrings
#-}
import System.Environment
import System.Process (runInteractiveProcess, waitForProcess, ProcessHandle)
import System.IO (Handle, stderr, stdout, stdin, hClose)
import Data.ByteString (ByteString, pack, hGetContents)
import qualified Data.ByteString
import Data.ByteString.Char8 (unpack, hPutStrLn)
import qualified Data.ByteString.Char8 as Char8
import Data.Word
import Control.Applicative
import Control.Monad
import qualified Text.Printf
import Data.IORef
import Data.List
import Test.QuickCheck
import Test.QuickCheck.Monadic
import Text.ShellEscape hiding (sh, bash)
-- It is best to implement the echo test with `printf':
--
-- . Some echo implementations always interprete backslash escapes like \3
-- and give us no way to turn it off. Dash is like this.
--
-- . GNU echo can not be made to simply ignore options like `--help'.
--
-- The `printf' implementations available to me -- Bash and Dash --
-- consistently ignore backslash escape sequences and any options that follow
-- the format argument.
--
printf :: (Shell t, Escape t) => t -> IO ByteString
printf escaped = do
(i, o, e, p) <- shell escaped cmd
exit <- waitForProcess p
hGetContents o <* mapM_ hClose [i, o, e]
where
cmd = "printf '%s' " ++ unpack (bytes escaped)
prop_echoBash :: ByteString -> Property
prop_echoBash = something_prop escapeBash
prop_echoSh :: ByteString -> Property
prop_echoSh = something_prop escapeSh
something_prop esc b = monadicIO $ do
assert =<< run (test printf b (esc b))
escapeSh :: ByteString -> Sh
escapeSh b = escape b
escapeBash :: ByteString -> Bash
escapeBash b = escape b
test cmd original escaped = do
b <- cmd escaped
Data.ByteString.appendFile "./lengths" (displayLength original)
Data.ByteString.appendFile "./chars" (Char8.unlines $ displayBytes original)
when (b /= original) $ do
err "Result differs from unescaped result:"
err "Escaped form:"
err (Char8.unwords . displayBytes $ bytes escaped)
err "Output:"
err (Char8.unwords . displayBytes $ b)
err "Original:"
err (Char8.unwords . displayBytes $ original)
return (b == original)
displayBytes = fmap Char8.pack
. fmap (\w -> Text.Printf.printf "0x%02x" w)
. Data.ByteString.unpack
displayLength = Char8.pack
. (\w -> Text.Printf.printf "%4d\n" w)
. Data.ByteString.length
class (Escape t) => Shell t where
shell :: t -> String -> IO (Handle, Handle, Handle, ProcessHandle)
instance Shell Sh where
shell _ = sh
instance Shell Bash where
shell _ = bash
sh s = runInteractiveProcess "sh" ["-c", s] Nothing Nothing
bash s = runInteractiveProcess "bash" ["-c", s] Nothing Nothing
instance Arbitrary ByteString where
arbitrary = do
bytes <- arbitrary :: Gen [NonZero Word8]
NonEmpty bytes' <- arbitrary :: Gen (NonEmptyList (NonZero Word8))
pack `fmap` elements
(fmap unNonZero `fmap` [bytes', bytes', bytes, bytes', bytes'])
where
unNonZero (NonZero t) = t
main = do
runSh <- newIORef True
runBash <- newIORef True
testsR <- newIORef 10000
let testsRwrite = writeIORef testsR
noBash = writeIORef runBash False
noSh = writeIORef runSh False
args <- getArgs
case (sort . nub) args of
["--bash", "--sh", d] -> testsRwrite (read d)
["--bash", "--sh" ] -> return ()
["--bash", d] -> noSh >> testsRwrite (read d)
[ "--sh", d] -> noBash >> testsRwrite (read d)
[ d] -> testsRwrite (read d)
[ ] -> return ()
_ -> error "Invalid arguments."
tests <- readIORef testsR
let msg = "Performing " ++ show tests ++ " tests."
qcArgs = Args Nothing tests tests 32 False
qc = quickCheckWith qcArgs
err "Tests are random ByteStrings, containing any byte but null."
runSh ?> do
err "Testing Sh escaping."
err (Char8.pack msg)
qc prop_echoSh
runBash ?> do
err "Testing Bash escaping."
err (Char8.pack msg)
qc prop_echoBash
err = hPutStrLn stderr
(?>) :: IORef Bool -> IO () -> IO ()
ref ?> action = readIORef ref >>= (`when` action)