{-# LINE 1 "src/System/Socket/Type/Stream.hsc" #-}
module System.Socket.Type.Stream (
Stream
, sendAll
, sendAllLazy
, sendAllBuilder
, receiveAll
) where
import Control.Exception (throwIO)
import Control.Monad (when)
import Data.Int
import Data.Word
import Data.Monoid
import Foreign.Ptr
import Foreign.Marshal.Alloc
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BS
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Builder.Internal as BB
import qualified Data.ByteString.Lazy as LBS
import System.Socket
import System.Socket.Unsafe
data Stream
instance Type Stream where
typeNumber _ = (1)
{-# LINE 47 "src/System/Socket/Type/Stream.hsc" #-}
sendAll :: Socket f Stream p -> BS.ByteString -> MessageFlags -> IO Int
sendAll s bs flags = do
BS.unsafeUseAsCStringLen bs (uncurry sendAllPtr)
return (BS.length bs)
where
sendAllPtr :: Ptr a -> Int -> IO ()
sendAllPtr ptr len = do
sent <- fromIntegral `fmap` unsafeSend s ptr (fromIntegral len) flags
when (sent < len) $ sendAllPtr (plusPtr ptr sent) (len - sent)
sendAllLazy :: Socket f Stream p -> LBS.ByteString -> MessageFlags -> IO Int64
sendAllLazy s lbs flags =
LBS.foldlChunks f (return 0) lbs
where
f action bs = do
sent <- action
sent' <- fromIntegral `fmap` sendAll s bs flags
return $! sent + sent'
sendAllBuilder :: Socket f Stream p -> Int -> BB.Builder -> MessageFlags -> IO Int64
sendAllBuilder s bufsize builder flags = do
allocaBytes bufsize g
where
g ptr = writeStep (BB.runPut $ BB.putBuilder builder) 0
where
bufferRange :: BB.BufferRange
bufferRange =
BB.BufferRange ptr (plusPtr ptr bufsize)
writeStep :: BB.BuildStep a -> Int64 -> IO Int64
writeStep step alreadySent =
BB.fillWithBuildStep step whenDone whenFull whenChunk bufferRange
where
whenDone ptrToNextFreeByte _
| len > 0 = do
sendAllPtr ptr len
return $! alreadySent + fromIntegral len
| otherwise =
return alreadySent
where
len = minusPtr ptrToNextFreeByte ptr
whenFull ptrToNextFreeByte minBytesRequired nextStep
| minBytesRequired > bufsize =
throwIO eNoBufferSpace
| otherwise = do
sendAllPtr ptr len
writeStep nextStep $! alreadySent + fromIntegral len
where
len = minusPtr ptrToNextFreeByte ptr
whenChunk ptrToNextFreeByte bs nextStep = do
sendAllPtr ptr len
if BS.null bs
then
writeStep nextStep $! alreadySent + fromIntegral len
else do
bsLen <- sendAll s bs flags
writeStep nextStep $! alreadySent + fromIntegral (len + bsLen)
where
len = minusPtr ptrToNextFreeByte ptr
sendAllPtr :: Ptr Word8 -> Int -> IO ()
sendAllPtr ptr len = do
sent <- fromIntegral `fmap` unsafeSend s ptr (fromIntegral len) flags
when (sent < len) $ sendAllPtr (plusPtr ptr sent) (len - sent)
receiveAll :: Socket f Stream p -> Int64 -> MessageFlags -> IO LBS.ByteString
receiveAll sock maxLen flags = collect 0 Data.Monoid.mempty
where
collect len accum
| len > maxLen = do
build accum
| otherwise = do
bs <- receive sock BB.smallChunkSize flags
if BS.null bs then do
build accum
else do
collect (len + fromIntegral (BS.length bs))
$! (accum `Data.Monoid.mappend` BB.byteString bs)
build accum = do
return (BB.toLazyByteString accum)
{-# DEPRECATED receiveAll "Semantics will change in the next major release. Don't use it anymore!" #-}