{-# LANGUAGE BangPatterns #-}
module System.Plex.Internal (
executeFile'
, readCommand
, readCommand_
, cmd
, cmd_
, cmdTimeout
, cmdTimeout_
) where
import Control.Concurrent.Async (waitEitherCatch, withAsync)
import Control.DeepSeq (NFData, rnf )
import Control.Exception (onException, evaluate, try, SomeException)
import Control.Concurrent (threadDelay)
import Control.Monad
import Data.Either (either)
import System.IO (hGetContents, hPutStrLn, stderr, Handle)
import System.Posix.Process (createSession, executeFile, forkProcess,
getProcessGroupIDOf)
import System.Posix.IO (closeFd, stdError, stdOutput, dupTo,
createPipe, fdToHandle)
import System.Posix.Signals (signalProcessGroup, killProcess)
import System.Posix.Types (ProcessID)
tryAny :: IO a -> IO (Either SomeException a)
tryAny = try
executeFile' ::
FilePath -> Bool -> [String] -> Maybe [(String, String)] -> IO ()
executeFile' cmd shell args env =
tryAny (executeFile cmd shell args env) >>=
either
(\ex -> hPutStrLn stderr $ "error executing " ++ cmd ++ ", " ++ show ex)
(error "shouldn't be here")
readCommand :: FilePath -> [String] -> IO (ProcessID, IO String)
readCommand command args = readCommand_ hGetContents command args
readCommand_
:: NFData a =>
(Handle -> IO a) -> FilePath -> [String] -> IO (ProcessID, IO a)
readCommand_ hGetContents command args = do
(readPipeEnd, writePipeEnd) <- createPipe
let childTask :: IO ()
childTask = do
void createSession
void $ dupTo writePipeEnd stdOutput
void $ dupTo writePipeEnd stdError
closeFd readPipeEnd
closeFd writePipeEnd
executeFile' command True args Nothing
!childPid <- forkProcess childTask
closeFd writePipeEnd
let readerTask = do
!readPipeHdl <- fdToHandle readPipeEnd
result <- hGetContents readPipeHdl `onException` closeFd readPipeEnd
evaluate $ rnf result
return result
return (childPid, readerTask)
cmd :: FilePath -> [String] -> IO String
cmd command args = cmd_ hGetContents command args
cmd_ :: NFData b => (Handle -> IO b) -> FilePath -> [String] -> IO b
cmd_ hGetContents command args = do
(_childPid, readerTask) <- readCommand_ hGetContents command args
readerTask
rightToMaybe :: Either a b -> Maybe b
rightToMaybe = either (const Nothing) Just
race' ::
IO a
-> IO b
-> IO (Either (Either SomeException a) (Either SomeException b))
race' left right =
withAsync left $ \a -> withAsync right $ \b -> waitEitherCatch a b
type SEx = SomeException
cmdTimeout :: FilePath -> [String] -> Int -> IO (Maybe String)
cmdTimeout command args microSecs =
cmdTimeout_ hGetContents command args microSecs
cmdTimeout_ ::
NFData a => (Handle -> IO a) -> FilePath -> [String] -> Int -> IO (Maybe a)
cmdTimeout_ hGetContents command args microSecs
| microSecs <= 0 = return Nothing
| otherwise = do
(childPid, readerTask) <- readCommand_ hGetContents command args
let timerTask :: Int -> IO ()
timerTask n = do
threadDelay n
!childGroupID <- getProcessGroupIDOf childPid
!_ <- signalProcessGroup killProcess childGroupID
return ()
timerTask' n = timerTask n `onException` return ()
rightToMaybe . onlyA <$> race' (timerTask' microSecs) readerTask
where
onlyA :: Either (Either SEx ()) (Either SEx a) -> Either () a
onlyA = either (const $ Left ()) (either (const $ Left ()) Right)