packages feed

network-unexceptional 0.2.1.0 → 0.2.1.1

raw patch · 9 files changed

+418/−368 lines, 9 filesnew-uploader

Files

CHANGELOG.md view
@@ -1,5 +1,9 @@ # Revision history for network-unexceptional +## 0.2.1.1 -- 2024-02-07++* Update package metadata.+ ## 0.2.1.0 -- 2024-01-17  * Add `receiveFromInterruptible"
network-unexceptional.cabal view
@@ -1,39 +1,54 @@-cabal-version: 3.0-name: network-unexceptional-version: 0.2.1.0-synopsis: Network functions that do not throw exceptions+cabal-version:   3.0+name:            network-unexceptional+version:         0.2.1.1+category:        Network+synopsis:        Network functions that do not throw exceptions description:   Functions compatible with the Socket type from the network library that   do not convert POSIX error codes to thrown exceptions. This library   can throw exceptions, but they only happen in the case of misuse, not   as the result of anything a network peer does.-license: BSD-3-Clause-license-file: LICENSE-author: Andrew Martin-maintainer: andrew.thaddeus@gmail.com-copyright: 2023 Andrew Martin-build-type: Simple++license:         BSD-3-Clause+license-file:    LICENSE+author:          Andrew Martin+maintainer:      amartin@layer3com.com+homepage:        https://github.com/byteverse/network-unexceptional+bug-reports:     https://github.com/byteverse/network-unexceptional/issues+copyright:       2023 Andrew Martin+build-type:      Simple extra-doc-files: CHANGELOG.md+tested-with:     GHC ==9.4.8 || ==9.6.3 || ==9.8.1 +common build-settings+  default-language: Haskell2010+  ghc-options:      -Wall -Wunused-packages+ library-  ghc-options: -O2 -Wall+  import:          build-settings+  ghc-options:     -O2   exposed-modules:     Network.Unexceptional     Network.Unexceptional.ByteArray-    Network.Unexceptional.ByteString     Network.Unexceptional.Bytes+    Network.Unexceptional.ByteString     Network.Unexceptional.Chunks     Network.Unexceptional.MutableBytes     Network.Unexceptional.Types+   build-depends:-    , base >=4.16.3 && <5-    , posix-api >=0.7-    , error-codes >=0.1.3-    , byteslice >=0.2.8-    , network >=3.1-    , primitive >=0.9-    , primitive-addr >=0.1.0.2-    , bytestring >=0.11.4-    , stm >=2.5.1-  hs-source-dirs: src-  default-language: Haskell2010+    , base            >=4.16.3  && <5+    , byteslice       >=0.2.8+    , bytestring      >=0.11.4+    , error-codes     >=0.1.3+    , network         >=3.1+    , posix-api       >=0.7+    , primitive       >=0.9+    , primitive-addr  >=0.1.0.2+    , stm             >=2.5.1++  hs-source-dirs:  src++source-repository head+  type:     git+  location: git://github.com/byteverse/network-unexceptional.git
src/Network/Unexceptional.hs view
@@ -1,8 +1,7 @@-{-# language BangPatterns #-}-{-# language DuplicateRecordFields #-}-{-# language PatternSynonyms #-}-{-# language LambdaCase #-}-{-# language NamedFieldPuns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}  module Network.Unexceptional   ( accept_@@ -11,43 +10,46 @@   , connectInterruptible   ) where +import Control.Applicative ((<|>))+import Control.Concurrent.STM (STM, TVar) import Control.Exception (mask_) import Control.Monad ((<=<))-import Control.Applicative ((<|>)) import Data.Functor (($>))-import Network.Socket (Socket,SockAddr,mkSocket,withFdSocket,SocketOption(SoError),getSocketOption)-import Network.Socket.Address (SocketAddress,pokeSocketAddress,sizeOfSocketAddress)+import Foreign.C.Error (Errno (Errno))+import Foreign.C.Error.Pattern (pattern EAGAIN, pattern EINPROGRESS, pattern EINTR, pattern EWOULDBLOCK) import Foreign.Marshal.Alloc (allocaBytes)-import Foreign.C.Error (Errno(Errno))-import GHC.Conc (threadWaitRead,threadWaitWrite,threadWaitWriteSTM)-import Foreign.C.Error.Pattern (pattern EWOULDBLOCK,pattern EAGAIN,pattern EINPROGRESS,pattern EINTR)-import System.Posix.Types (Fd(Fd))-import Foreign.Ptr (castPtr,nullPtr)+import Foreign.Ptr (castPtr, nullPtr)+import GHC.Conc (threadWaitRead, threadWaitWrite, threadWaitWriteSTM) import GHC.Exts (Ptr)-import Control.Concurrent.STM (STM,TVar)+import Network.Socket (SockAddr, Socket, SocketOption (SoError), getSocketOption, mkSocket, withFdSocket)+import Network.Socket.Address (SocketAddress, pokeSocketAddress, sizeOfSocketAddress)+import System.Posix.Types (Fd (Fd))  import qualified Control.Concurrent.STM as STM import qualified Linux.Socket as X-import qualified Posix.Socket as X import qualified Network.Socket as N+import qualified Posix.Socket as X --- | Accept a connection. See the documentation in @network@ for @accept@.------ Note: This may leak a file descriptor if an asynchronous exception is--- received while this function is running.+{- | Accept a connection. See the documentation in @network@ for @accept@.++Note: This may leak a file descriptor if an asynchronous exception is+received while this function is running.+-} accept_ :: Socket -> IO (Either Errno Socket) accept_ listing_sock = withFdSocket listing_sock $ \listing_fd -> do   let acceptLoop = do         threadWaitRead (Fd listing_fd)         X.uninterruptibleAccept4_ (Fd listing_fd) (X.nonblocking <> X.closeOnExec) >>= \case-          Left e -> if e == EAGAIN || e == EWOULDBLOCK-            then acceptLoop-            else pure (Left e)+          Left e ->+            if e == EAGAIN || e == EWOULDBLOCK+              then acceptLoop+              else pure (Left e)           Right (Fd fd) -> fmap Right (mkSocket fd)   acceptLoop --- | Connect to a socket address. See the documentation in @network@--- for @connect@.+{- | Connect to a socket address. See the documentation in @network@+for @connect@.+-} connect :: Socket -> SockAddr -> IO (Either Errno ()) connect s sa = withSocketAddress sa $ \p_sa sz -> withFdSocket s $ \fd ->   let loop = do@@ -65,12 +67,13 @@             _ -> pure (Left err)    in loop --- | Variant of 'connect' that can be interrupted by setting the interrupt--- variable to @True@. If interrupted in this way, this function returns--- @EAGAIN@. For example, to attempt to connect for no more than 1 second:------ > interrupt <- Control.Concurrent.STM.registerDelay 1_000_000--- > connectInterruptible interrupt sock sockAddr+{- | Variant of 'connect' that can be interrupted by setting the interrupt+variable to @True@. If interrupted in this way, this function returns+@EAGAIN@. For example, to attempt to connect for no more than 1 second:++> interrupt <- Control.Concurrent.STM.registerDelay 1_000_000+> connectInterruptible interrupt sock sockAddr+-} connectInterruptible :: TVar Bool -> Socket -> SockAddr -> IO (Either Errno ()) connectInterruptible !interrupt s sa = withSocketAddress sa $ \p_sa sz -> withFdSocket s $ \fd ->   let loop = do@@ -79,19 +82,20 @@           Right _ -> pure (Right ())           Left err -> case err of             EINTR -> loop-            EINPROGRESS -> waitUntilWriteable interrupt (Fd fd) >>= \case-              Interrupted -> pure (Left EAGAIN)-              Ready -> do-                errB <- getSocketOption s SoError-                case errB of-                  0 -> pure (Right ())-                  _ -> pure (Left (Errno (fromIntegral errB)))+            EINPROGRESS ->+              waitUntilWriteable interrupt (Fd fd) >>= \case+                Interrupted -> pure (Left EAGAIN)+                Ready -> do+                  errB <- getSocketOption s SoError+                  case errB of+                    0 -> pure (Right ())+                    _ -> pure (Left (Errno (fromIntegral errB)))             _ -> pure (Left err)    in loop  -- Copied this from the network library. TODO: See if network can -- just export this.-withSocketAddress :: SocketAddress sa => sa -> (Ptr sa -> Int -> IO a) -> IO a+withSocketAddress :: (SocketAddress sa) => sa -> (Ptr sa -> Int -> IO a) -> IO a withSocketAddress addr f = do   let sz = sizeOfSocketAddress addr   if sz == 0@@ -105,25 +109,26 @@  waitUntilWriteable :: TVar Bool -> Fd -> IO Outcome waitUntilWriteable !interrupt !fd = do-  (isReadyAction,deregister) <- threadWaitWriteSTM fd+  (isReadyAction, deregister) <- threadWaitWriteSTM fd   outcome <- STM.atomically $ (isReadyAction $> Ready) <|> (checkFinished interrupt $> Interrupted)   deregister   pure outcome --- | Create a socket. See the documentation in @network@ for @socket@.------ There is no interruptible variant of this function because it cannot--- block. (It does not actually perform network activity.)+{- | Create a socket. See the documentation in @network@ for @socket@.++There is no interruptible variant of this function because it cannot+block. (It does not actually perform network activity.)+-} socket ::-     N.Family         -- Family Name (usually AF_INET)-  -> N.SocketType     -- Socket Type (usually Stream)-  -> N.ProtocolNumber -- Protocol Number (getProtocolByName to find value)-  -> IO (Either Errno Socket)      -- Unconnected Socket+  N.Family -> -- Family Name (usually AF_INET)+  N.SocketType -> -- Socket Type (usually Stream)+  N.ProtocolNumber -> -- Protocol Number (getProtocolByName to find value)+  IO (Either Errno Socket) -- Unconnected Socket socket !fam !stype !protocol = case stype of   N.Stream -> finish X.stream   N.Datagram -> finish X.datagram   _ -> fail "Network.Unexceptional.socket: Currently only supports stream and datagram types"-  where+ where   finish !sockTy = mask_ $ do     X.uninterruptibleSocket (X.Family (N.packFamily fam)) (X.applySocketFlags (X.closeOnExec <> X.nonblocking) sockTy) (X.Protocol protocol) >>= \case       Left err -> pure (Left err)
src/Network/Unexceptional/ByteArray.hs view
@@ -1,38 +1,28 @@-{-# language BangPatterns #-}-{-# language DuplicateRecordFields #-}-{-# language PatternSynonyms #-}-{-# language LambdaCase #-}-{-# language NamedFieldPuns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}  module Network.Unexceptional.ByteArray   ( receiveExactly   , receiveFromInterruptible   ) where -import Control.Exception (throwIO)-import Control.Monad (when)+import Control.Concurrent.STM (TVar)+import Data.Bytes.Types (MutableBytes (MutableBytes)) import Data.Primitive (ByteArray)-import Data.Bytes.Types (Bytes(Bytes),MutableBytes(MutableBytes)) import Foreign.C.Error (Errno)-import Foreign.C.Error.Pattern (pattern EWOULDBLOCK,pattern EAGAIN)-import GHC.Conc (threadWaitWrite) import Network.Socket (Socket)-import System.Posix.Types (Fd(Fd))-import Control.Concurrent.STM (TVar) -import qualified Network.Unexceptional.Types as Types-import qualified Posix.Socket as X-import qualified Linux.Socket as X-import qualified Data.Bytes.Types-import qualified Network.Socket as S import qualified Data.Primitive as PM+import qualified Network.Socket as S import qualified Network.Unexceptional.MutableBytes as MB  -- | Blocks until an exact number of bytes has been received. receiveExactly ::-     Socket-  -> Int -- ^ Exact number of bytes to receive, must be greater than zero-  -> IO (Either Errno ByteArray)+  Socket ->+  -- | Exact number of bytes to receive, must be greater than zero+  Int ->+  IO (Either Errno ByteArray) receiveExactly !s !n = do   dst <- PM.newByteArray n   MB.receiveExactly s (MutableBytes dst 0 n) >>= \case@@ -42,15 +32,16 @@       pure (Right dst')  receiveFromInterruptible ::-     TVar Bool-  -> Socket-  -> Int -- ^ Maximum number of bytes to receive.-  -> IO (Either Errno (ByteArray, S.SockAddr))+  TVar Bool ->+  Socket ->+  -- | Maximum number of bytes to receive.+  Int ->+  IO (Either Errno (ByteArray, S.SockAddr)) receiveFromInterruptible !intr s !n = do   dst <- PM.newByteArray n   MB.receiveFromInterruptible intr s (MutableBytes dst 0 n) >>= \case     Left err -> pure (Left err)-    Right (sz,sockAddr) -> do+    Right (sz, sockAddr) -> do       PM.shrinkMutableByteArray dst sz       dst' <- PM.unsafeFreezeByteArray dst       pure (Right (dst', sockAddr))
src/Network/Unexceptional/ByteString.hs view
@@ -1,9 +1,8 @@-{-# language BangPatterns #-}-{-# language DuplicateRecordFields #-}-{-# language MagicHash #-}-{-# language PatternSynonyms #-}-{-# language LambdaCase #-}-{-# language NamedFieldPuns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PatternSynonyms #-}  module Network.Unexceptional.ByteString   ( send@@ -14,21 +13,21 @@   ) where  import Control.Applicative ((<|>))-import Control.Concurrent.STM (STM,TVar)-import GHC.Conc (threadWaitWrite,threadWaitWriteSTM)-import Control.Monad (when)-import Control.Monad ((<=<))-import Data.ByteString.Internal (ByteString(BS))-import Data.Bytes.Types (MutableBytes(MutableBytes))+import Control.Concurrent.STM (STM, TVar)+import Control.Monad (when, (<=<))+import Data.ByteString.Internal (ByteString (BS))+import Data.Bytes.Types (MutableBytes (MutableBytes)) import Data.Functor (($>))-import Data.Primitive (ByteArray(ByteArray))-import Data.Primitive.Addr (Addr(Addr),plusAddr)+import Data.Primitive (ByteArray (ByteArray))+import Data.Primitive.Addr (Addr (Addr), plusAddr) import Foreign.C.Error (Errno)-import Foreign.C.Error.Pattern (pattern EWOULDBLOCK,pattern EAGAIN)-import GHC.ForeignPtr (ForeignPtr(ForeignPtr),ForeignPtrContents(PlainPtr))+import Foreign.C.Error.Pattern (pattern EAGAIN, pattern EWOULDBLOCK)+import GHC.Conc (threadWaitWrite, threadWaitWriteSTM)+import GHC.ForeignPtr (ForeignPtr (ForeignPtr), ForeignPtrContents (PlainPtr)) import Network.Socket (Socket)-import System.Posix.Types (Fd(Fd))+import System.Posix.Types (Fd (Fd)) +import qualified Control.Concurrent.STM as STM import qualified Data.ByteString.Unsafe as ByteString import qualified Data.Primitive as PM import qualified GHC.Exts as Exts@@ -36,30 +35,31 @@ import qualified Network.Socket as S import qualified Network.Unexceptional.MutableBytes as MB import qualified Posix.Socket as X-import qualified Control.Concurrent.STM as STM --- | Send the entire byte sequence. This call POSIX @send@ in a loop--- until all of the bytes have been sent.+{- | Send the entire byte sequence. This call POSIX @send@ in a loop+until all of the bytes have been sent.+-} send ::-     Socket-  -> ByteString-  -> IO (Either Errno ())+  Socket ->+  ByteString ->+  IO (Either Errno ()) send s !b =-  S.withFdSocket s $ \fd -> ByteString.unsafeUseAsCStringLen b $ \(PM.Ptr ptr,len) ->-  -- We attempt the first send without testing if the socket is in-  -- ready for writes. This is because it is uncommon for the transmit-  -- buffer to already be full.-  sendLoop (Fd fd) (Addr ptr) len+  S.withFdSocket s $ \fd -> ByteString.unsafeUseAsCStringLen b $ \(PM.Ptr ptr, len) ->+    -- We attempt the first send without testing if the socket is in+    -- ready for writes. This is because it is uncommon for the transmit+    -- buffer to already be full.+    sendLoop (Fd fd) (Addr ptr) len  -- does not wait for file descriptor to be ready sendLoop :: Fd -> Addr -> Int -> IO (Either Errno ()) sendLoop !fd !addr !len =   X.uninterruptibleSend fd addr (fromIntegral len) (X.noSignal <> X.dontWait) >>= \case-    Left e -> if e == EAGAIN || e == EWOULDBLOCK-      then do-        threadWaitWrite fd-        sendLoop fd addr len-      else pure (Left e)+    Left e ->+      if e == EAGAIN || e == EWOULDBLOCK+        then do+          threadWaitWrite fd+          sendLoop fd addr len+        else pure (Left e)     Right sentSzC ->       let sentSz = fromIntegral sentSzC :: Int        in case compare sentSz len of@@ -67,29 +67,32 @@             LT -> sendLoop fd (plusAddr addr sentSz) (len - sentSz)             GT -> fail "Network.Unexceptional.ByteString.sendLoop: send claimed to send too many bytes" --- | Send the entire byte sequence. This call POSIX @send@ in a loop--- until all of the bytes have been sent.+{- | Send the entire byte sequence. This call POSIX @send@ in a loop+until all of the bytes have been sent.+-} sendInterruptible ::-     TVar Bool-  -> Socket-  -> ByteString-  -> IO (Either Errno ())-sendInterruptible !interrupt  s !b =-  S.withFdSocket s $ \fd -> ByteString.unsafeUseAsCStringLen b $ \(PM.Ptr ptr,len) ->-  -- We attempt the first send without testing if the socket is in-  -- ready for writes. This is because it is uncommon for the transmit-  -- buffer to already be full.-  sendInterruptibleLoop interrupt (Fd fd) (Addr ptr) len+  TVar Bool ->+  Socket ->+  ByteString ->+  IO (Either Errno ())+sendInterruptible !interrupt s !b =+  S.withFdSocket s $ \fd -> ByteString.unsafeUseAsCStringLen b $ \(PM.Ptr ptr, len) ->+    -- We attempt the first send without testing if the socket is in+    -- ready for writes. This is because it is uncommon for the transmit+    -- buffer to already be full.+    sendInterruptibleLoop interrupt (Fd fd) (Addr ptr) len  -- does not wait for file descriptor to be ready sendInterruptibleLoop :: TVar Bool -> Fd -> Addr -> Int -> IO (Either Errno ()) sendInterruptibleLoop !interrupt !fd !addr !len =   X.uninterruptibleSend fd addr (fromIntegral len) (X.noSignal <> X.dontWait) >>= \case-    Left e -> if e == EAGAIN || e == EWOULDBLOCK-      then waitUntilWriteable interrupt fd >>= \case-        Ready -> sendInterruptibleLoop interrupt fd addr len-        Interrupted -> pure (Left EAGAIN)-      else pure (Left e)+    Left e ->+      if e == EAGAIN || e == EWOULDBLOCK+        then+          waitUntilWriteable interrupt fd >>= \case+            Ready -> sendInterruptibleLoop interrupt fd addr len+            Interrupted -> pure (Left EAGAIN)+        else pure (Left e)     Right sentSzC ->       let sentSz = fromIntegral sentSzC :: Int        in case compare sentSz len of@@ -97,12 +100,14 @@             LT -> sendInterruptibleLoop interrupt fd (plusAddr addr sentSz) (len - sentSz)             GT -> fail "Network.Unexceptional.ByteString.sendInterruptibleLoop: send claimed to send too many bytes" --- | If this returns zero bytes, it means that the peer has--- performed an orderly shutdown.+{- | If this returns zero bytes, it means that the peer has+performed an orderly shutdown.+-} receive ::-     Socket-  -> Int -- ^ Maximum number of bytes to receive-  -> IO (Either Errno ByteString)+  Socket ->+  -- | Maximum number of bytes to receive+  Int ->+  IO (Either Errno ByteString) receive s n = do   dst <- PM.newPinnedByteArray n   MB.receive s (MutableBytes dst 0 n) >>= \case@@ -114,9 +119,10 @@  -- | Blocks until an exact number of bytes has been received. receiveExactly ::-     Socket-  -> Int -- ^ Exact number of bytes to receive, must be greater than zero-  -> IO (Either Errno ByteString)+  Socket ->+  -- | Exact number of bytes to receive, must be greater than zero+  Int ->+  IO (Either Errno ByteString) receiveExactly !s !n = do   dst <- PM.newPinnedByteArray n   MB.receiveExactly s (MutableBytes dst 0 n) >>= \case@@ -127,10 +133,11 @@  -- | Blocks until an exact number of bytes has been received. receiveExactlyInterruptible ::-     TVar Bool-  -> Socket-  -> Int -- ^ Exact number of bytes to receive, must be greater than zero-  -> IO (Either Errno ByteString)+  TVar Bool ->+  Socket ->+  -- | Exact number of bytes to receive, must be greater than zero+  Int ->+  IO (Either Errno ByteString) receiveExactlyInterruptible !intr !s !n = do   dst <- PM.newPinnedByteArray n   MB.receiveExactlyInterruptible intr s (MutableBytes dst 0 n) >>= \case@@ -141,7 +148,7 @@  waitUntilWriteable :: TVar Bool -> Fd -> IO Outcome waitUntilWriteable !interrupt !fd = do-  (isReadyAction,deregister) <- threadWaitWriteSTM fd+  (isReadyAction, deregister) <- threadWaitWriteSTM fd   outcome <- STM.atomically $ (isReadyAction $> Ready) <|> (checkFinished interrupt $> Interrupted)   deregister   pure outcome
src/Network/Unexceptional/Bytes.hs view
@@ -1,8 +1,8 @@-{-# language BangPatterns #-}-{-# language DuplicateRecordFields #-}-{-# language PatternSynonyms #-}-{-# language LambdaCase #-}-{-# language NamedFieldPuns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PatternSynonyms #-}  module Network.Unexceptional.Bytes   ( send@@ -12,19 +12,18 @@   ) where  import Control.Applicative ((<|>))-import Control.Concurrent.STM (STM,TVar)+import Control.Concurrent.STM (STM, TVar) import Control.Exception (throwIO)-import Control.Monad ((<=<))-import Control.Monad (when)-import Data.Bytes.Types (Bytes(Bytes),MutableBytes(MutableBytes))+import Control.Monad (when, (<=<))+import Data.Bytes.Types (Bytes (Bytes), MutableBytes (MutableBytes)) import Data.Functor (($>))-import Data.Primitive (MutableByteArray,ByteArray)+import Data.Primitive (ByteArray, MutableByteArray) import Foreign.C.Error (Errno)-import Foreign.C.Error.Pattern (pattern EWOULDBLOCK,pattern EAGAIN)-import GHC.Conc (threadWaitWrite,threadWaitWriteSTM)+import Foreign.C.Error.Pattern (pattern EAGAIN, pattern EWOULDBLOCK)+import GHC.Conc (threadWaitWrite, threadWaitWriteSTM) import GHC.Exts (RealWorld) import Network.Socket (Socket)-import System.Posix.Types (Fd(Fd))+import System.Posix.Types (Fd (Fd))  import qualified Control.Concurrent.STM as STM import qualified Data.Bytes.Types@@ -35,16 +34,17 @@ import qualified Network.Unexceptional.Types as Types import qualified Posix.Socket as X --- | Send the entire byte sequence. This call POSIX @send@ in a loop--- until all of the bytes have been sent.------ If this is passed the empty byte sequence, it doesn't actually call--- POSIX @send()@. It just returns that it succeeded.+{- | Send the entire byte sequence. This call POSIX @send@ in a loop+until all of the bytes have been sent.++If this is passed the empty byte sequence, it doesn't actually call+POSIX @send()@. It just returns that it succeeded.+-} send ::-     Socket-  -> Bytes-  -> IO (Either Errno ())-send s Bytes{array,offset,length=len} = case len of+  Socket ->+  Bytes ->+  IO (Either Errno ())+send s Bytes {array, offset, length = len} = case len of   0 -> pure (Right ())   _ -> S.withFdSocket s $ \fd ->     -- We attempt the first send without testing if the socket is in@@ -56,11 +56,12 @@ sendLoop :: Fd -> ByteArray -> Int -> Int -> IO (Either Errno ()) sendLoop !fd !arr !off !len =   X.uninterruptibleSendByteArray fd arr off (fromIntegral len) (X.noSignal <> X.dontWait) >>= \case-    Left e -> if e == EAGAIN || e == EWOULDBLOCK-      then do-        threadWaitWrite fd-        sendLoop fd arr off len-      else pure (Left e)+    Left e ->+      if e == EAGAIN || e == EWOULDBLOCK+        then do+          threadWaitWrite fd+          sendLoop fd arr off len+        else pure (Left e)     Right sentSzC ->       let sentSz = fromIntegral sentSzC :: Int        in case compare sentSz len of@@ -71,11 +72,13 @@ sendInterruptibleLoop :: TVar Bool -> Fd -> ByteArray -> Int -> Int -> IO (Either Errno ()) sendInterruptibleLoop !interrupt !fd !arr !off !len =   X.uninterruptibleSendByteArray fd arr off (fromIntegral len) (X.noSignal <> X.dontWait) >>= \case-    Left e -> if e == EAGAIN || e == EWOULDBLOCK-      then waitUntilWriteable interrupt fd >>= \case-        Ready -> sendInterruptibleLoop interrupt fd arr off len-        Interrupted -> pure (Left EAGAIN)-      else pure (Left e)+    Left e ->+      if e == EAGAIN || e == EWOULDBLOCK+        then+          waitUntilWriteable interrupt fd >>= \case+            Ready -> sendInterruptibleLoop interrupt fd arr off len+            Interrupted -> pure (Left EAGAIN)+        else pure (Left e)     Right sentSzC ->       let sentSz = fromIntegral sentSzC :: Int        in case compare sentSz len of@@ -85,19 +88,20 @@  -- | Variant of 'send' that fails with @EAGAIN@ if the interrupt ever becomes true. sendInterruptible ::-     TVar Bool-  -> Socket-  -> Bytes-  -> IO (Either Errno ())-sendInterruptible !interrupt s Bytes{array,offset,length=len} = case len of+  TVar Bool ->+  Socket ->+  Bytes ->+  IO (Either Errno ())+sendInterruptible !interrupt s Bytes {array, offset, length = len} = case len of   0 -> pure (Right ())-  _ -> STM.readTVarIO interrupt >>= \case-    True -> pure (Left EAGAIN)-    False -> S.withFdSocket s $ \fd ->-      -- We attempt the first send without testing if the socket is in-      -- ready for writes. This is because it is uncommon for the transmit-      -- buffer to already be full.-      sendInterruptibleLoop interrupt (Fd fd) array offset len+  _ ->+    STM.readTVarIO interrupt >>= \case+      True -> pure (Left EAGAIN)+      False -> S.withFdSocket s $ \fd ->+        -- We attempt the first send without testing if the socket is in+        -- ready for writes. This is because it is uncommon for the transmit+        -- buffer to already be full.+        sendInterruptibleLoop interrupt (Fd fd) array offset len  data Outcome = Ready | Interrupted @@ -106,40 +110,47 @@  waitUntilWriteable :: TVar Bool -> Fd -> IO Outcome waitUntilWriteable !interrupt !fd = do-  (isReadyAction,deregister) <- threadWaitWriteSTM fd+  (isReadyAction, deregister) <- threadWaitWriteSTM fd   outcome <- STM.atomically $ (isReadyAction $> Ready) <|> (checkFinished interrupt $> Interrupted)   deregister   pure outcome --- | If this returns zero bytes, it means that the peer has--- performed an orderly shutdown.-receive :: -     Socket-  -> Int -- ^ Maximum number of bytes to receive-  -> IO (Either Errno Bytes)-receive s n = if n > 0-  then do-    dst <- PM.newByteArray n-    MB.receive s (MutableBytes dst 0 n) >>= handleRececeptionResult dst n-  else throwIO Types.NonpositiveReceptionSize+{- | If this returns zero bytes, it means that the peer has+performed an orderly shutdown.+-}+receive ::+  Socket ->+  -- | Maximum number of bytes to receive+  Int ->+  IO (Either Errno Bytes)+receive s n =+  if n > 0+    then do+      dst <- PM.newByteArray n+      MB.receive s (MutableBytes dst 0 n) >>= handleRececeptionResult dst n+    else throwIO Types.NonpositiveReceptionSize --- | If this returns zero bytes, it means that the peer has--- performed an orderly shutdown.-receiveInterruptible :: -     TVar Bool -- ^ Interrupt-  -> Socket-  -> Int -- ^ Maximum number of bytes to receive-  -> IO (Either Errno Bytes)-receiveInterruptible !interrupt s n = if n > 0-  then do-    dst <- PM.newByteArray n-    MB.receiveInterruptible interrupt s (MutableBytes dst 0 n) >>= handleRececeptionResult dst n-  else throwIO Types.NonpositiveReceptionSize+{- | If this returns zero bytes, it means that the peer has+performed an orderly shutdown.+-}+receiveInterruptible ::+  -- | Interrupt+  TVar Bool ->+  Socket ->+  -- | Maximum number of bytes to receive+  Int ->+  IO (Either Errno Bytes)+receiveInterruptible !interrupt s n =+  if n > 0+    then do+      dst <- PM.newByteArray n+      MB.receiveInterruptible interrupt s (MutableBytes dst 0 n) >>= handleRececeptionResult dst n+    else throwIO Types.NonpositiveReceptionSize  handleRececeptionResult :: MutableByteArray RealWorld -> Int -> Either Errno Int -> IO (Either Errno Bytes) handleRececeptionResult !dst !n x = case x of   Left e -> pure (Left e)   Right m -> do     when (m < n) (PM.shrinkMutableByteArray dst m)-    dst' <- PM.unsafeFreezeByteArray dst +    dst' <- PM.unsafeFreezeByteArray dst     pure (Right (Bytes dst' 0 m))
src/Network/Unexceptional/Chunks.hs view
@@ -1,33 +1,31 @@-{-# language BangPatterns #-}-{-# language DuplicateRecordFields #-}-{-# language PatternSynonyms #-}-{-# language LambdaCase #-}-{-# language NamedFieldPuns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DuplicateRecordFields #-}  module Network.Unexceptional.Chunks   ( send   , sendInterruptible   ) where +import Control.Concurrent.STM (TVar)+import Data.Bytes.Chunks (Chunks) import Foreign.C.Error (Errno) import Network.Socket (Socket)-import Data.Bytes.Chunks (Chunks)-import Control.Concurrent.STM (TVar)  import qualified Data.Bytes.Chunks as Chunks import qualified Network.Unexceptional.Bytes as NB --- | Send the entire byte sequence. This call POSIX @send@ in a loop--- until all of the bytes have been sent.+{- | Send the entire byte sequence. This call POSIX @send@ in a loop+until all of the bytes have been sent.+-} send ::-     Socket-  -> Chunks-  -> IO (Either Errno ())+  Socket ->+  Chunks ->+  IO (Either Errno ()) send !s cs = NB.send s (Chunks.concat cs)  sendInterruptible ::-     TVar Bool-  -> Socket-  -> Chunks-  -> IO (Either Errno ())+  TVar Bool ->+  Socket ->+  Chunks ->+  IO (Either Errno ()) sendInterruptible !interrupt !s cs = NB.sendInterruptible interrupt s (Chunks.concat cs)
src/Network/Unexceptional/MutableBytes.hs view
@@ -1,61 +1,64 @@-{-# language BangPatterns #-}-{-# language DuplicateRecordFields #-}-{-# language LambdaCase #-}-{-# language NamedFieldPuns #-}-{-# language PatternSynonyms #-}-{-# language ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-} --- | Note: The functions that are designated as being intended for stream--- sockets convert a reception length of zero to an non-standard @EOI@ error--- code. Datagram reception functions do not do this.+{- | Note: The functions that are designated as being intended for stream+sockets convert a reception length of zero to an non-standard @EOI@ error+code. Datagram reception functions do not do this.+-} module Network.Unexceptional.MutableBytes   ( -- * Stream Sockets     receive   , receiveInterruptible   , receiveExactly   , receiveExactlyInterruptible+     -- * Datagram Sockets   , receiveFromInterruptible   ) where  import Control.Applicative ((<|>))-import Control.Concurrent.STM (STM,TVar)+import Control.Concurrent.STM (STM, TVar) import Control.Exception (throwIO) import Control.Monad ((<=<))-import Data.Bytes.Types (MutableBytes(MutableBytes))+import Data.Bytes.Types (MutableBytes (MutableBytes)) import Data.Functor (($>)) import Data.Primitive (MutableByteArray)-import Foreign.C.Types (CSize,CInt) import Foreign.C.Error (Errno)-import Foreign.C.Error.Pattern (pattern EEOI)-import Foreign.C.Error.Pattern (pattern EWOULDBLOCK,pattern EAGAIN)-import Foreign.Storable (poke)+import Foreign.C.Error.Pattern+  ( pattern EAGAIN+  , pattern EEOI+  , pattern EWOULDBLOCK+  )+import Foreign.C.Types (CSize) import Foreign.Ptr (castPtr)-import Foreign.Marshal.Alloc (allocaBytes,alloca)-import GHC.Conc (threadWaitRead,threadWaitReadSTM)-import GHC.Exts (RealWorld,Ptr)-import Network.Socket (Socket,SockAddr)+import GHC.Conc (threadWaitRead, threadWaitReadSTM)+import GHC.Exts (Ptr, RealWorld)+import Network.Socket (SockAddr, Socket) import Network.Socket.Address (peekSocketAddress)-import System.Posix.Types (Fd(Fd))-import Data.Word (Word8)+import System.Posix.Types (Fd (Fd)) -import qualified Data.Primitive as PM-import qualified Data.Primitive.Ptr as PM import qualified Control.Concurrent.STM as STM import qualified Data.Bytes.Types+import qualified Data.Primitive as PM import qualified Linux.Socket as X import qualified Network.Socket as S import qualified Network.Unexceptional.Types as Types import qualified Posix.Socket as X --- | Receive bytes from a socket. Receives at most N bytes, where N--- is the size of the buffer. Returns the number of bytes that were--- actually received.+{- | Receive bytes from a socket. Receives at most N bytes, where N+is the size of the buffer. Returns the number of bytes that were+actually received.+-} receive ::-     Socket-  -> MutableBytes RealWorld -- ^ Slice of a buffer-  -> IO (Either Errno Int)-receive s MutableBytes{array,offset,length=len} =+  Socket ->+  -- | Slice of a buffer+  MutableBytes RealWorld ->+  IO (Either Errno Int)+receive s MutableBytes {array, offset, length = len} =   if len > 0     then S.withFdSocket s $ \fd ->       -- We attempt the first receive without testing if the socket is@@ -63,15 +66,17 @@       receiveLoop (Fd fd) array offset len     else throwIO Types.NonpositiveReceptionSize --- | Receive bytes from a socket. Receives at most N bytes, where N--- is the size of the buffer. Returns the number of bytes that were--- actually received.+{- | Receive bytes from a socket. Receives at most N bytes, where N+is the size of the buffer. Returns the number of bytes that were+actually received.+-} receiveFromInterruptible ::-     TVar Bool-  -> Socket-  -> MutableBytes RealWorld -- ^ Slice of a buffer-  -> IO (Either Errno (Int, SockAddr))-receiveFromInterruptible !interrupt s MutableBytes{array,offset,length=len} =+  TVar Bool ->+  Socket ->+  -- | Slice of a buffer+  MutableBytes RealWorld ->+  IO (Either Errno (Int, SockAddr))+receiveFromInterruptible !interrupt s MutableBytes {array, offset, length = len} =   if len > 0     then S.withFdSocket s $ \fd -> do       -- We attempt the first receive without testing if the socket is@@ -80,20 +85,22 @@     else throwIO Types.NonpositiveReceptionSize  receiveFromInterruptibleLoop ::-     TVar Bool-  -> Fd-  -> MutableByteArray RealWorld-  -> Int-  -> Int-  -> IO (Either Errno (Int, SockAddr))-receiveFromInterruptibleLoop !intr !fd !dst !doff !dlen = +  TVar Bool ->+  Fd ->+  MutableByteArray RealWorld ->+  Int ->+  Int ->+  IO (Either Errno (Int, SockAddr))+receiveFromInterruptibleLoop !intr !fd !dst !doff !dlen =   X.uninterruptibleReceiveFromMutableByteArray fd dst doff (fromIntegral dlen :: CSize) mempty 128 >>= \case-    Left e -> if e == EAGAIN || e == EWOULDBLOCK-      then waitUntilReadable intr fd >>= \case-        Ready -> receiveFromInterruptibleLoop intr fd dst doff dlen-        Interrupted -> pure (Left EAGAIN)-      else pure (Left e)-    Right (sockAddrSz,X.SocketAddress sockAddr,recvSzC) -> do+    Left e ->+      if e == EAGAIN || e == EWOULDBLOCK+        then+          waitUntilReadable intr fd >>= \case+            Ready -> receiveFromInterruptibleLoop intr fd dst doff dlen+            Interrupted -> pure (Left EAGAIN)+        else pure (Left e)+    Right (sockAddrSz, X.SocketAddress sockAddr, recvSzC) -> do       let sockAddrSzI = fromIntegral sockAddrSz :: Int       pinned <- PM.newPinnedByteArray sockAddrSzI       PM.copyByteArray pinned 0 sockAddr 0 sockAddrSzI@@ -106,11 +113,13 @@             _ -> pure (Right (recvSz, sockAddrNetwork))  receiveInterruptible ::-     TVar Bool -- ^ Interrupt-  -> Socket-  -> MutableBytes RealWorld -- ^ Slice of a buffer-  -> IO (Either Errno Int)-receiveInterruptible !interrupt s MutableBytes{array,offset,length=len} =+  -- | Interrupt+  TVar Bool ->+  Socket ->+  -- | Slice of a buffer+  MutableBytes RealWorld ->+  IO (Either Errno Int)+receiveInterruptible !interrupt s MutableBytes {array, offset, length = len} =   if len > 0     then S.withFdSocket s $ \fd ->       -- We attempt the first receive without testing if the socket is@@ -123,11 +132,12 @@ receiveLoop :: Fd -> MutableByteArray RealWorld -> Int -> Int -> IO (Either Errno Int) receiveLoop !fd !arr !off !len =   X.uninterruptibleReceiveMutableByteArray fd arr off (fromIntegral len) X.dontWait >>= \case-    Left e -> if e == EAGAIN || e == EWOULDBLOCK-      then do-        threadWaitRead fd-        receiveLoop fd arr off len-      else pure (Left e)+    Left e ->+      if e == EAGAIN || e == EWOULDBLOCK+        then do+          threadWaitRead fd+          receiveLoop fd arr off len+        else pure (Left e)     Right recvSzC ->       let recvSz = fromIntegral recvSzC :: Int        in case recvSz of@@ -141,11 +151,13 @@ receiveInterruptibleLoop :: TVar Bool -> Fd -> MutableByteArray RealWorld -> Int -> Int -> IO (Either Errno Int) receiveInterruptibleLoop !interrupt !fd !arr !off !len =   X.uninterruptibleReceiveMutableByteArray fd arr off (fromIntegral len) X.dontWait >>= \case-    Left e -> if e == EAGAIN || e == EWOULDBLOCK-      then waitUntilReadable interrupt fd >>= \case-        Ready -> receiveInterruptibleLoop interrupt fd arr off len-        Interrupted -> pure (Left EAGAIN)-      else pure (Left e)+    Left e ->+      if e == EAGAIN || e == EWOULDBLOCK+        then+          waitUntilReadable interrupt fd >>= \case+            Ready -> receiveInterruptibleLoop interrupt fd arr off len+            Interrupted -> pure (Left EAGAIN)+        else pure (Left e)     Right recvSzC ->       let recvSz = fromIntegral recvSzC :: Int        in case recvSz of@@ -161,41 +173,45 @@  waitUntilReadable :: TVar Bool -> Fd -> IO Outcome waitUntilReadable !interrupt !fd = do-  (isReadyAction,deregister) <- threadWaitReadSTM fd+  (isReadyAction, deregister) <- threadWaitReadSTM fd   outcome <- STM.atomically $ (isReadyAction $> Ready) <|> (checkFinished interrupt $> Interrupted)   deregister   pure outcome  -- | Blocks until an exact number of bytes has been received. receiveExactly ::-     Socket-  -> MutableBytes RealWorld-     -- ^ Length is the exact number of bytes to receive,-     -- must be greater than zero.-  -> IO (Either Errno ())-receiveExactly s (MutableBytes dst off0 n) = if n > 0-  then do-    let loop !ix !remaining = case remaining of-          0 -> pure (Right ())-          _ -> receive s (MutableBytes dst ix remaining) >>= \case-            Left e -> pure (Left e)-            Right k -> loop (ix + k) (remaining - k)-    loop off0 n-  else throwIO Types.NonpositiveReceptionSize+  Socket ->+  -- | Length is the exact number of bytes to receive,+  -- must be greater than zero.+  MutableBytes RealWorld ->+  IO (Either Errno ())+receiveExactly s (MutableBytes dst off0 n) =+  if n > 0+    then do+      let loop !ix !remaining = case remaining of+            0 -> pure (Right ())+            _ ->+              receive s (MutableBytes dst ix remaining) >>= \case+                Left e -> pure (Left e)+                Right k -> loop (ix + k) (remaining - k)+      loop off0 n+    else throwIO Types.NonpositiveReceptionSize  receiveExactlyInterruptible ::-     TVar Bool-  -> Socket-  -> MutableBytes RealWorld-     -- ^ Length is the exact number of bytes to receive,-     -- must be greater than zero.-  -> IO (Either Errno ())-receiveExactlyInterruptible !intr !s (MutableBytes dst off0 n) = if n > 0-  then do-    let loop !ix !remaining = case remaining of-          0 -> pure (Right ())-          _ -> receiveInterruptible intr s (MutableBytes dst ix remaining) >>= \case-            Left e -> pure (Left e)-            Right k -> loop (ix + k) (remaining - k)-    loop off0 n-  else throwIO Types.NonpositiveReceptionSize+  TVar Bool ->+  Socket ->+  -- | Length is the exact number of bytes to receive,+  -- must be greater than zero.+  MutableBytes RealWorld ->+  IO (Either Errno ())+receiveExactlyInterruptible !intr !s (MutableBytes dst off0 n) =+  if n > 0+    then do+      let loop !ix !remaining = case remaining of+            0 -> pure (Right ())+            _ ->+              receiveInterruptible intr s (MutableBytes dst ix remaining) >>= \case+                Left e -> pure (Left e)+                Right k -> loop (ix + k) (remaining - k)+      loop off0 n+    else throwIO Types.NonpositiveReceptionSize
src/Network/Unexceptional/Types.hs view
@@ -1,41 +1,44 @@-{-# language DerivingStrategies #-}-{-# language DeriveAnyClass #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-} --- | All of the exceptions defined in this module indicate either misuse--- of the library or an implementation mistake in the libary.+{- | All of the exceptions defined in this module indicate either misuse+of the library or an implementation mistake in the libary.+-} module Network.Unexceptional.Types-  ( NonpositiveReceptionSize(..)-  , ReceivedTooManyBytes(..)+  ( NonpositiveReceptionSize (..)+  , ReceivedTooManyBytes (..)   ) where  import Control.Exception (Exception) --- | Thrown when any of the @receive@ functions are called with--- a length less than 1. This includes zero and any negative numbers.--- This indicates misuse of the API and is not considered a recoverable--- exception.------ Requesting a negative number is bytes is clear misuse of the API.--- But what about zero? This deserves some justification. POSIX allows--- requesting zero bytes with @recv@, and the result is that it copies--- no bytes into the buffer and returns 0. Essentially, it's a no-op.--- However, the return length 0 is also used to indicate a shutdown.--- This overloaded meaning of the return value 0 makes it difficult to--- interpret what it means. (It would be nice if @recv@ instead set the--- error code to something indicating EOF when the peer had shutdown,--- but we live in a more difficult world.) To correctly interpret the--- meaning of return length 0, an application must consider what buffer--- size it passed to @recv@. To prevent the caller from having to do this--- bookkeeping, this library simply forbids requesting 0 bytes with @recv@.--- If you do request 0 bytes with @recv@, you get this exception, and you--- can fix the part of your program that failed to satisfy the--- precondition.+{- | Thrown when any of the @receive@ functions are called with+a length less than 1. This includes zero and any negative numbers.+This indicates misuse of the API and is not considered a recoverable+exception.++Requesting a negative number is bytes is clear misuse of the API.+But what about zero? This deserves some justification. POSIX allows+requesting zero bytes with @recv@, and the result is that it copies+no bytes into the buffer and returns 0. Essentially, it's a no-op.+However, the return length 0 is also used to indicate a shutdown.+This overloaded meaning of the return value 0 makes it difficult to+interpret what it means. (It would be nice if @recv@ instead set the+error code to something indicating EOF when the peer had shutdown,+but we live in a more difficult world.) To correctly interpret the+meaning of return length 0, an application must consider what buffer+size it passed to @recv@. To prevent the caller from having to do this+bookkeeping, this library simply forbids requesting 0 bytes with @recv@.+If you do request 0 bytes with @recv@, you get this exception, and you+can fix the part of your program that failed to satisfy the+precondition.+-} data NonpositiveReceptionSize = NonpositiveReceptionSize   deriving stock (Show)   deriving anyclass (Exception) --- | This indicates a mistake in this library. Open an issue if this--- exception is ever thrown. +{- | This indicates a mistake in this library. Open an issue if this+exception is ever thrown.+-} data ReceivedTooManyBytes = ReceivedTooManyBytes   deriving stock (Show)   deriving anyclass (Exception)