Helpers.hs

module Foreign.Nix.Shellout.Helpers where

import Protolude hiding (async, wait)
import Foreign.Nix.Shellout.Types
import qualified System.Process as P
import qualified Data.Text.IO as TIO
import qualified Data.Text as T
import qualified System.IO as SIO

-- needed for ignoreSigPipe
import GHC.IO.Exception (IOErrorType(..), IOException(..))
import Foreign.C.Error (Errno(Errno), ePIPE)

-- | Read the output of a process into a NixAction.
-- | Keeps stderr if process returns a failure exit code.
-- | The text is decoded as @UTF-8@.
readProcess :: ((Text, Text) -> ExitCode -> ExceptT e IO a)
            -- ^ handle (stdout, stderr) depending on the return value
            -> Text
            -- ^ name of executable
            -> [Text]
            -- ^ arguments
            -> NixAction e a
            -- ^ error: (stderr, errormsg), success: path
readProcess with exec args = NixAction $ do
  (exc, out, err) <- liftIO
    $ readCreateProcessWithExitCodeAndEncoding
        (P.proc (toS exec) (map toS args)) SIO.utf8 ""
  withExceptT (err,) $ with (out, err) exc


-- Copied & modified from System.Process (process-1.6.4.0)

-- | like @readCreateProcessWithExitCodeAndEncoding, but uses
-- | Text instead of [Char] and lets the user specify an encoding
-- | for the handles.
readCreateProcessWithExitCodeAndEncoding
    :: P.CreateProcess
    -> SIO.TextEncoding            -- ^ encoding for handles
    -> Text                        -- ^ standard input
    -> IO (ExitCode, Text, Text)   -- ^ exitcode, stdout, stderr
readCreateProcessWithExitCodeAndEncoding cp encoding input = do
    let cp_opts = cp
          { P.std_in  = P.CreatePipe
          , P.std_out = P.CreatePipe
          , P.std_err = P.CreatePipe }
    -- todo: this is not exposed by System.Process
    -- withCreateProcess_ "readCreateProcessWithExitCode" cp_opts $
    P.withCreateProcess cp_opts $
      \(Just inh) (Just outh) (Just errh) ph -> do

        SIO.hSetEncoding outh encoding
        SIO.hSetEncoding errh encoding
        SIO.hSetEncoding inh encoding

        out <- TIO.hGetContents outh
        err <- TIO.hGetContents errh

        -- fork off threads to start consuming stdout & stderr
        withForkWait  (evaluate $ rnf out) $ \waitOut ->
         withForkWait (evaluate $ rnf err) $ \waitErr -> do

          -- now write any input
          unless (T.null input) $
            ignoreSigPipe $ hPutStr inh input
          -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
          ignoreSigPipe $ SIO.hClose inh

          -- wait on the output
          waitOut
          waitErr

          -- TODO: isn’t this done by `withCreateProcess`?
          SIO.hClose outh
          SIO.hClose errh

        -- wait on the process
        ex <- P.waitForProcess ph

        return (ex, out, err)


-- Copied from System.Process (process-1.6.4.0)

-- | Fork a thread while doing something else, but kill it if there's an
-- exception.
--
-- This is important in the cases above because we want to kill the thread
-- that is holding the Handle lock, because when we clean up the process we
-- try to close that handle, which could otherwise deadlock.
--
withForkWait :: IO () -> (IO () ->  IO a) -> IO a
withForkWait async body = do
  waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
  mask $ \restore -> do
    tid <- forkIO $ try (restore async) >>= putMVar waitVar
    let wait = takeMVar waitVar >>= either throwIO return
    restore (body wait) `onException` killThread tid

ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe = handle $ \e -> case e of
  IOError { ioe_type  = ResourceVanished
          , ioe_errno = Just ioe }
    | Errno ioe == ePIPE -> return ()
  _ -> throwIO e