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 )
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
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
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
}