-----------------------------------------------------------------------------

-- |

-- 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 (Dbg h x) n =

        do val <- readBlock x n

           hPutStrLn h ("--readBlock " ++ show n)

           hPutStrLn h (show val)

           return val

    readLine (Dbg h x) =

        do val <- readLine x

           hPutStrLn h ("--readLine")

           hPutStrLn h (show val)

           return val

    writeBlock (Dbg h x) str =

        do val <- writeBlock x str

           hPutStrLn h ("--writeBlock" ++ show str)

           hPutStrLn h (show val)

           return val

    close (Dbg h x) =

        do hPutStrLn h "--closing..."

           hFlush h

           close x

           hPutStrLn h "--closed."

           hClose h

    closeOnEnd (Dbg h x) f =

        do hPutStrLn h ("--close-on-end.." ++ show f)

           hFlush h 

           closeOnEnd x 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 file stream = 

    do h <- openFile file AppendMode

       hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.")

       return (Dbg h stream)

debugByteStream :: HStream ty => FilePath -> HandleStream ty -> IO (HandleStream ty)

debugByteStream file stream = do

   sh <- getStreamHooks stream 

   case sh of

     Just h 

      | hook_name h == file -> return stream -- reuse the stream hooks.

     _ -> do

       h <- openFile file 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 h nm = 

  StreamHooks

    { hook_readBlock = \ toStr n val -> do

       let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v}

       hPutStrLn h ("--readBlock " ++ show n)

       hPutStrLn h (either show show eval)

    , hook_readLine = \ toStr val -> do

           let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v}

           hPutStrLn h ("--readLine")

           hPutStrLn h (either show show eval)

    , hook_writeBlock = \ toStr str val -> do

           hPutStrLn h ("--writeBlock " ++ show val)

           hPutStrLn h (toStr str)

    , hook_close = do

           hPutStrLn h "--closing..."

           hFlush h

           hClose h

    , hook_name = nm

    }