{-# OPTIONS -#include "HsNet.h" #-}
module NetExtra 
	( fdSocket 	-- :: Socket -> CInt
	, send		-- :: Socket -> String -> IO Int
	, recv		-- :: Socket -> Int -> IO String
	) where

import SocketPrim

import CForeign
import Foreign

import Concurrent ( threadWaitWrite, threadWaitRead )

import PrelCError
import CString
import CTypes
import Ptr
import Monad

fdSocket :: Socket -> CInt
fdSocket (MkSocket fd _ _ _ _) = fd

send :: Socket -> String -> IO Int
send sock xs = do
 let fd = fdSocket sock
 withCString xs $ \str -> do
  liftM fromIntegral $
     throwErrnoIfMinus1Retry_repeatOnBlock "send"
	(threadWaitWrite (fromIntegral fd)) $
	c_send fd str (fromIntegral $ length xs) 0{-flags-} 

recv :: Socket -> Int -> IO String
recv sock nbytes = do
  let fd = fdSocket sock
  allocaBytes nbytes $ \ptr -> do
        len <- throwErrnoIfMinus1Retry_repeatOnBlock "recv" 
        	   (threadWaitRead (fromIntegral fd)) $
        	   c_recv fd ptr (fromIntegral nbytes) 0{-flags-} 
        let len' = fromIntegral len
        peekCStringLen (ptr,len')

-- ripped straight out of SocketPrim.hsc
throwErrnoIfMinus1Retry_repeatOnBlock :: Num a => String -> IO b -> IO a -> IO a
throwErrnoIfMinus1Retry_repeatOnBlock name on_block act = do
  throwErrnoIfMinus1Retry_mayBlock name (on_block >> repeat) act
  where repeat = throwErrnoIfMinus1Retry_repeatOnBlock name on_block act

throwErrnoIfMinus1Retry_mayBlock :: Num a => String -> IO a -> IO a -> IO a
throwErrnoIfMinus1Retry_mayBlock name on_block act = do
    res <- act
    if res == -1
        then do
            err <- getErrno
            if err == eINTR
                then throwErrnoIfMinus1Retry_mayBlock name on_block act
	        else if err == eWOULDBLOCK || err == eAGAIN
		        then on_block
                        else throwErrno name
        else return res

foreign import "send" unsafe
  c_send :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt

foreign import "recv" unsafe
  c_recv :: CInt -> Ptr CChar -> CSize -> CInt -> IO CInt