-----------------------------------------------------------------------------
-- |
-- 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 Result String
val <- x -> Int -> IO (Result String)
forall x. Stream x => x -> Int -> IO (Result String)
readBlock x
x Int
n
           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 (Result String -> String
forall a. Show a => a -> String
show Result String
val)
           Result String -> IO (Result String)
forall (m :: * -> *) a. Monad m => a -> m a
return Result String
val
    readLine :: StreamDebugger x -> IO (Result String)
readLine (Dbg Handle
h x
x) =
        do Result String
val <- x -> IO (Result String)
forall x. Stream x => x -> IO (Result String)
readLine x
x
           Handle -> String -> IO ()
hPutStrLn Handle
h (String
"--readLine")
           Handle -> String -> IO ()
hPutStrLn Handle
h (Result String -> String
forall a. Show a => a -> String
show Result String
val)
           Result String -> IO (Result String)
forall (m :: * -> *) a. Monad m => a -> m a
return Result String
val
    writeBlock :: StreamDebugger x -> String -> IO (Result ())
writeBlock (Dbg Handle
h x
x) String
str =
        do Result ()
val <- x -> String -> IO (Result ())
forall x. Stream x => x -> String -> IO (Result ())
writeBlock x
x String
str
           Handle -> String -> IO ()
hPutStrLn Handle
h (String
"--writeBlock" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
str)
           Handle -> String -> IO ()
hPutStrLn Handle
h (Result () -> String
forall a. Show a => a -> String
show Result ()
val)
           Result () -> IO (Result ())
forall (m :: * -> *) a. Monad m => a -> m a
return Result ()
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 :: String -> a -> IO (StreamDebugger a)
debugStream String
file a
stream =
    do Handle
h <- String -> IOMode -> IO Handle
openFile String
file IOMode
AppendMode
       Handle -> String -> IO ()
hPutStrLn Handle
h (String
"File \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
file String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" opened for appending.")
       StreamDebugger a -> IO (StreamDebugger a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle -> a -> StreamDebugger a
forall x. Handle -> x -> StreamDebugger x
Dbg Handle
h a
stream)

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

debugStreamHooks :: HStream ty => Handle -> String -> StreamHooks ty
debugStreamHooks :: Handle -> String -> StreamHooks ty
debugStreamHooks Handle
h String
nm =
  StreamHooks :: forall ty.
((ty -> String) -> Result ty -> IO ())
-> ((ty -> String) -> Int -> Result ty -> IO ())
-> ((ty -> String) -> ty -> Result () -> IO ())
-> IO ()
-> String
-> StreamHooks ty
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
    }