module Shelly
(
Sh, ShIO, shelly, shellyNoDir, sub, silently, verbosely, escaping, print_stdout, print_commands, tracing, errExit
, run, run_, runFoldLines, cmd, FoldCallback
, (-|-), lastStderr, setStdin, lastExitCode
, command, command_, command1, command1_
, sshPairs, sshPairs_
, ShellArg (..)
, runHandle, runHandles, transferLinesAndCombine, transferFoldHandleLines
, StdHandle(..), StdStream(..)
, setenv, get_env, get_env_text, getenv, get_env_def, appendToPath
, cd, chdir, pwd
, echo, echo_n, echo_err, echo_n_err, inspect, inspect_err
, tag, trace, show_command
, ls, lsT, test_e, test_f, test_d, test_s, which
, absPath, (</>), (<.>), canonic, canonicalize, relPath, relativeTo, path
, hasExt
, mv, rm, rm_f, rm_rf, cp, cp_r, mkdir, mkdir_p, mkdirTree
, readfile, readBinary, writefile, appendfile, touchfile, withTmpDir
, exit, errorExit, quietExit, terror
, catchany, catch_sh, finally_sh, ShellyHandler(..), catches_sh, catchany_sh
, toTextIgnore, toTextWarn, fromText
, whenM, unlessM, time, sleep
, liftIO, when, unless, FilePath, (<$>)
, get, put
, find, findWhen, findFold, findDirFilter, findDirFilterWhen, findFoldDirFilter
) where
import Shelly.Base
import Shelly.Find
import Control.Monad ( when, unless, void, forM, filterM )
import Control.Monad.Trans ( MonadIO )
import Control.Monad.Reader (ask)
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706
import Prelude hiding ( readFile, FilePath, catch)
#else
import Prelude hiding ( readFile, FilePath)
#endif
import Data.Char ( isAlphaNum, isSpace )
import Data.Typeable
import Data.IORef
import Data.Sequence (Seq, (|>))
import Data.Foldable (foldl')
import Data.Maybe
import System.IO ( hClose, stderr, stdout, openTempFile )
import System.IO.Error (isPermissionError, catchIOError, isEOFError, isIllegalOperation)
import System.Exit
import System.Environment
import Control.Applicative
import Control.Exception hiding (handle)
import Control.Concurrent
import Data.Time.Clock( getCurrentTime, diffUTCTime )
import qualified Data.Text.IO as TIO
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding.Error as TE
import System.Process( CmdSpec(..), StdStream(CreatePipe, UseHandle), CreateProcess(..), createProcess, waitForProcess, terminateProcess, ProcessHandle, StdStream(..) )
import qualified Data.Text as T
import qualified Data.ByteString as BS
import Data.ByteString (ByteString)
import Data.Monoid (Monoid, mempty, mappend)
#if __GLASGOW_HASKELL__ < 704
infixr 5 <>
(<>) :: Monoid m => m -> m -> m
(<>) = mappend
#else
import Data.Monoid ((<>))
#endif
import Filesystem.Path.CurrentOS hiding (concat, fromText, (</>), (<.>))
import Filesystem hiding (canonicalizePath)
import qualified Filesystem.Path.CurrentOS as FP
import System.Directory ( setPermissions, getPermissions, Permissions(..), getTemporaryDirectory )
import Data.Char (isDigit)
import Data.Tree(Tree(..))
import qualified Data.Set as S
import qualified Data.List as L
searchPathSeparator :: Char
#if defined(mingw32_HOST_OS)
searchPathSeparator = ';'
#else
searchPathSeparator = ':'
#endif
class ShellArg a where toTextArg :: a -> Text
instance ShellArg Text where toTextArg = id
instance ShellArg FilePath where toTextArg = toTextIgnore
instance ShellArg String where toTextArg = T.pack
class ShellCommand t where
cmdAll :: FilePath -> [Text] -> t
instance ShellCommand (Sh Text) where
cmdAll = run
instance (s ~ Text, Show s) => ShellCommand (Sh s) where
cmdAll = run
instance ShellCommand (Sh ()) where
cmdAll = run_
instance (ShellArg arg, ShellCommand result) => ShellCommand (arg -> result) where
cmdAll fp acc x = cmdAll fp (acc ++ [toTextArg x])
cmd :: (ShellCommand result) => FilePath -> result
cmd fp = cmdAll fp []
class ToFilePath a where
toFilePath :: a -> FilePath
instance ToFilePath FilePath where toFilePath = id
instance ToFilePath Text where toFilePath = FP.fromText
instance ToFilePath String where toFilePath = FP.fromText . T.pack
(</>) :: (ToFilePath filepath1, ToFilePath filepath2) => filepath1 -> filepath2 -> FilePath
x </> y = toFilePath x FP.</> toFilePath y
(<.>) :: (ToFilePath filepath) => filepath -> Text -> FilePath
x <.> y = toFilePath x FP.<.> y
toTextWarn :: FilePath -> Sh Text
toTextWarn efile = case toText efile of
Left f -> encodeError f >> return f
Right f -> return f
where
encodeError f = echo ("Invalid encoding for file: " <> f)
fromText :: Text -> FilePath
fromText = FP.fromText
transferLinesAndCombine :: Handle -> Handle -> IO Text
transferLinesAndCombine h1 h2 = transferFoldHandleLines mempty (|>) h1 h2 >>=
return . lineSeqToText
lineSeqToText :: Seq Text -> Text
lineSeqToText = T.intercalate "\n" . foldl' (flip (:)) []
type FoldCallback a = (a -> Text -> a)
transferFoldHandleLines :: a -> FoldCallback a -> Handle -> Handle -> IO a
transferFoldHandleLines start foldLine readHandle writeHandle = go start
where
catchIOErrors action = catchIOError
(fmap Just action)
(\e -> if isEOFError e || isIllegalOperation e
then return Nothing
else ioError e)
go acc = do
mLine <- catchIOErrors (TIO.hGetLine readHandle)
case mLine of
Nothing -> return acc
Just line -> TIO.hPutStrLn writeHandle line >> go (foldLine acc line)
foldHandleLines :: a -> FoldCallback a -> Handle -> IO a
foldHandleLines start foldLine readHandle = go start
where
go acc = do
line <- TIO.hGetLine readHandle
go $ foldLine acc line
`catchany` \_ -> return acc
tag :: Sh a -> Text -> Sh a
tag action msg = do
trace msg
action
put :: State -> Sh ()
put newState = do
stateVar <- ask
liftIO (writeIORef stateVar newState)
runCommandNoEscape :: [StdHandle] -> State -> FilePath -> [Text] -> Sh (Handle, Handle, Handle, ProcessHandle)
runCommandNoEscape handles st exe args = liftIO $ shellyProcess handles st $
ShellCommand $ T.unpack $ T.intercalate " " (toTextIgnore exe : args)
runCommand :: [StdHandle] -> State -> FilePath -> [Text] -> Sh (Handle, Handle, Handle, ProcessHandle)
runCommand handles st exe args = findExe exe >>= \fullExe ->
liftIO $ shellyProcess handles st $
RawCommand (unpack fullExe) (map T.unpack args)
where
findExe :: FilePath -> Sh FilePath
findExe fp = do
#if defined(mingw32_HOST_OS)
let fullExe = case extension fp of
Nothing -> fp <.> "exe"
Just _ -> fp
mExe <- which fullExe
return $ case mExe of
Just execFp -> execFp
Nothing -> fp
#else
mExe <- which exe
case mExe of
Just execFp -> return execFp
Nothing -> liftIO $ throwIO $ userError $
"shelly did not find " `mappend` encodeString fp `mappend`
if absolute exe then "" else " in the PATH"
#endif
shellyProcess :: [StdHandle] -> State -> CmdSpec -> IO (Handle, Handle, Handle, ProcessHandle)
shellyProcess reusedHandles st cmdSpec = do
(createdInH, createdOutH, createdErrorH, pHandle) <- createProcess CreateProcess {
cmdspec = cmdSpec
, cwd = Just $ unpack $ sDirectory st
, env = Just $ sEnvironment st
, std_in = createUnless mInH
, std_out = createUnless mOutH
, std_err = createUnless mErrorH
, close_fds = False
#if MIN_VERSION_process(1,1,0)
, create_group = False
#endif
}
return ( just $ createdInH <|> toHandle mInH
, just $ createdOutH <|> toHandle mOutH
, just $ createdErrorH <|> toHandle mErrorH
, pHandle
)
where
just :: Maybe a -> a
just Nothing = error "error in shelly creating process"
just (Just j) = j
toHandle (Just (UseHandle h)) = Just h
toHandle (Just CreatePipe) = error "shelly process creation failure CreatePIpe"
toHandle (Just Inherit) = error "cannot access an inherited pipe"
toHandle Nothing = error "error in shelly creating process"
createUnless Nothing = CreatePipe
createUnless (Just stream) = stream
mInH = getStream mIn reusedHandles
mOutH = getStream mOut reusedHandles
mErrorH = getStream mError reusedHandles
getStream :: (StdHandle -> Maybe StdStream) -> [StdHandle] -> Maybe StdStream
getStream _ [] = Nothing
getStream mHandle (h:hs) = mHandle h <|> getStream mHandle hs
mIn, mOut, mError :: (StdHandle -> Maybe StdStream)
mIn (InHandle h) = Just h
mIn _ = Nothing
mOut (OutHandle h) = Just h
mOut _ = Nothing
mError (ErrorHandle h) = Just h
mError _ = Nothing
catch_sh :: (Exception e) => Sh a -> (e -> Sh a) -> Sh a
catch_sh action handle = do
ref <- ask
liftIO $ catch (runSh action ref) (\e -> runSh (handle e) ref)
finally_sh :: Sh a -> Sh b -> Sh a
finally_sh action handle = do
ref <- ask
liftIO $ finally (runSh action ref) (runSh handle ref)
data ShellyHandler a = forall e . Exception e => ShellyHandler (e -> Sh a)
catches_sh :: Sh a -> [ShellyHandler a] -> Sh a
catches_sh action handlers = do
ref <- ask
let runner a = runSh a ref
liftIO $ catches (runner action) $ map (toHandler runner) handlers
where
toHandler :: (Sh a -> IO a) -> ShellyHandler a -> Handler a
toHandler runner (ShellyHandler handle) = Handler (\e -> runner (handle e))
catchany_sh :: Sh a -> (SomeException -> Sh a) -> Sh a
catchany_sh = catch_sh
cd :: FilePath -> Sh ()
cd = canonic >=> cd'
where
cd' dir = do
trace $ "cd " <> tdir
unlessM (test_d dir) $ errorExit $ "not a directory: " <> tdir
modify $ \st -> st { sDirectory = dir, sPathExecutables = Nothing }
where
tdir = toTextIgnore dir
chdir :: FilePath -> Sh a -> Sh a
chdir dir action = do
d <- gets sDirectory
cd dir
action `finally_sh` cd d
chdir_p :: FilePath -> Sh a -> Sh a
chdir_p d action = mkdir_p d >> chdir d action
pack :: String -> FilePath
pack = decodeString
mv :: FilePath -> FilePath -> Sh ()
mv from' to' = do
from <- absPath from'
to <- absPath to'
trace $ "mv " <> toTextIgnore from <> " " <> toTextIgnore to
to_dir <- test_d to
let to_loc = if not to_dir then to else to FP.</> filename from
liftIO $ rename from to_loc
`catchany` (\e -> throwIO $
ReThrownException e (extraMsg to_loc from)
)
where
extraMsg t f = "during copy from: " ++ unpack f ++ " to: " ++ unpack t
lsT :: FilePath -> Sh [Text]
lsT = ls >=> mapM toTextWarn
pwd :: Sh FilePath
pwd = gets sDirectory `tag` "pwd"
exit :: Int -> Sh a
exit 0 = liftIO exitSuccess `tag` "exit 0"
exit n = liftIO (exitWith (ExitFailure n)) `tag` ("exit " <> T.pack (show n))
errorExit :: Text -> Sh a
errorExit msg = echo msg >> exit 1
quietExit :: Int -> Sh a
quietExit 0 = exit 0
quietExit n = throw $ QuietExit n
terror :: Text -> Sh a
terror = fail . T.unpack
mkdir :: FilePath -> Sh ()
mkdir = absPath >=> \fp -> do
trace $ "mkdir " <> toTextIgnore fp
liftIO $ createDirectory False fp
mkdir_p :: FilePath -> Sh ()
mkdir_p = absPath >=> \fp -> do
trace $ "mkdir -p " <> toTextIgnore fp
liftIO $ createTree fp
mkdirTree :: Tree FilePath -> Sh ()
mkdirTree = mk . unrollPath
where mk :: Tree FilePath -> Sh ()
mk (Node a ts) = do
b <- test_d a
unless b $ mkdir a
chdir a $ mapM_ mkdirTree ts
unrollPath :: Tree FilePath -> Tree FilePath
unrollPath (Node v ts) = unrollRoot v $ map unrollPath ts
where unrollRoot x = foldr1 phi $ map Node $ splitDirectories x
phi a b = a . return . b
which :: FilePath -> Sh (Maybe FilePath)
which fp = (trace . mappend "which " . toTextIgnore) fp >> whichUntraced
where
whichUntraced | absolute fp = checkFile
| length (splitDirectories fp) > 0 = lookupPath
| otherwise = lookupCache
checkFile = do
exists <- liftIO $ isFile fp
return $ if exists then Just fp else Nothing
lookupPath =
pathDirs >>= findMapM (\dir -> do
let fullFp = dir </> fp
res <- liftIO $ isExecutable $ encodeString $ fullFp
return $ if res then Just fullFp else Nothing
)
lookupCache = do
pathExecutables <- cachedPathExecutables
liftIO $ print pathExecutables
return $ fmap (flip (</>) fp . fst) $
L.find (S.member fp . snd) pathExecutables
pathDirs = mapM absPath =<< ((map fromText . T.split (== searchPathSeparator)) `fmap` get_env_text "PATH")
isExecutable f = (executable `fmap` getPermissions f) `catch`
(\(_ :: IOError) -> return False)
cachedPathExecutables :: Sh [(FilePath, S.Set FilePath)]
cachedPathExecutables = do
mPathExecutables <- gets sPathExecutables
case mPathExecutables of
Just pExecutables -> return pExecutables
Nothing -> do
dirs <- pathDirs
executables <- forM dirs (\dir -> do
files <- (liftIO . listDirectory) dir `catch_sh` (\(_ :: IOError) -> return [])
exes <- fmap (map snd) $ liftIO $ filterM (isExecutable . fst) $
map (\f -> (encodeString f, filename f)) files
return $ S.fromList exes
)
let cachedExecutables = zip dirs executables
modify $ \x -> x { sPathExecutables = Just cachedExecutables }
return $ cachedExecutables
findMapM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b)
findMapM _ [] = return Nothing
findMapM f (x:xs) =
do
mb <- f x
if (isJust mb)
then return mb
else findMapM f xs
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM c a = c >>= \res -> unless res a
test_e :: FilePath -> Sh Bool
test_e = absPath >=> \f ->
liftIO $ do
file <- isFile f
if file then return True else isDirectory f
test_f :: FilePath -> Sh Bool
test_f = absPath >=> liftIO . isFile
rm_rf :: FilePath -> Sh ()
rm_rf = absPath >=> \f -> do
trace $ "rm -rf " <> toTextIgnore f
isDir <- (test_d f)
if not isDir then whenM (test_f f) $ rm_f f
else
(liftIO_ $ removeTree f) `catch_sh` (\(e :: IOError) ->
when (isPermissionError e) $ do
find f >>= mapM_ (\file -> liftIO_ $ fixPermissions (unpack file) `catchany` \_ -> return ())
liftIO $ removeTree f
)
where fixPermissions file =
do permissions <- liftIO $ getPermissions file
let deletable = permissions { readable = True, writable = True, executable = True }
liftIO $ setPermissions file deletable
rm_f :: FilePath -> Sh ()
rm_f = absPath >=> \f -> do
trace $ "rm -f " <> toTextIgnore f
whenM (test_e f) $ canonic f >>= liftIO . removeFile
rm :: FilePath -> Sh ()
rm = absPath >=> \f -> do
trace $ "rm" <> toTextIgnore f
canonic f >>= liftIO . removeFile
setenv :: Text -> Text -> Sh ()
setenv k v =
if k == path_env then setPath v else do
let (kStr, vStr) = (T.unpack k, T.unpack v)
wibble environment = (kStr, vStr) : filter ((/=kStr) . fst) environment
in modify $ \x -> x { sEnvironment = wibble $ sEnvironment x }
setPath :: Text -> Sh ()
setPath newPath = do
modify $ \x -> x{ sPathExecutables = Nothing }
setenv path_env newPath
path_env :: Text
path_env = "PATH"
appendToPath :: FilePath -> Sh ()
appendToPath = absPath >=> \filepath -> do
tp <- toTextWarn filepath
pe <- get_env_text path_env
setPath $ pe <> T.singleton searchPathSeparator <> tp
get_env :: Text -> Sh (Maybe Text)
get_env k = do
mval <- return . fmap T.pack . lookup (T.unpack k) =<< gets sEnvironment
return $ case mval of
Nothing -> Nothing
j@(Just val) -> if T.null val then Nothing else j
getenv :: Text -> Sh Text
getenv k = get_env_def k ""
get_env_text :: Text -> Sh Text
get_env_text = get_env_def ""
get_env_def :: Text -> Text -> Sh Text
get_env_def d = get_env >=> return . fromMaybe d
silently :: Sh a -> Sh a
silently a = sub $ modify (\x -> x { sPrintStdout = False, sPrintCommands = False }) >> a
verbosely :: Sh a -> Sh a
verbosely a = sub $ modify (\x -> x { sPrintStdout = True, sPrintCommands = True }) >> a
print_stdout :: Bool -> Sh a -> Sh a
print_stdout shouldPrint a = sub $ modify (\x -> x { sPrintStdout = shouldPrint }) >> a
print_commands :: Bool -> Sh a -> Sh a
print_commands shouldPrint a = sub $ modify (\st -> st { sPrintCommands = shouldPrint }) >> a
sub :: Sh a -> Sh a
sub a = do
oldState <- get
modify $ \st -> st { sTrace = T.empty }
a `finally_sh` restoreState oldState
where
restoreState oldState = do
newState <- get
put oldState {
sTrace = sTrace oldState <> sTrace newState
, sCode = sCode newState
, sStderr = sStderr newState
, sStdin = sStdin newState
}
tracing :: Bool -> Sh a -> Sh a
tracing shouldTrace action = sub $ do
modify $ \st -> st { sTracing = shouldTrace }
action
escaping :: Bool -> Sh a -> Sh a
escaping shouldEscape action = sub $ do
modify $ \st -> st { sRun =
if shouldEscape then runCommand else runCommandNoEscape
}
action
errExit :: Bool -> Sh a -> Sh a
errExit shouldExit action = sub $ do
modify $ \st -> st { sErrExit = shouldExit }
action
data ShellyOpts = ShellyOpts { failToDir :: Bool }
shellyOpts :: ShellyOpts
shellyOpts = ShellyOpts { failToDir = True }
shellyNoDir :: MonadIO m => Sh a -> m a
shellyNoDir = shelly' shellyOpts { failToDir = False }
shelly :: MonadIO m => Sh a -> m a
shelly = shelly' shellyOpts
shelly' :: MonadIO m => ShellyOpts -> Sh a -> m a
shelly' opts action = do
environment <- liftIO getEnvironment
dir <- liftIO getWorkingDirectory
let def = State { sCode = 0
, sStdin = Nothing
, sStderr = T.empty
, sPrintStdout = True
, sPrintCommands = False
, sRun = runCommand
, sEnvironment = environment
, sTracing = True
, sTrace = T.empty
, sDirectory = dir
, sPathExecutables = Nothing
, sErrExit = True
}
stref <- liftIO $ newIORef def
let caught =
action `catches_sh` [
ShellyHandler (\ex ->
case ex of
ExitSuccess -> liftIO $ throwIO ex
ExitFailure _ -> throwExplainedException ex
)
, ShellyHandler (\ex -> case ex of
QuietExit n -> liftIO $ throwIO $ ExitFailure n)
, ShellyHandler (\(ex::SomeException) -> throwExplainedException ex)
]
liftIO $ runSh caught stref
where
throwExplainedException :: Exception exception => exception -> Sh a
throwExplainedException ex = get >>= errorMsg >>= liftIO . throwIO . ReThrownException ex
errorMsg st =
if not (failToDir opts) then ranCommands else do
d <- pwd
sf <- shellyFile
let logFile = d</>shelly_dir</>sf
(writefile logFile trc >> return ("log of commands saved to: " <> encodeString logFile))
`catchany_sh` (\_ -> ranCommands)
where
trc = sTrace st
ranCommands = return . mappend "Ran commands: \n" . T.unpack $ trc
shelly_dir = ".shelly"
shellyFile = chdir_p shelly_dir $ do
fs <- ls "."
return $ pack $ show (nextNum fs) <> ".txt"
nextNum :: [FilePath] -> Int
nextNum [] = 1
nextNum fs = (+ 1) . maximum . map (readDef 1 . filter isDigit . unpack . filename) $ fs
readDef :: Read a => a -> String -> a
readDef def = fromMaybe def . readMay
where
readMay :: Read a => String -> Maybe a
readMay s = case [x | (x,t) <- reads s, ("","") <- lex t] of
[x] -> Just x
_ -> Nothing
data RunFailed = RunFailed FilePath [Text] Int Text deriving (Typeable)
instance Show RunFailed where
show (RunFailed exe args code errs) =
let codeMsg = case code of
127 -> ". exit code 127 usually means the command does not exist (in the PATH)"
_ -> ""
in "error running: " ++ T.unpack (show_command exe args) ++
"\nexit status: " ++ show code ++ codeMsg ++ "\nstderr: " ++ T.unpack errs
instance Exception RunFailed
show_command :: FilePath -> [Text] -> Text
show_command exe args =
T.intercalate " " $ map quote (toTextIgnore exe : args)
where
quote t | T.any (== '\'') t = t
quote t | T.any isSpace t = surround '\'' t
quote t | otherwise = t
surround :: Char -> Text -> Text
surround c t = T.cons c $ T.snoc t c
sshPairs_ :: Text -> [(FilePath, [Text])] -> Sh ()
sshPairs_ _ [] = return ()
sshPairs_ server cmds = sshPairs' run_ server cmds
sshPairs :: Text -> [(FilePath, [Text])] -> Sh Text
sshPairs _ [] = return ""
sshPairs server cmds = sshPairs' run server cmds
sshPairs' :: (FilePath -> [Text] -> Sh a) -> Text -> [(FilePath, [Text])] -> Sh a
sshPairs' run' server actions = escaping False $ do
let ssh_commands = surround '\'' $ foldl1
(\memo next -> memo <> " && " <> next)
(map toSSH actions)
run' "ssh" [server, ssh_commands]
where
toSSH (exe,args) = show_command exe args
data QuietExit = QuietExit Int deriving (Show, Typeable)
instance Exception QuietExit
data ReThrownException e = ReThrownException e String deriving (Typeable)
instance Exception e => Exception (ReThrownException e)
instance Exception e => Show (ReThrownException e) where
show (ReThrownException ex msg) = "\n" ++
msg ++ "\n" ++ "Exception: " ++ show ex
run :: FilePath -> [Text] -> Sh Text
run fp args = return . lineSeqToText =<< runFoldLines mempty (|>) fp args
command :: FilePath -> [Text] -> [Text] -> Sh Text
command com args more_args = run com (args ++ more_args)
command_ :: FilePath -> [Text] -> [Text] -> Sh ()
command_ com args more_args = run_ com (args ++ more_args)
command1 :: FilePath -> [Text] -> Text -> [Text] -> Sh Text
command1 com args one_arg more_args = run com ([one_arg] ++ args ++ more_args)
command1_ :: FilePath -> [Text] -> Text -> [Text] -> Sh ()
command1_ com args one_arg more_args = run_ com ([one_arg] ++ args ++ more_args)
run_ :: FilePath -> [Text] -> Sh ()
run_ = runFoldLines () (\_ _ -> ())
liftIO_ :: IO a -> Sh ()
liftIO_ action = void (liftIO action)
runHandle :: FilePath
-> [Text]
-> (Handle -> Sh a)
-> Sh a
runHandle exe args withHandle =
runHandles exe args [] $ \_ outH errH -> do
errVar <- liftIO $ do
errVar' <- newEmptyMVar
_ <- forkIO $ transferLinesAndCombine errH stderr >>= putMVar errVar'
return errVar'
res <- withHandle outH
errs <- liftIO $ takeMVar errVar
modify $ \state' -> state' { sStderr = errs }
return res
runHandles :: FilePath
-> [Text]
-> [StdHandle]
-> (Handle -> Handle -> Handle -> Sh a)
-> Sh a
runHandles exe args reusedHandles withHandles = do
origstate <- get
let mStdin = sStdin origstate
put $ origstate { sStdin = Nothing, sCode = 0, sStderr = T.empty }
state <- get
let cmdString = show_command exe args
when (sPrintCommands state) $ echo cmdString
trace cmdString
bracketOnWindowsError
((sRun state) reusedHandles state exe args)
(\(_,_,_,procH) -> (liftIO $ terminateProcess procH))
(\(inH,outH,errH,procH) -> do
liftIO $ case mStdin of
Just input -> TIO.hPutStr inH input
Nothing -> return ()
result <- withHandles inH outH errH
(ex, code) <- liftIO $ do
ex' <- waitForProcess procH
hClose outH `catchany` (const $ return ())
hClose errH `catchany` (const $ return ())
hClose inH `catchany` (const $ return ())
return $ case ex' of
ExitSuccess -> (ex', 0)
ExitFailure n -> (ex', n)
modify $ \state' -> state' { sCode = code }
case (sErrExit state, ex) of
(True, ExitFailure n) -> do
newState <- get
liftIO $ throwIO $ RunFailed exe args n (sStderr newState)
_ -> return result
)
where
#if defined(mingw32_HOST_OS)
bracketOnWindowsError acquire release main = do
resource <- acquire
main resource `catchany_sh` (\e -> do
_ <- release resource
liftIO $ throwIO e
)
#else
bracketOnWindowsError :: Sh a -> (a -> Sh ()) -> (a -> Sh b) -> Sh b
bracketOnWindowsError acquire _ main = acquire >>= main
#endif
runFoldLines :: a -> FoldCallback a -> FilePath -> [Text] -> Sh a
runFoldLines start cb exe args =
runHandles exe args [] $ \inH outH errH -> do
(errVar, outVar) <- liftIO $ do
hClose inH
errVar' <- newEmptyMVar
outVar' <- newEmptyMVar
_ <- forkIO $ transferLinesAndCombine errH stderr >>= putMVar errVar'
return (errVar', outVar')
state <- get
errs <- liftIO $ do
void $ if sPrintStdout state
then
forkIO $ transferFoldHandleLines start cb outH stdout >>= putMVar outVar
else
forkIO $ foldHandleLines start cb outH >>= putMVar outVar
takeMVar errVar
modify $ \state' -> state' { sStderr = errs }
liftIO $ takeMVar outVar
lastStderr :: Sh Text
lastStderr = gets sStderr
lastExitCode :: Sh Int
lastExitCode = gets sCode
setStdin :: Text -> Sh ()
setStdin input = modify $ \st -> st { sStdin = Just input }
(-|-) :: Sh Text -> Sh b -> Sh b
one -|- two = do
res <- print_stdout False one
setStdin res
two
cp_r :: FilePath -> FilePath -> Sh ()
cp_r from' to' = do
from <- absPath from'
fromIsDir <- (test_d from)
if not fromIsDir then cp from' to' else do
to <- absPath to'
trace $ "cp -r " <> toTextIgnore from <> " " <> toTextIgnore to
toIsDir <- test_d to
when (from == to) $ liftIO $ throwIO $ userError $ show $ "cp_r: " <>
toTextIgnore from <> " and " <> toTextIgnore to <> " are identical"
finalTo <- if not toIsDir then mkdir to >> return to else do
let d = to </> dirname (addTrailingSlash from)
mkdir_p d >> return d
ls from >>= mapM_ (\item -> cp_r (from FP.</> filename item) (finalTo FP.</> filename item))
cp :: FilePath -> FilePath -> Sh ()
cp from' to' = do
from <- absPath from'
to <- absPath to'
trace $ "cp " <> toTextIgnore from <> " " <> toTextIgnore to
to_dir <- test_d to
let to_loc = if to_dir then to FP.</> filename from else to
liftIO $ copyFile from to_loc `catchany` (\e -> throwIO $
ReThrownException e (extraMsg to_loc from)
)
where
extraMsg t f = "during copy from: " ++ unpack f ++ " to: " ++ unpack t
withTmpDir :: (FilePath -> Sh a) -> Sh a
withTmpDir act = do
trace "withTmpDir"
dir <- liftIO getTemporaryDirectory
tid <- liftIO myThreadId
(pS, handle) <- liftIO $ openTempFile dir ("tmp"++filter isAlphaNum (show tid))
let p = pack pS
liftIO $ hClose handle
rm_f p
mkdir p
act p `finally_sh` rm_rf p
writefile :: FilePath -> Text -> Sh ()
writefile f' bits = absPath f' >>= \f -> do
trace $ "writefile " <> toTextIgnore f
liftIO (TIO.writeFile (unpack f) bits)
touchfile :: FilePath -> Sh ()
touchfile = absPath >=> flip appendfile ""
appendfile :: FilePath -> Text -> Sh ()
appendfile f' bits = absPath f' >>= \f -> do
trace $ "appendfile " <> toTextIgnore f
liftIO (TIO.appendFile (unpack f) bits)
readfile :: FilePath -> Sh Text
readfile = absPath >=> \fp -> do
trace $ "readfile " <> toTextIgnore fp
readBinary fp >>=
return . TE.decodeUtf8With TE.lenientDecode
readBinary :: FilePath -> Sh ByteString
readBinary = absPath >=> liftIO . BS.readFile . unpack
hasExt :: Text -> FilePath -> Bool
hasExt = flip hasExtension
time :: Sh a -> Sh (Double, a)
time what = sub $ do
trace "time"
t <- liftIO getCurrentTime
res <- what
t' <- liftIO getCurrentTime
return (realToFrac $ diffUTCTime t' t, res)
sleep :: Int -> Sh ()
sleep = liftIO . threadDelay . (1000 * 1000 *)