{-# LINE 1 "Network/Socket/ByteString/IO.hsc" #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.Socket.ByteString.IO
(
send
, sendAll
, sendTo
, sendAllTo
, sendMany
, sendManyTo
, recv
, recvFrom
, waitWhen0
, sendMsg
, recvMsg
, MsgFlag(..)
, Cmsg(..)
) where
import Control.Concurrent (threadWaitWrite, rtsSupportsBoundThreads)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.ByteString.Internal (createAndTrim)
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import Foreign.Marshal.Alloc (allocaBytes)
import Network.Socket.Buffer
import Network.Socket.ByteString.Internal
import Network.Socket.Imports
import Network.Socket.Types
import Data.ByteString.Internal (create, ByteString(..))
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Marshal.Utils (with)
import Network.Socket.Internal
import Network.Socket.Flag
{-# LINE 61 "Network/Socket/ByteString/IO.hsc" #-}
import Network.Socket.Posix.Cmsg
import Network.Socket.Posix.IOVec
import Network.Socket.Posix.MsgHdr (MsgHdr(..))
{-# LINE 70 "Network/Socket/ByteString/IO.hsc" #-}
send :: Socket
-> ByteString
-> IO Int
send s xs = unsafeUseAsCStringLen xs $ \(str, len) ->
sendBuf s (castPtr str) len
waitWhen0 :: Int -> Socket -> IO ()
waitWhen0 0 s = when rtsSupportsBoundThreads $
withFdSocket s $ \fd -> threadWaitWrite $ fromIntegral fd
waitWhen0 _ _ = return ()
sendAll :: Socket
-> ByteString
-> IO ()
sendAll _ "" = return ()
sendAll s bs0 = loop bs0
where
loop bs = do
sent <- send s bs
waitWhen0 sent s
when (sent /= B.length bs) $ loop $ B.drop sent bs
sendTo :: SocketAddress sa =>
Socket
-> ByteString
-> sa
-> IO Int
sendTo s xs sa =
unsafeUseAsCStringLen xs $ \(str, len) -> sendBufTo s str len sa
sendAllTo :: SocketAddress sa =>
Socket
-> ByteString
-> sa
-> IO ()
sendAllTo _ "" _ = return ()
sendAllTo s bs0 sa = loop bs0
where
loop bs = do
sent <- sendTo s bs sa
waitWhen0 sent s
when (sent /= B.length bs) $ loop $ B.drop sent bs
sendMany :: Socket
-> [ByteString]
-> IO ()
sendMany _ [] = return ()
sendMany s cs = do
sent <- sendManyInner
waitWhen0 sent s
when (sent >= 0) $ sendMany s $ remainingChunks sent cs
where
sendManyInner =
{-# LINE 154 "Network/Socket/ByteString/IO.hsc" #-}
fmap fromIntegral . withIOVecfromBS cs $ \(iovsPtr, iovsLen) ->
withFdSocket s $ \fd -> do
let len = fromIntegral $ min iovsLen (1024)
{-# LINE 157 "Network/Socket/ByteString/IO.hsc" #-}
throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendMany" $
c_writev fd iovsPtr len
{-# LINE 168 "Network/Socket/ByteString/IO.hsc" #-}
sendManyTo :: Socket
-> [ByteString]
-> SockAddr
-> IO ()
sendManyTo _ [] _ = return ()
sendManyTo s cs addr = do
sent <- fromIntegral <$> sendManyToInner
waitWhen0 sent s
when (sent >= 0) $ sendManyTo s (remainingChunks sent cs) addr
where
sendManyToInner =
withSockAddr addr $ \addrPtr addrSize ->
{-# LINE 188 "Network/Socket/ByteString/IO.hsc" #-}
withIOVecfromBS cs $ \(iovsPtr, iovsLen) -> do
let msgHdr = MsgHdr {
msgName = addrPtr
, msgNameLen = fromIntegral addrSize
, msgIov = iovsPtr
, msgIovLen = fromIntegral iovsLen
, msgCtrl = nullPtr
, msgCtrlLen = 0
, msgFlags = 0
}
withFdSocket s $ \fd ->
with msgHdr $ \msgHdrPtr ->
throwSocketErrorWaitWrite s "Network.Socket.ByteString.sendManyTo" $
c_sendmsg fd msgHdrPtr 0
{-# LINE 220 "Network/Socket/ByteString/IO.hsc" #-}
recv :: Socket
-> Int
-> IO ByteString
recv s nbytes
| nbytes < 0 = ioError (mkInvalidRecvArgError "Network.Socket.ByteString.recv")
| otherwise = createAndTrim nbytes $ \ptr -> recvBuf s ptr nbytes
recvFrom :: SocketAddress sa =>
Socket
-> Int
-> IO (ByteString, sa)
recvFrom sock nbytes =
allocaBytes nbytes $ \ptr -> do
(len, sockaddr) <- recvBufFrom sock ptr nbytes
str <- B.packCStringLen (ptr, len)
return (str, sockaddr)
remainingChunks :: Int -> [ByteString] -> [ByteString]
remainingChunks _ [] = []
remainingChunks i (x:xs)
| i < len = B.drop i x : xs
| otherwise = let i' = i - len in i' `seq` remainingChunks i' xs
where
len = B.length x
{-# LINE 279 "Network/Socket/ByteString/IO.hsc" #-}
withIOVecfromBS :: [ByteString] -> ((Ptr IOVec, Int) -> IO a) -> IO a
withIOVecfromBS cs f = withBufSizs cs $ \bufsizs -> withIOVec bufsizs f
{-# LINE 293 "Network/Socket/ByteString/IO.hsc" #-}
withBufSizs :: [ByteString] -> ([(Ptr Word8, Int)] -> IO a) -> IO a
withBufSizs bss0 f = loop bss0 id
where
loop [] !build = f $ build []
loop (PS fptr off len:bss) !build = withForeignPtr fptr $ \ptr -> do
let !ptr' = ptr `plusPtr` off
loop bss (build . ((ptr',len) :))
sendMsg :: Socket
-> SockAddr
-> [ByteString]
-> [Cmsg]
-> MsgFlag
-> IO Int
sendMsg _ _ [] _ _ = return 0
sendMsg s addr bss cmsgs flags = withBufSizs bss $ \bufsizs ->
sendBufMsg s addr bufsizs cmsgs flags
recvMsg :: Socket
-> Int
-> Int
-> MsgFlag
-> IO (SockAddr, ByteString, [Cmsg], MsgFlag)
recvMsg s siz clen flags = do
bs@(PS fptr _ _) <- create siz $ \ptr -> zeroMemory ptr (fromIntegral siz)
withForeignPtr fptr $ \ptr -> do
(addr,len,cmsgs,flags') <- recvBufMsg s [(ptr,siz)] clen flags
let bs' | len < siz = PS fptr 0 len
| otherwise = bs
return (addr, bs', cmsgs, flags')