{-# OPTIONS_GHC -fno-warn-orphans #-}
module Network.StreamSocket
( handleSocketError
, myrecv
) where
import Network.Stream
( Stream(..), ConnError(ErrorReset, ErrorMisc), Result
)
import Network.Socket
( Socket, getSocketOption, shutdown
, ShutdownCmd(ShutdownBoth), SocketOption(SoError)
)
import Network.Socket.ByteString (send, recv)
import qualified Network.Socket
( close )
import Network.HTTP.Base ( catchIO )
import Network.HTTP.Utils ( fromUTF8BS, toUTF8BS )
import Control.Monad (liftM)
import Control.Exception as Exception (IOException)
import System.IO.Error (isEOFError)
handleSocketError :: Socket -> IOException -> IO (Result a)
handleSocketError :: forall a. Socket -> IOException -> IO (Result a)
handleSocketError Socket
sk IOException
e =
do se <- Socket -> SocketOption -> IO Int
getSocketOption Socket
sk SocketOption
SoError
case se of
Int
0 -> IOException -> IO (Result a)
forall a. IOException -> IO a
ioError IOException
e
Int
10054 -> Result a -> IO (Result a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result a -> IO (Result a)) -> Result a -> IO (Result a)
forall a b. (a -> b) -> a -> b
$ ConnError -> Result a
forall a b. a -> Either a b
Left ConnError
ErrorReset
Int
_ -> Result a -> IO (Result a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Result a -> IO (Result a)) -> Result a -> IO (Result a)
forall a b. (a -> b) -> a -> b
$ ConnError -> Result a
forall a b. a -> Either a b
Left (ConnError -> Result a) -> ConnError -> Result a
forall a b. (a -> b) -> a -> b
$ String -> ConnError
ErrorMisc (String -> ConnError) -> String -> ConnError
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
se
myrecv :: Socket -> Int -> IO String
myrecv :: Socket -> Int -> IO String
myrecv Socket
sock Int
len =
let handler :: IOException -> IO [a]
handler IOException
e = if IOException -> Bool
isEOFError IOException
e then [a] -> IO [a]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [] else IOException -> IO [a]
forall a. IOException -> IO a
ioError IOException
e
in IO String -> (IOException -> IO String) -> IO String
forall a. IO a -> (IOException -> IO a) -> IO a
catchIO ((ByteString -> String) -> IO ByteString -> IO String
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> String
fromUTF8BS (Socket -> Int -> IO ByteString
recv Socket
sock Int
len)) IOException -> IO String
forall {a}. IOException -> IO [a]
handler
instance Stream Socket where
readBlock :: Socket -> Int -> IO (Result String)
readBlock Socket
sk Int
n = Socket -> Int -> IO (Result String)
readBlockSocket Socket
sk Int
n
readLine :: Socket -> IO (Result String)
readLine Socket
sk = Socket -> IO (Result String)
readLineSocket Socket
sk
writeBlock :: Socket -> String -> IO (Result ())
writeBlock Socket
sk String
str = Socket -> String -> IO (Result ())
writeBlockSocket Socket
sk String
str
close :: Socket -> IO ()
close Socket
sk = do
Socket -> ShutdownCmd -> IO ()
shutdown Socket
sk ShutdownCmd
ShutdownBoth
Socket -> IO ()
Network.Socket.close Socket
sk
closeOnEnd :: Socket -> Bool -> IO ()
closeOnEnd Socket
_sk Bool
_ = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
readBlockSocket :: Socket -> Int -> IO (Result String)
readBlockSocket :: Socket -> Int -> IO (Result String)
readBlockSocket Socket
sk Int
n = ((String -> Result String) -> IO String -> IO (Result String)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM String -> Result String
forall a b. b -> Either a b
Right (IO String -> IO (Result String))
-> IO String -> IO (Result String)
forall a b. (a -> b) -> a -> b
$ Int -> IO String
fn Int
n) IO (Result String)
-> (IOException -> IO (Result String)) -> IO (Result String)
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` (Socket -> IOException -> IO (Result String)
forall a. Socket -> IOException -> IO (Result a)
handleSocketError Socket
sk)
where
fn :: Int -> IO String
fn Int
x = do { str <- Socket -> Int -> IO String
myrecv Socket
sk Int
x
; let len = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str
; if len < x
then ( fn (x-len) >>= \String
more -> String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
strString -> String -> String
forall a. [a] -> [a] -> [a]
++String
more) )
else return str
}
readLineSocket :: Socket -> IO (Result String)
readLineSocket :: Socket -> IO (Result String)
readLineSocket Socket
sk = ((String -> Result String) -> IO String -> IO (Result String)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM String -> Result String
forall a b. b -> Either a b
Right (IO String -> IO (Result String))
-> IO String -> IO (Result String)
forall a b. (a -> b) -> a -> b
$ String -> IO String
fn String
"") IO (Result String)
-> (IOException -> IO (Result String)) -> IO (Result String)
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` (Socket -> IOException -> IO (Result String)
forall a. Socket -> IOException -> IO (Result a)
handleSocketError Socket
sk)
where
fn :: String -> IO String
fn String
str = do
c <- Socket -> Int -> IO String
myrecv Socket
sk Int
1
if null c || c == "\n"
then return (reverse str++c)
else fn (head c:str)
writeBlockSocket :: Socket -> String -> IO (Result ())
writeBlockSocket :: Socket -> String -> IO (Result ())
writeBlockSocket Socket
sk String
str = ((() -> Result ()) -> IO () -> IO (Result ())
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM () -> Result ()
forall a b. b -> Either a b
Right (IO () -> IO (Result ())) -> IO () -> IO (Result ())
forall a b. (a -> b) -> a -> b
$ String -> IO ()
fn String
str) IO (Result ()) -> (IOException -> IO (Result ())) -> IO (Result ())
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` (Socket -> IOException -> IO (Result ())
forall a. Socket -> IOException -> IO (Result a)
handleSocketError Socket
sk)
where
fn :: String -> IO ()
fn [] = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
fn String
x = Socket -> ByteString -> IO Int
send Socket
sk (String -> ByteString
toUTF8BS String
x) IO Int -> (Int -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
i -> String -> IO ()
fn (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
i String
x)