{-# 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)