    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Network.StreamDebugger
    -- Copyright   :  See LICENSE file
    -- License     :  BSD
    --
    -- Maintainer  :  Ganesh Sittampalam <ganesh@earth.li>
    -- Stability   :  experimental
    -- Portability :  non-portable (not tested)
    --
    -- Implements debugging of @Stream@s.  Originally part of Gray's\/Bringert's
    -- HTTP module.
    --
    -- * Changes by Robin Bate Boerop <robin@bateboerop.name>:
    --      - Created.  Made minor formatting changes.
    --
    -----------------------------------------------------------------------------
    module Network.StreamDebugger
       ( StreamDebugger
       , debugStream
       , debugByteStream
       ) where

    import Network.Stream (Stream(..))
    import System.IO
       ( Handle, hFlush, hPutStrLn, IOMode(AppendMode), hClose, openFile,
         hSetBuffering, BufferMode(NoBuffering)
       )
    import Network.TCP ( HandleStream, HStream,
                         StreamHooks(..), setStreamHooks, getStreamHooks )

    -- | Allows stream logging.  Refer to 'debugStream' below.
    data StreamDebugger x
       = Dbg Handle x

    instance (Stream x) => Stream (StreamDebugger x) where
        readBlock :: StreamDebugger x -> Int -> IO (Result String)
    readBlock (Dbg Handle
    h x
    x) Int
    n =
            do val <- x -> Int -> IO (Result String)
    forall x. Stream x => x -> Int -> IO (Result String)
    readBlock x
    x Int
    n
               hPutStrLn h ("--readBlock " ++ show n)
               hPutStrLn h (show val)
               return val
        readLine :: StreamDebugger x -> IO (Result String)
    readLine (Dbg Handle
    h x
    x) =
            do val <- x -> IO (Result String)
    forall x. Stream x => x -> IO (Result String)
    readLine x
    x
               hPutStrLn h ("--readLine")
               hPutStrLn h (show val)
               return val
        writeBlock :: StreamDebugger x -> String -> IO (Result ())
    writeBlock (Dbg Handle
    h x
    x) String
    str =
            do val <- x -> String -> IO (Result ())
    forall x. Stream x => x -> String -> IO (Result ())
    writeBlock x
    x String
    str
               hPutStrLn h ("--writeBlock" ++ show str)
               hPutStrLn h (show val)
               return val
        close :: StreamDebugger x -> IO ()
    close (Dbg Handle
    h x
    x) =
            do Handle -> String -> IO ()
    hPutStrLn Handle
    h String
    "--closing..."
               Handle -> IO ()
    hFlush Handle
    h
               x -> IO ()
    forall x. Stream x => x -> IO ()
    close x
    x
               Handle -> String -> IO ()
    hPutStrLn Handle
    h String
    "--closed."
               Handle -> IO ()
    hClose Handle
    h
        closeOnEnd :: StreamDebugger x -> Bool -> IO ()
    closeOnEnd (Dbg Handle
    h x
    x) Bool
    f =
            do Handle -> String -> IO ()
    hPutStrLn Handle
    h (String
    "--close-on-end.." String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Bool -> String
    forall a. Show a => a -> String
    show Bool
    f)
               Handle -> IO ()
    hFlush Handle
    h
               x -> Bool -> IO ()
    forall x. Stream x => x -> Bool -> IO ()
    closeOnEnd x
    x Bool
    f

    -- | Wraps a stream with logging I\/O.
    --   The first argument is a filename which is opened in @AppendMode@.
    debugStream :: (Stream a) => FilePath -> a -> IO (StreamDebugger a)
    debugStream :: forall a. Stream a => String -> a -> IO (StreamDebugger a)
    debugStream String
    file a
    stream =
        do h <- String -> IOMode -> IO Handle
    openFile String
    file IOMode
    AppendMode
           hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.")
           return (Dbg h stream)

    debugByteStream :: HStream ty => FilePath -> HandleStream ty -> IO (HandleStream ty)
    debugByteStream :: forall ty.
    HStream ty =>
    String -> HandleStream ty -> IO (HandleStream ty)
    debugByteStream String
    file HandleStream ty
    stream = do
       sh <- HandleStream ty -> IO (Maybe (StreamHooks ty))
    forall ty. HandleStream ty -> IO (Maybe (StreamHooks ty))
    getStreamHooks HandleStream ty
    stream
       case sh of
         Just StreamHooks ty
    h
          | StreamHooks ty -> String
    forall ty. StreamHooks ty -> String
    hook_name StreamHooks ty
    h String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String
    file -> HandleStream ty -> IO (HandleStream ty)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return HandleStream ty
    stream -- reuse the stream hooks.
         Maybe (StreamHooks ty)
    _ -> do
           h <- String -> IOMode -> IO Handle
    openFile String
    file IOMode
    AppendMode
           hSetBuffering h NoBuffering
           hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.")
           setStreamHooks stream (debugStreamHooks h file)
           return stream

    debugStreamHooks :: HStream ty => Handle -> String -> StreamHooks ty
    debugStreamHooks :: forall ty. HStream ty => Handle -> String -> StreamHooks ty
    debugStreamHooks Handle
    h String
    nm =
      StreamHooks
        { hook_readBlock :: (ty -> String) -> Int -> Result ty -> IO ()
    hook_readBlock = \ ty -> String
    toStr Int
    n Result ty
    val -> do
           let eval :: Result String
    eval = case Result ty
    val of { Left ConnError
    e -> ConnError -> Result String
    forall a b. a -> Either a b
    Left ConnError
    e ; Right ty
    v -> String -> Result String
    forall a b. b -> Either a b
    Right (String -> Result String) -> String -> Result String
    forall a b. (a -> b) -> a -> b
    $ ty -> String
    toStr ty
    v}
           Handle -> String -> IO ()
    hPutStrLn Handle
    h (String
    "--readBlock " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    n)
           Handle -> String -> IO ()
    hPutStrLn Handle
    h ((ConnError -> String)
    -> (String -> String) -> Result String -> String
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either ConnError -> String
    forall a. Show a => a -> String
    show String -> String
    forall a. Show a => a -> String
    show Result String
    eval)
        , hook_readLine :: (ty -> String) -> Result ty -> IO ()
    hook_readLine = \ ty -> String
    toStr Result ty
    val -> do
               let eval :: Result String
    eval = case Result ty
    val of { Left ConnError
    e -> ConnError -> Result String
    forall a b. a -> Either a b
    Left ConnError
    e ; Right ty
    v -> String -> Result String
    forall a b. b -> Either a b
    Right (String -> Result String) -> String -> Result String
    forall a b. (a -> b) -> a -> b
    $ ty -> String
    toStr ty
    v}
               Handle -> String -> IO ()
    hPutStrLn Handle
    h (String
    "--readLine")
               Handle -> String -> IO ()
    hPutStrLn Handle
    h ((ConnError -> String)
    -> (String -> String) -> Result String -> String
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
    either ConnError -> String
    forall a. Show a => a -> String
    show String -> String
    forall a. Show a => a -> String
    show Result String
    eval)
        , hook_writeBlock :: (ty -> String) -> ty -> Result () -> IO ()
    hook_writeBlock = \ ty -> String
    toStr ty
    str Result ()
    val -> do
               Handle -> String -> IO ()
    hPutStrLn Handle
    h (String
    "--writeBlock " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Result () -> String
    forall a. Show a => a -> String
    show Result ()
    val)
               Handle -> String -> IO ()
    hPutStrLn Handle
    h (ty -> String
    toStr ty
    str)
        , hook_close :: IO ()
    hook_close = do
               Handle -> String -> IO ()
    hPutStrLn Handle
    h String
    "--closing..."
               Handle -> IO ()
    hFlush Handle
    h
               Handle -> IO ()
    hClose Handle
    h
        , hook_name :: String
    hook_name = String
    nm
        }