diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,12 +7,19 @@ This project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). -## [0.7.1.0] - 2023-??-?? +## 0.7.2.0 -- 2024-02-28 +- Add `socket` as alias for `uninterruptibleSocket`. +- Add `withSocket`. +- Removed `UNLIFTEDARRAYFUNCTIONS` flag and support for GHC < 9.4. + +## 0.7.1.0 -- 2023-10-03 + - Add `uninterruptibleOpenModeUntypedFlags`. - Add `Posix.Struct.AddressInfo.Poke`. +- Add `Posix.File.uninterruptibleReadMutableByteArray`. -## [0.7.0.0] - 2023-08-30 +## 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 @@ -20,35 +27,35 @@ with the `UNLIFTEDARRAYFUNCTIONS` flag to get them back. - Add `uninterruptibleConnectPtr` for better compatibility with `network`. -## [0.6.1.0] - 2023-08-14 +## 0.6.1.0 -- 2023-08-14 - Add `uninterruptibleWriteBytesCompletelyErrno` - Add `writeBytesCompletelyErrno` - Add `uninterruptibleAccept4_` -## [0.6.0.1] - 2023-07-13 +## 0.6.0.1 -- 2023-07-13 - Fix mistake in header file that caused builds to fail -## [0.6.0.0] - 2023-07-13 +## 0.6.0.0 -- 2023-07-13 - Use Int instead of CInt for all offsets into byte arrays -## [0.5.0.0] - 2023-07-13 +## 0.5.0.0 -- 2023-07-13 - Move Linux.Systemd to systemd-api library to make docs build on hackage. -## [0.4.0.1] - 2023-06-27 +## 0.4.0.1 -- 2023-06-27 - Build with GHC 9.4 -## [0.4.0.0] - 2022-12-08 +## 0.4.0.0 -- 2022-12-08 - Add `writeMutableByteArray` - In the 0.3.5.0 release, the major version was supposed to be bumped. This is being done now instead. -## [0.3.5.0] - 2021-07-02 +## 0.3.5.0 -- 2021-07-02 - Breaking: Start using pattern synonyms for macros. - Add dedicated modules for peeking at structures. @@ -57,26 +64,26 @@ - Add `uninterruptibleSetSocketOption`. - Add socket options `SO_BINDTODEVICE` and `SO_REUSEADDR`. -## [0.3.4.0] - 2020-03-09 +## 0.3.4.0 -- 2020-03-09 - Add `Posix.File` - Add lower bound for `hsc2hs` build tool -## [0.3.3.0] - 2019-12-18 +## 0.3.3.0 -- 2019-12-18 - Support several POSIX message queue functions. - Support Linux systemd functions. -## [0.3.2.0] - 2019-07-21 +## 0.3.2.0 -- 2019-07-21 - Add more functions. -## [0.3.1.0] - YYYY-MM-DD +## 0.3.1.0 -- YYYY-MM-DD - Make the test suite build again. - Add `uninterruptibleSendByteArrays`. -## [0.1.0.0] - 2018-01-02 +## 0.1.0.0 -- 2018-01-02 - Initial release. - Includes a ton of sockets API stuff. - Includes the get working directory function. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/cbits/HaskellPosix.c b/cbits/HaskellPosix.c --- a/cbits/HaskellPosix.c +++ b/cbits/HaskellPosix.c @@ -21,7 +21,7 @@ #define MAX_BYTEARRAYS 64 // Generally, this library tries to avoid wrapping POSIX functions -// in an additional function. However, for some functions whose wrappers +// in an additional function. However, for some functions whose // unsafe FFI wrappers use unpinned ByteArray instead of Addr, the only // way to support providing an offset (without just copying the bytes // into pinned memory) is to use a wrapper. @@ -48,6 +48,9 @@ } ssize_t recv_offset(int socket, char *buffer, HsInt offset, size_t length, int flags) { return recv(socket, (void*)(buffer + offset), length, flags); +} +ssize_t read_offset(int fd, char *buffer, HsInt offset, size_t length) { + return read(fd, (void*)(buffer + offset), length); } ssize_t send_offset(int socket, const char *buffer, HsInt offset, size_t length, int flags) { return send(socket, (const void*)(buffer + offset), length, flags); diff --git a/include/HaskellPosix.h b/include/HaskellPosix.h --- a/include/HaskellPosix.h +++ b/include/HaskellPosix.h @@ -3,6 +3,7 @@ #include #include "Rts.h" +ssize_t read_offset(int socket, char *buffer, HsInt offset, size_t length); ssize_t recv_offset(int socket, char *buffer, HsInt offset, size_t length, int flags); ssize_t send_offset(int socket, const char *buffer, HsInt offset, size_t length, int flags); @@ -19,4 +20,3 @@ int recvmmsg_sockaddr_discard (int sockfd , int *lens , StgArrBytes **bufs // used for output , unsigned int vlen , int flags); - diff --git a/include/custom.h b/include/custom.h --- a/include/custom.h +++ b/include/custom.h @@ -72,4 +72,3 @@ } else { \ hsc_printf ("BAD_BYTEARRAY_ALIGNMENT"); \ } - diff --git a/posix-api.cabal b/posix-api.cabal --- a/posix-api.cabal +++ b/posix-api.cabal @@ -1,7 +1,7 @@ -cabal-version: 2.2 -name: posix-api -version: 0.7.1.0 -synopsis: posix bindings +cabal-version: 3.0 +name: posix-api +version: 0.7.2.0 +synopsis: posix bindings description: This library provides a very thin wrapper around POSIX APIs. It can be compiled on any operating system that implements the standard as specified @@ -10,19 +10,19 @@ differs in several areas: . * `ByteArray` and `Addr` are used pervasively. There is no use of - `String` in this library. + `String` in this library. . * Functions do not throw errors. This library uses `IO (Either Errno a)` - in places where `unix` would use `IO a`. + in places where `unix` would use `IO a`. . * The numeric types from `Foreign.C.Types` and `System.Posix.Types` are - used in the type signatures of functions so that a haskell function's - type signature matches its underlying POSIX equivalent exactly. + used in the type signatures of functions so that a haskell function's + type signature matches its underlying POSIX equivalent exactly. . * Flags are newtypes over `CInt` (or whatever integral type matches the - posix specification) rather than enumerations. The data constructors - are exported, making the types extensible for operating system that - have additional flags. + posix specification) rather than enumerations. The data constructors + are exported, making the types extensible for operating system that + have additional flags. . About a dozen other packages offers wrappers for some subset of the POSIX specification are strewn across hackage. They include `regex-posix`, @@ -32,58 +32,62 @@ this package from some or all of these others: . * Scope. Although this library does not include all APIs specified by - POSIX, it welcomes as many of them as anyone is willing to implement. + POSIX, it welcomes as many of them as anyone is willing to implement. . * Monomorphization. Effectful functions in this library return their - results in `IO` rather than using a type that involves `MonadIO` - or `MonadBaseControl`. + results in `IO` rather than using a type that involves `MonadIO` + or `MonadBaseControl`. . * Typeclass avoidance. This library does not introduce new typeclasses. - Overloading is eschewed in favor of providing multiple functions - with distinct names. + Overloading is eschewed in favor of providing multiple functions + with distinct names. . * Minimality. Functions wrapping the POSIX APIs do little more than - wrap the underlying functions. The major deviation here is that, - when applicable, the wrappers allocate buffers are the underlying - functions fill. This eschews C's characteristic buffer-passing - in favor of the Haskell convention of allocating internally and returning. - A more minor deviation is that for safe FFI calls, this library - will perform additional work to ensure that only pinned byte arrays are - handed over. + wrap the underlying functions. The major deviation here is that, + when applicable, the wrappers allocate buffers are the underlying + functions fill. This eschews C's characteristic buffer-passing + in favor of the Haskell convention of allocating internally and returning. + A more minor deviation is that for safe FFI calls, this library + will perform additional work to ensure that only pinned byte arrays are + handed over. . Unlike `network`, this sockets API in this library does not integrate sockets with GHC's event manager. This is geared toward an audience that understands how to use `threadWaitRead` and `threadWaitWrite` with unsafe FFI calls to avoid blocking the runtime. -homepage: https://github.com/andrewthad/posix-api -license: BSD-3-Clause -license-file: LICENSE -author: Andrew Martin -maintainer: andrew.thaddeus@gmail.com -copyright: 2018 Andrew Martin -category: System -build-type: Simple + +homepage: https://github.com/byteverse/posix-api +bug-reports: https://github.com/byteverse/posix-api/issues +license: BSD-3-Clause +license-file: LICENSE +author: Andrew Martin +maintainer: amartin@layer3com.com +copyright: 2018 Andrew Martin +category: System +build-type: Simple extra-source-files: - README.md - CHANGELOG.md cbits/HaskellPosix.c - include/HaskellPosix.h include/custom.h + include/HaskellPosix.h +extra-doc-files: + CHANGELOG.md + README.md + +tested-with: GHC ==9.4.8 || ==9.6.3 || ==9.8.1 + flag assertions - manual: True - description: Extra run-time invariant checking - default: False + manual: True + 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 +common build-settings + default-language: Haskell2010 + ghc-options: -Wall -Wunused-packages library + import: build-settings exposed-modules: Foreign.C.String.Managed Linux.Epoll @@ -95,11 +99,13 @@ Posix.Poll Posix.Select Posix.Socket - Posix.Types - Posix.Struct.SocketAddressInternet.Peek Posix.Struct.AddressInfo.Peek Posix.Struct.AddressInfo.Poke + Posix.Struct.SocketAddressInternet.Peek + Posix.Types + other-modules: + Assertion Linux.Epoll.Types Linux.MessageQueue.Types Linux.Socket.Types @@ -108,43 +114,48 @@ Posix.Poll.Types Posix.Socket.Platform Posix.Socket.Types - Assertion + build-depends: - , 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 - , 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 + , base >=4.16.3 && <5 + , byte-order >=0.1.2 && <0.2 + , byteslice >=0.2.10 && <0.3 + , primitive >=0.9 && <0.10 + , primitive-addr >=0.1 && <0.2 + , primitive-offset >=0.2 && <0.3 + , run-st >=0.1.1 && <0.2 + , text-short >=0.1.5 + + hs-source-dirs: src + if flag(assertions) hs-source-dirs: src-assertions + else hs-source-dirs: src-noassertions + if os(linux) hs-source-dirs: src-linux - default-language: Haskell2010 - ghc-options: -Wall -O2 - c-sources: cbits/HaskellPosix.c - include-dirs: include - includes: HaskellPosix.h - build-tool-depends: hsc2hs:hsc2hs >= 0.68.5 + ghc-options: -O2 + c-sources: cbits/HaskellPosix.c + include-dirs: include + includes: HaskellPosix.h + build-tool-depends: hsc2hs:hsc2hs >=0.68.5 + test-suite test - type: exitcode-stdio-1.0 + import: build-settings + type: exitcode-stdio-1.0 hs-source-dirs: test - main-is: Main.hs + main-is: Main.hs build-depends: , base , posix-api + , primitive >=0.7 , tasty , tasty-hunit - , primitive >= 0.7 - , primitive-unlifted - ghc-options: -Wall -O2 -threaded - default-language: Haskell2010 + ghc-options: -threaded + +source-repository head + type: git + location: git://github.com/byteverse/posix-api.git diff --git a/src-assertions/Assertion.hs b/src-assertions/Assertion.hs --- a/src-assertions/Assertion.hs +++ b/src-assertions/Assertion.hs @@ -1,5 +1,4 @@ -{-# language MagicHash #-} -{-# language UnboxedTuples #-} +{-# LANGUAGE MagicHash #-} module Assertion ( assertByteArrayPinned @@ -7,30 +6,22 @@ , assertMutablePrimArrayPinned ) where -import GHC.Exts (isTrue#) - import qualified Data.Primitive as PM -import qualified GHC.Exts as Exts assertMutablePrimArrayPinned :: PM.MutablePrimArray s a -> PM.MutablePrimArray s a -assertMutablePrimArrayPinned x = if isMutablePrimArrayPinned x - then x - else error "assertMutablePrimArrayPinned" - -assertMutableByteArrayPinned :: PM.MutablePrimArray s a -> PM.MutablePrimArray s a -assertMutableByteArrayPinned x = if isMutableByteArrayPinned x - then x - else error "assertMutableByteArrayPinned" - -isMutablePrimArrayPinned :: PM.MutablePrimArray s a -> Bool -{-# inline isMutablePrimArrayPinned #-} -isMutablePrimArrayPinned (PM.MutablePrimArray marr#) = isTrue# (Exts.isMutableByteArrayPinned# marr#) +assertMutablePrimArrayPinned x = + if PM.isMutablePrimArrayPinned x + then x + else error "assertMutablePrimArrayPinned" -isMutableByteArrayPinned :: PM.MutableByteArray s -> Bool -{-# inline isMutableByteArrayPinned #-} -isMutableByteArrayPinned (PM.MutableByteArray marr#) = isTrue# (Exts.isMutableByteArrayPinned# marr#) +assertMutableByteArrayPinned :: PM.MutableByteArray s -> PM.MutableByteArray s +assertMutableByteArrayPinned x = + if PM.isMutableByteArrayPinned x + then x + else error "assertMutableByteArrayPinned" assertByteArrayPinned :: PM.ByteArray -> PM.ByteArray -assertByteArrayPinned x = if PM.isByteArrayPinned x - then x - else error "assertByteArrayPinned" +assertByteArrayPinned x = + if PM.isByteArrayPinned x + then x + else error "assertByteArrayPinned" diff --git a/src-linux/Posix/Socket/Platform.hsc b/src-linux/Posix/Socket/Platform.hsc --- a/src-linux/Posix/Socket/Platform.hsc +++ b/src-linux/Posix/Socket/Platform.hsc @@ -40,7 +40,7 @@ import qualified Data.Primitive.Addr as PMA import qualified Foreign.Storable as FS --- | The size of a serialized internet socket address. +-- | The size of a serialized internet socket address. sizeofSocketAddressInternet :: CInt sizeofSocketAddressInternet = #{size struct sockaddr_in} @@ -115,7 +115,7 @@ -- error code. encodeSocketAddressUnix :: SocketAddressUnix -> SocketAddress encodeSocketAddressUnix (SocketAddressUnix !name) = - SocketAddress $ runByteArrayST $ unboxByteArrayST $ do + SocketAddress $ runByteArrayST $ unboxByteArrayST $ do -- On linux, sun_path always has exactly 108 bytes. It is a null-terminated -- string, so we initialize the byte array to zeroes to ensure this -- happens. @@ -142,4 +142,3 @@ -- data constructor allocation. runByteArrayST :: (State## RealWorld -> (## State## RealWorld, ByteArray## ##)) -> ByteArray runByteArrayST st_rep = case runRW## st_rep of (## _, a ##) -> ByteArray a - diff --git a/src/Foreign/C/String/Managed.hs b/src/Foreign/C/String/Managed.hs --- a/src/Foreign/C/String/Managed.hs +++ b/src/Foreign/C/String/Managed.hs @@ -1,14 +1,14 @@ -{-# language BangPatterns #-} -{-# language DerivingStrategies #-} -{-# language GeneralizedNewtypeDeriving #-} -{-# language MagicHash #-} -{-# language MultiWayIf #-} -{-# language TypeApplications #-} -{-# language ScopedTypeVariables #-} -{-# language UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnboxedTuples #-} module Foreign.C.String.Managed - ( ManagedCString(..) + ( ManagedCString (..) , terminated , terminatedU , unterminated @@ -23,25 +23,24 @@ import Control.Monad.ST (ST) import Control.Monad.ST.Run (runByteArrayST) -import Data.Bytes.Types (Bytes(Bytes)) +import Data.Bytes.Types (Bytes (Bytes)) import Data.Char (ord) -import Data.Primitive (ByteArray(..),MutableByteArray) +import Data.Primitive (ByteArray (..), MutableByteArray) import Data.Text.Short (ShortText) import Data.Word (Word8) import Foreign.C.String (CString) import Foreign.Ptr (castPtr) -import GHC.Exts (Int(I#),Char(C#),ByteArray#,chr#,touch#) -import GHC.IO (IO(IO)) +import GHC.Exts (ByteArray#, Char (C#), Int (I#), chr#, touch#) +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. newtype ManagedCString = ManagedCString ByteArray - deriving newtype Eq + deriving newtype (Eq) instance Semigroup ManagedCString where ManagedCString a <> ManagedCString b = ManagedCString $ runByteArrayST $ do @@ -62,14 +61,18 @@ fromString = fromLatinString instance Show ManagedCString where - showsPrec _ (ManagedCString arr) s0 = PM.foldrByteArray - ( \(w :: Word8) s -> - if | w == 0 -> s - | w < 32 -> '?' : s - | w > 126 -> '?' : s - | otherwise -> case fromIntegral @Word8 @Int w of - I# i -> C# (chr# i) : s - ) s0 arr + showsPrec _ (ManagedCString arr) s0 = + PM.foldrByteArray + ( \(w :: Word8) s -> + if + | w == 0 -> s + | w < 32 -> '?' : s + | w > 126 -> '?' : s + | otherwise -> case fromIntegral @Word8 @Int w of + I# i -> C# (chr# i) : s + ) + s0 + arr terminatedU :: ManagedCString -> ByteArray terminatedU (ManagedCString x) = x @@ -100,13 +103,14 @@ PM.unsafeFreezeByteArray dst pin :: ManagedCString -> ManagedCString -pin (ManagedCString x) = if PM.isByteArrayPinned x - then ManagedCString x - else ManagedCString $ runByteArrayST $ do - let len = PM.sizeofByteArray x - dst <- PM.newPinnedByteArray len - PM.copyByteArray dst 0 x 0 len - PM.unsafeFreezeByteArray dst +pin (ManagedCString x) = + if PM.isByteArrayPinned x + then ManagedCString x + else ManagedCString $ runByteArrayST $ do + let len = PM.sizeofByteArray x + dst <- PM.newPinnedByteArray len + PM.copyByteArray dst 0 x 0 len + PM.unsafeFreezeByteArray dst touch :: ManagedCString -> IO () touch (ManagedCString (ByteArray x)) = touchByteArray# x @@ -114,32 +118,35 @@ touchByteArray# :: ByteArray# -> IO () touchByteArray# x = IO $ \s -> case touch# x s of s' -> (# s', () #) --- | Convert a 'String' consisting of only characters representable --- by ISO-8859-1. These are encoded with ISO-8859-1. Any character --- with a codepoint above @U+00FF@ is replaced by an unspecified byte. +{- | Convert a 'String' consisting of only characters representable +by ISO-8859-1. These are encoded with ISO-8859-1. Any character +with a codepoint above @U+00FF@ is replaced by an unspecified byte. +-} fromLatinString :: String -> ManagedCString -{-# noinline fromLatinString #-} +{-# NOINLINE fromLatinString #-} fromLatinString str = ManagedCString $ runByteArrayST $ do let lenPred0 = 63 dst0 <- PM.newByteArray (lenPred0 + 1) go str dst0 0 lenPred0 - where + where go :: forall s. String -> MutableByteArray s -> Int -> Int -> ST s ByteArray go [] !dst !ix !_ = do PM.writeByteArray dst ix (0 :: Word8) PM.resizeMutableByteArray dst (ix + 1) >>= PM.unsafeFreezeByteArray - go (c:cs) !dst !ix !lenPred = if ix < lenPred - then do - PM.writeByteArray dst ix (fromIntegral @Int @Word8 (ord c)) - go cs dst (ix + 1) lenPred - else do - let nextLenPred = lenPred * 2 - dst' <- PM.newByteArray (nextLenPred + 1) - PM.copyMutableByteArray dst' 0 dst 0 ix - PM.writeByteArray dst' ix (fromIntegral @Int @Word8 (ord c)) - go cs dst' (ix + 1) nextLenPred + go (c : cs) !dst !ix !lenPred = + if ix < lenPred + then do + PM.writeByteArray dst ix (fromIntegral @Int @Word8 (ord c)) + go cs dst (ix + 1) lenPred + else do + let nextLenPred = lenPred * 2 + dst' <- PM.newByteArray (nextLenPred + 1) + PM.copyMutableByteArray dst' 0 dst 0 ix + PM.writeByteArray dst' ix (fromIntegral @Int @Word8 (ord c)) + go cs dst' (ix + 1) nextLenPred --- | Get a pointer to the payload of the managed C string. The behavior is --- undefined if the argument is not pinned. +{- | Get a pointer to the payload of the managed C string. The behavior is +undefined if the argument is not pinned. +-} contents :: ManagedCString -> CString contents (ManagedCString x) = castPtr (PM.byteArrayContents x) diff --git a/src/Linux/Epoll.hs b/src/Linux/Epoll.hs --- a/src/Linux/Epoll.hs +++ b/src/Linux/Epoll.hs @@ -1,30 +1,34 @@ -{-# language BangPatterns #-} -{-# language DataKinds #-} -{-# language GADTSyntax #-} -{-# language KindSignatures #-} -{-# language MagicHash #-} -{-# language UnliftedFFITypes #-} -{-# language NamedFieldPuns #-} -{-# language UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTSyntax #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} module Linux.Epoll ( -- * Functions + -- ** Create uninterruptibleCreate , uninterruptibleCreate1 + -- ** Wait , waitMutablePrimArray , uninterruptibleWaitMutablePrimArray + -- ** Control , uninterruptibleControlMutablePrimArray + -- * Types - , EpollFlags(..) - , ControlOperation(..) - , Events(..) - , Event(..) - , Exchange(..) + , EpollFlags (..) + , ControlOperation (..) + , Events (..) + , Event (..) + , Exchange (..) + -- * Classes , PrimEpollData + -- * Constants , T.closeOnExec , T.add @@ -37,9 +41,11 @@ , T.readHangup , T.error , T.edgeTriggered + -- * Events Combinators , T.containsAnyEvents , T.containsAllEvents + -- * Marshalling , T.sizeofEvent , T.peekEventEvents @@ -48,21 +54,17 @@ , T.peekEventDataU32 , T.peekEventDataU64 , T.pokeEventDataU64 - -- , T.readEventDataU64 - -- , T.writeEventDataU64 - -- , T.writeEventEvents ) where import Prelude hiding (error) import Assertion (assertMutablePrimArrayPinned) -import Data.Primitive (MutablePrimArray(..)) -import Foreign.C.Error (Errno,getErrno) -import Foreign.C.Types (CInt(..)) -import GHC.Exts (RealWorld,MutableByteArray#) -import Linux.Epoll.Types (EpollFlags(..),ControlOperation(..),Events(..),Exchange(..)) -import Linux.Epoll.Types (Event(..),PrimEpollData(..)) -import System.Posix.Types (Fd(..)) +import Data.Primitive (MutablePrimArray (..)) +import Foreign.C.Error (Errno, getErrno) +import Foreign.C.Types (CInt (..)) +import GHC.Exts (MutableByteArray#, RealWorld) +import Linux.Epoll.Types (ControlOperation (..), EpollFlags (..), Event (..), Events (..), Exchange (..), PrimEpollData (..)) +import System.Posix.Types (Fd (..)) import qualified Linux.Epoll.Types as T @@ -93,81 +95,99 @@ -- PM.writeByteArray arr (ix * 3 + 2) (word64ToWord32 payload) uninterruptibleCreate :: - CInt -- ^ Size, ignored since Linux 2.6.8 - -> IO (Either Errno Fd) -{-# inline uninterruptibleCreate #-} + -- | Size, ignored since Linux 2.6.8 + CInt -> + IO (Either Errno Fd) +{-# INLINE uninterruptibleCreate #-} uninterruptibleCreate !sz = c_epoll_create sz >>= errorsFromFd uninterruptibleCreate1 :: - EpollFlags -- ^ Flags - -> IO (Either Errno Fd) -{-# inline uninterruptibleCreate1 #-} + -- | Flags + EpollFlags -> + IO (Either Errno Fd) +{-# INLINE uninterruptibleCreate1 #-} uninterruptibleCreate1 !flags = c_epoll_create1 flags >>= errorsFromFd --- | Wait for an I/O event on an epoll file descriptor. The --- --- includes more details. The @timeout@ argument is omitted --- since it is nonsense to choose anything other than 0 when --- using the unsafe FFI. +{- | Wait for an I/O event on an epoll file descriptor. The + + includes more details. The @timeout@ argument is omitted + since it is nonsense to choose anything other than 0 when + using the unsafe FFI. +-} uninterruptibleWaitMutablePrimArray :: - Fd -- ^ EPoll file descriptor - -> MutablePrimArray RealWorld (Event 'Response a) -- ^ Event buffer - -> CInt -- ^ Maximum events - -> IO (Either Errno CInt) -- ^ Number of events received -{-# inline uninterruptibleWaitMutablePrimArray #-} + -- | EPoll file descriptor + Fd -> + -- | Event buffer + MutablePrimArray RealWorld (Event 'Response a) -> + -- | Maximum events + CInt -> + -- | Number of events received + IO (Either Errno CInt) +{-# INLINE uninterruptibleWaitMutablePrimArray #-} uninterruptibleWaitMutablePrimArray !epfd (MutablePrimArray evs) !maxEvents = c_epoll_wait_unsafe epfd evs maxEvents 0 >>= errorsFromInt --- | Wait for an I/O event on an epoll file descriptor. The --- --- includes more details. The event buffer must be a pinned --- byte array. +{- | Wait for an I/O event on an epoll file descriptor. The + + includes more details. The event buffer must be a pinned + byte array. +-} waitMutablePrimArray :: - Fd -- ^ EPoll file descriptor - -> MutablePrimArray RealWorld (Event 'Response a) -- ^ Event buffer, must be pinned - -> CInt -- ^ Maximum events - -> CInt -- ^ Timeout in milliseconds, use @-1@ to block forever. - -> IO (Either Errno CInt) -- ^ Number of events received -{-# inline waitMutablePrimArray #-} + -- | EPoll file descriptor + Fd -> + -- | Event buffer, must be pinned + MutablePrimArray RealWorld (Event 'Response a) -> + -- | Maximum events + CInt -> + -- | Timeout in milliseconds, use @-1@ to block forever. + CInt -> + -- | Number of events received + IO (Either Errno CInt) +{-# INLINE waitMutablePrimArray #-} waitMutablePrimArray !epfd !evs !maxEvents !timeout = let !(MutablePrimArray evs#) = assertMutablePrimArrayPinned evs in c_epoll_wait_safe epfd evs# maxEvents timeout >>= errorsFromInt --- | Add, modify, or remove entries in the interest list of the --- epoll instance referred to by the file descriptor @epfd@. --- --- includes more details. +{- | Add, modify, or remove entries in the interest list of the + epoll instance referred to by the file descriptor @epfd@. + + includes more details. +-} uninterruptibleControlMutablePrimArray :: - Fd -- ^ EPoll file descriptor (@epfd@) - -> ControlOperation - -- ^ Operation: @EPOLL_CTL_ADD@, @EPOLL_CTL_MOD@, or @EPOLL_CTL_DEL@ - -> Fd -- ^ File descriptor whose registration will be affected - -> MutablePrimArray RealWorld (Event 'Request a) - -- ^ A single event. This is read from, not written to. - -> IO (Either Errno ()) -{-# inline uninterruptibleControlMutablePrimArray #-} + -- | EPoll file descriptor (@epfd@) + Fd -> + -- | Operation: @EPOLL_CTL_ADD@, @EPOLL_CTL_MOD@, or @EPOLL_CTL_DEL@ + ControlOperation -> + -- | File descriptor whose registration will be affected + Fd -> + -- | A single event. This is read from, not written to. + MutablePrimArray RealWorld (Event 'Request a) -> + IO (Either Errno ()) +{-# INLINE uninterruptibleControlMutablePrimArray #-} uninterruptibleControlMutablePrimArray !epfd !op !fd (MutablePrimArray ev) = c_epoll_ctl_unsafe epfd op fd ev >>= errorsFromInt_ errorsFromFd :: Fd -> IO (Either Errno Fd) -{-# inline errorsFromFd #-} -errorsFromFd r = if r > (-1) - then pure (Right r) - else fmap Left getErrno +{-# INLINE errorsFromFd #-} +errorsFromFd r = + if r > (-1) + then pure (Right r) + else fmap Left getErrno errorsFromInt :: CInt -> IO (Either Errno CInt) -{-# inline errorsFromInt #-} -errorsFromInt r = if r > (-1) - then pure (Right r) - else fmap Left getErrno +{-# INLINE errorsFromInt #-} +errorsFromInt r = + if r > (-1) + then pure (Right r) + else fmap Left getErrno -- Sometimes, functions that return an int use zero to indicate -- success and negative one to indicate failure without including -- additional information in the value. errorsFromInt_ :: CInt -> IO (Either Errno ()) -{-# inline errorsFromInt_ #-} -errorsFromInt_ r = if r == 0 - then pure (Right ()) - else fmap Left getErrno - +{-# INLINE errorsFromInt_ #-} +errorsFromInt_ r = + if r == 0 + then pure (Right ()) + else fmap Left getErrno diff --git a/src/Linux/Epoll/Types.hsc b/src/Linux/Epoll/Types.hsc --- a/src/Linux/Epoll/Types.hsc +++ b/src/Linux/Epoll/Types.hsc @@ -11,7 +11,7 @@ {-# language PolyKinds #-} {-# language ScopedTypeVariables #-} {-# language TypeApplications #-} -{-# language TypeInType #-} +{-# language DataKinds #-} {-# language UnboxedTuples #-} -- This is needed because hsc2hs does not currently handle ticked @@ -334,30 +334,3 @@ unI :: Int -> Int## unI (I## i) = i - --- -- | Read @data.u64@ from @struct epoll_event@. --- readEventDataU64 :: --- MutableByteArray RealWorld --- -> Int -- ^ Index. Elements are @struct epoll_event@. --- -> IO Word64 --- readEventDataU64 !arr !ix = do --- -- On 64-bit platforms, Linux bitpacks this structure, causing the --- -- data (a 64-bit word) to be misaligned. Consequently, we must --- -- hardcode the assumed offsets to perform only aligned accesses. --- -- The behavior is deterministic across platforms of different --- -- endianness only if the only use of this function is paired with --- -- writeEventDataU64. --- (a :: Word32) <- PM.readByteArray arr (ix * 3 + 1) --- (b :: Word32) <- PM.readByteArray arr (ix * 3 + 2) --- pure (unsafeShiftL (word32ToWord64 a) 32 .|. word32ToWord64 b) --- --- -- | Write @data.u64@ from @struct epoll_event@. --- writeEventDataU64 :: --- MutableByteArray RealWorld --- -> Int -- ^ Index. Element are @struct epoll_event@. --- -> Word64 -- ^ Data --- -> IO () --- writeEventDataU64 !arr !ix !payload = do --- -- See the comments on readEventDataU64 --- PM.writeByteArray arr (ix * 3 + 1) (word64ToWord32 (unsafeShiftR payload 32)) --- PM.writeByteArray arr (ix * 3 + 2) (word64ToWord32 payload) diff --git a/src/Linux/Socket.hs b/src/Linux/Socket.hs --- a/src/Linux/Socket.hs +++ b/src/Linux/Socket.hs @@ -1,40 +1,40 @@ -{-# language BangPatterns #-} -{-# language CPP #-} -{-# language DataKinds #-} -{-# language MagicHash #-} -{-# language ScopedTypeVariables #-} -{-# language UnboxedTuples #-} -{-# language UnliftedFFITypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnliftedFFITypes #-} module Linux.Socket ( -- * Functions uninterruptibleAccept4 , uninterruptibleAccept4_ -#if defined(UNLIFTEDARRAYFUNCTIONS) - , uninterruptibleReceiveMultipleMessageA - , uninterruptibleReceiveMultipleMessageB - , uninterruptibleReceiveMultipleMessageC - , uninterruptibleReceiveMultipleMessageD -#endif + -- * Types - , SocketFlags(..) + , SocketFlags (..) + -- * Option Names , LST.headerInclude + -- * Message Flags , LST.dontWait , LST.truncate , LST.controlTruncate + -- * Socket Flags , LST.closeOnExec , LST.nonblocking + -- * Twiddle , applySocketFlags + -- * UDP Header , LST.sizeofUdpHeader , LST.pokeUdpHeaderSourcePort , LST.pokeUdpHeaderDestinationPort , LST.pokeUdpHeaderLength , LST.pokeUdpHeaderChecksum + -- * IPv4 Header , LST.sizeofIpHeader , LST.pokeIpHeaderVersionIhl @@ -51,333 +51,74 @@ import Prelude hiding (truncate) -import Control.Monad (when) 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.Primitive (MutableByteArray (..)) import Data.Void (Void) -import Data.Word (Word8) -import Foreign.C.Error (Errno,getErrno) -import Foreign.C.Types (CInt(..),CSize(..),CUInt(..)) +import Foreign.C.Error (Errno, getErrno) +import Foreign.C.Types (CInt (..)) import Foreign.Ptr (nullPtr) -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 GHC.Exts (Int (I#), MutableByteArray#, Ptr (..), RealWorld, shrinkMutableByteArray#) +import Linux.Socket.Types (SocketFlags (..)) +import Posix.Socket (SocketAddress (..), Type (..)) +import System.Posix.Types (Fd (..)) 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 -foreign import ccall unsafe "sys/socket.h recvmmsg" - c_unsafe_addr_recvmmsg :: Fd - -> Addr# -- This addr is an array of msghdr - -> CUInt -- Length of msghdr array - -> MessageFlags 'Receive - -> Addr# -- Timeout - -> IO CSsize - foreign import ccall unsafe "sys/socket.h accept4" - c_unsafe_accept4 :: Fd - -> MutableByteArray# RealWorld -- SocketAddress - -> MutableByteArray# RealWorld -- Ptr CInt - -> SocketFlags - -> IO Fd + c_unsafe_accept4 :: + Fd -> + MutableByteArray# RealWorld -> -- SocketAddress + MutableByteArray# RealWorld -> -- Ptr CInt + SocketFlags -> + IO Fd -- Variant of c_unsafe_ptr_accept4 that uses Ptr instead of MutableByteArray. -- Currently, we expect that the two pointers are set to NULL. -- This is only used internally. foreign import ccall unsafe "sys/socket.h accept4" c_unsafe_ptr_accept4 :: - Fd - -> Ptr Void -- SocketAddress - -> Ptr Void -- Ptr CInt - -> SocketFlags - -> IO Fd + Fd -> + Ptr Void -> -- SocketAddress + Ptr Void -> -- Ptr CInt + SocketFlags -> + IO Fd -#if defined(UNLIFTEDARRAYFUNCTIONS) -foreign import ccall unsafe "HaskellPosix.h recvmmsg_sockaddr_in" - c_unsafe_recvmmsg_sockaddr_in :: - Fd - -> MutableByteArray# RealWorld -- lengths - -> MutableByteArray# RealWorld -- sockaddrs - -> MutableArray# RealWorld (MutableByteArray# RealWorld) -- buffers - -> CUInt -- Length of msghdr array - -> MessageFlags 'Receive - -> IO CInt +{- | Linux extends the @type@ argument of + to allow + setting two socket flags on socket creation: @SOCK_CLOEXEC@ and + @SOCK_NONBLOCK@. It is advisable to set @SOCK_CLOEXEC@ on when + opening a socket on linux. For example, we may open a TCP Internet + socket with: -foreign import ccall unsafe "HaskellPosix.h recvmmsg_sockaddr_discard" - c_unsafe_recvmmsg_sockaddr_discard :: - Fd - -> MutableByteArray# RealWorld -- lengths - -> MutableArray# RealWorld (MutableByteArray# RealWorld) -- buffers - -> CUInt -- Length of msghdr array - -> MessageFlags 'Receive - -> IO CInt -#endif + > uninterruptibleSocket internet (applySocketFlags closeOnExec stream) defaultProtocol --- | Linux extends the @type@ argument of --- to allow --- setting two socket flags on socket creation: @SOCK_CLOEXEC@ and --- @SOCK_NONBLOCK@. It is advisable to set @SOCK_CLOEXEC@ on when --- opening a socket on linux. For example, we may open a TCP Internet --- socket with: --- --- > uninterruptibleSocket internet (applySocketFlags closeOnExec stream) defaultProtocol --- --- To additionally open the socket in nonblocking mode --- (e.g. with @SOCK_NONBLOCK@): --- --- > uninterruptibleSocket internet (applySocketFlags (closeOnExec <> nonblocking) stream) defaultProtocol --- + To additionally open the socket in nonblocking mode + (e.g. with @SOCK_NONBLOCK@): + + > uninterruptibleSocket internet (applySocketFlags (closeOnExec <> nonblocking) stream) defaultProtocol +-} 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 --- datagram is never split across noncontiguous memory. It supplies --- @NULL@ for the timeout argument. All of the messages must have the --- same maximum size. All resulting byte arrays have been explicitly --- pinned. In addition to bytearrays corresponding to each datagram, --- this also provides the maximum @msg_len@ that @recvmmsg@ wrote --- back out. This is provided so that users of @MSG_TRUNC@ can detect --- when bytes were dropped from the end of a message (although it does --- let the user figure out which message had bytes dropped). -uninterruptibleReceiveMultipleMessageA :: - Fd -- ^ Socket - -> CSize -- ^ Maximum bytes per message - -> CUInt -- ^ Maximum number of messages - -> MessageFlags 'Receive -- ^ Flags - -> IO (Either Errno (CUInt,UnliftedArray ByteArray)) -uninterruptibleReceiveMultipleMessageA !s !msgSize !msgCount !flags = do - 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) - let iovecsAddr = ptrToAddr (PM.mutableByteArrayContents iovecsBuf) - initializeMultipleMessageHeadersWithoutSockAddr bufs iovecsAddr mmsghdrsAddr msgSize msgCount - r <- c_unsafe_addr_recvmmsg s mmsghdrsAddr# msgCount flags nullAddr# - if r > (-1) - then do - (_,maxMsgSz,frozenBufs) <- shrinkAndFreezeMessages msgSize 0 (cssizeToInt r) bufs mmsghdrsAddr - touchMutableUnliftedArray bufs - touchMutableByteArray iovecsBuf - touchMutableByteArray mmsghdrsBuf - pure (Right (maxMsgSz,frozenBufs)) - else do - touchMutableUnliftedArray bufs - touchMutableByteArray iovecsBuf - touchMutableByteArray mmsghdrsBuf - fmap Left getErrno - --- | Receive multiple messages. This is similar to --- @uninterruptibleReceiveMultipleMessageA@. However, it also --- provides the @sockaddr@s of the remote endpoints. These are --- written in contiguous memory to a bytearray of length --- @max_num_msgs * expected_sockaddr_sz@. The @sockaddr@s must --- all be expected to be of the same length. This function --- provides a @sockaddr@ size check that is non-zero when any --- @sockaddr@ had a length other than the expected length. --- This can be used to detect if the @sockaddr@ array has one or --- more corrupt @sockaddr@s in it. All byte arrays returned by --- this function are pinned. --- --- The values in the returned tuple are: --- --- * Error-checking number for @sockaddr@ size. Non-zero indicates --- that at least one @sockaddr@ required a number of bytes other --- than the expected number. --- * Pinned bytearray with all of the @sockaddr@s in it as a --- array of structures. --- * The size of the largest message received. If @MSG_TRUNC@ is used --- this lets the caller know if one or more messages were truncated. --- * The message data of each message. --- --- The @sockaddr@s bytearray and the unlifted array of messages are --- guaranteed to have the same number of elements. -uninterruptibleReceiveMultipleMessageB :: - Fd -- ^ Socket - -> CInt -- ^ Expected @sockaddr@ size - -> CSize -- ^ Maximum bytes per message - -> CUInt -- ^ Maximum number of messages - -> MessageFlags 'Receive -- ^ Flags - -> IO (Either Errno (CInt,ByteArray,CUInt,UnliftedArray ByteArray)) -uninterruptibleReceiveMultipleMessageB !s !expSockAddrSize !msgSize !msgCount !flags = do - 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) - -- Linux does not require zeroing out sockaddr_in before using it, - -- so we leave sockaddrsBuf alone after initialization. - let sockaddrsAddr = ptrToAddr (PM.mutableByteArrayContents sockaddrsBuf) - let !mmsghdrsAddr@(Addr mmsghdrsAddr#) = ptrToAddr (PM.mutableByteArrayContents mmsghdrsBuf) - let iovecsAddr = ptrToAddr (PM.mutableByteArrayContents iovecsBuf) - initializeMultipleMessageHeadersWithSockAddr bufs iovecsAddr mmsghdrsAddr sockaddrsAddr expSockAddrSize msgSize msgCount - r <- c_unsafe_addr_recvmmsg s mmsghdrsAddr# msgCount flags nullAddr# - if r > (-1) - then do - (validation,maxMsgSz,frozenBufs) <- shrinkAndFreezeMessages msgSize expSockAddrSize (cssizeToInt r) bufs mmsghdrsAddr - shrinkMutableByteArray sockaddrsBuf (cssizeToInt r * cintToInt expSockAddrSize) - sockaddrs <- PM.unsafeFreezeByteArray sockaddrsBuf - touchMutableByteArray iovecsBuf - touchMutableByteArray mmsghdrsBuf - touchMutableByteArray sockaddrsBuf - pure (Right (validation,sockaddrs,maxMsgSz,frozenBufs)) - else do - touchMutableUnliftedArray bufs - touchMutableByteArray iovecsBuf - touchMutableByteArray mmsghdrsBuf - touchMutableByteArray sockaddrsBuf - fmap Left getErrno - --- | All three buffer arguments need to have the same length (in elements, not bytes). -uninterruptibleReceiveMultipleMessageC :: - Fd -- ^ Socket - -> MutablePrimArray RealWorld CInt -- ^ Buffer for payload lengths - -> MutablePrimArray RealWorld S.SocketAddressInternet -- ^ Buffer for @sockaddr_in@s - -> MutableUnliftedArray RealWorld (MutableByteArray RealWorld) -- ^ Buffers for payloads - -> CUInt -- ^ Maximum number of datagrams to receive, length of buffers - -> MessageFlags 'Receive -- ^ Flags - -> IO (Either Errno CInt) -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). --- This discards the source addresses. -uninterruptibleReceiveMultipleMessageD :: - Fd -- ^ Socket - -> MutablePrimArray RealWorld CInt -- ^ Buffer for payload lengths - -> MutableUnliftedArray RealWorld (MutableByteArray RealWorld) -- ^ Buffers for payloads - -> CUInt -- ^ Maximum number of datagrams to receive, length of buffers - -> MessageFlags 'Receive -- ^ Flags - -> IO (Either Errno CInt) -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 --- be an array of iovec with a single element. -initializeMultipleMessageHeadersWithoutSockAddr :: - MutableUnliftedArray RealWorld (MutableByteArray RealWorld) -- buffers - -> Addr -- array of iovec - -> Addr -- array of message headers - -> CSize -- message size - -> CUInt -- message count - -> IO () -initializeMultipleMessageHeadersWithoutSockAddr bufs iovecsAddr mmsgHdrsAddr msgSize msgCount = - let go !ix !iovecAddr !mmsgHdrAddr = if ix < cuintToInt msgCount - then do - pokeMultipleMessageHeader mmsgHdrAddr nullAddr 0 iovecAddr 1 nullAddr 0 mempty 0 - initializeIOVector bufs iovecAddr msgSize ix - go (ix + 1) (plusAddr iovecAddr (cintToInt S.sizeofIOVector)) (plusAddr mmsgHdrAddr (cintToInt LST.sizeofMultipleMessageHeader)) - else pure () - in go 0 iovecsAddr mmsgHdrsAddr - --- This sets up an array of mmsghdr. Each msghdr has msg_iov set to --- 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) - -> Addr -- array of iovec - -> Addr -- array of message headers - -> Addr -- array of sockaddrs - -> CInt -- expected sockaddr size - -> CSize -- message size - -> CUInt -- message count - -> IO () -initializeMultipleMessageHeadersWithSockAddr bufs iovecsAddr0 mmsgHdrsAddr0 sockaddrsAddr0 sockaddrSize msgSize msgCount = - let go !ix !iovecAddr !mmsgHdrAddr !sockaddrAddr = if ix < cuintToInt msgCount - then do - pokeMultipleMessageHeader mmsgHdrAddr sockaddrAddr sockaddrSize iovecAddr 1 nullAddr 0 mempty 0 - initializeIOVector bufs iovecAddr msgSize ix - go (ix + 1) - (plusAddr iovecAddr (cintToInt S.sizeofIOVector)) - (plusAddr mmsgHdrAddr (cintToInt LST.sizeofMultipleMessageHeader)) - (plusAddr sockaddrAddr (cintToInt sockaddrSize)) - else pure () - in go 0 iovecsAddr0 mmsgHdrsAddr0 sockaddrsAddr0 - -ptrToAddr :: Ptr Word8 -> Addr -ptrToAddr (Ptr x) = Addr x - --- Initialize a single iovec. We write the pinned byte array into --- both the iov_base field and into an unlifted array. -initializeIOVector :: - MutableUnliftedArray RealWorld (MutableByteArray RealWorld) - -> Addr - -> CSize - -> Int - -> IO () -initializeIOVector bufs iovecAddr msgSize ix = do - buf <- PM.newPinnedByteArray (csizeToInt msgSize) - PM.writeUnliftedArray bufs ix buf - S.pokeIOVectorBase iovecAddr (ptrToAddr (PM.mutableByteArrayContents buf)) - S.pokeIOVectorLength iovecAddr msgSize - --- Freeze a slice of the mutable byte arrays inside the unlifted array, --- shrinking the byte arrays before doing so. -shrinkAndFreezeMessages :: - CSize -- Full size of each buffer - -> CInt -- Expected sockaddr size - -> Int -- Actual number of received messages - -> MutableUnliftedArray RealWorld (MutableByteArray RealWorld) - -> Addr -- Array of mmsghdr - -> IO (CInt,CUInt,UnliftedArray ByteArray) -shrinkAndFreezeMessages !bufSize !expSockAddrSize !n !bufs !mmsghdr0 = do - r <- PM.unsafeNewUnliftedArray n - go r 0 0 0 mmsghdr0 - where - go !r !validation !ix !maxMsgSz !mmsghdr = if ix < n - then do - sz <- LST.peekMultipleMessageHeaderLength mmsghdr - sockaddrSz <- LST.peekMultipleMessageHeaderNameLength mmsghdr - buf <- PM.readUnliftedArray bufs ix - when (cuintToInt sz < csizeToInt bufSize) (shrinkMutableByteArray buf (cuintToInt sz)) - PM.writeUnliftedArray r ix =<< PM.unsafeFreezeByteArray buf - go r (validation .|. (sockaddrSz - expSockAddrSize)) (ix + 1) (max maxMsgSz sz) - (plusAddr mmsghdr (cintToInt LST.sizeofMultipleMessageHeader)) - 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 - LST.pokeMultipleMessageHeaderName mmsgHdrAddr a - LST.pokeMultipleMessageHeaderNameLength mmsgHdrAddr b - LST.pokeMultipleMessageHeaderIOVector mmsgHdrAddr c - LST.pokeMultipleMessageHeaderIOVectorLength mmsgHdrAddr d - LST.pokeMultipleMessageHeaderControl mmsgHdrAddr e - LST.pokeMultipleMessageHeaderControlLength mmsgHdrAddr f - LST.pokeMultipleMessageHeaderFlags mmsgHdrAddr g - LST.pokeMultipleMessageHeaderLength mmsgHdrAddr len - shrinkMutableByteArray :: MutableByteArray RealWorld -> Int -> IO () shrinkMutableByteArray (MutableByteArray arr) (I# sz) = PM.primitive_ (shrinkMutableByteArray# arr sz) --- | Variant of 'Posix.Socket.uninterruptibleAccept' that allows setting --- flags on the newly-accepted connection. +{- | Variant of 'Posix.Socket.uninterruptibleAccept' that allows setting + flags on the newly-accepted connection. +-} uninterruptibleAccept4 :: - Fd -- ^ Listening socket - -> CInt -- ^ Maximum socket address size - -> SocketFlags -- ^ Set non-blocking and close-on-exec without extra syscall - -> IO (Either Errno (CInt,SocketAddress,Fd)) -- ^ Peer information and connected socket -{-# inline uninterruptibleAccept4 #-} + -- | Listening socket + Fd -> + -- | Maximum socket address size + CInt -> + -- | Set non-blocking and close-on-exec without extra syscall + SocketFlags -> + -- | Peer information and connected socket + IO (Either Errno (CInt, SocketAddress, Fd)) +{-# INLINE uninterruptibleAccept4 #-} uninterruptibleAccept4 !sock !maxSz !flags = do sockAddrBuf@(MutableByteArray sockAddrBuf#) <- PM.newByteArray (cintToInt maxSz) lenBuf@(MutableByteArray lenBuf#) <- PM.newByteArray (PM.sizeOf (undefined :: CInt)) @@ -390,16 +131,20 @@ then shrinkMutableByteArray sockAddrBuf (cintToInt sz) else pure () sockAddr <- PM.unsafeFreezeByteArray sockAddrBuf - pure (Right (sz,SocketAddress sockAddr,r)) + pure (Right (sz, SocketAddress sockAddr, r)) else fmap Left getErrno --- | Variant of 'uninterruptibleAccept4' that requests that the kernel not --- include the socket address in its reponse. +{- | Variant of 'uninterruptibleAccept4' that requests that the kernel not +include the socket address in its reponse. +-} uninterruptibleAccept4_ :: - Fd -- ^ Listening socket - -> SocketFlags -- ^ Set non-blocking and close-on-exec without extra syscall - -> IO (Either Errno Fd) -- ^ Connected socket -{-# inline uninterruptibleAccept4_ #-} + -- | Listening socket + Fd -> + -- | Set non-blocking and close-on-exec without extra syscall + SocketFlags -> + -- | Connected socket + IO (Either Errno Fd) +{-# INLINE uninterruptibleAccept4_ #-} uninterruptibleAccept4_ !sock !flags = do r <- c_unsafe_ptr_accept4 sock nullPtr nullPtr flags if r > (-1) @@ -408,32 +153,3 @@ cintToInt :: CInt -> Int cintToInt = fromIntegral - -cuintToInt :: CUInt -> Int -cuintToInt = fromIntegral - -csizeToInt :: CSize -> Int -csizeToInt = fromIntegral - -cssizeToInt :: CSsize -> Int -cssizeToInt = fromIntegral - -errorsFromInt :: CInt -> IO (Either Errno CInt) -{-# inline errorsFromInt #-} -errorsFromInt r = if r > (-1) - then pure (Right r) - else fmap Left getErrno - -touchMutableByteArray :: MutableByteArray RealWorld -> IO () -touchMutableByteArray (MutableByteArray x) = touchMutableByteArray# x - -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/Linux/Socket/Types.hsc b/src/Linux/Socket/Types.hsc --- a/src/Linux/Socket/Types.hsc +++ b/src/Linux/Socket/Types.hsc @@ -75,7 +75,7 @@ -- newtype Collection :: Type -> Type where -- Collection :: !(Ptr a) -> Collection a --- +-- -- indexCollection :: Ptr a -- => Collection a -> Int -> IO (Ptr a) -- indexCollection (Collection p) n = advancePtr p n @@ -88,12 +88,12 @@ -- , controlLength :: !CSize -- , flags :: !(MessageFlags Receive) -- } --- +-- -- data IOVector = IOVector -- { base :: !Addr -- , length :: !CSize -- } --- +-- -- data ControlMessageHeader = ControlMessageHeader -- { length :: !CInt -- , level :: !CInt diff --git a/src/Posix/Directory.hs b/src/Posix/Directory.hs --- a/src/Posix/Directory.hs +++ b/src/Posix/Directory.hs @@ -1,18 +1,15 @@ -{-# language BangPatterns #-} -{-# language MagicHash #-} -{-# language LambdaCase #-} -{-# language UnboxedTuples #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} module Posix.Directory ( getCurrentWorkingDirectory ) where import Data.Primitive (ByteArray) -import GHC.Exts (Ptr(..)) +import Foreign.C.Error (Errno, eRANGE, getErrno) +import Foreign.C.Types (CChar, CSize (..)) import Foreign.Ptr (nullPtr) -import Foreign.C.Error (Errno,eRANGE,getErrno) -import Foreign.C.Types (CChar,CSize(..)) -import GHC.IO (IO(..)) +import GHC.Exts (Ptr (..)) import qualified Data.Primitive as PM import qualified Foreign.Storable as FS @@ -20,11 +17,13 @@ foreign import ccall safe "getcwd" c_getcwd :: Ptr CChar -> CSize -> IO (Ptr CChar) --- | Get the current working directory without using the system locale --- to convert it to text. This is implemented with a safe FFI call --- since it may block. +{- | Get the current working directory without using the system locale + to convert it to text. This is implemented with a safe FFI call + since it may block. +-} getCurrentWorkingDirectory :: IO (Either Errno ByteArray) -getCurrentWorkingDirectory = go (4096 - chunkOverhead) where +getCurrentWorkingDirectory = go (4096 - chunkOverhead) + where go !sz = do -- It may be nice to add a variant of getCurrentWorkingDirectory that -- allow the user to supply an initial pinned buffer. I'm not sure @@ -59,10 +58,10 @@ -- There must be a null byte present or bad things will happen. -- This will return a nonnegative number. findNullByte :: Ptr CChar -> IO Int -findNullByte = go 0 where +findNullByte = go 0 + where go :: Int -> Ptr CChar -> IO Int go !ix !ptr = do FS.peekElemOff ptr ix >>= \case 0 -> pure ix _ -> go (ix + 1) ptr - diff --git a/src/Posix/File.hs b/src/Posix/File.hs --- a/src/Posix/File.hs +++ b/src/Posix/File.hs @@ -1,9 +1,8 @@ -{-# language BangPatterns #-} -{-# language BinaryLiterals #-} -{-# language LambdaCase #-} -{-# language MagicHash #-} -{-# language TypeApplications #-} -{-# language UnliftedFFITypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UnliftedFFITypes #-} module Posix.File ( -- * Functions @@ -13,6 +12,7 @@ , uninterruptibleWriteBytes , uninterruptibleWriteBytesCompletely , uninterruptibleWriteBytesCompletelyErrno + , uninterruptibleReadMutableByteArray , writeBytesCompletelyErrno , uninterruptibleOpen , uninterruptibleOpenMode @@ -25,49 +25,53 @@ , uninterruptibleErrorlessClose , uninterruptibleUnlink , uninterruptibleLink + -- * Types - , AccessMode(..) - , CreationFlags(..) - , DescriptorFlags(..) - , StatusFlags(..) + , AccessMode (..) + , CreationFlags (..) + , DescriptorFlags (..) + , StatusFlags (..) + -- * File Descriptor Flags , Types.nonblocking , Types.append , isReadOnly , isWriteOnly , isReadWrite + -- * Open Access Mode , Types.readOnly , Types.writeOnly , Types.readWrite + -- * File Creation Flags , Types.create , Types.truncate , Types.exclusive ) where -import Assertion (assertByteArrayPinned,assertMutableByteArrayPinned) -import Data.Bits ((.&.),(.|.)) -import Data.Primitive (ByteArray(..)) -import Foreign.C.Error (Errno(Errno),getErrno,eOK) -import Foreign.C.String.Managed (ManagedCString(..)) -import Foreign.C.Types (CInt(..),CSize(..)) -import GHC.Exts (ByteArray#,MutableByteArray#,RealWorld) -import Posix.File.Types (CreationFlags(..),AccessMode(..),StatusFlags(..)) -import Posix.File.Types (DescriptorFlags(..)) -import System.Posix.Types (Fd(..),CSsize(..),CMode(..)) -import Data.Bytes.Types (Bytes(Bytes)) -import Data.Primitive (MutableByteArray(MutableByteArray)) +import Assertion (assertByteArrayPinned, assertMutableByteArrayPinned) +import Data.Bits ((.&.), (.|.)) +import Data.Bytes.Types (Bytes (Bytes)) +import Data.Primitive (ByteArray (..), MutableByteArray (MutableByteArray)) +import Foreign.C.Error (Errno (Errno), eOK, getErrno) +import Foreign.C.String.Managed (ManagedCString (..)) +import Foreign.C.Types (CInt (..), CSize (..)) +import GHC.Exts (ByteArray#, MutableByteArray#, RealWorld) +import Posix.File.Types (AccessMode (..), CreationFlags (..), DescriptorFlags (..), StatusFlags (..)) +import System.Posix.Types (CMode (..), CSsize (..), Fd (..)) import qualified Posix.File.Types as Types --- | Get file descriptor flags. This uses the unsafe FFI to --- perform @fcntl(fd,F_GETFD)@. +{- | Get file descriptor flags. This uses the unsafe FFI to +perform @fcntl(fd,F_GETFD)@. +-} uninterruptibleGetDescriptorFlags :: Fd -> IO (Either Errno DescriptorFlags) uninterruptibleGetDescriptorFlags !fd = c_getFdFlags fd >>= errorsFromDescriptorFlags --- | Get file status flags. This uses the unsafe FFI to --- perform @fcntl(fd,F_GETFL)@. +{- | Get file status flags. This uses the unsafe FFI to +perform @fcntl(fd,F_GETFL)@. +-} uninterruptibleGetStatusFlags :: Fd -> IO (Either Errno StatusFlags) uninterruptibleGetStatusFlags !fd = c_getFlFlags fd >>= errorsFromStatusFlags @@ -111,183 +115,257 @@ c_unsafe_close :: Fd -> IO CInt uninterruptibleOpen :: - ManagedCString -- ^ NULL-terminated file name - -> AccessMode -- ^ Access mode - -> CreationFlags -- ^ Creation flags - -> StatusFlags -- ^ Status flags - -> IO (Either Errno Fd) + -- | NULL-terminated file name + ManagedCString -> + -- | Access mode + AccessMode -> + -- | Creation flags + CreationFlags -> + -- | Status flags + StatusFlags -> + 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. +{- | 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) + -- | NULL-terminated file name + ManagedCString -> + -- | Flags + CInt -> + IO (Either Errno Fd) uninterruptibleOpenUntypedFlags (ManagedCString (ByteArray name)) x = c_unsafe_open name x >>= errorsFromFd --- | Variant of 'uninterruptibleOpenMode' that does not help the caller with --- the types of the flags. +{- | Variant of 'uninterruptibleOpenMode' that does not help the caller with +the types of the flags. +-} uninterruptibleOpenModeUntypedFlags :: - ManagedCString -- ^ NULL-terminated file name - -> CInt -- ^ Flags - -> CMode -- ^ Mode - -> IO (Either Errno Fd) + -- | NULL-terminated file name + ManagedCString -> + -- | Flags + CInt -> + -- | Mode + CMode -> + IO (Either Errno Fd) uninterruptibleOpenModeUntypedFlags (ManagedCString (ByteArray name)) !x !mode = c_unsafe_open_mode name x mode >>= errorsFromFd uninterruptibleOpenMode :: - ManagedCString -- ^ NULL-terminated file name - -> AccessMode -- ^ Access mode, should include @O_CREAT@ - -> CreationFlags -- ^ Creation flags - -> StatusFlags -- ^ Status flags - -> CMode -- ^ Permissions assigned to newly created file - -> IO (Either Errno Fd) + -- | NULL-terminated file name + ManagedCString -> + -- | Access mode, should include @O_CREAT@ + AccessMode -> + -- | Creation flags + CreationFlags -> + -- | Status flags + StatusFlags -> + -- | Permissions assigned to newly created file + CMode -> + IO (Either Errno Fd) uninterruptibleOpenMode (ManagedCString (ByteArray name)) (AccessMode x) (CreationFlags y) (StatusFlags z) !mode = c_unsafe_open_mode name (x .|. y .|. z) mode >>= errorsFromFd errorsFromDescriptorFlags :: DescriptorFlags -> IO (Either Errno DescriptorFlags) -errorsFromDescriptorFlags r@(DescriptorFlags x) = if x > (-1) - then pure (Right r) - else fmap Left getErrno +errorsFromDescriptorFlags r@(DescriptorFlags x) = + if x > (-1) + then pure (Right r) + else fmap Left getErrno errorsFromStatusFlags :: StatusFlags -> IO (Either Errno StatusFlags) -errorsFromStatusFlags r@(StatusFlags x) = if x > (-1) - then pure (Right r) - else fmap Left getErrno +errorsFromStatusFlags r@(StatusFlags x) = + if x > (-1) + then pure (Right r) + else fmap Left getErrno --- | Wrapper for @write(2)@ that takes a slice of bytes and an offset. --- The byte array backing the slice does not need to be pinned. +{- | Wrapper for @write(2)@ that takes a slice of bytes and an offset. +The byte array backing the slice does not need to be pinned. +-} uninterruptibleWriteBytesCompletely :: - Fd -- ^ File descriptor - -> Bytes -- ^ Source bytes - -> IO (Either Errno ()) + -- | File descriptor + Fd -> + -- | Source bytes + Bytes -> + IO (Either Errno ()) uninterruptibleWriteBytesCompletely !fd !b = do e <- uninterruptibleWriteBytesCompletelyErrno fd b if e == eOK then pure (Right ()) else pure (Left e) --- | Variant of 'uninterruptibleWriteBytesCompletely' that uses errno 0 --- to communicate success. +{- | Variant of 'uninterruptibleWriteBytesCompletely' that uses errno 0 +to communicate success. +-} uninterruptibleWriteBytesCompletelyErrno :: - Fd -- ^ File descriptor - -> Bytes -- ^ Source bytes - -> IO Errno + -- | File descriptor + Fd -> + -- | Source bytes + Bytes -> + IO Errno uninterruptibleWriteBytesCompletelyErrno !fd (Bytes (ByteArray buf) off len) = c_unsafe_bytearray_write_loop fd buf off (fromIntegral @Int @CSize len) --- | Wrapper for @write(2)@ that takes a slice of bytes and an offset. --- The byte array backing the slice must be pinned. +{- | Wrapper for @write(2)@ that takes a slice of bytes and an offset. +The byte array backing the slice must be pinned. +-} writeBytesCompletelyErrno :: - Fd -- ^ File descriptor - -> Bytes -- ^ Source bytes - -> IO Errno + -- | File descriptor + Fd -> + -- | Source bytes + Bytes -> + IO Errno writeBytesCompletelyErrno !fd (Bytes buf0 off len) = let !(ByteArray buf1) = assertByteArrayPinned buf0 in c_safe_bytearray_write_loop fd buf1 off (fromIntegral @Int @CSize len) --- | Wrapper for @write(2)@ that takes a slice of bytes and an offset. --- The byte array backing the slice does not need to be pinned. +{- | Wrapper for @write(2)@ that takes a slice of bytes and an offset. +The byte array backing the slice does not need to be pinned. +-} uninterruptibleWriteBytes :: - Fd -- ^ File descriptor - -> Bytes -- ^ Source bytes - -> IO (Either Errno CSize) -- ^ Number of bytes written + -- | File descriptor + Fd -> + -- | Source bytes + Bytes -> + -- | Number of bytes written + IO (Either Errno CSize) uninterruptibleWriteBytes !fd (Bytes (ByteArray buf) off len) = c_unsafe_bytearray_write fd buf off (fromIntegral @Int @CSize len) >>= errorsFromSize --- | Wrapper for @write(2)@ that takes a byte array and an offset. --- The byte array does not need to be pinned. +{- | Wrapper for @write(2)@ that takes a byte array and an offset. +The byte array does not need to be pinned. +-} uninterruptibleWriteByteArray :: - Fd -- ^ Socket - -> ByteArray -- ^ Source byte array - -> Int -- ^ Offset into source array - -> CSize -- ^ Length in bytes - -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer + -- | Socket + Fd -> + -- | Source byte array + ByteArray -> + -- | Offset into source array + Int -> + -- | Length in bytes + CSize -> + -- | Number of bytes pushed to send buffer + IO (Either Errno CSize) uninterruptibleWriteByteArray !fd (ByteArray buf) !off !len = c_unsafe_bytearray_write fd buf off len >>= errorsFromSize --- | Wrapper for @write(2)@ that takes a byte array and an offset. --- Uses @safe@ FFI. The byte array must be pinned. +{- | Wrapper for @write(2)@ that takes a byte array and an offset. +Uses @safe@ FFI. The byte array must be pinned. +-} writeByteArray :: - Fd -- ^ File descriptor - -> ByteArray -- ^ Source byte array - -> Int -- ^ Offset into source array - -> CSize -- ^ Length in bytes - -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer + -- | File descriptor + Fd -> + -- | Source byte array + ByteArray -> + -- | Offset into source array + Int -> + -- | Length in bytes + CSize -> + -- | Number of bytes pushed to send buffer + IO (Either Errno CSize) writeByteArray !fd !buf0 !off !len = let !(ByteArray buf1) = assertByteArrayPinned buf0 in c_safe_bytearray_write fd buf1 off len >>= errorsFromSize -- writeByteArrayCompletely :: --- | Variant of 'writeByteArray' that operates on mutable byte array. --- Uses @safe@ FFI. The byte array must be pinned. +{- | Variant of 'writeByteArray' that operates on mutable byte array. +Uses @safe@ FFI. The byte array must be pinned. +-} writeMutableByteArray :: - Fd -- ^ File descriptor - -> MutableByteArray RealWorld -- ^ Source byte array - -> Int -- ^ Offset into source array - -> CSize -- ^ Length in bytes - -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer + -- | File descriptor + Fd -> + -- | Source byte array + MutableByteArray RealWorld -> + -- | Offset into source array + Int -> + -- | Length in bytes + CSize -> + -- | Number of bytes pushed to send buffer + IO (Either Errno CSize) writeMutableByteArray !fd !buf0 !off !len = let !(MutableByteArray buf1) = assertMutableByteArrayPinned buf0 in c_safe_mutablebytearray_write fd buf1 off len >>= errorsFromSize +uninterruptibleReadMutableByteArray :: + -- | File descriptor + Fd -> + -- | Destination + MutableByteArray RealWorld -> + -- | Destination offset + Int -> + -- | Length in bytes + CSize -> + -- | Number of bytes received + IO (Either Errno CSize) +uninterruptibleReadMutableByteArray !fd !(MutableByteArray !b) !doff !dlen = do + c_unsafe_mutable_byte_array_read fd b doff dlen >>= errorsFromSize + errorsFromSize :: CSsize -> IO (Either Errno CSize) -errorsFromSize r = if r > (-1) - then pure (Right (cssizeToCSize r)) - else fmap Left getErrno +errorsFromSize r = + if r > (-1) + then pure (Right (cssizeToCSize r)) + else fmap Left getErrno errorsFromFd :: Fd -> IO (Either Errno Fd) -errorsFromFd r = if r > (-1) - then pure (Right r) - else fmap Left getErrno +errorsFromFd r = + if r > (-1) + then pure (Right r) + else fmap Left getErrno uninterruptibleLink :: - ManagedCString -- ^ Path to existing file - -> ManagedCString -- ^ Path to new file - -> IO (Either Errno ()) + -- | Path to existing file + ManagedCString -> + -- | Path to new file + ManagedCString -> + IO (Either Errno ()) uninterruptibleLink (ManagedCString (ByteArray x)) (ManagedCString (ByteArray y)) = c_unsafe_link x y >>= errorsFromInt_ uninterruptibleUnlink :: - ManagedCString -- ^ File name - -> IO (Either Errno ()) + -- | File name + ManagedCString -> + IO (Either Errno ()) uninterruptibleUnlink (ManagedCString (ByteArray x)) = c_unsafe_unlink x >>= errorsFromInt_ --- | Close a file descriptor. --- The --- includes more details. This uses the safe FFI. +{- | Close a file descriptor. + The + includes more details. This uses the safe FFI. +-} close :: - Fd -- ^ Socket - -> IO (Either Errno ()) + -- | Socket + Fd -> + IO (Either Errno ()) close fd = c_safe_close fd >>= errorsFromInt_ --- | Close a file descriptor. This uses the unsafe FFI. According to the --- , --- "If @fildes@ refers to a socket, @close()@ shall cause the socket to --- be destroyed. If the socket is in connection-mode, and the @SO_LINGER@ --- option is set for the socket with non-zero linger time, and the socket --- has untransmitted data, then @close()@ shall block for up to the current --- linger interval until all data is transmitted." +{- | Close a file descriptor. This uses the unsafe FFI. According to the + , + "If @fildes@ refers to a socket, @close()@ shall cause the socket to + be destroyed. If the socket is in connection-mode, and the @SO_LINGER@ + option is set for the socket with non-zero linger time, and the socket + has untransmitted data, then @close()@ shall block for up to the current + linger interval until all data is transmitted." +-} uninterruptibleClose :: - Fd -- ^ Socket - -> IO (Either Errno ()) + -- | Socket + Fd -> + IO (Either Errno ()) uninterruptibleClose fd = c_unsafe_close fd >>= errorsFromInt_ --- | Close a file descriptor with the unsafe FFI. Do not check for errors. --- It is only appropriate to use this when a file descriptor is being --- closed to handle an exceptional case. Since the user will want to --- propogate the original exception, the exception provided by --- 'uninterruptibleClose' would just be discarded. This function allows us --- to potentially avoid an additional FFI call to 'getErrno'. +{- | Close a file descriptor with the unsafe FFI. Do not check for errors. + It is only appropriate to use this when a file descriptor is being + closed to handle an exceptional case. Since the user will want to + propogate the original exception, the exception provided by + 'uninterruptibleClose' would just be discarded. This function allows us + to potentially avoid an additional FFI call to 'getErrno'. +-} uninterruptibleErrorlessClose :: - Fd -- ^ Socket - -> IO () + -- | Socket + Fd -> + IO () uninterruptibleErrorlessClose fd = do _ <- c_unsafe_close fd pure () @@ -309,7 +387,10 @@ -- success and negative one to indicate failure without including -- additional information in the value. errorsFromInt_ :: CInt -> IO (Either Errno ()) -errorsFromInt_ r = if r == 0 - then pure (Right ()) - else fmap Left getErrno +errorsFromInt_ r = + if r == 0 + then pure (Right ()) + else fmap Left getErrno +foreign import ccall unsafe "HaskellPosix.h read_offset" + c_unsafe_mutable_byte_array_read :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> IO CSsize diff --git a/src/Posix/MessageQueue.hs b/src/Posix/MessageQueue.hs --- a/src/Posix/MessageQueue.hs +++ b/src/Posix/MessageQueue.hs @@ -1,65 +1,82 @@ -{-# language BangPatterns #-} -{-# language MagicHash #-} -{-# language UnboxedTuples #-} -{-# language UnliftedFFITypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} + module Posix.MessageQueue ( open , uninterruptibleReceiveByteArray , uninterruptibleSendBytes + -- * Types - , AccessMode(..) - , CreationFlags(..) - , StatusFlags(..) + , AccessMode (..) + , CreationFlags (..) + , StatusFlags (..) + -- * Open Access Mode , F.readOnly , F.writeOnly , F.readWrite + -- * Open Flags , F.nonblocking ) where +import qualified Control.Monad.Primitive as PM import Data.Bits ((.|.)) -import GHC.Exts (RealWorld,ByteArray#,MutableByteArray#,Addr#) -import GHC.Exts (Int(I#)) -import System.Posix.Types (Fd(..),CSsize(..)) -import Foreign.C.Types (CInt(..),CSize(..),CUInt(..)) -import Foreign.C.Error (Errno,getErrno) +import Data.Bytes.Types (Bytes (Bytes)) +import Data.Primitive (ByteArray (..), MutableByteArray (..)) +import qualified Data.Primitive as PM +import Foreign.C.Error (Errno, getErrno) import Foreign.C.String (CString) -import Data.Primitive (MutableByteArray(..),ByteArray(..)) -import Data.Bytes.Types (Bytes(Bytes)) -import Posix.File.Types (CreationFlags(..),AccessMode(..),StatusFlags(..)) +import Foreign.C.Types (CInt (..), CSize (..), CUInt (..)) +import GHC.Exts (Addr#, ByteArray#, Int (I#), MutableByteArray#, RealWorld) import qualified GHC.Exts as Exts -import qualified Data.Primitive as PM -import qualified Control.Monad.Primitive as PM +import Posix.File.Types (AccessMode (..), CreationFlags (..), StatusFlags (..)) import qualified Posix.File.Types as F +import System.Posix.Types (CSsize (..), Fd (..)) foreign import ccall unsafe "mqueue.h mq_receive" - c_unsafe_mq_receive :: Fd -> MutableByteArray# RealWorld - -> CSize -> Addr# -> IO CSsize + c_unsafe_mq_receive :: + Fd -> + MutableByteArray# RealWorld -> + CSize -> + Addr# -> + IO CSsize foreign import ccall unsafe "mqueue.h mq_send_offset" - c_unsafe_mq_send_offset :: Fd - -> ByteArray# -> Int -> CSize -> CUInt -> IO CInt + c_unsafe_mq_send_offset :: + Fd -> + ByteArray# -> + Int -> + CSize -> + CUInt -> + IO CInt foreign import ccall safe "mqueue.h mq_open" c_safe_mq_open :: CString -> CInt -> IO Fd open :: - CString -- ^ NULL-terminated name of queue, must start with slash - -> AccessMode -- ^ Access mode - -> CreationFlags -- ^ Creation flags - -> StatusFlags -- ^ Status flags - -> IO (Either Errno Fd) + -- | NULL-terminated name of queue, must start with slash + CString -> + -- | Access mode + AccessMode -> + -- | Creation flags + CreationFlags -> + -- | Status flags + StatusFlags -> + IO (Either Errno Fd) open !name (AccessMode x) (CreationFlags y) (StatusFlags z) = c_safe_mq_open name (x .|. y .|. z) >>= errorsFromFd uninterruptibleReceiveByteArray :: - Fd -- ^ Message queue - -> CSize -- ^ Maximum length of message - -> IO (Either Errno ByteArray) + -- | Message queue + Fd -> + -- | Maximum length of message + CSize -> + IO (Either Errno ByteArray) uninterruptibleReceiveByteArray !fd !len = do - m@(MutableByteArray m# ) <- PM.newByteArray (csizeToInt len) - r <- c_unsafe_mq_receive fd m# len Exts.nullAddr# + m@(MutableByteArray m#) <- PM.newByteArray (csizeToInt len) + r <- c_unsafe_mq_receive fd m# len Exts.nullAddr# case r of (-1) -> fmap Left getErrno _ -> do @@ -69,14 +86,17 @@ pure (Right a) uninterruptibleSendBytes :: - Fd -- ^ Message queue - -> Bytes -- ^ Message - -> CUInt -- ^ Priority - -> IO (Either Errno ()) + -- | Message queue + Fd -> + -- | Message + Bytes -> + -- | Priority + CUInt -> + IO (Either Errno ()) uninterruptibleSendBytes !fd (Bytes (ByteArray arr) off len) pri = c_unsafe_mq_send_offset fd arr off (intToCSize len) pri >>= errorsFromInt_ - + shrinkMutableByteArray :: MutableByteArray RealWorld -> Int -> IO () shrinkMutableByteArray (MutableByteArray arr) (I# sz) = PM.primitive_ (Exts.shrinkMutableByteArray# arr sz) @@ -94,12 +114,13 @@ -- success and negative one to indicate failure without including -- additional information in the value. errorsFromInt_ :: CInt -> IO (Either Errno ()) -errorsFromInt_ r = if r == 0 - then pure (Right ()) - else fmap Left getErrno +errorsFromInt_ r = + if r == 0 + then pure (Right ()) + else fmap Left getErrno errorsFromFd :: Fd -> IO (Either Errno Fd) -errorsFromFd r = if r > (-1) - then pure (Right r) - else fmap Left getErrno - +errorsFromFd r = + if r > (-1) + then pure (Right r) + else fmap Left getErrno diff --git a/src/Posix/Poll.hs b/src/Posix/Poll.hs --- a/src/Posix/Poll.hs +++ b/src/Posix/Poll.hs @@ -1,13 +1,12 @@ -{-# language BangPatterns #-} -{-# language MagicHash #-} -{-# language UnliftedFFITypes #-} -{-# language ScopedTypeVariables #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnliftedFFITypes #-} module Posix.Poll ( uninterruptiblePoll , uninterruptiblePollMutablePrimArray - , PollFd(..) - , Exchange(..) + , PollFd (..) + , Exchange (..) , PT.input , PT.output , PT.error @@ -16,13 +15,13 @@ , PT.isSubeventOf ) where -import Posix.Types (CNfds(..)) -import Foreign.C.Error (Errno,getErrno) -import Foreign.C.Types (CInt(..)) +import Data.Primitive (MutablePrimArray (..)) +import Foreign.C.Error (Errno, getErrno) +import Foreign.C.Types (CInt (..)) +import GHC.Exts (MutableByteArray#, RealWorld) import GHC.Ptr (Ptr) -import GHC.Exts (RealWorld,MutableByteArray#) -import Posix.Poll.Types (PollFd(..),Exchange(..)) -import Data.Primitive (MutablePrimArray(..)) +import Posix.Poll.Types (Exchange (..), PollFd (..)) +import Posix.Types (CNfds (..)) import qualified Posix.Poll.Types as PT @@ -32,23 +31,25 @@ foreign import ccall unsafe "poll.h poll" c_poll_prim_array :: MutableByteArray# RealWorld -> CNfds -> CInt -> IO CInt --- | The @timeout@ argument is omitted since it is nonsense to choose --- anything other than 0 when using the unsafe FFI. +{- | The @timeout@ argument is omitted since it is nonsense to choose + anything other than 0 when using the unsafe FFI. +-} uninterruptiblePoll :: - Ptr PollFd - -> CNfds - -> IO (Either Errno CInt) + Ptr PollFd -> + CNfds -> + IO (Either Errno CInt) uninterruptiblePoll pfds n = c_poll_ptr pfds n 0 >>= errorsFromInt uninterruptiblePollMutablePrimArray :: - MutablePrimArray RealWorld PollFd - -> CNfds - -> IO (Either Errno CInt) + MutablePrimArray RealWorld PollFd -> + CNfds -> + IO (Either Errno CInt) uninterruptiblePollMutablePrimArray (MutablePrimArray pfds) n = c_poll_prim_array pfds n 0 >>= errorsFromInt errorsFromInt :: CInt -> IO (Either Errno CInt) -errorsFromInt r = if r >= 0 - then pure (Right r) - else fmap Left getErrno +errorsFromInt r = + if r >= 0 + then pure (Right r) + else fmap Left getErrno diff --git a/src/Posix/Poll/Types.hsc b/src/Posix/Poll/Types.hsc --- a/src/Posix/Poll/Types.hsc +++ b/src/Posix/Poll/Types.hsc @@ -11,7 +11,7 @@ {-# language MagicHash #-} {-# language UnboxedTuples #-} {-# language PolyKinds #-} -{-# language TypeInType #-} +{-# language DataKinds #-} -- This is needed because hsc2hs does not currently handle ticked -- promoted data constructors correctly. @@ -37,12 +37,10 @@ import Prelude hiding (truncate,error) import Data.Bits ((.|.),(.&.)) -import Data.Word (Word8,Word16,Word32,Word64) import Data.Primitive (Prim(..)) import Foreign.C.Types (CInt(..),CShort) import Foreign.Storable (Storable(..)) -import GHC.Ptr (Ptr(..)) -import GHC.Exts (RealWorld,Int(I##),Int##,(+##),(*##)) +import GHC.Exts (Int(I##),Int##,(+##),(*##)) import System.Posix.Types (Fd(..)) import qualified Data.Kind diff --git a/src/Posix/Select.hs b/src/Posix/Select.hs --- a/src/Posix/Select.hs +++ b/src/Posix/Select.hs @@ -1,5 +1,3 @@ module Posix.Select ( ) where - - diff --git a/src/Posix/Socket.hs b/src/Posix/Socket.hs --- a/src/Posix/Socket.hs +++ b/src/Posix/Socket.hs @@ -1,1496 +1,1522 @@ -{-# language BangPatterns #-} -{-# language CPP #-} -{-# language DataKinds #-} -{-# language DuplicateRecordFields #-} -{-# language GADTSyntax #-} -{-# language KindSignatures #-} -{-# language LambdaCase #-} -{-# language MagicHash #-} -{-# language NamedFieldPuns #-} -{-# language PatternSynonyms #-} -{-# language ScopedTypeVariables #-} -{-# language UnboxedTuples #-} -{-# language UnliftedFFITypes #-} - --- | Types and functions related to the POSIX sockets API. --- Unusual characteristics: --- --- * Any time the standard calls for @socklen_t@, we use --- @CInt@ instead. Linus Torvalds --- that \"Any sane library must have @socklen_t@ be the same size as @int@. --- Anything else breaks any BSD socket layer stuff.\" --- * Send and receive each have several variants. They are distinguished by --- the safe\/unsafe FFI use and by the @Addr@\/@ByteArray@/@MutableByteArray@ --- buffer type. They all call @send@ or @recv@ exactly once. They do not --- repeatedly make syscalls like some of the functions in @network@. --- Users who want that behavior need to build on top of this package. --- * There are no requirements on the pinnedness of @ByteArray@ arguments --- passed to any of these functions. If wrappers of the safe FFI are --- passed unpinned @ByteArray@ arguments, they will copy the contents --- into pinned memory before invoking the foreign function. -module Posix.Socket - ( -- * Functions - -- ** Socket - uninterruptibleSocket - -- ** Socket Pair - , uninterruptibleSocketPair - -- ** Address Resolution - , getAddressInfo - , uninterruptibleFreeAddressInfo - -- ** Bind - , uninterruptibleBind - -- ** Connect - , connect - , uninterruptibleConnect - , uninterruptibleConnectPtr - -- ** Listen - , uninterruptibleListen - -- ** Accept - , accept - , uninterruptibleAccept - , accept_ - -- ** Get Socket Name - , uninterruptibleGetSocketName - -- ** Get Socket Option - , uninterruptibleGetSocketOption - -- ** Set Socket Option - , uninterruptibleSetSocketOption - , uninterruptibleSetSocketOptionByteArray - , uninterruptibleSetSocketOptionInt - -- ** Close - , F.close - , F.uninterruptibleClose - , F.uninterruptibleErrorlessClose - -- ** Shutdown - , uninterruptibleShutdown - -- ** Send - , send - , sendByteArray - , sendMutableByteArray - , uninterruptibleSend - , uninterruptibleSendByteArray - , uninterruptibleSendMutableByteArray - -- ** Send To - , uninterruptibleSendToByteArray - , uninterruptibleSendToMutableByteArray - , uninterruptibleSendToInternet - , uninterruptibleSendToInternetByteArray - , uninterruptibleSendToInternetMutableByteArray - -- ** Write Vector -#if defined(UNLIFTEDARRAYFUNCTIONS) - , writeVector -#endif - -- ** Receive - , receive - , receiveByteArray - , uninterruptibleReceive - , uninterruptibleReceiveMutableByteArray - -- ** Receive From - , uninterruptibleReceiveFromMutableByteArray - , uninterruptibleReceiveFromMutableByteArray_ - , uninterruptibleReceiveFrom_ - , uninterruptibleReceiveFromInternet - , uninterruptibleReceiveFromInternetMutableByteArray - -- ** Receive Message - -- $receiveMessage -#if defined(UNLIFTEDARRAYFUNCTIONS) - , uninterruptibleReceiveMessageA - , uninterruptibleReceiveMessageB -#endif - -- ** Send Message - , uninterruptibleSendMessageA - , uninterruptibleSendMessageB -#if defined(UNLIFTEDARRAYFUNCTIONS) - , uninterruptibleSendByteArrays -#endif - -- ** Byte-Order Conversion - -- $conversion - , hostToNetworkLong - , hostToNetworkShort - , networkToHostLong - , networkToHostShort - -- * Types - , Family(..) - , Type(..) - , Protocol(..) - , OptionName(..) - , OptionValue(..) - , Level(..) - , Message(..) - , MessageFlags(..) - , ShutdownType(..) - , AddressInfo - -- * Socket Address - -- ** Types - , SocketAddress(..) - , PST.SocketAddressInternet(..) - , PST.SocketAddressUnix(..) - -- ** Encoding - , PSP.encodeSocketAddressInternet - , PSP.encodeSocketAddressUnix - -- ** Decoding - , PSP.decodeSocketAddressInternet - , PSP.indexSocketAddressInternet - -- ** Sizes - , PSP.sizeofSocketAddressInternet - -- * Data Construction - -- ** Socket Domains - , pattern PST.Unix - , pattern PST.Unspecified - , pattern PST.Internet - , pattern PST.Internet6 - -- ** Socket Types - , PST.stream - , PST.datagram - , PST.raw - , PST.sequencedPacket - -- ** Protocols - , PST.defaultProtocol - , PST.rawProtocol - , PST.icmp - , PST.tcp - , PST.udp - , PST.ip - , PST.ipv6 - -- ** Receive Flags - , PST.peek - , PST.outOfBand - , PST.waitAll - -- ** Send Flags - , PST.noSignal - -- ** Shutdown Types - , PST.read - , PST.write - , PST.readWrite - -- ** Socket Levels - , PST.levelSocket - -- ** Option Names - , PST.optionError - , PST.bindToDevice - , PST.broadcast - , PST.reuseAddress - -- ** Address Info - -- *** Peek - , PST.peekAddressInfoFlags - -- *** Poke - , PST.pokeAddressInfoFlags - -- *** Metadata - , PST.sizeofAddressInfo - -- ** Message Header - -- *** Peek - , PST.peekMessageHeaderName - , PST.peekMessageHeaderNameLength - , PST.peekMessageHeaderIOVector - , PST.peekMessageHeaderIOVectorLength - , PST.peekMessageHeaderControl - , PST.peekMessageHeaderControlLength - , PST.peekMessageHeaderFlags - , PST.peekControlMessageHeaderLevel - , PST.peekControlMessageHeaderLength - , PST.peekControlMessageHeaderType - -- *** Poke - , PST.pokeMessageHeaderName - , PST.pokeMessageHeaderNameLength - , PST.pokeMessageHeaderIOVector - , PST.pokeMessageHeaderIOVectorLength - , PST.pokeMessageHeaderControl - , PST.pokeMessageHeaderControlLength - , PST.pokeMessageHeaderFlags - -- *** Metadata - , PST.sizeofMessageHeader - -- ** IO Vector - -- *** Peek - , PST.peekIOVectorBase - , PST.peekIOVectorLength - -- *** Poke - , PST.pokeIOVectorBase - , PST.pokeIOVectorLength - -- *** Metadata - , PST.sizeofIOVector - ) where - -import GHC.ByteOrder (ByteOrder(BigEndian,LittleEndian),targetByteOrder) -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) -import Data.Void (Void) -import Foreign.C.Error (Errno(Errno),getErrno) -import Foreign.C.String (CString) -import Foreign.C.Types (CInt(..),CSize(..)) -import Foreign.Ptr (nullPtr) -import GHC.Exts (Ptr(Ptr),RealWorld,ByteArray#,MutableByteArray#) -import GHC.Exts (Addr#,TYPE) -import GHC.Exts (Int(I#)) -import GHC.Exts (shrinkMutableByteArray#,touch#) -import Posix.Socket.Types (Family(..),Protocol(..),Type(..),SocketAddress(..)) -import Posix.Socket.Types (SocketAddressInternet(..)) -import Posix.Socket.Types (MessageFlags(..),Message(..),ShutdownType(..)) -import Posix.Socket.Types (Level(..),OptionName(..),OptionValue(..)) -import Posix.Socket.Types (AddressInfo) -import System.Posix.Types (Fd(..),CSsize(..)) - -#if MIN_VERSION_base(4,16,0) -import GHC.Exts (RuntimeRep(BoxedRep),Levity(Unlifted)) -#else -import GHC.Exts (RuntimeRep(UnliftedRep)) -#endif - -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 - --- This module include operating-system specific code used --- to serialize some of various kind of socket address types. -import qualified Posix.Socket.Platform as PSP - --- getaddrinfo cannot use the unsafe ffi -foreign import ccall safe "sys/socket.h getaddrinfo" - c_safe_getaddrinfo :: - CString - -> CString - -> Ptr AddressInfo - -> MutableByteArray# RealWorld -- actually a `Ptr (Ptr AddressInfo))`. - -> IO Errno - --- | Free the @addrinfo@ at the pointer. -foreign import ccall safe "sys/socket.h freeaddrinfo" - uninterruptibleFreeAddressInfo :: Ptr AddressInfo -> IO () - -foreign import ccall unsafe "sys/socket.h socket" - c_socket :: Family -> Type -> Protocol -> IO Fd - -foreign import ccall unsafe "sys/socket.h socketpair" - c_socketpair :: Family -> Type -> Protocol -> MutableByteArray# RealWorld -> IO CInt - -foreign import ccall unsafe "sys/socket.h listen" - c_listen :: Fd -> CInt -> IO CInt - -foreign import ccall unsafe "unistd.h shutdown" - c_unsafe_shutdown :: Fd -> ShutdownType -> IO CInt - --- Per the spec, the type signature of bind is: --- int bind(int socket, const struct sockaddr *address, socklen_t address_len); --- However, here we choose to represent the third argument as --- CInt rather than introducing a type corresponding to socklen_t. --- According to Linus Torvalds, "Any sane library must have socklen_t --- be the same size as int. Anything else breaks any BSD socket layer stuff." --- (https://yarchive.net/comp/linux/socklen_t.html). If a platform --- violates this assumption, this wrapper will be broken on that platform. -foreign import ccall unsafe "sys/socket.h bind" - c_bind :: Fd -> ByteArray# -> CInt -> IO CInt - --- Per the spec, the type signature of accept is: --- int accept(int socket, struct sockaddr *restrict address, socklen_t *restrict address_len); --- The restrict keyword does not matter much for our purposes. See the --- note on c_bind for why we use CInt for socklen_t. Remember that the --- first bytearray argument is actually SocketAddress in the function that --- wraps this one. The second bytearray argument is a pointer to the size. -foreign import ccall safe "sys/socket.h accept" - c_safe_accept :: Fd - -> MutableByteArray# RealWorld -- SocketAddress - -> MutableByteArray# RealWorld -- Ptr CInt - -> IO Fd -foreign import ccall unsafe "sys/socket.h accept" - c_unsafe_accept :: Fd - -> MutableByteArray# RealWorld -- SocketAddress - -> MutableByteArray# RealWorld -- Ptr CInt - -> IO Fd --- This variant of accept is used when we do not care about the --- remote sockaddr. We pass null. -foreign import ccall safe "sys/socket.h accept" - c_safe_ptr_accept :: Fd -> Ptr Void -> Ptr CInt -> IO Fd - -foreign import ccall unsafe "sys/socket.h getsockname" - c_unsafe_getsockname :: Fd - -> MutableByteArray# RealWorld -- SocketAddress - -> MutableByteArray# RealWorld -- Addr length (Ptr CInt) - -> IO CInt - -foreign import ccall unsafe "sys/socket.h getsockopt" - c_unsafe_getsockopt :: Fd - -> Level - -> OptionName - -> MutableByteArray# RealWorld -- Option value - -> MutableByteArray# RealWorld -- Option len (Ptr CInt) - -> IO CInt - -foreign import ccall unsafe "sys/socket.h setsockopt_int" - c_unsafe_setsockopt_int :: Fd - -> Level - -> OptionName - -> CInt -- option_value - -> IO CInt - -foreign import ccall unsafe "sys/socket.h setsockopt" - c_unsafe_setsockopt :: Fd - -> Level - -> OptionName - -> Ptr Void -- option_val - -> CInt -- option_len - -> IO CInt - -foreign import ccall unsafe "sys/socket.h setsockopt" - c_unsafe_setsockopt_ba :: Fd - -> Level - -> OptionName - -> ByteArray# -- option_val - -> CInt -- option_len - -> IO CInt - --- Per the spec the type signature of connect is: --- int connect(int sockfd, const struct sockaddr *addr, socklen_t addrlen); --- The bytearray argument is actually SocketAddress. -foreign import ccall safe "sys/socket.h connect" - c_safe_connect :: Fd -> ByteArray# -> CInt -> IO CInt -foreign import ccall safe "sys/socket.h connect" - 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 --- have the option of writing to either an address or a byte array. --- Unsafe FFI calls guarantee that byte arrays will not be relocated --- while the FFI call is taking place. Safe FFI calls do not have --- this guarantee, so internally we must be careful when using these to only --- provide pinned byte arrays as arguments. -foreign import ccall safe "sys/socket.h send" - c_safe_addr_send :: Fd -> Addr# -> CSize -> MessageFlags 'Send -> IO CSsize -foreign import ccall safe "sys/socket.h send_offset" - c_safe_bytearray_send :: Fd -> ByteArray# -> Int -> CSize -> MessageFlags 'Send -> IO CSsize -foreign import ccall safe "sys/socket.h send_offset" - c_safe_mutablebytearray_send :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> MessageFlags 'Send -> IO CSsize -foreign import ccall safe "sys/socket.h send" - c_safe_mutablebytearray_no_offset_send :: Fd -> MutableByteArray# RealWorld -> CSize -> MessageFlags 'Send -> IO CSsize -foreign import ccall unsafe "sys/socket.h send" - c_unsafe_addr_send :: Fd -> Addr# -> CSize -> MessageFlags 'Send -> IO CSsize -foreign import ccall unsafe "sys/socket.h send_offset" - c_unsafe_bytearray_send :: Fd -> ByteArray# -> Int -> CSize -> MessageFlags 'Send -> IO CSsize -foreign import ccall unsafe "sys/socket.h send_offset" - c_unsafe_mutable_bytearray_send :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> MessageFlags 'Send -> IO CSsize - --- The ByteArray# (second to last argument) is a SocketAddress. -foreign import ccall unsafe "sys/socket.h sendto_offset" - c_unsafe_bytearray_sendto :: Fd -> ByteArray# -> Int -> CSize -> MessageFlags 'Send -> ByteArray# -> CInt -> IO CSsize --- The ByteArray# (second to last argument) is a SocketAddress. -foreign import ccall unsafe "sys/socket.h sendto_offset" - c_unsafe_mutable_bytearray_sendto :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> MessageFlags 'Send -> ByteArray# -> CInt -> IO CSsize -foreign import ccall unsafe "sys/socket.h sendto_inet_offset" - c_unsafe_mutable_bytearray_sendto_inet :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> MessageFlags 'Send -> Word16 -> Word32 -> IO CSsize -foreign import ccall unsafe "HaskellPosix.h sendto_inet_offset" - c_unsafe_bytearray_sendto_inet :: Fd -> ByteArray# -> Int -> CSize -> MessageFlags 'Send -> Word16 -> Word32 -> IO CSsize -foreign import ccall unsafe "HaskellPosix.h sendto_inet_addr" - c_unsafe_addr_sendto_inet :: Fd -> Addr# -> CSize -> MessageFlags 'Send -> Word16 -> Word32 -> IO CSsize - -foreign import ccall unsafe "HaskellPosix.h sendmsg_a" - c_unsafe_sendmsg_a :: Fd -> Addr# -> CSize -> MutableByteArray# RealWorld -> Int -> CSize -> MessageFlags 'Send -> IO CSsize - -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 - --- There are several ways to wrap recv. -foreign import ccall safe "sys/socket.h recv" - c_safe_addr_recv :: Fd -> Addr# -> CSize -> MessageFlags 'Receive -> IO CSsize -foreign import ccall unsafe "sys/socket.h recv" - c_unsafe_addr_recv :: Fd -> Addr# -> CSize -> MessageFlags 'Receive -> IO CSsize -foreign import ccall unsafe "sys/socket.h recv_offset" - c_unsafe_mutable_byte_array_recv :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> MessageFlags 'Receive -> IO CSsize - --- The last two arguments are SocketAddress and Ptr CInt. -foreign import ccall unsafe "sys/socket.h recvfrom_offset" - c_unsafe_mutable_byte_array_recvfrom :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> MessageFlags 'Receive -> MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> IO CSsize -foreign import ccall unsafe "sys/socket.h recvfrom_offset_peerless" - c_unsafe_mutable_byte_array_peerless_recvfrom :: - Fd - -> MutableByteArray# RealWorld -> Int -> CSize - -> MessageFlags 'Receive -> IO CSsize -foreign import ccall unsafe "sys/socket.h recvfrom_addr_peerless" - c_unsafe_addr_peerless_recvfrom :: - Fd -> Addr# -> CSize -> MessageFlags 'Receive -> IO CSsize -foreign import ccall unsafe "sys/socket.h recvfrom_offset_inet" - c_unsafe_recvfrom_inet :: - Fd - -> MutableByteArray# RealWorld - -> Int - -> CSize - -> MessageFlags 'Receive - -> MutableByteArray# RealWorld - -> Int - -> IO CSsize -foreign import ccall unsafe "sys/socket.h recvfrom_offset_inet_addr" - c_unsafe_recvfrom_inet_addr :: - Fd - -> Addr# - -> CSize - -> MessageFlags 'Receive - -> MutableByteArray# RealWorld - -> Int - -> IO CSsize - -foreign import ccall unsafe "sys/socket.h recvmsg" - c_unsafe_addr_recvmsg :: Fd - -> Addr# -- This addr is a pointer to msghdr - -> MessageFlags 'Receive - -> IO CSsize - --- | Create an endpoint for communication, returning a file --- descriptor that refers to that endpoint. The --- --- includes more details. No special preparation is required before calling --- this function. The author believes that it cannot block for a prolonged --- period of time. -uninterruptibleSocket :: - Family -- ^ Communications domain (e.g. 'internet', 'unix') - -> Type -- ^ Socket type (e.g. 'datagram', 'stream') with flags - -> Protocol -- ^ Protocol - -> IO (Either Errno Fd) -uninterruptibleSocket dom typ prot = c_socket dom typ prot >>= errorsFromFd - --- | Create an unbound pair of connected sockets in a specified domain, of --- a specified type, under the protocol optionally specified by the protocol --- argument. The --- includes more details. No special preparation is required before calling --- this function. The author believes that it cannot block for a prolonged --- period of time. -uninterruptibleSocketPair :: - Family -- ^ Communications domain (probably 'unix') - -> Type -- ^ Socket type (e.g. 'datagram', 'stream') with flags - -> Protocol -- ^ Protocol - -> IO (Either Errno (Fd,Fd)) -uninterruptibleSocketPair dom typ prot = do - -- If this ever switches to the safe FFI, we will need to use - -- a pinned array here instead. - (sockets@(MutablePrimArray sockets#) :: MutablePrimArray RealWorld Fd) <- PM.newPrimArray 2 - r <- c_socketpair dom typ prot sockets# - if r == 0 - then do - fd1 <- PM.readPrimArray sockets 0 - fd2 <- PM.readPrimArray sockets 1 - pure (Right (fd1,fd2)) - else fmap Left getErrno - - --- | Given node and service, which identify an Internet host and a service, --- @getaddrinfo()@ returns one or more @addrinfo@ structures. The type of this --- wrapper differs slightly from the type of its C counterpart. Remember to call --- 'uninterruptibleFreeAddressInfo' when finished with the result. -getAddressInfo :: - CString -- ^ Node, identifies an Internet host - -> CString -- ^ Service - -> Ptr AddressInfo -- ^ Hints - -> IO (Either Errno (Ptr AddressInfo)) -getAddressInfo !node !service !hints = do - resBuf@(MutableByteArray resBuf#) <- PM.newPinnedByteArray (PM.sizeOf (undefined :: Ptr ())) - c_safe_getaddrinfo node service hints resBuf# >>= \case - Errno 0 -> do - res <- PM.readByteArray resBuf 0 - pure (Right res) - e -> pure (Left e) - --- | Assign a local socket address address to a socket identified by --- descriptor socket that has no local socket address assigned. The --- --- includes more details. The 'SocketAddress' represents the @sockaddr@ pointer argument, together --- with its @socklen_t@ size, as a byte array. This allows @bind@ to --- be used with @sockaddr@ extensions on various platforms. No special --- preparation is required before calling this function. The author --- believes that it cannot block for a prolonged period of time. -uninterruptibleBind :: - Fd -- ^ Socket - -> SocketAddress -- ^ Socket address, extensible tagged union - -> IO (Either Errno ()) -uninterruptibleBind fd (SocketAddress b@(ByteArray b#)) = - c_bind fd b# (intToCInt (PM.sizeofByteArray b)) >>= errorsFromInt_ - --- | Mark the socket as a passive socket, that is, as a socket that --- will be used to accept incoming connection requests using @accept@. --- The --- includes more details. No special preparation is required before --- calling this function. The author believes that it cannot block --- for a prolonged period of time. -uninterruptibleListen :: - Fd -- ^ Socket - -> CInt -- ^ Backlog - -> IO (Either Errno ()) -uninterruptibleListen fd backlog = c_listen fd backlog >>= errorsFromInt_ - --- | Connect the socket to the specified socket address. --- The --- includes more details. -connect :: - Fd -- ^ Fd - -> SocketAddress -- ^ Socket address, extensible tagged union - -> IO (Either Errno ()) -connect fd (SocketAddress sockAddr@(ByteArray sockAddr#)) = - case isByteArrayPinned sockAddr of - True -> c_safe_connect fd sockAddr# (intToCInt (PM.sizeofByteArray sockAddr)) >>= errorsFromInt_ - False -> do - let len = PM.sizeofByteArray sockAddr - x@(MutableByteArray x#) <- PM.newPinnedByteArray len - PM.copyByteArray x 0 sockAddr 0 len - c_safe_mutablebytearray_connect fd x# (intToCInt len) >>= errorsFromInt_ - --- | Connect the socket to the specified socket address. --- The --- includes more details. The only sensible way to use this is to --- give a nonblocking socket as the argument. -uninterruptibleConnect :: - Fd -- ^ Fd - -> SocketAddress -- ^ Socket address, extensible tagged union - -> IO (Either Errno ()) -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 --- the specification: --- --- > int accept(int socket, struct sockaddr *restrict address, socklen_t *restrict address_len); --- --- Instead of requiring the caller to prepare buffers through which --- information is returned, this haskell binding to @accept@ prepares --- those buffers internally. This eschews C\'s characteristic buffer-passing --- in favor of the Haskell convention of allocating internally and returning. --- --- More specifically, this binding lacks an argument corresponding to the --- @sockaddr@ buffer from the specification. That mutable buffer is allocated --- internally, resized and frozen upon a success, and returned along with --- the file descriptor of the accepted socket. The size of this buffer is --- determined by the second argument (maximum socket address size). This --- size argument is also writen to the @address_len@ buffer, which is also --- allocated internally. The size returned through this pointer is used to --- resize the @sockaddr@ buffer, which is then frozen so that an immutable --- 'SocketAddress' is returned to the end user. --- --- For applications uninterested in the peer (described by @sockaddr@), --- POSIX @accept@ allows the null pointer to be passed as both @address@ and --- @address_len@. This behavior is provided by 'accept_'. -accept :: - Fd -- ^ Listening socket - -> CInt -- ^ Maximum socket address size - -> IO (Either Errno (CInt,SocketAddress,Fd)) -- ^ Peer information and connected socket -accept !sock !maxSz = do - sockAddrBuf@(MutableByteArray sockAddrBuf#) <- PM.newPinnedByteArray (cintToInt maxSz) - lenBuf@(MutableByteArray lenBuf#) <- PM.newPinnedByteArray (PM.sizeOf (undefined :: CInt)) - PM.writeByteArray lenBuf 0 maxSz - r <- c_safe_accept sock sockAddrBuf# lenBuf# - if r > (-1) - then do - (sz :: CInt) <- PM.readByteArray lenBuf 0 - -- Why copy when we could just shrink? We want to always return - -- byte arrays that are not explicitly pinned. - let minSz = min sz maxSz - x <- PM.newByteArray (cintToInt minSz) - PM.copyMutableByteArray x 0 sockAddrBuf 0 (cintToInt minSz) - sockAddr <- PM.unsafeFreezeByteArray x - pure (Right (sz,SocketAddress sockAddr,r)) - else fmap Left getErrno - --- | See 'accept'. This uses the unsafe FFI. Consequently, it does not --- not need to allocate pinned memory. It only makes sense to call this --- on a nonblocking socket. -uninterruptibleAccept :: - Fd -- ^ Listening socket - -> CInt -- ^ Maximum socket address size - -> IO (Either Errno (CInt,SocketAddress,Fd)) -- ^ Peer information and connected socket -uninterruptibleAccept !sock !maxSz = do - sockAddrBuf@(MutableByteArray sockAddrBuf#) <- PM.newByteArray (cintToInt maxSz) - lenBuf@(MutableByteArray lenBuf#) <- PM.newByteArray (PM.sizeOf (undefined :: CInt)) - PM.writeByteArray lenBuf 0 maxSz - r <- c_unsafe_accept sock sockAddrBuf# lenBuf# - if r > (-1) - then do - (sz :: CInt) <- PM.readByteArray lenBuf 0 - if sz < maxSz - then shrinkMutableByteArray sockAddrBuf (cintToInt sz) - else pure () - sockAddr <- PM.unsafeFreezeByteArray sockAddrBuf - pure (Right (sz,SocketAddress sockAddr,r)) - else fmap Left getErrno - --- | A variant of 'accept' that does not provide the user with a --- 'SocketAddress' detailing the peer. -accept_ :: - Fd -- ^ Listening socket - -> IO (Either Errno Fd) -- ^ Connected socket -accept_ sock = - c_safe_ptr_accept sock nullPtr nullPtr >>= errorsFromFd - --- | Retrieve the locally-bound name of the specified socket. The --- --- of @getsockname@ includes more details. -uninterruptibleGetSocketName :: - Fd -- ^ Socket - -> CInt -- ^ Maximum socket address size - -> IO (Either Errno (CInt,SocketAddress)) -uninterruptibleGetSocketName sock maxSz = do - sockAddrBuf@(MutableByteArray sockAddrBuf#) <- PM.newByteArray (cintToInt maxSz) - lenBuf@(MutableByteArray lenBuf#) <- PM.newByteArray (PM.sizeOf (undefined :: CInt)) - PM.writeByteArray lenBuf 0 maxSz - r <- c_unsafe_getsockname sock sockAddrBuf# lenBuf# - if r == 0 - then do - (sz :: CInt) <- PM.readByteArray lenBuf 0 - if sz < maxSz - then shrinkMutableByteArray sockAddrBuf (cintToInt sz) - else pure () - sockAddr <- PM.unsafeFreezeByteArray sockAddrBuf - pure (Right (sz,SocketAddress sockAddr)) - else fmap Left getErrno - --- | Retrieve the value for the option specified by the 'Option' argument for --- the socket specified by the 'Fd' argument. The --- --- of @getsockopt@ includes more details. -uninterruptibleGetSocketOption :: - Fd -- ^ Socket - -> Level -- ^ Socket level - -> OptionName -- Option name - -> CInt -- ^ Maximum option value size - -> IO (Either Errno (CInt,OptionValue)) -uninterruptibleGetSocketOption sock level optName maxSz = do - valueBuf@(MutableByteArray valueBuf#) <- PM.newByteArray (cintToInt maxSz) - lenBuf@(MutableByteArray lenBuf#) <- PM.newByteArray (PM.sizeOf (undefined :: CInt)) - PM.writeByteArray lenBuf 0 maxSz - r <- c_unsafe_getsockopt sock level optName valueBuf# lenBuf# - if r == 0 - then do - (sz :: CInt) <- PM.readByteArray lenBuf 0 - if sz < maxSz - then shrinkMutableByteArray valueBuf (cintToInt sz) - else pure () - value <- PM.unsafeFreezeByteArray valueBuf - pure (Right (sz,OptionValue value)) - else fmap Left getErrno - --- | Set the value for the option specified by the 'Option' argument for --- the socket specified by the 'Fd' argument. The --- --- of @getsockopt@ includes more details. This variant requires that the --- size of the @option_value@ --- be the same as the size of 'CInt'. That is, the @option_name@ must --- describe an option that is represented by a C integer. This is a --- common case, so we avoid allocations by reference-passing in C. -uninterruptibleSetSocketOptionInt :: - Fd -- ^ Socket - -> Level -- ^ Socket level - -> OptionName -- ^ Option name - -> CInt -- ^ Option value - -> IO (Either Errno ()) -uninterruptibleSetSocketOptionInt sock level optName optValue = - c_unsafe_setsockopt_int sock level optName optValue >>= errorsFromInt_ - --- | Set the value for the option specified by the 'Option' argument for --- the socket specified by the 'Fd' argument. The --- --- of @getsockopt@ includes more details. -uninterruptibleSetSocketOption :: - Fd -- ^ Socket - -> Level -- ^ Socket level - -> OptionName -- ^ Option name - -> Ptr Void -- ^ Option value - -> CInt -- ^ Option value length - -> IO (Either Errno ()) -uninterruptibleSetSocketOption sock level optName optValue optLen = - c_unsafe_setsockopt sock level optName optValue optLen >>= errorsFromInt_ - --- | Variant of 'uninterruptibleSetSocketOption' that accepts the option --- as a byte array instead of a pointer into unmanaged memory. The argument --- does not need to be pinned. -uninterruptibleSetSocketOptionByteArray :: - Fd -- ^ Socket - -> Level -- ^ Socket level - -> OptionName -- ^ Option name - -> ByteArray -- ^ Option value - -> CInt -- ^ Option value length - -> IO (Either Errno ()) -uninterruptibleSetSocketOptionByteArray sock level optName (ByteArray optVal) optLen = - c_unsafe_setsockopt_ba sock level optName optVal optLen >>= errorsFromInt_ - --- | Send data from a 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 --- FFI, it allocates a pinned copy of the bytearry if it was not --- already pinned. -sendByteArray :: - Fd -- ^ Socket - -> ByteArray -- ^ Source byte array - -> Int -- ^ Offset into source array - -> CSize -- ^ Length in bytes - -> MessageFlags 'Send -- ^ Flags - -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer -sendByteArray fd b@(ByteArray b#) off len flags = if isByteArrayPinned b - then errorsFromSize =<< c_safe_bytearray_send fd b# off len flags - else do - x@(MutableByteArray x#) <- PM.newPinnedByteArray (csizeToInt len) - PM.copyByteArray x off b 0 (csizeToInt len) - errorsFromSize =<< c_safe_mutablebytearray_no_offset_send fd x# len flags - -#if MIN_VERSION_base(4,16,0) -data UList (a :: TYPE ('BoxedRep 'Unlifted)) where -#else -data UList (a :: TYPE 'UnliftedRep) where -#endif - UNil :: UList a - UCons :: a -> UList a -> UList a - --- Internal function. Fold with strict accumulator. Upper bound is exclusive. --- Hits every int in the range [0,hi) from highest to lowest. -foldDownward :: forall a. Int -> a -> (a -> Int -> IO a) -> IO a -{-# INLINE foldDownward #-} -foldDownward !hi !a0 f = go (hi - 1) a0 where - go :: Int -> a -> IO a - go !ix !a = if ix >= 0 - then f a ix >>= go (ix - 1) - else pure a - --- | Copy and pin a byte array if, it's not already pinned. -pinByteArray :: ByteArray -> IO (Maybe ByteArray) -{-# INLINE pinByteArray #-} -pinByteArray byteArray = - if isByteArrayPinned byteArray - then - pure Nothing - else do - pinnedByteArray <- PM.newPinnedByteArray len - PM.copyByteArray pinnedByteArray 0 byteArray 0 len - r <- PM.unsafeFreezeByteArray pinnedByteArray - pure (Just r) - where - len = PM.sizeofByteArray byteArray - --- | Send two payloads (one from unmanaged memory and one from --- managed memory) over a network socket. -uninterruptibleSendMessageA :: - Fd -- ^ Socket - -> Addr -- ^ Source address (payload A) - -> CSize -- ^ Length in bytes (payload A) - -> MutableByteArrayOffset RealWorld -- ^ Source and offset (payload B) - -> CSize -- ^ Length in bytes (payload B) - -> MessageFlags 'Send -- ^ Flags - -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer -uninterruptibleSendMessageA fd (Addr addr) lenA - (MutableByteArrayOffset{array,offset}) lenB flags = - c_unsafe_sendmsg_a fd addr lenA (unMba array) offset lenB flags - >>= errorsFromSize - --- | Send two payloads (one from managed memory and one from --- unmanaged memory) over a network socket. -uninterruptibleSendMessageB :: - Fd -- ^ Socket - -> MutableByteArrayOffset RealWorld -- ^ Source and offset (payload B) - -> CSize -- ^ Length in bytes (payload B) - -> Addr -- ^ Source address (payload A) - -> CSize -- ^ Length in bytes (payload A) - -> MessageFlags 'Send -- ^ Flags - -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer -uninterruptibleSendMessageB fd - (MutableByteArrayOffset{array,offset}) lenB - (Addr addr) lenA flags = - c_unsafe_sendmsg_b fd (unMba array) offset lenB addr lenA 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 --- FFI, it allocates a pinned copy of the bytearry if it was not --- already pinned. -sendMutableByteArray :: - Fd -- ^ Socket - -> MutableByteArray RealWorld -- ^ Source byte array - -> Int -- ^ Offset into source array - -> CSize -- ^ Length in bytes - -> MessageFlags 'Send -- ^ Flags - -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer -sendMutableByteArray fd b@(MutableByteArray b#) off len flags = if isMutableByteArrayPinned b - then errorsFromSize =<< c_safe_mutablebytearray_send fd b# off len flags - else do - x@(MutableByteArray x#) <- PM.newPinnedByteArray (csizeToInt len) - PM.copyMutableByteArray x off b 0 (csizeToInt len) - errorsFromSize =<< c_safe_mutablebytearray_no_offset_send fd x# len flags - --- | Send data from an address over a network socket. This is not guaranteed --- to send the entire length. This uses the safe FFI since --- it may block indefinitely. -send :: - Fd -- ^ Connected socket - -> Addr -- ^ Source address - -> CSize -- ^ Length in bytes - -> MessageFlags 'Send -- ^ Flags - -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer -send fd (Addr addr) len flags = - c_safe_addr_send fd addr len flags >>= errorsFromSize - --- | Send data from an address over a network socket. This uses the unsafe FFI. --- Users of this function should be sure to set flags that prohibit this --- from blocking. On Linux this is accomplished with @O_NONBLOCK@. It is --- often desirable to call 'threadWaitWrite' on a nonblocking socket before --- calling @unsafeSend@ on it. -uninterruptibleSend :: - Fd -- ^ Socket - -> Addr -- ^ Source address - -> CSize -- ^ Length in bytes - -> MessageFlags 'Send -- ^ Flags - -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer -uninterruptibleSend fd (Addr addr) len flags = - c_unsafe_addr_send fd addr len flags >>= errorsFromSize - --- | Send data from a byte array over a network socket. This uses the unsafe FFI; --- considerations pertaining to 'sendUnsafe' apply to this function as well. Users --- may specify a length to send fewer bytes than are actually present in the --- array. -uninterruptibleSendByteArray :: - Fd -- ^ Socket - -> ByteArray -- ^ Source byte array - -> Int -- ^ Offset into source array - -> CSize -- ^ Length in bytes - -> MessageFlags 'Send -- ^ Flags - -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer -uninterruptibleSendByteArray fd (ByteArray b) off len flags = - c_unsafe_bytearray_send fd b off len flags >>= errorsFromSize - --- | Send data from a mutable byte array over a network socket. This uses the unsafe FFI; --- considerations pertaining to 'sendUnsafe' apply to this function as well. Users --- specify an offset and a length to send fewer bytes than are actually present in the --- array. -uninterruptibleSendMutableByteArray :: - Fd -- ^ Socket - -> MutableByteArray RealWorld -- ^ Source mutable byte array - -> Int -- ^ Offset into source array - -> CSize -- ^ Length in bytes - -> MessageFlags 'Send -- ^ Flags - -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer -uninterruptibleSendMutableByteArray fd (MutableByteArray b) off len flags = - c_unsafe_mutable_bytearray_send fd b off len flags >>= errorsFromSize - --- | Send data from a byte array over an unconnected network socket. --- This uses the unsafe FFI; considerations pertaining to 'sendToUnsafe' --- apply to this function as well. The offset and length arguments --- cause a slice of the byte array to be sent rather than the entire --- byte array. -uninterruptibleSendToByteArray :: - Fd -- ^ Socket - -> ByteArray -- ^ Source byte array - -> Int -- ^ Offset into source array - -> CSize -- ^ Length in bytes - -> MessageFlags 'Send -- ^ Flags - -> SocketAddress -- ^ Socket Address - -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer -uninterruptibleSendToByteArray fd (ByteArray b) off len flags (SocketAddress a@(ByteArray a#)) = - c_unsafe_bytearray_sendto fd b off len flags a# (intToCInt (PM.sizeofByteArray a)) >>= errorsFromSize - --- | Variant of 'uninterruptibleSendToByteArray' that requires --- that @sockaddr_in@ be used as the socket address. This is used to --- avoid allocating a buffer for the socket address when the caller --- knows in advance that they are sending to an IPv4 address. -uninterruptibleSendToInternetByteArray :: - Fd -- ^ Socket - -> ByteArray -- ^ Source byte array - -> Int -- ^ Offset into source array - -> CSize -- ^ Length in bytes - -> MessageFlags 'Send -- ^ Flags - -> SocketAddressInternet -- ^ Socket Address - -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer -uninterruptibleSendToInternetByteArray fd (ByteArray b) off len flags (SocketAddressInternet{port,address}) = - c_unsafe_bytearray_sendto_inet fd b off len flags port address >>= errorsFromSize - --- | Variant of 'uninterruptibleSendToByteArray' that requires --- that @sockaddr_in@ be used as the socket address. This is used to --- avoid allocating a buffer for the socket address when the caller --- knows in advance that they are sending to an IPv4 address. -uninterruptibleSendToInternet :: - Fd -- ^ Socket - -> Addr -- ^ Source byte array - -> CSize -- ^ Length in bytes - -> MessageFlags 'Send -- ^ Flags - -> SocketAddressInternet -- ^ Socket Address - -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer -uninterruptibleSendToInternet fd (Addr b) len flags (SocketAddressInternet{port,address}) = - c_unsafe_addr_sendto_inet fd b len flags port address >>= errorsFromSize - --- | Send data from a mutable byte array over an unconnected network socket. --- This uses the unsafe FFI; concerns pertaining to 'uninterruptibleSend' --- apply to this function as well. The offset and length arguments --- cause a slice of the mutable byte array to be sent rather than the entire --- byte array. -uninterruptibleSendToMutableByteArray :: - Fd -- ^ Socket - -> MutableByteArray RealWorld -- ^ Source byte array - -> Int -- ^ Offset into source array - -> CSize -- ^ Length in bytes - -> MessageFlags 'Send -- ^ Flags - -> SocketAddress -- ^ Socket Address - -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer -uninterruptibleSendToMutableByteArray fd (MutableByteArray b) off len flags (SocketAddress a@(ByteArray a#)) = - c_unsafe_mutable_bytearray_sendto fd b off len flags a# (intToCInt (PM.sizeofByteArray a)) >>= errorsFromSize - --- | Variant of 'uninterruptibleSendToMutableByteArray' that requires --- that @sockaddr_in@ be used as the socket address. This is used to --- avoid allocating a buffer for the socket address when the caller --- knows in advance that they are sending to an IPv4 address. -uninterruptibleSendToInternetMutableByteArray :: - Fd -- ^ Socket - -> MutableByteArray RealWorld -- ^ Source byte array - -> Int -- ^ Offset into source array - -> CSize -- ^ Length in bytes - -> MessageFlags 'Send -- ^ Flags - -> SocketAddressInternet -- ^ Socket Address - -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer -uninterruptibleSendToInternetMutableByteArray fd (MutableByteArray b) off len flags (SocketAddressInternet{port,address}) = - c_unsafe_mutable_bytearray_sendto_inet fd b off len flags port address >>= errorsFromSize - --- | Receive data into an address from a network socket. This wraps @recv@ using --- the safe FFI. When the returned size is zero, there are no --- additional bytes to receive and the peer has performed an orderly shutdown. -receive :: - Fd -- ^ Socket - -> Addr -- ^ Source address - -> CSize -- ^ Length in bytes - -> MessageFlags 'Receive -- ^ Flags - -> IO (Either Errno CSize) -receive fd (Addr addr) len flags = - c_safe_addr_recv fd addr len flags >>= errorsFromSize - --- | Receive data into a byte array from a network socket. This wraps @recv@ using --- the safe FFI. When the returned size is zero, there are no --- additional bytes to receive and the peer has performed an orderly shutdown. -receiveByteArray :: - Fd -- ^ Socket - -> CSize -- ^ Length in bytes - -> MessageFlags 'Receive -- ^ Flags - -> IO (Either Errno ByteArray) -receiveByteArray !fd !len !flags = do - m <- PM.newPinnedByteArray (csizeToInt len) - let !(Addr addr) = ptrToAddr (PM.mutableByteArrayContents m) - r <- c_safe_addr_recv fd addr len flags - if r /= (-1) - then do - -- Why copy when we could just shrink? We want to always return - -- byte arrays that are not explicitly pinned. - let sz = cssizeToInt r - x <- PM.newByteArray sz - PM.copyMutableByteArray x 0 m 0 sz - a <- PM.unsafeFreezeByteArray x - pure (Right a) - else fmap Left getErrno - --- | Receive data into an address from a network socket. This wraps @recv@ --- using the unsafe FFI. Users of this function should be sure to set flags --- that prohibit this from blocking. On Linux this is accomplished by setting --- the @MSG_DONTWAIT@ flag and handling the resulting @EAGAIN@ or --- @EWOULDBLOCK@. When the returned size is zero, there are no additional --- bytes to receive and the peer has performed an orderly shutdown. -uninterruptibleReceive :: - Fd -- ^ Socket - -> Addr -- ^ Source address - -> CSize -- ^ Length in bytes - -> MessageFlags 'Receive -- ^ Flags - -> IO (Either Errno CSize) -{-# inline uninterruptibleReceive #-} -uninterruptibleReceive !fd (Addr !addr) !len !flags = - c_unsafe_addr_recv fd addr len flags >>= errorsFromSize - --- | Receive data into an address from a network socket. This uses the unsafe --- FFI; considerations pertaining to 'receiveUnsafe' apply to this function --- as well. Users may specify a length to receive fewer bytes than are --- actually present in the mutable byte array. -uninterruptibleReceiveMutableByteArray :: - Fd -- ^ Socket - -> MutableByteArray RealWorld -- ^ Destination byte array - -> Int -- ^ Destination offset - -> CSize -- ^ Maximum bytes to receive - -> MessageFlags 'Receive -- ^ Flags - -> IO (Either Errno CSize) -- ^ Bytes received into array -{-# inline uninterruptibleReceiveMutableByteArray #-} -uninterruptibleReceiveMutableByteArray !fd (MutableByteArray !b) !off !len !flags = - c_unsafe_mutable_byte_array_recv fd b off len flags >>= errorsFromSize - --- | Receive data into an address from an unconnected network socket. This --- uses the unsafe FFI. Users may specify an offset into the destination --- byte array. This function does not resize the buffer. -uninterruptibleReceiveFromMutableByteArray :: - Fd -- ^ Socket - -> MutableByteArray RealWorld -- ^ Destination byte array - -> Int -- ^ Destination offset - -> CSize -- ^ Maximum bytes to receive - -> MessageFlags 'Receive -- ^ Flags - -> CInt -- ^ Maximum socket address size - -> IO (Either Errno (CInt,SocketAddress,CSize)) - -- ^ Remote host, bytes received into array, bytes needed for @addrlen@. -{-# inline uninterruptibleReceiveFromMutableByteArray #-} --- GHC does not inline this unless we give it the pragma. We really --- want this to inline since inlining typically avoids the Left/Right --- data constructor allocation. -uninterruptibleReceiveFromMutableByteArray !fd (MutableByteArray !b) !off !len !flags !maxSz = do - -- TODO: We currently allocate one buffer for the size and - -- one for the peer. We could improve this by allocating - -- a single buffer instead. We would need to add some - -- cleverness in the cbits directory. - sockAddrBuf@(MutableByteArray sockAddrBuf#) <- PM.newByteArray (cintToInt maxSz) - lenBuf@(MutableByteArray lenBuf#) <- PM.newByteArray (PM.sizeOf (undefined :: CInt)) - PM.writeByteArray lenBuf 0 maxSz - r <- c_unsafe_mutable_byte_array_recvfrom fd b off len flags sockAddrBuf# lenBuf# - if r > (-1) - then do - (sz :: CInt) <- PM.readByteArray lenBuf 0 - if sz < maxSz - then shrinkMutableByteArray sockAddrBuf (cintToInt sz) - else pure () - sockAddr <- PM.unsafeFreezeByteArray sockAddrBuf - pure (Right (sz,SocketAddress sockAddr,cssizeToCSize r)) - else fmap Left getErrno - -uninterruptibleReceiveFromInternet :: - Fd -- ^ Socket - -> Addr -- ^ Destination byte array - -> CSize -- ^ Maximum bytes to receive - -> MessageFlags 'Receive -- ^ Flags - -> MutablePrimArrayOffset RealWorld SocketAddressInternet -- ^ Address - -> IO (Either Errno CSize) -- ^ Number of bytes received into array -{-# inline uninterruptibleReceiveFromInternet #-} -uninterruptibleReceiveFromInternet !fd - (Addr b) !len !flags - (MutablePrimArrayOffset (MutablePrimArray sockAddrBuf) addrOff) = - c_unsafe_recvfrom_inet_addr fd b len flags sockAddrBuf addrOff - >>= errorsFromSize - -uninterruptibleReceiveFromInternetMutableByteArray :: - Fd -- ^ Socket - -> MutableByteArrayOffset RealWorld -- ^ Destination byte array - -> CSize -- ^ Maximum bytes to receive - -> MessageFlags 'Receive -- ^ Flags - -> MutablePrimArrayOffset RealWorld SocketAddressInternet -- ^ Address - -> IO (Either Errno CSize) -- ^ Number of bytes received into array -{-# inline uninterruptibleReceiveFromInternetMutableByteArray #-} -uninterruptibleReceiveFromInternetMutableByteArray !fd - (MutableByteArrayOffset (MutableByteArray b) off) !len !flags - (MutablePrimArrayOffset (MutablePrimArray sockAddrBuf) addrOff) = - c_unsafe_recvfrom_inet fd b off len flags sockAddrBuf addrOff - >>= errorsFromSize - --- | Receive data into an address from a network socket. This uses the unsafe --- FFI. This does not return the socket address of the remote host that --- sent the packet received. -uninterruptibleReceiveFromMutableByteArray_ :: - Fd -- ^ Socket - -> MutableByteArray RealWorld -- ^ Destination byte array - -> Int -- ^ Destination offset - -> CSize -- ^ Maximum bytes to receive - -> MessageFlags 'Receive -- ^ Flags - -> IO (Either Errno CSize) -- ^ Number of bytes received into array -{-# inline uninterruptibleReceiveFromMutableByteArray_ #-} -uninterruptibleReceiveFromMutableByteArray_ !fd (MutableByteArray !b) !off !len !flags = - c_unsafe_mutable_byte_array_peerless_recvfrom fd b off len flags - >>= errorsFromSize - --- | Receive data into an address from a network socket. This uses the unsafe --- FFI. This does not return the socket address of the remote host that --- sent the packet received. -uninterruptibleReceiveFrom_ :: - Fd -- ^ Socket - -> Addr -- ^ Destination byte array - -> CSize -- ^ Maximum bytes to receive - -> MessageFlags 'Receive -- ^ Flags - -> IO (Either Errno CSize) -- ^ Number of bytes received into array -{-# inline uninterruptibleReceiveFrom_ #-} -uninterruptibleReceiveFrom_ !fd (Addr !b) !len !flags = - c_unsafe_addr_peerless_recvfrom fd b len flags - >>= errorsFromSize - -ptrToAddr :: Ptr Word8 -> Addr -ptrToAddr (Exts.Ptr a) = Addr a - --- | Shutdown a socket. This uses the unsafe FFI. -uninterruptibleShutdown :: - Fd - -> ShutdownType - -> IO (Either Errno ()) -uninterruptibleShutdown fd typ = - c_unsafe_shutdown fd typ >>= errorsFromInt_ - -errorsFromSize :: CSsize -> IO (Either Errno CSize) -errorsFromSize r = if r > (-1) - then pure (Right (cssizeToCSize r)) - else fmap Left getErrno - -errorsFromFd :: Fd -> IO (Either Errno Fd) -errorsFromFd r = if r > (-1) - then pure (Right r) - else fmap Left getErrno - --- Sometimes, functions that return an int use zero to indicate --- success and negative one to indicate failure without including --- additional information in the value. -errorsFromInt_ :: CInt -> IO (Either Errno ()) -errorsFromInt_ r = if r == 0 - then pure (Right ()) - else fmap Left getErrno - -intToCInt :: Int -> CInt -intToCInt = fromIntegral - -intToCSize :: Int -> CSize -intToCSize = fromIntegral - -cintToInt :: CInt -> Int -cintToInt = fromIntegral - -csizeToInt :: CSize -> Int -csizeToInt = fromIntegral - -cssizeToInt :: CSsize -> Int -cssizeToInt = fromIntegral - --- only call this when it is known that the argument is non-negative -cssizeToCSize :: CSsize -> CSize -cssizeToCSize = fromIntegral - -shrinkMutableByteArray :: MutableByteArray RealWorld -> Int -> IO () -shrinkMutableByteArray (MutableByteArray arr) (I# sz) = - PM.primitive_ (shrinkMutableByteArray# arr sz) - --- | Convert a 16-bit word from host to network byte order (e.g. @htons@). -hostToNetworkShort :: Word16 -> Word16 -hostToNetworkShort = case targetByteOrder of - BigEndian -> id - LittleEndian -> byteSwap16 - --- | Convert a 16-bit word from network to host byte order (e.g. @ntohs@). -networkToHostShort :: Word16 -> Word16 -networkToHostShort = case targetByteOrder of - BigEndian -> id - LittleEndian -> byteSwap16 - --- | Convert a 32-bit word from host to network byte order (e.g. @htonl@). -hostToNetworkLong :: Word32 -> Word32 -hostToNetworkLong = case targetByteOrder of - BigEndian -> id - LittleEndian -> byteSwap32 - --- | Convert a 32-bit word from network to host byte order (e.g. @ntohl@). -networkToHostLong :: Word32 -> Word32 -networkToHostLong = case targetByteOrder of - BigEndian -> id - LittleEndian -> byteSwap32 - -pokeMessageHeader :: Addr -> Addr -> CInt -> Addr -> CSize -> Addr -> CSize -> MessageFlags 'Receive -> IO () -pokeMessageHeader msgHdrAddr a b c d e f g = do - PST.pokeMessageHeaderName msgHdrAddr a - PST.pokeMessageHeaderNameLength msgHdrAddr b - PST.pokeMessageHeaderIOVector msgHdrAddr c - PST.pokeMessageHeaderIOVectorLength msgHdrAddr d - PST.pokeMessageHeaderControl msgHdrAddr e - 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 --- do that because they are pinned) go in the iov_base field. -initializeIOVectors :: - MutableUnliftedArray RealWorld (MutableByteArray RealWorld) -- buffers - -> Addr -- array of iovec - -> CSize -- chunk size - -> CSize -- chunk count - -> IO () -initializeIOVectors bufs iovecsAddr chunkSize chunkCount = - let go !ix !iovecAddr = if ix < csizeToInt chunkCount - then do - initializeIOVector bufs iovecAddr chunkSize ix - go (ix + 1) (plusAddr iovecAddr (cintToInt PST.sizeofIOVector)) - else pure () - in go 0 iovecsAddr - --- Initialize a single iovec. We write the pinned byte array into --- both the iov_base field and into an unlifted array. There is a --- copy of this function in Linux.Socket. -initializeIOVector :: - MutableUnliftedArray RealWorld (MutableByteArray RealWorld) - -> Addr - -> CSize - -> Int - -> IO () -initializeIOVector bufs iovecAddr chunkSize ix = do - buf <- PM.newPinnedByteArray (csizeToInt chunkSize) - PM.writeUnliftedArray bufs ix buf - let !(Exts.Ptr bufAddr#) = PM.mutableByteArrayContents buf - bufAddr = Addr bufAddr# - PST.pokeIOVectorBase iovecAddr bufAddr - PST.pokeIOVectorLength iovecAddr chunkSize - --- This is intended to be called on an array of iovec after recvmsg --- and before deepFreezeIOVectors. An adaptation of this function exists --- in Linux.Socket. -countAndShrinkIOVectors :: - Int -- Total number of supplied iovecs - -> Int -- Total amount of space used by receive - -> Int -- Amount of space per buffer (each buffer must have equal size) - -> MutableUnliftedArray RealWorld (MutableByteArray RealWorld) - -> IO Int -countAndShrinkIOVectors !n !totalUsedSz !maxBufSz !bufs = go 0 totalUsedSz where - -- This outer if (checking that the index is in bounds) should - -- not actually be necessary. I will remove once the test suite - -- bolsters my confidence. - go !ix !remainingBytes = if ix < n - then if remainingBytes >= maxBufSz - then go - (ix + 1) - (remainingBytes - maxBufSz) - else if remainingBytes == 0 - then pure ix - else do - buf <- PM.readUnliftedArray bufs ix - shrinkMutableByteArray buf remainingBytes - pure (ix + 1) - else pure ix - --- Freeze a slice of the mutable byte arrays inside the unlifted --- array. This copies makes a copy of the slice of the original --- array. A copy of this function exists in Linux.Socket. -deepFreezeIOVectors :: - Int -- How many iovecs actually had a non-zero number of bytes - -> MutableUnliftedArray RealWorld (MutableByteArray RealWorld) - -> IO (UnliftedArray ByteArray) -deepFreezeIOVectors n m = do - x <- PM.unsafeNewUnliftedArray n - let go !ix = if ix < n - then do - PM.writeUnliftedArray x ix =<< PM.unsafeFreezeByteArray =<< PM.readUnliftedArray m ix - go (ix + 1) - else PM.unsafeFreezeUnliftedArray x - go 0 - -touchMutableUnliftedArray :: MutableUnliftedArray RealWorld a -> IO () -touchMutableUnliftedArray (MutableUnliftedArray x) = touchMutableUnliftedArray# x - -touchUnliftedArray :: UnliftedArray a -> IO () -touchUnliftedArray (UnliftedArray x) = touchUnliftedArray# 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', () #) - -touchLifted :: a -> IO () -touchLifted x = IO $ \s -> case touch# x s of s' -> (# s', () #) - -{- $conversion -These functions are used to convert IPv4 addresses and ports between network -byte order and host byte order. They are essential when working with -'SocketAddressInternet'. To avoid getting in the way of GHC compile-time -optimizations, these functions are not actually implemented with FFI -calls to @htonl@ and friends. Rather, they are reimplemented in haskell. --} - - -{- $receiveMessage -The function @recvMsg@ presents us with a challenge. Since it uses a -data structure with many nested pointers, we have to use pinned byte -arrays for everything. There is also the difficulty of marshalling -haskell's unlifted array (array of arrays) type into what C's -array of @iovec@. There's the question of the array of @cmsghdr@s. -On top of all of this, we have to answer the question of whether -we want to accept mutable buffer or whether we want to do the -allocations internally (both for the buffers and for the ancilliary -data structurs needed to massage the data into what C expects). - -What we do to handle this in offer several variants of @recvmsg@ -ending in @A@, @B@, etc. --} - -isByteArrayPinned :: ByteArray -> Bool -{-# inline isByteArrayPinned #-} -isByteArrayPinned (ByteArray arr#) = - Exts.isTrue# (Exts.isByteArrayPinned# arr#) - -isMutableByteArrayPinned :: MutableByteArray s -> Bool -{-# inline isMutableByteArrayPinned #-} -isMutableByteArrayPinned (MutableByteArray marr#) = - Exts.isTrue# (Exts.isMutableByteArrayPinned# marr#) - -unMba :: MutableByteArray s -> MutableByteArray# s -{-# inline unMba #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GADTSyntax #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnliftedFFITypes #-} + +{- | Types and functions related to the POSIX sockets API. + Unusual characteristics: + + * Any time the standard calls for @socklen_t@, we use + @CInt@ instead. Linus Torvalds + that \"Any sane library must have @socklen_t@ be the same size as @int@. + Anything else breaks any BSD socket layer stuff.\" + * Send and receive each have several variants. They are distinguished by + the safe\/unsafe FFI use and by the @Addr@\/@ByteArray@/@MutableByteArray@ + buffer type. They all call @send@ or @recv@ exactly once. They do not + repeatedly make syscalls like some of the functions in @network@. + Users who want that behavior need to build on top of this package. + * There are no requirements on the pinnedness of @ByteArray@ arguments + passed to any of these functions. If wrappers of the safe FFI are + passed unpinned @ByteArray@ arguments, they will copy the contents + into pinned memory before invoking the foreign function. +-} +module Posix.Socket + ( -- * Functions + + -- ** Socket + uninterruptibleSocket + , socket + , withSocket + + -- ** Socket Pair + , uninterruptibleSocketPair + + -- ** Address Resolution + , getAddressInfo + , uninterruptibleFreeAddressInfo + + -- ** Bind + , uninterruptibleBind + + -- ** Connect + , connect + , uninterruptibleConnect + , uninterruptibleConnectPtr + + -- ** Listen + , uninterruptibleListen + + -- ** Accept + , accept + , uninterruptibleAccept + , accept_ + + -- ** Get Socket Name + , uninterruptibleGetSocketName + + -- ** Get Socket Option + , uninterruptibleGetSocketOption + + -- ** Set Socket Option + , uninterruptibleSetSocketOption + , uninterruptibleSetSocketOptionByteArray + , uninterruptibleSetSocketOptionInt + + -- ** Close + , F.close + , F.uninterruptibleClose + , F.uninterruptibleErrorlessClose + + -- ** Shutdown + , uninterruptibleShutdown + + -- ** Send + , send + , sendByteArray + , sendMutableByteArray + , uninterruptibleSend + , uninterruptibleSendByteArray + , uninterruptibleSendMutableByteArray + + -- ** Send To + , uninterruptibleSendToByteArray + , uninterruptibleSendToMutableByteArray + , uninterruptibleSendToInternet + , uninterruptibleSendToInternetByteArray + , uninterruptibleSendToInternetMutableByteArray + + -- ** Write Vector + + -- ** Receive + , receive + , receiveByteArray + , uninterruptibleReceive + , uninterruptibleReceiveMutableByteArray + + -- ** Receive From + , uninterruptibleReceiveFromMutableByteArray + , uninterruptibleReceiveFromMutableByteArray_ + , uninterruptibleReceiveFrom_ + , uninterruptibleReceiveFromInternet + , uninterruptibleReceiveFromInternetMutableByteArray + + -- ** Receive Message + -- $receiveMessage + , uninterruptibleSendMessageA + , uninterruptibleSendMessageB + + -- ** Byte-Order Conversion + -- $conversion + , hostToNetworkLong + , hostToNetworkShort + , networkToHostLong + , networkToHostShort + + -- * Types + , Family (..) + , Type (..) + , Protocol (..) + , OptionName (..) + , OptionValue (..) + , Level (..) + , Message (..) + , MessageFlags (..) + , ShutdownType (..) + , AddressInfo + + -- * Socket Address + + -- ** Types + , SocketAddress (..) + , PST.SocketAddressInternet (..) + , PST.SocketAddressUnix (..) + + -- ** Encoding + , PSP.encodeSocketAddressInternet + , PSP.encodeSocketAddressUnix + + -- ** Decoding + , PSP.decodeSocketAddressInternet + , PSP.indexSocketAddressInternet + + -- ** Sizes + , PSP.sizeofSocketAddressInternet + + -- * Data Construction + + -- ** Socket Domains + , pattern PST.Unix + , pattern PST.Unspecified + , pattern PST.Internet + , pattern PST.Internet6 + + -- ** Socket Types + , PST.stream + , PST.datagram + , PST.raw + , PST.sequencedPacket + + -- ** Protocols + , PST.defaultProtocol + , PST.rawProtocol + , PST.icmp + , PST.tcp + , PST.udp + , PST.ip + , PST.ipv6 + + -- ** Receive Flags + , PST.peek + , PST.outOfBand + , PST.waitAll + + -- ** Send Flags + , PST.noSignal + + -- ** Shutdown Types + , PST.read + , PST.write + , PST.readWrite + + -- ** Socket Levels + , PST.levelSocket + + -- ** Option Names + , PST.optionError + , PST.bindToDevice + , PST.broadcast + , PST.reuseAddress + + -- ** Address Info + + -- *** Peek + , PST.peekAddressInfoFlags + + -- *** Poke + , PST.pokeAddressInfoFlags + + -- *** Metadata + , PST.sizeofAddressInfo + + -- ** Message Header + + -- *** Peek + , PST.peekMessageHeaderName + , PST.peekMessageHeaderNameLength + , PST.peekMessageHeaderIOVector + , PST.peekMessageHeaderIOVectorLength + , PST.peekMessageHeaderControl + , PST.peekMessageHeaderControlLength + , PST.peekMessageHeaderFlags + , PST.peekControlMessageHeaderLevel + , PST.peekControlMessageHeaderLength + , PST.peekControlMessageHeaderType + + -- *** Poke + , PST.pokeMessageHeaderName + , PST.pokeMessageHeaderNameLength + , PST.pokeMessageHeaderIOVector + , PST.pokeMessageHeaderIOVectorLength + , PST.pokeMessageHeaderControl + , PST.pokeMessageHeaderControlLength + , PST.pokeMessageHeaderFlags + + -- *** Metadata + , PST.sizeofMessageHeader + + -- ** IO Vector + + -- *** Peek + , PST.peekIOVectorBase + , PST.peekIOVectorLength + + -- *** Poke + , PST.pokeIOVectorBase + , PST.pokeIOVectorLength + + -- *** Metadata + , PST.sizeofIOVector + ) where + +import Control.Exception (mask, onException) +import Data.Primitive (ByteArray (..), MutableByteArray (..), MutablePrimArray (..)) +import Data.Primitive.Addr (Addr (..)) +import Data.Primitive.ByteArray.Offset (MutableByteArrayOffset (..)) +import Data.Primitive.PrimArray.Offset (MutablePrimArrayOffset (..)) +import Data.Void (Void) +import Data.Word (Word16, Word32, Word8, byteSwap16, byteSwap32) +import Foreign.C.Error (Errno (Errno), getErrno) +import Foreign.C.String (CString) +import Foreign.C.Types (CInt (..), CSize (..)) +import Foreign.Ptr (nullPtr) +import GHC.ByteOrder (ByteOrder (BigEndian, LittleEndian), targetByteOrder) +import GHC.Exts (Addr#, ByteArray#, Int (I#), MutableByteArray#, Ptr (Ptr), RealWorld, shrinkMutableByteArray#) +import Posix.Socket.Types + ( AddressInfo + , Family (..) + , Level (..) + , Message (..) + , MessageFlags (..) + , OptionName (..) + , OptionValue (..) + , Protocol (..) + , ShutdownType (..) + , SocketAddress (..) + , SocketAddressInternet (..) + , Type (..) + ) +import System.Posix.Types (CSsize (..), Fd (..)) + +import qualified Control.Monad.Primitive as PM +import qualified Data.Primitive as PM +import qualified GHC.Exts as Exts +import qualified Posix.File as F +import qualified Posix.Socket.Types as PST + +-- This module include operating-system specific code used +-- to serialize some of various kind of socket address types. +import qualified Posix.Socket.Platform as PSP + +-- getaddrinfo cannot use the unsafe ffi +foreign import ccall safe "sys/socket.h getaddrinfo" + c_safe_getaddrinfo :: + CString -> + CString -> + Ptr AddressInfo -> + MutableByteArray# RealWorld -> -- actually a `Ptr (Ptr AddressInfo))`. + IO Errno + +-- | Free the @addrinfo@ at the pointer. +foreign import ccall safe "sys/socket.h freeaddrinfo" + uninterruptibleFreeAddressInfo :: Ptr AddressInfo -> IO () + +foreign import ccall unsafe "sys/socket.h socket" + c_socket :: Family -> Type -> Protocol -> IO Fd + +foreign import ccall unsafe "sys/socket.h socketpair" + c_socketpair :: Family -> Type -> Protocol -> MutableByteArray# RealWorld -> IO CInt + +foreign import ccall unsafe "sys/socket.h listen" + c_listen :: Fd -> CInt -> IO CInt + +foreign import ccall unsafe "unistd.h shutdown" + c_unsafe_shutdown :: Fd -> ShutdownType -> IO CInt + +-- Per the spec, the type signature of bind is: +-- int bind(int socket, const struct sockaddr *address, socklen_t address_len); +-- However, here we choose to represent the third argument as +-- CInt rather than introducing a type corresponding to socklen_t. +-- According to Linus Torvalds, "Any sane library must have socklen_t +-- be the same size as int. Anything else breaks any BSD socket layer stuff." +-- (https://yarchive.net/comp/linux/socklen_t.html). If a platform +-- violates this assumption, this wrapper will be broken on that platform. +foreign import ccall unsafe "sys/socket.h bind" + c_bind :: Fd -> ByteArray# -> CInt -> IO CInt + +-- Per the spec, the type signature of accept is: +-- int accept(int socket, struct sockaddr *restrict address, socklen_t *restrict address_len); +-- The restrict keyword does not matter much for our purposes. See the +-- note on c_bind for why we use CInt for socklen_t. Remember that the +-- first bytearray argument is actually SocketAddress in the function that +-- wraps this one. The second bytearray argument is a pointer to the size. +foreign import ccall safe "sys/socket.h accept" + c_safe_accept :: + Fd -> + MutableByteArray# RealWorld -> -- SocketAddress + MutableByteArray# RealWorld -> -- Ptr CInt + IO Fd +foreign import ccall unsafe "sys/socket.h accept" + c_unsafe_accept :: + Fd -> + MutableByteArray# RealWorld -> -- SocketAddress + MutableByteArray# RealWorld -> -- Ptr CInt + IO Fd + +-- This variant of accept is used when we do not care about the +-- remote sockaddr. We pass null. +foreign import ccall safe "sys/socket.h accept" + c_safe_ptr_accept :: Fd -> Ptr Void -> Ptr CInt -> IO Fd + +foreign import ccall unsafe "sys/socket.h getsockname" + c_unsafe_getsockname :: + Fd -> + MutableByteArray# RealWorld -> -- SocketAddress + MutableByteArray# RealWorld -> -- Addr length (Ptr CInt) + IO CInt + +foreign import ccall unsafe "sys/socket.h getsockopt" + c_unsafe_getsockopt :: + Fd -> + Level -> + OptionName -> + MutableByteArray# RealWorld -> -- Option value + MutableByteArray# RealWorld -> -- Option len (Ptr CInt) + IO CInt + +foreign import ccall unsafe "sys/socket.h setsockopt_int" + c_unsafe_setsockopt_int :: + Fd -> + Level -> + OptionName -> + CInt -> -- option_value + IO CInt + +foreign import ccall unsafe "sys/socket.h setsockopt" + c_unsafe_setsockopt :: + Fd -> + Level -> + OptionName -> + Ptr Void -> -- option_val + CInt -> -- option_len + IO CInt + +foreign import ccall unsafe "sys/socket.h setsockopt" + c_unsafe_setsockopt_ba :: + Fd -> + Level -> + OptionName -> + ByteArray# -> -- option_val + CInt -> -- option_len + IO CInt + +-- Per the spec the type signature of connect is: +-- int connect(int sockfd, const struct sockaddr *addr, socklen_t addrlen); +-- The bytearray argument is actually SocketAddress. +foreign import ccall safe "sys/socket.h connect" + c_safe_connect :: Fd -> ByteArray# -> CInt -> IO CInt +foreign import ccall safe "sys/socket.h connect" + 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 +-- have the option of writing to either an address or a byte array. +-- Unsafe FFI calls guarantee that byte arrays will not be relocated +-- while the FFI call is taking place. Safe FFI calls do not have +-- this guarantee, so internally we must be careful when using these to only +-- provide pinned byte arrays as arguments. +foreign import ccall safe "sys/socket.h send" + c_safe_addr_send :: Fd -> Addr# -> CSize -> MessageFlags 'Send -> IO CSsize +foreign import ccall safe "sys/socket.h send_offset" + c_safe_bytearray_send :: Fd -> ByteArray# -> Int -> CSize -> MessageFlags 'Send -> IO CSsize +foreign import ccall safe "sys/socket.h send_offset" + c_safe_mutablebytearray_send :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> MessageFlags 'Send -> IO CSsize +foreign import ccall safe "sys/socket.h send" + c_safe_mutablebytearray_no_offset_send :: Fd -> MutableByteArray# RealWorld -> CSize -> MessageFlags 'Send -> IO CSsize +foreign import ccall unsafe "sys/socket.h send" + c_unsafe_addr_send :: Fd -> Addr# -> CSize -> MessageFlags 'Send -> IO CSsize +foreign import ccall unsafe "sys/socket.h send_offset" + c_unsafe_bytearray_send :: Fd -> ByteArray# -> Int -> CSize -> MessageFlags 'Send -> IO CSsize +foreign import ccall unsafe "sys/socket.h send_offset" + c_unsafe_mutable_bytearray_send :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> MessageFlags 'Send -> IO CSsize + +-- The ByteArray# (second to last argument) is a SocketAddress. +foreign import ccall unsafe "sys/socket.h sendto_offset" + c_unsafe_bytearray_sendto :: Fd -> ByteArray# -> Int -> CSize -> MessageFlags 'Send -> ByteArray# -> CInt -> IO CSsize + +-- The ByteArray# (second to last argument) is a SocketAddress. +foreign import ccall unsafe "sys/socket.h sendto_offset" + c_unsafe_mutable_bytearray_sendto :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> MessageFlags 'Send -> ByteArray# -> CInt -> IO CSsize +foreign import ccall unsafe "sys/socket.h sendto_inet_offset" + c_unsafe_mutable_bytearray_sendto_inet :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> MessageFlags 'Send -> Word16 -> Word32 -> IO CSsize +foreign import ccall unsafe "HaskellPosix.h sendto_inet_offset" + c_unsafe_bytearray_sendto_inet :: Fd -> ByteArray# -> Int -> CSize -> MessageFlags 'Send -> Word16 -> Word32 -> IO CSsize +foreign import ccall unsafe "HaskellPosix.h sendto_inet_addr" + c_unsafe_addr_sendto_inet :: Fd -> Addr# -> CSize -> MessageFlags 'Send -> Word16 -> Word32 -> IO CSsize + +foreign import ccall unsafe "HaskellPosix.h sendmsg_a" + c_unsafe_sendmsg_a :: Fd -> Addr# -> CSize -> MutableByteArray# RealWorld -> Int -> CSize -> MessageFlags 'Send -> IO CSsize + +foreign import ccall unsafe "HaskellPosix.h sendmsg_b" + c_unsafe_sendmsg_b :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> Addr# -> CSize -> MessageFlags 'Send -> IO CSsize + +-- There are several ways to wrap recv. +foreign import ccall safe "sys/socket.h recv" + c_safe_addr_recv :: Fd -> Addr# -> CSize -> MessageFlags 'Receive -> IO CSsize +foreign import ccall unsafe "sys/socket.h recv" + c_unsafe_addr_recv :: Fd -> Addr# -> CSize -> MessageFlags 'Receive -> IO CSsize +foreign import ccall unsafe "sys/socket.h recv_offset" + c_unsafe_mutable_byte_array_recv :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> MessageFlags 'Receive -> IO CSsize + +-- The last two arguments are SocketAddress and Ptr CInt. +foreign import ccall unsafe "sys/socket.h recvfrom_offset" + c_unsafe_mutable_byte_array_recvfrom :: Fd -> MutableByteArray# RealWorld -> Int -> CSize -> MessageFlags 'Receive -> MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> IO CSsize +foreign import ccall unsafe "sys/socket.h recvfrom_offset_peerless" + c_unsafe_mutable_byte_array_peerless_recvfrom :: + Fd -> + MutableByteArray# RealWorld -> + Int -> + CSize -> + MessageFlags 'Receive -> + IO CSsize +foreign import ccall unsafe "sys/socket.h recvfrom_addr_peerless" + c_unsafe_addr_peerless_recvfrom :: + Fd -> Addr# -> CSize -> MessageFlags 'Receive -> IO CSsize +foreign import ccall unsafe "sys/socket.h recvfrom_offset_inet" + c_unsafe_recvfrom_inet :: + Fd -> + MutableByteArray# RealWorld -> + Int -> + CSize -> + MessageFlags 'Receive -> + MutableByteArray# RealWorld -> + Int -> + IO CSsize +foreign import ccall unsafe "sys/socket.h recvfrom_offset_inet_addr" + c_unsafe_recvfrom_inet_addr :: + Fd -> + Addr# -> + CSize -> + MessageFlags 'Receive -> + MutableByteArray# RealWorld -> + Int -> + IO CSsize + +{- | Create an endpoint for communication, returning a file + descriptor that refers to that endpoint. The + + includes more details. No special preparation is required before calling + this function. The author believes that it cannot block for a prolonged + period of time. +-} +uninterruptibleSocket :: + -- | Communications domain (e.g. 'internet', 'unix') + Family -> + -- | Socket type (e.g. 'datagram', 'stream') with flags + Type -> + -- | Protocol + Protocol -> + IO (Either Errno Fd) +uninterruptibleSocket dom typ prot = c_socket dom typ prot >>= errorsFromFd + +-- | Alias for 'uninterruptibleSocket'. +socket :: + -- | Communications domain (e.g. 'internet', 'unix') + Family -> + -- | Socket type (e.g. 'datagram', 'stream') with flags + Type -> + -- | Protocol + Protocol -> + IO (Either Errno Fd) +socket = uninterruptibleSocket + +{- | Helper function for the common case where 'socket' or +'uninterruptibleSocket' is paired with 'close'. This ensures that the +socket is closed even in the case of an exception. Do not call 'close' in +the callback since 'close' is called by this function after the callback +completes (or after an exception is thrown). + +This is implementated with @mask@ (and restore) and @onException@ +directly rather than with @bracket@. +-} +withSocket :: + -- | Communications domain (e.g. 'internet', 'unix') + Family -> + -- | Socket type (e.g. 'datagram', 'stream') with flags + Type -> + -- | Protocol + Protocol -> + -- | Callback that uses the socket. Must not close the socket. + -- The callback is not used when the @socket()@ call fails. + (Fd -> IO a) -> + IO (Either Errno a) +{-# INLINE withSocket #-} +withSocket !dom !typ !prot cb = + mask $ \restore -> do + r <- c_socket dom typ prot + if r > (-1) + then do + a <- restore (cb r) `onException` F.close r + _ <- F.close r + pure (Right a) + else fmap Left getErrno + +{- | Create an unbound pair of connected sockets in a specified domain, of + a specified type, under the protocol optionally specified by the protocol + argument. The + includes more details. No special preparation is required before calling + this function. The author believes that it cannot block for a prolonged + period of time. +-} +uninterruptibleSocketPair :: + -- | Communications domain (probably 'unix') + Family -> + -- | Socket type (e.g. 'datagram', 'stream') with flags + Type -> + -- | Protocol + Protocol -> + IO (Either Errno (Fd, Fd)) +uninterruptibleSocketPair dom typ prot = do + -- If this ever switches to the safe FFI, we will need to use + -- a pinned array here instead. + (sockets@(MutablePrimArray sockets#) :: MutablePrimArray RealWorld Fd) <- PM.newPrimArray 2 + r <- c_socketpair dom typ prot sockets# + if r == 0 + then do + fd1 <- PM.readPrimArray sockets 0 + fd2 <- PM.readPrimArray sockets 1 + pure (Right (fd1, fd2)) + else fmap Left getErrno + +{- | Given node and service, which identify an Internet host and a service, +@getaddrinfo()@ returns one or more @addrinfo@ structures. The type of this +wrapper differs slightly from the type of its C counterpart. Remember to call +'uninterruptibleFreeAddressInfo' when finished with the result. +-} +getAddressInfo :: + -- | Node, identifies an Internet host + CString -> + -- | Service + CString -> + -- | Hints + Ptr AddressInfo -> + IO (Either Errno (Ptr AddressInfo)) +getAddressInfo !node !service !hints = do + resBuf@(MutableByteArray resBuf#) <- PM.newPinnedByteArray (PM.sizeOf (undefined :: Ptr ())) + c_safe_getaddrinfo node service hints resBuf# >>= \case + Errno 0 -> do + res <- PM.readByteArray resBuf 0 + pure (Right res) + e -> pure (Left e) + +{- | Assign a local socket address address to a socket identified by + descriptor socket that has no local socket address assigned. The + + includes more details. The 'SocketAddress' represents the @sockaddr@ pointer argument, together + with its @socklen_t@ size, as a byte array. This allows @bind@ to + be used with @sockaddr@ extensions on various platforms. No special + preparation is required before calling this function. The author + believes that it cannot block for a prolonged period of time. +-} +uninterruptibleBind :: + -- | Socket + Fd -> + -- | Socket address, extensible tagged union + SocketAddress -> + IO (Either Errno ()) +uninterruptibleBind fd (SocketAddress b@(ByteArray b#)) = + c_bind fd b# (intToCInt (PM.sizeofByteArray b)) >>= errorsFromInt_ + +{- | Mark the socket as a passive socket, that is, as a socket that + will be used to accept incoming connection requests using @accept@. + The + includes more details. No special preparation is required before + calling this function. The author believes that it cannot block + for a prolonged period of time. +-} +uninterruptibleListen :: + -- | Socket + Fd -> + -- | Backlog + CInt -> + IO (Either Errno ()) +uninterruptibleListen fd backlog = c_listen fd backlog >>= errorsFromInt_ + +{- | Connect the socket to the specified socket address. + The + includes more details. +-} +connect :: + -- | Fd + Fd -> + -- | Socket address, extensible tagged union + SocketAddress -> + IO (Either Errno ()) +connect fd (SocketAddress sockAddr@(ByteArray sockAddr#)) = + case isByteArrayPinned sockAddr of + True -> c_safe_connect fd sockAddr# (intToCInt (PM.sizeofByteArray sockAddr)) >>= errorsFromInt_ + False -> do + let len = PM.sizeofByteArray sockAddr + x@(MutableByteArray x#) <- PM.newPinnedByteArray len + PM.copyByteArray x 0 sockAddr 0 len + c_safe_mutablebytearray_connect fd x# (intToCInt len) >>= errorsFromInt_ + +{- | Connect the socket to the specified socket address. + The + includes more details. The only sensible way to use this is to + give a nonblocking socket as the argument. +-} +uninterruptibleConnect :: + -- | Fd + Fd -> + -- | Socket address, extensible tagged union + SocketAddress -> + IO (Either Errno ()) +uninterruptibleConnect fd (SocketAddress sockAddr@(ByteArray sockAddr#)) = + c_unsafe_connect fd sockAddr# (intToCInt (PM.sizeofByteArray sockAddr)) >>= errorsFromInt_ + +uninterruptibleConnectPtr :: + -- | Fd + Fd -> + -- | Socket address + Ptr a -> + -- | Size of socket address + Int -> + 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 + the specification: + + > int accept(int socket, struct sockaddr *restrict address, socklen_t *restrict address_len); + + Instead of requiring the caller to prepare buffers through which + information is returned, this haskell binding to @accept@ prepares + those buffers internally. This eschews C\'s characteristic buffer-passing + in favor of the Haskell convention of allocating internally and returning. + + More specifically, this binding lacks an argument corresponding to the + @sockaddr@ buffer from the specification. That mutable buffer is allocated + internally, resized and frozen upon a success, and returned along with + the file descriptor of the accepted socket. The size of this buffer is + determined by the second argument (maximum socket address size). This + size argument is also writen to the @address_len@ buffer, which is also + allocated internally. The size returned through this pointer is used to + resize the @sockaddr@ buffer, which is then frozen so that an immutable + 'SocketAddress' is returned to the end user. + + For applications uninterested in the peer (described by @sockaddr@), + POSIX @accept@ allows the null pointer to be passed as both @address@ and + @address_len@. This behavior is provided by 'accept_'. +-} +accept :: + -- | Listening socket + Fd -> + -- | Maximum socket address size + CInt -> + -- | Peer information and connected socket + IO (Either Errno (CInt, SocketAddress, Fd)) +accept !sock !maxSz = do + sockAddrBuf@(MutableByteArray sockAddrBuf#) <- PM.newPinnedByteArray (cintToInt maxSz) + lenBuf@(MutableByteArray lenBuf#) <- PM.newPinnedByteArray (PM.sizeOf (undefined :: CInt)) + PM.writeByteArray lenBuf 0 maxSz + r <- c_safe_accept sock sockAddrBuf# lenBuf# + if r > (-1) + then do + (sz :: CInt) <- PM.readByteArray lenBuf 0 + -- Why copy when we could just shrink? We want to always return + -- byte arrays that are not explicitly pinned. + let minSz = min sz maxSz + x <- PM.newByteArray (cintToInt minSz) + PM.copyMutableByteArray x 0 sockAddrBuf 0 (cintToInt minSz) + sockAddr <- PM.unsafeFreezeByteArray x + pure (Right (sz, SocketAddress sockAddr, r)) + else fmap Left getErrno + +{- | See 'accept'. This uses the unsafe FFI. Consequently, it does not + not need to allocate pinned memory. It only makes sense to call this + on a nonblocking socket. +-} +uninterruptibleAccept :: + -- | Listening socket + Fd -> + -- | Maximum socket address size + CInt -> + -- | Peer information and connected socket + IO (Either Errno (CInt, SocketAddress, Fd)) +uninterruptibleAccept !sock !maxSz = do + sockAddrBuf@(MutableByteArray sockAddrBuf#) <- PM.newByteArray (cintToInt maxSz) + lenBuf@(MutableByteArray lenBuf#) <- PM.newByteArray (PM.sizeOf (undefined :: CInt)) + PM.writeByteArray lenBuf 0 maxSz + r <- c_unsafe_accept sock sockAddrBuf# lenBuf# + if r > (-1) + then do + (sz :: CInt) <- PM.readByteArray lenBuf 0 + if sz < maxSz + then shrinkMutableByteArray sockAddrBuf (cintToInt sz) + else pure () + sockAddr <- PM.unsafeFreezeByteArray sockAddrBuf + pure (Right (sz, SocketAddress sockAddr, r)) + else fmap Left getErrno + +{- | A variant of 'accept' that does not provide the user with a + 'SocketAddress' detailing the peer. +-} +accept_ :: + -- | Listening socket + Fd -> + -- | Connected socket + IO (Either Errno Fd) +accept_ sock = + c_safe_ptr_accept sock nullPtr nullPtr >>= errorsFromFd + +{- | Retrieve the locally-bound name of the specified socket. The + + of @getsockname@ includes more details. +-} +uninterruptibleGetSocketName :: + -- | Socket + Fd -> + -- | Maximum socket address size + CInt -> + IO (Either Errno (CInt, SocketAddress)) +uninterruptibleGetSocketName sock maxSz = do + sockAddrBuf@(MutableByteArray sockAddrBuf#) <- PM.newByteArray (cintToInt maxSz) + lenBuf@(MutableByteArray lenBuf#) <- PM.newByteArray (PM.sizeOf (undefined :: CInt)) + PM.writeByteArray lenBuf 0 maxSz + r <- c_unsafe_getsockname sock sockAddrBuf# lenBuf# + if r == 0 + then do + (sz :: CInt) <- PM.readByteArray lenBuf 0 + if sz < maxSz + then shrinkMutableByteArray sockAddrBuf (cintToInt sz) + else pure () + sockAddr <- PM.unsafeFreezeByteArray sockAddrBuf + pure (Right (sz, SocketAddress sockAddr)) + else fmap Left getErrno + +{- | Retrieve the value for the option specified by the 'Option' argument for + the socket specified by the 'Fd' argument. The + + of @getsockopt@ includes more details. +-} +uninterruptibleGetSocketOption :: + -- | Socket + Fd -> + -- | Socket level + Level -> + OptionName -> -- Option name + + -- | Maximum option value size + CInt -> + IO (Either Errno (CInt, OptionValue)) +uninterruptibleGetSocketOption sock level optName maxSz = do + valueBuf@(MutableByteArray valueBuf#) <- PM.newByteArray (cintToInt maxSz) + lenBuf@(MutableByteArray lenBuf#) <- PM.newByteArray (PM.sizeOf (undefined :: CInt)) + PM.writeByteArray lenBuf 0 maxSz + r <- c_unsafe_getsockopt sock level optName valueBuf# lenBuf# + if r == 0 + then do + (sz :: CInt) <- PM.readByteArray lenBuf 0 + if sz < maxSz + then shrinkMutableByteArray valueBuf (cintToInt sz) + else pure () + value <- PM.unsafeFreezeByteArray valueBuf + pure (Right (sz, OptionValue value)) + else fmap Left getErrno + +{- | Set the value for the option specified by the 'Option' argument for + the socket specified by the 'Fd' argument. The + + of @getsockopt@ includes more details. This variant requires that the + size of the @option_value@ + be the same as the size of 'CInt'. That is, the @option_name@ must + describe an option that is represented by a C integer. This is a + common case, so we avoid allocations by reference-passing in C. +-} +uninterruptibleSetSocketOptionInt :: + -- | Socket + Fd -> + -- | Socket level + Level -> + -- | Option name + OptionName -> + -- | Option value + CInt -> + IO (Either Errno ()) +uninterruptibleSetSocketOptionInt sock level optName optValue = + c_unsafe_setsockopt_int sock level optName optValue >>= errorsFromInt_ + +{- | Set the value for the option specified by the 'Option' argument for + the socket specified by the 'Fd' argument. The + + of @getsockopt@ includes more details. +-} +uninterruptibleSetSocketOption :: + -- | Socket + Fd -> + -- | Socket level + Level -> + -- | Option name + OptionName -> + -- | Option value + Ptr Void -> + -- | Option value length + CInt -> + IO (Either Errno ()) +uninterruptibleSetSocketOption sock level optName optValue optLen = + c_unsafe_setsockopt sock level optName optValue optLen >>= errorsFromInt_ + +{- | Variant of 'uninterruptibleSetSocketOption' that accepts the option + as a byte array instead of a pointer into unmanaged memory. The argument + does not need to be pinned. +-} +uninterruptibleSetSocketOptionByteArray :: + -- | Socket + Fd -> + -- | Socket level + Level -> + -- | Option name + OptionName -> + -- | Option value + ByteArray -> + -- | Option value length + CInt -> + IO (Either Errno ()) +uninterruptibleSetSocketOptionByteArray sock level optName (ByteArray optVal) optLen = + c_unsafe_setsockopt_ba sock level optName optVal optLen >>= errorsFromInt_ + +{- | Send data from a 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 + FFI, it allocates a pinned copy of the bytearry if it was not + already pinned. +-} +sendByteArray :: + -- | Socket + Fd -> + -- | Source byte array + ByteArray -> + -- | Offset into source array + Int -> + -- | Length in bytes + CSize -> + -- | Flags + MessageFlags 'Send -> + -- | Number of bytes pushed to send buffer + IO (Either Errno CSize) +sendByteArray fd b@(ByteArray b#) off len flags = + if isByteArrayPinned b + then errorsFromSize =<< c_safe_bytearray_send fd b# off len flags + else do + x@(MutableByteArray x#) <- PM.newPinnedByteArray (csizeToInt len) + PM.copyByteArray x off b 0 (csizeToInt len) + errorsFromSize =<< c_safe_mutablebytearray_no_offset_send fd x# len flags + +{- | Copy and pin a byte array if, it's not already pinned. +pinByteArray :: ByteArray -> IO (Maybe ByteArray) +{\-# INLINE pinByteArray #-\} +pinByteArray byteArray = + if isByteArrayPinned byteArray + then + pure Nothing + else do + pinnedByteArray <- PM.newPinnedByteArray len + PM.copyByteArray pinnedByteArray 0 byteArray 0 len + r <- PM.unsafeFreezeByteArray pinnedByteArray + pure (Just r) + where + len = PM.sizeofByteArray byteArray +-} + +{- | Send two payloads (one from unmanaged memory and one from +managed memory) over a network socket. +-} +uninterruptibleSendMessageA :: + -- | Socket + Fd -> + -- | Source address (payload A) + Addr -> + -- | Length in bytes (payload A) + CSize -> + -- | Source and offset (payload B) + MutableByteArrayOffset RealWorld -> + -- | Length in bytes (payload B) + CSize -> + -- | Flags + MessageFlags 'Send -> + -- | Number of bytes pushed to send buffer + IO (Either Errno CSize) +uninterruptibleSendMessageA + fd + (Addr addr) + lenA + (MutableByteArrayOffset {array, offset}) + lenB + flags = + c_unsafe_sendmsg_a fd addr lenA (unMba array) offset lenB flags + >>= errorsFromSize + +{- | Send two payloads (one from managed memory and one from +unmanaged memory) over a network socket. +-} +uninterruptibleSendMessageB :: + -- | Socket + Fd -> + -- | Source and offset (payload B) + MutableByteArrayOffset RealWorld -> + -- | Length in bytes (payload B) + CSize -> + -- | Source address (payload A) + Addr -> + -- | Length in bytes (payload A) + CSize -> + -- | Flags + MessageFlags 'Send -> + -- | Number of bytes pushed to send buffer + IO (Either Errno CSize) +uninterruptibleSendMessageB + fd + (MutableByteArrayOffset {array, offset}) + lenB + (Addr addr) + lenA + flags = + c_unsafe_sendmsg_b fd (unMba array) offset lenB addr lenA 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 + FFI, it allocates a pinned copy of the bytearry if it was not + already pinned. +-} +sendMutableByteArray :: + -- | Socket + Fd -> + -- | Source byte array + MutableByteArray RealWorld -> + -- | Offset into source array + Int -> + -- | Length in bytes + CSize -> + -- | Flags + MessageFlags 'Send -> + -- | Number of bytes pushed to send buffer + IO (Either Errno CSize) +sendMutableByteArray fd b@(MutableByteArray b#) off len flags = + if isMutableByteArrayPinned b + then errorsFromSize =<< c_safe_mutablebytearray_send fd b# off len flags + else do + x@(MutableByteArray x#) <- PM.newPinnedByteArray (csizeToInt len) + PM.copyMutableByteArray x off b 0 (csizeToInt len) + errorsFromSize =<< c_safe_mutablebytearray_no_offset_send fd x# len flags + +{- | Send data from an address over a network socket. This is not guaranteed + to send the entire length. This uses the safe FFI since + it may block indefinitely. +-} +send :: + -- | Connected socket + Fd -> + -- | Source address + Addr -> + -- | Length in bytes + CSize -> + -- | Flags + MessageFlags 'Send -> + -- | Number of bytes pushed to send buffer + IO (Either Errno CSize) +send fd (Addr addr) len flags = + c_safe_addr_send fd addr len flags >>= errorsFromSize + +{- | Send data from an address over a network socket. This uses the unsafe FFI. + Users of this function should be sure to set flags that prohibit this + from blocking. On Linux this is accomplished with @O_NONBLOCK@. It is + often desirable to call 'threadWaitWrite' on a nonblocking socket before + calling @unsafeSend@ on it. +-} +uninterruptibleSend :: + -- | Socket + Fd -> + -- | Source address + Addr -> + -- | Length in bytes + CSize -> + -- | Flags + MessageFlags 'Send -> + -- | Number of bytes pushed to send buffer + IO (Either Errno CSize) +uninterruptibleSend fd (Addr addr) len flags = + c_unsafe_addr_send fd addr len flags >>= errorsFromSize + +{- | Send data from a byte array over a network socket. This uses the unsafe FFI; + considerations pertaining to 'sendUnsafe' apply to this function as well. Users + may specify a length to send fewer bytes than are actually present in the + array. +-} +uninterruptibleSendByteArray :: + -- | Socket + Fd -> + -- | Source byte array + ByteArray -> + -- | Offset into source array + Int -> + -- | Length in bytes + CSize -> + -- | Flags + MessageFlags 'Send -> + -- | Number of bytes pushed to send buffer + IO (Either Errno CSize) +uninterruptibleSendByteArray fd (ByteArray b) off len flags = + c_unsafe_bytearray_send fd b off len flags >>= errorsFromSize + +{- | Send data from a mutable byte array over a network socket. This uses the unsafe FFI; + considerations pertaining to 'sendUnsafe' apply to this function as well. Users + specify an offset and a length to send fewer bytes than are actually present in the + array. +-} +uninterruptibleSendMutableByteArray :: + -- | Socket + Fd -> + -- | Source mutable byte array + MutableByteArray RealWorld -> + -- | Offset into source array + Int -> + -- | Length in bytes + CSize -> + -- | Flags + MessageFlags 'Send -> + -- | Number of bytes pushed to send buffer + IO (Either Errno CSize) +uninterruptibleSendMutableByteArray fd (MutableByteArray b) off len flags = + c_unsafe_mutable_bytearray_send fd b off len flags >>= errorsFromSize + +{- | Send data from a byte array over an unconnected network socket. + This uses the unsafe FFI; considerations pertaining to 'sendToUnsafe' + apply to this function as well. The offset and length arguments + cause a slice of the byte array to be sent rather than the entire + byte array. +-} +uninterruptibleSendToByteArray :: + -- | Socket + Fd -> + -- | Source byte array + ByteArray -> + -- | Offset into source array + Int -> + -- | Length in bytes + CSize -> + -- | Flags + MessageFlags 'Send -> + -- | Socket Address + SocketAddress -> + -- | Number of bytes pushed to send buffer + IO (Either Errno CSize) +uninterruptibleSendToByteArray fd (ByteArray b) off len flags (SocketAddress a@(ByteArray a#)) = + c_unsafe_bytearray_sendto fd b off len flags a# (intToCInt (PM.sizeofByteArray a)) >>= errorsFromSize + +{- | Variant of 'uninterruptibleSendToByteArray' that requires + that @sockaddr_in@ be used as the socket address. This is used to + avoid allocating a buffer for the socket address when the caller + knows in advance that they are sending to an IPv4 address. +-} +uninterruptibleSendToInternetByteArray :: + -- | Socket + Fd -> + -- | Source byte array + ByteArray -> + -- | Offset into source array + Int -> + -- | Length in bytes + CSize -> + -- | Flags + MessageFlags 'Send -> + -- | Socket Address + SocketAddressInternet -> + -- | Number of bytes pushed to send buffer + IO (Either Errno CSize) +uninterruptibleSendToInternetByteArray fd (ByteArray b) off len flags (SocketAddressInternet {port, address}) = + c_unsafe_bytearray_sendto_inet fd b off len flags port address >>= errorsFromSize + +{- | Variant of 'uninterruptibleSendToByteArray' that requires + that @sockaddr_in@ be used as the socket address. This is used to + avoid allocating a buffer for the socket address when the caller + knows in advance that they are sending to an IPv4 address. +-} +uninterruptibleSendToInternet :: + -- | Socket + Fd -> + -- | Source byte array + Addr -> + -- | Length in bytes + CSize -> + -- | Flags + MessageFlags 'Send -> + -- | Socket Address + SocketAddressInternet -> + -- | Number of bytes pushed to send buffer + IO (Either Errno CSize) +uninterruptibleSendToInternet fd (Addr b) len flags (SocketAddressInternet {port, address}) = + c_unsafe_addr_sendto_inet fd b len flags port address >>= errorsFromSize + +{- | Send data from a mutable byte array over an unconnected network socket. + This uses the unsafe FFI; concerns pertaining to 'uninterruptibleSend' + apply to this function as well. The offset and length arguments + cause a slice of the mutable byte array to be sent rather than the entire + byte array. +-} +uninterruptibleSendToMutableByteArray :: + -- | Socket + Fd -> + -- | Source byte array + MutableByteArray RealWorld -> + -- | Offset into source array + Int -> + -- | Length in bytes + CSize -> + -- | Flags + MessageFlags 'Send -> + -- | Socket Address + SocketAddress -> + -- | Number of bytes pushed to send buffer + IO (Either Errno CSize) +uninterruptibleSendToMutableByteArray fd (MutableByteArray b) off len flags (SocketAddress a@(ByteArray a#)) = + c_unsafe_mutable_bytearray_sendto fd b off len flags a# (intToCInt (PM.sizeofByteArray a)) >>= errorsFromSize + +{- | Variant of 'uninterruptibleSendToMutableByteArray' that requires + that @sockaddr_in@ be used as the socket address. This is used to + avoid allocating a buffer for the socket address when the caller + knows in advance that they are sending to an IPv4 address. +-} +uninterruptibleSendToInternetMutableByteArray :: + -- | Socket + Fd -> + -- | Source byte array + MutableByteArray RealWorld -> + -- | Offset into source array + Int -> + -- | Length in bytes + CSize -> + -- | Flags + MessageFlags 'Send -> + -- | Socket Address + SocketAddressInternet -> + -- | Number of bytes pushed to send buffer + IO (Either Errno CSize) +uninterruptibleSendToInternetMutableByteArray fd (MutableByteArray b) off len flags (SocketAddressInternet {port, address}) = + c_unsafe_mutable_bytearray_sendto_inet fd b off len flags port address >>= errorsFromSize + +{- | Receive data into an address from a network socket. This wraps @recv@ using + the safe FFI. When the returned size is zero, there are no + additional bytes to receive and the peer has performed an orderly shutdown. +-} +receive :: + -- | Socket + Fd -> + -- | Source address + Addr -> + -- | Length in bytes + CSize -> + -- | Flags + MessageFlags 'Receive -> + IO (Either Errno CSize) +receive fd (Addr addr) len flags = + c_safe_addr_recv fd addr len flags >>= errorsFromSize + +{- | Receive data into a byte array from a network socket. This wraps @recv@ using + the safe FFI. When the returned size is zero, there are no + additional bytes to receive and the peer has performed an orderly shutdown. +-} +receiveByteArray :: + -- | Socket + Fd -> + -- | Length in bytes + CSize -> + -- | Flags + MessageFlags 'Receive -> + IO (Either Errno ByteArray) +receiveByteArray !fd !len !flags = do + m <- PM.newPinnedByteArray (csizeToInt len) + let !(Addr addr) = ptrToAddr (PM.mutableByteArrayContents m) + r <- c_safe_addr_recv fd addr len flags + if r /= (-1) + then do + -- Why copy when we could just shrink? We want to always return + -- byte arrays that are not explicitly pinned. + let sz = cssizeToInt r + x <- PM.newByteArray sz + PM.copyMutableByteArray x 0 m 0 sz + a <- PM.unsafeFreezeByteArray x + pure (Right a) + else fmap Left getErrno + +{- | Receive data into an address from a network socket. This wraps @recv@ + using the unsafe FFI. Users of this function should be sure to set flags + that prohibit this from blocking. On Linux this is accomplished by setting + the @MSG_DONTWAIT@ flag and handling the resulting @EAGAIN@ or + @EWOULDBLOCK@. When the returned size is zero, there are no additional + bytes to receive and the peer has performed an orderly shutdown. +-} +uninterruptibleReceive :: + -- | Socket + Fd -> + -- | Source address + Addr -> + -- | Length in bytes + CSize -> + -- | Flags + MessageFlags 'Receive -> + IO (Either Errno CSize) +{-# INLINE uninterruptibleReceive #-} +uninterruptibleReceive !fd (Addr !addr) !len !flags = + c_unsafe_addr_recv fd addr len flags >>= errorsFromSize + +{- | Receive data into an address from a network socket. This uses the unsafe + FFI; considerations pertaining to 'receiveUnsafe' apply to this function + as well. Users may specify a length to receive fewer bytes than are + actually present in the mutable byte array. +-} +uninterruptibleReceiveMutableByteArray :: + -- | Socket + Fd -> + -- | Destination byte array + MutableByteArray RealWorld -> + -- | Destination offset + Int -> + -- | Maximum bytes to receive + CSize -> + -- | Flags + MessageFlags 'Receive -> + -- | Bytes received into array + IO (Either Errno CSize) +{-# INLINE uninterruptibleReceiveMutableByteArray #-} +uninterruptibleReceiveMutableByteArray !fd (MutableByteArray !b) !off !len !flags = + c_unsafe_mutable_byte_array_recv fd b off len flags >>= errorsFromSize + +{- | Receive data into an address from an unconnected network socket. This + uses the unsafe FFI. Users may specify an offset into the destination + byte array. This function does not resize the buffer. +-} +uninterruptibleReceiveFromMutableByteArray :: + -- | Socket + Fd -> + -- | Destination byte array + MutableByteArray RealWorld -> + -- | Destination offset + Int -> + -- | Maximum bytes to receive + CSize -> + -- | Flags + MessageFlags 'Receive -> + -- | Maximum socket address size + CInt -> + -- | Remote host, bytes received into array, bytes needed for @addrlen@. + IO (Either Errno (CInt, SocketAddress, CSize)) +{-# INLINE uninterruptibleReceiveFromMutableByteArray #-} +-- GHC does not inline this unless we give it the pragma. We really +-- want this to inline since inlining typically avoids the Left/Right +-- data constructor allocation. +uninterruptibleReceiveFromMutableByteArray !fd (MutableByteArray !b) !off !len !flags !maxSz = do + -- TODO: We currently allocate one buffer for the size and + -- one for the peer. We could improve this by allocating + -- a single buffer instead. We would need to add some + -- cleverness in the cbits directory. + sockAddrBuf@(MutableByteArray sockAddrBuf#) <- PM.newByteArray (cintToInt maxSz) + lenBuf@(MutableByteArray lenBuf#) <- PM.newByteArray (PM.sizeOf (undefined :: CInt)) + PM.writeByteArray lenBuf 0 maxSz + r <- c_unsafe_mutable_byte_array_recvfrom fd b off len flags sockAddrBuf# lenBuf# + if r > (-1) + then do + (sz :: CInt) <- PM.readByteArray lenBuf 0 + if sz < maxSz + then shrinkMutableByteArray sockAddrBuf (cintToInt sz) + else pure () + sockAddr <- PM.unsafeFreezeByteArray sockAddrBuf + pure (Right (sz, SocketAddress sockAddr, cssizeToCSize r)) + else fmap Left getErrno + +uninterruptibleReceiveFromInternet :: + -- | Socket + Fd -> + -- | Destination byte array + Addr -> + -- | Maximum bytes to receive + CSize -> + -- | Flags + MessageFlags 'Receive -> + -- | Address + MutablePrimArrayOffset RealWorld SocketAddressInternet -> + -- | Number of bytes received into array + IO (Either Errno CSize) +{-# INLINE uninterruptibleReceiveFromInternet #-} +uninterruptibleReceiveFromInternet + !fd + (Addr b) + !len + !flags + (MutablePrimArrayOffset (MutablePrimArray sockAddrBuf) addrOff) = + c_unsafe_recvfrom_inet_addr fd b len flags sockAddrBuf addrOff + >>= errorsFromSize + +uninterruptibleReceiveFromInternetMutableByteArray :: + -- | Socket + Fd -> + -- | Destination byte array + MutableByteArrayOffset RealWorld -> + -- | Maximum bytes to receive + CSize -> + -- | Flags + MessageFlags 'Receive -> + -- | Address + MutablePrimArrayOffset RealWorld SocketAddressInternet -> + -- | Number of bytes received into array + IO (Either Errno CSize) +{-# INLINE uninterruptibleReceiveFromInternetMutableByteArray #-} +uninterruptibleReceiveFromInternetMutableByteArray + !fd + (MutableByteArrayOffset (MutableByteArray b) off) + !len + !flags + (MutablePrimArrayOffset (MutablePrimArray sockAddrBuf) addrOff) = + c_unsafe_recvfrom_inet fd b off len flags sockAddrBuf addrOff + >>= errorsFromSize + +{- | Receive data into an address from a network socket. This uses the unsafe + FFI. This does not return the socket address of the remote host that + sent the packet received. +-} +uninterruptibleReceiveFromMutableByteArray_ :: + -- | Socket + Fd -> + -- | Destination byte array + MutableByteArray RealWorld -> + -- | Destination offset + Int -> + -- | Maximum bytes to receive + CSize -> + -- | Flags + MessageFlags 'Receive -> + -- | Number of bytes received into array + IO (Either Errno CSize) +{-# INLINE uninterruptibleReceiveFromMutableByteArray_ #-} +uninterruptibleReceiveFromMutableByteArray_ !fd (MutableByteArray !b) !off !len !flags = + c_unsafe_mutable_byte_array_peerless_recvfrom fd b off len flags + >>= errorsFromSize + +{- | Receive data into an address from a network socket. This uses the unsafe + FFI. This does not return the socket address of the remote host that + sent the packet received. +-} +uninterruptibleReceiveFrom_ :: + -- | Socket + Fd -> + -- | Destination byte array + Addr -> + -- | Maximum bytes to receive + CSize -> + -- | Flags + MessageFlags 'Receive -> + -- | Number of bytes received into array + IO (Either Errno CSize) +{-# INLINE uninterruptibleReceiveFrom_ #-} +uninterruptibleReceiveFrom_ !fd (Addr !b) !len !flags = + c_unsafe_addr_peerless_recvfrom fd b len flags + >>= errorsFromSize + +ptrToAddr :: Ptr Word8 -> Addr +ptrToAddr (Exts.Ptr a) = Addr a + +-- | Shutdown a socket. This uses the unsafe FFI. +uninterruptibleShutdown :: + Fd -> + ShutdownType -> + IO (Either Errno ()) +uninterruptibleShutdown fd typ = + c_unsafe_shutdown fd typ >>= errorsFromInt_ + +errorsFromSize :: CSsize -> IO (Either Errno CSize) +errorsFromSize r = + if r > (-1) + then pure (Right (cssizeToCSize r)) + else fmap Left getErrno + +errorsFromFd :: Fd -> IO (Either Errno Fd) +errorsFromFd r = + if r > (-1) + then pure (Right r) + else fmap Left getErrno + +-- Sometimes, functions that return an int use zero to indicate +-- success and negative one to indicate failure without including +-- additional information in the value. +errorsFromInt_ :: CInt -> IO (Either Errno ()) +errorsFromInt_ r = + if r == 0 + then pure (Right ()) + else fmap Left getErrno + +intToCInt :: Int -> CInt +intToCInt = fromIntegral + +cintToInt :: CInt -> Int +cintToInt = fromIntegral + +csizeToInt :: CSize -> Int +csizeToInt = fromIntegral + +cssizeToInt :: CSsize -> Int +cssizeToInt = fromIntegral + +-- only call this when it is known that the argument is non-negative +cssizeToCSize :: CSsize -> CSize +cssizeToCSize = fromIntegral + +shrinkMutableByteArray :: MutableByteArray RealWorld -> Int -> IO () +shrinkMutableByteArray (MutableByteArray arr) (I# sz) = + PM.primitive_ (shrinkMutableByteArray# arr sz) + +-- | Convert a 16-bit word from host to network byte order (e.g. @htons@). +hostToNetworkShort :: Word16 -> Word16 +hostToNetworkShort = case targetByteOrder of + BigEndian -> id + LittleEndian -> byteSwap16 + +-- | Convert a 16-bit word from network to host byte order (e.g. @ntohs@). +networkToHostShort :: Word16 -> Word16 +networkToHostShort = case targetByteOrder of + BigEndian -> id + LittleEndian -> byteSwap16 + +-- | Convert a 32-bit word from host to network byte order (e.g. @htonl@). +hostToNetworkLong :: Word32 -> Word32 +hostToNetworkLong = case targetByteOrder of + BigEndian -> id + LittleEndian -> byteSwap32 + +-- | Convert a 32-bit word from network to host byte order (e.g. @ntohl@). +networkToHostLong :: Word32 -> Word32 +networkToHostLong = case targetByteOrder of + BigEndian -> id + LittleEndian -> byteSwap32 + +{- $conversion +These functions are used to convert IPv4 addresses and ports between network +byte order and host byte order. They are essential when working with +'SocketAddressInternet'. To avoid getting in the way of GHC compile-time +optimizations, these functions are not actually implemented with FFI +calls to @htonl@ and friends. Rather, they are reimplemented in haskell. +-} + +{- $receiveMessage +The function @recvMsg@ presents us with a challenge. Since it uses a +data structure with many nested pointers, we have to use pinned byte +arrays for everything. There is also the difficulty of marshalling +haskell's unlifted array (array of arrays) type into what C's +array of @iovec@. There's the question of the array of @cmsghdr@s. +On top of all of this, we have to answer the question of whether +we want to accept mutable buffer or whether we want to do the +allocations internally (both for the buffers and for the ancilliary +data structurs needed to massage the data into what C expects). + +What we do to handle this in offer several variants of @recvmsg@ +ending in @A@, @B@, etc. +-} + +isByteArrayPinned :: ByteArray -> Bool +{-# INLINE isByteArrayPinned #-} +isByteArrayPinned (ByteArray arr#) = + Exts.isTrue# (Exts.isByteArrayPinned# arr#) + +isMutableByteArrayPinned :: MutableByteArray s -> Bool +{-# INLINE isMutableByteArrayPinned #-} +isMutableByteArrayPinned (MutableByteArray marr#) = + Exts.isTrue# (Exts.isMutableByteArrayPinned# marr#) + +unMba :: MutableByteArray s -> MutableByteArray# s +{-# INLINE unMba #-} unMba (MutableByteArray x) = x diff --git a/src/Posix/Types.hsc b/src/Posix/Types.hsc --- a/src/Posix/Types.hsc +++ b/src/Posix/Types.hsc @@ -7,18 +7,6 @@ ( CNfds(..) ) where -import Data.Word - -import Foreign.Storable (Storable) -import Data.Bits (FiniteBits,Bits) -#if MIN_VERSION_base(4,14,0) import System.Posix.Types (CNfds(..)) -#endif #include - --- This is a compatibility shim for older GHCs -#if !MIN_VERSION_base(4,14,0) -newtype CNfds = CNfds #{type nfds_t} - deriving newtype (Eq,Real,Integral,Enum,Num,Ord,Storable,FiniteBits,Bits) -#endif diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,61 +1,56 @@ -{-# language BangPatterns #-} -{-# language BinaryLiterals #-} -{-# language LambdaCase #-} -{-# language NamedFieldPuns #-} -{-# language ScopedTypeVariables #-} -{-# language TypeApplications #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -import Control.Concurrent (forkIO) -import Control.Concurrent (threadWaitRead,threadWaitWrite) +import Control.Concurrent (forkIO, threadWaitWrite) import Control.Monad (when) -import Data.Primitive (ByteArray,MutablePrimArray(..),MutableByteArray(..)) -import Data.Word (Word32,Word8) -import Foreign.C.Error (Errno,errnoToIOError) -import Foreign.C.Types (CInt,CSize) +import Data.Primitive (ByteArray, MutableByteArray (..), MutablePrimArray (..)) +import Data.Word (Word8) +import Foreign.C.Error (Errno, errnoToIOError) +import Foreign.C.Types (CSize) import GHC.Exts (RealWorld) import Numeric (showIntAtBase) import Test.Tasty import Test.Tasty.HUnit -import qualified GHC.Exts as E import qualified Data.Primitive as PM -import qualified Data.Primitive.Unlifted.Array as PM import qualified Data.Primitive.MVar as PM -import qualified Posix.Socket as S -import qualified Linux.Socket as L +import qualified GHC.Exts as E import qualified Linux.Epoll as Epoll +import qualified Posix.Socket as S main :: IO () main = defaultMain tests tests :: TestTree -tests = testGroup "tests" - [ testGroup "posix" - [ testGroup "sockets" - [ testCase "A" testSocketsA - , testCase "B" testSocketsB - , testCase "C" testSocketsC - , testCase "D" testSocketsD - , testCase "E" testSocketsE - , testCase "F" testSocketsF - , testCase "G" testSocketsG - ] - ] - , testGroup "linux" - [ testGroup "sockets" - [ testCase "A" testLinuxSocketsA - , testCase "B" testLinuxSocketsB - , testCase "C" testLinuxSocketsC - ] - , testGroup "epoll" - [ testCase "A" testLinuxEpollA - ] +tests = + testGroup + "tests" + [ testGroup + "posix" + [ testGroup + "sockets" + [ testCase "A" testSocketsA + , testCase "B" testSocketsB + , testCase "C" testSocketsC + , testCase "D" testSocketsD + ] + ] + , testGroup + "linux" + [ testGroup + "epoll" + [ testCase "A" testLinuxEpollA + ] + ] ] - ] 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,26 +63,28 @@ 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 - y <- PM.newByteArray wordSz - PM.writeByteArray y 0 (1 + n) - z <- PM.unsafeFreezeByteArray y - oneWord =<< demand =<< S.sendByteArray b z 0 cwordSz mempty - x <- demand =<< S.receiveByteArray b cwordSz mempty - go1 (ix + 1) (PM.indexByteArray x 0) - else pure n - go2 !(ix :: Int) = if (ix < limit) - then do - x <- demand =<< S.receiveByteArray a cwordSz mempty - y <- PM.newByteArray wordSz - PM.writeByteArray y 0 (1 + PM.indexByteArray x 0 :: Int) - z <- PM.unsafeFreezeByteArray y - oneWord =<< demand =<< S.sendByteArray a z 0 cwordSz mempty - go2 (ix + 1) - else PM.putMVar lock () + let go1 !(ix :: Int) !(n :: Int) = + if (ix < limit) + then do + y <- PM.newByteArray wordSz + PM.writeByteArray y 0 (1 + n) + z <- PM.unsafeFreezeByteArray y + oneWord =<< demand =<< S.sendByteArray b z 0 cwordSz mempty + x <- demand =<< S.receiveByteArray b cwordSz mempty + go1 (ix + 1) (PM.indexByteArray x 0) + else pure n + go2 !(ix :: Int) = + if (ix < limit) + then do + x <- demand =<< S.receiveByteArray a cwordSz mempty + y <- PM.newByteArray wordSz + PM.writeByteArray y 0 (1 + PM.indexByteArray x 0 :: Int) + z <- PM.unsafeFreezeByteArray y + oneWord =<< demand =<< S.sendByteArray a z 0 cwordSz mempty + go2 (ix + 1) + else PM.putMVar lock () _ <- forkIO (go2 0) r <- go1 0 0 PM.takeMVar lock @@ -95,7 +92,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,175 +102,33 @@ 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") actual <- demand =<< S.receiveByteArray a 5 mempty sample @=? actual -testSocketsE :: Assertion -testSocketsE = do - (a,b) <- demand =<< S.uninterruptibleSocketPair S.Unix S.datagram S.defaultProtocol - _ <- forkIO $ do - threadWaitWrite b - bytesSent <- demand =<< S.uninterruptibleSendByteArray b sample 0 5 mempty - when (bytesSent /= 5) (fail "testSocketsE: bytesSent was wrong") - threadWaitRead a - actual <- demand =<< S.uninterruptibleReceiveMessageA a 3 10 mempty - (5,E.fromList [E.fromList [1,2,3],E.fromList [4,5]]) @=? actual - -testSocketsF :: Assertion -testSocketsF = do - 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 - 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})) - when (bytesSent /= 5) (fail "testSocketsF: bytesSent was wrong") - threadWaitRead a - actual <- demand =<< S.uninterruptibleReceiveMessageB a 5 2 mempty 128 - (expectedSzB,expectedSockAddrB) <- demand =<< S.uninterruptibleGetSocketName b 128 - when (expectedSzB > 128) (fail "testSocketsF: bad socket address size for socket B") - (expectedSzB,expectedSockAddrB,5,E.fromList [sample]) @=? actual - -testSocketsG :: Assertion -testSocketsG = do - (a,b) <- demand =<< S.uninterruptibleSocketPair S.Unix S.datagram S.defaultProtocol - _ <- forkIO $ do - bytesSent <- demand =<< S.writeVector b - ( E.fromList - [ E.fromList (enumFromTo (1 :: Word8) 6) - , E.fromList (enumFromTo (7 :: Word8) 9) - ] - ) - when (bytesSent /= 9) (fail "testSocketsG: bytesSent was wrong") - actual <- demand =<< S.receiveByteArray a 9 mempty - E.fromList (enumFromTo (1 :: Word8) 9) @=? actual - -testLinuxSocketsA :: Assertion -testLinuxSocketsA = do - (a,b) <- demand =<< S.uninterruptibleSocketPair S.Unix S.datagram S.defaultProtocol - threadWaitWrite b - bytesSent1 <- demand =<< S.uninterruptibleSendByteArray b sample 0 5 mempty - threadWaitWrite b - bytesSent2 <- demand =<< S.uninterruptibleSendByteArray b sample2 0 4 mempty - when (bytesSent1 /= 5) (fail "testLinuxSocketsA: bytesSent1 was wrong") - when (bytesSent2 /= 4) (fail "testLinuxSocketsA: bytesSent2 was wrong") - threadWaitRead a - actual <- demand =<< L.uninterruptibleReceiveMultipleMessageA a 6 3 L.dontWait - (5,E.fromList [sample,sample2]) @=? actual - -testLinuxSocketsB :: Assertion -testLinuxSocketsB = do - 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 /= S.sizeofSocketAddressInternet) - (fail "testLinixSocketsB: bad socket address size for socket A") - 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 - demand =<< S.uninterruptibleBind b - (S.encodeSocketAddressInternet $ S.SocketAddressInternet - { S.port = 0 - , S.address = localhost - } - ) - threadWaitWrite b - bytesSent1 <- demand =<< S.uninterruptibleSendToByteArray b sample 0 5 mempty - (S.encodeSocketAddressInternet (S.SocketAddressInternet {S.port = portA, S.address = localhost})) - when (bytesSent1 /= 5) - (fail "testLinixSocketsB: bytesSent1 was wrong") - threadWaitWrite b - bytesSent2 <- demand =<< S.uninterruptibleSendToByteArray b sample2 0 4 mempty - (S.encodeSocketAddressInternet (S.SocketAddressInternet {S.port = portA, S.address = localhost})) - when (bytesSent2 /= 4) - (fail "testLinixSocketsB: bytesSent2 was wrong") - threadWaitRead a - actual <- demand - =<< L.uninterruptibleReceiveMultipleMessageB a S.sizeofSocketAddressInternet 6 3 L.dontWait - (expectedSzB,S.SocketAddress sabytesB) <- demand =<< S.uninterruptibleGetSocketName b 128 - when (expectedSzB /= S.sizeofSocketAddressInternet) - (fail "testLinixSocketsB: bad socket address size for socket B") - (0,sabytesB <> sabytesB,5,E.fromList [sample,sample2]) @=? actual - -testLinuxSocketsC :: Assertion -testLinuxSocketsC = do - 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 /= S.sizeofSocketAddressInternet) - (fail "testLinuxSocketsC: bad socket address size for socket A") - 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 - demand =<< S.uninterruptibleBind b - (S.encodeSocketAddressInternet $ S.SocketAddressInternet - { S.port = 0 - , S.address = localhost - } - ) - threadWaitWrite b - bytesSent1 <- demand =<< S.uninterruptibleSendToByteArray b sample 0 5 mempty - (S.encodeSocketAddressInternet (S.SocketAddressInternet {S.port = portA, S.address = localhost})) - when (bytesSent1 /= 5) - (fail "testLinuxSocketsC: bytesSent1 was wrong") - threadWaitWrite b - bytesSent2 <- demand =<< S.uninterruptibleSendToByteArray b sample2 0 4 mempty - (S.encodeSocketAddressInternet (S.SocketAddressInternet {S.port = portA, S.address = localhost})) - when (bytesSent2 /= 4) - (fail "testLinuxSocketsC: bytesSent2 was wrong") - threadWaitRead a - lens <- PM.newPrimArray 2 - addrs <- PM.newPrimArray 2 - payloadsMut <- PM.unsafeNewUnliftedArray 2 - PM.newByteArray 6 >>= PM.writeUnliftedArray payloadsMut 0 - PM.newByteArray 6 >>= PM.writeUnliftedArray payloadsMut 1 - msgCount <- demand =<< L.uninterruptibleReceiveMultipleMessageC a lens addrs payloadsMut 2 L.dontWait - when (msgCount /= 2) (fail "wrong number of messages") - addrsFrozen <- PM.unsafeFreezePrimArray addrs - payloads <- PM.unsafeFreezeUnliftedArray payloadsMut - len0 <- PM.readPrimArray lens 0 - len1 <- PM.readPrimArray lens 1 - buf0 <- PM.unsafeFreezeByteArray - =<< PM.resizeMutableByteArray (PM.indexUnliftedArray payloads 0) (fromIntegral @CInt @Int len0) - buf1 <- PM.unsafeFreezeByteArray - =<< PM.resizeMutableByteArray (PM.indexUnliftedArray payloads 1) (fromIntegral @CInt @Int len1) - (expectedSzB,S.SocketAddress sabytesB) <- demand =<< S.uninterruptibleGetSocketName b 128 - when (expectedSzB /= S.sizeofSocketAddressInternet) - (fail "testLinuxSocketsC: bad socket address size for socket B") - let primSockAddr = case sabytesB of PM.ByteArray x -> PM.PrimArray x - (primSockAddr <> primSockAddr,E.fromList [sample,sample2]) @=? (addrsFrozen,[buf0,buf1]) - -- This test opens two datagram sockets and send a message from each -- one to the other. Then it checks that epoll's event-triggered -- interface correctly notifies the user about the read-readiness -- 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 - { Epoll.events = Epoll.input <> Epoll.edgeTriggered - , Epoll.payload = a - } + PM.writePrimArray reg 0 $ + Epoll.Event + { Epoll.events = Epoll.input <> Epoll.edgeTriggered + , Epoll.payload = a + } demand =<< Epoll.uninterruptibleControlMutablePrimArray epfd Epoll.add a reg - PM.writePrimArray reg 0 $ Epoll.Event - { Epoll.events = Epoll.input <> Epoll.edgeTriggered - , Epoll.payload = b - } + PM.writePrimArray reg 0 $ + Epoll.Event + { Epoll.events = Epoll.input <> Epoll.edgeTriggered + , Epoll.payload = b + } demand =<< Epoll.uninterruptibleControlMutablePrimArray epfd Epoll.add b reg threadWaitWrite b bytesSentB <- demand =<< S.uninterruptibleSendByteArray b sample 0 5 mempty @@ -287,13 +142,13 @@ when (evCount /= 2) (fail ("testLinuxEpollA: evCount was " ++ show evCount)) r <- case () of _ -> do - Epoll.Event{Epoll.events,Epoll.payload} <- PM.readPrimArray evs 0 + Epoll.Event {Epoll.events, Epoll.payload} <- PM.readPrimArray evs 0 when (payload /= a && payload /= b) (fail ("testLinuxEpollA: payload x was " ++ show payload)) let Epoll.Events e = events when (not (Epoll.containsAnyEvents events Epoll.input)) $ do fail ("testLinuxEpollA: events x bitmask " ++ showIntAtBase 2 binChar e " missing EPOLLIN") pure payload - Epoll.Event{Epoll.events,Epoll.payload} <- PM.readPrimArray evs 1 + Epoll.Event {Epoll.events, Epoll.payload} <- PM.readPrimArray evs 1 when (payload == r) (fail ("testLinuxEpollA: same payload " ++ show payload ++ " for both events")) when (payload /= a && payload /= b) (fail ("testLinuxEpollA: payload y was " ++ show payload)) let Epoll.Events e = events @@ -311,25 +166,20 @@ loadGarbage (MutablePrimArray x) = do let arr = MutableByteArray x go :: Int -> IO () - go !ix = if ix > (-1) - then do - PM.writeByteArray arr ix ((0b01010101 :: Word8) + fromIntegral ix) - go (ix - 1) - else pure () + go !ix = + if ix > (-1) + then do + PM.writeByteArray arr ix ((0b01010101 :: Word8) + fromIntegral ix) + go (ix - 1) + else pure () n <- PM.getSizeofMutableByteArray arr go (n - 1) sample :: ByteArray -sample = E.fromList [1,2,3,4,5] - -sample2 :: ByteArray -sample2 = E.fromList [6,7,8,9] +sample = E.fromList [1, 2, 3, 4, 5] demand :: Either Errno a -> IO a demand = either (\e -> ioError (errnoToIOError "test" e Nothing Nothing)) pure - + oneWord :: CSize -> IO () oneWord x = if x == fromIntegral (PM.sizeOf (undefined :: Int)) then pure () else fail "expected one machine word" - -localhost :: Word32 -localhost = S.hostToNetworkLong 2130706433