{-# 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 sepearate 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 :: Socket -> IOException -> IO (Result a)
handleSocketError Socket
sk IOException
e =
    do Int
se <- Socket -> SocketOption -> IO Int
getSocketOption Socket
sk SocketOption
SoError
       case Int
se of
          Int
0     -> IOException -> IO (Result a)
forall a. IOException -> IO a
ioError IOException
e
          Int
10054 -> Result a -> IO (Result 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 (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 (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 (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 (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 { String
str <- Socket -> Int -> IO String
myrecv Socket
sk Int
x
             ; let len :: Int
len = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str
             ; if Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
x
                then ( Int -> IO String
fn (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
len) IO String -> (String -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
more -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
strString -> String -> String
forall a. [a] -> [a] -> [a]
++String
more) )
                else String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
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
     String
c <- Socket -> Int -> IO String
myrecv Socket
sk Int
1 -- like eating through a straw.
     if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
c Bool -> Bool -> Bool
|| String
c String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"\n"
      then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String
forall a. [a] -> [a]
reverse String
strString -> String -> String
forall a. [a] -> [a] -> [a]
++String
c)
      else String -> IO String
fn (String -> Char
forall a. [a] -> a
head String
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
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 (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 (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)