posix-api 0.4.0.0 → 0.4.0.1
raw patch · 6 files changed
+56/−38 lines, 6 filesdep +text-shortdep ~basedep ~byteslicedep ~primitive-unlifted
Dependencies added: text-short
Dependency ranges changed: base, byteslice, primitive-unlifted
Files
- CHANGELOG.md +4/−0
- posix-api.cabal +5/−4
- src/Foreign/C/String/Managed.hs +7/−0
- src/Linux/Socket.hs +19/−15
- src/Posix/Socket.hs +7/−5
- test/Main.hs +14/−14
CHANGELOG.md view
@@ -7,6 +7,10 @@ This project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## [0.4.0.1] - 2023-06-27++- Build with GHC 9.4+ ## [0.4.0.0] - 2022-12-08 - Add `writeMutableByteArray`
posix-api.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: posix-api-version: 0.4.0.0+version: 0.4.0.1 synopsis: posix bindings description: This library provides a very thin wrapper around POSIX APIs. It can be@@ -103,14 +103,15 @@ Posix.Socket.Types Assertion build-depends:- , base >=4.11.1 && <5+ , base >=4.17.1 && <5 , byte-order >= 0.1.2 && <0.2- , byteslice >= 0.1.3 && <0.3+ , byteslice >= 0.2.10 && <0.3 , primitive >= 0.7 && <0.8 , primitive-addr >= 0.1 && <0.2 , primitive-offset >= 0.2 && <0.3- , primitive-unlifted >= 0.1 && <0.2+ , primitive-unlifted >= 2.0 && <2.1 , run-st >= 0.1.1 && <0.2+ , text-short >=0.1.5 hs-source-dirs: src if flag(assertions) hs-source-dirs: src-assertions
src/Foreign/C/String/Managed.hs view
@@ -14,6 +14,7 @@ , unterminated , fromBytes , fromLatinString+ , fromShortText , pinnedFromBytes , pin , touch@@ -25,6 +26,7 @@ import Data.Bytes.Types (Bytes(Bytes)) import Data.Char (ord) import Data.Primitive (ByteArray(..),MutableByteArray)+import Data.Text.Short (ShortText) import Data.Word (Word8) import Foreign.C.String (CString) import Foreign.Ptr (castPtr)@@ -32,7 +34,9 @@ import GHC.IO (IO(IO)) import qualified Data.Bytes as Bytes+import qualified Data.Bytes.Text.Utf8 as Utf8 import qualified Data.Primitive as PM+import qualified Data.Text.Short as TS import qualified GHC.Exts as Exts -- | An unsliced byte sequence with @NUL@ as the final byte.@@ -75,6 +79,9 @@ unterminated :: ManagedCString -> Bytes unterminated (ManagedCString x) = Bytes x 0 (PM.sizeofByteArray x - 1)++fromShortText :: ShortText -> ManagedCString+fromShortText !ts = fromBytes (Utf8.fromShortText ts) -- | Copies the slice, appending a @NUL@ byte to the end. fromBytes :: Bytes -> ManagedCString
src/Linux/Socket.hs view
@@ -51,16 +51,18 @@ import Data.Bits ((.|.)) import Data.Primitive.Addr (Addr(..),plusAddr,nullAddr) import Data.Primitive (MutableByteArray(..),ByteArray(..),MutablePrimArray(..))-import Data.Primitive.Unlifted.Array (MutableUnliftedArray(..),UnliftedArray)+import Data.Primitive.Unlifted.Array (MutableUnliftedArray,UnliftedArray)+import Data.Primitive.Unlifted.Array (MutableUnliftedArray_(MutableUnliftedArray)) import Data.Word (Word8) import Foreign.C.Error (Errno,getErrno) import Foreign.C.Types (CInt(..),CSize(..),CUInt(..))-import GHC.Exts (Ptr(..),RealWorld,MutableByteArray#,Addr#,MutableArrayArray#,Int(I#))+import GHC.Exts (Ptr(..),RealWorld,MutableArray#,MutableByteArray#,Addr#,Int(I#)) import GHC.Exts (shrinkMutableByteArray#,touch#,nullAddr#) import GHC.IO (IO(..)) import Linux.Socket.Types (SocketFlags(..)) import Posix.Socket (Type(..),MessageFlags(..),Message(Receive),SocketAddress(..)) import System.Posix.Types (Fd(..),CSsize(..))+import Data.Primitive.Unlifted.Array.Primops (MutableUnliftedArray#(MutableUnliftedArray#)) import qualified Data.Primitive as PM import qualified Data.Primitive.Unlifted.Array as PM@@ -88,7 +90,7 @@ Fd -> MutableByteArray# RealWorld -- lengths -> MutableByteArray# RealWorld -- sockaddrs- -> MutableArrayArray# RealWorld -- buffers+ -> MutableArray# RealWorld (MutableByteArray# RealWorld) -- buffers -> CUInt -- Length of msghdr array -> MessageFlags 'Receive -> IO CInt@@ -97,7 +99,7 @@ c_unsafe_recvmmsg_sockaddr_discard :: Fd -> MutableByteArray# RealWorld -- lengths- -> MutableArrayArray# RealWorld -- buffers+ -> MutableArray# RealWorld (MutableByteArray# RealWorld) -- buffers -> CUInt -- Length of msghdr array -> MessageFlags 'Receive -> IO CInt@@ -137,7 +139,8 @@ -> MessageFlags 'Receive -- ^ Flags -> IO (Either Errno (CUInt,UnliftedArray ByteArray)) uninterruptibleReceiveMultipleMessageA !s !msgSize !msgCount !flags = do- bufs <- PM.unsafeNewUnliftedArray (cuintToInt msgCount)+ placeholder <- PM.newByteArray 0+ bufs <- PM.newUnliftedArray (cuintToInt msgCount) placeholder mmsghdrsBuf <- PM.newPinnedByteArray (cuintToInt msgCount * cintToInt LST.sizeofMultipleMessageHeader) iovecsBuf <- PM.newPinnedByteArray (cuintToInt msgCount * cintToInt S.sizeofIOVector) let !mmsghdrsAddr@(Addr mmsghdrsAddr#) = ptrToAddr (PM.mutableByteArrayContents mmsghdrsBuf)@@ -190,7 +193,8 @@ -> MessageFlags 'Receive -- ^ Flags -> IO (Either Errno (CInt,ByteArray,CUInt,UnliftedArray ByteArray)) uninterruptibleReceiveMultipleMessageB !s !expSockAddrSize !msgSize !msgCount !flags = do- bufs <- PM.unsafeNewUnliftedArray (cuintToInt msgCount)+ placeholder <- PM.newByteArray 0+ bufs <- PM.newUnliftedArray (cuintToInt msgCount) placeholder mmsghdrsBuf <- PM.newPinnedByteArray (cuintToInt msgCount * cintToInt LST.sizeofMultipleMessageHeader) iovecsBuf <- PM.newPinnedByteArray (cuintToInt msgCount * cintToInt S.sizeofIOVector) sockaddrsBuf <- PM.newPinnedByteArray (cuintToInt msgCount * cintToInt expSockAddrSize)@@ -226,7 +230,7 @@ -> CUInt -- ^ Maximum number of datagrams to receive, length of buffers -> MessageFlags 'Receive -- ^ Flags -> IO (Either Errno CInt)-uninterruptibleReceiveMultipleMessageC !s (MutablePrimArray lens) (MutablePrimArray addrs) (PM.MutableUnliftedArray payloads) !msgCount !flags =+uninterruptibleReceiveMultipleMessageC !s (MutablePrimArray lens) (MutablePrimArray addrs) (MutableUnliftedArray (MutableUnliftedArray# payloads)) !msgCount !flags = c_unsafe_recvmmsg_sockaddr_in s lens addrs payloads msgCount flags >>= errorsFromInt -- | All three buffer arguments need to have the same length (in elements, not bytes).@@ -238,7 +242,7 @@ -> CUInt -- ^ Maximum number of datagrams to receive, length of buffers -> MessageFlags 'Receive -- ^ Flags -> IO (Either Errno CInt)-uninterruptibleReceiveMultipleMessageD !s (MutablePrimArray lens) (PM.MutableUnliftedArray payloads) !msgCount !flags =+uninterruptibleReceiveMultipleMessageD !s (MutablePrimArray lens) (MutableUnliftedArray (MutableUnliftedArray# payloads)) !msgCount !flags = c_unsafe_recvmmsg_sockaddr_discard s lens payloads msgCount flags >>= errorsFromInt -- This sets up an array of mmsghdr. Each msghdr has msg_iov set to@@ -263,7 +267,7 @@ -- be an array of iovec with a single element. One giant buffer with -- space for all of the @sockaddr@s is used. initializeMultipleMessageHeadersWithSockAddr ::- MutableUnliftedArray RealWorld (MutableByteArray RealWorld) -- buffers+ MutableUnliftedArray RealWorld (MutableByteArray RealWorld) -> Addr -- array of iovec -> Addr -- array of message headers -> Addr -- array of sockaddrs@@ -382,14 +386,14 @@ then pure (Right r) else fmap Left getErrno -touchMutableUnliftedArray :: MutableUnliftedArray RealWorld a -> IO ()-touchMutableUnliftedArray (MutableUnliftedArray x) = touchMutableUnliftedArray# x- touchMutableByteArray :: MutableByteArray RealWorld -> IO () touchMutableByteArray (MutableByteArray x) = touchMutableByteArray# x -touchMutableUnliftedArray# :: MutableArrayArray# RealWorld -> IO ()-touchMutableUnliftedArray# x = IO $ \s -> case touch# x s of s' -> (# s', () #)- touchMutableByteArray# :: MutableByteArray# RealWorld -> IO () touchMutableByteArray# x = IO $ \s -> case touch# x s of s' -> (# s', () #)++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', () #)
src/Posix/Socket.hs view
@@ -206,7 +206,9 @@ import GHC.IO (IO(..)) import Data.Primitive.Addr (Addr(..),plusAddr,nullAddr) import Data.Primitive (MutablePrimArray(..),MutableByteArray(..),ByteArray(..))-import Data.Primitive.Unlifted.Array (MutableUnliftedArray(..),UnliftedArray(..))+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#) import Data.Primitive.ByteArray.Offset (MutableByteArrayOffset(..)) import Data.Primitive.PrimArray.Offset (MutablePrimArrayOffset(..)) import Data.Word (Word8,Word16,Word32,byteSwap16,byteSwap32)@@ -217,7 +219,7 @@ import Foreign.Ptr (nullPtr) import GHC.Exts (Ptr,RealWorld,ByteArray#,MutableByteArray#) import GHC.Exts (Addr#,TYPE)-import GHC.Exts (ArrayArray#,MutableArrayArray#,Int(I#))+import GHC.Exts (Int(I#)) import GHC.Exts (shrinkMutableByteArray#,touch#) import Posix.Socket.Types (Family(..),Protocol(..),Type(..),SocketAddress(..)) import Posix.Socket.Types (SocketAddressInternet(..))@@ -389,7 +391,7 @@ c_unsafe_sendmsg_b :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> Addr# -> CSize -> MessageFlags 'Send -> IO CSsize foreign import ccall unsafe "HaskellPosix.h sendmsg_bytearrays"- c_unsafe_sendmsg_bytearrays :: Fd -> ArrayArray# -> Int -> Int -> Int -> MessageFlags 'Send -> IO CSsize+ c_unsafe_sendmsg_bytearrays :: Fd -> UnliftedArray# ByteArray# -> Int -> Int -> Int -> MessageFlags 'Send -> IO CSsize foreign import ccall safe "sys/uio.h writev" c_safe_writev :: Fd -> MutableByteArray# RealWorld -> CInt -> IO CSsize@@ -1417,10 +1419,10 @@ touchMutableByteArray :: MutableByteArray RealWorld -> IO () touchMutableByteArray (MutableByteArray x) = touchMutableByteArray# x -touchMutableUnliftedArray# :: MutableArrayArray# RealWorld -> IO ()+touchMutableUnliftedArray# :: MutableUnliftedArray# RealWorld a -> IO () touchMutableUnliftedArray# x = IO $ \s -> case touch# x s of s' -> (# s', () #) -touchUnliftedArray# :: ArrayArray# -> IO ()+touchUnliftedArray# :: UnliftedArray# a -> IO () touchUnliftedArray# x = IO $ \s -> case touch# x s of s' -> (# s', () #) touchMutableByteArray# :: MutableByteArray# RealWorld -> IO ()
test/Main.hs view
@@ -55,7 +55,7 @@ testSocketsA :: Assertion testSocketsA = do- (a,b) <- demand =<< S.uninterruptibleSocketPair S.unix S.datagram S.defaultProtocol+ (a,b) <- demand =<< S.uninterruptibleSocketPair S.Unix S.datagram S.defaultProtocol m <- PM.newEmptyMVar _ <- forkIO $ S.receiveByteArray b 5 mempty >>= PM.putMVar m bytesSent <- demand =<< S.sendByteArray a sample 0 5 mempty@@ -68,7 +68,7 @@ let limit = 10 wordSz = PM.sizeOf (undefined :: Int) cwordSz = fromIntegral wordSz :: CSize- (a,b) <- demand =<< S.uninterruptibleSocketPair S.unix S.datagram S.defaultProtocol+ (a,b) <- demand =<< S.uninterruptibleSocketPair S.Unix S.datagram S.defaultProtocol lock <- PM.newEmptyMVar let go1 !(ix :: Int) !(n :: Int) = if (ix < limit) then do@@ -95,7 +95,7 @@ testSocketsC :: Assertion testSocketsC = do- (a,b) <- demand =<< S.uninterruptibleSocketPair S.unix S.datagram S.defaultProtocol+ (a,b) <- demand =<< S.uninterruptibleSocketPair S.Unix S.datagram S.defaultProtocol m <- PM.newEmptyMVar _ <- forkIO $ S.receiveByteArray a 5 mempty >>= PM.putMVar m bytesSent <- demand =<< S.sendByteArray b sample 0 5 mempty@@ -105,7 +105,7 @@ testSocketsD :: Assertion testSocketsD = do- (a,b) <- demand =<< S.uninterruptibleSocketPair S.unix S.datagram S.defaultProtocol+ (a,b) <- demand =<< S.uninterruptibleSocketPair S.Unix S.datagram S.defaultProtocol _ <- forkIO $ do bytesSent <- demand =<< S.sendByteArray b sample 0 5 mempty when (bytesSent /= 5) (fail "testSocketsD: bytesSent was wrong")@@ -114,7 +114,7 @@ testSocketsE :: Assertion testSocketsE = do- (a,b) <- demand =<< S.uninterruptibleSocketPair S.unix S.datagram S.defaultProtocol+ (a,b) <- demand =<< S.uninterruptibleSocketPair S.Unix S.datagram S.defaultProtocol _ <- forkIO $ do threadWaitWrite b bytesSent <- demand =<< S.uninterruptibleSendByteArray b sample 0 5 mempty@@ -125,14 +125,14 @@ testSocketsF :: Assertion testSocketsF = do- a <- demand =<< S.uninterruptibleSocket S.internet S.datagram S.defaultProtocol+ a <- demand =<< S.uninterruptibleSocket S.Internet S.datagram S.defaultProtocol demand =<< S.uninterruptibleBind a (S.encodeSocketAddressInternet (S.SocketAddressInternet {S.port = 0, S.address = localhost})) (expectedSzA,expectedSockAddrA) <- demand =<< S.uninterruptibleGetSocketName a 128 when (expectedSzA > 128) (fail "testSocketsF: bad socket address size for socket A") portA <- case S.decodeSocketAddressInternet expectedSockAddrA of Nothing -> fail "testSocketsF: not a sockaddr_in" Just (S.SocketAddressInternet {S.port}) -> pure port- b <- demand =<< S.uninterruptibleSocket S.internet S.datagram S.defaultProtocol+ b <- demand =<< S.uninterruptibleSocket S.Internet S.datagram S.defaultProtocol demand =<< S.uninterruptibleBind b (S.encodeSocketAddressInternet (S.SocketAddressInternet {S.port = 0, S.address = localhost})) threadWaitWrite b bytesSent <- demand =<< S.uninterruptibleSendToByteArray b sample 0 5 mempty (S.encodeSocketAddressInternet (S.SocketAddressInternet {S.port = portA, S.address = localhost}))@@ -145,7 +145,7 @@ testSocketsG :: Assertion testSocketsG = do- (a,b) <- demand =<< S.uninterruptibleSocketPair S.unix S.datagram S.defaultProtocol+ (a,b) <- demand =<< S.uninterruptibleSocketPair S.Unix S.datagram S.defaultProtocol _ <- forkIO $ do bytesSent <- demand =<< S.writeVector b ( E.fromList@@ -159,7 +159,7 @@ testLinuxSocketsA :: Assertion testLinuxSocketsA = do- (a,b) <- demand =<< S.uninterruptibleSocketPair S.unix S.datagram S.defaultProtocol+ (a,b) <- demand =<< S.uninterruptibleSocketPair S.Unix S.datagram S.defaultProtocol threadWaitWrite b bytesSent1 <- demand =<< S.uninterruptibleSendByteArray b sample 0 5 mempty threadWaitWrite b@@ -172,7 +172,7 @@ testLinuxSocketsB :: Assertion testLinuxSocketsB = do- a <- demand =<< S.uninterruptibleSocket S.internet S.datagram S.defaultProtocol+ a <- demand =<< S.uninterruptibleSocket S.Internet S.datagram S.defaultProtocol demand =<< S.uninterruptibleBind a (S.encodeSocketAddressInternet (S.SocketAddressInternet {S.port = 0, S.address = localhost})) (expectedSzA,expectedSockAddrA) <- demand =<< S.uninterruptibleGetSocketName a 128@@ -181,7 +181,7 @@ portA <- case S.decodeSocketAddressInternet expectedSockAddrA of Nothing -> fail "testLinixSocketsB: not a sockaddr_in" Just (S.SocketAddressInternet {S.port}) -> pure port- b <- demand =<< S.uninterruptibleSocket S.internet S.datagram S.defaultProtocol+ b <- demand =<< S.uninterruptibleSocket S.Internet S.datagram S.defaultProtocol demand =<< S.uninterruptibleBind b (S.encodeSocketAddressInternet $ S.SocketAddressInternet { S.port = 0@@ -208,7 +208,7 @@ testLinuxSocketsC :: Assertion testLinuxSocketsC = do- a <- demand =<< S.uninterruptibleSocket S.internet S.datagram S.defaultProtocol+ a <- demand =<< S.uninterruptibleSocket S.Internet S.datagram S.defaultProtocol demand =<< S.uninterruptibleBind a (S.encodeSocketAddressInternet (S.SocketAddressInternet {S.port = 0, S.address = localhost})) (expectedSzA,expectedSockAddrA) <- demand =<< S.uninterruptibleGetSocketName a 128@@ -217,7 +217,7 @@ portA <- case S.decodeSocketAddressInternet expectedSockAddrA of Nothing -> fail "testLinuxSocketsC: not a sockaddr_in" Just (S.SocketAddressInternet {S.port}) -> pure port- b <- demand =<< S.uninterruptibleSocket S.internet S.datagram S.defaultProtocol+ b <- demand =<< S.uninterruptibleSocket S.Internet S.datagram S.defaultProtocol demand =<< S.uninterruptibleBind b (S.encodeSocketAddressInternet $ S.SocketAddressInternet { S.port = 0@@ -262,7 +262,7 @@ -- that has happened. testLinuxEpollA :: Assertion testLinuxEpollA = do- (a,b) <- demand =<< S.uninterruptibleSocketPair S.unix S.datagram S.defaultProtocol+ (a,b) <- demand =<< S.uninterruptibleSocketPair S.Unix S.datagram S.defaultProtocol epfd <- demand =<< Epoll.uninterruptibleCreate 1 reg <- PM.newPrimArray 1 PM.writePrimArray reg 0 $ Epoll.Event