{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ForeignFunctionInterface #-}
module System.Posix.Redirect
( redirectStdout
, redirectStderr
, redirectWriteHandle
, unsafeRedirectWriteFd
) where
import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.ByteString as BS
import Foreign.C.Types
import Foreign.Ptr
import System.IO
import System.Posix.IO
import System.Posix.Types
unsafeRedirectWriteFd :: Fd -> IO a -> IO (ByteString, a)
unsafeRedirectWriteFd :: forall a. Fd -> IO a -> IO (ByteString, a)
unsafeRedirectWriteFd Fd
fd IO a
f = IO (Handle, (Fd, Fd))
-> ((Handle, (Fd, Fd)) -> IO ())
-> ((Handle, (Fd, Fd)) -> IO (ByteString, a))
-> IO (ByteString, a)
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Handle, (Fd, Fd))
setup (Handle -> IO ()
hClose (Handle -> IO ())
-> ((Handle, (Fd, Fd)) -> Handle) -> (Handle, (Fd, Fd)) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Handle, (Fd, Fd)) -> Handle
forall a b. (a, b) -> a
fst) (((Handle, (Fd, Fd)) -> IO (ByteString, a)) -> IO (ByteString, a))
-> ((Handle, (Fd, Fd)) -> IO (ByteString, a)) -> IO (ByteString, a)
forall a b. (a -> b) -> a -> b
$
\ (Handle
outHandle, (Fd
wfd, Fd
old)) -> do
MVar ByteString
outMVar <- IO (MVar ByteString)
forall a. IO (MVar a)
newEmptyMVar
IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (Handle -> IO ByteString
BS.hGetContents Handle
outHandle IO ByteString -> (ByteString -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar ByteString -> ByteString -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ByteString
outMVar)
a
r <- IO a
f IO a -> IO () -> IO a
forall a b. IO a -> IO b -> IO a
`finally` do
IO Fd -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Fd -> IO ()) -> IO Fd -> IO ()
forall a b. (a -> b) -> a -> b
$ Fd -> Fd -> IO Fd
dupTo Fd
old Fd
fd
Fd -> IO ()
closeFd Fd
wfd
ByteString
out <- MVar ByteString -> IO ByteString
forall a. MVar a -> IO a
takeMVar MVar ByteString
outMVar
(ByteString, a) -> IO (ByteString, a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
out, a
r)
where
setup :: IO (Handle, (Fd, Fd))
setup = do
(Fd
rfd, Fd
wfd) <- IO (Fd, Fd)
createPipe
Fd
old <- Fd -> IO Fd
dup Fd
fd
IO Fd -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Fd -> IO ()) -> IO Fd -> IO ()
forall a b. (a -> b) -> a -> b
$ Fd -> Fd -> IO Fd
dupTo Fd
wfd Fd
fd
Handle
outHandle <- Fd -> IO Handle
fdToHandle Fd
rfd
(Handle, (Fd, Fd)) -> IO (Handle, (Fd, Fd))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle
outHandle, (Fd
wfd, Fd
old))
redirectWriteHandle :: Fd -> Handle -> Ptr FILE -> IO a -> IO (ByteString, a)
redirectWriteHandle :: forall a. Fd -> Handle -> Ptr FILE -> IO a -> IO (ByteString, a)
redirectWriteHandle Fd
oldFd Handle
oldHandle Ptr FILE
cOldHandle IO a
f = do
Handle -> IO ()
hFlush Handle
oldHandle
Handle -> IO ()
hFlush Handle
stdout
IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr FILE -> IO CInt
c_fflush Ptr FILE
cOldHandle
Fd -> IO a -> IO (ByteString, a)
forall a. Fd -> IO a -> IO (ByteString, a)
unsafeRedirectWriteFd Fd
oldFd (IO a -> IO (ByteString, a)) -> IO a -> IO (ByteString, a)
forall a b. (a -> b) -> a -> b
$ do
a
r <- IO a
f
Handle -> IO ()
hFlush Handle
oldHandle
IO CInt -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CInt -> IO ()) -> IO CInt -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr FILE -> IO CInt
c_fflush Ptr FILE
cOldHandle
a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
redirectStdout :: IO a -> IO (ByteString, a)
redirectStdout :: forall a. IO a -> IO (ByteString, a)
redirectStdout IO a
f = do
Ptr FILE
c_stdout <- IO (Ptr FILE)
cio_stdout
Fd -> Handle -> Ptr FILE -> IO a -> IO (ByteString, a)
forall a. Fd -> Handle -> Ptr FILE -> IO a -> IO (ByteString, a)
redirectWriteHandle Fd
stdOutput Handle
stdout Ptr FILE
c_stdout IO a
f
redirectStderr :: IO a -> IO (ByteString, a)
redirectStderr :: forall a. IO a -> IO (ByteString, a)
redirectStderr IO a
f = do
Ptr FILE
c_stderr <- IO (Ptr FILE)
cio_stderr
Fd -> Handle -> Ptr FILE -> IO a -> IO (ByteString, a)
forall a. Fd -> Handle -> Ptr FILE -> IO a -> IO (ByteString, a)
redirectWriteHandle Fd
stdError Handle
stderr Ptr FILE
c_stderr IO a
f
data FILE
foreign import ccall safe "stdio.h fflush"
c_fflush :: Ptr FILE -> IO CInt
foreign import ccall unsafe "hsredirect.h PosixRedirect_stdout"
cio_stdout :: IO (Ptr FILE)
foreign import ccall unsafe "hsredirect.h PosixRedirect_stderr"
cio_stderr :: IO (Ptr FILE)