diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2010, Edward Z. Yang + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Edward Z. Yang nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/System/Posix/Redirect.hs b/System/Posix/Redirect.hs new file mode 100644 --- /dev/null +++ b/System/Posix/Redirect.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface #-} + +{- | +Module : System.Posix.Redirect +Copyright : Galois, Inc. 2010 +Maintainer : ezyang@galois.com +Stability : experimental +Portability : non-portable (POSIX, GHC) + +Misbehaved third-party libraries (usually not written in Haskell) +may print error messages directly to stdout or stderr when we would +actually like to capture them and propagate them as a normal exception. +In such cases, it would be useful to temporarily override those file +descriptors to point to a pipe that we control. + +This module is not portable and not thread safe. However, it can +safely manage arbitrarily large amounts of data, as it spins off another +thread to read from the pipe created; therefore, you must use -threaded +to compile a program with this. If you are making a foreign call, +you must ensure that the foreign call is marked safe or there is a +possibility of deadlock. + +While this module is an interesting novelty, it is the module author's +opinion that it is not a sustainable method for making C libraries +behave properly, primarily due to its unportability (this trick does not +appear to be possible on Windows). Use at your own risk. +-} + +module System.Posix.Redirect + ( redirectStdout + , redirectStderr + -- * Low-level operations + , redirectWriteHandle + , unsafeRedirectWriteFd + ) where + +import System.Posix.Types +import System.Posix.IO +import System.IO + +import Foreign +import Foreign.C.Types + +import Control.Concurrent +import Control.Exception + +dupTo_ :: Fd -> Fd -> IO () +dupTo_ a b = dupTo a b >>= \_ -> return () + +-- | @'unsafeRedirectFd' fd f@ executes the computation @f@, passing as +-- an argument a handle which is the read end of a pipe that +-- @fd@ now points to. When the computation is done, the original file +-- descriptor is restored. Use with care: if there are any file +-- handles with this descriptor that have unflushed buffers, they will +-- not flush to the old file descriptor, but the new file descriptor. +unsafeRedirectWriteFd :: Fd -> IO a -> IO (String, a) +unsafeRedirectWriteFd fd f = do + -- setup + (rfd, wfd) <- createPipe + old <- dup fd + dupTo_ wfd fd + -- fork a thread to consume output + outMVar <- newEmptyMVar + outHandle <- fdToHandle rfd + out <- hGetContents outHandle + _ <- forkIO $ do + _ <- evaluate (length out) + putMVar outMVar () + -- run the code + r <- f + -- cleanup + dupTo_ old fd + closeFd wfd + -- wait for output + takeMVar outMVar + hClose outHandle + return (out, r) + +-- | @'redirectWriteHandle' oldFd oldHandle oldCHandle f@ executes the +-- computation @f@, passing as an argument a handle which is the read +-- end of a pipe that @fd@ now points to. This function appropriately +-- flushes the Haskell @oldHandle@ and the C @oldCHandle@ before +-- and after @f@'s execution. +redirectWriteHandle :: Fd -> Handle -> Ptr FILE -> IO a -> IO (String, a) +redirectWriteHandle oldFd oldHandle cOldHandle f = do + hFlush oldHandle + hFlush stdout + _ <- c_fflush cOldHandle + unsafeRedirectWriteFd oldFd $ do + r <- f + hFlush oldHandle + _ <- c_fflush cOldHandle + return r + +-- | @'redirectStdout f' redirects standard output during the execution +-- of @f@ into a pipe passed as the first argument to @f@. +redirectStdout :: IO a -> IO (String, a) +redirectStdout f = do + c_stdout <- cio_stdout + redirectWriteHandle stdOutput stdout c_stdout f + +-- | @'redirectStderr f' redirects standard error during the execution +-- of @f@ into a pipe passed as the first argument to @f@. +redirectStderr :: IO a -> IO (String, a) +redirectStderr f = do + c_stderr <- cio_stderr + redirectWriteHandle stdError stderr c_stderr f + +--------------------------------------------------- +-- FFI imports, since we need to flush the C buffer + +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) diff --git a/cbits/hsredirect.c b/cbits/hsredirect.c new file mode 100644 --- /dev/null +++ b/cbits/hsredirect.c @@ -0,0 +1,14 @@ +#include + +/** + * Helper functions for stdout and stderr, because I can't evaluate them + * at compile/link time. + */ + +FILE *PosixRedirect_stdout() { + return stdout; +} + +FILE *PosixRedirect_stderr() { + return stderr; +} diff --git a/include/hsredirect.h b/include/hsredirect.h new file mode 100644 --- /dev/null +++ b/include/hsredirect.h @@ -0,0 +1,4 @@ +#include + +FILE *PosixRedirect_stdout(); +FILE *PosixRedirect_stderr(); diff --git a/system-posix-redirect.cabal b/system-posix-redirect.cabal new file mode 100644 --- /dev/null +++ b/system-posix-redirect.cabal @@ -0,0 +1,36 @@ +Name: system-posix-redirect +Version: 1.0 +Synopsis: A toy module that allows you to temporarily redirect + a program's stdout. +Description: Due to the design of POSIX, it is possible to + temporarily overload the file descriptors + corresponding to stdout and stderr to point to an + arbitrary pipe. It is, however, tricky to get + right. This module gets it right, as far as such + a terrible hack can be made right. It can be used + to make misbehaving third-party C libraries stop + spewing to standard output. Warning: the module + author has concluded that due to lack of + portability, this module should not be used in any + serious sytem. But, for those who like living + dangerously... +License: BSD3 +License-file: LICENSE +Author: Galois Inc. +Maintainer: ezyang@galois.com +Copyright: (c) 2010 Galois Inc. +Category: System +Build-type: Simple +Extra-source-files: include/*.h + cbits/*.c +Cabal-Version: >= 1.6 + +Library + Exposed-modules: System.Posix.Redirect + Extensions: ForeignFunctionInterface, + EmptyDataDecls + Build-depends: base == 4.*, + unix >= 2.4.0 && < 2.5 + C-sources: cbits/hsredirect.c + Include-dirs: include + Install-includes: include/hsredirect.h