module Control.Shell (
Shell,
Guard (..),
File (..),
shell,
mayFail, orElse,
withEnv, getEnv, lookupEnv,
run, run_, runInteractive, genericRun, sudo,
cd, cpDir, pwd, ls, mkdir, rmdir, inDirectory, isDirectory,
withHomeDirectory, inHomeDirectory, withAppDirectory, inAppDirectory,
forEachFile, forEachFile_, cpFiltered,
isFile, rm, mv, cp,
withTempFile, withCustomTempFile,
withTempDirectory, withCustomTempDirectory, inTempDirectory,
hPutStr, hPutStrLn, hClose, echo,
(|>),
module System.FilePath, liftIO
) where
import Control.Applicative
import Control.Monad (ap, forM, filterM, forM_, when)
import Control.Monad.IO.Class
import Data.Time.Clock
import Data.Typeable
import System.FilePath
import System.IO.Unsafe
import qualified System.Process as Proc
import qualified System.Directory as Dir
import qualified System.Exit as Exit
import qualified System.IO as IO
import qualified Control.Exception as Ex
import qualified Control.Concurrent as Conc
import qualified System.IO.Temp as Temp
import qualified System.Environment as Env
newtype ShellException = ShellException String deriving (Typeable, Show)
instance Ex.Exception ShellException
type Env = [(String, String)]
data Pid = Pid {pidName :: String, pidHandle :: Proc.ProcessHandle}
newtype Shell a = Shell {
unSh :: Env -> IO (Either String a, [Pid])
}
instance Monad Shell where
fail err = Shell $ \_ -> return (Left err, [])
return x = Shell $ \_ -> return (Right x, [])
(Shell m) >>= f = Shell $ \env -> do
(x, pids) <- m env
merr <- waitPids pids
case (x, merr) of
(Left err, _) -> return (Left err, [])
(_, Just err) -> return (Left err, [])
(Right x', _) -> unSh (f x') env
instance MonadIO Shell where
liftIO act = Shell $ \_ -> flip Ex.catch exHandler $ do
x <- act
return (Right x, [])
instance Applicative Shell where
pure = return
(<*>) = ap
instance Functor Shell where
fmap f x = do
x' <- x
return $! f x'
class File a where
file :: FilePath -> a
instance File (String -> Shell ()) where
file f = liftIO . writeFile f
instance File (Shell String) where
file f = liftIO $ readFile f
(|>) :: Shell String -> (String -> Shell a) -> Shell a
(Shell m) |> f = Shell $ \env -> do
(x, pids) <- m env
(x', pids') <- case x of
Left err -> return (Left err, [])
Right x' -> unSh (f x') env
return (x', pids ++ pids')
infixl 1 |>
waitPids :: [Pid] -> IO (Maybe String)
waitPids (p:ps) = do
exCode <- Proc.waitForProcess (pidHandle p)
case exCode of
Exit.ExitFailure ec -> do
killPids ps
return . Just $ "Command '" ++ (pidName p) ++ "' failed with error "
++" code " ++ show ec
_ -> do
waitPids ps
waitPids _ = do
return Nothing
killPids :: [Pid] -> IO ()
killPids = mapM_ (Proc.terminateProcess . pidHandle)
shell :: Shell a -> IO (Either String a)
shell act = do
dir <- Dir.getCurrentDirectory
env <- Env.getEnvironment
(res, pids) <- unSh act env
merr <- waitPids pids
Dir.setCurrentDirectory dir
case merr of
Just err -> return $ Left err
_ -> return res
withEnv :: String -> (String -> String) -> Shell a -> Shell a
withEnv key f (Shell act) = Shell $ \env -> do
act $ insert env
where
insert (x@(k,v):xs) | k == key = (key, f v) : xs
| otherwise = x : insert xs
insert _ = [(key, f "")]
lookupEnv :: String -> Shell (Maybe String)
lookupEnv key = Shell $ \env -> return (Right $ lookup key env, [])
getEnv :: String -> Shell String
getEnv key = maybe "" id `fmap` lookupEnv key
exHandler :: Ex.SomeException -> IO (Either String a, [Pid])
exHandler x = return (Left $ show x, [])
run :: FilePath -> [String] -> String -> Shell String
run p args stdin = do
(Just inp, Just out, pid) <- runP p args Proc.CreatePipe Proc.CreatePipe
Shell $ \_ -> do
let feed str = do
case splitAt 4096 str of
([], []) -> IO.hClose inp
(first, str') -> IO.hPutStr inp first >> feed str'
Conc.forkIO $ feed stdin
s <- IO.hGetContents out
s `seq` return (Right s, [Pid p pid])
genericRun :: FilePath -> [String] -> String -> Shell (Bool, String, String)
genericRun p args stdin = do
(Just inp, Just out, Just err, pid) <- createproc
Shell $ \_ -> do
let feed str = do
case splitAt 4096 str of
([], []) -> IO.hClose inp
(first, str') -> IO.hPutStr inp first >> feed str'
Conc.forkIO $ feed stdin
o <- IO.hGetContents out
e <- IO.hGetContents err
merr <- waitPids [Pid p pid]
return (Right (maybe True (const False) merr, o, e), [])
where
createproc = Shell $ \env -> do
(inp, out, err, pid) <- Proc.createProcess (cproc env)
return (Right (inp, out, err, pid), [])
cproc env = Proc.CreateProcess {
Proc.cmdspec = Proc.RawCommand p args,
Proc.cwd = Nothing,
Proc.env = Just env,
Proc.std_in = Proc.CreatePipe,
Proc.std_out = Proc.CreatePipe,
Proc.std_err = Proc.CreatePipe,
Proc.close_fds = False,
#if MIN_VERSION_process(1,2,0)
Proc.delegate_ctlc = False,
#endif
Proc.create_group = False
}
run_ :: FilePath -> [String] -> String -> Shell ()
run_ p args stdin = do
(Just inp, _, pid) <- runP p args Proc.CreatePipe Proc.Inherit
exCode <- liftIO $ do
IO.hPutStr inp stdin
IO.hClose inp
Proc.waitForProcess pid
case exCode of
Exit.ExitFailure ec -> fail $ "Command '" ++ p ++ "' failed with error "
++" code " ++ show ec
_ -> return ()
sudo :: FilePath -> [String] -> String -> Shell String
sudo cmd args stdin = run "sudo" (cmd:args) stdin
runP :: String
-> [String]
-> Proc.StdStream
-> Proc.StdStream
-> Shell (Maybe IO.Handle, Maybe IO.Handle, Proc.ProcessHandle)
runP p args stdin stdout = Shell $ \env -> do
(inp, out, _, pid) <- Proc.createProcess (cproc env)
return (Right (inp, out, pid), [])
where
cproc env = Proc.CreateProcess {
Proc.cmdspec = Proc.RawCommand p args,
Proc.cwd = Nothing,
Proc.env = Just env,
Proc.std_in = stdin,
Proc.std_out = stdout,
Proc.std_err = Proc.Inherit,
Proc.close_fds = False,
#if MIN_VERSION_process(1,2,0)
Proc.delegate_ctlc = False,
#endif
Proc.create_group = False
}
runInteractive :: FilePath -> [String] -> Shell ()
runInteractive p args = do
(_, _, pid) <- runP p args Proc.Inherit Proc.Inherit
exitCode <- liftIO $ Proc.waitForProcess pid
case exitCode of
Exit.ExitFailure ec -> fail (show ec)
_ -> return ()
cd :: FilePath -> Shell ()
cd = liftIO . Dir.setCurrentDirectory
pwd :: Shell FilePath
pwd = liftIO $ Dir.getCurrentDirectory
rm :: FilePath -> Shell ()
rm = liftIO . Dir.removeFile
mv :: FilePath -> FilePath -> Shell ()
mv from to = liftIO $ Dir.renameFile from to
cpDir :: FilePath -> FilePath -> Shell ()
cpDir from to = do
todir <- isDirectory to
if todir
then do
cpDir from (to </> takeBaseName from)
else do
cpfile <- isFile from
if cpfile
then do
cp from to
else do
liftIO $ Dir.createDirectoryIfMissing False to
ls from >>= mapM_ (\f -> cpDir (from </> f) (to </> f))
cpFiltered :: (FilePath -> Bool) -> FilePath -> FilePath -> Shell ()
cpFiltered pred from to = do
isdir <- isDirectory to
let to' = unsafePerformIO $ do
when (not isdir) $ Dir.createDirectory to
return to
files <- ls from
mapM_ ((`cp` to') . (from </>)) (filter pred files)
fromdirs <- filterM (\d -> isDirectory (from </> d)) files
forM_ fromdirs $ \dir -> do
cpFiltered pred (from </> dir) (to </> dir)
forEachFile :: FilePath -> (FilePath -> Shell a) -> Shell [a]
forEachFile dir f = do
files <- map (dir </>) <$> ls dir
xs <- filterM isFile files >>= mapM f
fromdirs <- filterM isDirectory files
xss <- forM fromdirs $ \d -> do
forEachFile d f
return $ concat (xs:xss)
forEachFile_ :: FilePath -> (FilePath -> Shell ()) -> Shell ()
forEachFile_ dir f = do
files <- map (dir </>) <$> ls dir
filterM isFile files >>= mapM_ f
fromdirs <- filterM isDirectory files
forM_ fromdirs $ \d -> do
forEachFile d f
cp :: FilePath -> FilePath -> Shell ()
cp from to = do
todir <- isDirectory to
if todir
then cp from (to </> takeFileName from)
else liftIO $ Dir.copyFile from to
ls :: FilePath -> Shell [FilePath]
ls dir = do
contents <- liftIO $ Dir.getDirectoryContents dir
return [f | f <- contents, f /= ".", f /= ".."]
mkdir :: Bool -> FilePath -> Shell ()
mkdir True = liftIO . Dir.createDirectoryIfMissing True
mkdir _ = liftIO . Dir.createDirectory
rmdir :: FilePath -> Shell ()
rmdir = liftIO . Dir.removeDirectoryRecursive
withHomeDirectory :: (FilePath -> Shell a) -> Shell a
withHomeDirectory act = liftIO Dir.getHomeDirectory >>= act
inHomeDirectory :: Shell a -> Shell a
inHomeDirectory act = withHomeDirectory $ \dir -> inDirectory dir act
withAppDirectory :: String -> (FilePath -> Shell a) -> Shell a
withAppDirectory app act = liftIO (Dir.getAppUserDataDirectory app) >>= act
inAppDirectory :: FilePath -> Shell a -> Shell a
inAppDirectory app act = withAppDirectory app $ \dir -> inDirectory dir act
inDirectory :: FilePath -> Shell a -> Shell a
inDirectory dir act = do
curDir <- pwd
cd dir
x <- act
cd curDir
return x
isDirectory :: FilePath -> Shell Bool
isDirectory = liftIO . Dir.doesDirectoryExist
isFile :: FilePath -> Shell Bool
isFile = liftIO . Dir.doesFileExist
withTempDirectory :: String -> (FilePath -> Shell a) -> Shell a
withTempDirectory template act = Shell $ \env -> do
Temp.withSystemTempDirectory template (act' env)
where
act' env fp = Ex.catch (unSh (act fp) env) exHandler
withCustomTempDirectory :: FilePath -> (FilePath -> Shell a) -> Shell a
withCustomTempDirectory dir act = Shell $ \env -> do
Temp.withTempDirectory dir "shellmate" (act' env)
where
act' env fp = Ex.catch (unSh (act fp) env) exHandler
inTempDirectory :: Shell a -> Shell a
inTempDirectory = withTempDirectory "shellmate" . flip inDirectory
withTempFile :: String -> (FilePath -> IO.Handle -> Shell a) -> Shell a
withTempFile template act = Shell $ \env -> do
Temp.withSystemTempFile template (act' env)
where
act' env fp h = Ex.catch (unSh (act fp h) env) exHandler
withCustomTempFile :: FilePath -> (FilePath -> IO.Handle -> Shell a) -> Shell a
withCustomTempFile dir act = Shell $ \env -> do
Temp.withTempFile dir "shellmate" (act' env)
where
act' env fp h = Ex.catch (unSh (act fp h) env) exHandler
mayFail :: Shell a -> Shell (Either String a)
mayFail (Shell act) = Shell $ \env -> do
(x, pids) <- Ex.catch (act env) exHandler
merr <- waitPids pids
case merr of
Just err -> return (Right (Left err), [])
_ -> return (Right x, [])
orElse :: Shell a -> Shell a -> Shell a
orElse a b = do
ex <- mayFail a
case ex of
Right x -> return x
_ -> b
hPutStr :: IO.Handle -> String -> Shell ()
hPutStr h s = liftIO $ IO.hPutStr h s
hPutStrLn :: IO.Handle -> String -> Shell ()
hPutStrLn h s = liftIO $ IO.hPutStrLn h s
hClose :: IO.Handle -> Shell ()
hClose h = liftIO $ IO.hClose h
echo :: String -> Shell ()
echo = liftIO . putStrLn
class Guard guard a | guard -> a where
guard :: String -> guard -> Shell a
instance Guard (Maybe a) a where
guard _ (Just x) = return x
guard desc _ = fail $ "Guard failed: " ++ desc
instance Guard Bool () where
guard _ True = return ()
guard desc _ = fail $ "Guard failed: " ++ desc
instance Guard a b => Guard (Shell a) b where
guard desc m = m >>= \x -> guard desc x