module Shellish
(
ShIO, shellish, sub, silently, verbosely
, setenv, getenv, cd, pwd
, echo, echo_n, echo_err, echo_n_err
, ls, test_e, test_f, test_d, test_s, which, find
, mv, rm_f, rm_rf, cp, cp_r, mkdir, mkdir_p
, readfile, writefile, appendfile, withTmpDir
, run, (#), lastOutput, lastStdout, lastStderr
, (</>), (<.>), (<$>), (<$$>), grep, whenM, canonic
, catch_sh, liftIO, MemTime(..), time, catchany
, RunFailed(..)
) where
import Prelude hiding ( catch, readFile )
import Data.List( isInfixOf, (\\) )
import Data.Typeable
import Data.IORef
import Data.Maybe
import System.IO hiding ( readFile )
import System.IO.Strict( readFile )
import System.PosixCompat.Files( getSymbolicLinkStatus, isSymbolicLink )
import System.Directory
import System.Exit
import System.FilePath
import System.Environment
import Control.Applicative
import Control.Exception
import Control.Monad.Reader
import Control.Concurrent
import Data.Time.Clock( getCurrentTime, diffUTCTime, UTCTime(..) )
import Control.Exception ( bracket, evaluate )
import qualified Data.ByteString.Char8 as B
import System.Process( runInteractiveProcess, waitForProcess, ProcessHandle )
data MemTime = MemTime Rational Double deriving (Read, Show, Ord, Eq)
data St = St { sCode :: Int, sStderr :: B.ByteString , sStdout :: B.ByteString
, sOutput :: B.ByteString, sDirectory :: FilePath
, sVerbose :: Bool, sRun :: String -> [String] ->
ShIO (Handle, Handle, Handle, ProcessHandle)
, sEnvironment :: [(String, String)] }
type ShIO a = ReaderT (IORef St) IO a
get :: ShIO St
get = ask >>= liftIO . readIORef
put v = ask >>= liftIO . flip writeIORef v
modify f = ask >>= liftIO . flip modifyIORef f
gets f = f <$> get
runInteractiveProcess' cmd args = do
st <- get
liftIO $ runInteractiveProcess cmd args (Just $ 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)
cd :: FilePath -> ShIO ()
cd dir = do dir' <- path dir
modify $ \st -> st { sDirectory = dir' }
path p | isRelative p = (</> p) <$> gets sDirectory
| otherwise = return p
mv :: FilePath -> FilePath -> ShIO ()
mv a b = do a' <- path a
b' <- path b
liftIO $ renameFile a' b'
ls :: FilePath -> ShIO [String]
ls dir = do dir' <- path dir
liftIO $ filter (`notElem` [".", ".."]) <$> getDirectoryContents dir'
find :: FilePath -> ShIO [String]
find dir = do bits <- ls dir
sub <- forM bits $ \x -> do
ex <- test_d $ dir </> x
sym <- test_s $ dir </> x
if ex && not sym then find (dir </> x)
else return []
return $ map (dir </>) bits ++ concat sub
pwd :: ShIO String
pwd = gets sDirectory
echo, echo_n, echo_err, echo_n_err :: String -> ShIO ()
echo = liftIO . putStrLn
echo_n = liftIO . (>> hFlush System.IO.stdout) . putStr
echo_err = liftIO . hPutStrLn stderr
echo_n_err = liftIO . (>> hFlush stderr) . hPutStr stderr
mkdir :: FilePath -> ShIO ()
mkdir = path >=> liftIO . createDirectory
mkdir_p :: FilePath -> ShIO ()
mkdir_p = path >=> liftIO . createDirectoryIfMissing True
which :: String -> ShIO (Maybe FilePath)
which = liftIO . findExecutable
canonic :: FilePath -> ShIO FilePath
canonic = path >=> liftIO . canonicalizePath
whenM :: Monad m => m Bool -> m () -> m ()
whenM c a = do res <- c
when res a
test_e :: FilePath -> ShIO Bool
test_e f = do f' <- path f
liftIO $ do
dir <- doesDirectoryExist f'
file <- doesFileExist f'
return $ file || dir
test_f :: FilePath -> ShIO Bool
test_f = path >=> liftIO . doesFileExist
test_d :: FilePath -> ShIO Bool
test_d = path >=> liftIO . doesDirectoryExist
test_s :: FilePath -> ShIO Bool
test_s = path >=> liftIO . \f -> do
stat <- getSymbolicLinkStatus f
return $ isSymbolicLink stat
rm_rf :: FilePath -> ShIO ()
rm_rf f = path f >>= \f' -> do
let deletable = Permissions True True True True
whenM (test_d f) $ do
find f' >>= mapM (\file -> liftIO $ setPermissions file deletable `catchany` \_ -> return ())
liftIO $ removeDirectoryRecursive f'
whenM (test_f f) $ rm_f f'
rm_f :: FilePath -> ShIO ()
rm_f f = path f >>= \f' -> whenM (test_e f) $ liftIO $ removeFile f'
setenv :: String -> String -> ShIO ()
setenv k v = modify $ \x -> x { sEnvironment = wibble $ sEnvironment x }
where wibble env = (k, v) : filter ((/=k).fst) env
getenv :: String -> ShIO String
getenv k = fromMaybe "" <$> lookup k <$> gets sEnvironment
silently :: ShIO a -> ShIO a
silently a = sub $ modify (\x -> x { sVerbose = False }) >> a
verbosely :: ShIO a -> ShIO a
verbosely a = sub $ modify (\x -> x { sVerbose = True }) >> a
sub :: ShIO a -> ShIO a
sub a = do
st <- get
r <- a `catch_sh` (\(e :: SomeException) -> put st >> throw e)
put st
return r
shellish :: MonadIO m => ShIO a -> m a
shellish a = do
env <- liftIO $ getEnvironment
dir <- liftIO $ getCurrentDirectory
let empty = St { sCode = 0, sStderr = B.empty, sOutput = B.empty
, sStdout = B.empty, sVerbose = True
, sRun = runInteractiveProcess', sEnvironment = env
, sDirectory = dir }
stref <- liftIO $ newIORef empty
liftIO $ runReaderT a stref
drain :: Handle -> Maybe Handle -> Chan B.ByteString -> ShIO (Chan B.ByteString)
drain h verb all =
do chan <- liftIO newChan
let work acc = do line <- liftIO $ B.hGetLine h
writeChan all line
liftIO $ when (isJust verb) $ B.hPutStrLn (fromJust verb) line
work $ B.concat [acc, line, "\n"]
`catchany` \_ -> liftIO $ writeChan chan acc
_ <- liftIO $ forkIO $ work ""
return chan
drainChan :: Chan a -> IO [a]
drainChan ch = do empty <- isEmptyChan ch
if empty then return []
else do b <- readChan ch
(b:) <$> drainChan ch
data RunFailed = RunFailed String Int String deriving (Typeable)
instance Show RunFailed where
show (RunFailed cmd code errs) =
"error running " ++ cmd ++ ": exit status " ++ show code ++ ":\n" ++ errs
instance Exception RunFailed
(#) :: String -> [String] -> ShIO String
cmd # args = run cmd args
run :: String -> [String] -> ShIO String
run cmd args = do
st <- get
(_,outH,errH,procH) <- (sRun st) cmd args
all' <- liftIO $ newChan
res' <- drain outH (if sVerbose st then Just stdout else Nothing) all'
errs' <- drain errH (if sVerbose st then Just stderr else Nothing) all'
ex <- liftIO $ waitForProcess procH
errs <- liftIO $ readChan errs'
res <- liftIO $ readChan res'
all <- liftIO $ B.intercalate "\n" <$> drainChan all'
modify $ \x -> x { sCode = 0, sStderr = errs, sStdout = res, sOutput = all }
case ex of
ExitSuccess -> return ()
ExitFailure n -> do
modify $ \x -> x { sCode = n }
throw $ RunFailed (cmd ++ " " ++ show args) n (B.unpack errs)
return $ B.unpack res
lastOutput, lastStderr, lastStdout :: ShIO B.ByteString
lastStdout = gets sStdout
lastStderr = gets sStderr
lastOutput = gets sOutput
time :: ShIO a -> ShIO (MemTime, a)
time what = sub $ do
t <- liftIO getCurrentTime
res <- what
t' <- liftIO getCurrentTime
let mt = MemTime 0 (realToFrac $ diffUTCTime t' t)
return (mt, res)
cp_r :: FilePath -> FilePath -> ShIO ()
cp_r from to = do
whenM (test_d from) $
mkdir to >> ls from >>= mapM_ (\item -> cp_r (from </> item) (to </> item))
whenM (test_f from) $ cp from to
cp :: FilePath -> FilePath -> ShIO ()
cp from to = do
from' <- path from
to' <- path to
to_dir <- test_d to
liftIO $ copyFile from' (if to_dir then to' </> takeFileName from else to')
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 l = filter (match p) l
(<$$>) :: (Functor m) => (b -> c) -> (a -> m b) -> a -> m c
f <$$> v = fmap f . v
withTmpDir :: (FilePath -> ShIO a) -> ShIO a
withTmpDir act = do
dir <- liftIO $ getTemporaryDirectory
(path, handle) <- liftIO $ openTempFile dir "tmp"
liftIO $ hClose handle
rm_f path
mkdir path
a <- act path `catch_sh` \(e :: SomeException) -> rm_rf path >> throw e
rm_rf path
return a
writefile :: FilePath -> String -> ShIO ()
writefile f bits = path f >>= \f' -> liftIO (writeFile f' bits)
appendfile :: FilePath -> String -> ShIO ()
appendfile f bits = path f >>= \f' -> liftIO (appendFile f' bits)
readfile :: FilePath -> ShIO String
readfile = path >=> liftIO . readFile