{-# LANGUAGE CPP #-}
--
-- | A Posix.popen compatibility mapping.
--
-- If we use this, we should build -threaded
--
module System.Plugins.Process (exec, popen) where

import System.Exit
import System.IO
import System.Process
import Control.Concurrent       (forkIO)

import qualified Control.Exception as E

--
-- slight wrapper over popen for calls that don't care about stdin to the program
--
exec :: String -> [String] -> IO ([String],[String],Bool)
exec :: String -> [String] -> IO ([String], [String], Bool)
exec String
f [String]
as = do
        (String
a,String
b,Bool
c,ProcessID
_) <- String
-> [String] -> Maybe String -> IO (String, String, Bool, ProcessID)
popen String
f [String]
as (String -> Maybe String
forall a. a -> Maybe a
Just [])
        ([String], [String], Bool) -> IO ([String], [String], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> [String]
lines String
a, String -> [String]
lines String
b,Bool
c)

type ProcessID = ProcessHandle

--
-- Ignoring exit status for now.
--
-- XXX there are still issues. Large amounts of output can cause what
-- seems to be a dead lock on the pipe write from runplugs, for example.
-- Posix.popen doesn't have this problem, so maybe we can reproduce its
-- pipe handling somehow.
--
popen :: FilePath -> [String] -> Maybe String -> IO (String,String,Bool,ProcessID)
popen :: String
-> [String] -> Maybe String -> IO (String, String, Bool, ProcessID)
popen String
file [String]
args Maybe String
minput =
    (IOException -> IO (String, String, Bool, ProcessID))
-> IO (String, String, Bool, ProcessID)
-> IO (String, String, Bool, ProcessID)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
E.handle (\IOException
e -> (String, String, Bool, ProcessID)
-> IO (String, String, Bool, ProcessID)
forall (m :: * -> *) a. Monad m => a -> m a
return ([],IOException -> String
forall a. Show a => a -> String
show (IOException
e::E.IOException), Bool
False, String -> ProcessID
forall a. HasCallStack => String -> a
error (IOException -> String
forall a. Show a => a -> String
show IOException
e))) (IO (String, String, Bool, ProcessID)
 -> IO (String, String, Bool, ProcessID))
-> IO (String, String, Bool, ProcessID)
-> IO (String, String, Bool, ProcessID)
forall a b. (a -> b) -> a -> b
$ do

    (Handle
inp,Handle
out,Handle
err,ProcessID
pid) <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO (Handle, Handle, Handle, ProcessID)
runInteractiveProcess String
file [String]
args Maybe String
forall a. Maybe a
Nothing Maybe [(String, String)]
forall a. Maybe a
Nothing

    case Maybe String
minput of
        Just String
input -> Handle -> String -> IO ()
hPutStr Handle
inp String
input IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
inp -- importante!
        Maybe String
Nothing    -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- Now, grab the input
    String
output <- Handle -> IO String
hGetContents Handle
out
    String
errput <- Handle -> IO String
hGetContents Handle
err

    -- SimonM sez:
    -- ... avoids blocking the main thread, but ensures that all the
    -- data gets pulled as it becomes available. you have to force the
    -- output strings before waiting for the process to terminate.
    --
    ThreadId
_ <- IO () -> IO ThreadId
forkIO (Int -> IO Int
forall a. a -> IO a
E.evaluate (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
output) IO Int -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    ThreadId
_ <- IO () -> IO ThreadId
forkIO (Int -> IO Int
forall a. a -> IO a
E.evaluate (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
errput) IO Int -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())

    -- And now we wait. We must wait after we read, unsurprisingly.
    ExitCode
exitCode <- ProcessID -> IO ExitCode
waitForProcess ProcessID
pid -- blocks without -threaded, you're warned.
    case ExitCode
exitCode of
      ExitFailure Int
code
          | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
errput -> let errMsg :: String
errMsg = String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": failed with error code " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
code
                           in (String, String, Bool, ProcessID)
-> IO (String, String, Bool, ProcessID)
forall (m :: * -> *) a. Monad m => a -> m a
return ([],String
errMsg,Bool
False,String -> ProcessID
forall a. HasCallStack => String -> a
error String
errMsg)
          | Bool
otherwise -> (String, String, Bool, ProcessID)
-> IO (String, String, Bool, ProcessID)
forall (m :: * -> *) a. Monad m => a -> m a
return ([],String
errput,Bool
False,String -> ProcessID
forall a. HasCallStack => String -> a
error String
errput)
      ExitCode
_ -> (String, String, Bool, ProcessID)
-> IO (String, String, Bool, ProcessID)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
output,String
errput,Bool
True,ProcessID
pid)