git.iko.soy/typeable/pandoc
on bc3caaa help sign in
typeable/pandoc/src/Text/Pandoc/Process.hs
114 lines 4.2 kB history raw
1{-# LANGUAGE NoImplicitPrelude #-}
2{- |
3 Module : Text.Pandoc.Process
4 Copyright : Copyright (C) 2013-2019 John MacFarlane
5 License : GNU GPL, version 2 or above
7 Maintainer : John MacFarlane <jgm@berkeley.edu>
8 Stability : alpha
9 Portability : portable
11ByteString variant of 'readProcessWithExitCode'.
12-}
13module Text.Pandoc.Process (pipeProcess)
14where
15import Prelude
16import Control.Concurrent (MVar, forkIO, killThread, newEmptyMVar, putMVar,
17 takeMVar)
18import Control.Exception (SomeException (..))
19import qualified Control.Exception as E
20import Control.Monad (unless)
21import Control.DeepSeq (rnf)
22import qualified Data.ByteString.Lazy as BL
23import Foreign.C (Errno (Errno), ePIPE)
24import GHC.IO.Exception (IOErrorType(..), IOException(..))
25import System.Exit (ExitCode (..))
26import System.IO (hClose)
27import System.Process
29{- |
30Version of 'System.Process.readProcessWithExitCode' that uses lazy bytestrings
31instead of strings and allows setting environment variables.
33@readProcessWithExitCode@ creates an external process, reads its
34standard output strictly, waits until the process
35terminates, and then returns the 'ExitCode' of the process
36and the standard output. stderr is inherited from the parent.
38If an asynchronous exception is thrown to the thread executing
39@readProcessWithExitCode@, the forked process will be terminated and
40@readProcessWithExitCode@ will wait (block) until the process has been
41terminated.
43This function was adapted from @readProcessWithExitCode@ of module
44System.Process, package process-1.6.3.0. The original code is BSD
45licensed and © University of Glasgow 2004-2008.
46-}
47pipeProcess
48 :: Maybe [(String, String)] -- ^ environment variables
49 -> FilePath -- ^ Filename of the executable (see 'proc' for details)
50 -> [String] -- ^ any arguments
51 -> BL.ByteString -- ^ standard input
52 -> IO (ExitCode,BL.ByteString) -- ^ exitcode, stdout
53pipeProcess mbenv cmd args input = do
54 let cp_opts = (proc cmd args)
55 { env = mbenv
56 , std_in = CreatePipe
57 , std_out = CreatePipe
58 , std_err = Inherit
59 }
60 withCreateProcess cp_opts $
61 \mbInh mbOuth _ pid -> do
62 let (inh, outh) =
63 case (mbInh, mbOuth) of
64 (Just i, Just o) -> (i, o)
65 (Nothing, _) -> error "withCreateProcess no inh"
66 (_, Nothing) -> error "withCreateProcess no outh"
68 out <- BL.hGetContents outh
70 -- fork off threads to start consuming stdout & stderr
71 withForkWait (E.evaluate $ rnf out) $ \waitOut -> do
73 -- now write any input
74 unless (BL.null input) $
75 ignoreSigPipe $ BL.hPutStr inh input
76 -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
77 ignoreSigPipe $ hClose inh
79 -- wait on the output
80 waitOut
82 hClose outh
84 -- wait on the process
85 ex <- waitForProcess pid
87 return (ex, out)
89-- | Fork a thread while doing something else, but kill it if there's an
90-- exception.
91--
92-- This is important in the cases above because we want to kill the thread
93-- that is holding the Handle lock, because when we clean up the process we
94-- try to close that handle, which could otherwise deadlock.
95--
96-- This function was copied verbatim from module System.Process of package
97-- process-1.6.3.0.
98withForkWait :: IO () -> (IO () -> IO a) -> IO a
99withForkWait async body = do
100 waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
101 E.mask $ \restore -> do
102 tid <- forkIO $ E.try (restore async) >>= putMVar waitVar
103 let wait = takeMVar waitVar >>= either E.throwIO return
104 restore (body wait) `E.onException` killThread tid
106-- This function was copied verbatim from module System.Process of package
107-- process-1.6.3.0.
108ignoreSigPipe :: IO () -> IO ()
109ignoreSigPipe = E.handle $ \e ->
110 case e of
111 IOError { ioe_type = ResourceVanished
112 , ioe_errno = Just ioe }
113 | Errno ioe == ePIPE -> return ()
114 _ -> E.throwIO e