module HSH.Command (Environment,
ShellCommand(..),
PipeCommand(..),
(-|-),
RunResult,
run,
runIO,
runSL,
InvokeResult,
checkResults,
tryEC,
catchEC,
setenv,
unsetenv
) where
import Prelude hiding (catch)
import System.IO
import System.Exit
import System.Log.Logger
import System.IO.Error hiding (catch)
import Data.Maybe.Utils
import Data.Maybe
import Data.List.Utils(uniq)
import Control.Exception(evaluate, SomeException, catch)
import Text.Regex.Posix
import Control.Monad(when)
import Data.String.Utils(rstrip)
import Control.Concurrent
import System.Process
import System.Environment(getEnvironment)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString as BS
import HSH.Channel
d, dr :: String -> IO ()
d = debugM "HSH.Command"
dr = debugM "HSH.Command.Run"
em = errorM "HSH.Command"
type InvokeResult = (String, IO ExitCode)
type Environment = Maybe [(String, String)]
class (Show a) => ShellCommand a where
fdInvoke :: a
-> Environment
-> Channel
-> IO (Channel, [InvokeResult])
instance Show (Handle -> Handle -> IO ()) where
show _ = "(Handle -> Handle -> IO ())"
instance Show (Channel -> IO Channel) where
show _ = "(Channel -> IO Channel)"
instance Show (String -> String) where
show _ = "(String -> String)"
instance Show (() -> String) where
show _ = "(() -> String)"
instance Show (String -> IO String) where
show _ = "(String -> IO String)"
instance Show (() -> IO String) where
show _ = "(() -> IO String)"
instance Show (BSL.ByteString -> BSL.ByteString) where
show _ = "(Data.ByteString.Lazy.ByteString -> Data.ByteString.Lazy.ByteString)"
instance Show (() -> BSL.ByteString) where
show _ = "(() -> Data.ByteString.Lazy.ByteString)"
instance Show (BSL.ByteString -> IO BSL.ByteString) where
show _ = "(Data.ByteString.Lazy.ByteString -> IO Data.ByteString.Lazy.ByteString)"
instance Show (() -> IO BSL.ByteString) where
show _ = "(() -> IO BSL.ByteString)"
instance Show (BS.ByteString -> BS.ByteString) where
show _ = "(Data.ByteString.ByteString -> Data.ByteString.ByteString)"
instance Show (() -> BS.ByteString) where
show _ = "(() -> Data.ByteString.ByteString)"
instance Show (BS.ByteString -> IO BS.ByteString) where
show _ = "(Data.ByteString.ByteString -> IO Data.ByteString.ByteString)"
instance Show (() -> IO BS.ByteString) where
show _ = "(() -> IO Data.ByteString.ByteString)"
instance ShellCommand (String -> IO String) where
fdInvoke = genericStringlikeIO chanAsString
instance ShellCommand (() -> IO String) where
fdInvoke = genericStringlikeO
instance ShellCommand (BSL.ByteString -> IO BSL.ByteString) where
fdInvoke = genericStringlikeIO chanAsBSL
instance ShellCommand (() -> IO BSL.ByteString) where
fdInvoke = genericStringlikeO
instance ShellCommand (BS.ByteString -> IO BS.ByteString) where
fdInvoke = genericStringlikeIO chanAsBS
instance ShellCommand (() -> IO BS.ByteString) where
fdInvoke = genericStringlikeO
instance ShellCommand (String -> String) where
fdInvoke func =
fdInvoke iofunc
where iofunc :: String -> IO String
iofunc = return . func
instance ShellCommand (() -> String) where
fdInvoke func =
fdInvoke iofunc
where iofunc :: () -> IO String
iofunc = return . func
instance ShellCommand (BSL.ByteString -> BSL.ByteString) where
fdInvoke func =
fdInvoke iofunc
where iofunc :: BSL.ByteString -> IO BSL.ByteString
iofunc = return . func
instance ShellCommand (() -> BSL.ByteString) where
fdInvoke func =
fdInvoke iofunc
where iofunc :: () -> IO BSL.ByteString
iofunc = return . func
instance ShellCommand (BS.ByteString -> BS.ByteString) where
fdInvoke func =
fdInvoke iofunc
where iofunc :: BS.ByteString -> IO BS.ByteString
iofunc = return . func
instance ShellCommand (() -> BS.ByteString) where
fdInvoke func =
fdInvoke iofunc
where iofunc :: () -> IO BS.ByteString
iofunc = return . func
instance ShellCommand (Channel -> IO Channel) where
fdInvoke func _ cstdin =
runInHandler (show func) (func cstdin)
genericStringlikeIO :: (Show (a -> IO a), Channelizable a) =>
(Channel -> IO a)
-> (a -> IO a)
-> Environment
-> Channel
-> IO (Channel, [InvokeResult])
genericStringlikeIO dechanfunc userfunc _ cstdin =
do contents <- dechanfunc cstdin
runInHandler (show userfunc) (realfunc contents)
where realfunc contents = do r <- userfunc contents
return (toChannel r)
genericStringlikeO :: (Show (() -> IO a), Channelizable a) =>
(() -> IO a)
-> Environment
-> Channel
-> IO (Channel, [InvokeResult])
genericStringlikeO userfunc _ _ =
runInHandler (show userfunc) realfunc
where realfunc :: IO Channel
realfunc = do r <- userfunc ()
return (toChannel r)
instance Show ([String] -> [String]) where
show _ = "([String] -> [String])"
instance Show (() -> [String]) where
show _ = "(() -> [String])"
instance Show ([String] -> IO [String]) where
show _ = "([String] -> IO [String])"
instance Show (() -> IO [String]) where
show _ = "(() -> IO [String])"
instance ShellCommand ([String] -> [String]) where
fdInvoke func = fdInvoke (unlines . func . lines)
instance ShellCommand (() -> [String]) where
fdInvoke func = fdInvoke (unlines . func)
instance ShellCommand ([String] -> IO [String]) where
fdInvoke func = fdInvoke iofunc
where iofunc input = do r <- func (lines input)
return (unlines r)
instance ShellCommand (() -> IO [String]) where
fdInvoke func = fdInvoke iofunc
where iofunc :: (() -> IO String)
iofunc () = do r <- func ()
return (unlines r)
instance ShellCommand (String, [String]) where
fdInvoke (fp, args) = genericCommand (RawCommand fp args)
instance ShellCommand String where
fdInvoke cmd = genericCommand (ShellCommand cmd)
genericCommand :: CmdSpec
-> Environment
-> Channel
-> IO (Channel, [InvokeResult])
genericCommand c environ (ChanHandle ih) =
let cp = CreateProcess {cmdspec = c,
cwd = Nothing,
env = environ,
std_in = UseHandle ih,
std_out = CreatePipe,
std_err = Inherit,
close_fds = True
#if MIN_VERSION_process(1,1,0)
, create_group = False
#endif
}
in do (_, oh', _, ph) <- createProcess cp
let oh = fromJust oh'
return (ChanHandle oh, [(printCmdSpec c, waitForProcess ph)])
genericCommand cspec environ ichan =
let cp = CreateProcess {cmdspec = cspec,
cwd = Nothing,
env = environ,
std_in = CreatePipe,
std_out = CreatePipe,
std_err = Inherit,
close_fds = True
#if MIN_VERSION_process(1,1,0)
, create_group = False
#endif
}
in do (ih', oh', _, ph) <- createProcess cp
let ih = fromJust ih'
let oh = fromJust oh'
chanToHandle True ichan ih
return (ChanHandle oh, [(printCmdSpec cspec, waitForProcess ph)])
printCmdSpec :: CmdSpec -> String
printCmdSpec (ShellCommand s) = s
printCmdSpec (RawCommand fp args) = show (fp, args)
data PipeCommand a b = (ShellCommand a, ShellCommand b) => PipeCommand a b
deriving instance Show (PipeCommand a b)
instance (ShellCommand a, ShellCommand b) => ShellCommand (PipeCommand a b) where
fdInvoke (PipeCommand cmd1 cmd2) env ichan =
do (chan1, res1) <- fdInvoke cmd1 env ichan
(chan2, res2) <- fdInvoke cmd2 env chan1
return (chan2, res1 ++ res2)
(-|-) :: (ShellCommand a, ShellCommand b) => a -> b -> PipeCommand a b
(-|-) = PipeCommand
class RunResult a where
run :: (ShellCommand b) => b -> a
instance RunResult (IO ()) where
run cmd = run cmd >>= checkResults
instance RunResult (IO (String, ExitCode)) where
run cmd =
do (ochan, r) <- fdInvoke cmd Nothing (ChanHandle stdin)
chanToHandle False ochan stdout
processResults r
instance RunResult (IO ExitCode) where
run cmd = ((run cmd)::IO (String, ExitCode)) >>= return . snd
instance RunResult (IO Int) where
run cmd = do rc <- run cmd
case rc of
ExitSuccess -> return 0
ExitFailure x -> return x
instance RunResult (IO Bool) where
run cmd = do rc <- run cmd
return ((rc::Int) == 0)
instance RunResult (IO [String]) where
run cmd = do r <- run cmd
return (lines r)
instance RunResult (IO String) where
run cmd = genericStringlikeResult chanAsString (\c -> evaluate (length c))
cmd
instance RunResult (IO BSL.ByteString) where
run cmd = genericStringlikeResult chanAsBSL
(\c -> evaluate (BSL.length c))
cmd
instance RunResult (IO BS.ByteString) where
run cmd = genericStringlikeResult chanAsBS
(\c -> evaluate (BS.length c))
cmd
instance RunResult (IO (String, IO (String, ExitCode))) where
run cmd = intermediateStringlikeResult chanAsString cmd
instance RunResult (IO (BSL.ByteString, IO (String, ExitCode))) where
run cmd = intermediateStringlikeResult chanAsBSL cmd
instance RunResult (IO (BS.ByteString, IO (String, ExitCode))) where
run cmd = intermediateStringlikeResult chanAsBS cmd
instance RunResult (IO (IO (String, ExitCode))) where
run cmd = do (ochan, r) <- fdInvoke cmd Nothing (ChanHandle stdin)
chanToHandle False ochan stdout
return (processResults r)
intermediateStringlikeResult :: ShellCommand b =>
(Channel -> IO a)
-> b
-> IO (a, IO (String, ExitCode))
intermediateStringlikeResult chanfunc cmd =
do (ochan, r) <- fdInvoke cmd Nothing (ChanHandle stdin)
c <- chanfunc ochan
return (c, processResults r)
genericStringlikeResult :: ShellCommand b =>
(Channel -> IO a)
-> (a -> IO c)
-> b
-> IO a
genericStringlikeResult chanfunc evalfunc cmd =
do (c, r) <- intermediateStringlikeResult chanfunc cmd
evalfunc c
r >>= checkResults
return c
processResults :: [InvokeResult] -> IO (String, ExitCode)
processResults r =
do rc <- mapM procresult r
case catMaybes rc of
[] -> return (fst (last r), ExitSuccess)
x -> return (last x)
where procresult :: InvokeResult -> IO (Maybe (String, ExitCode))
procresult (cmd, action) =
do rc <- action
return $ case rc of
ExitSuccess -> Nothing
x -> Just (cmd, x)
checkResults :: (String, ExitCode) -> IO ()
checkResults (cmd, ps) =
case ps of
ExitSuccess -> return ()
ExitFailure x ->
fail $ cmd ++ ": exited with code " ++ show x
tryEC :: IO a -> IO (Either ExitCode a)
tryEC action =
do r <- try action
case r of
Left ioe ->
if isUserError ioe then
case (ioeGetErrorString ioe =~~ pat) of
Nothing -> ioError ioe
Just e -> return . Left . procit $ e
else ioError ioe
Right result -> return (Right result)
where pat = ": exited with code [0-9]+$|: terminated by signal ([0-9]+)$|: stopped by signal [0-9]+"
procit :: String -> ExitCode
procit e
| e =~ "^: exited" = ExitFailure (str2ec e)
| otherwise = error "Internal error in tryEC"
str2ec e =
read (e =~ "[0-9]+$")
catchEC :: IO a -> (ExitCode -> IO a) -> IO a
catchEC action handler =
do r <- tryEC action
case r of
Left ec -> handler ec
Right result -> return result
runIO :: (ShellCommand a) => a -> IO ()
runIO = run
runSL :: (ShellCommand a) => a -> IO String
runSL cmd =
do r <- run cmd
when (r == []) $ fail $ "runSL: no output received from " ++ show cmd
return (rstrip . head $ r)
runInHandler :: String
-> (IO Channel)
-> IO (Channel, [InvokeResult])
runInHandler descrip func =
catch (realfunc) (exchandler)
where realfunc = do r <- func
return (r, [(descrip, return ExitSuccess)])
exchandler :: SomeException -> IO (Channel, [InvokeResult])
exchandler e = do em $ "runInHandler/" ++ descrip ++ ": " ++ show e
return (ChanString "", [(descrip, return (ExitFailure 1))])
type EnvironFilter = [(String, String)] -> [(String, String)]
instance Show EnvironFilter where
show _ = "EnvironFilter"
data EnvironCommand a = (ShellCommand a) => EnvironCommand EnvironFilter a
deriving instance Show (EnvironCommand a)
instance (ShellCommand a) => ShellCommand (EnvironCommand a) where
fdInvoke (EnvironCommand efilter cmd) Nothing ichan =
do
e <- getEnvironment
fdInvoke cmd (Just (efilter e)) ichan
fdInvoke (EnvironCommand efilter cmd) (Just ienv) ichan =
fdInvoke cmd (Just (efilter ienv)) ichan
setenv :: (ShellCommand cmd) => [(String, String)] -> cmd -> EnvironCommand cmd
setenv items cmd =
EnvironCommand efilter cmd
where efilter ienv = foldr efilter' ienv items
efilter' (key, val) ienv =
(key, val) : (filter (\(k, _) -> k /= key) ienv)
unsetenv :: (ShellCommand cmd) => [String] -> cmd -> EnvironCommand cmd
unsetenv keys cmd =
EnvironCommand efilter cmd
where efilter ienv = foldr efilter' ienv keys
efilter' key = filter (\(k, _) -> k /= key)