module Shelly
(
ShIO, shelly, sub, silently, verbosely, print_stdout, print_commands
, run, run_, cmd, (-|-), lastStderr, setStdin
, command, command_, command1, command1_
, setenv, getenv, getenv_def, appendToPath
, cd, chdir, pwd
, echo, echo_n, echo_err, echo_n_err, inspect
, tag, trace, show_command
, ls, ls', test_e, test_f, test_d, test_s, which, find
, path, absPath, (</>), (<.>)
, mv, rm_f, rm_rf, cp, cp_r, mkdir, mkdir_p
, readfile, writefile, appendfile, withTmpDir
, jobs, background, getBgResult, BgResult
, exit, errorExit, terror
, (<$>), (<$$>), grep, whenM, unlessM, canonic
, catchany, catch_sh, catchany_sh
, Timing(..), time
, RunFailed(..)
, toTextIgnore, toTextWarn, fromText
, liftIO, when, unless, FilePath
) where
import Prelude hiding ( catch, readFile, FilePath )
import Data.List( isInfixOf )
import Data.Char( isAlphaNum, isSpace )
import Data.Typeable
import Data.IORef
import Data.Maybe
import System.IO hiding ( readFile, FilePath )
import System.Exit
import System.Environment
import Control.Applicative
import Control.Exception hiding (handle)
import Control.Monad.Reader
import Control.Concurrent
import qualified Control.Concurrent.MSem as Sem
import Data.Time.Clock( getCurrentTime, diffUTCTime )
import qualified Data.Text.Lazy.IO as TIO
import qualified Data.Text.IO as STIO
import System.Process( runInteractiveProcess, waitForProcess, ProcessHandle )
import qualified Data.Text.Lazy as LT
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text as T
import Data.Monoid (mappend)
import Filesystem.Path.CurrentOS hiding (concat, fromText, (</>), (<.>))
import Filesystem
import qualified Filesystem.Path.CurrentOS as FP
import System.PosixCompat.Files( getSymbolicLinkStatus, isSymbolicLink )
import System.Directory ( setPermissions, getPermissions, Permissions(..), getTemporaryDirectory, findExecutable )
class ShellArg a where toTextArg :: a -> Text
instance ShellArg Text where toTextArg = id
instance ShellArg FilePath where toTextArg = toTextIgnore
class ShellCommand t where
cmdAll :: FilePath -> [Text] -> t
instance ShellCommand (ShIO Text) where
cmdAll fp args = run fp args
instance ShellCommand (ShIO a) where
cmdAll fp args = run_ fp args >>
return (error "No Way! Shelly did not see this coming. Please report this error.")
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 = fromText
instance ToFilePath T.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.<.> LT.toStrict y
toTextIgnore :: FilePath -> Text
toTextIgnore fp = LT.fromStrict $ case toText fp of
Left f -> f
Right f -> f
toTextWarn :: FilePath -> ShIO Text
toTextWarn efile = fmap lazy $ case toText efile of
Left f -> encodeError f >> return f
Right f -> return f
where
encodeError f = echo ("Invalid encoding for file: " `mappend` lazy f)
lazy = LT.fromStrict
fromText :: Text -> FilePath
fromText = FP.fromText . LT.toStrict
printGetContent :: Handle -> Handle -> IO Text
printGetContent rH wH =
fmap B.toLazyText $ printFoldHandleLines (B.fromText "") foldBuilder rH wH
getContent :: Handle -> IO Text
getContent h = fmap B.toLazyText $ foldHandleLines (B.fromText "") foldBuilder h
type FoldCallback a = ((a, Text) -> a)
printFoldHandleLines :: a -> FoldCallback a -> Handle -> Handle -> IO a
printFoldHandleLines start foldLine readHandle writeHandle = go start
where
go acc = do
line <- TIO.hGetLine readHandle
TIO.hPutStrLn writeHandle line >> go (foldLine (acc, line))
`catchany` \_ -> return acc
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
data State = State { sCode :: Int
, sStdin :: Maybe Text
, sStderr :: Text
, sDirectory :: FilePath
, sPrintStdout :: Bool
, sPrintCommands :: Bool
, sRun :: FilePath -> [Text] -> ShIO (Handle, Handle, Handle, ProcessHandle)
, sEnvironment :: [(String, String)]
, sTrace :: B.Builder
}
tag :: ShIO a -> Text -> ShIO a
tag action msg = do
trace msg
result <- action
return result
trace :: Text -> ShIO ()
trace msg = modify $ \st -> st { sTrace = sTrace st `mappend` B.fromLazyText msg `mappend` "\n" }
type ShIO a = ReaderT (IORef State) IO a
get :: ShIO State
get = do
stateVar <- ask
liftIO (readIORef stateVar)
put :: State -> ShIO ()
put newState = do
stateVar <- ask
liftIO (writeIORef stateVar newState)
modify :: (State -> State) -> ShIO ()
modify f = do
state <- ask
liftIO (modifyIORef state f)
gets :: (State -> a) -> ShIO a
gets f = f <$> get
runInteractiveProcess' :: FilePath -> [Text] -> ShIO (Handle, Handle, Handle, ProcessHandle)
runInteractiveProcess' exe args = do
st <- get
liftIO $ runInteractiveProcess (unpack exe)
(map LT.unpack args)
(Just $ unpack $ sDirectory st)
(Just $ sEnvironment st)
catchany :: IO a -> (SomeException -> IO a) -> IO a
catchany = catch
catch_sh :: (Exception e) => ShIO a -> (e -> ShIO a) -> ShIO a
catch_sh a h = do ref <- ask
liftIO $ catch (runReaderT a ref) (\e -> runReaderT (h e) ref)
catchany_sh :: ShIO a -> (SomeException -> ShIO a) -> ShIO a
catchany_sh = catch_sh
cd :: FilePath -> ShIO ()
cd dir = do dir' <- absPath dir
trace $ "cd " `mappend` toTextIgnore dir'
modify $ \st -> st { sDirectory = dir' }
chdir :: FilePath -> ShIO a -> ShIO a
chdir dir action = do
d <- pwd
cd dir
r <- action `catchany_sh` (\e ->
cd d >> liftIO (throwIO e)
)
cd d
return r
path :: FilePath -> ShIO FilePath
path = canonic
absPath :: FilePath -> ShIO FilePath
absPath p | relative p = (FP.</> p) <$> gets sDirectory
| otherwise = return p
unpack :: FilePath -> String
unpack = encodeString
pack :: String -> FilePath
pack = decodeString
mv :: FilePath -> FilePath -> ShIO ()
mv a b = do a' <- absPath a
b' <- absPath b
trace $ "mv " `mappend` toTextIgnore a' `mappend` " " `mappend` toTextIgnore b'
liftIO $ rename a' b'
ls' :: FilePath -> ShIO [Text]
ls' fp = do
trace $ "ls " `mappend` toTextIgnore fp
efiles <- ls fp
mapM toTextWarn efiles
ls :: FilePath -> ShIO [FilePath]
ls = path >=> \fp -> (liftIO $ listDirectory fp) `tag` ("ls " `mappend` toTextIgnore fp)
find :: FilePath -> ShIO [FilePath]
find dir = do trace ("find " `mappend` toTextIgnore dir)
bits <- ls dir
subDir <- forM bits $ \x -> do
ex <- test_d $ dir FP.</> x
sym <- test_s $ dir FP.</> x
if ex && not sym then find (dir FP.</> x)
else return []
return $ map (dir FP.</>) bits ++ concat subDir
pwd :: ShIO FilePath
pwd = gets sDirectory `tag` "pwd"
echo, echo_n, echo_err, echo_n_err :: Text -> ShIO ()
echo = traceLiftIO TIO.putStrLn
echo_n = traceLiftIO $ (>> hFlush System.IO.stdout) . TIO.putStr
echo_err = traceLiftIO $ TIO.hPutStrLn stderr
echo_n_err = traceLiftIO $ (>> hFlush stderr) . TIO.hPutStr stderr
traceLiftIO :: (Text -> IO ()) -> Text -> ShIO ()
traceLiftIO f msg = trace ("echo " `mappend` msg) >> liftIO (f msg)
exit :: Int -> ShIO ()
exit 0 = liftIO (exitWith ExitSuccess) `tag` "exit 0"
exit n = liftIO (exitWith (ExitFailure n)) `tag` ("exit " `mappend` LT.pack (show n))
errorExit :: Text -> ShIO ()
errorExit msg = echo msg >> exit 1
terror :: Text -> ShIO a
terror = fail . LT.unpack
inspect :: (Show s) => s -> ShIO ()
inspect = trace . LT.pack . show >=> liftIO . print
mkdir :: FilePath -> ShIO ()
mkdir = absPath >=> \fp -> do
trace $ "mkdir " `mappend` toTextIgnore fp
liftIO $ createDirectory False fp `catchany` (\e -> throwIO e >> return ())
mkdir_p :: FilePath -> ShIO ()
mkdir_p = absPath >=> \fp -> do
trace $ "mkdir -p " `mappend` toTextIgnore fp
liftIO $ createTree fp
which :: FilePath -> ShIO (Maybe FilePath)
which fp = do
(trace . mappend "which " . toTextIgnore) fp
(liftIO . findExecutable . unpack >=> return . fmap pack) fp
canonic :: FilePath -> ShIO FilePath
canonic = absPath >=> liftIO . canonicalizePath
whenM :: Monad m => m Bool -> m () -> m ()
whenM c a = c >>= \res -> when res a
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM c a = c >>= \res -> unless res a
test_e :: FilePath -> ShIO Bool
test_e f = do
fs <- absPath f
liftIO $ do
file <- isFile fs
if file then return True else isDirectory fs
test_f :: FilePath -> ShIO Bool
test_f = absPath >=> liftIO . isFile
test_d :: FilePath -> ShIO Bool
test_d = absPath >=> liftIO . isDirectory
test_s :: FilePath -> ShIO Bool
test_s = absPath >=> liftIO . \f -> do
stat <- getSymbolicLinkStatus (unpack f)
return $ isSymbolicLink stat
rm_rf :: FilePath -> ShIO ()
rm_rf f = absPath f >>= \f' -> do
trace $ "rm -rf " `mappend` toTextIgnore f
whenM (test_d f) $ do
_<- find f' >>= mapM (\file -> liftIO_ $ fixPermissions (unpack file) `catchany` \_ -> return ())
liftIO_ $ removeTree f'
whenM (test_f f) $ rm_f 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 -> ShIO ()
rm_f f = do
trace $ "rm -f " `mappend` toTextIgnore f
whenM (test_e f) $ absPath f >>= liftIO . removeFile
setenv :: Text -> Text -> ShIO ()
setenv k v =
let (kStr, vStr) = (LT.unpack k, LT.unpack v)
wibble env = (kStr, vStr) : filter ((/=kStr).fst) env
in modify $ \x -> x { sEnvironment = wibble $ sEnvironment x }
appendToPath :: FilePath -> ShIO ()
appendToPath filepath = do
tp <- toTextWarn filepath
pe <- getenv path_env
setenv path_env $ pe `mappend` ":" `mappend` tp
where
path_env = "PATH"
getenv :: Text -> ShIO Text
getenv k = getenv_def k ""
getenv_def :: Text -> Text -> ShIO Text
getenv_def k d = gets sEnvironment >>=
return . LT.pack . fromMaybe (LT.unpack d) . lookup (LT.unpack k)
silently :: ShIO a -> ShIO a
silently a = sub $ modify (\x -> x { sPrintStdout = False, sPrintCommands = False }) >> a
verbosely :: ShIO a -> ShIO a
verbosely a = sub $ modify (\x -> x { sPrintStdout = True, sPrintCommands = True }) >> a
print_stdout :: Bool -> ShIO a -> ShIO a
print_stdout shouldPrint a = sub $ modify (\x -> x { sPrintStdout = shouldPrint }) >> a
jobs :: Int -> (BgJobManager -> ShIO a) -> ShIO a
jobs limit action = do
unless (limit > 0) $ terror "expected limit to be > 0"
availableJobsSem <- liftIO $ Sem.new limit
res <- action $ BgJobManager availableJobsSem
liftIO $ waitForJobs availableJobsSem
return res
where
waitForJobs sem = do
avail <- Sem.peekAvail sem
if avail == limit then return () else waitForJobs sem
newtype BgJobManager = BgJobManager (Sem.MSem Int)
newtype BgResult a = BgResult (MVar a)
getBgResult :: BgResult a -> ShIO a
getBgResult (BgResult mvar) = liftIO $ takeMVar mvar
background :: BgJobManager -> ShIO a -> ShIO (BgResult a)
background (BgJobManager manager) proc = do
state <- get
liftIO $ do
Sem.wait manager
mvar <- newEmptyMVar
_<- forkIO $ do
result <- shelly $ (put state >> proc)
Sem.signal manager
liftIO $ putMVar mvar result
return $ BgResult mvar
print_commands :: Bool -> ShIO a -> ShIO a
print_commands shouldPrint a = sub $ modify (\st -> st { sPrintCommands = shouldPrint }) >> a
sub :: ShIO a -> ShIO a
sub a = do
oldState <- get
modify $ \st -> st { sTrace = B.fromText "" }
r <- a `catchany_sh` (\e -> do
restoreState oldState
liftIO $ throwIO e)
restoreState oldState
return r
where
restoreState oldState = do
newState <- get
put oldState { sTrace = sTrace oldState `mappend` sTrace newState }
shelly :: MonadIO m => ShIO a -> m a
shelly action = do
env <- liftIO getEnvironment
dir <- liftIO getWorkingDirectory
let def = State { sCode = 0
, sStdin = Nothing
, sStderr = LT.empty
, sPrintStdout = True
, sPrintCommands = False
, sRun = runInteractiveProcess'
, sEnvironment = env
, sTrace = B.fromText ""
, sDirectory = dir }
stref <- liftIO $ newIORef def
let caught =
action `catchany_sh` \e ->
get >>= liftIO . throwIO . ReThrownException e . errorMsg . LT.unpack . B.toLazyText . sTrace
liftIO $ runReaderT caught stref
where
errorMsg trc = "Ran commands: \n" `mappend` trc
data RunFailed = RunFailed FilePath [Text] Int Text deriving (Typeable)
instance Show RunFailed where
show (RunFailed exe args code errs) =
"error running: " ++ LT.unpack (show_command exe args) ++
"\nexit status: " ++ show code ++ "\nstderr: " ++ LT.unpack errs
instance Exception RunFailed
show_command :: FilePath -> [Text] -> Text
show_command exe args =
LT.intercalate " " $ map quote (toTextIgnore exe : args)
where
quote t = if LT.any isSpace t then surround '\'' t else t
surround c t = LT.cons c $ LT.snoc t c
data Exception e => 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] -> ShIO Text
run exe args = fmap B.toLazyText $ runFoldLines (B.fromText "") foldBuilder exe args
foldBuilder :: (B.Builder, Text) -> B.Builder
foldBuilder (b, line) = b `mappend` B.fromLazyText line `mappend` B.singleton '\n'
command :: FilePath -> [Text] -> [Text] -> ShIO Text
command com args more_args = run com (args ++ more_args)
command_ :: FilePath -> [Text] -> [Text] -> ShIO ()
command_ com args more_args = run_ com (args ++ more_args)
command1 :: FilePath -> [Text] -> Text -> [Text] -> ShIO Text
command1 com args one_arg more_args = run com ([one_arg] ++ args ++ more_args)
command1_ :: FilePath -> [Text] -> Text -> [Text] -> ShIO ()
command1_ com args one_arg more_args = run_ com ([one_arg] ++ args ++ more_args)
run_ :: FilePath -> [Text] -> ShIO ()
run_ = runFoldLines () (\(_, _) -> ())
liftIO_ :: IO a -> ShIO ()
liftIO_ action = liftIO action >> return ()
runFoldLines :: a -> FoldCallback a -> FilePath -> [Text] -> ShIO a
runFoldLines start cb exe args = do
origstate <- get
let mStdin = sStdin origstate
put $ origstate { sStdin = Nothing, sCode = 0, sStderr = LT.empty }
state <- get
let cmdString = show_command exe args
when (sPrintCommands state) $ echo cmdString
trace cmdString
(inH,outH,errH,procH) <- sRun state exe args
case mStdin of
Just input ->
liftIO $ TIO.hPutStr inH input >> hClose inH
Nothing -> return ()
errV <- liftIO newEmptyMVar
outV <- liftIO newEmptyMVar
if sPrintStdout state
then do
liftIO_ $ forkIO $ printGetContent errH stderr >>= putMVar errV
liftIO_ $ forkIO $ printFoldHandleLines start cb outH stdout >>= putMVar outV
else do
liftIO_ $ forkIO $ getContent errH >>= putMVar errV
liftIO_ $ forkIO $ foldHandleLines start cb outH >>= putMVar outV
errs <- liftIO $ takeMVar errV
ex <- liftIO $ waitForProcess procH
let code = case ex of
ExitSuccess -> 0
ExitFailure n -> n
put $ state { sStderr = errs , sCode = code }
liftIO $ case ex of
ExitSuccess -> takeMVar outV
ExitFailure n -> throwIO $ RunFailed exe args n errs
lastStderr :: ShIO Text
lastStderr = gets sStderr
setStdin :: Text -> ShIO ()
setStdin input = modify $ \st -> st { sStdin = Just input }
(-|-) :: ShIO Text -> ShIO b -> ShIO b
one -|- two = do
res <- (print_stdout False) one
setStdin res
two
data Timing = Timing Double deriving (Read, Show, Ord, Eq)
time :: ShIO a -> ShIO (Timing, a)
time what = sub $ do
trace "time"
t <- liftIO getCurrentTime
res <- what
t' <- liftIO getCurrentTime
let mt = Timing (realToFrac $ diffUTCTime t' t)
return (mt, res)
cp_r :: FilePath -> FilePath -> ShIO ()
cp_r from to = do
trace $ "cp -r " `mappend` toTextIgnore from `mappend` " " `mappend` toTextIgnore to
from_d <- (test_d from)
if not from_d then cp from to else do
let fromName = filename from
let toDir = if filename to == fromName then to else to FP.</> fromName
unlessM (test_d toDir) $ mkdir toDir
ls from >>= mapM_
(\item -> cp_r (from FP.</> filename item) (toDir FP.</> filename item))
cp :: FilePath -> FilePath -> ShIO ()
cp from to = do
from' <- absPath from
to' <- absPath to
trace $ "cp " `mappend` toTextIgnore from' `mappend` " " `mappend` 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
class PredicateLike pattern hay where
match :: pattern -> hay -> Bool
instance PredicateLike (a -> Bool) a where
match = id
instance (Eq a) => PredicateLike [a] [a] where
match pat = (pat `isInfixOf`)
grep :: (PredicateLike pattern hay) => pattern -> [hay] -> [hay]
grep p = filter (match p)
(<$$>) :: (Functor m) => (b -> c) -> (a -> m b) -> a -> m c
f <$$> v = fmap f . v
withTmpDir :: (FilePath -> ShIO a) -> ShIO 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
a <- act p `catchany_sh` \e -> do
rm_rf p >> liftIO (throwIO e)
rm_rf p
return a
writefile :: FilePath -> Text -> ShIO ()
writefile f bits = absPath f >>= \f' -> do
trace $ "writefile " `mappend` toTextIgnore f'
liftIO (TIO.writeFile (unpack f') bits)
appendfile :: FilePath -> Text -> ShIO ()
appendfile f bits = absPath f >>= \f' -> do
trace $ "appendfile " `mappend` toTextIgnore f'
liftIO (TIO.appendFile (unpack f') bits)
readfile :: FilePath -> ShIO Text
readfile = absPath >=> \fp -> do
trace $ "readfile " `mappend` toTextIgnore fp
(fmap LT.fromStrict . liftIO . STIO.readFile . unpack) fp