{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Network.StreamSocket
-- Copyright   :  See LICENSE file
-- License     :  BSD
--
-- Maintainer  :  Ganesh Sittampalam <ganesh@earth.li>
-- Stability   :  experimental
-- Portability :  non-portable (not tested)
--
-- Socket Stream instance. Originally part of Gray's\/Bringert's HTTP module.
--
-- * Changes by Robin Bate Boerop <robin@bateboerop.name>:
--      - Made dependencies explicit in import statements.
--      - Removed false dependencies in import statements.
--      - Created separate module for instance Stream Socket.
--
-- * Changes by Simon Foster:
--      - Split module up into to separate Network.[Stream,TCP,HTTP] modules
--
-----------------------------------------------------------------------------
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)

-- | Exception handler for socket operations.
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  -- reset
          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
        -- This slams closed the connection (which is considered rude for TCP\/IP)
         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 () -- can't really deal with this, so do run the risk of leaking sockets here.

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
             }

-- Use of the following function is discouraged.
-- The function reads in one character at a time,
-- which causes many calls to the kernel recv()
-- hence causes many context switches.
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 -- like eating through a straw.
     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)