From a2c0971f080ad4447aa959359092a26d15fd9516 Mon Sep 17 00:00:00 2001 From: Brian McKeon <135748266+brianjosephmckeon@users.noreply.github.com> Date: Wed, 28 Feb 2024 12:43:03 -0500 Subject: [PATCH] Prepare 0.7.2.0 release. Reformatted. Use new .github workflows. Updated package metadata. Fix src-assertions/Assertion.hs build error and remove unliftedarrayfunctions cabal flag. Delete tests that refer to functions that have been removed. Removed all code that added support for GHC < 9.4. --------- Co-authored-by: Andrew Martin --- .github/CODEOWNERS | 1 + .github/workflows/build.yaml | 11 + .github/workflows/release.yaml | 10 + .gitignore | 1 + CHANGELOG.md | 31 +- Setup.hs | 2 - fourmolu.yaml | 51 + include/HaskellPosix.h | 1 - include/custom.h | 1 - posix-api.cabal | 149 +-- src-assertions/Assertion.hs | 37 +- src-linux/Posix/Socket/Platform.hsc | 5 +- src/Foreign/C/String/Managed.hs | 103 +- src/Linux/Epoll.hs | 168 +-- src/Linux/Epoll/Types.hsc | 29 +- src/Linux/Socket.hs | 424 ++----- src/Linux/Socket/Types.hsc | 6 +- src/Posix/Directory.hs | 27 +- src/Posix/File.hs | 343 +++--- src/Posix/MessageQueue.hs | 107 +- src/Posix/Poll.hs | 47 +- src/Posix/Poll/Types.hsc | 6 +- src/Posix/Select.hs | 2 - src/Posix/Socket.hs | 1744 +++++++++++++-------------- src/Posix/Types.hsc | 12 - test/Main.hs | 308 ++--- 26 files changed, 1663 insertions(+), 1963 deletions(-) create mode 100644 .github/CODEOWNERS create mode 100644 .github/workflows/build.yaml create mode 100644 .github/workflows/release.yaml delete mode 100644 Setup.hs create mode 100644 fourmolu.yaml diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS new file mode 100644 index 0000000..f6c0b22 --- /dev/null +++ b/.github/CODEOWNERS @@ -0,0 +1 @@ +@byteverse/l3c diff --git a/.github/workflows/build.yaml b/.github/workflows/build.yaml new file mode 100644 index 0000000..e818a4e --- /dev/null +++ b/.github/workflows/build.yaml @@ -0,0 +1,11 @@ +name: build +on: + pull_request: + branches: + - "*" + +jobs: + call-workflow: + uses: byteverse/.github/.github/workflows/build-matrix.yaml@main + with: + cabal-file: posix-api.cabal diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml new file mode 100644 index 0000000..9411962 --- /dev/null +++ b/.github/workflows/release.yaml @@ -0,0 +1,10 @@ +name: release +on: + push: + tags: + - "*" + +jobs: + call-workflow: + uses: byteverse/.github/.github/workflows/release.yaml@main + secrets: inherit diff --git a/.gitignore b/.gitignore index 7da183f..7ee22e9 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,4 @@ +.vscode/ dist dist-* cabal-dev diff --git a/CHANGELOG.md b/CHANGELOG.md index a5ca4f5..3a72ff3 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,18 +7,19 @@ added, changed, deprecated, etc. subsections. This project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). -## [0.7.2.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 +## 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 @@ -26,35 +27,35 @@ This project adheres to the [Haskell Package Versioning Policy](https://pvp.hask 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. @@ -63,26 +64,26 @@ This project adheres to the [Haskell Package Versioning Policy](https://pvp.hask - 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 index 9a994af..0000000 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/fourmolu.yaml b/fourmolu.yaml new file mode 100644 index 0000000..40cd005 --- /dev/null +++ b/fourmolu.yaml @@ -0,0 +1,51 @@ +# Number of spaces per indentation step +indentation: 2 + +# Max line length for automatic line breaking +column-limit: 200 + +# Styling of arrows in type signatures (choices: trailing, leading, or leading-args) +function-arrows: trailing + +# How to place commas in multi-line lists, records, etc. (choices: leading or trailing) +comma-style: leading + +# Styling of import/export lists (choices: leading, trailing, or diff-friendly) +import-export-style: leading + +# Whether to full-indent or half-indent 'where' bindings past the preceding body +indent-wheres: false + +# Whether to leave a space before an opening record brace +record-brace-space: true + +# Number of spaces between top-level declarations +newlines-between-decls: 1 + +# How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) +haddock-style: multi-line + +# How to print module docstring +haddock-style-module: null + +# Styling of let blocks (choices: auto, inline, newline, or mixed) +let-style: auto + +# How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) +in-style: right-align + +# Whether to put parentheses around a single constraint (choices: auto, always, or never) +single-constraint-parens: always + +# Output Unicode syntax (choices: detect, always, or never) +unicode: never + +# Give the programmer more choice on where to insert blank lines +respectful: true + +# Fixity information for operators +fixities: [] + +# Module reexports Fourmolu should know about +reexports: [] + diff --git a/include/HaskellPosix.h b/include/HaskellPosix.h index e789816..6e88492 100644 --- a/include/HaskellPosix.h +++ b/include/HaskellPosix.h @@ -20,4 +20,3 @@ int recvmmsg_sockaddr_in (int sockfd , int *lens , struct sockaddr_in *addrs 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 index f604caa..f39ea23 100644 --- 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 index c805a05..c26b73e 100644 --- a/posix-api.cabal +++ b/posix-api.cabal @@ -1,7 +1,7 @@ -cabal-version: 2.2 -name: posix-api -version: 0.7.2.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 @@ description: 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 @@ description: 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 @@ library 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 @@ library 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 index f261f44..c01965e 100644 --- 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 @@ module Assertion , 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 index 1759c52..5717ad3 100644 --- a/src-linux/Posix/Socket/Platform.hsc +++ b/src-linux/Posix/Socket/Platform.hsc @@ -40,7 +40,7 @@ import qualified Data.Primitive as PM 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 @@ indexSocketAddressInternet addr ix = do -- 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 @@ unboxByteArrayST (ST f) s = case f s of -- 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 index 798487a..301054e 100644 --- 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 @@ module Foreign.C.String.Managed 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 @@ instance Exts.IsString ManagedCString where 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 @@ pinnedFromBytes (Bytes arr off len) = ManagedCString $ runByteArrayST $ do 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 @@ touch (ManagedCString (ByteArray x)) = touchByteArray# x 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 - --- | Get a pointer to the payload of the managed C string. The behavior is --- undefined if the argument is not pinned. + 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. +-} contents :: ManagedCString -> CString contents (ManagedCString x) = castPtr (PM.byteArrayContents x) diff --git a/src/Linux/Epoll.hs b/src/Linux/Epoll.hs index 0e1caed..ce81e2f 100644 --- 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 @@ module Linux.Epoll , T.readHangup , T.error , T.edgeTriggered + -- * Events Combinators , T.containsAnyEvents , T.containsAllEvents + -- * Marshalling , T.sizeofEvent , T.peekEventEvents @@ -48,21 +54,17 @@ module Linux.Epoll , 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 @@ foreign import ccall unsafe "sys/epoll.h epoll_ctl" -- 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 index 5fb4fed..dc6cbd4 100644 --- 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 @@ word64ToWord32 = fromIntegral 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 index f840d85..df356c3 100644 --- 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 @@ module Linux.Socket 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 - -#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 - -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 - --- | 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 --- + Fd -> + Ptr Void -> -- SocketAddress + Ptr Void -> -- Ptr CInt + SocketFlags -> + IO Fd + +{- | 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 +-} 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 @@ uninterruptibleAccept4 !sock !maxSz !flags = do 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 @@ uninterruptibleAccept4_ !sock !flags = do 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 index 8d7c6a4..1cdafbf 100644 --- a/src/Linux/Socket/Types.hsc +++ b/src/Linux/Socket/Types.hsc @@ -75,7 +75,7 @@ newtype SocketFlags = SocketFlags CInt -- 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 @@ newtype SocketFlags = SocketFlags CInt -- , 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 index 4fe9f1d..07e4caa 100644 --- 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 @@ import qualified Foreign.Storable as FS 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 @@ intToCSize = fromIntegral -- 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 index b65572f..32a1d10 100644 --- 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 @@ -26,49 +25,53 @@ module Posix.File , 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 @@ -112,192 +115,257 @@ foreign import ccall unsafe "unistd.h close" 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 - --- | 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. +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. +-} 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 :: - Fd -- ^ File descriptor - -> MutableByteArray RealWorld -- ^ Destination - -> Int -- ^ Destination offset - -> CSize -- ^ Length in bytes - -> IO (Either Errno CSize) -- ^ Number of bytes received + -- | 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 () @@ -319,9 +387,10 @@ isReadWrite (StatusFlags x) = x .&. 0b11 == 2 -- 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 index 3a1626a..9cce719 100644 --- 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 @@ uninterruptibleReceiveByteArray !fd !len = do 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 @@ intToCSize = fromIntegral -- 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 index c53c77e..8eb6f6b 100644 --- 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 @@ module Posix.Poll , 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" 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 index 82ab9d7..f20fd53 100644 --- 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 @@ module Posix.Poll.Types 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 index 9e9be83..b27b31a 100644 --- 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 index 86d76f1..450b278 100644 --- a/src/Posix/Socket.hs +++ b/src/Posix/Socket.hs @@ -1,70 +1,83 @@ -{-# 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. +{-# 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 @@ -72,80 +85,85 @@ module Posix.Socket , 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(..) + , Family (..) + , Type (..) + , Protocol (..) + , OptionName (..) + , OptionValue (..) + , Level (..) + , Message (..) + , MessageFlags (..) + , ShutdownType (..) , AddressInfo + -- * Socket Address + -- ** Types - , SocketAddress(..) - , PST.SocketAddressInternet(..) - , PST.SocketAddressUnix(..) + , 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 @@ -154,31 +172,42 @@ module Posix.Socket , 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 @@ -190,6 +219,7 @@ module Posix.Socket , PST.peekControlMessageHeaderLevel , PST.peekControlMessageHeaderLength , PST.peekControlMessageHeaderType + -- *** Poke , PST.pokeMessageHeaderName , PST.pokeMessageHeaderNameLength @@ -198,64 +228,58 @@ module Posix.Socket , 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 Control.Exception (onException,mask) -import Data.Primitive.ByteArray.Offset (MutableByteArrayOffset(..)) -import Data.Primitive.PrimArray.Offset (MutablePrimArrayOffset(..)) -import Data.Word (Word8,Word16,Word32,byteSwap16,byteSwap32) +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 Foreign.C.Error (Errno(Errno),getErrno) +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.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 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 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 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. @@ -264,11 +288,11 @@ 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 + 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" @@ -304,56 +328,64 @@ foreign import ccall unsafe "sys/socket.h bind" -- 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 + 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 + 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 + 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 + 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 + 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 + 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 + 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); @@ -392,6 +424,7 @@ foreign import ccall unsafe "sys/socket.h send_offset" -- 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 @@ -408,14 +441,6 @@ foreign import ccall unsafe "HaskellPosix.h sendmsg_a" 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 @@ -429,97 +454,109 @@ 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 + 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 + 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 + 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. + 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 :: - Family -- ^ Communications domain (e.g. 'internet', 'unix') - -> Type -- ^ Socket type (e.g. 'datagram', 'stream') with flags - -> Protocol -- ^ Protocol - -> IO (Either Errno Fd) + -- | 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 :: - Family -- ^ Communications domain (e.g. 'internet', 'unix') - -> Type -- ^ Socket type (e.g. 'datagram', 'stream') with flags - -> Protocol -- ^ Protocol - -> IO (Either Errno Fd) + -- | 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@. +{- | 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 :: - Family -- ^ Communications domain (e.g. 'internet', 'unix') - -> Type -- ^ Socket type (e.g. 'datagram', 'stream') with flags - -> Protocol -- ^ Protocol - -> (Fd -> IO a) - -- ^ Callback that uses the socket. Must not close the socket. - -- The callback is not used when the @socket()@ call fails. - -> IO (Either Errno a) -{-# inline 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 + _ <- 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. +{- | 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)) + -- | 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. @@ -529,19 +566,22 @@ uninterruptibleSocketPair dom typ prot = do then do fd1 <- PM.readPrimArray sockets 0 fd2 <- PM.readPrimArray sockets 1 - pure (Right (fd1,fd2)) + 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. +{- | 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)) + -- | 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 @@ -550,40 +590,49 @@ getAddressInfo !node !service !hints = do 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. +{- | 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 ()) + -- | 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. +{- | 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 ()) + -- | 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 the socket to the specified socket address. + The + includes more details. +-} connect :: - Fd -- ^ Fd - -> SocketAddress -- ^ Socket address, extensible tagged union - -> IO (Either Errno ()) + -- | 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_ @@ -593,54 +642,64 @@ connect fd (SocketAddress sockAddr@(ByteArray sockAddr#)) = 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. +{- | 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 ()) + -- | 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 - -> Ptr a -- ^ Socket address - -> Int -- ^ Size of socket address - -> IO (Either Errno ()) + -- | 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_'. +{- | 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 + -- | 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)) @@ -655,16 +714,20 @@ accept !sock !maxSz = do x <- PM.newByteArray (cintToInt minSz) PM.copyMutableByteArray x 0 sockAddrBuf 0 (cintToInt minSz) sockAddr <- PM.unsafeFreezeByteArray x - pure (Right (sz,SocketAddress sockAddr,r)) + 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. +{- | 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 + -- | 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)) @@ -677,24 +740,30 @@ uninterruptibleAccept !sock !maxSz = do 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 --- | A variant of 'accept' that does not provide the user with a --- 'SocketAddress' detailing the peer. +{- | 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 + -- | 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. +{- | 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)) + -- | 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)) @@ -707,19 +776,24 @@ uninterruptibleGetSocketName sock maxSz = do then shrinkMutableByteArray sockAddrBuf (cintToInt sz) else pure () sockAddr <- PM.unsafeFreezeByteArray sockAddrBuf - pure (Right (sz,SocketAddress sockAddr)) + 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. +{- | 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)) + -- | 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)) @@ -732,93 +806,100 @@ uninterruptibleGetSocketOption sock level optName maxSz = do then shrinkMutableByteArray valueBuf (cintToInt sz) else pure () value <- PM.unsafeFreezeByteArray valueBuf - pure (Right (sz,OptionValue value)) + 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. +{- | 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 ()) + -- | 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. +{- | 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 ()) + -- | 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. +{- | 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 ()) + -- | 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. +{- | 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. + -- | 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 #-} +{\-# INLINE pinByteArray #-\} pinByteArray byteArray = if isByteArrayPinned byteArray then @@ -830,207 +911,315 @@ pinByteArray byteArray = pure (Just r) where len = PM.sizeofByteArray byteArray +-} --- | Send two payloads (one from unmanaged memory and one from --- managed memory) over a network socket. +{- | 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 = + -- | 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. +{- | 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 = + -- | 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. +{- | 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. + -- | 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 :: - Fd -- ^ Connected socket - -> Addr -- ^ Source address - -> CSize -- ^ Length in bytes - -> MessageFlags 'Send -- ^ Flags - -> IO (Either Errno CSize) -- ^ Number of bytes pushed to send buffer + -- | 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. +{- | 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 + -- | 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. +{- | 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 + -- | 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. +{- | 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 + -- | 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. +{- | 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 + -- | 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. +{- | 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}) = + -- | 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. +{- | 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}) = + -- | 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. +{- | 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 + -- | 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. +{- | 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}) = + -- | 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 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) + -- | 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. +{- | 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) + -- | 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) @@ -1046,50 +1235,69 @@ receiveByteArray !fd !len !flags = do 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. +{- | 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 #-} + -- | 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. +{- | 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 #-} + -- | 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. +{- | 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 #-} + -- | 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. @@ -1109,62 +1317,93 @@ uninterruptibleReceiveFromMutableByteArray !fd (MutableByteArray !b) !off !len ! then shrinkMutableByteArray sockAddrBuf (cintToInt sz) else pure () sockAddr <- PM.unsafeFreezeByteArray sockAddrBuf - pure (Right (sz,SocketAddress sockAddr,cssizeToCSize r)) + 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 + -- | 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 + >>= 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 + -- | 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 + >>= 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. +{- | 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_ #-} + -- | 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. +{- | 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_ #-} + -- | 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 @@ -1174,36 +1413,36 @@ ptrToAddr (Exts.Ptr a) = Addr a -- | Shutdown a socket. This uses the unsafe FFI. uninterruptibleShutdown :: - Fd - -> ShutdownType - -> IO (Either Errno ()) + 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 +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 -- 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 +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 @@ -1245,256 +1484,6 @@ 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 @@ -1503,7 +1492,6 @@ 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 @@ -1520,15 +1508,15 @@ ending in @A@, @B@, etc. -} isByteArrayPinned :: ByteArray -> Bool -{-# inline isByteArrayPinned #-} +{-# INLINE isByteArrayPinned #-} isByteArrayPinned (ByteArray arr#) = Exts.isTrue# (Exts.isByteArrayPinned# arr#) isMutableByteArrayPinned :: MutableByteArray s -> Bool -{-# inline isMutableByteArrayPinned #-} +{-# INLINE isMutableByteArrayPinned #-} isMutableByteArrayPinned (MutableByteArray marr#) = Exts.isTrue# (Exts.isMutableByteArrayPinned# marr#) unMba :: MutableByteArray s -> MutableByteArray# s -{-# inline unMba #-} +{-# INLINE unMba #-} unMba (MutableByteArray x) = x diff --git a/src/Posix/Types.hsc b/src/Posix/Types.hsc index 452fe71..5a4121e 100644 --- a/src/Posix/Types.hsc +++ b/src/Posix/Types.hsc @@ -7,18 +7,6 @@ module Posix.Types ( 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 index 9256600..4632d98 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,61 +1,56 @@ -{-# language BangPatterns #-} -{-# language BinaryLiterals #-} -{-# language LambdaCase #-} -{-# language NamedFieldPuns #-} -{-# language ScopedTypeVariables #-} -{-# language TypeApplications #-} - -import Control.Concurrent (forkIO) -import Control.Concurrent (threadWaitRead,threadWaitWrite) +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +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 @@ testSocketsB = do 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 @@ testSocketsB = do 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 @@ testSocketsC = do 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 @@ testLinuxEpollA = do 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 RealWorld a -> IO () 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