module HSH.Command (ShellCommand(..),
PipeCommand(..),
(-|-),
RunResult,
run,
runIO,
runSL,
InvokeResult,
tryEC,
catchEC,
) where
import System.IO
import System.Exit
import System.Posix.Types
import System.Posix.IO
import System.Posix.Process
import System.Log.Logger
import System.IO.Error
import Data.Maybe.Utils
import Data.Maybe
import Data.List.Utils(uniq)
import Control.Exception(evaluate)
import System.Posix.Env
import Text.Regex.Posix
import Control.Monad(when)
import Data.String.Utils(rstrip)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString as BS
d, dr :: String -> IO ()
d = debugM "HSH.Command"
dr = debugM "HSH.Command.Run"
type InvokeResult = (String, IO ProcessStatus)
class (Show a) => ShellCommand a where
fdInvoke :: a
-> Fd
-> Fd
-> [Fd]
-> (IO ())
-> IO [InvokeResult]
instance Show (String -> String) where
show _ = "(String -> String)"
instance Show (String -> IO String) where
show _ = "(String -> IO String)"
instance Show (BSL.ByteString -> BSL.ByteString) where
show _ = "(Data.ByteString.Lazy.ByteString -> Data.ByteString.Lazy.ByteString)"
instance Show (BSL.ByteString -> IO BSL.ByteString) where
show _ = "(Data.ByteString.Lazy.ByteString -> IO Data.ByteString.Lazy.ByteString)"
instance Show (BS.ByteString -> BS.ByteString) where
show _ = "(Data.ByteString.ByteString -> Data.ByteString.ByteString)"
instance Show (BS.ByteString -> IO BS.ByteString) where
show _ = "(Data.ByteString.ByteString -> IO Data.ByteString.ByteString)"
instance ShellCommand (String -> IO String) where
fdInvoke = genericStringlikeIO hGetContents hPutStr
instance ShellCommand (BSL.ByteString -> IO BSL.ByteString) where
fdInvoke = genericStringlikeIO BSL.hGetContents BSL.hPut
instance ShellCommand (BS.ByteString -> IO BS.ByteString) where
fdInvoke = genericStringlikeIO BS.hGetContents BS.hPut
instance ShellCommand (String -> String) where
fdInvoke func =
fdInvoke iofunc
where iofunc :: String -> 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 (BS.ByteString -> BS.ByteString) where
fdInvoke func =
fdInvoke iofunc
where iofunc :: BS.ByteString -> IO BS.ByteString
iofunc = return . func
genericStringlikeIO :: (Show (a -> IO a)) =>
(Handle -> IO a)
-> (Handle -> a -> IO ())
-> (a -> IO a)
-> Fd
-> Fd
-> [Fd]
-> (IO ())
-> IO [InvokeResult]
genericStringlikeIO getcontentsfunc hputstrfunc func fstdin fstdout childclosefds childfunc =
do
p <- try (forkProcess childstuff)
pid <- case p of
Right x -> return x
Left x -> fail $ "Error in fork for func: " ++ show x
return $ seq pid pid
return [(show func,
getProcessStatus True False pid >>=
(return . forceMaybe))]
where childstuff = do closefds childclosefds [fstdin, fstdout]
d $ "SIOSFC Input is on " ++ show fstdin
hr <- fdToHandle fstdin
d $ "SIOSFC Output is on " ++ show fstdout
hw <- fdToHandle fstdout
hSetBuffering hw LineBuffering
d $ "SIOSFC Running child func"
childfunc
d $ "SIOSFC Running func in child"
contents <- getcontentsfunc hr
d $ "SIOSFC Contents read"
result <- func contents
d $ "SIOSFC Func applied"
hputstrfunc hw result
d $ "SIOSFC Func done, closing handles."
hClose hr
hClose hw
d $ "SIOSFC Child exiting."
instance Show ([String] -> [String]) where
show _ = "([String] -> [String])"
instance Show ([String] -> IO [String]) where
show _ = "([String] -> IO [String])"
instance ShellCommand ([String] -> [String]) where
fdInvoke func = fdInvoke (unlines . func . lines)
instance ShellCommand ([String] -> IO [String]) where
fdInvoke func = fdInvoke iofunc
where iofunc input = do r <- func (lines input)
return (unlines r)
instance ShellCommand (String, [String]) where
fdInvoke pc@(cmd, args) fstdin fstdout childclosefds childfunc =
do d $ "S Before fork for " ++ show pc
p <- try (forkProcess childstuff)
pid <- case p of
Right x -> return x
Left x -> fail $ "Error in fork: " ++ show x
d $ "SP New pid " ++ show pid ++ " for " ++ show pc
return $ seq pid pid
return [(show (cmd, args),
getProcessStatus True False pid >>=
(return . forceMaybe))]
where
childstuff = do d $ "SC preparing to redir"
d $ "SC input is on " ++ show fstdin
d $ "SC output is on " ++ show fstdout
redir fstdin stdInput
redir fstdout stdOutput
closefds childclosefds [fstdin, fstdout, 0, 1]
childfunc
dr ("RUN: " ++ cmd ++ " " ++ (show args))
executeFile cmd True args Nothing
instance ShellCommand String where
fdInvoke cmdline ifd ofd closefd forkfunc =
do esh <- getEnv "SHELL"
let sh = case esh of
Nothing -> "/bin/sh"
Just x -> x
fdInvoke (sh, ["-c", cmdline]) ifd ofd closefd forkfunc
redir :: Fd -> Fd -> IO ()
redir fromfd tofd
| fromfd == tofd = do d $ "ignoring identical redir " ++ show fromfd
return ()
| otherwise = do d $ "running dupTo " ++ show (fromfd, tofd)
dupTo fromfd tofd
closeFd fromfd
closefds :: [Fd]
-> [Fd]
-> IO ()
closefds inpclosefds noclosefds =
do d $ "closefds " ++ show uclosefds ++ " " ++ show noclosefds
mapM_ closeit . filter (\x -> not (x `elem` noclosefds)) $ uclosefds
where closeit fd = do d $ "Closing fd " ++ show fd
closeFd fd
uclosefds = uniq inpclosefds
data (ShellCommand a, ShellCommand b) => PipeCommand a b = PipeCommand a b
deriving Show
instance (ShellCommand a, ShellCommand b) => ShellCommand (PipeCommand a b) where
fdInvoke pc@(PipeCommand cmd1 cmd2) fstdin fstdout childclosefds forkfunc =
do d $ "*** Handling pipe: " ++ show pc
(reader, writer) <- createPipe
let allfdstoclose = reader : writer : fstdin : fstdout : childclosefds
d $ "pipd fdInvoke: New pipe endpoints: " ++ show (reader, writer)
res1 <- fdInvoke cmd1 fstdin writer allfdstoclose forkfunc
res2 <- fdInvoke cmd2 reader fstdout allfdstoclose forkfunc
d $ "pipe fdInvoke: Parent closing " ++ show [reader, writer]
mapM_ closeFd [reader, writer]
d $ "*** Done handling pipe " ++ show pc
return $ res1 ++ res2
(-|-) :: (ShellCommand a, ShellCommand b) => a -> b -> PipeCommand a b
(-|-) = PipeCommand
nullChildFunc :: IO ()
nullChildFunc = return ()
class RunResult a where
run :: (ShellCommand b) => b -> a
instance RunResult (IO ()) where
run cmd = run cmd >>= checkResults
instance RunResult (IO (String, ProcessStatus)) where
run cmd =
do r <- fdInvoke cmd stdInput stdOutput [] nullChildFunc
processResults r
instance RunResult (IO ProcessStatus) where
run cmd = ((run cmd)::IO (String, ProcessStatus)) >>= return . snd
instance RunResult (IO Int) where
run cmd = do rc <- run cmd
case rc of
Exited (ExitSuccess) -> return 0
Exited (ExitFailure x) -> return x
Terminated x -> return (128 + (fromIntegral x))
Stopped x -> return (128 + (fromIntegral 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 hGetContents (\c -> evaluate (length c))
cmd
instance RunResult (IO BSL.ByteString) where
run cmd = genericStringlikeResult BSL.hGetContents
(\c -> evaluate (BSL.length c))
cmd
instance RunResult (IO BS.ByteString) where
run cmd = genericStringlikeResult BS.hGetContents
(\c -> evaluate (BS.length c))
cmd
genericStringlikeResult :: ShellCommand b =>
(Handle -> IO a)
-> (a -> IO c)
-> b
-> IO a
genericStringlikeResult hgetcontentsfunc evalfunc cmd =
do (pread, pwrite) <- createPipe
r <- fdInvoke cmd stdInput pwrite [pread, pwrite] nullChildFunc
closeFd pwrite
hread <- fdToHandle pread
c <- hgetcontentsfunc hread
evalfunc c
hClose hread
processResults r >>= checkResults
return c
processResults :: [InvokeResult] -> IO (String, ProcessStatus)
processResults r =
do rc <- mapM procresult r
case catMaybes rc of
[] -> return (fst (last r), Exited (ExitSuccess))
x -> return (last x)
where procresult :: InvokeResult -> IO (Maybe (String, ProcessStatus))
procresult (cmd, action) =
do rc <- action
return $ case rc of
Exited (ExitSuccess) -> Nothing
x -> Just (cmd, x)
checkResults :: (String, ProcessStatus) -> IO ()
checkResults (cmd, ps) =
case ps of
Exited (ExitSuccess) -> return ()
Exited (ExitFailure x) ->
fail $ cmd ++ ": exited with code " ++ show x
Terminated sig ->
fail $ cmd ++ ": terminated by signal " ++ show sig
Stopped sig ->
fail $ cmd ++ ": stopped by signal " ++ show sig
tryEC :: IO a -> IO (Either ProcessStatus 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 . proc $ 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]+"
proc :: String -> ProcessStatus
proc e
| e =~ "^: exited" = Exited (ExitFailure (str2ec e))
| e =~ "^: terminated by signal" = Terminated (str2ec e)
| e =~ "^: stopped by signal" = Stopped (str2ec e)
| otherwise = error "Internal error in tryEC"
str2ec e =
read (e =~ "[0-9]+$")
catchEC :: IO a -> (ProcessStatus -> 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)