diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,14 @@ This project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [0.7.0.0] - 2023-08-30 + +- For now, remove all of the functions that work on UnliftedArray. These + will be added back later once hackage starts using GHC 9.4. They are + now guarded by CPP, so if anyone was using them, build this library + with the `UNLIFTEDARRAYFUNCTIONS` flag to get them back. +- Add `uninterruptibleConnectPtr` for better compatibility with `network`. + ## [0.6.1.0] - 2023-08-14 - Add `uninterruptibleWriteBytesCompletelyErrno` diff --git a/posix-api.cabal b/posix-api.cabal --- a/posix-api.cabal +++ b/posix-api.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: posix-api -version: 0.6.1.0 +version: 0.7.0.0 synopsis: posix bindings description: This library provides a very thin wrapper around POSIX APIs. It can be @@ -76,6 +76,13 @@ description: Extra run-time invariant checking default: False +-- This only exists to help get this library to build on hackage. +-- Whenever hackage moves to GHC 9.4, remove this. +flag unliftedarrayfunctions + manual: True + description: Build and export functions using unlifted arrays + default: False + library exposed-modules: Foreign.C.String.Managed @@ -102,15 +109,16 @@ Posix.Socket.Types Assertion build-depends: - , base >=4.17.1 && <5 + , base >=4.16.3 && <5 , byte-order >= 0.1.2 && <0.2 , byteslice >= 0.2.10 && <0.3 , primitive >= 0.7 && <0.10 , primitive-addr >= 0.1 && <0.2 , primitive-offset >= 0.2 && <0.3 - , primitive-unlifted >= 2.0 && <2.2 , run-st >= 0.1.1 && <0.2 , text-short >=0.1.5 + if flag(unliftedarrayfunctions) + build-depends: primitive-unlifted >=2.1 && <2.2 hs-source-dirs: src if flag(assertions) hs-source-dirs: src-assertions diff --git a/src/Linux/Socket.hs b/src/Linux/Socket.hs --- a/src/Linux/Socket.hs +++ b/src/Linux/Socket.hs @@ -1,4 +1,5 @@ {-# language BangPatterns #-} +{-# language CPP #-} {-# language DataKinds #-} {-# language MagicHash #-} {-# language ScopedTypeVariables #-} @@ -7,12 +8,14 @@ module Linux.Socket ( -- * Functions - uninterruptibleReceiveMultipleMessageA + uninterruptibleAccept4 + , uninterruptibleAccept4_ +#if defined(UNLIFTEDARRAYFUNCTIONS) + , uninterruptibleReceiveMultipleMessageA , uninterruptibleReceiveMultipleMessageB , uninterruptibleReceiveMultipleMessageC , uninterruptibleReceiveMultipleMessageD - , uninterruptibleAccept4 - , uninterruptibleAccept4_ +#endif -- * Types , SocketFlags(..) -- * Option Names @@ -52,9 +55,11 @@ import Data.Bits ((.|.)) import Data.Primitive (MutableByteArray(..),ByteArray(..),MutablePrimArray(..)) import Data.Primitive.Addr (Addr(..),plusAddr,nullAddr) +#if defined(UNLIFTEDARRAYFUNCTIONS) import Data.Primitive.Unlifted.Array (MutableUnliftedArray,UnliftedArray) import Data.Primitive.Unlifted.Array (MutableUnliftedArray_(MutableUnliftedArray)) import Data.Primitive.Unlifted.Array.Primops (MutableUnliftedArray#(MutableUnliftedArray#)) +#endif import Data.Void (Void) import Data.Word (Word8) import Foreign.C.Error (Errno,getErrno) @@ -69,7 +74,9 @@ import qualified Control.Monad.Primitive as PM import qualified Data.Primitive as PM +#if defined(UNLIFTEDARRAYFUNCTIONS) import qualified Data.Primitive.Unlifted.Array as PM +#endif import qualified Linux.Socket.Types as LST import qualified Posix.Socket as S @@ -99,6 +106,7 @@ -> SocketFlags -> IO Fd +#if defined(UNLIFTEDARRAYFUNCTIONS) foreign import ccall unsafe "HaskellPosix.h recvmmsg_sockaddr_in" c_unsafe_recvmmsg_sockaddr_in :: Fd @@ -117,6 +125,7 @@ -> CUInt -- Length of msghdr array -> MessageFlags 'Receive -> IO CInt +#endif -- | Linux extends the @type@ argument of -- to allow @@ -135,6 +144,7 @@ applySocketFlags :: SocketFlags -> Type -> Type applySocketFlags (SocketFlags s) (Type t) = Type (s .|. t) +#if defined(UNLIFTEDARRAYFUNCTIONS) -- | Receive multiple messages. This does not provide the socket -- addresses or the control messages. It does not use any of the -- input-scattering that @recvmmsg@ offers, meaning that a single @@ -343,6 +353,7 @@ else do a <- PM.unsafeFreezeUnliftedArray r pure (validation,maxMsgSz,a) +#endif pokeMultipleMessageHeader :: Addr -> Addr -> CInt -> Addr -> CSize -> Addr -> CSize -> MessageFlags 'Receive -> CUInt -> IO () pokeMultipleMessageHeader mmsgHdrAddr a b c d e f g len = do @@ -419,8 +430,10 @@ touchMutableByteArray# :: MutableByteArray# RealWorld -> IO () touchMutableByteArray# x = IO $ \s -> case touch# x s of s' -> (# s', () #) +#if defined(UNLIFTEDARRAYFUNCTIONS) touchMutableUnliftedArray :: MutableUnliftedArray RealWorld a -> IO () touchMutableUnliftedArray (MutableUnliftedArray x) = touchMutableUnliftedArray# x touchMutableUnliftedArray# :: MutableUnliftedArray# RealWorld a -> IO () touchMutableUnliftedArray# x = IO $ \s -> case touch# x s of s' -> (# s', () #) +#endif diff --git a/src/Posix/File.hs b/src/Posix/File.hs --- a/src/Posix/File.hs +++ b/src/Posix/File.hs @@ -16,6 +16,7 @@ , writeBytesCompletelyErrno , uninterruptibleOpen , uninterruptibleOpenMode + , uninterruptibleOpenUntypedFlags , writeByteArray , writeMutableByteArray , close @@ -116,6 +117,15 @@ -> IO (Either Errno Fd) uninterruptibleOpen (ManagedCString (ByteArray name)) (AccessMode x) (CreationFlags y) (StatusFlags z) = c_unsafe_open name (x .|. y .|. z) >>= errorsFromFd + +-- | Variant of 'uninterruptibleOpen' that does not help the caller with +-- the types of the flags. +uninterruptibleOpenUntypedFlags :: + ManagedCString -- ^ NULL-terminated file name + -> CInt -- ^ Flags + -> IO (Either Errno Fd) +uninterruptibleOpenUntypedFlags (ManagedCString (ByteArray name)) x = + c_unsafe_open name x >>= errorsFromFd uninterruptibleOpenMode :: ManagedCString -- ^ NULL-terminated file name diff --git a/src/Posix/Socket.hs b/src/Posix/Socket.hs --- a/src/Posix/Socket.hs +++ b/src/Posix/Socket.hs @@ -42,6 +42,7 @@ -- ** Connect , connect , uninterruptibleConnect + , uninterruptibleConnectPtr -- ** Listen , uninterruptibleListen -- ** Accept @@ -76,7 +77,9 @@ , uninterruptibleSendToInternetByteArray , uninterruptibleSendToInternetMutableByteArray -- ** Write Vector +#if defined(UNLIFTEDARRAYFUNCTIONS) , writeVector +#endif -- ** Receive , receive , receiveByteArray @@ -90,12 +93,16 @@ , uninterruptibleReceiveFromInternetMutableByteArray -- ** Receive Message -- $receiveMessage +#if defined(UNLIFTEDARRAYFUNCTIONS) , uninterruptibleReceiveMessageA , uninterruptibleReceiveMessageB +#endif -- ** Send Message , uninterruptibleSendMessageA , uninterruptibleSendMessageB +#if defined(UNLIFTEDARRAYFUNCTIONS) , uninterruptibleSendByteArrays +#endif -- ** Byte-Order Conversion -- $conversion , hostToNetworkLong @@ -206,9 +213,13 @@ import GHC.IO (IO(..)) import Data.Primitive.Addr (Addr(..),plusAddr,nullAddr) import Data.Primitive (MutablePrimArray(..),MutableByteArray(..),ByteArray(..)) + +#if defined(UNLIFTEDARRAYFUNCTIONS) import Data.Primitive.Unlifted.Array (MutableUnliftedArray,UnliftedArray,UnliftedArray_(UnliftedArray)) import Data.Primitive.Unlifted.Array (MutableUnliftedArray_(MutableUnliftedArray)) import Data.Primitive.Unlifted.Array.Primops (UnliftedArray#(UnliftedArray#),MutableUnliftedArray#) +#endif + import Data.Primitive.ByteArray.Offset (MutableByteArrayOffset(..)) import Data.Primitive.PrimArray.Offset (MutablePrimArrayOffset(..)) import Data.Word (Word8,Word16,Word32,byteSwap16,byteSwap32) @@ -217,7 +228,7 @@ import Foreign.C.String (CString) import Foreign.C.Types (CInt(..),CSize(..)) import Foreign.Ptr (nullPtr) -import GHC.Exts (Ptr,RealWorld,ByteArray#,MutableByteArray#) +import GHC.Exts (Ptr(Ptr),RealWorld,ByteArray#,MutableByteArray#) import GHC.Exts (Addr#,TYPE) import GHC.Exts (Int(I#)) import GHC.Exts (shrinkMutableByteArray#,touch#) @@ -237,7 +248,9 @@ import qualified Posix.File as F import qualified Posix.Socket.Types as PST import qualified Data.Primitive as PM +#if defined(UNLIFTEDARRAYFUNCTIONS) import qualified Data.Primitive.Unlifted.Array as PM +#endif import qualified Control.Monad.Primitive as PM import qualified GHC.Exts as Exts @@ -348,6 +361,8 @@ c_safe_mutablebytearray_connect :: Fd -> MutableByteArray# RealWorld -> CInt -> IO CInt foreign import ccall unsafe "sys/socket.h connect" c_unsafe_connect :: Fd -> ByteArray# -> CInt -> IO CInt +foreign import ccall unsafe "sys/socket.h connect" + c_unsafe_connect_addr :: Fd -> Addr# -> CInt -> IO CInt -- There are several options for wrapping send. Both safe and unsafe -- are useful. Additionally, in the unsafe category, we also @@ -390,8 +405,10 @@ foreign import ccall unsafe "HaskellPosix.h sendmsg_b" c_unsafe_sendmsg_b :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> Addr# -> CSize -> MessageFlags 'Send -> IO CSsize +#if defined(UNLIFTEDARRAYFUNCTIONS) foreign import ccall unsafe "HaskellPosix.h sendmsg_bytearrays" c_unsafe_sendmsg_bytearrays :: Fd -> UnliftedArray# ByteArray# -> Int -> Int -> Int -> MessageFlags 'Send -> IO CSsize +#endif foreign import ccall safe "sys/uio.h writev" c_safe_writev :: Fd -> MutableByteArray# RealWorld -> CInt -> IO CSsize @@ -549,6 +566,14 @@ uninterruptibleConnect fd (SocketAddress sockAddr@(ByteArray sockAddr#)) = c_unsafe_connect fd sockAddr# (intToCInt (PM.sizeofByteArray sockAddr)) >>= errorsFromInt_ +uninterruptibleConnectPtr :: + Fd -- ^ Fd + -> Ptr a -- ^ Socket address + -> Int -- ^ Size of socket address + -> IO (Either Errno ()) +uninterruptibleConnectPtr !fd (Ptr sockAddr#) !sz = + c_unsafe_connect_addr fd sockAddr# (intToCInt sz) >>= errorsFromInt_ + -- | Extract the first connection on the queue of pending connections. The -- -- includes more details. This function\'s type differs slightly from @@ -735,50 +760,6 @@ PM.copyByteArray x off b 0 (csizeToInt len) errorsFromSize =<< c_safe_mutablebytearray_no_offset_send fd x# len flags --- | Write data from multiple byte arrays to the file/socket associated --- with the file descriptor. This does not support slicing. The --- --- of @writev@ includes more details. -writeVector :: - Fd -- ^ Socket - -> UnliftedArray ByteArray -- ^ Source byte arrays - -> IO (Either Errno CSize) -writeVector fd buffers = do - iovecs@(MutableByteArray iovecs#) :: MutableByteArray RealWorld <- - PM.newPinnedByteArray - (cintToInt PST.sizeofIOVector * PM.sizeofUnliftedArray buffers) - - -- We construct a list of the new buffers for the sole purpose - -- of ensuring that we can touch the list later to keep all - -- the new buffers live. - newBufs <- foldDownward (PM.sizeofUnliftedArray buffers) UNil $ \newBufs i -> do - let !buf = PM.indexUnliftedArray buffers i - pinByteArray buf >>= \case - Nothing -> do - let buffer = buf - let targetAddr :: Addr - targetAddr = ptrToAddr (PM.mutableByteArrayContents iovecs) `plusAddr` - (i * cintToInt PST.sizeofIOVector) - PST.pokeIOVectorBase targetAddr (ptrToAddr (PM.byteArrayContents buffer)) - PST.pokeIOVectorLength targetAddr (intToCSize (PM.sizeofByteArray buffer)) - pure newBufs - Just buffer -> do - let targetAddr :: Addr - targetAddr = ptrToAddr (PM.mutableByteArrayContents iovecs) `plusAddr` - (i * cintToInt PST.sizeofIOVector) - PST.pokeIOVectorBase targetAddr (ptrToAddr (PM.byteArrayContents buffer)) - PST.pokeIOVectorLength targetAddr (intToCSize (PM.sizeofByteArray buffer)) - pure (UCons (unByteArray buffer) newBufs) - r <- errorsFromSize =<< - c_safe_writev fd iovecs# (intToCInt (PM.sizeofUnliftedArray buffers)) - -- Touching both the unlifted array and the list of new buffers - -- here is crucial to ensuring that - -- the buffers do not get GCed before c_safe_writev. Just touching - -- them should keep all of their children alive too. - touchUnliftedArray buffers - touchLifted newBufs - pure r - #if MIN_VERSION_base(4,16,0) data UList (a :: TYPE ('BoxedRep 'Unlifted)) where #else @@ -843,23 +824,6 @@ c_unsafe_sendmsg_b fd (unMba array) offset lenB addr lenA flags >>= errorsFromSize --- | Send many immutable byte arrays with @sendmsg@. --- This accepts a slice into the chunks. Additionally, --- this accepts an offset into the first chunk. -uninterruptibleSendByteArrays :: - Fd -- ^ Socket - -> UnliftedArray ByteArray -- ^ Byte arrays - -> Int -- ^ Offset into byte array chunks - -> Int -- ^ Number of chunks to send - -> Int -- ^ Offset into first chunk - -> MessageFlags 'Send - -> IO (Either Errno CSize) -{-# inline uninterruptibleSendByteArrays #-} -uninterruptibleSendByteArrays !fd (UnliftedArray arrs) - off !len !offC !flags = - c_unsafe_sendmsg_bytearrays fd arrs off len offC flags - >>= errorsFromSize - -- | Send data from a mutable byte array over a network socket. Users -- may specify an offset and a length to send fewer bytes than are -- actually present in the array. Since this uses the safe @@ -1167,86 +1131,9 @@ c_unsafe_addr_peerless_recvfrom fd b len flags >>= errorsFromSize --- | Receive a message, scattering the input. This does not provide --- the socket address or the control messages. All of the chunks --- must have the same maximum size. All resulting byte arrays have --- been explicitly pinned. -uninterruptibleReceiveMessageA :: - Fd -- ^ Socket - -> CSize -- ^ Maximum bytes per chunk - -> CSize -- ^ Maximum number of chunks - -> MessageFlags 'Receive -- ^ Flags - -> IO (Either Errno (CSize,UnliftedArray ByteArray)) -uninterruptibleReceiveMessageA !s !chunkSize !chunkCount !flags = do - bufs <- PM.unsafeNewUnliftedArray (csizeToInt chunkCount) - iovecsBuf <- PM.newPinnedByteArray (csizeToInt chunkCount * cintToInt PST.sizeofIOVector) - let iovecsAddr = ptrToAddr (PM.mutableByteArrayContents iovecsBuf) - initializeIOVectors bufs iovecsAddr chunkSize chunkCount - msgHdrBuf <- PM.newPinnedByteArray (cintToInt PST.sizeofMessageHeader) - let !msgHdrAddr@(Addr msgHdrAddr#) = ptrToAddr (PM.mutableByteArrayContents msgHdrBuf) - pokeMessageHeader msgHdrAddr nullAddr 0 iovecsAddr chunkCount nullAddr 0 flags - r <- c_unsafe_addr_recvmsg s msgHdrAddr# flags - if r > (-1) - then do - filled <- countAndShrinkIOVectors (csizeToInt chunkCount) (cssizeToInt r) (csizeToInt chunkSize) bufs - frozenBufs <- deepFreezeIOVectors filled bufs - touchMutableUnliftedArray bufs - touchMutableByteArray iovecsBuf - touchMutableByteArray msgHdrBuf - pure (Right (cssizeToCSize r,frozenBufs)) - else do - touchMutableUnliftedArray bufs - touchMutableByteArray iovecsBuf - touchMutableByteArray msgHdrBuf - fmap Left getErrno - ptrToAddr :: Ptr Word8 -> Addr ptrToAddr (Exts.Ptr a) = Addr a --- | Receive a message, scattering the input. This provides the socket --- address but does not include control messages. All of the chunks --- must have the same maximum size. All resulting byte arrays have --- been explicitly pinned. -uninterruptibleReceiveMessageB :: - Fd -- ^ Socket - -> CSize -- ^ Maximum bytes per chunk - -> CSize -- ^ Maximum number of chunks - -> MessageFlags 'Receive -- ^ Flags - -> CInt -- ^ Maximum socket address size - -> IO (Either Errno (CInt,SocketAddress,CSize,UnliftedArray ByteArray)) -uninterruptibleReceiveMessageB !s !chunkSize !chunkCount !flags !maxSockAddrSz = do - sockAddrBuf <- PM.newPinnedByteArray (cintToInt maxSockAddrSz) - bufs <- PM.unsafeNewUnliftedArray (csizeToInt chunkCount) - iovecsBuf <- PM.newPinnedByteArray (csizeToInt chunkCount * cintToInt PST.sizeofIOVector) - let iovecsAddr = ptrToAddr (PM.mutableByteArrayContents iovecsBuf) - initializeIOVectors bufs iovecsAddr chunkSize chunkCount - msgHdrBuf <- PM.newPinnedByteArray (cintToInt PST.sizeofMessageHeader) - let !msgHdrAddr@(Addr msgHdrAddr#) = ptrToAddr (PM.mutableByteArrayContents msgHdrBuf) - pokeMessageHeader msgHdrAddr - (ptrToAddr (PM.mutableByteArrayContents sockAddrBuf)) maxSockAddrSz iovecsAddr - chunkCount nullAddr 0 flags - r <- c_unsafe_addr_recvmsg s msgHdrAddr# flags - if r > (-1) - then do - actualSockAddrSz <- PST.peekMessageHeaderNameLength msgHdrAddr - if actualSockAddrSz < maxSockAddrSz - then shrinkMutableByteArray sockAddrBuf (cintToInt actualSockAddrSz) - else pure () - sockAddr <- PM.unsafeFreezeByteArray sockAddrBuf - filled <- countAndShrinkIOVectors (csizeToInt chunkCount) (cssizeToInt r) (csizeToInt chunkSize) bufs - frozenBufs <- deepFreezeIOVectors filled bufs - touchMutableUnliftedArray bufs - touchMutableByteArray iovecsBuf - touchMutableByteArray msgHdrBuf - touchMutableByteArray sockAddrBuf - pure (Right (actualSockAddrSz,SocketAddress sockAddr,cssizeToCSize r,frozenBufs)) - else do - touchMutableUnliftedArray bufs - touchMutableByteArray iovecsBuf - touchMutableByteArray msgHdrBuf - touchMutableByteArray sockAddrBuf - fmap Left getErrno - -- | Shutdown a socket. This uses the unsafe FFI. uninterruptibleShutdown :: Fd @@ -1330,6 +1217,144 @@ PST.pokeMessageHeaderControlLength msgHdrAddr f PST.pokeMessageHeaderFlags msgHdrAddr g +#if defined(UNLIFTEDARRAYFUNCTIONS) +-- | Write data from multiple byte arrays to the file/socket associated +-- with the file descriptor. This does not support slicing. The +-- +-- of @writev@ includes more details. +writeVector :: + Fd -- ^ Socket + -> UnliftedArray ByteArray -- ^ Source byte arrays + -> IO (Either Errno CSize) +writeVector fd buffers = do + iovecs@(MutableByteArray iovecs#) :: MutableByteArray RealWorld <- + PM.newPinnedByteArray + (cintToInt PST.sizeofIOVector * PM.sizeofUnliftedArray buffers) + -- We construct a list of the new buffers for the sole purpose + -- of ensuring that we can touch the list later to keep all + -- the new buffers live. + newBufs <- foldDownward (PM.sizeofUnliftedArray buffers) UNil $ \newBufs i -> do + let !buf = PM.indexUnliftedArray buffers i + pinByteArray buf >>= \case + Nothing -> do + let buffer = buf + let targetAddr :: Addr + targetAddr = ptrToAddr (PM.mutableByteArrayContents iovecs) `plusAddr` + (i * cintToInt PST.sizeofIOVector) + PST.pokeIOVectorBase targetAddr (ptrToAddr (PM.byteArrayContents buffer)) + PST.pokeIOVectorLength targetAddr (intToCSize (PM.sizeofByteArray buffer)) + pure newBufs + Just buffer -> do + let targetAddr :: Addr + targetAddr = ptrToAddr (PM.mutableByteArrayContents iovecs) `plusAddr` + (i * cintToInt PST.sizeofIOVector) + PST.pokeIOVectorBase targetAddr (ptrToAddr (PM.byteArrayContents buffer)) + PST.pokeIOVectorLength targetAddr (intToCSize (PM.sizeofByteArray buffer)) + pure (UCons (unByteArray buffer) newBufs) + r <- errorsFromSize =<< + c_safe_writev fd iovecs# (intToCInt (PM.sizeofUnliftedArray buffers)) + -- Touching both the unlifted array and the list of new buffers + -- here is crucial to ensuring that + -- the buffers do not get GCed before c_safe_writev. Just touching + -- them should keep all of their children alive too. + touchUnliftedArray buffers + touchLifted newBufs + pure r + +-- | Send many immutable byte arrays with @sendmsg@. +-- This accepts a slice into the chunks. Additionally, +-- this accepts an offset into the first chunk. +uninterruptibleSendByteArrays :: + Fd -- ^ Socket + -> UnliftedArray ByteArray -- ^ Byte arrays + -> Int -- ^ Offset into byte array chunks + -> Int -- ^ Number of chunks to send + -> Int -- ^ Offset into first chunk + -> MessageFlags 'Send + -> IO (Either Errno CSize) +{-# inline uninterruptibleSendByteArrays #-} +uninterruptibleSendByteArrays !fd (UnliftedArray arrs) + off !len !offC !flags = + c_unsafe_sendmsg_bytearrays fd arrs off len offC flags + >>= errorsFromSize + +-- | Receive a message, scattering the input. This does not provide +-- the socket address or the control messages. All of the chunks +-- must have the same maximum size. All resulting byte arrays have +-- been explicitly pinned. +uninterruptibleReceiveMessageA :: + Fd -- ^ Socket + -> CSize -- ^ Maximum bytes per chunk + -> CSize -- ^ Maximum number of chunks + -> MessageFlags 'Receive -- ^ Flags + -> IO (Either Errno (CSize,UnliftedArray ByteArray)) +uninterruptibleReceiveMessageA !s !chunkSize !chunkCount !flags = do + bufs <- PM.unsafeNewUnliftedArray (csizeToInt chunkCount) + iovecsBuf <- PM.newPinnedByteArray (csizeToInt chunkCount * cintToInt PST.sizeofIOVector) + let iovecsAddr = ptrToAddr (PM.mutableByteArrayContents iovecsBuf) + initializeIOVectors bufs iovecsAddr chunkSize chunkCount + msgHdrBuf <- PM.newPinnedByteArray (cintToInt PST.sizeofMessageHeader) + let !msgHdrAddr@(Addr msgHdrAddr#) = ptrToAddr (PM.mutableByteArrayContents msgHdrBuf) + pokeMessageHeader msgHdrAddr nullAddr 0 iovecsAddr chunkCount nullAddr 0 flags + r <- c_unsafe_addr_recvmsg s msgHdrAddr# flags + if r > (-1) + then do + filled <- countAndShrinkIOVectors (csizeToInt chunkCount) (cssizeToInt r) (csizeToInt chunkSize) bufs + frozenBufs <- deepFreezeIOVectors filled bufs + touchMutableUnliftedArray bufs + touchMutableByteArray iovecsBuf + touchMutableByteArray msgHdrBuf + pure (Right (cssizeToCSize r,frozenBufs)) + else do + touchMutableUnliftedArray bufs + touchMutableByteArray iovecsBuf + touchMutableByteArray msgHdrBuf + fmap Left getErrno + +-- | Receive a message, scattering the input. This provides the socket +-- address but does not include control messages. All of the chunks +-- must have the same maximum size. All resulting byte arrays have +-- been explicitly pinned. +uninterruptibleReceiveMessageB :: + Fd -- ^ Socket + -> CSize -- ^ Maximum bytes per chunk + -> CSize -- ^ Maximum number of chunks + -> MessageFlags 'Receive -- ^ Flags + -> CInt -- ^ Maximum socket address size + -> IO (Either Errno (CInt,SocketAddress,CSize,UnliftedArray ByteArray)) +uninterruptibleReceiveMessageB !s !chunkSize !chunkCount !flags !maxSockAddrSz = do + sockAddrBuf <- PM.newPinnedByteArray (cintToInt maxSockAddrSz) + bufs <- PM.unsafeNewUnliftedArray (csizeToInt chunkCount) + iovecsBuf <- PM.newPinnedByteArray (csizeToInt chunkCount * cintToInt PST.sizeofIOVector) + let iovecsAddr = ptrToAddr (PM.mutableByteArrayContents iovecsBuf) + initializeIOVectors bufs iovecsAddr chunkSize chunkCount + msgHdrBuf <- PM.newPinnedByteArray (cintToInt PST.sizeofMessageHeader) + let !msgHdrAddr@(Addr msgHdrAddr#) = ptrToAddr (PM.mutableByteArrayContents msgHdrBuf) + pokeMessageHeader msgHdrAddr + (ptrToAddr (PM.mutableByteArrayContents sockAddrBuf)) maxSockAddrSz iovecsAddr + chunkCount nullAddr 0 flags + r <- c_unsafe_addr_recvmsg s msgHdrAddr# flags + if r > (-1) + then do + actualSockAddrSz <- PST.peekMessageHeaderNameLength msgHdrAddr + if actualSockAddrSz < maxSockAddrSz + then shrinkMutableByteArray sockAddrBuf (cintToInt actualSockAddrSz) + else pure () + sockAddr <- PM.unsafeFreezeByteArray sockAddrBuf + filled <- countAndShrinkIOVectors (csizeToInt chunkCount) (cssizeToInt r) (csizeToInt chunkSize) bufs + frozenBufs <- deepFreezeIOVectors filled bufs + touchMutableUnliftedArray bufs + touchMutableByteArray iovecsBuf + touchMutableByteArray msgHdrBuf + touchMutableByteArray sockAddrBuf + pure (Right (actualSockAddrSz,SocketAddress sockAddr,cssizeToCSize r,frozenBufs)) + else do + touchMutableUnliftedArray bufs + touchMutableByteArray iovecsBuf + touchMutableByteArray msgHdrBuf + touchMutableByteArray sockAddrBuf + fmap Left getErrno + -- This sets up an array of iovec. The iov_len is assigned to the -- same length in all of these. The actual buffers are allocated -- and stuck in an unlifted array. Pointers to these buffers (we can @@ -1407,23 +1432,24 @@ else PM.unsafeFreezeUnliftedArray x go 0 -unByteArray :: ByteArray -> ByteArray# -unByteArray (ByteArray x) = x - touchMutableUnliftedArray :: MutableUnliftedArray RealWorld a -> IO () touchMutableUnliftedArray (MutableUnliftedArray x) = touchMutableUnliftedArray# x touchUnliftedArray :: UnliftedArray a -> IO () touchUnliftedArray (UnliftedArray x) = touchUnliftedArray# x -touchMutableByteArray :: MutableByteArray RealWorld -> IO () -touchMutableByteArray (MutableByteArray x) = touchMutableByteArray# x - touchMutableUnliftedArray# :: MutableUnliftedArray# RealWorld a -> IO () touchMutableUnliftedArray# x = IO $ \s -> case touch# x s of s' -> (# s', () #) touchUnliftedArray# :: UnliftedArray# a -> IO () touchUnliftedArray# x = IO $ \s -> case touch# x s of s' -> (# s', () #) +#endif + +unByteArray :: ByteArray -> ByteArray# +unByteArray (ByteArray x) = x + +touchMutableByteArray :: MutableByteArray RealWorld -> IO () +touchMutableByteArray (MutableByteArray x) = touchMutableByteArray# x touchMutableByteArray# :: MutableByteArray# RealWorld -> IO () touchMutableByteArray# x = IO $ \s -> case touch# x s of s' -> (# s', () #)