Network/StreamSocket.hs

{-# 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, send, recv, sClose
 , ShutdownCmd(ShutdownBoth), SocketOption(SoError)
 )

import Network.HTTP.Base ( catchIO )
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 sk e =
 do se <- getSocketOption sk SoError
 case se of
 0 -> ioError e
 10054 -> return $ Left ErrorReset -- reset
 _ -> return $ Left $ ErrorMisc $ show se

myrecv :: Socket -> Int -> IO String
myrecv sock len =
 let handler e = if isEOFError e then return [] else ioError e
 in catchIO (recv sock len) handler

instance Stream Socket where
 readBlock sk n = readBlockSocket sk n
 readLine sk = readLineSocket sk
 writeBlock sk str = writeBlockSocket sk str
 close sk = do
 -- This slams closed the connection (which is considered rude for TCP\/IP)
 shutdown sk ShutdownBoth
 sClose sk
 closeOnEnd _sk _ = return () -- can't really deal with this, so do run the risk of leaking sockets here.

readBlockSocket :: Socket -> Int -> IO (Result String)
readBlockSocket sk n = (liftM Right $ fn n) `catchIO` (handleSocketError sk)
 where
 fn x = do { str <- myrecv sk x
 ; let len = length str
 ; if len < x
 then ( fn (x-len) >>= \more -> return (str++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 sk = (liftM Right $ fn "") `catchIO` (handleSocketError sk)
 where
 fn str = do
 c <- myrecv sk 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 sk str = (liftM Right $ fn str) `catchIO` (handleSocketError sk)
 where
 fn [] = return ()
 fn x = send sk x >>= \i -> fn (drop i x)

AltStyle によって変換されたページ (->オリジナル) /