module Network.Stream (
Debug,
Stream(..),
debugStream,
ConnError(..),
Result,
handleSocketError,
bindE,
myrecv
) where
import Control.Exception as Exception
import System.IO.Error
import Network (withSocketsDo)
import Network.BSD
import Network.URI
import Network.Socket
import Control.Monad (when,liftM,guard)
import System.IO
data ConnError = ErrorReset
| ErrorClosed
| ErrorParse String
| ErrorMisc String
deriving(Show,Eq)
bindE :: Either ConnError a -> (a -> Either ConnError b) -> Either ConnError b
bindE (Left e) _ = Left e
bindE (Right v) f = f v
type Result a = Either ConnError
a
class Stream x where
readLine :: x -> IO (Result String)
readBlock :: x -> Int -> IO (Result String)
writeBlock :: x -> String -> IO (Result ())
close :: x -> IO ()
handleSocketError :: Socket -> Exception -> IO (Result a)
handleSocketError sk e =
do { se <- getSocketOption sk SoError
; if se == 0
then throw e
else return $ if se == 10054
then Left ErrorReset
else Left $ ErrorMisc $ show se
}
instance Stream Socket where
readBlock sk n = (liftM Right $ fn n) `Exception.catch` (handleSocketError sk)
where
fn x = do { str <- myrecv sk x
; let len = length str
; if len < x
then ( fn (xlen) >>= \more -> return (str++more) )
else return str
}
readLine sk = (liftM Right $ fn "") `Exception.catch` (handleSocketError sk)
where
fn str =
do { c <- myrecv sk 1
; if null c || c == "\n"
then return (reverse str++c)
else fn (head c:str)
}
writeBlock sk str = (liftM Right $ fn str) `Exception.catch` (handleSocketError sk)
where
fn [] = return ()
fn x = send sk x >>= \i -> fn (drop i x)
close sk = shutdown sk ShutdownBoth >> sClose sk
myrecv :: Socket -> Int -> IO String
myrecv _ 0 = return ""
myrecv sock len =
let handler e = if isEOFError e then return [] else ioError e
in System.IO.Error.catch (recv sock len) handler
data Debug x = Dbg Handle x
instance (Stream x) => Stream (Debug x) where
readBlock (Dbg h c) n =
do { val <- readBlock c n
; hPutStrLn h ("readBlock " ++ show n ++ ' ' : show val)
; return val
}
readLine (Dbg h c) =
do { val <- readLine c
; hPutStrLn h ("readLine " ++ show val)
; return val
}
writeBlock (Dbg h c) str =
do { val <- writeBlock c str
; hPutStrLn h ("writeBlock " ++ show val ++ ' ' : show str)
; return val
}
close (Dbg h c) =
do { hPutStrLn h "closing..."
; hFlush h
; close c
; hPutStrLn h "...closed"
; hClose h
}
debugStream :: (Stream a) => String -> a -> IO (Debug a)
debugStream file stm =
do { h <- openFile file AppendMode
; hPutStrLn h "File opened for appending."
; return (Dbg h stm)
}