packages feed

sockets 0.3.1.0 → 0.4.0.0

raw patch · 74 files changed

+6060/−2845 lines, 74 filesdep +byteslicedep +primitive-addrdep +primitive-checkeddep ~bytestringdep ~error-codesdep ~posix-api

Dependencies added: byteslice, primitive-addr, primitive-checked, primitive-offset, primitive-unlifted

Dependency ranges changed: bytestring, error-codes, posix-api, primitive

Files

+ bench/Http.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import Control.Exception+import Data.Bytes.Types (Bytes(..),MutableBytes(..))+import Data.Char (ord)+import Data.Primitive+import Data.Word+import GHC.Exts (RealWorld)+import Socket.Stream.IPv4 (Connection)+import System.Environment+import System.IO (stderr)+import Text.Read (readMaybe)++import qualified Data.ByteString.Char8 as BC+import qualified Data.Primitive as PM+import qualified GHC.Exts as E+import qualified Net.IPv4 as IPv4+import qualified Socket.Stream.IPv4 as S+import qualified Socket.Stream.Uninterruptible.MutableBytes as Mutable+import qualified Socket.Stream.Uninterruptible.Bytes as Immutable++main :: IO ()+main = do+  portStr <- lookupEnv "PORT"+  let port = maybe 8888 id (readMaybe =<< portStr)+  err <- S.withListener (S.Peer{S.address=IPv4.any,S.port}) $ \lstn _ -> do+    let go = do+          e <- S.forkAcceptedUnmasked lstn+            (\e () -> either handleCloseException pure e)+            (\conn _ -> do+              buf <- PM.newByteArray (2048 - 16)+              echoStage1 conn buf+            )+          case e of+            Left err -> pure err+            Right _ -> go+    go+  either throwIO throwIO err++echoStage1 :: Connection -> MutableByteArray RealWorld -> IO ()+echoStage1 !conn !buffer = do+  Mutable.receiveBetween conn (MutableBytes buffer 0 bufSize) 4 >>= \case+    Left err -> case err of+      -- A shutdown right here is expected for http clients that do not+      -- reuse connections.+      S.ReceiveShutdown -> pure ()+      -- For some reason, wrk resets the connections when it finishes+      -- instead of shutting them down gracefully.+      S.ReceiveReset -> pure ()+      S.ReceiveHostUnreachable -> BC.hPutStrLn stderr "While receiving, peer became unreachable." +    Right n -> echoStage2 conn buffer n++-- precondition: total >= 4+echoStage2 :: Connection -> MutableByteArray RealWorld -> Int -> IO ()+echoStage2 !sock !buffer !total = do+  (w4 :: Word8) <- PM.readByteArray buffer (total - 1)+  (w3 :: Word8) <- PM.readByteArray buffer (total - 2)+  (w2 :: Word8) <- PM.readByteArray buffer (total - 3)+  (w1 :: Word8) <- PM.readByteArray buffer (total - 4)+  if w1 == 13 && w2 == 10 && w3 == 13 && w4 == 10+    then Immutable.send sock (unsliced httpResponse) >>= \case+      Left err -> BC.hPutStrLn stderr (BC.pack (show err))+      Right _ -> echoStage1 sock buffer+    else do+      let remaining = bufSize - total+      if remaining > 0+        then Mutable.receiveOnce sock (MutableBytes buffer total remaining) >>= \case+          Left err -> BC.hPutStrLn stderr (BC.pack (show err))+          Right n -> echoStage2 sock buffer (total + n)+        else BC.hPutStrLn stderr "Buffer exhausted"++unsliced :: ByteArray -> Bytes+unsliced arr = Bytes arr 0 (PM.sizeofByteArray arr)++httpResponse :: ByteArray+httpResponse = E.fromList $ map (fromIntegral . ord)+  "HTTP/1.1 200 OK\r\n\+  \Content-Type: text/html; charset=UTF-8\r\n\+  \Content-Length: 500\r\n\+  \Connection: Keep-Alive\r\n\+  \\r\n"+  +++  replicate 500 (48 :: Word8)++bufSize :: Int+bufSize = 2048 - 16++handleCloseException :: S.CloseException -> IO ()+handleCloseException S.ClosePeerContinuedSending =+  BC.hPutStrLn stderr "Exception: Peer continued sending\n"
example/Main.hs view
@@ -2,15 +2,18 @@ {-# language LambdaCase #-} {-# language OverloadedStrings #-} -import Prelude hiding (log)+import Prelude hiding (log,length)  import Control.Exception (Exception,throwIO) import System.Environment (getArgs) import Data.Primitive (ByteArray(..)) import Control.Monad (replicateM_)+import Data.Bytes.Types (Bytes(..)) -import qualified Socket.Datagram.IPv4.Undestined as DIU+import qualified Socket.Datagram.IPv4.Unconnected as DIU+import qualified Socket.Datagram.Uninterruptible.Bytes as DIU import qualified Socket.Stream.IPv4 as SI+import qualified Socket.Stream.Uninterruptible.Bytes as SI import qualified GHC.Exts as E import qualified Data.Primitive as PM import qualified Data.Primitive.MVar as PM@@ -19,15 +22,24 @@ import qualified Data.ByteString.Short.Internal as SB import qualified Data.ByteString.Char8 as BC import qualified System.Log.FastLogger as FL+import qualified Data.Primitive as PM +-- TODO: Use optparse-applicative to let the user choose+-- between different commands.+ main :: IO () main = udpStdoutServer  gettysburgClient :: IO () gettysburgClient = do   [port] <- getArgs-  unhandled $ SI.withConnection (SI.Endpoint IPv4.loopback (read port)) $ \conn -> do-    unhandled $ SI.sendByteArray conn gettysburgAddress+  unhandled $ SI.withConnection+    (SI.Peer IPv4.loopback (read port)) +    throwOnCloseException $ \conn -> unhandled $ SI.send conn $ Bytes+      { array = gettysburgAddress +      , offset = 0+      , length = PM.sizeofByteArray gettysburgAddress+      }  -- This waits until a single connection is established. It then dumps out -- anything it receives to stdout. When the remote application shuts down@@ -35,11 +47,11 @@ tcpStdoutServer :: IO () tcpStdoutServer = do   FL.withFastLogger (FL.LogStdout 2048) $ \log -> do-    unhandled $ SI.withListener (SI.Endpoint IPv4.loopback 0) $ \listener port -> do+    unhandled $ SI.withListener (SI.Peer IPv4.loopback 0) $ \listener port -> do       log (FL.toLogStr ("Listening on 127.0.0.1:" <> BC.pack (show port) <> "\n============================\n"))-      unhandled $ SI.withAccepted listener $ \conn _ -> do-        let go = SI.receiveBoundedByteArray conn 512 >>= \case-              Left (SI.SocketException SI.Receive SI.RemoteShutdown) -> pure ()+      unhandled $ SI.withAccepted listener throwOnCloseException $ \conn _ -> do+        let go = SI.receiveOnce conn 512 >>= \case+              Left SI.ReceiveShutdown -> pure ()               Left e -> throwIO e               Right (PM.ByteArray arr) -> do                 log (FL.toLogStr (SB.fromShort (SB.SBS arr)))@@ -50,15 +62,18 @@ -- socket, after receiving ten packets. udpStdoutServer :: IO () udpStdoutServer = do-  unhandled $ DIU.withSocket (DIU.Endpoint IPv4.loopback 0) $ \sock port -> do+  unhandled $ DIU.withSocket (DIU.Peer IPv4.loopback 0) $ \sock port -> do     BC.putStrLn ("Receiving datagrams on 127.0.0.1:" <> BC.pack (show port))     replicateM_ 10 $ do-      DIU.Message remote (ByteArray payload) <- unhandled (DIU.receive sock 1024)+      DIU.Message remote (ByteArray payload) <- unhandled (DIU.receiveFromIPv4 sock 1024)       BC.putStrLn ("Datagram from " <> BC.pack (show remote))       BC.putStr (SB.fromShort (SB.SBS payload))  unhandled :: Exception e => IO (Either e a) -> IO a unhandled action = action >>= either throwIO pure++throwOnCloseException :: Either SI.CloseException () -> () -> IO ()+throwOnCloseException e () = either throwIO pure e  gettysburgAddress :: PM.ByteArray gettysburgAddress = PM.ByteArray arr
sockets.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: sockets-version: 0.3.1.0+version: 0.4.0.0 synopsis: High-level network sockets description:   This library provides a high-level abstraction for network sockets. It uses@@ -56,43 +56,423 @@   description: Use sendmmsg and recvmmsg    default: False +flag verbose-errors+  manual: True+  description: More informative messages from internal errors+  default: False+ flag debug   manual: True   description: Print debug output    default: False +flag checked+  manual: True+  description: Add bounds-checking to primitive array operations+  default: False+ flag example   manual: True   description: Build example executables   default: False -library-  exposed-modules:-    Socket.Datagram.IPv4.Undestined-    Socket.Datagram.IPv4.Spoof-    Socket.Stream.IPv4-  other-modules:-    Socket.Stream-    Socket.Datagram-    Socket.Datagram.IPv4.Undestined.Multiple-    Socket.Datagram.IPv4.Undestined.Internal-    Socket.Debug-    Socket.IPv4-    Socket+library sockets-internal   build-depends:-    , base >= 4.11.1.0 && < 5-    , bytestring >= 0.10 && < 0.11-    , error-codes >= 0.1 && < 0.2+    , base >= 4.11.1.0 && <5     , ip >= 1.4.1-    , posix-api >= 0.2.1-    , primitive >= 0.6.4+    , posix-api >=0.3 && <0.4+    , primitive-offset >= 0.2 && <0.3+    , primitive-unlifted >= 0.1 && <0.2+    , primitive-addr >= 0.1 && <0.2     , stm >= 2.4     , text >= 1.2-  hs-source-dirs: src+    , byteslice >=0.1.1 && <0.2+  if flag(checked)+    build-depends: primitive-checked >= 0.7 && <0.8+  else+    build-depends: primitive >= 0.7 && <0.8+  exposed-modules:+    Socket+    Socket.AddrLength+    Socket.Datagram+    Socket.Debug+    Socket.Error+    Socket.EventManager+    Socket.IPv4+    Socket.Stream+    Socket.Bytes+    Socket.Destined.IPv4.MutableBytes+    Socket.Destined.IPv4.Bytes+    Socket.Discard+    Socket.Connected.MutableBytes+    Socket.Connected.Bytes+    Socket.MutableBytes+    Socket.MutableBytes.Peerless+    Socket.MutableBytes.SocketAddressInternet+    Socket.Interruptible+    Socket.Uninterruptible+    Hybrid.Send.MutableBytes.AddrLength   if flag(debug)     hs-source-dirs: src-debug   else     hs-source-dirs: src-production+  if flag(debug) || flag(verbose-errors)+    hs-source-dirs: src-err+  else+    hs-source-dirs: src-noerr+  hs-source-dirs: src-internal+  default-language: Haskell2010+  ghc-options: -O2 -Wall++library sockets-interrupt+  build-depends:+    , base >= 4.11.1.0 && <5+    , error-codes >= 0.1.0.1 && < 0.2+    , stm >= 2.4+    , sockets-internal+  signatures: Socket.Interrupt+  hs-source-dirs: src-interrupt+  default-language: Haskell2010+  ghc-options: -O2 -Wall++library sockets-buffer+  build-depends: base >= 4.11.1.0 && <5+  signatures: Socket.Buffer+  hs-source-dirs: src-buffer+  default-language: Haskell2010+  ghc-options: -O2 -Wall++library sockets-datagram-send+  build-depends:+    , base >= 4.11.1.0 && <5+    , error-codes >= 0.1.0.1 && < 0.2+    , posix-api >=0.3 && <0.4+    , stm >= 2.4+    , sockets-internal+    , sockets-buffer+    , sockets-interrupt+  exposed-modules:+    Datagram.Send.Indefinite+  signatures:+    Datagram.Send+  hs-source-dirs: src-datagram-send+  default-language: Haskell2010+  ghc-options: -O2 -Wall++library sockets-datagram-receive+  build-depends:+    , base >= 4.11.1.0 && <5+    , error-codes >= 0.1.0.1 && < 0.2+    , stm >= 2.4+    , posix-api >=0.3 && <0.4+    , primitive-offset >= 0.2 && <0.3+    , sockets-internal+    , sockets-buffer+    , sockets-interrupt+  exposed-modules:+    Datagram.Receive.Indefinite+  signatures:+    Datagram.Receive+  hs-source-dirs: src-datagram-receive+  default-language: Haskell2010+  ghc-options: -O2 -Wall++-- This is only used as a shim for when the platform does not+-- support recvmmsg. It lets us share code for the interruptible+-- and uninterruptible variants.+library sockets-datagram-receive-many+  build-depends:+    , base >= 4.11.1.0 && <5+    , error-codes >= 0.1.0.1 && < 0.2+    , stm >= 2.4+    , posix-api >=0.3 && <0.4+    , primitive-unlifted >= 0.1 && <0.2+    , byteslice >= 0.1.1+    , sockets-datagram-receive+    , sockets-internal+  if flag(checked)+    build-depends: primitive-checked >= 0.7 && <0.8+  else+    build-depends: primitive >= 0.7 && <0.8+  exposed-modules:+    Datagram.Receive.Many.Indefinite+  hs-source-dirs: src-datagram-receive-many+  mixins:+    sockets-datagram-receive+      (Datagram.Receive.Indefinite as Socket.Datagram.Instantiate)+      requires+      (Socket.Buffer as Socket.MutableBytes)+  default-language: Haskell2010+  ghc-options: -O2 -Wall++library sockets-stream-send+  build-depends:+    , base >= 4.11.1.0 && <5+    , error-codes >= 0.1.0.1 && < 0.2+    , posix-api >=0.3 && <0.4+    , stm >= 2.4+    , sockets-internal+    , sockets-buffer+    , sockets-interrupt+  exposed-modules:+    Stream.Send.Indefinite+  signatures:+    Stream.Send+  hs-source-dirs: src-stream-send+  default-language: Haskell2010+  ghc-options: -O2 -Wall++library sockets-stream-receive+  build-depends:+    , base >= 4.11.1.0 && <5+    , error-codes >= 0.1.0.1 && < 0.2+    , posix-api >=0.3 && <0.4+    , stm >= 2.4+    , sockets-internal+    , sockets-buffer+    , sockets-interrupt+  exposed-modules:+    Stream.Receive.Indefinite+  signatures:+    Stream.Receive+  hs-source-dirs: src-stream-receive+  default-language: Haskell2010+  ghc-options: -O2 -Wall++library sockets-stream-send-two+  build-depends:+    , base >= 4.11.1.0 && <5+    , error-codes >= 0.1.0.1 && < 0.2+    , posix-api >=0.3 && <0.4+    , stm >= 2.4+    , sockets-internal+    , sockets-interrupt+    , sockets-stream-send+  exposed-modules:+    Stream.Send.Two.Indefinite+  signatures:+    Stream.Send.Two+    Stream.Send.B+    Stream.Send.Buffer.A+    Stream.Send.Buffer.B+  mixins:+    sockets-stream-send+      (Stream.Send.Indefinite)+      requires+      (Socket.Buffer as Stream.Send.Buffer.B,+       Stream.Send as Stream.Send.B)+  hs-source-dirs: src-stream-send-two+  default-language: Haskell2010+  ghc-options: -O2 -Wall++-- Here, we partially apply the indefinite packages for+-- stream send and stream receive. The avoids duplication+-- in the public library.+library sockets-stream-bidirectional+  build-depends:+    , base >= 4.11.1.0 && <5+    , error-codes >= 0.1.0.1 && < 0.2+    , stm >= 2.4+    , sockets-internal+    , sockets-stream-send+    , sockets-stream-receive+  reexported-modules:+    , Stream.Send.Indefinite+    , Stream.Receive.Indefinite+  mixins:+      sockets-stream-send (Stream.Send.Indefinite)+    , sockets-stream-receive (Stream.Receive.Indefinite)+  default-language: Haskell2010++library+  exposed-modules:+    Socket.Address+    Socket.Datagram.IPv4.Unconnected+    Socket.Datagram.IPv4.Connected+    Socket.Stream.IPv4+    Socket.Datagram.Interruptible.Bytes+    Socket.Datagram.Interruptible.MutableBytes+    Socket.Datagram.Slab+    Socket.Datagram.Uninterruptible.Bytes+    Socket.Datagram.Uninterruptible.MutableBytes+    Socket.Stream.Interruptible.Addr+    Socket.Stream.Interruptible.ByteString+    Socket.Stream.Interruptible.Bytes+    Socket.Stream.Interruptible.MutableBytes+    Socket.Stream.Interruptible.Hybrid+    Socket.Stream.Uninterruptible.Addr+    Socket.Stream.Uninterruptible.ByteString+    Socket.Stream.Uninterruptible.Bytes+    Socket.Stream.Uninterruptible.MutableBytes+    Socket.Stream.Uninterruptible.Hybrid+  other-modules:+    Socket.Datagram.Interruptible.MutableBytes.Many+    Socket.Datagram.Uninterruptible.MutableBytes.Many+  mixins:+    sockets-datagram-receive-many+      (Datagram.Receive.Many.Indefinite as Socket.Datagram.Uninterruptible.MutableBytes.Receive.Many.Unit)+      requires+      (Datagram.Receive as Socket.MutableBytes.Peerless,+       Socket.Interrupt as Socket.Uninterruptible),+    sockets-datagram-receive-many+      (Datagram.Receive.Many.Indefinite as Socket.Datagram.Uninterruptible.MutableBytes.Receive.Many.IPv4)+      requires+      (Datagram.Receive as Socket.MutableBytes.SocketAddressInternet,+       Socket.Interrupt as Socket.Uninterruptible),+    sockets-datagram-receive-many+      (Datagram.Receive.Many.Indefinite as Socket.Datagram.Interruptible.MutableBytes.Receive.Many.Unit)+      requires+      (Datagram.Receive as Socket.MutableBytes.Peerless,+       Socket.Interrupt as Socket.Interruptible),+    sockets-datagram-receive-many+      (Datagram.Receive.Many.Indefinite as Socket.Datagram.Interruptible.MutableBytes.Receive.Many.IPv4)+      requires+      (Datagram.Receive as Socket.MutableBytes.SocketAddressInternet,+       Socket.Interrupt as Socket.Interruptible),+    sockets-datagram-send+      (Datagram.Send.Indefinite as Socket.Datagram.Uninterruptible.MutableBytes.Send.IPv4)+      requires+      (Datagram.Send as Socket.Destined.IPv4.MutableBytes,+       Socket.Interrupt as Socket.Uninterruptible,+       Socket.Buffer as Socket.MutableBytes),+    sockets-datagram-send+      (Datagram.Send.Indefinite as Socket.Datagram.Uninterruptible.Bytes.Send.Connected)+      requires+      (Datagram.Send as Socket.Connected.Bytes,+       Socket.Interrupt as Socket.Uninterruptible,+       Socket.Buffer as Socket.Bytes),+    sockets-datagram-send+      (Datagram.Send.Indefinite as Socket.Datagram.Uninterruptible.Bytes.Send.IPv4)+      requires+      (Datagram.Send as Socket.Destined.IPv4.Bytes,+       Socket.Interrupt as Socket.Uninterruptible,+       Socket.Buffer as Socket.Bytes),+    sockets-datagram-send+      (Datagram.Send.Indefinite as Socket.Datagram.Interruptible.MutableBytes.Send.IPv4)+      requires+      (Datagram.Send as Socket.Destined.IPv4.MutableBytes,+       Socket.Interrupt as Socket.Interruptible,+       Socket.Buffer as Socket.MutableBytes),+    sockets-datagram-send+      (Datagram.Send.Indefinite as Socket.Datagram.Uninterruptible.MutableBytes.Send.Connected)+      requires+      (Datagram.Send as Socket.Connected.MutableBytes,+       Socket.Interrupt as Socket.Uninterruptible,+       Socket.Buffer as Socket.MutableBytes),+    sockets-datagram-send+      (Datagram.Send.Indefinite as Socket.Datagram.Interruptible.MutableBytes.Send.Connected)+      requires+      (Datagram.Send as Socket.Connected.MutableBytes,+       Socket.Interrupt as Socket.Interruptible,+       Socket.Buffer as Socket.MutableBytes),+    sockets-datagram-receive+      (Datagram.Receive.Indefinite as Socket.Datagram.Uninterruptible.MutableBytes.Receive.IPv4)+      requires+      (Datagram.Receive as Socket.MutableBytes.SocketAddressInternet,+       Socket.Interrupt as Socket.Uninterruptible,+       Socket.Buffer as Socket.MutableBytes),+    sockets-datagram-receive+      (Datagram.Receive.Indefinite as Socket.Datagram.Interruptible.MutableBytes.Receive.IPv4)+      requires+      (Datagram.Receive as Socket.MutableBytes.SocketAddressInternet,+       Socket.Interrupt as Socket.Interruptible,+       Socket.Buffer as Socket.MutableBytes),+    sockets-datagram-receive+      (Datagram.Receive.Indefinite as Socket.Datagram.Uninterruptible.MutableBytes.Receive.Connected)+      requires+      (Datagram.Receive as Socket.MutableBytes.Peerless,+       Socket.Interrupt as Socket.Uninterruptible,+       Socket.Buffer as Socket.MutableBytes),+    sockets-datagram-receive+      (Datagram.Receive.Indefinite as Socket.Datagram.Interruptible.MutableBytes.Receive.Connected)+      requires+      (Datagram.Receive as Socket.MutableBytes.Peerless,+       Socket.Interrupt as Socket.Interruptible,+       Socket.Buffer as Socket.MutableBytes),+    sockets-stream-send+      (Stream.Send.Indefinite as Socket.Stream.Interruptible.Bytes.Send)+      requires+      (Stream.Send as Socket.Bytes,+       Socket.Interrupt as Socket.Interruptible,+       Socket.Buffer as Socket.Bytes),+    sockets-stream-send+      (Stream.Send.Indefinite as Socket.Stream.Uninterruptible.Bytes.Send)+      requires+      (Stream.Send as Socket.Bytes,+       Socket.Interrupt as Socket.Uninterruptible,+       Socket.Buffer as Socket.Bytes),+    sockets-stream-bidirectional+      (Stream.Send.Indefinite as Socket.Stream.Interruptible.MutableBytes.Send,+       Stream.Receive.Indefinite as Socket.Stream.Interruptible.MutableBytes.Receive)+      requires+      (Stream.Send as Socket.MutableBytes,+       Stream.Receive as Socket.MutableBytes,+       Socket.Buffer as Socket.MutableBytes,+       Socket.Interrupt as Socket.Interruptible),+    sockets-stream-bidirectional+      (Stream.Send.Indefinite as Socket.Stream.Uninterruptible.MutableBytes.Send,+       Stream.Receive.Indefinite as Socket.Stream.Uninterruptible.MutableBytes.Receive)+      requires+      (Stream.Send as Socket.MutableBytes,+       Stream.Receive as Socket.MutableBytes,+       Socket.Buffer as Socket.MutableBytes,+       Socket.Interrupt as Socket.Uninterruptible),+    sockets-stream-bidirectional+      (Stream.Send.Indefinite as Socket.Stream.Interruptible.Addr.Send,+       Stream.Receive.Indefinite as Socket.Stream.Interruptible.Addr.Receive)+      requires+      (Stream.Send as Socket.AddrLength,+       Stream.Receive as Socket.AddrLength,+       Socket.Buffer as Socket.AddrLength,+       Socket.Interrupt as Socket.Interruptible),+    sockets-stream-bidirectional+      (Stream.Send.Indefinite as Socket.Stream.Uninterruptible.Addr.Send,+       Stream.Receive.Indefinite as Socket.Stream.Uninterruptible.Addr.Receive)+      requires+      (Stream.Send as Socket.AddrLength,+       Stream.Receive as Socket.AddrLength,+       Socket.Buffer as Socket.AddrLength,+       Socket.Interrupt as Socket.Uninterruptible),+    sockets-stream-send-two+      (Stream.Send.Two.Indefinite as Socket.Stream.Interruptible.MutableBytes.Addr.Send)+      requires+      (Stream.Send.B as Socket.AddrLength,+       Stream.Send.Buffer.A as Socket.MutableBytes,+       Stream.Send.Buffer.B as Socket.AddrLength,+       Stream.Send.Two as Hybrid.Send.MutableBytes.AddrLength,+       Socket.Interrupt as Socket.Interruptible),+    sockets-stream-send-two+      (Stream.Send.Two.Indefinite as Socket.Stream.Uninterruptible.MutableBytes.Addr.Send)+      requires+      (Stream.Send.B as Socket.AddrLength,+       Stream.Send.Buffer.A as Socket.MutableBytes,+       Stream.Send.Buffer.B as Socket.AddrLength,+       Stream.Send.Two as Hybrid.Send.MutableBytes.AddrLength,+       Socket.Interrupt as Socket.Uninterruptible),+  build-depends:+    , base >= 4.11.1.0 && <5+    , byteslice >=0.1.1 && <0.2+    , bytestring >=0.10 && <0.11+    , error-codes >=0.1.0.1 && <0.2+    , ip >=1.4.1+    , posix-api >=0.3 && <0.4+    , primitive-addr >= 0.1 && <0.2+    , primitive-offset >= 0.2 && <0.3+    , primitive-unlifted >= 0.1 && <0.2+    , sockets-datagram-receive+    , sockets-datagram-receive-many+    , sockets-datagram-send+    , sockets-internal+    , sockets-stream-bidirectional+    , sockets-stream-send+    , sockets-stream-send-two+    , stm >=2.4+    , text >=1.2+  if flag(checked)+    build-depends: primitive-checked >= 0.7 && <0.8+  else+    build-depends: primitive >= 0.7 && <0.8+  hs-source-dirs: src   if flag(mmsg)     hs-source-dirs: src-mmsg   else@@ -110,9 +490,15 @@     , tasty     , tasty-hunit     , ip >= 1.4.1-    , primitive >= 0.6.4     , async     , bytestring+    , byteslice >= 0.1.1+    , primitive-unlifted+    , primitive-addr+  if flag(checked)+    build-depends: primitive-checked >= 0.7 && <0.8+  else+    build-depends: primitive >= 0.7 && <0.8   ghc-options: -Wall -O2 -threaded   default-language: Haskell2010 @@ -122,23 +508,47 @@     , base >= 4.11.1.0 && < 5     , sockets     , ip >= 1.4.1-    , primitive >= 0.6.4     , bytestring >= 0.10.8.2     , entropy >= 0.4.1.4+  if flag(checked)+    build-depends: primitive-checked >= 0.7 && <0.8+  else+    build-depends: primitive >= 0.7 && <0.8   ghc-options: -Wall -O2 -threaded -rtsopts   default-language: Haskell2010   hs-source-dirs: bench   main-is: Macro.hs +benchmark http+  type: exitcode-stdio-1.0+  build-depends:+    , base >= 4.11.1.0 && < 5+    , sockets+    , ip >= 1.4.1+    , bytestring >= 0.10.8.2+    , byteslice >= 0.1.1+  if flag(checked)+    build-depends: primitive-checked >= 0.7 && <0.8+  else+    build-depends: primitive >= 0.7 && <0.8+  ghc-options: -Wall -O2 -threaded -rtsopts+  default-language: Haskell2010+  hs-source-dirs: bench+  main-is: Http.hs+ executable sockets-example   if flag(example)     build-depends:       , base >= 4.11.1.0 && < 5-      , sockets-      , ip >= 1.4.1-      , primitive >= 0.6.4+      , byteslice >= 0.1.1 && < 0.2       , bytestring >= 0.10.8.2       , fast-logger >= 2.4.13+      , ip >= 1.4.1+      , sockets+    if flag(checked)+      build-depends: primitive-checked >= 0.7 && <0.8+    else+      build-depends: primitive >= 0.7 && <0.8   else     buildable: False   hs-source-dirs: example
+ src-buffer/Socket/Buffer.hsig view
@@ -0,0 +1,16 @@+signature Socket.Buffer where++import Prelude (Int)++-- A buffer that needs to be either filled or consumed.+-- Consumers of this API will call advance to move through+-- the buffer until the length is 0. At that point, the+-- buffer has been entirely filled or consumed.+data Buffer++-- Move forward in the buffer. Callers of this function+-- are responsible for checking bounds.+advance :: Buffer -> Int -> Buffer++-- Length of the buffer.+length :: Buffer -> Int
+ src-datagram-receive-many/Datagram/Receive/Many/Indefinite.hs view
@@ -0,0 +1,114 @@+{-# language BangPatterns #-}+{-# language LambdaCase #-}+{-# language MagicHash #-}+{-# language ScopedTypeVariables #-}+{-# language UnboxedTuples #-}++module Datagram.Receive.Many.Indefinite+  ( receiveMany+  ) where++import Control.Monad.Primitive (primitive)+import Data.Bytes.Types (MutableBytes(..))+import Data.Primitive (MutablePrimArray,MutableByteArray)+import Data.Primitive.Unlifted.Array (MutableUnliftedArray)+import Data.Word (Word8)+import Foreign.C.Types (CInt)+import GHC.Exts (RealWorld,Int(I#))+import Socket.Debug (debug,whenDebugging)+import Socket.Datagram (ReceiveException)+import Socket.Datagram.Instantiate (receiveLoop,receiveAttempt)+import Socket.Interrupt (Intr,Interrupt)+import Socket.Interrupt (wait,tokenToDatagramReceiveException)+import System.Posix.Types (Fd)++import qualified Datagram.Receive as Receive+import qualified Data.Primitive as PM+import qualified Data.Primitive.Unlifted.Array as PM+import qualified GHC.Exts as Exts+import qualified Socket.EventManager as EM++-- Invariant: Buffer lengths are all equal, and their size is+-- greater than zero.+-- Implementation note: We only check for the interrupt on the+-- first datagram reception. After that, we keep going (without+-- checking for the interrupt) until we hit EAGAIN or until we+-- have received the maximum number of datagrams that the slab+-- can hold.+receiveMany :: +     Interrupt+  -> Fd -- ^ Socket+  -> MutablePrimArray RealWorld CInt+  -> Receive.AddressBuffer+  -> MutableUnliftedArray RealWorld (MutableByteArray RealWorld) -- ^ Buffers+  -> IO (Either (ReceiveException Intr) Int)+receiveMany !intr !sock !lens !addrs !bufs = do+  let !mngr = EM.manager+      !lenBufs = PM.sizeofMutableUnliftedArray bufs+  tv <- EM.reader mngr sock+  token0 <- wait intr tv+  case tokenToDatagramReceiveException token0 of+    Left err -> pure (Left err)+    Right _ -> do+      buf0 <- readMutableByteArrayArray bufs 0+      sz0 <- PM.getSizeofMutableByteArray buf0+      whenDebugging $ do+        (byte0 :: Word8) <- if sz0 > 0+          then PM.readByteArray buf0 0+          else pure 0+        debug $ "receiveMany: datagram 0 pre-run first byte: " ++ show byte0+      receiveLoop intr tv token0 sock (MutableBytes buf0 0 sz0) (Receive.offsetAddress addrs 0) >>= \case+        Left err -> pure (Left err)+        Right recvSz0 -> do+          -- What a shame that this must be converted from Int to CInt+          -- after just having been converted the other direction in+          -- receiveLoop. Oh well.+          PM.writePrimArray lens 0 (intToCInt recvSz0)+          whenDebugging $ do+            (byte0 :: Word8) <- if recvSz0 > 0+              then PM.readByteArray buf0 0+              else pure 0+            debug $ "receiveMany: datagram 0 received " ++ show recvSz0+                 ++ " bytes into " ++ show sz0 ++ "-byte buffer (first byte: "+                 ++ show byte0 ++ ")"+          let go !ix = if ix < lenBufs+                then do+                  buf <- readMutableByteArrayArray bufs ix+                  sz <- PM.getSizeofMutableByteArray buf+                  whenDebugging $ do+                    (byte0 :: Word8) <- if sz > 0+                      then PM.readByteArray buf 0+                      else pure 0+                    let addr0 = PM.mutableByteArrayContents buf+                    len0 <- PM.readPrimArray lens ix+                    debug $ "receiveMany: datagram " ++ show ix ++ " pre-run [first_byte="+                         ++ show byte0 ++ "][length=" ++ show len0 ++ "][buf_addr="+                         ++ show addr0 ++ "]"+                  receiveAttempt sock (MutableBytes buf 0 sz) (Receive.offsetAddress addrs ix) >>= \case+                    Left err -> pure (Left err)+                    Right m -> case m of+                      Nothing -> pure (Right ix)+                      Just recvSz -> do+                        PM.writePrimArray lens ix (intToCInt recvSz)+                        whenDebugging $ do+                          (byte0 :: Word8) <- if recvSz > 0+                            then PM.readByteArray buf 0+                            else pure 0+                          debug $ "receiveMany: datagram " ++ show ix ++ " received "+                               ++ show recvSz ++ " bytes into " ++ show sz+                               ++ "-byte buffer [first_byte=" ++ show byte0 ++ "]"+                        go (ix + 1)+                else pure (Right ix)+          go 1++intToCInt :: Int -> CInt+{-# inline intToCInt #-}+intToCInt = fromIntegral++readMutableByteArrayArray+  :: MutableUnliftedArray RealWorld (MutableByteArray RealWorld) -- ^ source+  -> Int -- ^ index+  -> IO (MutableByteArray RealWorld)+readMutableByteArrayArray (PM.MutableUnliftedArray maa#) (I# i#)+  = primitive $ \s -> case Exts.readMutableByteArrayArray# maa# i# s of+      (# s', aa# #) -> (# s', PM.MutableByteArray aa# #)
+ src-datagram-receive/Datagram/Receive.hsig view
@@ -0,0 +1,29 @@+{-# language DataKinds #-}++signature Datagram.Receive where++import Socket.Buffer (Buffer)++import Data.Primitive.PrimArray.Offset (MutablePrimArrayOffset)+import Foreign.C.Error (Errno)+import Foreign.C.Types (CSize,CInt)+import GHC.Exts (RealWorld)+import Posix.Socket (MessageFlags,Message(Receive))+import Posix.Socket (SocketAddress,SocketAddressInternet)+import Prelude (Either,IO,Int)+import System.Posix.Types (Fd)++data AddressBuffer+data AddressBufferOffset++-- writeAddress :: AddressBuffer -> Int -> Address -> IO ()+offsetAddress :: AddressBuffer -> Int -> AddressBufferOffset++-- Make a single POSIX @recv@ call with the unsafe FFI. This+-- is intended to be used on a datagram socket. This is allowed+-- to throw an unrecoverable exception if the returned socket+-- address is of the wrong length.+receiveFromOnce ::+     Fd -> Buffer -> MessageFlags 'Receive+  -> AddressBufferOffset+  -> IO (Either Errno CSize)
+ src-datagram-receive/Datagram/Receive/Indefinite.hs view
@@ -0,0 +1,92 @@+{-# language BangPatterns #-}+{-# language LambdaCase #-}+{-# language MultiWayIf #-}++module Datagram.Receive.Indefinite+  ( receive+  , receiveLoop+  , receiveAttempt+  ) where++import Control.Concurrent.STM (TVar)+import Foreign.C.Error (Errno(..), eAGAIN, eWOULDBLOCK)+import Foreign.C.Types (CSize)+import Socket.Error (die)+import Socket.EventManager (Token)+import Socket.Datagram (ReceiveException(..))+import Socket.Buffer (Buffer)+import Socket.Interrupt (Interrupt,Intr,wait,tokenToDatagramReceiveException)+import System.Posix.Types (Fd)++import qualified Foreign.C.Error.Describe as D+import qualified Socket.EventManager as EM+import qualified Socket.Buffer as Buffer+import qualified Datagram.Receive as Receive+import qualified Linux.Socket as L++-- Send the entirely of the buffer, making a single call to+-- POSIX @send@. This is used for datagram sockets. We cannot use a+-- Socket newtype here since connected and unconnected sockets+-- apply Socket to different types.+receive ::+     Interrupt+  -> Fd+  -> Buffer+  -> Receive.AddressBufferOffset+  -> IO (Either (ReceiveException Intr) Int)+receive !intr !sock !buf !addrBuf = do+  let !mngr = EM.manager+  tv <- EM.reader mngr sock+  token0 <- wait intr tv+  case tokenToDatagramReceiveException token0 of+    Left err -> pure (Left err)+    Right _ -> receiveLoop intr tv token0 sock buf addrBuf++receiveAttempt ::+     Fd -- ^ Socket+  -> Buffer -- ^ Buffer+  -> Receive.AddressBufferOffset -- ^ Buffer for the address+  -> IO (Either (ReceiveException Intr) (Maybe Int))+{-# inline receiveAttempt #-}+receiveAttempt !fd !buf !addrBuf = do+  -- We use MSG_TRUNC so that we are able to figure out+  -- whether or not bytes were discarded. If bytes were+  -- discarded (meaning that the buffer was too small),+  -- we return an exception.+  e <- Receive.receiveFromOnce fd buf L.truncate addrBuf+  case e of+    Left err -> if err == eWOULDBLOCK || err == eAGAIN+      then pure (Right Nothing)+      else die $ concat+        [ "Socket.Datagram.receive: " +        , describeErrorCode err+        ]+    Right recvSz -> do+      let !recvSzInt = csizeToInt recvSz+      if recvSzInt <= Buffer.length buf+        then pure (Right (Just recvSzInt))+        else pure (Left (ReceiveTruncated recvSzInt))++receiveLoop ::+     Interrupt+  -> TVar Token+  -> Token+  -> Fd -- ^ Socket+  -> Buffer -- ^ Buffer+  -> Receive.AddressBufferOffset+  -> IO (Either (ReceiveException Intr) Int)+receiveLoop !intr !tv !token0 !fd !buf !addrBuf = receiveAttempt fd buf addrBuf >>= \case+  Left err -> pure (Left err)+  Right m -> case m of+    Nothing -> do+      EM.unready token0 tv+      token1 <- wait intr tv+      receiveLoop intr tv token1 fd buf addrBuf+    Just !r -> pure (Right r)++csizeToInt :: CSize -> Int+csizeToInt = fromIntegral++describeErrorCode :: Errno -> String+describeErrorCode err@(Errno e) = "error code " ++ D.string err ++ " (" ++ show e ++ ")"+
+ src-datagram-send/Datagram/Send.hsig view
@@ -0,0 +1,14 @@+signature Datagram.Send where++import Socket.Buffer (Buffer)++import Foreign.C.Error (Errno)+import Foreign.C.Types (CSize)+import Prelude (Either,IO)+import System.Posix.Types (Fd)++data Peer++-- Make a single POSIX @send@ call with the unsafe FFI. This+-- is intended to be used on a datagram socket.+send :: Peer -> Fd -> Buffer -> IO (Either Errno CSize)
+ src-datagram-send/Datagram/Send/Indefinite.hs view
@@ -0,0 +1,60 @@+{-# language BangPatterns #-}+{-# language LambdaCase #-}+{-# language MultiWayIf #-}++module Datagram.Send.Indefinite+  ( send+  ) where++import Control.Concurrent.STM (TVar)+import Datagram.Send (Peer)+import Foreign.C.Error (Errno(..), eAGAIN, eWOULDBLOCK, eACCES)+import Foreign.C.Types (CSize)+import Socket.Error (die)+import Socket.EventManager (Token)+import Socket.Datagram (SendException(..))+import Socket.Buffer (Buffer)+import Socket.Interrupt (Interrupt,Intr,wait,tokenToDatagramSendException)+import System.Posix.Types (Fd)++import qualified Foreign.C.Error.Describe as D+import qualified Socket.EventManager as EM+import qualified Socket.Buffer as Buffer+import qualified Datagram.Send as Send++-- Send the entirely of the buffer, making a single call to+-- POSIX @send@. This is used for datagram sockets. We cannot use a+-- Socket newtype here since destined and undestined sockets+-- use different newtypes.+send :: Interrupt -> Peer -> Fd -> Buffer -> IO (Either (SendException Intr) ())+send !intr !dst !sock !buf = do+  let !mngr = EM.manager+  tv <- EM.writer mngr sock+  token0 <- wait intr tv+  case tokenToDatagramSendException token0 of+    Left err -> pure (Left err)+    Right _ -> sendLoop intr dst sock tv token0 buf++sendLoop ::+     Interrupt -> Peer -> Fd -> TVar Token -> Token+  -> Buffer -> IO (Either (SendException Intr) ())+sendLoop !intr !dst !sock !tv !old !buf =+  Send.send dst sock buf >>= \case+    Left e ->+      if | e == eAGAIN || e == eWOULDBLOCK -> do+             EM.unready old tv+             new <- wait intr tv+             case tokenToDatagramSendException new of+               Left err -> pure (Left err)+               Right _ -> sendLoop intr dst sock tv new buf+         | e == eACCES -> pure (Left SendBroadcasted)+         | otherwise -> die ("Socket.Datagram.send: " ++ describeErrorCode e)+    Right sz -> if csizeToInt sz == Buffer.length buf+      then pure $! Right ()+      else pure $! Left $! SendTruncated $! csizeToInt sz++csizeToInt :: CSize -> Int+csizeToInt = fromIntegral++describeErrorCode :: Errno -> String+describeErrorCode err@(Errno e) = "error code " ++ D.string err ++ " (" ++ show e ++ ")"
src-debug/Socket/Debug.hs view
@@ -1,10 +1,18 @@ module Socket.Debug   ( debug   , whenDebugging+  , debugging   ) where +import System.IO (hFlush,stdout)+ debug :: String -> IO ()-debug = putStrLn+debug str = do+  putStrLn str+  hFlush stdout  whenDebugging :: IO () -> IO () whenDebugging = id++debugging :: Bool+debugging = True
+ src-err/Socket/Error.hs view
@@ -0,0 +1,6 @@+module Socket.Error+  ( die+  ) where++die :: String -> IO a+die = fail
+ src-internal/Hybrid/Send/MutableBytes/AddrLength.hs view
@@ -0,0 +1,28 @@+{-# language DuplicateRecordFields #-}++module Hybrid.Send.MutableBytes.AddrLength+  ( sendOnce+  ) where++import Data.Bytes.Types (MutableBytes(..),UnmanagedBytes(..))+import Foreign.C.Error (Errno)+import Foreign.C.Types (CSize)+import GHC.Exts (RealWorld)+import System.Posix.Types (Fd)+import Data.Primitive.ByteArray.Offset (MutableByteArrayOffset(..))++import qualified Posix.Socket as S++sendOnce ::+     Fd+  -> MutableBytes RealWorld+  -> UnmanagedBytes+  -> IO (Either Errno CSize)+sendOnce fd (MutableBytes bufA offA lenA) (UnmanagedBytes bufB lenB) =+  S.uninterruptibleSendMessageB fd+    (MutableByteArrayOffset {array=bufA,offset=offA}) (intToCSize lenA)+    bufB (intToCSize lenB)+    S.noSignal++intToCSize :: Int -> CSize+intToCSize = fromIntegral
+ src-internal/Socket.hs view
@@ -0,0 +1,102 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}+{-# language DeriveAnyClass #-}+{-# language DerivingStrategies #-}+{-# language DuplicateRecordFields #-}+{-# language GADTs #-}+{-# language KindSignatures #-}++module Socket+  ( SocketUnrecoverableException(..)+  , Direction(..)+  , Connectedness(..)+  , Family(..)+  , Version(..)+  , Interruptibility(..)+  , Forkedness(..)+  , cgetsockname +  , cgetsockopt+  , cclose +  , crecv +  , crecvfrom+  , cshutdown+  , negativeSliceLength+  , nonInternetSocketFamily+  , functionWithAccepted+  , functionWithConnection+  , functionWithListener+  , functionWithSocket+  , functionGracefulClose+  , socketAddressSize+  ) where++import Control.Exception (Exception(..))+import Data.Kind (Type)+import Foreign.C.Types (CInt)++import qualified Data.List as L++data Direction = Send | Receive++data Connectedness = Connected | Unconnected++data Family = Internet Version | Unix++data Version = V4 | V6++data Interruptibility = Interruptible | Uninterruptible++data Forkedness = Forked | Unforked++data SocketUnrecoverableException = SocketUnrecoverableException+  { modules :: String+  , function :: String+  , description :: [String]+  }+  deriving stock (Show,Eq)++instance Exception SocketUnrecoverableException where+  displayException (SocketUnrecoverableException m f d) =+    m ++ "." ++ f ++ ": [" ++ L.intercalate "," d ++ "]"++cgetsockname :: String+cgetsockname = "getsockname"++cgetsockopt :: String+cgetsockopt = "getsockopt"++cclose :: String+cclose = "getsockname"++crecv :: String+crecv = "recv"++crecvfrom :: String+crecvfrom = "recvfrom"++cshutdown :: String+cshutdown = "shutdown"++functionGracefulClose :: String+functionGracefulClose = "gracefulClose"++nonInternetSocketFamily :: String+nonInternetSocketFamily = "non-internet socket family"++negativeSliceLength :: String+negativeSliceLength = "negative slice length"++functionWithAccepted :: String+functionWithAccepted = "withAccepted"++functionWithConnection :: String+functionWithConnection = "withConnection"++functionWithListener :: String+functionWithListener = "withListener"++functionWithSocket :: String+functionWithSocket = "withSocket"++socketAddressSize :: String+socketAddressSize = "socket address size"
+ src-internal/Socket/AddrLength.hs view
@@ -0,0 +1,44 @@+{-# language DuplicateRecordFields #-}++module Socket.AddrLength+  ( Buffer+  , advance+  , length+  , sendOnce+  , receiveOnce+  ) where++import Prelude hiding (length)++import Data.Bytes.Types (UnmanagedBytes(UnmanagedBytes))+import Posix.Socket (uninterruptibleSend,noSignal)+import Posix.Socket (uninterruptibleReceive)+import Foreign.C.Types (CSize)+import Foreign.C.Error (Errno)+import System.Posix.Types (Fd)++import qualified Data.Primitive.Addr as PM++type Buffer = UnmanagedBytes++advance :: UnmanagedBytes -> Int -> UnmanagedBytes+{-# inline advance #-}+advance (UnmanagedBytes addr len) n = UnmanagedBytes (PM.plusAddr addr n) (len - n)++length :: UnmanagedBytes -> Int+{-# inline length #-}+length (UnmanagedBytes _ len) = len++sendOnce :: Fd -> UnmanagedBytes -> IO (Either Errno CSize)+{-# inline sendOnce #-}+sendOnce fd (UnmanagedBytes addr len) =+  uninterruptibleSend fd addr (intToCSize len) noSignal++receiveOnce :: Fd -> UnmanagedBytes -> IO (Either Errno CSize)+{-# inline receiveOnce #-}+receiveOnce fd (UnmanagedBytes addr len) =+  uninterruptibleReceive fd addr (intToCSize len) mempty++intToCSize :: Int -> CSize+{-# inline intToCSize #-}+intToCSize = fromIntegral
+ src-internal/Socket/Bytes.hs view
@@ -0,0 +1,41 @@+module Socket.Bytes+  ( Buffer+  , advance+  , length+  , sendOnce+  ) where++-- Note that this module does not include a function for receiving+-- bytes since we use a mutable byte array for byte reception.++import Prelude hiding (length)++import Data.Bytes.Types (Bytes(Bytes))+import Posix.Socket (uninterruptibleSendByteArray,noSignal)+import Foreign.C.Types (CInt,CSize)+import Foreign.C.Error (Errno)+import System.Posix.Types (Fd)++type Buffer = Bytes++advance :: Bytes -> Int -> Bytes+{-# inline advance #-}+advance (Bytes arr off len) n = Bytes arr (off + n) (len - n)++length :: Bytes -> Int+{-# inline length #-}+length (Bytes _ _ len) = len++intToCInt :: Int -> CInt+{-# inline intToCInt #-}+intToCInt = fromIntegral++intToCSize :: Int -> CSize+{-# inline intToCSize #-}+intToCSize = fromIntegral++sendOnce :: Fd -> Bytes -> IO (Either Errno CSize)+{-# inline sendOnce #-}+sendOnce fd (Bytes arr off len) =+  uninterruptibleSendByteArray fd arr (intToCInt off) (intToCSize len) noSignal+
+ src-internal/Socket/Connected/Bytes.hs view
@@ -0,0 +1,37 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}+{-# language NamedFieldPuns #-}++module Socket.Connected.Bytes+  ( Buffer+  , Peer+  , advance+  , length+  , send+  ) where++import Prelude hiding (length)++import Data.Bytes.Types (Bytes(Bytes))+import Socket.Bytes (Buffer,length,advance)+import Foreign.C.Error (Errno)+import Foreign.C.Types (CInt,CSize)+import System.Posix.Types (Fd)+import qualified Posix.Socket as S++type Peer = ()++send :: () -> Fd -> Buffer -> IO (Either Errno CSize)+send !_ !sock (Bytes arr off len) =+  -- No need for MSG_NOSIGNAL since this is a datagram+  -- socket, not a stream socket.+  S.uninterruptibleSendByteArray sock arr+    (intToCInt off)+    (intToCSize len)+    mempty++intToCInt :: Int -> CInt+intToCInt = fromIntegral++intToCSize :: Int -> CSize+intToCSize = fromIntegral
+ src-internal/Socket/Connected/MutableBytes.hs view
@@ -0,0 +1,40 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}+{-# language NamedFieldPuns #-}++module Socket.Connected.MutableBytes+  ( Buffer+  , Peer+  , advance+  , length+  , send+  ) where++import Prelude hiding (length)++import Data.Bytes.Types (MutableBytes(MutableBytes))+import Socket.MutableBytes (Buffer,length,advance)+import Foreign.C.Error (Errno)+import Foreign.C.Types (CInt,CSize)+import System.Posix.Types (Fd)+import qualified Posix.Socket as S++type Peer = ()++send :: () -> Fd -> Buffer -> IO (Either Errno CSize)+send !_ !sock (MutableBytes arr off len) =+  -- No need for MSG_NOSIGNAL since this is a datagram+  -- socket, not a stream socket.+  S.uninterruptibleSendMutableByteArray sock arr+    (intToCInt off)+    (intToCSize len)+    mempty++intToCInt :: Int -> CInt+intToCInt = fromIntegral++intToCSize :: Int -> CSize+intToCSize = fromIntegral+++
+ src-internal/Socket/Datagram.hs view
@@ -0,0 +1,58 @@+{-# language DataKinds #-}+{-# language DeriveAnyClass #-}+{-# language DerivingStrategies #-}+{-# language GADTs #-}+{-# language KindSignatures #-}+{-# language StandaloneDeriving #-}+module Socket.Datagram+  ( Socket(..)+  , SendException(..)+  , ReceiveException(..)+  , SocketException(..)+  ) where++import Socket (Interruptibility(..),Connectedness,Family)+import Socket.IPv4 (SocketException(..))+import System.Posix.Types (Fd)++import Data.Kind (Type)+import Data.Typeable (Typeable)+import Control.Exception (Exception)++data SendException :: Interruptibility -> Type where+  -- | The datagram did not fit in the buffer. The field is the+  --   number of bytes that were successfully copied into the+  --   send buffer. The datagram does still get sent when this+  --   happens.+  SendTruncated :: !Int -> SendException i+  -- | Attempted to send to a broadcast address.+  SendBroadcasted :: SendException i+  -- | STM-style interrupt (much safer than C-style interrupt)+  SendInterrupted :: SendException 'Interruptible++deriving stock instance Show (SendException i)+deriving stock instance Eq (SendException i)+deriving anyclass instance (Typeable i) => Exception (SendException i)++data ReceiveException :: Interruptibility -> Type where+  -- | The datagram did not fit in the buffer. The field is the+  --   original size of the datagram that was truncated. If+  --   this happens, the process probably needs to start using+  --   a larger receive buffer.+  ReceiveTruncated :: !Int -> ReceiveException i+  -- | STM-style interrupt (much safer than C-style interrupt)+  ReceiveInterrupted :: ReceiveException 'Interruptible++deriving stock instance Show (ReceiveException i)+deriving stock instance Eq (ReceiveException i)+deriving anyclass instance (Typeable i) => Exception (ReceiveException i)++-- | A datagram socket. The 'Connectedness' refers to whether or+-- not POSIX @connect@ has been applied to the socket. A connected+-- socket socket uses POSIX @send@/@recv@ to communicate with a+-- single peer. An unconnected socket uses POSIX @sendto@/@recvfrom@+-- to communicate with many peers. The 'Family' refers to whether this+-- socket uses IPv4, IPv6, or Unix (local).+newtype Socket :: Connectedness -> Family -> Type where+  Socket :: Fd -> Socket c a+  deriving (Eq,Ord,Show)
+ src-internal/Socket/Destined/IPv4/Bytes.hs view
@@ -0,0 +1,45 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}+{-# language NamedFieldPuns #-}++module Socket.Destined.IPv4.Bytes+  ( Buffer+  , Peer+  , advance+  , length+  , send+  ) where++import Prelude hiding (length)++import Data.Bytes.Types (Bytes(Bytes))+import Foreign.C.Error (Errno)+import Foreign.C.Types (CInt,CSize)+import Net.Types (IPv4(..))+import Socket.IPv4 (Peer(..))+import Socket.Bytes (advance,length)+import System.Posix.Types (Fd)+import qualified Posix.Socket as S++type Buffer = Bytes++send :: Peer -> Fd -> Buffer -> IO (Either Errno CSize)+send !dst !sock (Bytes arr off len) =+  S.uninterruptibleSendToInternetByteArray sock arr+    (intToCInt off)+    (intToCSize len)+    mempty+    (endpointToSocketAddressInternet dst)++endpointToSocketAddressInternet :: Peer -> S.SocketAddressInternet+endpointToSocketAddressInternet (Peer {address, port}) =+  S.SocketAddressInternet+    { S.port = S.hostToNetworkShort port+    , S.address = S.hostToNetworkLong (getIPv4 address)+    }++intToCInt :: Int -> CInt+intToCInt = fromIntegral++intToCSize :: Int -> CSize+intToCSize = fromIntegral
+ src-internal/Socket/Destined/IPv4/MutableBytes.hs view
@@ -0,0 +1,46 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}+{-# language NamedFieldPuns #-}++module Socket.Destined.IPv4.MutableBytes+  ( Buffer+  , Peer+  , advance+  , length+  , send+  ) where++import Prelude hiding (length)++import Data.Bytes.Types (MutableBytes(MutableBytes))+import Foreign.C.Error (Errno)+import Foreign.C.Types (CInt,CSize)+import GHC.Exts (RealWorld)+import Net.Types (IPv4(..))+import Socket.IPv4 (Peer(..))+import Socket.MutableBytes (advance,length)+import System.Posix.Types (Fd)+import qualified Posix.Socket as S++type Buffer = MutableBytes RealWorld++send :: Peer -> Fd -> Buffer -> IO (Either Errno CSize)+send !dst !sock (MutableBytes arr off len) =+  S.uninterruptibleSendToInternetMutableByteArray sock arr+    (intToCInt off)+    (intToCSize len)+    mempty+    (endpointToSocketAddressInternet dst)++endpointToSocketAddressInternet :: Peer -> S.SocketAddressInternet+endpointToSocketAddressInternet (Peer {address, port}) =+  S.SocketAddressInternet+    { S.port = S.hostToNetworkShort port+    , S.address = S.hostToNetworkLong (getIPv4 address)+    }++intToCInt :: Int -> CInt+intToCInt = fromIntegral++intToCSize :: Int -> CSize+intToCSize = fromIntegral
+ src-internal/Socket/Discard.hs view
@@ -0,0 +1,114 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}+{-# language DeriveAnyClass #-}+{-# language DerivingStrategies #-}+{-# language DuplicateRecordFields #-}+{-# language GADTs #-}+{-# language KindSignatures #-}+{-# language MagicHash #-}+{-# language NamedFieldPuns #-}+{-# language StandaloneDeriving #-}+{-# language UnboxedTuples #-}++module Socket.Discard+  ( PeerlessSlab(..)+  , newPeerlessSlab+  , freezePeerlessSlab+  ) where++import Control.Monad.Primitive (primitive,primitive_)+import Data.Primitive (ByteArray(..))+import Data.Primitive.Unlifted.Array (MutableUnliftedArray,UnliftedArray)+import Data.Primitive (MutablePrimArray,MutableByteArray)+import Data.Primitive (SmallArray,SmallMutableArray)+import Data.Word (Word16)+import Foreign.C.Types (CInt)+import GHC.Exts (RealWorld,Int(I#))+import Socket.Error (die)++import qualified GHC.Exts as Exts+import qualified Data.Primitive as PM+import qualified Data.Primitive.Unlifted.Array as PM++-- | A slab of memory for bulk datagram ingest (via @recvmmsg@).+-- Slabs are not safe for concurrent access. This variant does+-- not have space for the peer addresses.+data PeerlessSlab = PeerlessSlab+  { sizes :: !(MutablePrimArray RealWorld CInt)+    -- ^ Buffer for returned datagram lengths+  , payloads :: !(MutableUnliftedArray RealWorld (MutableByteArray RealWorld))+    -- ^ Buffers for datagram payloads, no slicing+  }++-- | Allocate a slab that is used to receive multiple datagrams at+-- the same time without receiving any information about the peer.+newPeerlessSlab ::+     Int -- ^ maximum datagrams+  -> Int -- ^ maximum size of individual datagram +  -> IO PeerlessSlab+newPeerlessSlab !n !m = if n >= 1 && m >= 1+  then do+    sizes <- PM.newPrimArray n+    payloads <- PM.unsafeNewUnliftedArray n+    let go !ix = if ix > (-1)+          then do+            writeMutableByteArrayArray payloads ix =<< PM.newByteArray m+            go (ix - 1)+          else pure ()+    go (n - 1)+    pure PeerlessSlab{sizes,payloads}+  else die "newSlab"++-- | Freeze the specified number of messages in-place and return+-- them Replaces all of the frozen messages with tombstones so that+-- new buffers can be allocated before the next reception. End users+-- should not need this function.+freezePeerlessSlab :: PeerlessSlab -> Int -> IO (UnliftedArray ByteArray)+freezePeerlessSlab slab n = do+  msgs <- PM.unsafeNewUnliftedArray n+  freezeSlabGo slab msgs (n - 1)++freezeSlabGo ::+     PeerlessSlab+  -> MutableUnliftedArray RealWorld ByteArray+  -> Int+  -> IO (UnliftedArray ByteArray)+freezeSlabGo slab@PeerlessSlab{payloads,sizes} !arr !ix = if ix > (-1)+  then do+    !size <- PM.readPrimArray sizes ix+    -- Remove the byte array from the array of payloads, freeze it, and+    -- replace it with a freshly allocated byte array. +    payloadMut <- readMutableByteArrayArray payloads ix+    originalSize <- PM.getSizeofMutableByteArray payloadMut+    writeMutableByteArrayArray payloads ix =<< PM.newByteArray originalSize+    !payload <- PM.unsafeFreezeByteArray =<< PM.resizeMutableByteArray payloadMut (cintToInt size)+    writeByteArrayArray arr ix payload+    freezeSlabGo slab arr (ix - 1)+  else PM.unsafeFreezeUnliftedArray arr++cintToInt :: CInt -> Int+cintToInt = fromIntegral++writeMutableByteArrayArray+  :: MutableUnliftedArray RealWorld (MutableByteArray RealWorld) -- ^ destination+  -> Int -- ^ index+  -> MutableByteArray RealWorld -- ^ value+  -> IO ()+writeMutableByteArrayArray (PM.MutableUnliftedArray maa#) (I# i#) (PM.MutableByteArray a)+  = primitive_ (Exts.writeMutableByteArrayArray# maa# i# a)++writeByteArrayArray+  :: MutableUnliftedArray RealWorld ByteArray -- ^ destination+  -> Int -- ^ index+  -> ByteArray -- ^ value+  -> IO ()+writeByteArrayArray (PM.MutableUnliftedArray maa#) (I# i#) (PM.ByteArray a)+  = primitive_ (Exts.writeByteArrayArray# maa# i# a)++readMutableByteArrayArray+  :: MutableUnliftedArray RealWorld (MutableByteArray RealWorld) -- ^ source+  -> Int -- ^ index+  -> IO (MutableByteArray RealWorld)+readMutableByteArrayArray (PM.MutableUnliftedArray maa#) (I# i#)+  = primitive $ \s -> case Exts.readMutableByteArrayArray# maa# i# s of+      (# s', aa# #) -> (# s', PM.MutableByteArray aa# #)
+ src-internal/Socket/EventManager.hs view
@@ -0,0 +1,776 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}+{-# language DerivingStrategies #-}+{-# language GeneralizedNewtypeDeriving #-}+{-# language LambdaCase #-}+{-# language MagicHash #-}+{-# language MultiWayIf #-}+{-# language NamedFieldPuns #-}+{-# language ScopedTypeVariables #-}+{-# language UnboxedTuples #-}++module Socket.EventManager+  ( -- * Manager+    manager+    -- * Registration+  , register+  , reader+  , writer+    -- * Transactional Variables+  , Token+  , unready+  , wait+  , unreadyAndWait+  , persistentUnreadyAndWait+  , persistentUnready+  , interruptibleWait+  , interruptibleWaitCounting+  , isInterrupt+  ) where++import Control.Applicative (liftA2,(<|>))+import Control.Concurrent (getNumCapabilities,forkOn,rtsSupportsBoundThreads)+import Control.Concurrent.STM (TVar)+import Control.Monad (when)+import Control.Monad.STM (atomically)+import Data.Bits (countLeadingZeros,finiteBitSize,unsafeShiftL,(.|.),(.&.))+import Data.Bits (unsafeShiftR)+import Data.Primitive.Unlifted.Array (MutableUnliftedArray(..))+import Data.Primitive (MutableByteArray(..),MutablePrimArray(..))+import Data.Primitive (Prim)+import Data.Word (Word64,Word32)+import Foreign.C.Error (Errno(..),eINTR)+import Foreign.C.Types (CInt)+import GHC.Conc.Sync (TVar(..),yield)+import GHC.Exts (RealWorld,Int(I#),(*#),TVar#,ArrayArray#,MutableArrayArray#)+import GHC.Exts (Any,MutableArray#,unsafeCoerce#,(==#),isTrue#,casArray#)+import GHC.IO (IO(..))+import Numeric (showIntAtBase)+import Socket.Error (die)+import Socket.Debug (debug,whenDebugging,debugging)+import System.IO.Unsafe (unsafePerformIO)+import System.Posix.Types (Fd)++import qualified Control.Monad.STM as STM+import qualified Control.Concurrent.STM as STM+import qualified Linux.Epoll as Epoll+import qualified Control.Monad.Primitive as PM+import qualified Data.Primitive as PM+import qualified Data.Primitive.Unlifted.Array as PM+import qualified GHC.Exts as Exts++-- Why write another event manager? GHC ships with the mio event manager,+-- but mio is burdened with backwards-compatibility concerns that are+-- antithetical to performance:+--+-- * It supports platforms that have @poll@ as their only mechanism+--   for polling events. This limits mio to using the level-triggered+--   interfaces of @epoll@ and @kqueue@.+-- * It supports multiple registrations per file descriptor. Taking+--   advantage of this feature implies that a file descriptor is shared+--   across multiple green threads. However, such sharing is dubious.+--   An application using network sockets is this way is suseptible to+--   the thundering herd problem. Making this even worse is that a stream+--   socket shared across multiple threads lacks useful behavior (unlike+--   a datagram socket).+-- * It supports arbitrary callbacks associated with each registration.+--   With network sockets, the only callback ever used is one that fills+--   a TVar or MVar. This is good since processing data inside the+--   callback could delay or hang the event manager. But, since the+--   only callback network sockets ever need is one that fills a variable,+--   there is no need to support arbitrary callbacks.+--+-- In constrast to mio, the event manager in this module:+--+-- * Supports only platforms with event notification facilities that provide+--   an edge-triggered interface.+-- * Allows at most 1 registration per file descriptor. This registration+--   always includes the read channel and the write channel.+-- * Pushes out readiness notifications using @TVar@s rather than callbacks.+-- +-- After a user registers an file descriptor with @register@, it may call+-- @reader@ or @writer@ at any time to retrieve the @TVar Bool@ associated with+-- that describes the readiness of that channel. Because of how edge-triggered+-- event notification works, this TVar has some slightly unusual properties.+-- This is best illustrated by example. The example has been removed.++++-- | Register interest in reads and writes. After registering a socket,+-- use 'reader' and 'writer' to get access to the transactional variables+-- that describe the readiness of their corresponding channels. When+-- possible, register a file descriptor before doing whatever thing+-- may cause it to become ready. This is currently not important for+-- correctness (since the read and write channel optimistically start+-- out as ready). However, future optimizations may introduce+-- registration functions that let users specify if the channels+-- should start as ready or not ready.+--+-- Precondition: There is no existing registration for this file descriptor.+register ::+     Manager -- The event manager+  -> Fd -- File descriptor+  -> IO ()+register mngr@Manager{epoll} !fd = do+  (ixTier2, tier2) <- constructivelyLookupTier1 (fdToInt fd) mngr+  let ixRead = ixTier2 * 2+      ixWrite = ixRead + 1+  readVar <- readTVarArray tier2 ixRead+  writeVar <- readTVarArray tier2 ixWrite+  -- It should not be necessary to batch these in the same atomically+  -- since this function should only ever be called with exceptions+  -- masked. However, we do it anyway since it might improve performance.+  -- It's difficult to test this theory.+  atomically $ do+    STM.modifyTVar' readVar resetToken+    STM.modifyTVar' writeVar resetToken+  -- Enough space for a single registration.+  ev <- PM.newPrimArray 1+  debug ("register: registering fd " ++ show fd)+  PM.writePrimArray ev 0 $ Epoll.Event+    { Epoll.events = Epoll.input <> Epoll.output <> Epoll.edgeTriggered <> Epoll.readHangup+    , Epoll.payload = fd+    }+  e <- Epoll.uninterruptibleControlMutablePrimArray epoll Epoll.add fd ev+  case e of+    Left (Errno code) ->+      die $ "Socket.EventManager.register: epoll_ctl error " ++ show code+    Right () -> pure ()++-- HAHA: deregister has been eliminated.+-- This does not close the file descriptor. Call this function either+-- right before or right after closing the socket. It does not matter+-- which order they happen in. Be sure to mask exceptions when closing+-- the socket. It is important to ensure that an asynchronous exception+-- doesn't cause closing or deregistration to happen without the other+-- happening as well. Notice that this function does not call epoll_ctl.+-- Closing the file descriptor will cause epoll deregistration to happen.+-- deregister :: Manager -> Fd -> IO ()+-- deregister Manager{variables} !fd = do+--   (readVar,writeVar) <- lookupBoth (fdToInt fd) variables++-- Deregister insterest in reads and writes.+-- Precondition: A previous call to register has been made.+-- unregister++type MUArray = MutableUnliftedArray RealWorld++data Manager = Manager+  { variables :: !(MUArray (MUArray (TVar Token)))+  , novars :: !(MUArray (TVar Token))+    -- An empty mutable array. This array is used to mark the absense of+    -- a tier-two array of TVars.+  , epoll :: !Fd+  }++manager :: Manager+{-# noinline manager #-}+manager = unsafePerformIO $ do+  when (not rtsSupportsBoundThreads) $ do+    fail $ "Socket.Event.manager: threaded runtime required"+  !novars <- PM.unsafeNewUnliftedArray 0+  !variables <- PM.unsafeNewUnliftedArray 32+  let goX !ix = if ix >= 0+        then do+          writeMutableUnliftedArrayArray variables ix novars+          goX (ix - 1)+        else pure ()+  goX 32+  Epoll.uninterruptibleCreate1 Epoll.closeOnExec >>= \case+    Left (Errno code) ->+      die $ "Socket.EventManager.manager: epoll_create error code " ++ show code+    Right !epoll -> do+      -- Spawn a worker thread (for calling epoll_wait in the background)+      -- on each capability. Recall that since this is in a +      -- noinline+unsafePerformIO setting, this only happens the+      -- first time the manager is accessed. These workers should+      -- continue to run forever. Nothing should be able to kill them+      -- since the thread IDs are discarded.+      capNum <- getNumCapabilities+      -- There should basically never be a non-positive number of+      -- capabilities, so we reserve this check for debugging+      -- situations.+      whenDebugging $ do+        when (capNum < 1) $ do+          die $ "Socket.EventManager.manager: non-positive number of capabilities"+      let go !ix = if ix > (-1)+            then do+              _ <- forkOn ix $ do+                let !initSz = if debugging then 1 else 8+                !initArr <- newPinnedPrimArray initSz+                loopManager initArr initSz epoll variables+              go (ix - 1)+            else pure ()+      -- In debugging mode, spawn a single event manager thread.+      go (if debugging then 0 else capNum)+      pure (Manager {variables,novars,epoll})++reader :: Manager -> Fd -> IO (TVar Token)+reader Manager{variables} !fd = lookupGeneric 0 (fdToInt fd) variables++writer :: Manager -> Fd -> IO (TVar Token)+writer Manager{variables} !fd = lookupGeneric 1 (fdToInt fd) variables++lookupBoth ::+     Int -- File descriptor+  -> MUArray (MUArray (TVar Token))+  -> IO (TVar Token,TVar Token)+lookupBoth !fd !arr = do+  let (ixTier1,ixTier2) = decompose fd+  tier2 <- readMutableUnliftedArrayArray arr ixTier1+  liftA2 (,)+    (readTVarArray tier2 (ixTier2 * 2))+    (readTVarArray tier2 (ixTier2 * 2 + 1))++-- The file descriptor must already be registered. Otherwise, this+-- function may look in an uninitialized tier-two array.+lookupGeneric ::+     Int -- Read: 0, Write: 1+  -> Int -- File descriptor+  -> MutableUnliftedArray RealWorld (MutableUnliftedArray RealWorld (TVar Token))+  -> IO (TVar Token)+lookupGeneric !rw !fd !arr = do+  let (ixTier1,ixTier2) = decompose fd+  tier2 <- readMutableUnliftedArrayArray arr ixTier1+  readTVarArray tier2 ((ixTier2 * 2) + rw)++constructivelyLookupTier1 ::+     Int -- File descriptor+  -> Manager+  -> IO (Int, MUArray (TVar Token))+constructivelyLookupTier1 !fd Manager{variables,novars} = do+  let (ixTier1,ixTier2) = decompose fd+  varsTier2 <- readMutableUnliftedArrayArray variables ixTier1+  if PM.sameMutableUnliftedArray varsTier2 novars+    then do+      -- We want 2 * 2^N tvars because there is a separate read and+      -- write tvar for every file descriptor.+      let !len = exp2succ ixTier1+      varsAttempt <- PM.unsafeNewUnliftedArray len+      let goVars !ix = if ix > (-1)+            then do+              writeTVarArray varsAttempt ix+                =<< STM.newTVarIO emptyToken+              goVars (ix - 1)+            else pure ()+      goVars (len - 1)+      -- We ignore the success of casUnliftedArray. It does not actually+      -- matter whether or not it succeeded. If it failed, some other+      -- thread must have initialized the tier 2 arrays.+      (success,tier2) <- casMutableUnliftedArrayArray variables ixTier1 novars varsAttempt+      debug ("constructivelyLookupTier1: Created tier 2 array of length " ++ show len ++ " at index " ++ show ixTier1 ++ " with success " ++ show success)+      pure (ixTier2,tier2)+    else pure (ixTier2,varsTier2)++loopManager :: +     MutablePrimArray RealWorld (Epoll.Event 'Epoll.Response Fd)+  -> Int -- size of events buffer+  -> Fd -- epoll file descriptor+  -> MUArray (MUArray (TVar Token)) -- tier 1 variables array+  -> IO ()+loopManager !evs0 !sz0 !epfd !tier1 = do+  yield+  (!evs1, !sz1) <- stepManager evs0 sz0 epfd tier1+  loopManager evs1 sz1 epfd tier1++stepManager ::+     MutablePrimArray RealWorld (Epoll.Event 'Epoll.Response Fd)+  -> Int -- size of events buffer+  -> Fd -- epoll file descriptor+  -> MUArray (MUArray (TVar Token)) -- tier 1 variables array+  -> IO (MutablePrimArray RealWorld (Epoll.Event 'Epoll.Response Fd),Int)+     -- returns new events buffer and its size+stepManager !evs0 !sz0 !epfd !tier1 = do+  Epoll.uninterruptibleWaitMutablePrimArray epfd evs0 (intToCInt sz0) >>= \case+    Left (Errno code) -> die $ "Socket.EventManager.stepManager: A " ++ show code+    Right len0 -> if len0 > 0+      then handleEvents evs0 (cintToInt len0) sz0 tier1+      else do+        debug "stepManager: first attempt returned no events"+        yield+        Epoll.uninterruptibleWaitMutablePrimArray epfd evs0 (intToCInt sz0) >>= \case+          Left (Errno code) -> die $ "Socket.EventManager.stepManager: B " ++ show code+          Right len1 -> if len1 > 0+            then do+              debug "stepManager: second attempt succeeded"+              handleEvents evs0 (cintToInt len1) sz0 tier1+            else do+              debug "stepManager: second attempt returned no events"+              whenDebugging $ do+                actualSize <- PM.getSizeofMutablePrimArray evs0+                when (actualSize /= sz0) (die "stepManager: bad size")+              let go = Epoll.waitMutablePrimArray epfd evs0 (intToCInt sz0) (-1) >>= \case+                    -- For reasons beyond me, epoll_wait will just randomly+                    -- return EINTR +                    Left err@(Errno code) -> if err == eINTR+                      then go+                      else die $ "Socket.EventManager.stepManager: C " ++ show code+                    Right len2 -> if len2 > 0+                      then do+                        whenDebugging $ do+                          let !(MutablePrimArray evs0#) = evs0+                          let untypedEvs0 = MutableByteArray evs0#+                          debug ("stepManager: third attempt succeeded, len=" ++ show len2 ++ ",sz=" ++ show sz0)+                          (w0 :: Word32) <- PM.readByteArray untypedEvs0 0+                          (w1 :: Word32) <- PM.readByteArray untypedEvs0 1+                          (w2 :: Word32) <- PM.readByteArray untypedEvs0 2+                          debug $ "stepManager: element 0 raw after third attempt " ++ +                            lpad 32 (showIntAtBase 2 binChar w0 "") ++ " " +++                            lpad 32 (showIntAtBase 2 binChar w1 "") ++ " " +++                            lpad 32 (showIntAtBase 2 binChar w2 "")+                          when (sz0 > 1) $ do+                            (w0a :: Word32) <- PM.readByteArray untypedEvs0 3+                            (w1a :: Word32) <- PM.readByteArray untypedEvs0 4+                            (w2a :: Word32) <- PM.readByteArray untypedEvs0 5+                            debug $ "stepManager: element 1 raw after third attempt " ++ +                              lpad 32 (showIntAtBase 2 binChar w0a "") ++ " " +++                              lpad 32 (showIntAtBase 2 binChar w1a "") ++ " " +++                              lpad 32 (showIntAtBase 2 binChar w2a "")+                        handleEvents evs0 (cintToInt len2) sz0 tier1+                      else die $ "Socket.EventManager.stepManager: D"+              go++lpad :: Int -> String -> String+lpad m xs = replicate (m - length ys) '0' ++ ys+  where ys = take m xs++intToCInt :: Int -> CInt+intToCInt = fromIntegral++cintToInt :: CInt -> Int+cintToInt = fromIntegral++-- This should only ever be called when the number of events is+-- greater than zero. It still works fine if the number is zero,+-- but @stepManager@ shoud be behaving differently depending on+-- this value. This function is also responsible for doubling+-- the buffer size when needed. Do not reuse the argument buffer+-- after calling this function.+handleEvents ::+     MutablePrimArray RealWorld (Epoll.Event 'Epoll.Response Fd)+  -> Int -- number of events+  -> Int -- size of events buffer, always greater than or equal to number of events+  -> MUArray (MUArray (TVar Token)) -- tier 1 variables array+  -> IO (MutablePrimArray RealWorld (Epoll.Event 'Epoll.Response Fd),Int)+     -- returns new events buffer and its size+handleEvents !evs !len !sz !vars = do+  traverseMutablePrimArray_+    ( \(Epoll.Event{Epoll.events,Epoll.payload}) -> do+      let fd = payload+      let hasReadInclusive = Epoll.containsAnyEvents events+            (Epoll.input <> Epoll.readHangup <> Epoll.error <> Epoll.hangup)+      let hasPersistentReadInclusive = Epoll.containsAnyEvents events Epoll.readHangup+      let hasWriteInclusive = Epoll.containsAnyEvents events+            (Epoll.output <> Epoll.error <> Epoll.hangup)+      let hasRead = Epoll.containsAnyEvents events Epoll.input+      let hasReadHangup = Epoll.containsAnyEvents events Epoll.readHangup+      let hasWrite = Epoll.containsAnyEvents events Epoll.output+      let hasHangup = Epoll.containsAnyEvents events Epoll.hangup+      let hasError = Epoll.containsAnyEvents events Epoll.error+      whenDebugging $ do+        let hasPriority = Epoll.containsAnyEvents events Epoll.priority+        let Epoll.Events e = events+        debug $+          "handleEvents: fd " ++ show fd  +++          " bitmask " ++ showIntAtBase 2 binChar e "" ++ " read [" ++ show hasRead +++          "] write [" ++ show hasWrite ++ "] hangup [" ++ show hasHangup +++          "] readHangup [" ++ show hasReadHangup +++          "] error [" ++ show hasError +++          "] priority [" ++ show hasPriority ++ "]"+      (readVar,writeVar) <- lookupBoth (fdToInt fd) vars+      when hasReadInclusive $ atomically $ do+        old <- STM.readTVar readVar+        let !new = if hasPersistentReadInclusive+              then persistentReadyToken old+              else readyToken old+        STM.writeTVar readVar new+      when hasWriteInclusive $ atomically $ STM.modifyTVar' writeVar readyToken+    ) evs 0 len+  if | len < sz -> pure (evs,sz)+     | len == sz -> do+        let newSz = sz * 2+        debug ("handleEvents: doubling size of array to " ++ show newSz)+        newBuf <- newPinnedPrimArray newSz+        pure (newBuf,newSz)+     | otherwise -> die "Socket.EventManager.handleEvents: len > sz"++binChar :: Int -> Char+binChar = \case+  0 -> '0'+  1 -> '1'+  _ -> 'x'++traverseMutablePrimArray_ ::+     Prim a+  => (a -> IO ())+  -> MutablePrimArray RealWorld a+  -> Int -- offset+  -> Int -- end+  -> IO ()+{-# inline traverseMutablePrimArray_ #-}+traverseMutablePrimArray_ f a off end = go off where+  go !ix = if ix < end+    then do+      debug ("traverseMutablePrimArray_: index " ++ show ix)+      f =<< PM.readPrimArray a ix+      go (ix + 1)+    else pure ()++-- Given an argument N, return 2^N.+exp2 :: Int -> Int+{-# INLINE exp2 #-}+exp2 n = unsafeShiftL (1 :: Int) n++-- Given an argument N, return 2^(N+1).+exp2succ :: Int -> Int+{-# INLINE exp2succ #-}+exp2succ n = unsafeShiftL (1 :: Int) (n + 1)++-- Decompose an index N into two parts, A and B.+--+-- * A = ⌊log2(N+1)⌋+-- * B = N - 2^A + 1+-- +-- This gives the following decompositions:+--+-- *  0 => (0,0)+-- *  1 => (1,0)+-- *  2 => (1,1)+-- *  3 => (2,0)+-- *  4 => (2,1)+-- *  5 => (2,2)+-- *  6 => (2,3)+-- *  7 => (3,0)+-- *  8 => (3,1)+-- *  9 => (3,2)+-- * 10 => (3,3)+-- * 11 => (3,4)+-- * 12 => (3,5)+-- * 13 => (3,6)+-- * 14 => (3,7)+--+-- Precondition: N >= 0.+decompose :: Int -> (Int,Int)+{-# INLINE decompose #-}+decompose n =+  let !a = finiteBitSize (undefined :: Int) - countLeadingZeros (n + 1) - 1+      !b = (n + 1) - exp2 a+   in (a,b)++fdToInt :: Fd -> Int+{-# INLINE fdToInt #-}+fdToInt = fromIntegral++-- Token is an optimization of the data type:+--   data Token = Token+--     { ready :: Bool, pready :: Bool, interrupt :: Bool, eventCount :: Word61 }+-- Invariant: the bytearray has length 8.+-- The descriptor counter and the event counter are represented in+-- the predictable way. The readiness bit is the highest bit. Visually:+--   |WXYZZZZZ|ZZZZZZZZ|ZZZZZZZZ|ZZZZZZZZ|ZZZZZZZZ|ZZZZZZZZ|ZZZZZZZZ|ZZZZZZZZ+-- W: readiness (1 is ready, 0 is not ready)+-- X: persistent readiness (only used for read channel, set by EPOLLRDHUP)+-- Y: interruptness (only used for interruptible waiting)+-- Z: event counter+--+-- Since a 62-bit word has so many inhabitants, we pretend that it will+-- never wrap around. In practice, an application would need to run for+-- trillions of years for overflow to happen.+--+-- The notion of persistent readiness is only relevant when dealing with+-- the read channel. Why does it even exist? Consider the following two+-- desirable behaviors:+-- +-- 1. Avoid unneeded @recv@ syscalls. That is, if a @recv@ returns+--    something less that the full number of bytes requested, we want+--    to unready the token. The next time we want to @recv@, we want to wait+--    for the token to be ready before even attempting a @recv@.+-- 2. We want to be properly notification when the peer shuts down. Epoll+--    reports this as EPOLLRDHUP.+--+-- The difficulty is that, without persistent readiness, performing+-- optimization (1), can lead to a hung application. So, we introduce a+-- persistent readiness. This is set when the EPOLLRDHUP notification+-- is delivered. It is only allowed to be reset when a @recv@ returns+-- EAGAIN, not by merely not receiving enough bytes. One might ask:+-- Why should it ever need to be reset? Recall that because of the way+-- this event manager is designed, it is always possible to receive+-- a notification that was intended for a previous user of the+-- file descriptor.+newtype Token = Token Word64++readyBit :: Word64+readyBit = 0x8000000000000000++persistentReadyBits :: Word64+persistentReadyBits = 0xC000000000000000++-- Preserves persistent readiness and interruptedness+unreadyBit :: Word64+unreadyBit = 0x7FFFFFFFFFFFFFFF++eqToken :: Token -> Token -> Bool+eqToken (Token a) (Token b) = a == b++-- The empty token has readiness set to true and persistent readiness+-- set to false.+emptyToken :: Token+emptyToken = Token readyBit++interruptToken :: Token+interruptToken = Token 0x2000000000000000++isTokenReady :: Token -> Bool+isTokenReady (Token w) = unsafeShiftR w 62 /= 0++isInterrupt :: Token -> Bool+isInterrupt (Token w) = (0x2000000000000000 == w)++-- Increments the event counter. Sets readiness to true.+-- Leaves persistent readiness alone. Leaves interruptedness+-- alone.+readyToken :: Token -> Token+readyToken (Token w) = Token (readyBit .|. (w + 1))++persistentReadyToken :: Token -> Token+persistentReadyToken (Token w) = Token (persistentReadyBits .|. (w + 1))++-- Increments the event counter. Sets readiness to true. Sets+-- persistent readiness and interruptness to false.+resetToken :: Token -> Token+resetToken (Token w) = Token ((readyBit .|. (w + 1)) .&. 0x9FFFFFFFFFFFFFFF)++-- | Sets the readiness to false. Leaves the persisted readiness alone.+-- Does not affect the interruptedness. Increments the event counter.+unreadyToken :: Token -> Token+unreadyToken (Token w) = Token (unreadyBit .&. (w + 1))++-- | Sets the readiness, the persisted readiness, and the interruptedness+-- to false. Increments the event counter.+persistentUnreadyToken :: Token -> Token+persistentUnreadyToken (Token w) = Token (0x1FFFFFFFFFFFFFFF .&. (w + 1))++-- | Why does 'unready' need the previous token value. At first glance,+-- it seems that it would suffice to simply set something to false+-- and be done with it. However, this runs into a subtle race condition.+-- What if an @epoll_wait@ worker thread discovered that the file+-- descriptor was ready for reads right before 'unready' was called?+-- We take the old token value so that we can check to see if anything +-- has changed since we last checked in. If that's the case, this+-- function aborts, leaving whatever the most recent call to+-- @epoll_wait@ had done in tact.+unready ::+     Token -- ^ Token provided by previous call to wait+  -> TVar Token -- ^ Transactional variable for readiness+  -> IO ()+unready !oldToken !tv = atomically $ do+  newToken <- STM.readTVar tv+  if eqToken oldToken newToken+    then STM.writeTVar tv $! unreadyToken oldToken+    else pure ()++persistentUnready ::+     Token -- ^ Token provided by previous call to wait+  -> TVar Token -- ^ Transactional variable for readiness+  -> IO ()+persistentUnready !oldToken !tv = atomically $ do+  newToken <- STM.readTVar tv+  if eqToken oldToken newToken+    then STM.writeTVar tv $! persistentUnreadyToken oldToken+    else pure ()++unreadyAndWait ::+     Token -- ^ Token provided by previous call to wait+  -> TVar Token -- ^ Transactional variable for readiness+  -> IO Token -- ^ New token+unreadyAndWait !oldToken !tv = do+  unready oldToken tv+  wait tv++persistentUnreadyAndWait ::+     Token -- ^ Token provided by previous call to wait+  -> TVar Token -- ^ Transactional variable for readiness+  -> IO Token -- ^ New token+persistentUnreadyAndWait !oldToken !tv = do+  persistentUnready oldToken tv+  wait tv++-- | Wait until the token indicates readiness. Keep in mind that+-- false positives are possible. When a false positive happens,+-- use 'unready' and then 'wait' again. Keep doing this until+-- the file descriptor is actually ready for reads/writes.+wait :: TVar Token -> IO Token+wait !tv = do+  !token0@(Token val) <- STM.readTVarIO tv+  debug $ "wait: initial token value " ++ (lpad 64 (showIntAtBase 2 binChar val ""))+  if isTokenReady token0+    then pure token0+    else atomically $ do+      token1 <- STM.readTVar tv+      STM.check (isTokenReady token1)+      pure token1++interruptibleWait ::+     TVar Bool -- ^ Interrupt+  -> TVar Token+  -> IO Token+interruptibleWait !interrupt !tv = do+  -- We make an effort to avoid a transaction if possible,+  -- calling readTVarIO on both variables.+  STM.readTVarIO interrupt >>= \case+    True -> pure interruptToken+    False -> do+      token0 <- STM.readTVarIO tv+      if isTokenReady token0+        then pure token0+        else do+          atomically $+            ( do STM.check =<< STM.readTVar interrupt+                 pure interruptToken+            ) <|>+            ( do token1 <- STM.readTVar tv+                 STM.check (isTokenReady token1)+                 pure token1+            )++interruptibleWaitCounting :: TVar Int -> TVar Bool -> TVar Token -> IO Token+interruptibleWaitCounting !counter !interrupt !tv = atomically $+  -- We cannot go to the same lengths to avoid a transaction as+  -- we do in interruptibleWait. Notablely, the token check and+  -- the counter increment must happen in a transaction together.+  ( do STM.check =<< STM.readTVar interrupt+       pure interruptToken+  ) <|>+  ( do token1 <- STM.readTVar tv+       STM.check (isTokenReady token1)+       STM.modifyTVar' counter (+1)+       pure token1+  )++-- Not yet present in primitive library.+newPinnedPrimArray :: forall a. Prim a+  => Int -> IO (MutablePrimArray RealWorld a)+{-# INLINE newPinnedPrimArray #-}+newPinnedPrimArray (I# n#)+  = PM.primitive (\s# -> case Exts.newPinnedByteArray# (n# *# PM.sizeOf# (undefined :: a)) s# of+      (# s'#, arr# #) -> (# s'#, MutablePrimArray arr# #))++-- This can be unsound if the result is passed to the FFI. Fortunately,+-- we do not do that with the result.+readTVarArray :: forall a.+     MutableUnliftedArray RealWorld (TVar a) -- ^ source+  -> Int -- ^ index+  -> IO (TVar a)+readTVarArray (MutableUnliftedArray maa#) (I# i#)                       +  = PM.primitive $ \s -> case Exts.readArrayArrayArray# maa# i# s of                +      (# s', aa# #) -> (# s', TVar ((unsafeCoerce# :: ArrayArray# -> TVar# RealWorld a) aa#) #)                       +readMutableUnliftedArrayArray                                                           +  :: MutableUnliftedArray RealWorld (MutableUnliftedArray RealWorld a) -- ^ source+  -> Int -- ^ index+  -> IO (MutableUnliftedArray RealWorld a)+readMutableUnliftedArrayArray (MutableUnliftedArray maa#) (I# i#)                       +  = PM.primitive $ \s -> case Exts.readArrayArrayArray# maa# i# s of                +      (# s', aa# #) -> (# s', MutableUnliftedArray ((unsafeCoerce# :: ArrayArray# -> MutableArrayArray# RealWorld) aa#) #)                       ++-- See readTVarArray+writeTVarArray :: forall a.+     MutableUnliftedArray RealWorld (TVar a) -- ^ destination+  -> Int -- ^ index+  -> TVar a -- ^ value+  -> IO ()+writeTVarArray (PM.MutableUnliftedArray maa#) (I# i#) (TVar a)+  = PM.primitive_ (Exts.writeArrayArrayArray# maa# i# ((unsafeCoerce# :: TVar# RealWorld a -> ArrayArray#) a))++writeMutableUnliftedArrayArray :: forall a.+     MutableUnliftedArray RealWorld (MutableUnliftedArray RealWorld a) -- ^ source+  -> Int -- ^ index+  -> MutableUnliftedArray RealWorld a -- ^ value+  -> IO ()+writeMutableUnliftedArrayArray (PM.MutableUnliftedArray maa#) (I# i#) (MutableUnliftedArray a)+  = PM.primitive_ (Exts.writeArrayArrayArray# maa# i# ((unsafeCoerce# :: MutableArrayArray# RealWorld -> ArrayArray#) a))++-- [Notes on registration]+-- This interface requires every call to @register@ to be paired with+-- a call to @deregister@. Consumers of this API must mask asynchronous+-- exceptions at appropriate places to ensure that this happens.+--+-- Consumers of this API must also help out when they discover+-- that a channel that was thought to be ready in not actually ready.+-- These consumers need to update the TVar appropriately. But what+-- if the TVar is updated by a epoll_wait worker thread at the+-- same time that the thread using the socket tries to update it?+-- This is what the event counter (in Token) is for. The socket thread+-- should abandon its attempt to update the token if it discovers+-- that the event counter has increased.+--+-- There is a bit of trickiness to closing sockets as well.+-- What if an epoll_wait worker thread attempts to fill a TVar+-- after a file descriptor is reused? Assuming an event manager thread+-- EVM and a worker thread WRK, consider this situation:+-- * [EVM] epoll_wait: finds that FD 123 became ready for reads+-- * [WRK] close socket with FD 123, causing epoll_ctl with EPOLL_CTL_DEL+-- * [WRK] open socket, kernel reuses FD 123+-- * [WRK] register FD 123+-- * [EVM] Lookup the read TVar and attempt to set its token to have+--         readiness true.+-- The descriptor counter (in Token) is used to prevent nonsense+-- results like this. However, this actually isn't a problem since+-- readiness is understood to include false positives. That is,+-- if the token says that a descriptor is ready, it might not+-- actually be true, but if a token says that a descriptor is+-- not ready, it is definitely not ready.+++-- This comment block is no longer relevant. We do not use poll anymore.+--+-- Since we use epoll's edge-triggered interface, epoll does not tell+-- us the original readiness values. To get these, we use poll. It is+-- important to register with epoll before calling poll. If we did it the other+-- way around, there would be a race condition where we could miss+-- a toggle from not ready to ready between the two calls. This could+-- happen if, between the two calls, the operating system received data from+-- the peer and stuck it in the receive buffer.+--+-- Assumption A. Crucially, the opposite situation cannot occur.+-- That is, it should not be possible for newly created socket to+-- go from ready to not ready on either the read or the write channel.+-- Since the socket should not be shared with another thread, there+-- could not have been any calls to recv/send that would cause a toggle+-- in this direction.+-- +-- Here is a table of how we interpret all possible situations:+-- * Var: True, Poll: X ==> True. epoll_wait ran at some point+--     before or after poll and found that channel had gone from+--     being not ready to ready. The value of poll does not matter.+--     If it was False, then poll must have ran before epoll_wait.+--     If it was True, we do not know in what order they ran. Either+--     way, we can say with confidence that the channel is now ready.+--     We can say this only because of Assumption A described earlier.+-- * Var: False, Poll: X ==> X. Either epoll_wait has not run, or+--     it ran and did not detect a change in the readiness of the channel.+--     Because of Assumption A, we do not consider the possibility that+--     epoll_wait ran after poll and set the readiness+--     to False. Consequently, we use the value from Poll since that must+--     still be the current value.+-- +-- These interpretations suggest that logical disjunction will give +-- us the current readiness of the channel.++casMutableUnliftedArrayArray ::+     MutableUnliftedArray RealWorld (MutableUnliftedArray RealWorld a) -- ^ array+  -> Int -- ^ index+  -> (MutableUnliftedArray RealWorld a) -- ^ expected old value+  -> (MutableUnliftedArray RealWorld a) -- ^ new value+  -> IO (Bool,MutableUnliftedArray RealWorld a)+{-# INLINE casMutableUnliftedArrayArray #-}+casMutableUnliftedArrayArray (MutableUnliftedArray arr#) (I# i#) (MutableUnliftedArray old) (MutableUnliftedArray new) =+  -- All of this unsafeCoercing is really nasty business. This will go away+  -- once https://github.com/ghc-proposals/ghc-proposals/pull/203 happens.+  -- Also, this is unsound if the result is immidiately consumed by+  -- the FFI.+  IO $ \s0 ->+    let !uold = (unsafeCoerce# :: MutableArrayArray# RealWorld -> Any) old+        !unew = (unsafeCoerce# :: MutableArrayArray# RealWorld -> Any) new+     in case casArray# ((unsafeCoerce# :: MutableArrayArray# RealWorld -> MutableArray# RealWorld Any) arr#) i# uold unew s0 of+          (# s1, n, ur #) -> (# s1, (isTrue# (n ==# 0# ),MutableUnliftedArray ((unsafeCoerce# :: Any -> MutableArrayArray# RealWorld) ur)) #)+
+ src-internal/Socket/IPv4.hs view
@@ -0,0 +1,184 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}+{-# language DeriveAnyClass #-}+{-# language DerivingStrategies #-}+{-# language DuplicateRecordFields #-}+{-# language GADTs #-}+{-# language KindSignatures #-}+{-# language MagicHash #-}+{-# language NamedFieldPuns #-}+{-# language StandaloneDeriving #-}+{-# language UnboxedTuples #-}++module Socket.IPv4+  ( Peer(..)+  , Message(..)+  , IPv4Slab(..)+  , SocketException(..)+  , describeEndpoint+  , freezeIPv4Slab+  , newIPv4Slab+  ) where++import Control.Exception (Exception)+import Control.Monad.Primitive (primitive_,primitive)+import Data.Kind (Type)+import Data.Primitive.Unlifted.Array (MutableUnliftedArray)+import Data.Primitive (ByteArray(..),MutableByteArray)+import Data.Primitive (MutablePrimArray)+import Data.Primitive (SmallArray,SmallMutableArray)+import Data.Word (Word16)+import Foreign.C.Types (CInt)+import GHC.Exts (RealWorld,Int(I#))+import Net.Types (IPv4(..))+import Socket.Error (die)++import qualified Data.Primitive as PM+import qualified Data.Primitive.Unlifted.Array as PM+import qualified Data.Text as T+import qualified GHC.Exts as Exts+import qualified Net.IPv4 as IPv4+import qualified Posix.Socket as S++-- | An peer for an IPv4 socket, connection, or listener.+--   Everything is in host byte order, and the user is not+--   responsible for performing any conversions.+data Peer = Peer+  { address :: !IPv4+  , port :: !Word16+  } deriving stock (Eq,Show)++-- | A message received from a peer.+data Message = Message+  { peer :: {-# UNPACK #-} !Peer+  , payload :: !ByteArray+  } deriving stock (Eq,Show)++-- | A slab of memory for bulk datagram ingest (via @recvmmsg@). This+-- approach cuts down on allocations. Slabs are not safe for concurrent+-- access. Do not share a slab across multiple threads.+data IPv4Slab = IPv4Slab+  { sizes :: !(MutablePrimArray RealWorld CInt)+    -- ^ Buffer for returned datagram lengths+  , peers :: !(MutablePrimArray RealWorld S.SocketAddressInternet)+    -- ^ Buffer for returned addresses+  , payloads :: !(MutableUnliftedArray RealWorld (MutableByteArray RealWorld))+    -- ^ Buffers for datagram payloads, no slicing+  }++-- | Allocate a slab that is used to receive multiple datagrams at+-- the same time, additionally storing the IPv4 addresses of the peers.+newIPv4Slab ::+     Int -- ^ maximum datagrams+  -> Int -- ^ maximum size of individual datagram +  -> IO IPv4Slab+newIPv4Slab !n !m = if n >= 1 && m >= 1+  then do+    sizes <- PM.newPrimArray n+    peers <- PM.newPrimArray n+    payloads <- PM.unsafeNewUnliftedArray n+    let go !ix = if ix > (-1)+          then do+            writeMutableByteArrayArray payloads ix =<< PM.newByteArray m+            go (ix - 1)+          else pure ()+    go (n - 1)+    pure IPv4Slab{sizes,peers,payloads}+  else die "newSlabIPv4"++-- This is used internally for debug messages and for presenting+-- unrecoverable exceptions.+describeEndpoint :: Peer -> String+describeEndpoint (Peer {address,port}) =+  T.unpack (IPv4.encode address) ++ ":" ++ show port++-- | Recoverable exceptions that happen when establishing an internet-domain+-- stream listener or datagram socket.+--+-- ==== __Discussion__+--+-- The recoverable exceptions that we encounter with stream sockets (established+-- with @socket@-@bind@-@listen@) and datagram sockets (established with+-- @socket@-@bind@) are the exact same exceptions. Consequently, we reuse+-- the same type in both case. It is a little unfortunate since the name+-- @ListenException@ would be more appropriate for stream sockets. But+-- the code reuse is worth the naming quibble.+data SocketException :: Type where+  -- | The address is protected, and the user is not the superuser. This most+  --   commonly happens when trying to bind to a port below 1024. On Linux,+  --   When it is necessary to bind to such a port on Linux, consider using the+  --   <http://man7.org/linux/man-pages/man7/capabilities.7.html CAP_NET_BIND_SERVICE>+  --   capability instead of running the process as root. (@EACCES@)+  SocketPermissionDenied :: SocketException+  -- | The given address is already in use. (@EADDRINUSE@ with specified port)+  SocketAddressInUse :: SocketException+  -- | The port number was specified as zero, but upon attempting to+  --   bind to an ephemeral port, it was determined that all port numbers+  --   numbers in the ephemeral port range are currently in use.+  --   (@EADDRINUSE@ with unspecified port)+  SocketEphemeralPortsExhausted :: SocketException+  -- | A limit on the number of open file descriptors has been reached.+  --   This could be the per-process limit or the system limit.+  --   (@EMFILE@ and @ENFILE@)+  SocketFileDescriptorLimit :: SocketException++deriving stock instance Show SocketException+deriving anyclass instance Exception SocketException++-- | Freeze the specified number of messages in-place and return+-- them (along with their origin peers). Replaces all of the frozen+-- messages with tombstones so that new buffers can be allocated+-- before the next reception. End users should not need this function.+freezeIPv4Slab ::+     IPv4Slab -- ^ The slab+  -> Int -- ^ Number of messages in the slab.+  -> IO (SmallArray Message)+freezeIPv4Slab slab n = do+  msgs <- PM.newSmallArray n errorThunk+  freezeSlabGo slab msgs (n - 1)++freezeSlabGo :: IPv4Slab -> SmallMutableArray RealWorld Message -> Int -> IO (SmallArray Message)+freezeSlabGo slab@IPv4Slab{payloads,peers,sizes} !arr !ix = if ix > (-1)+  then do+    !size <- PM.readPrimArray sizes ix+    !sockaddr <- PM.readPrimArray peers ix+    -- Remove the byte array from the array of payloads, freeze it, and+    -- replace it with a freshly allocated byte array. +    payloadMut <- readMutableByteArrayArray payloads ix+    originalSize <- PM.getSizeofMutableByteArray payloadMut+    !payload <- PM.unsafeFreezeByteArray =<< PM.resizeMutableByteArray payloadMut (cintToInt size)+    writeMutableByteArrayArray payloads ix =<< PM.newByteArray originalSize+    let !peer = sockAddrToPeer sockaddr+        !msg = Message {peer,payload}+    PM.writeSmallArray arr ix msg+    freezeSlabGo slab arr (ix - 1)+  else PM.unsafeFreezeSmallArray arr++{-# NOINLINE errorThunk #-}+errorThunk :: Message+errorThunk = error "Socket.IPv4.errorThunk"++cintToInt :: CInt -> Int+cintToInt = fromIntegral++sockAddrToPeer :: S.SocketAddressInternet -> Peer+sockAddrToPeer (S.SocketAddressInternet {address,port}) = Peer+  { address = IPv4 (S.networkToHostLong address)+  , port = S.networkToHostShort port+  }++writeMutableByteArrayArray+  :: MutableUnliftedArray RealWorld (MutableByteArray RealWorld) -- ^ destination+  -> Int -- ^ index+  -> MutableByteArray RealWorld -- ^ value+  -> IO ()+writeMutableByteArrayArray (PM.MutableUnliftedArray maa#) (I# i#) (PM.MutableByteArray a)+  = primitive_ (Exts.writeMutableByteArrayArray# maa# i# a)++readMutableByteArrayArray+  :: MutableUnliftedArray RealWorld (MutableByteArray RealWorld) -- ^ source+  -> Int -- ^ index+  -> IO (MutableByteArray RealWorld)+readMutableByteArrayArray (PM.MutableUnliftedArray maa#) (I# i#)+  = primitive $ \s -> case Exts.readMutableByteArrayArray# maa# i# s of+      (# s', aa# #) -> (# s', PM.MutableByteArray aa# #)
+ src-internal/Socket/Interruptible.hs view
@@ -0,0 +1,52 @@+{-# language DataKinds #-}++module Socket.Interruptible+  ( InterruptRep+  , Interrupt+  , Intr+  , wait+  , tokenToStreamSendException+  , tokenToStreamReceiveException+  , tokenToDatagramSendException+  , tokenToDatagramReceiveException+  ) where++import Socket (Interruptibility(Interruptible))+import Socket.EventManager (Token)+import Control.Concurrent.STM (TVar)+import GHC.Exts (RuntimeRep(LiftedRep))+import qualified Socket.EventManager as EM+import qualified Socket.Stream as Stream+import qualified Socket.Datagram as Datagram++type InterruptRep = 'LiftedRep+type Interrupt = TVar Bool+type Intr = 'Interruptible++tokenToStreamSendException :: Token -> Int -> Either (Stream.SendException 'Interruptible) ()+{-# inline tokenToStreamSendException #-}+tokenToStreamSendException t i = if EM.isInterrupt t+  then Left (Stream.SendInterrupted i)+  else Right ()++tokenToStreamReceiveException :: Token -> Int -> Either (Stream.ReceiveException 'Interruptible) ()+{-# inline tokenToStreamReceiveException #-}+tokenToStreamReceiveException t i = if EM.isInterrupt t+  then Left (Stream.ReceiveInterrupted i)+  else Right ()++tokenToDatagramSendException :: Token -> Either (Datagram.SendException 'Interruptible) ()+{-# inline tokenToDatagramSendException #-}+tokenToDatagramSendException t = if EM.isInterrupt t+  then Left Datagram.SendInterrupted+  else Right ()++tokenToDatagramReceiveException :: Token -> Either (Datagram.ReceiveException 'Interruptible) ()+{-# inline tokenToDatagramReceiveException #-}+tokenToDatagramReceiveException t = if EM.isInterrupt t+  then Left Datagram.ReceiveInterrupted+  else Right ()++wait :: TVar Bool -> TVar Token -> IO Token+{-# inline wait #-}+wait = EM.interruptibleWait
+ src-internal/Socket/MutableBytes.hs view
@@ -0,0 +1,49 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}++module Socket.MutableBytes+  ( Buffer+  , advance+  , length+  , sendOnce+  , receiveOnce+  ) where++import Prelude hiding (length)++import Data.Bytes.Types (MutableBytes(MutableBytes))+import Posix.Socket (uninterruptibleSendMutableByteArray)+import Posix.Socket (uninterruptibleReceiveMutableByteArray)+import Posix.Socket (noSignal)+import Foreign.C.Types (CInt,CSize)+import Foreign.C.Error (Errno)+import System.Posix.Types (Fd)+import GHC.Exts (RealWorld)++type Buffer = MutableBytes RealWorld++advance :: MutableBytes RealWorld -> Int -> MutableBytes RealWorld+{-# inline advance #-}+advance (MutableBytes arr off len) n = MutableBytes arr (off + n) (len - n)++length :: MutableBytes RealWorld -> Int+{-# inline length #-}+length (MutableBytes _ _ len) = len++sendOnce :: Fd -> MutableBytes RealWorld -> IO (Either Errno CSize)+{-# inline sendOnce #-}+sendOnce fd (MutableBytes arr off len) =+  uninterruptibleSendMutableByteArray fd arr (intToCInt off) (intToCSize len) noSignal++receiveOnce :: Fd -> MutableBytes RealWorld -> IO (Either Errno CSize)+{-# inline receiveOnce #-}+receiveOnce fd (MutableBytes arr off len) =+  uninterruptibleReceiveMutableByteArray fd arr (intToCInt off) (intToCSize len) mempty++intToCInt :: Int -> CInt+{-# inline intToCInt #-}+intToCInt = fromIntegral++intToCSize :: Int -> CSize+{-# inline intToCSize #-}+intToCSize = fromIntegral
+ src-internal/Socket/MutableBytes/Peerless.hs view
@@ -0,0 +1,49 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}++module Socket.MutableBytes.Peerless+  ( AddressBuffer+  , AddressBufferOffset+  , writeAddress+  , offsetAddress+  , receiveFromOnce+  ) where++import Prelude hiding (length)++import Data.Bytes.Types (MutableBytes(..))+import Foreign.C.Error (Errno)+import Foreign.C.Types (CInt,CSize)+import GHC.Exts (RealWorld)+import Posix.Socket (MessageFlags,Message(Receive))+import System.Posix.Types (Fd)+import qualified Posix.Socket as S++type Address = ()+type AddressBuffer = ()+type AddressBufferOffset = ()++writeAddress :: AddressBuffer -> Int -> Address -> IO ()+writeAddress _ _ _ = pure ()++offsetAddress :: AddressBuffer -> Int -> AddressBufferOffset+offsetAddress _ _ = ()++receiveFromOnce ::+     Fd+  -> MutableBytes RealWorld+  -> MessageFlags 'Receive+  -> ()+  -> IO (Either Errno CSize)+{-# inline receiveFromOnce #-}+receiveFromOnce fd (MutableBytes arr off len) flags !_ =+  S.uninterruptibleReceiveFromMutableByteArray_+    fd arr (intToCInt off) (intToCSize len) flags+   +intToCInt :: Int -> CInt+{-# inline intToCInt #-}+intToCInt = fromIntegral++intToCSize :: Int -> CSize+{-# inline intToCSize #-}+intToCSize = fromIntegral
+ src-internal/Socket/MutableBytes/SocketAddressInternet.hs view
@@ -0,0 +1,53 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}++module Socket.MutableBytes.SocketAddressInternet+  ( AddressBuffer+  , AddressBufferOffset+  , writeAddress+  , offsetAddress+  , receiveFromOnce+  ) where++import Prelude hiding (length)++import Data.Bytes.Types (MutableBytes(..))+import Data.Primitive.PrimArray.Offset (MutablePrimArrayOffset(..))+import Data.Primitive.ByteArray.Offset (MutableByteArrayOffset(..))+import Foreign.C.Error (Errno)+import Foreign.C.Types (CSize)+import GHC.Exts (RealWorld)+import Posix.Socket (MessageFlags,Message(Receive))+import Posix.Socket (SocketAddressInternet)+import System.Posix.Types (Fd)++import qualified Data.Primitive as PM+import qualified Posix.Socket as S++type AddressBuffer = PM.MutablePrimArray RealWorld SocketAddressInternet+type AddressBufferOffset = MutablePrimArrayOffset RealWorld SocketAddressInternet++writeAddress :: AddressBuffer -> Int -> SocketAddressInternet -> IO ()+{-# inline writeAddress #-}+writeAddress = PM.writePrimArray++offsetAddress :: AddressBuffer -> Int -> AddressBufferOffset+{-# inline offsetAddress #-}+offsetAddress = MutablePrimArrayOffset++receiveFromOnce ::+     Fd+  -> MutableBytes RealWorld+  -> MessageFlags 'Receive+  -> MutablePrimArrayOffset RealWorld SocketAddressInternet+  -> IO (Either Errno CSize)+{-# inline receiveFromOnce #-}+receiveFromOnce !sock (MutableBytes arr off len) !flags !addr =+  S.uninterruptibleReceiveFromInternetMutableByteArray sock+    (MutableByteArrayOffset arr off)+    (intToCSize len)+    flags addr+   +intToCSize :: Int -> CSize+{-# inline intToCSize #-}+intToCSize = fromIntegral
+ src-internal/Socket/Stream.hs view
@@ -0,0 +1,206 @@+{-# language DataKinds #-}+{-# language DeriveAnyClass #-}+{-# language DerivingStrategies #-}+{-# language GADTs #-}+{-# language KindSignatures #-}+{-# language StandaloneDeriving #-}+module Socket.Stream+  ( -- * Exceptions+    SendException(..)+  , ReceiveException(..)+  , ConnectException(..)+  , SocketException(..)+  , AcceptException(..)+  , CloseException(..)+    -- * Connection+  , Connection(..)+  ) where++import Socket (Family(..))+import Socket (Interruptibility(..))+import Socket.IPv4 (SocketException(..))+import System.Posix.Types (Fd)++import Data.Kind (Type)+import Data.Typeable (Typeable)+import Control.Exception (Exception)++-- | A connection-oriented stream socket.+newtype Connection = Connection Fd++-- | Recoverable exceptions that can occur while connecting to a peer.+-- This includes both failures while opening the socket and failures+-- while connecting to the peer.+--+-- ==== __Discussion__+--+-- In its API for connecting to a peer, this library combines the step of+-- creating a socket with the step of connecting to the peer. In other words,+-- the end user never gets access to an unconnected stream socket.+-- Consequently, the connection exceptions correspond to the @socket@+-- errors @EMFILE@ and @ENFILE@ as well as the @connect@+-- errors @ECONNREFUSED@, @EACCES@/@EPERM@, @ETIMEDOUT@, @ENETUNREACH@, and+-- @EADDRNOTAVAIL@.+--+-- Somewhat surprisingly, @EADDRINUSE@ is not included in the list of @connect@+-- error codes we recognize as recoverable. The+-- <http://man7.org/linux/man-pages/man2/connect.2.html accept man page>+-- describes @EADDRINUSE@ as "Local address is already in use". However,+-- it is unclear what this means. The caller of @connect@ does not provide+-- an internet socket address. If ephemeral ports are exhausted, @connect@+-- will error with @EADDRNOTAVAIL@. An unresolved+-- <https://stackoverflow.com/questions/43199021/how-could-connect-fail-and-set-errno-to-eaddrinuse Stack Overflow question>+-- calls into question whether or not it is actually possible for this+-- error to happen with an internet domain socket. The author has decided+-- to omit any checks for it. This means that, if it does ever happen,+-- it will cause a @SocketUnrecoverableException@ to be thrown. The Linux+-- cognoscenti are encouraged to open an issue if they have more information+-- about the circumstances under which this exception can occur.+--+-- Although both the POSIX spec and the linux man page list @ENETUNREACH@+-- as an error code that is possible for any type of socket, this library+-- author does not believe that this error code can happen when calling+-- @connect@ on a unix domain socket. Open an issue if this in incorrect.+data ConnectException :: Family -> Interruptibility -> Type where+  -- | Either the connection was blocked by a local firewall rule or it+  --   was blocked because it was to a broadcast address. Sadly, these+  --   two errors are not distinguished by the Linux sockets API.+  --   (@EACCES@/@EPERM@)+  ConnectFirewalled :: ConnectException d i+  -- | A limit on the number of open file descriptors has been reached.+  --   This could be the per-process limit or the system limit.+  --   (@EMFILE@ and @ENFILE@)+  ConnectFileDescriptorLimit :: ConnectException d i+  -- | The network is unreachable. (@ENETUNREACH@)+  ConnectNetworkUnreachable :: ConnectException ('Internet v) i+  -- | No valid routing table entry matches the destination address.+  --   (@EHOSTUNREACH@)+  ConnectHostUnreachable :: ConnectException ('Internet v) i+  -- | All port numbers in the ephemeral port range are currently in+  --   use. (@EADDRNOTAVAIL@).+  ConnectEphemeralPortsExhausted :: ConnectException d i+  -- | No one is listening on the remote address. (@ECONNREFUSED@)+  ConnectRefused :: ConnectException d i+  -- | Timeout while attempting connection. The server may be too busy+  --   to accept new connections. Note that stock Linux configuration has+  --   timeout at+  --   <http://willbryant.net/overriding_the_default_linux_kernel_20_second_tcp_socket_connect_timeout appropriately 20 seconds>.+  --   Users interested in timing out more quickly are encouraged to+  --   use @registerDelay@ with the @interruptible@ variants of the+  --   connection functions in this library. (@ETIMEDOUT@)+  ConnectTimeout :: ConnectException d i+  -- | Remote socket does not match the local socket type. (@EPROTOTYPE@)+  ConnectProtocolType :: ConnectException 'Unix i+  -- | STM-style interrupt (much safer than C-style interrupt)+  ConnectInterrupted :: ConnectException d 'Interruptible++deriving stock instance Eq (ConnectException d i)+deriving stock instance Ord (ConnectException d i)+deriving stock instance Show (ConnectException d i)+deriving anyclass instance (Typeable d, Typeable i) => Exception (ConnectException d i)+++data CloseException :: Type where+  -- | After the local process shut down the writing channel, it+  --   was expecting the peer to do the same. However, the peer+  --   sent more data instead. If this happens, the local process+  --   does still close the socket. However, it must send a TCP+  --   reset to accomplish this since there is still unread data+  --   in the receive buffer.+  --+  --   This can happen if the peer is misbehaving or if the consumer+  --   of the @sockets@ API has incorrectly implemented a protocol+  --   living above layer 4 of the OSI model.+  ClosePeerContinuedSending :: CloseException++deriving stock instance Eq CloseException+deriving stock instance Ord CloseException+deriving stock instance Show CloseException+deriving anyclass instance Exception CloseException++-- | Recoverable exceptions that can occur while accepting an inbound+-- connection.+data AcceptException :: Interruptibility -> Type where+  -- | The peer reset the connection before the running process+  --   accepted it. This is not typically treated as fatal. The+  --   process may continue accepting connections. (@ECONNABORTED@)+  AcceptConnectionAborted :: AcceptException i+  -- | A limit on the number of open file descriptors has been reached.+  --   This could be the per-process limit or the system limit.+  --   (@EMFILE@ and @ENFILE@)+  AcceptFileDescriptorLimit :: AcceptException i+  -- | Firewall rules forbid connection. (@EPERM@)+  AcceptFirewalled :: AcceptException i+  -- | STM-style interrupt (much safer than C-style interrupt)+  AcceptInterrupted :: AcceptException 'Interruptible++deriving stock instance Eq (AcceptException i)+deriving stock instance Ord (AcceptException i)+deriving stock instance Show (AcceptException i)+deriving anyclass instance (Typeable i) => Exception (AcceptException i)+++data SendException :: Interruptibility -> Type where+  -- | The local socket has already shutdown its writing channel.+  --   Consequently, sending is no longer possible. This can happen+  --   even if the process does not @shutdown@ the socket. If the+  --   peer decides to @close@ the connection, the local operating system+  --   will shutdown both the reading and writing channels. (@EPIPE@)+  SendShutdown :: SendException i+  -- | The peer reset the connection.+  SendReset :: SendException i+  -- | STM-style interrupt (much safer than C-style interrupt).+  -- This provides the number of bytes sent before the interrupt+  -- happened. For @sendOnce@, this will always be zero, but+  -- for @send@, it may be any non-negative number less than the+  -- number of bytes the caller intended to send.+  SendInterrupted :: !Int -> SendException 'Interruptible++deriving stock instance Eq (SendException i)+deriving stock instance Ord (SendException i)+deriving stock instance Show (SendException i)+deriving anyclass instance Typeable i => Exception (SendException i)++-- | Recoverable exceptions that can occur while receiving data on a+-- stream socket.+--+-- ==== __Discussion__+--+-- The <http://man7.org/linux/man-pages/man2/recv.2.html recv man page>+-- explicitly documents these:+--+-- * @EAGAIN@/@EAGAIN@: Not possible after using event manager to wait.+-- * @EBADF@: Prevented by this library.+-- * @ECONNREFUSED@: Not sure if this is possible. Currently treated as+--   an unrecoverable exception.+-- * @EFAULT@: Not recoverable. API consumer has misused @Addr@.+-- * @EINTR@: Prevented by this library. Unsafe FFI is not interruptible.+-- * @EINVAL@: Prevented by this library.+-- * @ENOMEM@: Not recoverable.+-- * @ENOTCONN@: Prevented by this library.+-- * @ENOTSOCK@: Prevented by this library.+--+-- The man page includes a disclaimer: "Additional errors may be generated+-- and returned from the underlying protocol modules". One such error+-- when dealing with stream sockets in @ECONNRESET@. One scenario where+-- this happens is when the process running on the peer terminates ungracefully+-- and the operating system on the peer cleans up by sending a reset.+data ReceiveException :: Interruptibility -> Type where+  -- | The peer shutdown its writing channel. (zero-length chunk)+  ReceiveShutdown :: ReceiveException i+  -- | The peer reset the connection. (@ECONNRESET@)+  ReceiveReset :: ReceiveException i+  -- | STM-style interrupt (much safer than C-style interrupt)+  -- This provides the number of bytes received before the interrupt+  -- happened. For @receiveOnce@, this will always be zero, but+  -- for @receiveExactly@ and @receiveBetween@, it may be any+  -- non-negative number less than the number of bytes the caller+  -- intended to receive.+  ReceiveInterrupted :: !Int -> ReceiveException 'Interruptible+  -- | The peer was unreachable. (@EHOSTUNREACH@)+  ReceiveHostUnreachable :: ReceiveException i++deriving stock instance Eq (ReceiveException i)+deriving stock instance Ord (ReceiveException i)+deriving stock instance Show (ReceiveException i)+deriving anyclass instance Typeable i => Exception (ReceiveException i)
+ src-internal/Socket/Uninterruptible.hs view
@@ -0,0 +1,56 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}+{-# language MagicHash #-}++module Socket.Uninterruptible+  ( InterruptRep+  , Interrupt+  , Intr+  , wait+  , tokenToStreamSendException+  , tokenToStreamReceiveException+  , tokenToDatagramSendException+  , tokenToDatagramReceiveException+  ) where++import Control.Concurrent.STM (TVar)+import Data.Void (Void)+import GHC.Exts (RuntimeRep(TupleRep),Proxy#)+import Socket (Interruptibility(Uninterruptible))+import Socket.EventManager (Token)+import qualified Socket.EventManager as EM+import qualified Socket.Stream as Stream+import qualified Socket.Datagram as Datagram++-- We use Proxy# instead of () to ensure that this interrupt type+-- has no runtime cost associated with it.+type InterruptRep = 'TupleRep '[]+type Interrupt = Proxy# Void+type Intr = 'Uninterruptible++tokenToStreamSendException ::+     Token+  -> Int+  -> Either (Stream.SendException 'Uninterruptible) ()+{-# inline tokenToStreamSendException #-}+tokenToStreamSendException _ _ = Right ()++tokenToStreamReceiveException ::+     Token+  -> Int+  -> Either (Stream.ReceiveException 'Uninterruptible) ()+{-# inline tokenToStreamReceiveException #-}+tokenToStreamReceiveException _ _ = Right ()++tokenToDatagramSendException :: Token -> Either (Datagram.SendException 'Uninterruptible) ()+{-# inline tokenToDatagramSendException #-}+tokenToDatagramSendException _ = Right ()++tokenToDatagramReceiveException :: Token -> Either (Datagram.ReceiveException 'Uninterruptible) ()+{-# inline tokenToDatagramReceiveException #-}+tokenToDatagramReceiveException _ = Right ()++wait :: Proxy# Void -> TVar Token -> IO Token+{-# inline wait #-}+wait !_ = EM.wait+
+ src-interrupt/Socket/Interrupt.hsig view
@@ -0,0 +1,34 @@+{-# language DataKinds #-}+{-# language KindSignatures #-}++signature Socket.Interrupt where++import Prelude (IO,Either,Int)++import Control.Concurrent.STM (TVar)+import Socket.EventManager (Token)+import Socket (Interruptibility)+import GHC.Exts (RuntimeRep,TYPE)+import qualified Socket.Stream as Stream+import qualified Socket.Datagram as Datagram++data InterruptRep :: RuntimeRep+data Interrupt :: TYPE InterruptRep+data Intr :: Interruptibility++wait :: Interrupt -> TVar Token -> IO Token++tokenToStreamSendException ::+     Token+  -> Int+  -> Either (Stream.SendException Intr) ()+tokenToStreamReceiveException ::+     Token+  -> Int+  -> Either (Stream.ReceiveException Intr) ()+tokenToDatagramSendException ::+     Token+  -> Either (Datagram.SendException Intr) ()+tokenToDatagramReceiveException ::+     Token+  -> Either (Datagram.ReceiveException Intr) ()
− src-mmsg/Socket/Datagram/IPv4/Undestined/Multiple.hs 
@@ -1,101 +0,0 @@-{-# language BangPatterns #-}-{-# language DuplicateRecordFields #-}-{-# language LambdaCase #-}-{-# language MagicHash #-}-{-# language NamedFieldPuns #-}-{-# language UnboxedTuples #-}-module Socket.Datagram.IPv4.Undestined.Multiple-  ( receiveMany-  ) where--import Control.Concurrent (threadWaitWrite,threadWaitRead)-import Control.Exception (mask,onException)-import Data.Primitive (ByteArray,MutableByteArray(..),Array)-import Data.Word (Word16)-import Foreign.C.Error (Errno(..),eWOULDBLOCK,eAGAIN)-import Foreign.C.Types (CInt,CSize,CUInt)-import GHC.Exts (Int(I#),RealWorld,shrinkMutableByteArray#,ByteArray#,touch#)-import GHC.IO (IO(..))-import Net.Types (IPv4(..))-import Socket (SocketException(..))-import Socket.Datagram.IPv4.Undestined.Internal (Message(..),Socket(..))-import Socket.Debug (debug)-import Socket.IPv4 (Endpoint(..))-import System.Posix.Types (Fd)--import qualified Control.Monad.Primitive as PM-import qualified Data.Primitive as PM-import qualified Linux.Socket as L-import qualified Posix.Socket as S---- | Receive up to the specified number of datagrams into freshly allocated---   byte arrays. When there are many datagrams present on the receive---   buffer, this is more efficient than calling 'receive' repeatedly. The---   array is guaranteed to have at least one message.------   The byte arrays in the resulting messages are always pinned.-receiveMany ::-     Socket -- ^ Socket-  -> Int -- ^ Maximum number of datagrams to receive-  -> Int -- ^ Maximum size of each datagram to receive-  -> IO (Either SocketException (Array Message))-receiveMany = receiveManyNative--receiveManyNative :: Socket -> Int -> Int -> IO (Either SocketException (Array Message))-receiveManyNative (Socket !fd) !maxDatagrams !maxSz = do-  threadWaitRead fd-  L.uninterruptibleReceiveMultipleMessageB fd S.sizeofSocketAddressInternet (intToCSize maxSz) (intToCUInt maxDatagrams) L.truncate >>= \case-    Left err -> pure (Left (errorCode err))-    Right (saneSockAddrs,sockAddrs,greatestMsgSz,msgs) -> if saneSockAddrs == 0-      then if cuintToInt greatestMsgSz > maxSz-        then pure (Left (ReceivedMessageTruncated (cuintToInt greatestMsgSz)))-        else do-          let len = PM.sizeofUnliftedArray msgs-          let sockaddrBase = PM.byteArrayContents sockAddrs-          finalMsgs <- PM.newArray len errorThunk-          let go !ix = if ix >= 0-                then S.indexSocketAddressInternet sockaddrBase ix >>= \case-                  Left fam -> do-                    touchByteArray sockAddrs-                    pure (Left (SocketAddressFamily fam))-                  Right sockAddrInet -> do-                    touchByteArray sockAddrs-                    let !msg = Message-                          (socketAddressInternetToEndpoint sockAddrInet)-                          (PM.indexUnliftedArray msgs ix)-                    PM.writeArray finalMsgs ix msg-                    go (ix - 1)-                else do-                  touchByteArray sockAddrs-                  fmap Right (PM.unsafeFreezeArray finalMsgs)-          go (len - 1)-      else pure (Left SocketAddressSize)---- Used internally in arrays-errorThunk :: a-errorThunk = error "Socket.Datagram.IPv4.Undestined: uninitialized element"--touchByteArray :: ByteArray -> IO ()-touchByteArray (PM.ByteArray x) = touchByteArray# x--touchByteArray# :: ByteArray# -> IO ()-touchByteArray# x = IO $ \s -> case touch# x s of s' -> (# s', () #)--socketAddressInternetToEndpoint :: S.SocketAddressInternet -> Endpoint-socketAddressInternetToEndpoint (S.SocketAddressInternet {address,port}) = Endpoint-  { address = IPv4 (S.networkToHostLong address)-  , port = S.networkToHostShort port-  }--cuintToInt :: CUInt -> Int-cuintToInt = fromIntegral--errorCode :: Errno -> SocketException-errorCode (Errno x) = ErrorCode x--intToCUInt :: Int -> CUInt-intToCUInt = fromIntegral--intToCSize :: Int -> CSize-intToCSize = fromIntegral-
+ src-mmsg/Socket/Datagram/Interruptible/MutableBytes/Many.hs view
@@ -0,0 +1,17 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}+{-# language DuplicateRecordFields #-}+{-# language LambdaCase #-}+{-# language MagicHash #-}+{-# language NamedFieldPuns #-}+{-# language UnboxedTuples #-}+module Socket.Datagram.Interruptible.MutableBytes.Many+  ( receiveManyFromIPv4+  , receiveMany+  ) where++receiveManyFromIPv4 :: a+receiveManyFromIPv4 = error "uhoetnuh"++receiveMany :: a+receiveMany = error "heatunobet"
+ src-mmsg/Socket/Datagram/Uninterruptible/MutableBytes/Many.hs view
@@ -0,0 +1,139 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}+{-# language DuplicateRecordFields #-}+{-# language LambdaCase #-}+{-# language MagicHash #-}+{-# language NamedFieldPuns #-}+{-# language UnboxedTuples #-}+module Socket.Datagram.Uninterruptible.MutableBytes.Many+  ( receiveMany+  , receiveManyFromIPv4+  ) where++import Control.Concurrent.STM (TVar)+import Control.Monad.Primitive (primitive)+import Data.Primitive (MutablePrimArray,MutableUnliftedArray,MutableByteArray)+import Foreign.C.Error (eWOULDBLOCK,eAGAIN)+import Foreign.C.Types (CInt,CUInt)+import GHC.Exts (RealWorld,Int(I#))+import GHC.IO (IO(..))+import Socket (Connectedness(..))+import Socket (Interruptibility(Uninterruptible))+import Socket.Datagram (Socket(..),ReceiveException(ReceiveTruncated))+import Socket.Error (die)+import Socket.IPv4 (Slab(..))+import System.Posix.Types (Fd)++import qualified Data.Primitive as PM+import qualified GHC.Exts as Exts+import qualified Linux.Socket as L+import qualified Socket as SCK+import qualified Socket.Discard+import qualified Socket.EventManager as EM++-- | Receive up to the specified number of datagrams into freshly allocated+--   byte arrays. When there are many datagrams present in the receive+--   buffer, this is more efficient than calling 'receive' repeatedly. This+--   is guaranteed to fill the buffer with at least one message.+--+--   The length buffer and the payload buffers arrange data in a+--   structure-of-arrays fashion. The size of the payload received+--   into @payloads[j]@ is stored at @lengths[j]@.+receiveMany :: +     Socket c a+     -- ^ Socket+  -> Socket.Discard.Slab+     -- ^ Buffers into which sizes and payloads are received+  -> IO (Either (ReceiveException 'Uninterruptible) Int)+receiveMany (Socket !fd) !slab@Socket.Discard.Slab{payloads} = do+  let !mngr = EM.manager+  tv <- EM.reader mngr fd+  let !sz = intToCUInt (PM.sizeofMutableUnliftedArray payloads)+  token0 <- EM.wait tv+  receiveManyGo sz tv fd slab token0++receiveManyGo ::+     CUInt+  -> TVar EM.Token +  -> Fd+  -> Socket.Discard.Slab+  -> EM.Token+  -> IO (Either (ReceiveException 'Uninterruptible) Int)+receiveManyGo !sz !tv !fd !slab@(Socket.Discard.Slab{sizes,payloads}) !token0 = do+  e <- L.uninterruptibleReceiveMultipleMessageD fd sizes payloads sz L.truncate+  case e of+    Left err -> if err == eAGAIN || err == eWOULDBLOCK+      then do+        EM.unready token0 tv+        token1 <- EM.wait tv+        receiveManyGo sz tv fd slab token1+      else die "receiveMany"+    Right grams -> if grams == 0+      then die "receiveMany: 0 datagrams"+      else validateSizes sizes payloads (cintToInt grams) 0++validateSizes ::+     MutablePrimArray RealWorld CInt+  -> MutableUnliftedArray RealWorld (MutableByteArray RealWorld)+  -> Int+  -> Int+  -> IO (Either (ReceiveException 'Uninterruptible) Int)+validateSizes !lens !bufs !total !ix = if ix < total+  then do+    reqLen <- PM.readPrimArray lens ix+    bufLen <- readMutableByteArrayArray bufs ix >>= PM.getSizeofMutableByteArray+    if cintToInt reqLen <= bufLen+      then validateSizes lens bufs total (ix + 1)+      else pure $! Left $! ReceiveTruncated $! cintToInt reqLen+  else pure $! Right $! total++-- | Variant of 'receiveMany' that provides that source address+-- corresponding to each datagram. This introduces another array+-- to the structure-of-arrays.+receiveManyFromIPv4 :: +     Socket 'Unconnected 'SCK.IPv4 -- ^ Socket+  -> Socket.IPv4.Slab+     -- ^ Buffers into which sizes, addresses, and payloads+     -- are received+  -> IO (Either (ReceiveException 'Uninterruptible) Int)+receiveManyFromIPv4 (Socket fd) slab@(Socket.IPv4.Slab{payloads}) = do+  let !mngr = EM.manager+  tv <- EM.reader mngr fd+  let !sz = intToCUInt (PM.sizeofMutableUnliftedArray payloads)+  token0 <- EM.wait tv+  receiveManyFromIPv4Go sz tv fd slab token0++receiveManyFromIPv4Go ::+     CUInt+  -> TVar EM.Token +  -> Fd+  -> Socket.IPv4.Slab+  -> EM.Token+  -> IO (Either (ReceiveException 'Uninterruptible) Int)+receiveManyFromIPv4Go !sz !tv !fd !slab@(Socket.IPv4.Slab{sizes,payloads,peers}) !token0 = do+  e <- L.uninterruptibleReceiveMultipleMessageC fd sizes peers payloads sz L.truncate+  -- TODO: add truncation check+  case e of+    Left err -> if err == eAGAIN || err == eWOULDBLOCK+      then do+        EM.unready token0 tv+        token1 <- EM.wait tv+        receiveManyFromIPv4Go sz tv fd slab token1+      else die "receiveMany"+    Right grams -> if grams == 0+      then die "receiveMany: 0 datagrams"+      else pure $! Right $! cintToInt grams++intToCUInt :: Int -> CUInt+intToCUInt = fromIntegral++cintToInt :: CInt -> Int+cintToInt = fromIntegral++readMutableByteArrayArray+  :: MutableUnliftedArray RealWorld (MutableByteArray RealWorld) -- ^ source+  -> Int -- ^ index+  -> IO (MutableByteArray RealWorld)+readMutableByteArrayArray (PM.MutableUnliftedArray maa#) (I# i#)+  = primitive $ \s -> case Exts.readMutableByteArrayArray# maa# i# s of+      (# s', aa# #) -> (# s', PM.MutableByteArray aa# #)
− src-no-mmsg/Socket/Datagram/IPv4/Undestined/Multiple.hs 
@@ -1,140 +0,0 @@-{-# language BangPatterns #-}-{-# language DuplicateRecordFields #-}-{-# language LambdaCase #-}-{-# language MagicHash #-}-{-# language NamedFieldPuns #-}-{-# language UnboxedTuples #-}-module Socket.Datagram.IPv4.Undestined.Multiple-  ( receiveMany-  , receiveManyUnless-  ) where--import Control.Applicative ((<|>))-import Control.Monad.STM (STM,atomically)-import Control.Concurrent (threadWaitWrite,threadWaitRead,threadWaitReadSTM)-import Control.Exception (mask,onException)-import Data.Functor (($>))-import Data.Primitive (ByteArray,MutableByteArray(..),Array)-import Data.Word (Word16)-import Foreign.C.Error (Errno(..),eWOULDBLOCK,eAGAIN)-import Foreign.C.Types (CInt,CSize,CUInt)-import GHC.Exts (Int(I#),RealWorld,shrinkMutableByteArray#,ByteArray#,touch#)-import GHC.IO (IO(..))-import Net.Types (IPv4(..))-import Socket (SocketException(..))-import Socket.Datagram.IPv4.Undestined.Internal (Message(..),Socket(..))-import Socket.Debug (debug)-import Socket.IPv4 (Endpoint(..))-import System.Posix.Types (Fd)--import qualified Control.Monad.Primitive as PM-import qualified Data.Primitive as PM-import qualified Linux.Socket as L-import qualified Posix.Socket as S---- | Receive up to the specified number of datagrams into freshly allocated---   byte arrays. When there are many datagrams present on the receive---   buffer, this is more efficient than calling 'receive' repeatedly. The---   array is guaranteed to have at least one message.------   The byte arrays in the resulting messages are always pinned.-receiveMany ::-     Socket -- ^ Socket-  -> Int -- ^ Maximum number of datagrams to receive-  -> Int -- ^ Maximum size of each datagram to receive-  -> IO (Either SocketException (Array Message))-receiveMany (Socket !fd) !maxDatagrams !maxSz = do-  debug "receiveMany: about to wait"-  threadWaitRead fd-  receiveManyShim fd maxDatagrams maxSz---- | This has the same behavior as 'receiveMany'. However, it also takes an---   'STM' action that it attempts to run while the event manager is waiting---   for the socket to be ready for a reads. If the supplied action finishes---   first, this abandons the attempt to receive datagrams and returns---   @'Left' 'ReceptionAbandoned'@.-receiveManyUnless :: -     STM () -- ^ If this completes, give up on receiving-  -> Socket -- ^ Socket-  -> Int -- ^ Maximum number of datagrams to receive-  -> Int -- ^ Maximum size of each datagram to receive-  -> IO (Either SocketException (Array Message))-receiveManyUnless abandon (Socket !fd) !maxDatagrams !maxSz = do-  debug "receiveMany: about to wait"-  (isReady,deregister) <- threadWaitReadSTM fd-  shouldReceive <- atomically ((abandon $> False) <|> (isReady $> True))-  deregister-  if shouldReceive-    then receiveManyShim fd maxDatagrams maxSz-    else pure (Left ReceptionAbandoned)---- Although this is a shim for recvmmsg, it is still better than calling--- receive repeatedly since it avoids unneeded calls to the event--- manager. This is guaranteed to return at least one message.------ This function is currently unused. It is being left here so that,--- when cross-platform compatibility is someday handled, this will--- be available for platforms that do not provide recvmmsg.-receiveManyShim :: Fd -> Int -> Int -> IO (Either SocketException (Array Message))-receiveManyShim !fd !maxDatagrams !maxSz = do-  debug "receiveMany: socket is now readable"-  msgs <- PM.newArray maxDatagrams errorThunk-  -- We use MSG_TRUNC so that we are able to figure out whether-  -- or not bytes were discarded. If bytes were discarded-  -- (meaning that the buffer was too small), we return an-  -- exception.-  let go !ix = if ix < maxDatagrams-        then do-          -- This does not need to allocate pinned memory for-          -- the call to recvfrom to work correctly. It allocates-          -- pinned memory so that its behavior is consistent with-          -- that of receiveManyNative.-          marr <- PM.newPinnedByteArray maxSz-          e <- S.uninterruptibleReceiveFromMutableByteArray fd marr 0-            (intToCSize maxSz) (L.truncate) S.sizeofSocketAddressInternet-          case e of-            Left err -> if err == eWOULDBLOCK || err == eAGAIN-              then do-                r <- PM.freezeArray msgs 0 ix-                pure (Right r)-              else pure (Left (errorCode err))-            Right (sockAddrRequiredSz,sockAddr,recvSz) -> if csizeToInt recvSz <= maxSz-              then if sockAddrRequiredSz == S.sizeofSocketAddressInternet-                then case S.decodeSocketAddressInternet sockAddr of-                  Just sockAddrInet -> do-                    shrinkMutableByteArray marr (csizeToInt recvSz)-                    arr <- PM.unsafeFreezeByteArray marr-                    let !msg = Message (socketAddressInternetToEndpoint sockAddrInet) arr-                    PM.writeArray msgs ix msg-                    go (ix + 1)-                  Nothing -> pure (Left (SocketAddressFamily (-1)))-                else pure (Left SocketAddressSize)-              else pure (Left (ReceivedMessageTruncated (csizeToInt recvSz)))-        else do-          r <- PM.unsafeFreezeArray msgs-          pure (Right r)-  go 0---- Used internally in arrays-errorThunk :: a-errorThunk = error "Socket.Datagram.IPv4.Undestined: uninitialized element"--csizeToInt :: CSize -> Int-csizeToInt = fromIntegral--socketAddressInternetToEndpoint :: S.SocketAddressInternet -> Endpoint-socketAddressInternetToEndpoint (S.SocketAddressInternet {address,port}) = Endpoint-  { address = IPv4 (S.networkToHostLong address)-  , port = S.networkToHostShort port-  }--shrinkMutableByteArray :: MutableByteArray RealWorld -> Int -> IO ()-shrinkMutableByteArray (MutableByteArray arr) (I# sz) =-  PM.primitive_ (shrinkMutableByteArray# arr sz)--intToCSize :: Int -> CSize-intToCSize = fromIntegral--errorCode :: Errno -> SocketException-errorCode (Errno x) = ErrorCode x-
+ src-no-mmsg/Socket/Datagram/Interruptible/MutableBytes/Many.hs view
@@ -0,0 +1,57 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}+{-# language DuplicateRecordFields #-}+{-# language LambdaCase #-}+{-# language MagicHash #-}+{-# language NamedFieldPuns #-}+{-# language UnboxedTuples #-}+module Socket.Datagram.Interruptible.MutableBytes.Many+  ( receiveMany+  , receiveManyFromIPv4+  ) where++import Control.Concurrent.STM (TVar)+import Socket (Interruptibility(Interruptible))+import Socket (Connectedness(..))+import Socket.Datagram (Socket(..),ReceiveException)+import Socket.Discard (PeerlessSlab(..))+import Socket.IPv4 (IPv4Slab(..))++import qualified Socket as SCK+import qualified Socket.Datagram.Interruptible.MutableBytes.Receive.Many.Unit as RU+import qualified Socket.Datagram.Interruptible.MutableBytes.Receive.Many.IPv4 as RV4++-- | Receive up to the specified number of datagrams into freshly allocated+--   byte arrays. When there are many datagrams present in the receive+--   buffer, this is more efficient than calling 'receive' repeatedly. This+--   is guaranteed to fill the buffer with at least one message.+--+--   The length buffer and the payload buffers arrange data in a+--   structure-of-arrays fashion. The size of the payload received+--   into @payloads[j]@ is stored at @lengths[j]@.+receiveMany :: +     TVar Bool+     -- ^ Interrupt. On 'True', give up and return+     -- @'Left' 'ReceiveInterrupted'@.+  -> Socket c a+     -- ^ Socket+  -> Socket.Discard.PeerlessSlab+     -- ^ Buffers into which sizes and payloads are received+  -> IO (Either (ReceiveException 'Interruptible) Int)+receiveMany intr (Socket fd) (Socket.Discard.PeerlessSlab{sizes,payloads}) =+  RU.receiveMany intr fd sizes () payloads++-- | Variant of 'receiveMany' that provides that source address+-- corresponding to each datagram. This introduces another array+-- to the structure-of-arrays.+receiveManyFromIPv4 :: +     TVar Bool+     -- ^ Interrupt. On 'True', give up and return+     -- @'Left' 'ReceiveInterrupted'@.+  -> Socket 'Unconnected ('SCK.Internet 'SCK.V4) -- ^ Socket+  -> Socket.IPv4.IPv4Slab+     -- ^ Buffers into which sizes, addresses, and payloads+     -- are received+  -> IO (Either (ReceiveException 'Interruptible) Int)+receiveManyFromIPv4 intr (Socket fd) (Socket.IPv4.IPv4Slab{sizes,peers,payloads}) =+  RV4.receiveMany intr fd sizes peers payloads
+ src-no-mmsg/Socket/Datagram/Uninterruptible/MutableBytes/Many.hs view
@@ -0,0 +1,52 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}+{-# language DuplicateRecordFields #-}+{-# language LambdaCase #-}+{-# language MagicHash #-}+{-# language NamedFieldPuns #-}+{-# language UnboxedTuples #-}+module Socket.Datagram.Uninterruptible.MutableBytes.Many+  ( receiveMany+  , receiveManyFromIPv4+  ) where++import GHC.Exts (proxy#)+import GHC.IO (IO(..))+import Socket (Interruptibility(Uninterruptible))+import Socket (Connectedness(..))+import Socket.Datagram (Socket(..),ReceiveException)+import Socket.IPv4 (IPv4Slab(..))++import qualified Socket.Discard+import qualified Socket as SCK+import qualified Socket.Datagram.Uninterruptible.MutableBytes.Receive.Many.Unit as RU+import qualified Socket.Datagram.Uninterruptible.MutableBytes.Receive.Many.IPv4 as RV4++-- | Receive up to the specified number of datagrams into freshly allocated+--   byte arrays. When there are many datagrams present in the receive+--   buffer, this is more efficient than calling 'receive' repeatedly. This+--   is guaranteed to fill the buffer with at least one message.+--+--   The length buffer and the payload buffers arrange data in a+--   structure-of-arrays fashion. The size of the payload received+--   into @payloads[j]@ is stored at @lengths[j]@.+receiveMany :: +     Socket c a+     -- ^ Socket+  -> Socket.Discard.PeerlessSlab+     -- ^ Buffers into which sizes and payloads are received+  -> IO (Either (ReceiveException 'Uninterruptible) Int)+receiveMany (Socket fd) (Socket.Discard.PeerlessSlab{sizes,payloads}) =+  RU.receiveMany proxy# fd sizes () payloads++-- | Variant of 'receiveMany' that provides that source address+-- corresponding to each datagram. This introduces another array+-- to the structure-of-arrays.+receiveManyFromIPv4 :: +     Socket 'Unconnected ('SCK.Internet 'SCK.V4) -- ^ Socket+  -> Socket.IPv4.IPv4Slab+     -- ^ Buffers into which sizes, addresses, and payloads+     -- are received+  -> IO (Either (ReceiveException 'Uninterruptible) Int)+receiveManyFromIPv4 (Socket fd) (Socket.IPv4.IPv4Slab{sizes,peers,payloads}) =+  RV4.receiveMany proxy# fd sizes peers payloads
+ src-noerr/Socket/Error.hs view
@@ -0,0 +1,27 @@+{-# language MagicHash #-}++module Socket.Error+  ( die+  ) where++-- The purpose of this module is to coax GHC into producing+-- core that is easier to reason about. (As a secondary concern,+-- it is possible that it may be compiled to slightly better cmm+-- and assembly). For some reason, GHC does not like to inline @fail@,+-- so here we inline the implementation of fail into @die@ and mark+-- @die@ with an INLINE pragma. This causes @raiseIO#@ to show up+-- in GHC core at use sites of this function. And we optimizing+-- core, GHC is smart enough to figure out that expressions that+-- follow @raiseIO#@ are unreachable.+--+-- Impressively, this seemingly minor change leads to GHC being able+-- to apply additional optimizations. For example, there is some+-- needless construction of @Left@ and @Right@ that is eliminated+-- when we have @raiseIO#@ inlined properly.+import GHC.IO (IO(..))+import GHC.Exts (raiseIO#)+import Control.Exception (toException)++die :: String -> IO a+{-# inline die #-}+die _ = IO (raiseIO# (toException (userError "sockets: internal error, rebuild with verbose-errors flag to learn more")))
src-production/Socket/Debug.hs view
@@ -1,6 +1,7 @@ module Socket.Debug   ( debug   , whenDebugging+  , debugging   ) where  debug :: String -> IO ()@@ -8,3 +9,6 @@  whenDebugging :: IO () -> IO () whenDebugging _ = pure ()++debugging :: Bool+debugging = True
+ src-stream-receive/Stream/Receive.hsig view
@@ -0,0 +1,11 @@+signature Stream.Receive where++import Socket.Buffer (Buffer)++import Foreign.C.Error (Errno)+import Foreign.C.Types (CSize)+import Prelude (Either,IO)+import System.Posix.Types (Fd)++-- Make a single POSIX @recv@ call with the unsafe FFI.+receiveOnce :: Fd -> Buffer -> IO (Either Errno CSize)
+ src-stream-receive/Stream/Receive/Indefinite.hs view
@@ -0,0 +1,131 @@+{-# language BangPatterns #-}+{-# language LambdaCase #-}+{-# language MagicHash #-}+{-# language MultiWayIf #-}+{-# language UnboxedTuples #-}++module Stream.Receive.Indefinite+  ( receiveExactly+  , receiveOnce+  , receiveBetween+  ) where++import Control.Monad (when)+import Control.Concurrent.STM (TVar)+import Foreign.C.Error (Errno(..), eAGAIN, eWOULDBLOCK, eCONNRESET, eHOSTUNREACH)+import Foreign.C.Types (CSize)+import GHC.Exts (RealWorld,State#,Int(I#),Int#)+import GHC.IO (IO(IO))+import Socket.Error (die)+import Socket.EventManager (Token)+import Socket.Stream (ReceiveException(..),Connection(..))+import Socket.Buffer (Buffer)+import Socket.Interrupt (Interrupt,Intr,wait,tokenToStreamReceiveException)+import System.Posix.Types (Fd)++import qualified Foreign.C.Error.Describe as D+import qualified Socket.EventManager as EM+import qualified Socket.Buffer as Buffer+import qualified Stream.Receive as Receive++-- Receive exactly the specified number of bytes, making repeated calls to+-- POSIX @recv@ if necessary.+receiveExactly ::+     Interrupt+  -> Connection+  -> Buffer+  -> IO (Either (ReceiveException Intr) ())+receiveExactly !intr (Connection !conn) !buf = do+  let !mngr = EM.manager+  !tv <- EM.reader mngr conn+  e <- box $ receiveLoop intr conn tv buf (Buffer.length buf) 0+  case e of+    Left err -> pure (Left err)+    -- Discard the total since it is known to be equal to the+    -- requested number of bytes.+    Right _ -> pure (Right ())++-- Receive a chunk of data from the socket. This may make multiple calls+-- to POSIX @recv@ if EAGAIN is returned. It makes at most one call that+-- successfully fills the buffer.+receiveOnce ::+     Interrupt+  -> Connection+  -> Buffer+  -> IO (Either (ReceiveException Intr) Int)+receiveOnce !intr (Connection !conn) !buf = do+  let !mngr = EM.manager+  !tv <- EM.reader mngr conn+  box $ receiveLoop intr conn tv buf 1 0++-- Receive a number of bytes bounded on the upper end by the buffer length+-- and on the lower end by the integer argument. This will make repeated+-- calls to POSIX @recv@ until the lower bound is reached.+receiveBetween :: Interrupt -> Connection -> Buffer -> Int -> IO (Either (ReceiveException Intr) Int)+receiveBetween !intr (Connection !conn) !buf !minLen+  | Buffer.length buf > 0 = if minLen >= 0 && minLen <= Buffer.length buf+      then do+        let !mngr = EM.manager+        !tv <- EM.reader mngr conn+        box $ receiveLoop intr conn tv buf minLen 0+      else die "Socket.Stream.IPv4.receive: negative slice length"+  | Buffer.length buf == 0 && minLen == 0 = pure (Right 0)+  | otherwise = die "Socket.Stream.IPv4.receive: negative slice length"++type Result# = State# RealWorld -> (# State# RealWorld, (# ReceiveException Intr | Int# #) #)++unbox :: IO (Either (ReceiveException Intr) Int) -> Result#+{-# inline unbox #-}+unbox (IO f) = \s0 -> case f s0 of+  (# s1, e #) -> case e of+    Left err -> (# s1, (# err | #) #)+    Right (I# i) -> (# s1, (# | i #) #)++box :: Result# -> IO (Either (ReceiveException Intr) Int)+box f = IO $ \s0 -> case f s0 of+  (# s1, e #) -> case e of+    (# err | #) -> (# s1, Left err #)+    (# | i #) -> (# s1, Right (I# i) #)++-- We unbox the result since GHC is not very good at CPR analysis.+receiveLoop ::+     Interrupt+  -> Fd+  -> TVar Token+  -> Buffer+  -> Int+  -> Int+  -> Result#+     -- result is isomorphic to IO (Either (ReceiveException Intr) Int)+receiveLoop !intr !conn !tv !buf !minLen !total+  | minLen <= 0 = unbox (pure (Right total))+  | otherwise = unbox $ do+      let !maxLen = Buffer.length buf+      !token <- wait intr tv+      case tokenToStreamReceiveException token total of+        Left err -> pure (Left err)+        Right _ -> Receive.receiveOnce conn buf >>= \case+          Left err ->+            if | err == eAGAIN || err == eWOULDBLOCK -> do+                   EM.persistentUnready token tv+                   box $ receiveLoop intr conn tv buf minLen total+               | err == eCONNRESET -> pure (Left ReceiveReset)+               | err == eHOSTUNREACH -> pure (Left ReceiveHostUnreachable)+               | otherwise -> die ("Socket.Stream.IPv4.receive: " ++ describeErrorCode err)+          Right recvSzCInt -> if recvSzCInt /= 0+            then do+              let recvSz = csizeToInt recvSzCInt+              -- This unready only works because of a guarantee that epoll+              -- makes in the man page in FAQ question 9.+              when (recvSz < maxLen) (EM.unready token tv)+              box $ receiveLoop intr conn tv+                (Buffer.advance buf recvSz) (minLen - recvSz) (total + recvSz)+            else pure (Left ReceiveShutdown)++csizeToInt :: CSize -> Int+csizeToInt = fromIntegral++describeErrorCode :: Errno -> String+describeErrorCode err@(Errno e) = "error code " ++ D.string err ++ " (" ++ show e ++ ")"++
+ src-stream-send-two/Stream/Send/B.hsig view
@@ -0,0 +1,14 @@+signature Stream.Send.B where++import Stream.Send.Buffer.B (Buffer)++import Foreign.C.Error (Errno)+import Foreign.C.Types (CSize)+import Prelude (Either,IO)+import System.Posix.Types (Fd)++-- Make a single POSIX @send@ call with the unsafe FFI.+sendOnce ::+     Fd+  -> Buffer+  -> IO (Either Errno CSize)
+ src-stream-send-two/Stream/Send/Buffer/A.hsig view
@@ -0,0 +1,11 @@+signature Stream.Send.Buffer.A where++-- This signature is just a copy of Socket.Buffer+-- from src-buffer. I do not know of a way to reuse+-- the signature instead of duplicating it.++import Prelude (Int)++data Buffer+advance :: Buffer -> Int -> Buffer+length :: Buffer -> Int
+ src-stream-send-two/Stream/Send/Buffer/B.hsig view
@@ -0,0 +1,11 @@+signature Stream.Send.Buffer.B where++-- This signature is just a copy of Socket.Buffer+-- from src-buffer. I do not know of a way to reuse+-- the signature instead of duplicating it.++import Prelude (Int)++data Buffer+advance :: Buffer -> Int -> Buffer+length :: Buffer -> Int
+ src-stream-send-two/Stream/Send/Two.hsig view
@@ -0,0 +1,18 @@+signature Stream.Send.Two where++import Foreign.C.Error (Errno)+import Foreign.C.Types (CSize)+import Prelude (Either,IO)+import System.Posix.Types (Fd)+import Posix.Socket (MessageFlags,Message(Send))++import qualified Stream.Send.Buffer.A as A+import qualified Stream.Send.Buffer.B as B++-- Make a single POSIX @sendmsg@ call with the unsafe FFI+-- to single two payloads with a single system call.+sendOnce ::+     Fd+  -> A.Buffer+  -> B.Buffer+  -> IO (Either Errno CSize)
+ src-stream-send-two/Stream/Send/Two/Indefinite.hs view
@@ -0,0 +1,67 @@+{-# language BangPatterns #-}+{-# language LambdaCase #-}+{-# language MultiWayIf #-}++module Stream.Send.Two.Indefinite+  ( sendBoth+  ) where++import Control.Concurrent.STM (TVar)+import Foreign.C.Error (Errno(..), eAGAIN, eWOULDBLOCK, ePIPE, eCONNRESET)+import Foreign.C.Types (CSize)+import Socket.Error (die)+import Socket.EventManager (Token)+import Socket.Stream (SendException(..),Connection(..))+import Socket.Interrupt (Interrupt,Intr,wait,tokenToStreamSendException)+import System.Posix.Types (Fd)++import qualified Foreign.C.Error.Describe as D+import qualified Socket.EventManager as EM+import qualified Stream.Send.Two as SendBoth+import qualified Stream.Send.Buffer.A as A+import qualified Stream.Send.Buffer.B as B+import qualified Stream.Send.Indefinite as SendIndef++sendBoth ::+     Interrupt+  -> Connection+  -> A.Buffer+  -> B.Buffer+  -> IO (Either (SendException Intr) ())+sendBoth !intr (Connection !conn) !bufA !bufB = do+  let !mngr = EM.manager+  tv <- EM.writer mngr conn+  token0 <- wait intr tv+  case tokenToStreamSendException token0 0 of+    Left err -> pure (Left err)+    Right _ -> sendLoop intr conn tv token0 bufA bufB (A.length bufA) 0++sendLoop ::+     Interrupt -> Fd -> TVar Token -> Token+  -> A.Buffer -> B.Buffer -> Int -> Int -> IO (Either (SendException Intr) ())+sendLoop !intr !conn !tv !old !bufA !bufB !origLenA !sent = if lenA > 0+  then SendBoth.sendOnce conn bufA bufB >>= \case+    Left e ->+      if | e == eAGAIN || e == eWOULDBLOCK -> do+             EM.unready old tv+             new <- wait intr tv+             case tokenToStreamSendException new sent of+               Left err -> pure (Left err)+               Right _ -> sendLoop intr conn tv new bufA bufB origLenA sent+         | e == ePIPE -> pure (Left SendShutdown)+         | e == eCONNRESET -> pure (Left SendReset)+         | otherwise -> die ("Socket.Stream.send: " ++ describeErrorCode e)+    Right sz' -> do+      let sz = csizeToInt sz'+      sendLoop intr conn tv old (A.advance bufA sz) bufB origLenA (sent + sz)+  else do+    let !sentB = sent - origLenA+    SendIndef.sendLoop intr conn tv old (B.advance bufB sentB) sentB origLenA+  where+  !lenA = A.length bufA++csizeToInt :: CSize -> Int+csizeToInt = fromIntegral++describeErrorCode :: Errno -> String+describeErrorCode err@(Errno e) = "error code " ++ D.string err ++ " (" ++ show e ++ ")"
+ src-stream-send/Stream/Send.hsig view
@@ -0,0 +1,16 @@+{-# language DataKinds #-}++signature Stream.Send where++import Socket.Buffer (Buffer)++import Foreign.C.Error (Errno)+import Foreign.C.Types (CSize)+import Prelude (Either,IO)+import System.Posix.Types (Fd)++-- Make a single POSIX @send@ call with the unsafe FFI.+sendOnce ::+     Fd+  -> Buffer+  -> IO (Either Errno CSize)
+ src-stream-send/Stream/Send/Indefinite.hs view
@@ -0,0 +1,106 @@+{-# language BangPatterns #-}+{-# language LambdaCase #-}+{-# language MultiWayIf #-}++module Stream.Send.Indefinite+  ( send+  , sendOnce+  , sendLoop+  ) where++import Control.Concurrent.STM (TVar)+import Foreign.C.Error (Errno(..), eAGAIN, eWOULDBLOCK, ePIPE, eCONNRESET)+import Foreign.C.Types (CSize)+import Socket.Error (die)+import Socket.EventManager (Token)+import Socket.Stream (SendException(..),Connection(..))+import Socket.Buffer (Buffer)+import Socket.Interrupt (Interrupt,Intr,wait,tokenToStreamSendException)+import System.Posix.Types (Fd)++import qualified Foreign.C.Error.Describe as D+import qualified Socket.EventManager as EM+import qualified Socket.Buffer as Buffer+import qualified Stream.Send as Send++-- Send the entirely of the buffer, making repeated calls to+-- POSIX @send@ if necessary. This is used for stream sockets.+send :: Interrupt -> Connection -> Buffer -> IO (Either (SendException Intr) ())+send !intr (Connection !conn) !buf = do+  let !mngr = EM.manager+  tv <- EM.writer mngr conn+  token0 <- wait intr tv+  case tokenToStreamSendException token0 0 of+    Left err -> pure (Left err)+    Right _ -> sendLoop intr conn tv token0 buf 0 0++-- This function is exported but only so that it may be reused+-- by sockets-stream-send-two.+-- The last argument, @extraOff@, is needed so that when this function+-- is used by stream-send-two, we can report a correct offset that+-- includes the length of the first payload as well.+sendLoop ::+     Interrupt -> Fd -> TVar Token -> Token+  -> Buffer -> Int -> Int -> IO (Either (SendException Intr) ())+sendLoop !intr !conn !tv !old !buf !sent !extraOff = if len > 0+  then Send.sendOnce conn buf >>= \case+    Left e ->+      if | e == eAGAIN || e == eWOULDBLOCK -> do+             EM.unready old tv+             new <- wait intr tv+             case tokenToStreamSendException new (sent + extraOff) of+               Left err -> pure (Left err)+               Right _ -> sendLoop intr conn tv new buf sent extraOff+         | e == ePIPE -> pure (Left SendShutdown)+         | e == eCONNRESET -> pure (Left SendReset)+         | otherwise -> die ("Socket.Stream.send: " ++ describeErrorCode e)+    Right sz' -> do+      let sz = csizeToInt sz'+      sendLoop intr conn tv old (Buffer.advance buf sz) (sent + sz) extraOff+  else if len == 0+    then pure (Right ())+    else die "Socket.Stream.send: negative slice length"+  where+  !len = Buffer.length buf++-- TODO: sendOnce and send (along with their recursive helper+-- functions) are extremely similar. Maybe there is a way to+-- factor out something they have in common.+sendOnce :: Interrupt -> Connection -> Buffer -> IO (Either (SendException Intr) Int)+sendOnce !intr (Connection conn) !buf = do+  let !mngr = EM.manager+  tv <- EM.writer mngr conn+  token0 <- wait intr tv+  case tokenToStreamSendException token0 0 of+    Left err -> pure (Left err)+    Right _ -> sendOnceLoop intr conn tv token0 buf++sendOnceLoop ::+     Interrupt -> Fd -> TVar Token -> Token+  -> Buffer -> IO (Either (SendException Intr) Int)+sendOnceLoop !intr !conn !tv !old !buf = if len > 0+  then Send.sendOnce conn buf >>= \case+    Left e ->+      if | e == eAGAIN || e == eWOULDBLOCK -> do+             EM.unready old tv+             new <- wait intr tv+             case tokenToStreamSendException new 0 of+               Left err -> pure (Left err)+               Right _ -> sendOnceLoop intr conn tv new buf+         | e == ePIPE -> pure (Left SendShutdown)+         | e == eCONNRESET -> pure (Left SendReset)+         | otherwise -> die ("Socket.Stream.send: " ++ describeErrorCode e)+    Right sz' -> pure $! Right $! csizeToInt sz'+  else if len == 0+    then pure (Right 0)+    else die "Socket.Stream.send: negative slice length"+  where+  !len = Buffer.length buf++csizeToInt :: CSize -> Int+csizeToInt = fromIntegral++describeErrorCode :: Errno -> String+describeErrorCode err@(Errno e) = "error code " ++ D.string err ++ " (" ++ show e ++ ")"++
− src/Socket.hs 
@@ -1,143 +0,0 @@-{-# language BangPatterns #-}-{-# language DataKinds #-}-{-# language DeriveAnyClass #-}-{-# language DerivingStrategies #-}-{-# language DuplicateRecordFields #-}-{-# language GADTs #-}-{-# language KindSignatures #-}--module Socket-  ( SocketException(..)-  , SocketUnrecoverableException(..)-  , Direction(..)-  , Interruptibility(..)-  , Forkedness(..)-  , cgetsockname -  , cgetsockopt-  , cclose -  , crecv -  , crecvfrom-  , cshutdown-  , negativeSliceLength-  , nonInternetSocketFamily-  , functionWithAccepted-  , functionWithConnection-  , functionWithListener-  , functionWithSocket-  , functionGracefulClose-  , socketAddressSize-  ) where--import Control.Exception (Exception(..))-import Data.Kind (Type)-import Foreign.C.Types (CInt)--import qualified Data.List as L--data Direction = Send | Receive--data Interruptibility = Interruptible | Uninterruptible--data Forkedness = Forked | Unforked---- | Represents any unexpected behaviors that a function working on a---   socket, connection, or listener can exhibit.-data SocketException-  = SentMessageTruncated !Int-    -- ^ The datagram did not fit in the buffer. This can happen while-    --   sending. The field is the size of the number of bytes in the-    --   datagram that were successfully copied into the send buffer.-  | ReceivedMessageTruncated !Int-    -- ^ The datagram did not fit in the buffer. This can happen while-    --   receiving. The field is the original size of the datagram that-    --   was was truncated while copying it into the buffer.-  | SocketAddressSize-    -- ^ The socket address was not the expected size. This exception-    --   indicates a bug in this library or (less likely) in the-    --   operating system.-  | SocketAddressFamily !CInt-    -- ^ The socket address had an unexpected family. This exception-    --   indicates a bug in this library or (less likely) in the-    --   operating system. The int argument is the actual family-    --   found in the socket address.-  | OptionValueSize-    -- ^ The option value was not the expected size. This exception-    --   indicates a bug in this library or (less likely) in the-    --   operating system.-  | NegativeBytesRequested-    -- ^ The user requested a negative number of bytes in a call-    --   to a receive function.-  | ReceptionAbandoned-    -- ^ This happens when the @Unless@ variant of a function is-    --   used and the @STM@ action completes before the socket is-    --   ready for a read.-  | RemoteNotShutdown-    -- ^ The remote end sent more data when it was expected to send-    --   a shutdown.-  | RemoteShutdown-    -- ^ The remote end has shutdown its side of the full-duplex-    --   connection. This can happen @receive@ is called on a-    --   stream socket. This is not necessarily a bad thing. Many-    --   protocols use shutdown to indicate that no more data-    --   is available. These protocols can be contrasted with-    --   protocols that send a length representing a number of-    --   expected bytes.-  | ErrorCode !CInt-    -- ^ Any error code from the operating system that this library does-    --   not expect or recognize. Consult your operating system manual-    --   for details about the error code.-  deriving stock (Eq,Show)-  deriving anyclass (Exception)--data SocketUnrecoverableException = SocketUnrecoverableException-  { modules :: String-  , function :: String-  , description :: [String]-  }-  deriving stock (Show,Eq)--instance Exception SocketUnrecoverableException where-  displayException (SocketUnrecoverableException m f d) =-    m ++ "." ++ f ++ ": [" ++ L.intercalate "," d ++ "]"--cgetsockname :: String-cgetsockname = "getsockname"--cgetsockopt :: String-cgetsockopt = "getsockopt"--cclose :: String-cclose = "getsockname"--crecv :: String-crecv = "recv"--crecvfrom :: String-crecvfrom = "recvfrom"--cshutdown :: String-cshutdown = "shutdown"--functionGracefulClose :: String-functionGracefulClose = "gracefulClose"--nonInternetSocketFamily :: String-nonInternetSocketFamily = "non-internet socket family"--negativeSliceLength :: String-negativeSliceLength = "negative slice length"--functionWithAccepted :: String-functionWithAccepted = "withAccepted"--functionWithConnection :: String-functionWithConnection = "withConnection"--functionWithListener :: String-functionWithListener = "withListener"--functionWithSocket :: String-functionWithSocket = "withSocket"--socketAddressSize :: String-socketAddressSize = "socket address size"
+ src/Socket/Address.hs view
@@ -0,0 +1,26 @@+{-# language DuplicateRecordFields #-}+{-# language NamedFieldPuns #-}++module Socket.Address+  ( posixToIPv4Peer+  , ipv4PeerToPosix+  ) where++import Net.Types (IPv4(..))++import qualified Posix.Socket as S+import qualified Socket.IPv4 as IPv4++posixToIPv4Peer :: S.SocketAddressInternet -> IPv4.Peer+{-# inline posixToIPv4Peer #-}+posixToIPv4Peer (S.SocketAddressInternet {address,port}) = IPv4.Peer+  { address = IPv4 (S.networkToHostLong address)+  , port = S.networkToHostShort port+  }++ipv4PeerToPosix :: IPv4.Peer -> S.SocketAddressInternet+{-# inline ipv4PeerToPosix #-}+ipv4PeerToPosix (IPv4.Peer {address, port}) = S.SocketAddressInternet+  { port = S.hostToNetworkShort port+  , address = S.hostToNetworkLong (getIPv4 address)+  }
− src/Socket/Datagram.hs 
@@ -1,44 +0,0 @@-{-# language DataKinds #-}-{-# language DeriveAnyClass #-}-{-# language DerivingStrategies #-}-{-# language GADTs #-}-{-# language KindSignatures #-}-{-# language StandaloneDeriving #-}-module Socket.Datagram-  ( SendException(..)-  , ReceiveException(..)-  , SocketException(..)-  ) where--import Socket (Interruptibility(..))-import Socket.IPv4 (SocketException(..))--import Data.Kind (Type)-import Data.Typeable (Typeable)-import Control.Exception (Exception)--data SendException :: Interruptibility -> Type where-  -- | The datagram did not fit in the buffer. The field is the-  --   number of bytes that were successfully copied into the-  --   send buffer. The datagram does still get sent when this-  --   happens.-  SendTruncated :: !Int -> SendException i-  -- | Attempted to send to a broadcast address.-  SendBroadcasted :: SendException i-  -- | STM-style interrupt (much safer than C-style interrupt)-  SendInterrupted :: SendException 'Interruptible--deriving stock instance Show (SendException i)-deriving anyclass instance (Typeable i) => Exception (SendException i)--data ReceiveException :: Interruptibility -> Type where-  -- | The datagram did not fit in the buffer. The field is the-  --   original size of the datagram that was truncated. If-  --   this happens, the process probably needs to start using-  --   a larger receive buffer.-  ReceiveTruncated :: !Int -> ReceiveException i-  -- | STM-style interrupt (much safer than C-style interrupt)-  ReceiveInterrupted :: ReceiveException 'Interruptible--deriving stock instance Show (ReceiveException i)-deriving anyclass instance (Typeable i) => Exception (ReceiveException i)
+ src/Socket/Datagram/IPv4/Connected.hs view
@@ -0,0 +1,127 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}+{-# language DeriveAnyClass #-}+{-# language DerivingStrategies #-}+{-# language DuplicateRecordFields #-}+{-# language LambdaCase #-}+{-# language MagicHash #-}+{-# language NamedFieldPuns #-}+{-# language UnboxedTuples #-}+{-# language ScopedTypeVariables #-}++-- | Internet datagram sockets with a fixed destination.+module Socket.Datagram.IPv4.Connected+  ( -- * Types+    Socket(..)+  , Peer(..)+  , Message(..)+    -- * Establish+  , withSocket+    -- * Exceptions+  , SocketException(..)+    -- * Examples+    -- $examples+  ) where++import Control.Exception (mask,onException)+import Data.Word (Word16)+import Foreign.C.Error (Errno(..),eACCES)+import Foreign.C.Error (eNFILE,eMFILE,eADDRINUSE)+import GHC.IO (IO(..))+import Net.Types (IPv4(..))+import Socket (Connectedness(Connected))+import Socket.Datagram (Socket(..))+import Socket.Datagram (SocketException(..))+import Socket.IPv4 (Peer(..),Message(..))+import Socket.Error (die)++import qualified Foreign.C.Error.Describe as D+import qualified Linux.Socket as L+import qualified Posix.Socket as S+import qualified Socket as SCK+import qualified Socket.EventManager as EM++withSocket ::+     Peer+     -- ^ Address and port to bind to+  -> Peer+     -- ^ Peer address and port+  -> (Socket 'Connected ('SCK.Internet 'SCK.V4) -> Word16 -> IO a)+     -- ^ Callback providing the socket and the chosen port+  -> IO (Either SocketException a)+withSocket local@Peer{port = specifiedPort} !peer f = mask $ \restore -> do+  -- TODO: This is mostly copied from the unconnected withSocket.+  e1 <- S.uninterruptibleSocket S.internet+    (L.applySocketFlags (L.closeOnExec <> L.nonblocking) S.datagram)+    S.defaultProtocol+  case e1 of+    Left err -> handleSocketException err+    Right fd -> do+      let !mngr = EM.manager+      EM.register mngr fd+      e2 <- S.uninterruptibleBind fd+        (S.encodeSocketAddressInternet (endpointToSocketAddressInternet local))+      case e2 of+        Left err -> do+          -- We intentionally discard any exceptions thrown by close.+          -- There is simply nothing that can be done with them.+          S.uninterruptibleErrorlessClose fd+          handleBindException specifiedPort err+        Right _ -> do+          eactualPort <- if specifiedPort == 0+            then S.uninterruptibleGetSocketName fd S.sizeofSocketAddressInternet >>= \case+              Left err -> do+                S.uninterruptibleErrorlessClose fd+                die ("Socket.Datagram.IPv4.Connected.getsockname: " ++ describeErrorCode err)+              Right (sockAddrRequiredSz,sockAddr) -> if sockAddrRequiredSz == S.sizeofSocketAddressInternet+                then case S.decodeSocketAddressInternet sockAddr of+                  Just S.SocketAddressInternet{port = actualPort} -> do+                    let cleanPort = S.networkToHostShort actualPort+                    pure (Right cleanPort)+                  Nothing -> do+                    S.uninterruptibleErrorlessClose fd+                    die "Socket.Datagram.IPv4.Connected: non-internet socket family"+                else do+                  S.uninterruptibleErrorlessClose fd+                  die "Socket.Datagram.IPv4.Connected: socket address size"+            else pure (Right specifiedPort)+          case eactualPort of+            Left err -> pure (Left err)+            Right actualPort -> do+              let sockAddr = id+                    $ S.encodeSocketAddressInternet+                    $ endpointToSocketAddressInternet+                    $ peer+              S.uninterruptibleConnect fd sockAddr >>= \case+                Left err -> +                  die ("Socket.Datagram.IPv4.Connected.connect: " ++ describeErrorCode err)+                Right (_ :: ()) -> do+                  a <- onException (restore (f (Socket fd) actualPort)) (S.uninterruptibleErrorlessClose fd)+                  S.uninterruptibleClose fd >>= \case+                    Left err -> die ("Socket.Datagram.IPv4.Undestined.close: " ++ describeErrorCode err)+                    Right _ -> pure (Right a)++describeErrorCode :: Errno -> String+describeErrorCode err@(Errno e) = "error code " ++ D.string err ++ " (" ++ show e ++ ")"++endpointToSocketAddressInternet :: Peer -> S.SocketAddressInternet+endpointToSocketAddressInternet (Peer {address, port}) = S.SocketAddressInternet+  { port = S.hostToNetworkShort port+  , address = S.hostToNetworkLong (getIPv4 address)+  }++handleSocketException :: Errno -> IO (Either SocketException a)+handleSocketException e+  | e == eMFILE = pure (Left SocketFileDescriptorLimit)+  | e == eNFILE = pure (Left SocketFileDescriptorLimit)+  | otherwise = die+      ("Socket.Datagram.IPv4.Undestined.socket: " ++ describeErrorCode e)++handleBindException :: Word16 -> Errno -> IO (Either SocketException a)+handleBindException !thePort !e+  | e == eACCES = pure (Left SocketPermissionDenied)+  | e == eADDRINUSE = if thePort == 0+      then pure (Left SocketAddressInUse)+      else pure (Left SocketEphemeralPortsExhausted)+  | otherwise = die+      ("Socket.Datagram.IPv4.Undestined.bind: " ++ describeErrorCode e)
− src/Socket/Datagram/IPv4/Spoof.hs 
@@ -1,291 +0,0 @@-{-# language BangPatterns #-}-{-# language DataKinds #-}-{-# language DeriveAnyClass #-}-{-# language DerivingStrategies #-}-{-# language DuplicateRecordFields #-}-{-# language GADTs #-}-{-# language KindSignatures #-}-{-# language LambdaCase #-}-{-# language MagicHash #-}-{-# language NamedFieldPuns #-}-{-# language StandaloneDeriving #-}-{-# language UnboxedTuples #-}---- | Internet datagram sockets without a fixed destination.--- The user may spoof the source address and may specify the--- packet ID. An application must have @CAP_NET_RAW@ or be--- running as root to use the functions in this module.-module Socket.Datagram.IPv4.Spoof-  ( -- * Types-    Socket(..)-  , Endpoint(..)-  , Message(..)-    -- * Establish-  , withSocket-    -- * Communicate-  , sendMutableByteArray-    -- * Exceptions-  , SocketException(..)-  , SendException(..)-  ) where--import Control.Concurrent (threadWaitWrite)-import Control.Exception (Exception,throwIO,mask,onException)-import Data.Bits (unsafeShiftR,complement,(.&.))-import Data.Kind (Type)-import Data.Primitive (MutableByteArray(..))-import Data.Word (Word16,Word8,Word64,Word32)-import Foreign.C.Error (Errno(..),eWOULDBLOCK,eAGAIN,eMFILE,eNFILE,eACCES,ePERM)-import Foreign.C.Types (CInt,CSize)-import GHC.Exts (RealWorld,touch#)-import GHC.IO (IO(..))-import Net.Types (IPv4(..))-import Socket (SocketUnrecoverableException(..),Interruptibility(..))-import Socket.Datagram (SendException(..))-import Socket.Datagram.IPv4.Undestined.Internal (Message(..))-import Socket.Debug (debug,whenDebugging)-import Socket.IPv4 (Endpoint(..))-import System.Posix.Types (Fd)-import Text.Printf (printf)--import qualified Data.Primitive as PM-import qualified Foreign.C.Error.Describe as D-import qualified GHC.Exts as E-import qualified Linux.Socket as L-import qualified Posix.Socket as S-import qualified Socket as SCK---- TODO: Something I am not sure about is whether or not it is necessary--- to bind to a port right after creating the socket. If we defering--- binding until the call to the time of sending, what port do we bind--- to? Does the kernel use the one in the source port or does it choose--- an ephemeral port? We need it to choose an ephemeral port. Otherwise,--- we can get spurious failures.---- | A socket that send datagrams with spoofed source IP addresses.--- It cannot receive datagrams.-newtype Socket = Socket Fd-  deriving stock (Eq,Ord,Show)--data SocketException :: Type where-  -- | Permission to create a raw socket was denied. The process needs-  --   the capability @CAP_NET_RAW@, or it must be run as root.-  SocketPermissionDenied :: SocketException-  -- | A limit on the number of open file descriptors has been reached.-  --   This could be the per-process limit or the system limit.-  --   (@EMFILE@ and @ENFILE@)-  SocketFileDescriptorLimit :: SocketException--deriving stock instance Show SocketException-deriving anyclass instance Exception SocketException---- | Open a socket and run the supplied callback on it. This closes the socket--- when the callback finishes or when an exception is thrown. Do not return --- the socket from the callback. This leads to undefined behavior. The user--- cannot specify an endpoint since the socket cannot receive traffic.-withSocket ::-     (Socket -> IO a) -- ^ Callback providing the socket-  -> IO (Either SocketException a)-withSocket f = mask $ \restore -> do-  debug "withSocket: opening raw socket"-  e1 <- S.uninterruptibleSocket S.internet-    (L.applySocketFlags (L.closeOnExec <> L.nonblocking) S.raw)-    S.rawProtocol-  debug "withSocket: opened raw socket"-  case e1 of-    Left err -> handleSocketException SCK.functionWithSocket err-    Right fd -> do-      a <- onException (restore (f (Socket fd))) (S.uninterruptibleErrorlessClose fd)-      S.uninterruptibleClose fd >>= \case-        Left err -> throwIO $ SocketUnrecoverableException-          moduleSocketDatagramIPv4Spoof-          SCK.functionWithSocket-          ["close",describeErrorCode err]-        Right _ -> pure (Right a)---- | Send a slice of a bytearray to the specified endpoint.-sendMutableByteArray ::-     Socket -- ^ Socket-  -> Endpoint -- ^ Spoofed source address and port-  -> Endpoint -- ^ Remote IPv4 address and port-  -> MutableByteArray RealWorld -- ^ Buffer (will be sliced)-  -> Int -- ^ Offset into payload-  -> Int -- ^ Lenth of slice into buffer-  -> IO (Either (SendException 'Uninterruptible) ())-sendMutableByteArray (Socket !s) !theSource !theRemote !thePayload !off !len = do-  let ipHeaderSz = cintToInt L.sizeofIpHeader-  let totalHeaderSz = cintToInt (L.sizeofIpHeader + L.sizeofUdpHeader)-  let totalPacketSz = len + totalHeaderSz-  -- Why do we add one to the size? This extra byte at the end will always-  -- be zeroed out. It makes UDP checksum calculation a little easier,-  -- since we can now pull out Word16s until we reach the end. If the-  -- original length was even, this extra byte ends up unused by the-  -- checksum. But, if the original length was odd, it does get used.-  buf <- PM.newPinnedByteArray (totalPacketSz + 1)-  PM.setByteArray buf 0 (totalPacketSz + 1) (0 :: Word8)-  let addr = PM.mutableByteArrayContents buf-  L.pokeIpHeaderVersionIhl addr (4 * 16 + 5)-  L.pokeIpHeaderTypeOfService addr 0-  -- TODO: Actually check the length.-  -- NB: The packet length must be in network byte order.-  -- Expermentally, it seems that it does not.-  L.pokeIpHeaderTotalLength addr (S.hostToNetworkShort (intToWord16 totalPacketSz))-  L.pokeIpHeaderIdentifier addr 0-  L.pokeIpHeaderFragmentOffset addr 0-  L.pokeIpHeaderTimeToLive addr 64-  L.pokeIpHeaderProtocol addr (cintToWord8 (S.getProtocol S.udp))-  -- The linux kernel fills in the ip header checksum for us.-  L.pokeIpHeaderChecksum addr 0-  let src = S.hostToNetworkLong (getIPv4 (address theSource))-  L.pokeIpHeaderSourceAddress addr src-  let dst = S.hostToNetworkLong (getIPv4 (address theRemote))-  L.pokeIpHeaderDestinationAddress addr dst-  let udpAddr = PM.plusAddr addr ipHeaderSz-  L.pokeUdpHeaderSourcePort udpAddr (S.hostToNetworkShort (port theSource))-  L.pokeUdpHeaderDestinationPort udpAddr (S.hostToNetworkShort (port theRemote))-  let udpLen = cintToInt L.sizeofUdpHeader + len-  L.pokeUdpHeaderLength udpAddr (S.hostToNetworkShort (intToWord16 udpLen))-  PM.copyMutableByteArray buf totalHeaderSz thePayload off len-  L.pokeUdpHeaderChecksum udpAddr . S.hostToNetworkShort =<< udpChecksum src dst buf ipHeaderSz udpLen-  touchMutableByteArray buf-  debug ("spoof send mutable: about to send to " ++ show theRemote)-  whenDebugging $ do-    d <- PM.newByteArray totalPacketSz-    PM.copyMutableByteArray d 0 buf 0 totalPacketSz-    x <- PM.unsafeFreezeByteArray d-    debug ("raw packet: " ++ (foldMap (printf "%.2x ") (E.toList x)))-  e1 <- S.uninterruptibleSendToMutableByteArray s buf 0 (intToCSize totalPacketSz)-    mempty-    (S.encodeSocketAddressInternet (endpointToSocketAddressInternet theRemote))-  debug ("spoof send mutable: just sent to " ++ show theRemote)-  case e1 of-    Left err1 -> if err1 == eWOULDBLOCK || err1 == eAGAIN-      then do-        debug ("send mutable: waiting to for write ready to send to " ++ show theRemote)-        threadWaitWrite s-        e2 <- S.uninterruptibleSendToMutableByteArray s buf-          (intToCInt off)-          (intToCSize len)-          mempty-          (S.encodeSocketAddressInternet (endpointToSocketAddressInternet theRemote))-        case e2 of-          Left err2 -> do-            debug ("send mutable: encountered error after sending")-            handleSendException "sendMutableByteArray" err2-          Right sz -> if csizeToInt sz == totalPacketSz-            then pure (Right ())-            else pure (Left (SendTruncated (csizeToInt sz)))-      else do-        debug "spoof send mutable: sent on first try but got error code" -        handleSendException "sendMutableByteArray" err1-    Right sz -> if csizeToInt sz == totalPacketSz-      then do-        debug ("send mutable: success")-        pure (Right ())-      else pure (Left (SendTruncated (csizeToInt sz)))---- Precondition: the mutable byte array must have an extra zeroed out--- byte at the end. That is, at arr[offset+length], there exists a--- zero byte. The offset must divide two evenly.-udpChecksum ::-     Word32 -- source (network byte order)-  -> Word32 -- dest (network byte order)-  -> MutableByteArray RealWorld -- payload-  -> Int -- offset (start of the udp header)-  -> Int -- length (udp header size plus payload size) -  -> IO Word16-udpChecksum src dst payload off len = do-  let sum0 = word16ToWord64 (S.hostToNetworkShort (word32ToWord16 src))-  debug ("udp checksum source lower: " ++ printf "%.8X" sum0)-  let sum1 = sum0 + word16ToWord64 (S.hostToNetworkShort (word32ToWord16 (unsafeShiftR src 16)))-  debug ("udp checksum source lower+upper: " ++ printf "%.8X" sum1)-  let sum2 = sum1 + word16ToWord64 (S.hostToNetworkShort (word32ToWord16 dst))-      sum3 = sum2 + word16ToWord64 (S.hostToNetworkShort (word32ToWord16 (unsafeShiftR dst 16)))-  debug ("udp checksum source+dest lower+upper: " ++ printf "%.8X" sum3)-  let sum4 = sum3 + word16ToWord64 (cintToWord16 (S.getProtocol S.udp))-      sum5 = sum4 + word16ToWord64 (intToWord16 len)-  debug ("udp checksum pseudoheader without carries: " ++ printf "%.8X" sum5)-  let halfLen = unsafeShiftR (len + off) 1-  debug ("udp checksum start offset: " ++ show (unsafeShiftR off 1))-  debug ("udp checksum last offset: " ++ show halfLen)-  let go :: Int -> Word64 -> IO Word64-      go !ix !acc = if ix < halfLen-        then do-          w16 <- PM.readByteArray payload ix :: IO Word16-          debug ("udp checksum payload iteration " ++ show ix ++ ": " ++ printf "%.8X" acc)-          go (ix + 1) (word16ToWord64 (S.hostToNetworkShort w16) + acc)-        else pure acc-  r <- go (unsafeShiftR off 1) sum5-  -- We assume that the upper 16 bits in this 64-bit word are zeroes.-  -- There is no way for a datagram to be long enough to start to-  -- fill the bits beyond 48.-  pure (word64ToWord16 (complement ((r .&. 0xFFFF) + (unsafeShiftR r 16 .&. 0xFFFF) + (unsafeShiftR r 32))))--endpointToSocketAddressInternet :: Endpoint -> S.SocketAddressInternet-endpointToSocketAddressInternet (Endpoint {address, port}) = S.SocketAddressInternet-  { port = S.hostToNetworkShort port-  , address = S.hostToNetworkLong (getIPv4 address)-  }--intToCInt :: Int -> CInt-intToCInt = fromIntegral--intToCSize :: Int -> CSize-intToCSize = fromIntegral--csizeToInt :: CSize -> Int-csizeToInt = fromIntegral--cintToInt :: CInt -> Int-cintToInt = fromIntegral--cintToWord8 :: CInt -> Word8-cintToWord8 = fromIntegral--intToWord16 :: Int -> Word16-intToWord16 = fromIntegral--cintToWord16 :: CInt -> Word16-cintToWord16 = fromIntegral--word16ToWord64 :: Word16 -> Word64-word16ToWord64 = fromIntegral--word64ToWord16 :: Word64 -> Word16-word64ToWord16 = fromIntegral--word32ToWord16 :: Word32 -> Word16-word32ToWord16 = fromIntegral--touchMutableByteArray :: MutableByteArray RealWorld -> IO ()-touchMutableByteArray (MutableByteArray x) = touchMutableByteArray# x--touchMutableByteArray# :: E.MutableByteArray# RealWorld -> IO ()-touchMutableByteArray# x = IO $ \s -> case touch# x s of s' -> (# s', () #)--moduleSocketDatagramIPv4Spoof :: String-moduleSocketDatagramIPv4Spoof = "Socket.Datagram.IPv4.Spoof"--handleSocketException :: String -> Errno -> IO (Either SocketException a)-{-# INLINE handleSocketException #-}-handleSocketException func e-  | e == ePERM = pure (Left SocketPermissionDenied)-  | e == eMFILE = pure (Left SocketFileDescriptorLimit)-  | e == eNFILE = pure (Left SocketFileDescriptorLimit)-  | otherwise = throwIO $ SocketUnrecoverableException-      moduleSocketDatagramIPv4Spoof-      func-      [describeErrorCode e]--describeErrorCode :: Errno -> String-describeErrorCode err@(Errno e) = "error code " ++ D.string err ++ " (" ++ show e ++ ")"--handleSendException :: String -> Errno -> IO (Either (SendException i) a)-{-# INLINE handleSendException #-}-handleSendException func e-  | e == eACCES = pure (Left SendBroadcasted)-  | otherwise = throwIO $ SocketUnrecoverableException-      moduleSocketDatagramIPv4Spoof-      func-      [describeErrorCode e]-
+ src/Socket/Datagram/IPv4/Unconnected.hs view
@@ -0,0 +1,126 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}+{-# language DeriveAnyClass #-}+{-# language DerivingStrategies #-}+{-# language DuplicateRecordFields #-}+{-# language LambdaCase #-}+{-# language MagicHash #-}+{-# language NamedFieldPuns #-}+{-# language UnboxedTuples #-}++-- | Internet datagram sockets without a fixed destination.+module Socket.Datagram.IPv4.Unconnected+  ( -- * Types+    Socket(..)+  , Peer(..)+  , Message(..)+    -- * Establish+  , withSocket+    -- * Exceptions+  , SocketException(..)+  ) where++import Control.Exception (mask,onException)+import Data.Word (Word16)+import Foreign.C.Error (Errno(..),eACCES)+import Foreign.C.Error (eNFILE,eMFILE,eADDRINUSE)+import GHC.IO (IO(..))+import Net.Types (IPv4(..))+import Socket (Connectedness(Unconnected))+import Socket.Datagram (Socket(..))+import Socket.Datagram (SocketException(..))+import Socket.Debug (debug)+import Socket.IPv4 (Peer(..),Message(..),describeEndpoint)+import Socket.Error (die)++import qualified Foreign.C.Error.Describe as D+import qualified Linux.Socket as L+import qualified Posix.Socket as S+import qualified Socket as SCK+import qualified Socket.EventManager as EM++-- | Open a socket and run the supplied callback on it. This closes the socket+-- when the callback finishes or when an exception is thrown. Do not return +-- the socket from the callback. This leads to undefined behavior. If the+-- address @0.0.0.0@ is used, the socket receives on all network interfaces.+-- If the port 0 is used, an unused port is chosen by the operating system.+-- The callback provides the chosen port (or if the user specified a non-zero+-- port, the chosen port will be that value).+withSocket ::+     Peer+     -- ^ Address and port to use+  -> (Socket 'Unconnected ('SCK.Internet 'SCK.V4)  -> Word16 -> IO a)+     -- ^ Callback providing the socket and the chosen port+  -> IO (Either SocketException a)+withSocket endpoint@Peer{port = specifiedPort} f = mask $ \restore -> do+  debug ("withSocket: opening socket " ++ describeEndpoint endpoint)+  e1 <- S.uninterruptibleSocket S.internet+    (L.applySocketFlags (L.closeOnExec <> L.nonblocking) S.datagram)+    S.defaultProtocol+  debug ("withSocket: opened socket " ++ describeEndpoint endpoint)+  case e1 of+    Left err -> handleSocketException err+    Right fd -> do+      let !mngr = EM.manager+      EM.register mngr fd+      e2 <- S.uninterruptibleBind fd+        (S.encodeSocketAddressInternet (endpointToSocketAddressInternet endpoint))+      debug ("withSocket: requested binding for " ++ describeEndpoint endpoint)+      case e2 of+        Left err -> do+          -- We intentionally discard any exceptions thrown by close.+          -- There is simply nothing that can be done with them.+          S.uninterruptibleErrorlessClose fd+          handleBindException specifiedPort err+        Right _ -> do+          eactualPort <- if specifiedPort == 0+            then S.uninterruptibleGetSocketName fd S.sizeofSocketAddressInternet >>= \case+              Left err -> do+                S.uninterruptibleErrorlessClose fd+                die ("Socket.Datagram.IPv4.Undestined.getsockname: " ++ describeErrorCode err)+              Right (sockAddrRequiredSz,sockAddr) -> if sockAddrRequiredSz == S.sizeofSocketAddressInternet+                then case S.decodeSocketAddressInternet sockAddr of+                  Just S.SocketAddressInternet{port = actualPort} -> do+                    let cleanPort = S.networkToHostShort actualPort+                    debug ("withSocket: successfully bound " ++ describeEndpoint endpoint ++ " and got port " ++ show cleanPort)+                    pure (Right cleanPort)+                  Nothing -> do+                    S.uninterruptibleErrorlessClose fd+                    die "Socket.Datagram.IPv4.Undestined: non-internet socket family"+                else do+                  S.uninterruptibleErrorlessClose fd+                  die "Socket.Datagram.IPv4.Undestined: socket address size"+            else pure (Right specifiedPort)+          case eactualPort of+            Left err -> pure (Left err)+            Right actualPort -> do+              a <- onException (restore (f (Socket fd) actualPort)) (S.uninterruptibleErrorlessClose fd)+              S.uninterruptibleClose fd >>= \case+                Left err -> die ("Socket.Datagram.IPv4.Undestined.close: " ++ describeErrorCode err)+                Right _ -> pure (Right a)+++endpointToSocketAddressInternet :: Peer -> S.SocketAddressInternet+endpointToSocketAddressInternet (Peer {address, port}) = S.SocketAddressInternet+  { port = S.hostToNetworkShort port+  , address = S.hostToNetworkLong (getIPv4 address)+  }++describeErrorCode :: Errno -> String+describeErrorCode err@(Errno e) = "error code " ++ D.string err ++ " (" ++ show e ++ ")"++handleSocketException :: Errno -> IO (Either SocketException a)+handleSocketException e+  | e == eMFILE = pure (Left SocketFileDescriptorLimit)+  | e == eNFILE = pure (Left SocketFileDescriptorLimit)+  | otherwise = die+      ("Socket.Datagram.IPv4.Undestined.socket: " ++ describeErrorCode e)++handleBindException :: Word16 -> Errno -> IO (Either SocketException a)+handleBindException !thePort !e+  | e == eACCES = pure (Left SocketPermissionDenied)+  | e == eADDRINUSE = if thePort == 0+      then pure (Left SocketAddressInUse)+      else pure (Left SocketEphemeralPortsExhausted)+  | otherwise = die+      ("Socket.Datagram.IPv4.Undestined.bind: " ++ describeErrorCode e)
− src/Socket/Datagram/IPv4/Undestined.hs 
@@ -1,377 +0,0 @@-{-# language BangPatterns #-}-{-# language DataKinds #-}-{-# language DeriveAnyClass #-}-{-# language DerivingStrategies #-}-{-# language DuplicateRecordFields #-}-{-# language LambdaCase #-}-{-# language MagicHash #-}-{-# language NamedFieldPuns #-}-{-# language UnboxedTuples #-}---- | Internet datagram sockets without a fixed destination.-module Socket.Datagram.IPv4.Undestined-  ( -- * Types-    Socket(..)-  , Endpoint(..)-  , Message(..)-    -- * Establish-  , withSocket-    -- * Communicate-  , send-  , sendMutableByteArraySlice-  , receiveByteArray-  , receiveMutableByteArraySlice_-  , receiveMany-  , receiveManyUnless-    -- * Exceptions-  , SocketException(..)-    -- * Examples-    -- $examples-  ) where--import Control.Concurrent (threadWaitWrite,threadWaitRead)-import Control.Exception (throwIO,mask,onException)-import Data.Primitive (ByteArray,MutableByteArray(..))-import Data.Word (Word16)-import Foreign.C.Error (Errno(..),eWOULDBLOCK,eAGAIN,eACCES)-import Foreign.C.Types (CInt,CSize)-import GHC.Exts (Int(I#),RealWorld,shrinkMutableByteArray#,ByteArray#,touch#)-import GHC.IO (IO(..))-import Net.Types (IPv4(..))-import Socket (SocketException(..),SocketUnrecoverableException(..),Direction(..),Interruptibility(..))-import Socket (cgetsockname)-import Socket.Datagram (SendException(..),ReceiveException(..))-import Socket.Datagram.IPv4.Undestined.Internal (Message(..),Socket(..))-import Socket.Datagram.IPv4.Undestined.Multiple (receiveMany,receiveManyUnless)-import Socket.Debug (debug)-import Socket.IPv4 (Endpoint(..),describeEndpoint)--import qualified Socket as SCK-import qualified Control.Monad.Primitive as PM-import qualified Data.Primitive as PM-import qualified Foreign.C.Error.Describe as D-import qualified Linux.Socket as L-import qualified Posix.Socket as S---- | Open a socket and run the supplied callback on it. This closes the socket--- when the callback finishes or when an exception is thrown. Do not return --- the socket from the callback. This leads to undefined behavior. If the--- address @0.0.0.0@ is used, the socket receives on all network interfaces.--- If the port 0 is used, an unused port is chosen by the operating system.--- The callback provides the chosen port (or if the user specified a non-zero--- port, the chosen port will be that value).-withSocket ::-     Endpoint -- ^ Address and port to use-  -> (Socket -> Word16 -> IO a) -- ^ Callback providing the socket and the chosen port-  -> IO (Either SocketException a)-withSocket endpoint@Endpoint{port = specifiedPort} f = mask $ \restore -> do-  debug ("withSocket: opening socket " ++ describeEndpoint endpoint)-  e1 <- S.uninterruptibleSocket S.internet-    (L.applySocketFlags (L.closeOnExec <> L.nonblocking) S.datagram)-    S.defaultProtocol-  debug ("withSocket: opened socket " ++ describeEndpoint endpoint)-  case e1 of-    Left err -> throwIO $ SocketUnrecoverableException-      moduleSocketDatagramIPv4Undestined-      functionWithSocket-      ["socket",describeEndpoint endpoint,describeErrorCode err]-    Right fd -> do-      e2 <- S.uninterruptibleBind fd-        (S.encodeSocketAddressInternet (endpointToSocketAddressInternet endpoint))-      debug ("withSocket: requested binding for " ++ describeEndpoint endpoint)-      case e2 of-        Left err -> do-          -- We intentionally discard any exceptions thrown by close. There is-          -- simply nothing that can be done with them.-          S.uninterruptibleErrorlessClose fd-          throwIO $ SocketUnrecoverableException-            moduleSocketDatagramIPv4Undestined-            functionWithSocket-            ["bind",describeEndpoint endpoint,describeErrorCode err]-        Right _ -> do-          eactualPort <- if specifiedPort == 0-            then S.uninterruptibleGetSocketName fd S.sizeofSocketAddressInternet >>= \case-              Left err -> do-                S.uninterruptibleErrorlessClose fd-                throwIO $ SocketUnrecoverableException-                  moduleSocketDatagramIPv4Undestined-                  functionWithSocket-                  ["getsockname",describeEndpoint endpoint,describeErrorCode err]-              Right (sockAddrRequiredSz,sockAddr) -> if sockAddrRequiredSz == S.sizeofSocketAddressInternet-                then case S.decodeSocketAddressInternet sockAddr of-                  Just S.SocketAddressInternet{port = actualPort} -> do-                    let cleanPort = S.networkToHostShort actualPort-                    debug ("withSocket: successfully bound " ++ describeEndpoint endpoint ++ " and got port " ++ show cleanPort)-                    pure (Right cleanPort)-                  Nothing -> do-                    S.uninterruptibleErrorlessClose fd-                    throwIO $ SocketUnrecoverableException-                      moduleSocketDatagramIPv4Undestined-                      functionWithSocket-                      [cgetsockname,describeEndpoint endpoint,"non-internet socket family"]-                else do-                  S.uninterruptibleErrorlessClose fd-                  throwIO $ SocketUnrecoverableException-                    moduleSocketDatagramIPv4Undestined-                    functionWithSocket-                    [cgetsockname,describeEndpoint endpoint,"socket address size"]-            else pure (Right specifiedPort)-          case eactualPort of-            Left err -> pure (Left err)-            Right actualPort -> do-              a <- onException (restore (f (Socket fd) actualPort)) (S.uninterruptibleErrorlessClose fd)-              S.uninterruptibleClose fd >>= \case-                Left err -> throwIO $ SocketUnrecoverableException-                  moduleSocketDatagramIPv4Undestined-                  functionWithSocket-                  ["close",describeEndpoint endpoint,describeErrorCode err]-                Right _ -> pure (Right a)---- | Send a slice of a bytearray to the specified endpoint.-send ::-     Socket -- ^ Socket-  -> Endpoint -- ^ Remote IPv4 address and port-  -> ByteArray -- ^ Buffer (will be sliced)-  -> Int -- ^ Offset into payload-  -> Int -- ^ Lenth of slice into buffer-  -> IO (Either SocketException ())-send (Socket !s) !theRemote !thePayload !off !len = do-  debug ("send: about to send to " ++ show theRemote)-  e1 <- S.uninterruptibleSendToByteArray s thePayload-    (intToCInt off)-    (intToCSize len)-    mempty-    (S.encodeSocketAddressInternet (endpointToSocketAddressInternet theRemote))-  debug ("send: just sent to " ++ show theRemote)-  case e1 of-    Left err1 -> if err1 == eWOULDBLOCK || err1 == eAGAIN-      then do-        debug ("send: waiting to for write ready to send to " ++ show theRemote)-        threadWaitWrite s-        e2 <- S.uninterruptibleSendToByteArray s thePayload-          (intToCInt off)-          (intToCSize len)-          mempty-          (S.encodeSocketAddressInternet (endpointToSocketAddressInternet theRemote))-        case e2 of-          Left err2 -> do-            debug ("send: encountered error after sending")-            throwIO $ SocketUnrecoverableException-              moduleSocketDatagramIPv4Undestined-              functionSend-              [show theRemote,describeErrorCode err2]-          Right sz -> if csizeToInt sz == len-            then pure (Right ())-            else pure (Left (SentMessageTruncated (csizeToInt sz)))-      else throwIO $ SocketUnrecoverableException-        moduleSocketDatagramIPv4Undestined-        functionSend-        [show theRemote,describeErrorCode err1]-    Right sz -> if csizeToInt sz == len-      then do-        debug ("send: success")-        pure (Right ())-      else pure (Left (SentMessageTruncated (csizeToInt sz)))---- | Send a slice of a bytearray to the specified endpoint.-sendMutableByteArraySlice ::-     Socket -- ^ Socket-  -> Endpoint -- ^ Remote IPv4 address and port-  -> MutableByteArray RealWorld -- ^ Buffer (will be sliced)-  -> Int -- ^ Offset into payload-  -> Int -- ^ Lenth of slice into buffer-  -> IO (Either (SendException 'Uninterruptible) ())-sendMutableByteArraySlice (Socket !s) !theRemote !thePayload !off !len = do-  debug ("send mutable: about to send to " ++ show theRemote)-  e1 <- S.uninterruptibleSendToMutableByteArray s thePayload-    (intToCInt off)-    (intToCSize len)-    mempty-    (S.encodeSocketAddressInternet (endpointToSocketAddressInternet theRemote))-  debug ("send mutable: just sent to " ++ show theRemote)-  case e1 of-    Left err1 -> if err1 == eWOULDBLOCK || err1 == eAGAIN-      then do-        debug ("send mutable: waiting to for write ready to send to " ++ show theRemote)-        threadWaitWrite s-        e2 <- S.uninterruptibleSendToMutableByteArray s thePayload-          (intToCInt off)-          (intToCSize len)-          mempty-          (S.encodeSocketAddressInternet (endpointToSocketAddressInternet theRemote))-        case e2 of-          Left err2 -> do-            debug ("send mutable: encountered error after sending")-            handleSendException functionSendMutableByteArray err2-          Right sz -> if csizeToInt sz == len-            then pure (Right ())-            else pure (Left (SendTruncated (csizeToInt sz)))-      else handleSendException functionSendMutableByteArray err1-    Right sz -> if csizeToInt sz == len-      then do-        debug ("send mutable: success")-        pure (Right ())-      else pure (Left (SendTruncated (csizeToInt sz)))---- | Receive a datagram into a freshly allocated bytearray.-receiveByteArray ::-     Socket -- ^ Socket-  -> Int -- ^ Maximum size of datagram to receive-  -> IO (Either (ReceiveException 'Uninterruptible) Message)-receiveByteArray (Socket !fd) !maxSz = do-  debug "receive: about to wait"-  threadWaitRead fd-  debug "receive: socket is now readable"-  marr <- PM.newByteArray maxSz-  -- We use MSG_TRUNC so that we are able to figure out whether-  -- or not bytes were discarded. If bytes were discarded-  -- (meaning that the buffer was too small), we return an-  -- exception.-  e <- S.uninterruptibleReceiveFromMutableByteArray fd marr 0-    (intToCSize maxSz) (L.truncate) S.sizeofSocketAddressInternet-  debug "receive: finished reading from socket"-  case e of-    Left err -> throwIO $ SocketUnrecoverableException-      moduleSocketDatagramIPv4Undestined-      functionReceive-      [describeErrorCode err]-    Right (sockAddrRequiredSz,sockAddr,recvSz) -> if csizeToInt recvSz <= maxSz-      then if sockAddrRequiredSz == S.sizeofSocketAddressInternet-        then case S.decodeSocketAddressInternet sockAddr of-          Just sockAddrInet -> do-            shrinkMutableByteArray marr (csizeToInt recvSz)-            arr <- PM.unsafeFreezeByteArray marr-            pure $ Right (Message (socketAddressInternetToEndpoint sockAddrInet) arr)-          Nothing -> throwIO $ SocketUnrecoverableException-            moduleSocketDatagramIPv4Undestined-            functionReceive-            [SCK.crecvfrom,SCK.nonInternetSocketFamily]-        else throwIO $ SocketUnrecoverableException-          moduleSocketDatagramIPv4Undestined-          functionReceive-          [SCK.crecvfrom,SCK.socketAddressSize]-      else pure (Left (ReceiveTruncated (csizeToInt recvSz)))---- | Receive a datagram into a mutable byte array, ignoring information about---   the remote endpoint. Returns the actual number of bytes present in the---   datagram. Precondition: @buffer_length - offset >= max_datagram_length@.-receiveMutableByteArraySlice_ ::-     Socket -- ^ Socket-  -> MutableByteArray RealWorld -- ^ Buffer-  -> Int -- ^ Offset into buffer-  -> Int -- ^ Maximum size of datagram to receive-  -> IO (Either SocketException Int)-receiveMutableByteArraySlice_ (Socket !fd) !buf !off !maxSz = do-  threadWaitRead fd-  -- We use MSG_TRUNC so that we are able to figure out whether-  -- or not bytes were discarded. If bytes were discarded-  -- (meaning that the buffer was too small), we return an-  -- exception.-  e <- S.uninterruptibleReceiveFromMutableByteArray_ fd buf (intToCInt off) (intToCSize maxSz) (L.truncate)-  case e of-    Left err -> throwIO $ SocketUnrecoverableException-      moduleSocketDatagramIPv4Undestined-      functionReceiveMutableByteArray-      [describeErrorCode err]-    Right recvSz -> if csizeToInt recvSz <= maxSz-      then pure (Right (csizeToInt recvSz))-      else pure (Left (ReceivedMessageTruncated (csizeToInt recvSz)))---- TODO: add receiveTimeout--- receiveTimeout ::---      Socket -- ^ Socket---   -> Int -- ^ Maximum size of datagram to receive---   -> Int -- ^ Microseconds to wait before giving up---   -> IO (Maybe (IPv4,ByteArray))--- receiveTimeout = error "uhoetuhntoehu"--endpointToSocketAddressInternet :: Endpoint -> S.SocketAddressInternet-endpointToSocketAddressInternet (Endpoint {address, port}) = S.SocketAddressInternet-  { port = S.hostToNetworkShort port-  , address = S.hostToNetworkLong (getIPv4 address)-  }--socketAddressInternetToEndpoint :: S.SocketAddressInternet -> Endpoint-socketAddressInternetToEndpoint (S.SocketAddressInternet {address,port}) = Endpoint-  { address = IPv4 (S.networkToHostLong address)-  , port = S.networkToHostShort port-  }--errorCode :: Errno -> SocketException-errorCode (Errno x) = ErrorCode x--shrinkMutableByteArray :: MutableByteArray RealWorld -> Int -> IO ()-shrinkMutableByteArray (MutableByteArray arr) (I# sz) =-  PM.primitive_ (shrinkMutableByteArray# arr sz)--{- $examples- -Print every UDP packet that we receive. This terminates, closing the-socket, after receiving ten packets. This code throws any exception that-happens. This is commonly a useful behavior since most exceptions cannot-be handled gracefully.--> import qualified Data.ByteString.Char8 as BC-> import Control.Monad (replicateM_)-> import qualified Data.ByteString.Short.Internal as SB-> -> udpStdoutServer :: IO ()-> udpStdoutServer = do->   unhandled $ withSocket (Endpoint IPv4.loopback 0) $ \sock port -> do->     BC.putStrLn ("Receiving datagrams on 127.0.0.1:" <> BC.pack (show port))->     replicateM_ 10 $ do->     DIU.Message sender (ByteArray contents) <- unhandled (DIU.receive sock 1024)->       BC.putStrLn ("Datagram from " <> BC.pack (show sender))->       BC.putStr (SB.fromShort (SB.SBS contents))-> -> unhandled :: Exception e => IO (Either e a) -> IO a-> unhandled action = action >>= either throwIO pure---}---touchByteArray :: ByteArray -> IO ()-touchByteArray (PM.ByteArray x) = touchByteArray# x--touchByteArray# :: ByteArray# -> IO ()-touchByteArray# x = IO $ \s -> case touch# x s of s' -> (# s', () #)--intToCInt :: Int -> CInt-intToCInt = fromIntegral--intToCSize :: Int -> CSize-intToCSize = fromIntegral--csizeToInt :: CSize -> Int-csizeToInt = fromIntegral--moduleSocketDatagramIPv4Undestined :: String-moduleSocketDatagramIPv4Undestined = "Socket.Datagram.IPv4.Undestined"--functionReceive :: String-functionReceive = "receive"--functionSend :: String-functionSend = "send"--functionSendMutableByteArray :: String-functionSendMutableByteArray = "sendMutableByteArray"--functionReceiveMutableByteArray :: String-functionReceiveMutableByteArray = "receiveMutableByteArray"--functionWithSocket :: String-functionWithSocket = "withSocket"--describeErrorCode :: Errno -> String-describeErrorCode err@(Errno e) = "error code " ++ D.string err ++ " (" ++ show e ++ ")"--handleSendException :: String -> Errno -> IO (Either (SendException i) a)-{-# INLINE handleSendException #-}-handleSendException func e-  | e == eACCES = pure (Left SendBroadcasted)-  | otherwise = throwIO $ SocketUnrecoverableException-      moduleSocketDatagramIPv4Undestined-      func-      [describeErrorCode e]-
− src/Socket/Datagram/IPv4/Undestined/Internal.hs 
@@ -1,24 +0,0 @@-{-# language BangPatterns #-}-{-# language DeriveAnyClass #-}-{-# language DerivingStrategies #-}--module Socket.Datagram.IPv4.Undestined.Internal-  ( Socket(..)-  , Message(..)-  ) where--import Socket.IPv4 (Endpoint)-import System.Posix.Types (Fd)-import Data.Primitive (ByteArray)---- | A connectionless datagram socket that may communicate with many different--- endpoints on a datagram-by-datagram basis.-newtype Socket = Socket Fd-  deriving stock (Eq,Ord,Show)--data Message = Message-  { remote :: {-# UNPACK #-} !Endpoint-  , payload :: !ByteArray-  } deriving stock (Eq,Show)--
+ src/Socket/Datagram/Interruptible/Bytes.hs view
@@ -0,0 +1,97 @@+{-# language BangPatterns #-}+{-# language LambdaCase #-}+{-# language GADTSyntax #-}+{-# language KindSignatures #-}+{-# language NamedFieldPuns #-}+{-# language DuplicateRecordFields #-}+{-# language DataKinds #-}++module Socket.Datagram.Interruptible.Bytes+  ( -- * Receive+    receive+  , receiveFromIPv4+    -- * Receive Many+  , receiveMany+  , receiveManyFromIPv4+  ) where++import Control.Concurrent.STM (TVar)+import Data.Bytes.Types (MutableBytes(..))+import Data.Primitive (ByteArray,SmallArray)+import Data.Primitive.Unlifted.Array (UnliftedArray)+import Data.Primitive.PrimArray.Offset (MutablePrimArrayOffset(..))+import Socket (Connectedness(..),Family(..),Version(..),Interruptibility(Interruptible))+import Socket.Address (posixToIPv4Peer)+import Socket.Datagram (Socket(..),ReceiveException)+import Socket.IPv4 (Message(..),IPv4Slab(..))++import qualified Data.Primitive as PM+import qualified Socket.IPv4+import qualified Socket.Discard+import qualified Socket as SCK+import qualified Socket.Datagram.Interruptible.MutableBytes.Many as MM+import qualified Socket.Datagram.Interruptible.MutableBytes.Receive.Connected as CR+import qualified Socket.Datagram.Interruptible.MutableBytes.Receive.IPv4 as V4R++-- | Receive a datagram, discarding the peer address. This can be used with+-- datagram sockets of any family. It is usable with both connected and+-- unconnected datagram sockets.+receive ::+     TVar Bool+     -- ^ Interrupt. On 'True', give up and return+     -- @'Left' 'ReceiveInterrupted'@.+  -> Socket c a -- ^ Socket+  -> Int -- ^ Maximum datagram size+  -> IO (Either (ReceiveException 'Interruptible) ByteArray)+receive !intr (Socket !sock) !maxSz = do+  buf <- PM.newByteArray maxSz+  CR.receive intr sock (MutableBytes buf 0 maxSz) () >>= \case+    Right sz -> do+      r <- PM.resizeMutableByteArray buf sz >>= PM.unsafeFreezeByteArray+      pure (Right r)+    Left err -> pure (Left err)++receiveFromIPv4 ::+     TVar Bool+     -- ^ Interrupt. On 'True', give up and return+     -- @'Left' 'ReceiveInterrupted'@.+  -> Socket 'Unconnected ('Internet 'V4) -- ^ IPv4 socket without designated peer+  -> Int -- ^ Maximum datagram size+  -> IO (Either (ReceiveException 'Interruptible) Message)+receiveFromIPv4 !intr (Socket !sock) !maxSz = do+  buf <- PM.newByteArray maxSz+  addr <- PM.newPrimArray 1+  V4R.receive intr sock (MutableBytes buf 0 maxSz) (MutablePrimArrayOffset addr 0) >>= \case+    Right size -> do+      r <- PM.resizeMutableByteArray buf size >>= PM.unsafeFreezeByteArray+      posixAddr <- PM.readPrimArray addr 0+      pure (Right (Message (posixToIPv4Peer posixAddr) r))+    Left err -> pure (Left err)++receiveManyFromIPv4 ::+     TVar Bool+     -- ^ Interrupt. On 'True', give up and return+     -- @'Left' 'ReceiveInterrupted'@.+  -> Socket 'Unconnected ('SCK.Internet 'SCK.V4) -- ^ Socket+  -> Socket.IPv4.IPv4Slab -- ^ Buffers for reception+  -> IO (Either (ReceiveException 'Interruptible) (SmallArray Message))+receiveManyFromIPv4 intr sock slab = do+  MM.receiveManyFromIPv4 intr sock slab >>= \case+    Left err -> pure (Left err)+    Right n -> do+      arr <- Socket.IPv4.freezeIPv4Slab slab n+      pure (Right arr)++receiveMany ::+     TVar Bool+     -- ^ Interrupt. On 'True', give up and return+     -- @'Left' 'ReceiveInterrupted'@.+  -> Socket 'Unconnected ('SCK.Internet 'SCK.V4) -- ^ Socket+  -> Socket.Discard.PeerlessSlab -- ^ Buffers for reception+  -> IO (Either (ReceiveException 'Interruptible) (UnliftedArray ByteArray))+receiveMany intr sock slab = do+  MM.receiveMany intr sock slab >>= \case+    Left err -> pure (Left err)+    Right n -> do+      arr <- Socket.Discard.freezePeerlessSlab slab n+      pure (Right arr)
+ src/Socket/Datagram/Interruptible/MutableBytes.hs view
@@ -0,0 +1,80 @@+{-# language BangPatterns #-}+{-# language LambdaCase #-}+{-# language GADTSyntax #-}+{-# language KindSignatures #-}+{-# language DataKinds #-}++module Socket.Datagram.Interruptible.MutableBytes+  ( -- * Send+    send+  , sendToIPv4+    -- * Receive+  , receive+  , receiveFromIPv4+    -- * Receive Many+  , MM.receiveMany+  , MM.receiveManyFromIPv4+  ) where++import Control.Concurrent.STM (TVar)+import Data.Bytes.Types (MutableBytes)+import Data.Primitive.PrimArray.Offset (MutablePrimArrayOffset)+import GHC.Exts (RealWorld)+import Posix.Socket (SocketAddressInternet)+import Socket (Connectedness(..),Family(..),Version(..),Interruptibility(Interruptible))+import Socket.Datagram (Socket(..),SendException,ReceiveException)+import Socket.IPv4 (Peer)++import qualified Socket.Datagram.Interruptible.MutableBytes.Many as MM+import qualified Socket.Datagram.Interruptible.MutableBytes.Receive.Connected as CR+import qualified Socket.Datagram.Interruptible.MutableBytes.Send.Connected as CS+import qualified Socket.Datagram.Interruptible.MutableBytes.Send.IPv4 as V4S+import qualified Socket.Datagram.Interruptible.MutableBytes.Receive.IPv4 as V4R++-- | Send a datagram using a socket with a pre-designated peer. This refers+-- to a datagram socket for which POSIX @connect@ has locked down communication+-- to an individual peer.+send ::+     TVar Bool+     -- ^ Interrupt. On 'True', give up and return @'Left' 'SendInterrupted'@.+  -> Socket 'Connected a -- ^ Socket with designated peer+  -> MutableBytes RealWorld -- ^ Slice of a buffer+  -> IO (Either (SendException 'Interruptible) ())+send !intr (Socket !sock) !buf =+  CS.send intr () sock buf++-- | Receive a datagram, discarding the peer address. This can be used with+-- datagram sockets of any family. It is usable with both connected and+-- unconnected datagram sockets.+receive ::+     TVar Bool+     -- ^ Interrupt. On 'True', give up and return @'Left' 'ReceiveInterrupted'@.+  -> Socket c a -- ^ Socket+  -> MutableBytes RealWorld -- ^ Slice of a buffer+  -> IO (Either (ReceiveException 'Interruptible) Int)+receive !intr (Socket !sock) !buf =+  CR.receive intr sock buf () >>= \case+    Right sz -> pure (Right sz)+    Left err -> pure (Left err)++sendToIPv4 ::+     TVar Bool+     -- ^ Interrupt. On 'True', give up and return @'Left' 'SendInterrupted'@.+  -> Socket 'Unconnected ('Internet 'V4) -- ^ IPv4 socket without designated peer+  -> Peer -- ^ Destination+  -> MutableBytes RealWorld -- ^ Slice of a buffer+  -> IO (Either (SendException 'Interruptible) ())+sendToIPv4 !intr (Socket !sock) !dst !buf =+  V4S.send intr dst sock buf++receiveFromIPv4 ::+     TVar Bool+     -- ^ Interrupt. On 'True', give up and return @'Left' 'ReceiveInterrupted'@.+  -> Socket 'Unconnected ('Internet 'V4) -- ^ IPv4 socket without designated peer+  -> MutableBytes RealWorld -- ^ Slice of a buffer+  -> MutablePrimArrayOffset RealWorld SocketAddressInternet+     -- ^ Buffer for returned peer address+  -> IO (Either (ReceiveException 'Interruptible) Int)+receiveFromIPv4 !intr (Socket !sock) !buf !addr =+  V4R.receive intr sock buf addr+
+ src/Socket/Datagram/Slab.hs view
@@ -0,0 +1,14 @@+module Socket.Datagram.Slab+  ( -- * Types+    D.PeerlessSlab(..)+  , I.IPv4Slab(..)+    -- * Create+  , D.newPeerlessSlab+  , I.newIPv4Slab+    -- * Freeze+  , D.freezePeerlessSlab+  , I.freezeIPv4Slab+  ) where++import qualified Socket.IPv4 as I+import qualified Socket.Discard as D
+ src/Socket/Datagram/Uninterruptible/Bytes.hs view
@@ -0,0 +1,120 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}+{-# language DuplicateRecordFields #-}+{-# language GADTSyntax #-}+{-# language KindSignatures #-}+{-# language LambdaCase #-}+{-# language MagicHash #-}+{-# language NamedFieldPuns #-}++module Socket.Datagram.Uninterruptible.Bytes+  ( -- * Send+    send+  , sendToIPv4+    -- * Receive+  , receive+  , receiveFromIPv4+    -- * Receive Many+  , receiveMany+  , receiveManyFromIPv4+    -- * Types+  , Message(..)+  , Peer(..)+  , ReceiveException(..)+    -- * Slabs+    -- ** Types+  , PeerlessSlab(..)+  , IPv4Slab(..)+    -- ** Functions+  , newPeerlessSlab+  , newIPv4Slab+  ) where++import Data.Bytes.Types (Bytes,MutableBytes(..))+import Data.Primitive (ByteArray,SmallArray)+import Data.Primitive.Unlifted.Array (UnliftedArray)+import Data.Primitive.PrimArray.Offset (MutablePrimArrayOffset(..))+import GHC.Exts (proxy#)+import Socket (Connectedness(..),Family(..),Version(..),Interruptibility(Uninterruptible))+import Socket.Address (posixToIPv4Peer)+import Socket.Datagram (Socket(..),SendException,ReceiveException(..))+import Socket.IPv4 (Peer(..),Message(..),IPv4Slab(..),freezeIPv4Slab)+import Socket.IPv4 (newIPv4Slab)+import Socket.Discard (PeerlessSlab(..),newPeerlessSlab)++import qualified Data.Primitive as PM+import qualified Socket.Discard+import qualified Socket.Datagram.Uninterruptible.Bytes.Send.Connected as CS+import qualified Socket.Datagram.Uninterruptible.Bytes.Send.IPv4 as V4S+import qualified Socket.Datagram.Uninterruptible.MutableBytes.Many as MM+import qualified Socket.Datagram.Uninterruptible.MutableBytes.Receive.Connected as CR+import qualified Socket.Datagram.Uninterruptible.MutableBytes.Receive.IPv4 as V4R++-- | Send a datagram using a socket with a pre-designated peer. This+-- refers to a datagram socket for which POSIX @connect@ has locked+-- down communication to an individual peer.+send ::+     Socket 'Connected a -- ^ Socket with designated peer+  -> Bytes -- ^ Slice of a buffer+  -> IO (Either (SendException 'Uninterruptible) ())+send (Socket !sock) !buf =+  CS.send proxy# () sock buf++sendToIPv4 ::+     Socket 'Unconnected ('Internet 'V4) -- ^ IPv4 socket without designated peer+  -> Peer -- ^ Destination+  -> Bytes -- ^ Slice of a buffer+  -> IO (Either (SendException 'Uninterruptible) ())+sendToIPv4 (Socket !sock) !dst !buf =+  V4S.send proxy# dst sock buf++-- | Receive a datagram, discarding the peer address. This can be used with+-- datagram sockets of any family. It is usable with both connected and+-- unconnected datagram sockets.+receive ::+     Socket c a -- ^ Socket+  -> Int -- ^ Maximum datagram size+  -> IO (Either (ReceiveException 'Uninterruptible) ByteArray)+receive (Socket !sock) !maxSz = do+  buf <- PM.newByteArray maxSz+  CR.receive proxy# sock (MutableBytes buf 0 maxSz) () >>= \case+    Right sz -> do+      r <- PM.resizeMutableByteArray buf sz >>= PM.unsafeFreezeByteArray+      pure (Right r)+    Left err -> pure (Left err)++receiveFromIPv4 ::+     Socket 'Unconnected ('Internet 'V4) -- ^ IPv4 socket without designated peer+  -> Int -- ^ Maximum datagram size+  -> IO (Either (ReceiveException 'Uninterruptible) Message)+receiveFromIPv4 (Socket !sock) !maxSz = do+  buf <- PM.newByteArray maxSz+  addr <- PM.newPrimArray 1+  V4R.receive proxy# sock (MutableBytes buf 0 maxSz) (MutablePrimArrayOffset addr 0) >>= \case+    Right size -> do+      r <- PM.resizeMutableByteArray buf size >>= PM.unsafeFreezeByteArray+      posixAddr <- PM.readPrimArray addr 0+      pure (Right (Message (posixToIPv4Peer posixAddr) r))+    Left err -> pure (Left err)++receiveManyFromIPv4 ::+     Socket 'Unconnected ('Internet 'V4) -- ^ Socket+  -> Socket.IPv4.IPv4Slab -- ^ Buffers for reception+  -> IO (Either (ReceiveException 'Uninterruptible) (SmallArray Message))+receiveManyFromIPv4 sock slab = do+  MM.receiveManyFromIPv4 sock slab >>= \case+    Left err -> pure (Left err)+    Right n -> do+      arr <- Socket.IPv4.freezeIPv4Slab slab n+      pure (Right arr)++receiveMany ::+     Socket 'Unconnected ('Internet 'V4) -- ^ Socket+  -> Socket.Discard.PeerlessSlab -- ^ Buffers for reception+  -> IO (Either (ReceiveException 'Uninterruptible) (UnliftedArray ByteArray))+receiveMany sock slab = do+  MM.receiveMany sock slab >>= \case+    Left err -> pure (Left err)+    Right n -> do+      arr <- Socket.Discard.freezePeerlessSlab slab n+      pure (Right arr)
+ src/Socket/Datagram/Uninterruptible/MutableBytes.hs view
@@ -0,0 +1,80 @@+{-# language BangPatterns #-}+{-# language LambdaCase #-}+{-# language GADTSyntax #-}+{-# language KindSignatures #-}+{-# language DataKinds #-}+{-# language MagicHash #-}++module Socket.Datagram.Uninterruptible.MutableBytes+  ( -- * Send+    send+  , sendToIPv4+    -- * Receive+  , receive+  , receiveFromIPv4+    -- * Receive Many+  , MM.receiveMany+  , MM.receiveManyFromIPv4+    -- * Slabs+    -- ** Types+  , PeerlessSlab(..)+  , IPv4Slab(..)+    -- ** Functions+  , newPeerlessSlab+  , newIPv4Slab+  ) where++import Data.Bytes.Types (MutableBytes)+import Data.Primitive.PrimArray.Offset (MutablePrimArrayOffset)+import GHC.Exts (RealWorld,proxy#)+import Posix.Socket (SocketAddressInternet)+import Socket (Connectedness(..),Family(..),Version(..),Interruptibility(Uninterruptible))+import Socket.Datagram (Socket(..),SendException,ReceiveException)+import Socket.IPv4 (Peer,newIPv4Slab,IPv4Slab(..))+import Socket.Discard (PeerlessSlab(..),newPeerlessSlab)++import qualified Socket.Datagram.Uninterruptible.MutableBytes.Many as MM+import qualified Socket.Datagram.Uninterruptible.MutableBytes.Receive.Connected as CR+import qualified Socket.Datagram.Uninterruptible.MutableBytes.Send.Connected as CS+import qualified Socket.Datagram.Uninterruptible.MutableBytes.Send.IPv4 as V4S+import qualified Socket.Datagram.Uninterruptible.MutableBytes.Receive.IPv4 as V4R++-- | Send a datagram using a socket with a pre-designated peer. This+-- refers to a datagram socket for which POSIX @connect@ has locked+-- down communication to an individual peer.+send ::+     Socket 'Connected a -- ^ Socket with designated peer+  -> MutableBytes RealWorld -- ^ Slice of a buffer+  -> IO (Either (SendException 'Uninterruptible) ())+send (Socket !sock) !buf =+  CS.send proxy# () sock buf++-- | Receive a datagram, discarding the peer address. This can be used with+-- datagram sockets of any family. It is usable with both connected and+-- unconnected datagram sockets.+receive ::+     Socket c a -- ^ Socket+  -> MutableBytes RealWorld -- ^ Slice of a buffer+  -> IO (Either (ReceiveException 'Uninterruptible) Int)+receive (Socket !sock) !buf =+  CR.receive proxy# sock buf () >>= \case+    Right sz -> pure (Right sz)+    Left err -> pure (Left err)++sendToIPv4 ::+     Socket 'Unconnected ('Internet 'V4) -- ^ IPv4 socket without designated peer+  -> Peer -- ^ Destination+  -> MutableBytes RealWorld -- ^ Slice of a buffer+  -> IO (Either (SendException 'Uninterruptible) ())+sendToIPv4 (Socket !sock) !dst !buf =+  V4S.send proxy# dst sock buf++receiveFromIPv4 ::+     Socket 'Unconnected ('Internet 'V4) -- ^ IPv4 socket without designated peer+  -> MutableBytes RealWorld -- ^ Slice of a buffer+  -> MutablePrimArrayOffset RealWorld SocketAddressInternet+     -- ^ Buffer for returned peer address+  -> IO (Either (ReceiveException 'Uninterruptible) Int)+receiveFromIPv4 (Socket !sock) !buf !addr =+  V4R.receive proxy# sock buf addr+
− src/Socket/IPv4.hs 
@@ -1,70 +0,0 @@-{-# language BangPatterns #-}-{-# language DataKinds #-}-{-# language DeriveAnyClass #-}-{-# language DerivingStrategies #-}-{-# language DuplicateRecordFields #-}-{-# language GADTs #-}-{-# language KindSignatures #-}-{-# language NamedFieldPuns #-}-{-# language StandaloneDeriving #-}--module Socket.IPv4-  ( Endpoint(..)-  , SocketException(..)-  , describeEndpoint-  ) where--import Control.Exception (Exception)-import Data.Kind (Type)-import Data.Word (Word16)-import Net.Types (IPv4(..))--import qualified Data.Text as T-import qualified Net.IPv4 as IPv4---- | An endpoint for an IPv4 socket, connection, or listener.---   Everything is in host byte order, and the user is not---   responisble for performing any conversions.-data Endpoint = Endpoint-  { address :: !IPv4-  , port :: !Word16-  } deriving stock (Eq,Show)---- This is used internally for debug messages and for presenting--- unrecoverable exceptions.-describeEndpoint :: Endpoint -> String-describeEndpoint (Endpoint {address,port}) =-  T.unpack (IPv4.encode address) ++ ":" ++ show port---- | Recoverable exceptions that happen when establishing an internet-domain--- stream listener or datagram socket.------ ==== __Discussion__------ The recoverable exceptions that we from stream sockets (established--- with @socket@-@bind@-@listen@) and datagram sockets (established with--- @socket@-@bind@) are the exact same exceptions. Consequently, we reuse--- the same type in both case. It is a little unfortunate since the name--- @ListenException@ would be more appropriate for stream sockets. But--- the code reuse is worth the naming quibble.-data SocketException :: Type where-  -- | The address is protected, and the user is not the superuser. This most-  --   commonly happens when trying to bind to a port below 1024. On Linux,-  --   When it is necessary to bind to such a port on Linux, consider using the-  --   <http://man7.org/linux/man-pages/man7/capabilities.7.html CAP_NET_BIND_SERVICE>-  --   capability instead of running the process as root. (@EACCES@)-  SocketPermissionDenied :: SocketException-  -- | The given address is already in use. (@EADDRINUSE@ with specified port)-  SocketAddressInUse :: SocketException-  -- | The port number was specified as zero, but upon attempting to-  --   bind to an ephemeral port, it was determined that all port numbers-  --   numbers in the ephemeral port range are currently in use.-  --   (@EADDRINUSE@ with unspecified port)-  SocketEphemeralPortsExhausted :: SocketException-  -- | A limit on the number of open file descriptors has been reached.-  --   This could be the per-process limit or the system limit.-  --   (@EMFILE@ and @ENFILE@)-  SocketFileDescriptorLimit :: SocketException--deriving stock instance Show SocketException-deriving anyclass instance Exception SocketException
− src/Socket/Stream.hs 
@@ -1,167 +0,0 @@-{-# language DataKinds #-}-{-# language DeriveAnyClass #-}-{-# language DerivingStrategies #-}-{-# language GADTs #-}-{-# language KindSignatures #-}-{-# language StandaloneDeriving #-}-module Socket.Stream-  ( SendException(..)-  , ReceiveException(..)-  , ConnectException(..)-  , SocketException(..)-  , AcceptException(..)-  , CloseException(..)-  ) where--import Socket (Direction(..),Interruptibility(..),Forkedness(..))-import Socket.IPv4 (SocketException(..))--import Data.Kind (Type)-import Data.Typeable (Typeable)-import Control.Exception (Exception)---- | Recoverable exceptions that can occur while connecting to a peer.--- This includes both failures while opening the socket and failures--- while connecting to the peer.------ ==== __Discussion__------ In its API for connecting to a peer, this library combines the step of--- creating a socket with the step of connecting to the peer. In other words,--- the end user never gets access to an unconnected stream socket.--- Consequently, the connection exceptions correspond to the @socket@--- errors @EMFILE@ and @ENFILE@ as well as the @connect@--- errors @ECONNREFUSED@, @EACCES@/@EPERM@, @ETIMEDOUT@, @ENETUNREACH@, and--- @EADDRNOTAVAIL@.------ Somewhat surprisingly, @EADDRINUSE@ is not included in the list of @connect@--- error codes we recognize as recoverable. The--- <http://man7.org/linux/man-pages/man2/connect.2.html accept man page>--- describes @EADDRINUSE@ as "Local address is already in use". However,--- it is unclear what this means. The caller of @connect@ does not provide--- an internet socket address. If ephemeral ports are exhausted, @connect@--- will error with @EADDRNOTAVAIL@. An unresolved--- <https://stackoverflow.com/questions/43199021/how-could-connect-fail-and-set-errno-to-eaddrinuse Stack Overflow question>--- calls into question whether or not it is actually possible for this--- error to happen with an internet domain socket. The author has decided--- to omit any checks for it. This means that, if it does ever happen,--- it will cause a @SocketUnrecoverableException@ to be thrown. The Linux--- cognoscenti are encouraged to open an issue if they have more information--- about the circumstances under which this exception can occur.-data ConnectException :: Interruptibility -> Type where-  -- | Either the connection was blocked by a local firewall rule or it-  --   was blocked because it was to a broadcast address. Sadly, these-  --   two errors are not distinguished by the Linux sockets API.-  --   (@EACCES@/@EPERM@)-  ConnectFirewalled :: ConnectException i-  -- | A limit on the number of open file descriptors has been reached.-  --   This could be the per-process limit or the system limit.-  --   (@EMFILE@ and @ENFILE@)-  ConnectFileDescriptorLimit :: ConnectException i-  -- | The network is unreachable. (@ENETUNREACH@)-  ConnectNetworkUnreachable :: ConnectException i-  -- | All port numbers in the ephemeral port range are currently in-  --   use. (@EADDRNOTAVAIL@)-  ConnectEphemeralPortsExhausted :: ConnectException i-  -- | No one is listening on the remote address. (@ECONNREFUSED@)-  ConnectRefused :: ConnectException i-  -- | Timeout while attempting connection. The server may be too busy-  --   to accept new connections. Note that stock Linux configuration has-  --   timeout at -  --   <http://willbryant.net/overriding_the_default_linux_kernel_20_second_tcp_socket_connect_timeout appropriately 20 seconds>.-  --   Users interested in timing out more quickly are encouraged to-  --   use @registerDelay@ with the @interruptible@ variants of the-  --   connection functions in this library. (@ETIMEDOUT@)-  ConnectTimeout :: ConnectException i-  -- | STM-style interrupt (much safer than C-style interrupt)-  ConnectInterrupted :: ConnectException 'Interruptible--deriving stock instance Show (ConnectException i)-deriving anyclass instance Typeable i => Exception (ConnectException i)---data CloseException :: Type where-  -- | After the local process shut down the writing channel, it-  --   was expecting the peer to do the same. However, the peer-  --   sent more data instead. If this happens, the local process-  --   does still close the socket. However, it must send a TCP-  --   reset to accomplish this since there is still unread data-  --   in the receive buffer.-  ---  --   This can happen if the peer is misbehaving or if the consumer-  --   of the @sockets@ API has incorrectly implemented a protocol-  --   living above layer 4 of the OSI model.-  ClosePeerContinuedSending :: CloseException--deriving stock instance Show CloseException-deriving anyclass instance Exception CloseException---- | Recoverable exceptions that can occur while accepting an inbound--- connection.-data AcceptException :: Interruptibility -> Type where-  -- | The peer reset the connection before the running process-  --   accepted it. This is not typically treated as fatal. The-  --   process may continue accepting connections. (@ECONNABORTED@)-  AcceptConnectionAborted :: AcceptException i-  -- | A limit on the number of open file descriptors has been reached.-  --   This could be the per-process limit or the system limit.-  --   (@EMFILE@ and @ENFILE@)-  AcceptFileDescriptorLimit :: AcceptException i-  -- | Firewall rules forbid connection. (@EPERM@)-  AcceptFirewalled :: AcceptException i-  -- | STM-style interrupt (much safer than C-style interrupt)-  AcceptInterrupted :: AcceptException 'Interruptible--deriving stock instance Show (AcceptException i)-deriving anyclass instance (Typeable i) => Exception (AcceptException i)---data SendException :: Interruptibility -> Type where-  -- | The local socket has already shutdown its writing channel.-  --   Consequently, sending is no longer possible. This can happen-  --   even if the process does not @shutdown@ the socket. If the-  --   peer decides to @close@ the connection, the local operating system-  --   will shutdown both the reading and writing channels. (@EPIPE@)-  SendShutdown :: SendException i-  -- | The peer reset the connection.-  SendReset :: SendException i-  -- | STM-style interrupt (much safer than C-style interrupt)-  SendInterrupted :: SendException 'Interruptible--deriving stock instance Show (SendException i)-deriving anyclass instance Typeable i => Exception (SendException i)---- | Recoverable exceptions that can occur while receiving data on a--- stream socket.------ ==== __Discussion__------ The <http://man7.org/linux/man-pages/man2/recv.2.html recv man page>--- explicitly documents these:------ * @EAGAIN@/@EAGAIN@: Not possible after using event manager to wait.--- * @EBADF@: Prevented by this library.--- * @ECONNREFUSED@: Not sure if this is possible. Currently treated as---   an unrecoverable exception.--- * @EFAULT@: Not recoverable. API consumer has misused @Addr@.--- * @EINTR@: Prevented by this library. Unsafe FFI is not interruptible.--- * @EINVAL@: Prevented by this library.--- * @ENOMEM@: Not recoverable.--- * @ENOTCONN@: Prevented by this library.--- * @ENOTSOCK@: Prevented by this library.------ The man page includes a disclaimer: "Additional errors may be generated--- and returned from the underlying protocol modules". One such error--- when dealing with stream sockets in @ECONNRESET@. One scenario where--- this happens is when the process running on the peer terminates ungracefully--- and the operating system on the peer cleans up by sending a reset.-data ReceiveException :: Interruptibility -> Type where-  -- | The peer shutdown its writing channel. (zero-length chunk)-  ReceiveShutdown :: ReceiveException i-  -- | The peer reset the connection. (@ECONNRESET@)-  ReceiveReset :: ReceiveException i-  -- | STM-style interrupt (much safer than C-style interrupt)-  ReceiveInterrupted :: ReceiveException 'Interruptible--deriving stock instance Show (ReceiveException i)-deriving anyclass instance Typeable i => Exception (ReceiveException i)
src/Socket/Stream/IPv4.hs view
@@ -1,1321 +1,790 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GADTs #-}--module Socket.Stream.IPv4-  ( -- * Types-    Listener-  , Connection-  , Endpoint(..)-    -- * Bracketed-  , withListener-  , withAccepted-  , withConnection-  , interruptibleWithConnection-  , forkAccepted-  , forkAcceptedUnmasked-  , interruptibleForkAcceptedUnmasked-    -- * Communicate-  , sendByteArray-  , sendByteArraySlice-  , sendMutableByteArray-  , sendMutableByteArraySlice-  , sendAddr-  , sendByteString-  , sendLazyByteString-  , interruptibleSendByteArray-  , interruptibleSendByteArraySlice-  , interruptibleSendMutableByteArraySlice-  , receiveByteArray-  , receiveBoundedByteArray-  , receiveBoundedMutableByteArraySlice-  , receiveMutableByteArray-  , receiveByteString-  , interruptibleReceiveByteArray-  , interruptibleReceiveBoundedMutableByteArraySlice-    -- * Exceptions-  , SendException(..)-  , ReceiveException(..)-  , ConnectException(..)-  , SocketException(..)-  , AcceptException(..)-  , CloseException(..)-  , Interruptibility(..)-    -- * Unbracketed-    -- $unbracketed-  , listen-  , unlisten-  , unlisten_-  , connect-  , interruptibleConnect-  , disconnect-  , disconnect_-  , accept-  , interruptibleAccept-  ) where--import Control.Applicative ((<|>))-import Control.Concurrent (ThreadId, threadWaitRead, threadWaitWrite)-import Control.Concurrent (threadWaitReadSTM,threadWaitWriteSTM)-import Control.Concurrent (forkIO, forkIOWithUnmask)-import Control.Exception (mask, mask_, onException, throwIO)-import Control.Monad.STM (atomically,retry)-import Control.Concurrent.STM (TVar,modifyTVar',readTVar)-import Data.Bool (bool)-import Data.ByteString (ByteString)-import Data.Functor (($>))-import Data.Primitive (Addr(..), ByteArray, MutableByteArray(..))-import Data.Word (Word16)-import Foreign.C.Error (Errno(..), eAGAIN, eINPROGRESS, eWOULDBLOCK, ePIPE, eNOTCONN)-import Foreign.C.Error (eADDRINUSE,eCONNRESET)-import Foreign.C.Error (eNFILE,eMFILE,eACCES,ePERM,eCONNABORTED)-import Foreign.C.Error (eTIMEDOUT,eADDRNOTAVAIL,eNETUNREACH,eCONNREFUSED)-import Foreign.C.Types (CInt, CSize)-import GHC.Exts (Ptr(Ptr),Int(I#), RealWorld, shrinkMutableByteArray#, byteArrayContents#, unsafeCoerce#)-import Net.Types (IPv4(..))-import Socket (Interruptibility(..))-import Socket (SocketUnrecoverableException(..))-import Socket (cgetsockname,cclose)-import Socket.Debug (debug)-import Socket.IPv4 (Endpoint(..),describeEndpoint)-import Socket.Stream (ConnectException(..),SocketException(..),AcceptException(..))-import Socket.Stream (SendException(..),ReceiveException(..),CloseException(..))-import System.Posix.Types(Fd)--import qualified Control.Monad.Primitive as PM-import qualified Data.ByteString.Internal as BI-import qualified Data.ByteString.Unsafe as BU-import qualified Data.ByteString.Lazy.Internal as LBS-import qualified Data.Primitive as PM-import qualified Foreign.C.Error.Describe as D-import qualified Linux.Socket as L-import qualified Posix.Socket as S-import qualified Socket as SCK-import qualified GHC.ForeignPtr as FP---- | A socket that listens for incomming connections.-newtype Listener = Listener Fd---- | A connection-oriented stream socket.-newtype Connection = Connection Fd---- | Open a socket that can be used to listen for inbound connections.--- Requirements:------ * This function may only be called in contexts where exceptions---   are masked.--- * The caller /must/ be sure to call 'unlistener' on the resulting---   'Listener' exactly once to close underlying file descriptor.--- * The 'Listener' cannot be used after being given as an argument---   to 'unlistener'.------ Noncompliant use of this function leads to undefined behavior. Prefer--- 'withListener' unless you are writing an integration with a--- resource-management library.-listen :: Endpoint -> IO (Either SocketException (Listener, Word16))-listen endpoint@Endpoint{port = specifiedPort} = do-  debug ("listen: opening listen " ++ describeEndpoint endpoint)-  e1 <- S.uninterruptibleSocket S.internet-    (L.applySocketFlags (L.closeOnExec <> L.nonblocking) S.stream)-    S.defaultProtocol-  debug ("listen: opened listen " ++ describeEndpoint endpoint)-  case e1 of-    Left err -> handleSocketListenException SCK.functionWithListener err-    Right fd -> do-      e2 <- S.uninterruptibleBind fd-        (S.encodeSocketAddressInternet (endpointToSocketAddressInternet endpoint))-      debug ("listen: requested binding for listen " ++ describeEndpoint endpoint)-      case e2 of-        Left err -> do-          _ <- S.uninterruptibleClose fd-          handleBindListenException specifiedPort SCK.functionWithListener err-        Right _ -> S.uninterruptibleListen fd 16 >>= \case-          -- We hardcode the listen backlog to 16. The author is unfamiliar-          -- with use cases where gains are realized from tuning this parameter.-          -- Open an issue if this causes problems for anyone.-          Left err -> do-            _ <- S.uninterruptibleClose fd-            debug "listen: listen failed with error code"-            handleBindListenException specifiedPort SCK.functionWithListener err-          Right _ -> do-            -- The getsockname is copied from code in Socket.Datagram.IPv4.Undestined.-            -- Consider factoring this out.-            actualPort <- if specifiedPort == 0-              then S.uninterruptibleGetSocketName fd S.sizeofSocketAddressInternet >>= \case-                Left err -> throwIO $ SocketUnrecoverableException-                  moduleSocketStreamIPv4-                  functionWithListener-                  [cgetsockname,describeEndpoint endpoint,describeErrorCode err]-                Right (sockAddrRequiredSz,sockAddr) -> if sockAddrRequiredSz == S.sizeofSocketAddressInternet-                  then case S.decodeSocketAddressInternet sockAddr of-                    Just S.SocketAddressInternet{port = actualPort} -> do-                      let cleanActualPort = S.networkToHostShort actualPort-                      debug ("listen: successfully bound listen " ++ describeEndpoint endpoint ++ " and got port " ++ show cleanActualPort)-                      pure cleanActualPort-                    Nothing -> do-                      _ <- S.uninterruptibleClose fd-                      throwIO $ SocketUnrecoverableException-                        moduleSocketStreamIPv4-                        functionWithListener-                        [cgetsockname,"non-internet socket family"]-                  else do-                    _ <- S.uninterruptibleClose fd-                    throwIO $ SocketUnrecoverableException-                      moduleSocketStreamIPv4-                      functionWithListener-                      [cgetsockname,describeEndpoint endpoint,"socket address size"]-              else pure specifiedPort-            pure (Right (Listener fd, actualPort))---- | Close a listener. This throws an unrecoverable exception if---   the socket cannot be closed.-unlisten :: Listener -> IO ()-unlisten (Listener fd) = S.uninterruptibleClose fd >>= \case-  Left err -> throwIO $ SocketUnrecoverableException-    moduleSocketStreamIPv4-    functionWithListener-    [cclose,describeErrorCode err]-  Right _ -> pure ()---- | Close a listener. This does not check to see whether or not--- the operating system successfully closed the socket. It never--- throws exceptions of any kind. This should only be preferred--- to 'unlistener' in exception-cleanup contexts where there is--- already an exception that will be rethrown. See the implementation--- of 'withListener' for an example of appropriate use of both--- 'unlistener' and 'unlistener_'.-unlisten_ :: Listener -> IO ()-unlisten_ (Listener fd) = S.uninterruptibleErrorlessClose fd--withListener ::-     Endpoint-  -> (Listener -> Word16 -> IO a)-  -> IO (Either SocketException a)-withListener endpoint f = mask $ \restore -> do-  listen endpoint >>= \case-    Left err -> pure (Left err)-    Right (sck, actualPort) -> do-      a <- onException-        (restore (f sck actualPort))-        (unlisten_ sck)-      unlisten sck-      pure (Right a)---- | Listen for an inbound connection.-accept :: Listener -> IO (Either (AcceptException 'Uninterruptible) (Connection,Endpoint))-accept (Listener fd) = do-  -- Although this function must be called in a context where-  -- exceptions are masked, recall that threadWaitRead uses-  -- takeMVar, meaning that this first part is still interruptible.-  -- This is a good thing in the case of this function.-  threadWaitRead fd-  waitlessAccept fd---- | Listen for an inbound connection. Can be interrupted by an--- STM-style interrupt.-interruptibleAccept ::-     TVar Bool-     -- ^ Interrupted. If this becomes 'True' give up and return-     --   @'Left' 'AcceptInterrupted'@.-  -> Listener-  -> IO (Either (AcceptException 'Interruptible) (Connection,Endpoint))-interruptibleAccept abandon (Listener fd) = do-  interruptibleWaitRead abandon fd >>= \case-    True -> waitlessAccept fd-    False -> pure (Left AcceptInterrupted)---- Only used internally-interruptibleAcceptCounting :: -     TVar Int-  -> TVar Bool-  -> Listener-  -> IO (Either (AcceptException 'Interruptible) (Connection,Endpoint))-interruptibleAcceptCounting counter abandon (Listener fd) = do-  interruptibleWaitReadCounting counter abandon fd >>= \case-    True -> waitlessAccept fd-    False -> pure (Left AcceptInterrupted)--waitlessAccept :: Fd -> IO (Either (AcceptException i) (Connection,Endpoint))-waitlessAccept lstn = do-  S.uninterruptibleAccept lstn S.sizeofSocketAddressInternet >>= \case-    Left err -> handleAcceptException "withAccepted" err-    Right (sockAddrRequiredSz,sockAddr,acpt) -> if sockAddrRequiredSz == S.sizeofSocketAddressInternet-      then case S.decodeSocketAddressInternet sockAddr of-        Just sockAddrInet -> do-          let !acceptedEndpoint = socketAddressInternetToEndpoint sockAddrInet-          debug ("internalAccepted: successfully accepted connection from " ++ show acceptedEndpoint)-          pure (Right (Connection acpt, acceptedEndpoint))-        Nothing -> do-          _ <- S.uninterruptibleClose acpt-          throwIO $ SocketUnrecoverableException-            moduleSocketStreamIPv4-            SCK.functionWithAccepted-            [SCK.cgetsockname,SCK.nonInternetSocketFamily]-      else do-        _ <- S.uninterruptibleClose acpt-        throwIO $ SocketUnrecoverableException-          moduleSocketStreamIPv4-          SCK.functionWithAccepted-          [SCK.cgetsockname,SCK.socketAddressSize]--gracefulCloseA :: Fd -> IO (Either CloseException ())-gracefulCloseA fd = S.uninterruptibleShutdown fd S.write >>= \case-  -- On Linux (not sure about others), calling shutdown-  -- on the write channel fails with with ENOTCONN if the-  -- write channel is already closed. It is common for this to-  -- happen (e.g. if the peer calls @close@ before the local-  -- process runs gracefulClose, the local operating system-  -- will have already closed the write channel). However,-  -- it does not pose a problem. We just proceed as we would-  -- have since either way we become certain that the write channel-  -- is closed.-  Left err -> if err == eNOTCONN-    then gracefulCloseB fd-    else do-      _ <- S.uninterruptibleClose fd-      -- TODO: What about ENOTCONN? Can this happen if the remote-      -- side has already closed the connection?-      throwIO $ SocketUnrecoverableException-        moduleSocketStreamIPv4-        SCK.functionGracefulClose-        [SCK.cshutdown,describeErrorCode err]-  Right _ -> gracefulCloseB fd--gracefulCloseB :: Fd -> IO (Either CloseException ())-gracefulCloseB fd = do-  buf <- PM.newByteArray 1-  S.uninterruptibleReceiveMutableByteArray fd buf 0 1 mempty >>= \case-    Left err1 -> if err1 == eWOULDBLOCK || err1 == eAGAIN-      then do-        threadWaitRead fd-        -- TODO: We do not actually want to remove the bytes from the-        -- receive buffer. We should use MSG_PEEK instead. Then we will-        -- be certain to send a reset when a CloseException is reported.-        S.uninterruptibleReceiveMutableByteArray fd buf 0 1 mempty >>= \case-          Left err -> do-            _ <- S.uninterruptibleClose fd-            throwIO $ SocketUnrecoverableException-              moduleSocketStreamIPv4-              SCK.functionGracefulClose-              [SCK.crecv,describeErrorCode err]-          Right sz -> if sz == 0-            then S.uninterruptibleClose fd >>= \case-              Left err -> throwIO $ SocketUnrecoverableException-                moduleSocketStreamIPv4-                SCK.functionGracefulClose-                [SCK.cclose,describeErrorCode err]-              Right _ -> pure (Right ())-            else do-              debug ("Socket.Stream.IPv4.gracefulClose: remote not shutdown A")-              _ <- S.uninterruptibleClose fd-              pure (Left ClosePeerContinuedSending)-      else do-        _ <- S.uninterruptibleClose fd-        -- We treat all @recv@ errors except for the nonblocking-        -- notices as unrecoverable.-        throwIO $ SocketUnrecoverableException-          moduleSocketStreamIPv4-          SCK.functionGracefulClose-          [SCK.crecv,describeErrorCode err1]-    Right sz -> if sz == 0-      then S.uninterruptibleClose fd >>= \case-        Left err -> throwIO $ SocketUnrecoverableException-          moduleSocketStreamIPv4-          SCK.functionGracefulClose-          [SCK.cclose,describeErrorCode err]-        Right _ -> pure (Right ())-      else do-        debug ("Socket.Stream.IPv4.gracefulClose: remote not shutdown B")-        _ <- S.uninterruptibleClose fd-        pure (Left ClosePeerContinuedSending)---- | Accept a connection on the listener and run the supplied callback--- on it. This closes the connection when the callback finishes or if--- an exception is thrown. Since this function blocks the thread until--- the callback finishes, it is only suitable for stream socket clients--- that handle one connection at a time. The variant 'forkAcceptedUnmasked'--- is preferrable for servers that need to handle connections concurrently--- (most use cases).-withAccepted ::-     Listener-  -> (Either CloseException () -> a -> IO b)-     -- ^ Callback to handle an ungraceful close. -  -> (Connection -> Endpoint -> IO a)-     -- ^ Callback to consume connection. Must not return the connection.-  -> IO (Either (AcceptException 'Uninterruptible) b)-withAccepted lstn consumeException cb = do-  r <- mask $ \restore -> do-    accept lstn >>= \case-      Left e -> pure (Left e)-      Right (conn, endpoint) -> do-        a <- onException (restore (cb conn endpoint)) (disconnect_ conn)-        e <- disconnect conn-        pure (Right (e,a))-  -- Notice that consumeException gets run in an unmasked context.-  case r of-    Left e -> pure (Left e)-    Right (e,a) -> fmap Right (consumeException e a)---- | Accept a connection on the listener and run the supplied callback in--- a new thread. Prefer 'forkAcceptedUnmasked' unless the masking state--- needs to be preserved for the callback. Such a situation seems unlikely--- to the author.-forkAccepted ::-     Listener-  -> (Either CloseException () -> a -> IO ())-     -- ^ Callback to handle an ungraceful close. -  -> (Connection -> Endpoint -> IO a)-     -- ^ Callback to consume connection. Must not return the connection.-  -> IO (Either (AcceptException 'Uninterruptible) ThreadId)-forkAccepted lstn consumeException cb =-  mask $ \restore -> accept lstn >>= \case-    Left e -> pure (Left e)-    Right (conn, endpoint) -> fmap Right $ forkIO $ do-      a <- onException (restore (cb conn endpoint)) (disconnect_ conn)-      e <- disconnect conn-      restore (consumeException e a)---- | Accept a connection on the listener and run the supplied callback in--- a new thread. The masking state is set to @Unmasked@ when running the--- callback. Typically, @a@ is instantiated to @()@.-forkAcceptedUnmasked ::-     Listener-  -> (Either CloseException () -> a -> IO ())-     -- ^ Callback to handle an ungraceful close. -  -> (Connection -> Endpoint -> IO a)-     -- ^ Callback to consume connection. Must not return the connection.-  -> IO (Either (AcceptException 'Uninterruptible) ThreadId)-forkAcceptedUnmasked lstn consumeException cb =-  mask_ $ accept lstn >>= \case-    Left e -> pure (Left e)-    Right (conn, endpoint) -> fmap Right $ forkIOWithUnmask $ \unmask -> do-      a <- onException (unmask (cb conn endpoint)) (disconnect_ conn)-      e <- disconnect conn-      unmask (consumeException e a)---- | Accept a connection on the listener and run the supplied callback in--- a new thread. The masking state is set to @Unmasked@ when running the--- callback. Typically, @a@ is instantiated to @()@.------ ==== __Discussion__------ Why is the @counter@ argument present? At first, it seems--- like this is something that the API consumer should implement on--- top of this library. The argument for the inclusion of the counter--- is has two parts: (1) clients supporting graceful termination--- always need these semantics and (2) these semantics cannot--- be provided without building in @counter@ as a @TVar@.------ 1. Clients supporting graceful termination always need these---    semantics. To gracefully bring down a server that has been---    accepting connections with a forking function, an application---    must wait for all active connections to finish. Since all---    connections run on separate threads, this can only be---    accomplished by a concurrency primitive. The straightforward---    solution is to wrap a counter with either @MVar@ or @TVar@.---    To complete graceful termination, the application must---    block until the counter reaches zero.--- 2. These semantics cannot be provided without building in---    @counter@ as a @TVar@. When @abandon@ becomes @True@,---    graceful termination begins. From this point onward, if at---    any point the counter reaches zero, the application consuming---    this API will complete termination. Consequently, we need---    the guarantee that the counter does not increment after---    the @abandon@ transaction completes. If it did increment---    in this forbidden way (e.g. if it was incremented some---    unspecified amount of time after a connection was accepted),---    there would be a race condition in which the application---    may terminate without giving the newly accepted connection---    a chance to finish. Fortunately, @STM@ gives us the---    composable transaction we need to get this guarantee.---    To wait for an inbound connection, we use:------    > (isReady,deregister) <- threadWaitReadSTM fd---    > shouldReceive <- atomically $ do---    >   readTVar abandon >>= \case---    >     True -> do---    >       isReady---    >       modifyTVar' counter (+1)---    >       pure True---    >     False -> pure False------    This eliminates the window for the race condition. If a---    connection is accepted, the counter is guaranteed to---    be incremented _before_ @abandon@ becomes @True@.---    However, this code would be more simple and would perform---    better if GHC's event manager used TVar instead of STM.-interruptibleForkAcceptedUnmasked ::-     TVar Int-     -- ^ Connection counter. Incremented when connection-     --   is accepted. Decremented after connection is closed.-  -> TVar Bool-     -- ^ Interrupted. If this becomes 'True' give up and return-     --   @'Left' 'AcceptInterrupted'@.-  -> Listener-     -- ^ Connection listener-  -> (Either CloseException () -> a -> IO ())-     -- ^ Callback to handle an ungraceful close. -  -> (Connection -> Endpoint -> IO a)-     -- ^ Callback to consume connection. Must not return the connection.-  -> IO (Either (AcceptException 'Interruptible) ThreadId)-interruptibleForkAcceptedUnmasked !counter !abandon !lstn consumeException cb =-  mask_ $ interruptibleAcceptCounting counter abandon lstn >>= \case-    Left e -> do-      case e of-        AcceptInterrupted -> pure ()-        _ -> atomically (modifyTVar' counter (subtract 1))-      pure (Left e)-    Right (conn, endpoint) -> fmap Right $ forkIOWithUnmask $ \unmask -> do-      a <- onException-        (unmask (cb conn endpoint))-        (disconnect_ conn *> atomically (modifyTVar' counter (subtract 1)))-      e <- disconnect conn-      r <- unmask (consumeException e a)-      atomically (modifyTVar' counter (subtract 1))-      pure r---- | Open a socket and connect to a peer. Requirements:------ * This function may only be called in contexts where exceptions---   are masked.--- * The caller /must/ be sure to call 'disconnect' or 'disconnect_'---   on the resulting 'Connection' exactly once to close underlying---   file descriptor.--- * The 'Connection' cannot be used after being given as an argument---   to 'disconnect' or 'disconnect_'.------ Noncompliant use of this function leads to undefined behavior. Prefer--- 'withConnection' unless you are writing an integration with a--- resource-management library.-connect ::-     Endpoint-     -- ^ Remote endpoint-  -> IO (Either (ConnectException 'Uninterruptible) Connection)-connect !remote = do-  beforeEstablishment remote >>= \case-    Left err -> pure (Left err)-    Right (fd,sockAddr) -> S.uninterruptibleConnect fd sockAddr >>= \case-      Left err2 -> if err2 == eINPROGRESS-        then do-          threadWaitWrite fd-          afterEstablishment fd-        else do-          S.uninterruptibleErrorlessClose fd-          handleConnectException SCK.functionWithConnection err2-      Right _ -> afterEstablishment fd---- | Variant of 'connect' that is interruptible using STM-style interrupts.-interruptibleConnect ::-     TVar Bool-     -- ^ Interrupted. If this becomes 'True', give up and return-     --   @'Left' 'AcceptInterrupted'@.-  -> Endpoint-     -- ^ Remote endpoint-  -> IO (Either (ConnectException 'Interruptible) Connection)-interruptibleConnect !abandon !remote = do-  beforeEstablishment remote >>= \case-    Left err -> pure (Left err)-    Right (fd,sockAddr) -> S.uninterruptibleConnect fd sockAddr >>= \case-      Left err2 -> if err2 == eINPROGRESS-        then do-          interruptibleWaitWrite abandon fd >>= \case-            True -> afterEstablishment fd-            False -> pure (Left ConnectInterrupted)-        else do-          S.uninterruptibleErrorlessClose fd-          handleConnectException SCK.functionWithConnection err2-      Right _ -> afterEstablishment fd---- Internal function called by both connect and interruptibleConnect--- before the connection is established. Creates the socket and prepares--- the sockaddr.-beforeEstablishment :: Endpoint -> IO (Either (ConnectException i) (Fd,S.SocketAddress))-{-# INLINE beforeEstablishment #-}-beforeEstablishment !remote = do-  debug ("beforeEstablishment: opening connection " ++ show remote)-  e1 <- S.uninterruptibleSocket S.internet-    (L.applySocketFlags (L.closeOnExec <> L.nonblocking) S.stream)-    S.defaultProtocol-  debug ("beforeEstablishment: opened connection " ++ show remote)-  case e1 of-    Left err -> handleSocketConnectException SCK.functionWithConnection err-    Right fd -> do-      let sockAddr = id-            $ S.encodeSocketAddressInternet-            $ endpointToSocketAddressInternet-            $ remote-      pure (Right (fd,sockAddr))---- Internal function called by both connect and interruptibleConnect--- after the connection is established.-afterEstablishment :: Fd -> IO (Either (ConnectException i) Connection)-afterEstablishment fd = do-  e <- S.uninterruptibleGetSocketOption fd-    S.levelSocket S.optionError (intToCInt (PM.sizeOf (undefined :: CInt)))-  case e of-    Left err -> do-      S.uninterruptibleErrorlessClose fd-      throwIO $ SocketUnrecoverableException-        moduleSocketStreamIPv4-        functionWithListener-        [SCK.cgetsockopt,describeErrorCode err]-    Right (sz,S.OptionValue val) -> if sz == intToCInt (PM.sizeOf (undefined :: CInt))-      then-        let err = PM.indexByteArray val 0 :: CInt in-        if err == 0-          then pure (Right (Connection fd))-          else do-            S.uninterruptibleErrorlessClose fd-            handleConnectException SCK.functionWithConnection (Errno err)-      else do-        S.uninterruptibleErrorlessClose fd-        throwIO $ SocketUnrecoverableException-          moduleSocketStreamIPv4-          functionWithListener-          [SCK.cgetsockopt,connectErrorOptionValueSize]---- | Close a connection gracefully, reporting a 'CloseException' when--- the connection has to be terminated by sending a TCP reset. This--- uses a combination of @shutdown@, @recv@, @close@ to detect when--- resets need to be sent.-disconnect :: Connection -> IO (Either CloseException ())-disconnect (Connection fd) = gracefulCloseA fd---- | Close a connection. This does not check to see whether or not--- the connection was brought down gracefully. It just calls @close@--- and is likely to cause a TCP reset to be sent. It never--- throws exceptions of any kind (even if @close@ fails).--- This should only be preferred--- to 'disconnect' in exception-cleanup contexts where there is--- already an exception that will be rethrown. See the implementation--- of 'withConnection' for an example of appropriate use of both--- 'disconnect' and 'disconnect_'.-disconnect_ :: Connection -> IO ()-disconnect_ (Connection fd) = S.uninterruptibleErrorlessClose fd---- | Establish a connection to a server.-withConnection ::-     Endpoint-     -- ^ Remote endpoint-  -> (Either CloseException () -> a -> IO b)-     -- ^ Callback to handle an ungraceful close. -  -> (Connection -> IO a)-     -- ^ Callback to consume connection. Must not return the connection.-  -> IO (Either (ConnectException 'Uninterruptible) b)-withConnection !remote g f = mask $ \restore -> do-  connect remote >>= \case-    Left err -> pure (Left err)-    Right conn -> do-      a <- onException (restore (f conn)) (disconnect_ conn)-      m <- disconnect conn-      b <- g m a-      pure (Right b)--interruptibleWithConnection ::-     TVar Bool-     -- ^ Interrupted. If this becomes 'True', give up and return-     --   @'Left' 'AcceptInterrupted'@.-  -> Endpoint-     -- ^ Remote endpoint-  -> (Either CloseException () -> a -> IO b)-     -- ^ Callback to handle an ungraceful close. -  -> (Connection -> IO a)-     -- ^ Callback to consume connection. Must not return the connection.-  -> IO (Either (ConnectException 'Interruptible) b)-interruptibleWithConnection !abandon !remote g f = mask $ \restore -> do-  interruptibleConnect abandon remote >>= \case-    Left err -> pure (Left err)-    Right conn -> do-      a <- onException (restore (f conn)) (disconnect_ conn)-      m <- disconnect conn-      b <- g m a-      pure (Right b)-    -sendByteArray ::-     Connection -- ^ Connection-  -> ByteArray -- ^ Payload-  -> IO (Either (SendException 'Uninterruptible) ())-sendByteArray conn arr =-  sendByteArraySlice conn arr 0 (PM.sizeofByteArray arr)--interruptibleSendByteArray ::-     TVar Bool-     -- ^ Interrupted. If this becomes 'True', give up and return-     --   @'Left' 'AcceptInterrupted'@.-  -> Connection -- ^ Connection-  -> ByteArray -- ^ Payload-  -> IO (Either (SendException 'Interruptible) ())-interruptibleSendByteArray abandon conn arr =-  interruptibleSendByteArraySlice abandon conn arr 0 (PM.sizeofByteArray arr)---- | Send a 'ByteString' over a connection. -sendByteString ::-     Connection -- ^ Connection-  -> ByteString -- ^ Payload-  -> IO (Either (SendException 'Uninterruptible) ())-sendByteString !conn !payload = BU.unsafeUseAsCStringLen payload-  (\(Ptr addr,len) -> sendAddr conn (Addr addr) len)---- | Send a lazy 'LBS.ByteString' over a connection. -sendLazyByteString ::-     Connection -- ^ Connection-  -> LBS.ByteString -- ^ Payload-  -> IO (Either (SendException 'Uninterruptible) ())-sendLazyByteString !conn !chunks0 = go chunks0 where-  go LBS.Empty = pure (Right ())-  go (LBS.Chunk chunk chunks) = sendByteString conn chunk >>= \case-    Left e -> pure (Left e)-    Right _ -> go chunks--sendAddr ::-     Connection -- ^ Connection-  -> Addr -- ^ Payload start address-  -> Int -- ^ Payload length -  -> IO (Either (SendException 'Uninterruptible) ())-sendAddr !conn !payload0 !len0 = go payload0 len0-  where-  go !payload !len = if len > 0-    then internalSendAddr conn payload len >>= \case-      Left e -> pure (Left e)-      Right sz' -> do-        let sz = csizeToInt sz'-        go (PM.plusAddr payload sz) (len - sz)-    else if len == 0-      then pure (Right ())-      else throwIO $ SocketUnrecoverableException-        moduleSocketStreamIPv4-        functionSendByteArray-        [SCK.negativeSliceLength]--sendByteArraySlice ::-     Connection -- ^ Connection-  -> ByteArray -- ^ Payload (will be sliced)-  -> Int -- ^ Offset into payload-  -> Int -- ^ Length of slice into buffer-  -> IO (Either (SendException 'Uninterruptible) ())-sendByteArraySlice !conn !payload !off0 !len0 = go off0 len0-  where-  go !off !len = if len > 0-    then internalSend conn payload off len >>= \case-      Left e -> pure (Left e)-      Right sz' -> do-        let sz = csizeToInt sz'-        go (off + sz) (len - sz)-    else if len == 0-      then pure (Right ())-      else throwIO $ SocketUnrecoverableException-        moduleSocketStreamIPv4-        functionSendByteArray-        [SCK.negativeSliceLength]--interruptibleSendByteArraySlice ::-     TVar Bool-     -- ^ Interrupted. If this becomes 'True', give up and return-     --   @'Left' 'AcceptInterrupted'@.-  -> Connection -- ^ Connection-  -> ByteArray -- ^ Payload (will be sliced)-  -> Int -- ^ Offset into payload-  -> Int -- ^ Length of slice into buffer-  -> IO (Either (SendException 'Interruptible) ())-interruptibleSendByteArraySlice !abandon !conn !payload !off0 !len0 = go off0 len0-  where-  go !off !len = if len > 0-    then internalInterruptibleSend abandon conn payload off len >>= \case-      Left e -> pure (Left e)-      Right sz' -> do-        let sz = csizeToInt sz'-        go (off + sz) (len - sz)-    else if len == 0-      then pure (Right ())-      else throwIO $ SocketUnrecoverableException-        moduleSocketStreamIPv4-        functionSendByteArray-        [SCK.negativeSliceLength]--sendMutableByteArray ::-     Connection -- ^ Connection-  -> MutableByteArray RealWorld -- ^ Buffer (will be sliced)-  -> IO (Either (SendException 'Uninterruptible) ())-sendMutableByteArray conn arr =-  sendMutableByteArraySlice conn arr 0 =<< PM.getSizeofMutableByteArray arr--sendMutableByteArraySlice ::-     Connection -- ^ Connection-  -> MutableByteArray RealWorld -- ^ Buffer (will be sliced)-  -> Int -- ^ Offset into payload-  -> Int -- ^ Length of slice into buffer-  -> IO (Either (SendException 'Uninterruptible) ())-sendMutableByteArraySlice !conn !payload !off0 !len0 = go off0 len0-  where-  go !off !len = if len > 0-    then internalSendMutable conn payload off len >>= \case-      Left e -> pure (Left e)-      Right sz' -> do-        let sz = csizeToInt sz'-        go (off + sz) (len - sz)-    else if len == 0-      then pure (Right ())-      else throwIO $ SocketUnrecoverableException-        moduleSocketStreamIPv4-        functionSendMutableByteArray-        [SCK.negativeSliceLength]--interruptibleSendMutableByteArraySlice ::-     TVar Bool-     -- ^ Interrupted. If this becomes 'True' give up and return-     --   @'Left' 'AcceptInterrupted'@.-  -> Connection -- ^ Connection-  -> MutableByteArray RealWorld -- ^ Buffer (will be sliced)-  -> Int -- ^ Offset into payload-  -> Int -- ^ Length of slice into buffer-  -> IO (Either (SendException 'Interruptible) ())-interruptibleSendMutableByteArraySlice !abandon !conn !payload !off0 !len0 = go off0 len0-  where-  go !off !len = if len > 0-    then internalInterruptibleSendMutable abandon conn payload off len >>= \case-      Left e -> pure (Left e)-      Right sz' -> do-        let sz = csizeToInt sz'-        go (off + sz) (len - sz)-    else if len == 0-      then pure (Right ())-      else throwIO $ SocketUnrecoverableException-        moduleSocketStreamIPv4-        functionSendMutableByteArray-        [SCK.negativeSliceLength]---- Precondition: the length must be greater than zero.-internalInterruptibleSendMutable ::-     TVar Bool-     -- ^ Interrupted. If this becomes 'True' give up and return-     --   @'Left' 'AcceptInterrupted'@.-  -> Connection -- ^ Connection-  -> MutableByteArray RealWorld -- ^ Buffer (will be sliced)-  -> Int -- ^ Offset into payload-  -> Int -- ^ Length of slice into buffer-  -> IO (Either (SendException 'Interruptible) CSize)-internalInterruptibleSendMutable !abandon !conn !payload !off !len =-  veryInternalSendMutable-    (\fd -> interruptibleWaitWrite abandon fd >>= \case-      True -> pure (Right ())-      False -> pure (Left SendInterrupted)-    ) conn payload off len---- Precondition: the length must be greater than zero.-internalSendMutable ::-     Connection -- ^ Connection-  -> MutableByteArray RealWorld -- ^ Buffer (will be sliced)-  -> Int -- ^ Offset into payload-  -> Int -- ^ Length of slice into buffer-  -> IO (Either (SendException 'Uninterruptible) CSize)-internalSendMutable !conn !payload !off !len =-  veryInternalSendMutable-    (\fd -> threadWaitWrite fd *> pure (Right ()))-    conn payload off len---- Precondition: the length must be greater than zero.-veryInternalSendMutable :: -     (Fd -> IO (Either (SendException i) ()))-  -> Connection -- ^ Connection-  -> MutableByteArray RealWorld -- ^ Buffer (will be sliced)-  -> Int -- ^ Offset into payload-  -> Int -- ^ Length of slice into buffer-  -> IO (Either (SendException i) CSize)-{-# INLINE veryInternalSendMutable #-}-veryInternalSendMutable wait (Connection !s) !payload !off !len = do-  e1 <- S.uninterruptibleSendMutableByteArray s payload-    (intToCInt off)-    (intToCSize len)-    (S.noSignal)-  case e1 of-    Left err1 -> if err1 == eWOULDBLOCK || err1 == eAGAIN-      then do-        wait s >>= \case-          Left err2 -> pure (Left err2)-          Right () -> do-            e3 <- S.uninterruptibleSendMutableByteArray s payload-              (intToCInt off)-              (intToCSize len)-              (S.noSignal)-            case e3 of-              Left err3 -> handleSendException functionSendMutableByteArray err3-              Right sz -> pure (Right sz)-      else handleSendException "sendMutableByteArray" err1-    Right sz -> pure (Right sz)---- Precondition: the length must be greater than zero.-internalSend ::-     Connection -- ^ Connection-  -> ByteArray -- ^ Buffer (will be sliced)-  -> Int -- ^ Offset into payload-  -> Int -- ^ Length of slice into buffer-  -> IO (Either (SendException 'Uninterruptible) CSize)-internalSend !conn !payload !off !len = veryInternalSend-  (\fd -> threadWaitWrite fd *> pure (Right ()))-  conn payload off len---- Precondition: the length must be greater than zero.-internalSendAddr ::-     Connection -- ^ Connection-  -> Addr -- ^ Buffer start address-  -> Int -- ^ Length of slice into buffer-  -> IO (Either (SendException 'Uninterruptible) CSize)-internalSendAddr !conn !payload !len = veryInternalSendAddr-  (\fd -> threadWaitWrite fd *> pure (Right ()))-  conn payload len---- Precondition: the length must be greater than zero.-internalInterruptibleSend ::-     TVar Bool -- ^ Aliveness-  -> Connection -- ^ Connection-  -> ByteArray -- ^ Buffer (will be sliced)-  -> Int -- ^ Offset into payload-  -> Int -- ^ Length of slice into buffer-  -> IO (Either (SendException 'Interruptible) CSize)-internalInterruptibleSend !abandon !conn !payload !off !len = veryInternalSend-  (\fd -> interruptibleWaitWrite abandon fd >>= \case-    True -> pure (Right ())-    False -> pure (Left SendInterrupted)-  ) conn payload off len---- Precondition: the length must be greater than zero.-veryInternalSend ::-     (Fd -> IO (Either (SendException i) ()))-  -> Connection -- ^ Connection-  -> ByteArray -- ^ Buffer (will be sliced)-  -> Int -- ^ Offset into payload-  -> Int -- ^ Length of slice into buffer-  -> IO (Either (SendException i) CSize)-{-# INLINE veryInternalSend #-}-veryInternalSend wait (Connection !s) !payload !off !len = do-  debug ("veryInternalSend: about to send chunk on stream socket, offset " ++ show off ++ " and length " ++ show len)-  e1 <- S.uninterruptibleSendByteArray s payload-    (intToCInt off)-    (intToCSize len)-    (S.noSignal)-  debug "veryInternalSend: just sent chunk on stream socket"-  case e1 of-    Left err1 -> if err1 == eWOULDBLOCK || err1 == eAGAIN-      then do-        debug "veryInternalSend: waiting to for write ready on stream socket"-        wait s >>= \case-          Left e -> pure (Left e)-          Right _ -> do-            e2 <- S.uninterruptibleSendByteArray s payload-              (intToCInt off)-              (intToCSize len)-              (S.noSignal)-            case e2 of-              Left err2 -> do-                debug "veryInternalSend: encountered error after sending chunk on stream socket"-                handleSendException functionSendByteArray err2-              Right sz -> pure (Right sz)-      else handleSendException functionSendByteArray err1-    Right sz -> pure (Right sz)---- Precondition: the length must be greater than zero.-veryInternalSendAddr ::-     (Fd -> IO (Either (SendException i) ()))-  -> Connection -- ^ Connection-  -> Addr -- ^ Buffer start address-  -> Int -- ^ Length of payload-  -> IO (Either (SendException i) CSize)-{-# INLINE veryInternalSendAddr #-}-veryInternalSendAddr wait (Connection !s) !payload !len = do-  debug ("veryInternalSendAddr: about to send chunk on stream socket, length " ++ show len)-  e1 <- S.uninterruptibleSend s payload-    (intToCSize len)-    (S.noSignal)-  debug "veryInternalSendAddr: just sent chunk on stream socket"-  case e1 of-    Left err1 -> if err1 == eWOULDBLOCK || err1 == eAGAIN-      then do-        debug "veryInternalSendAddr: waiting to for write ready on stream socket"-        wait s >>= \case-          Left e -> pure (Left e)-          Right _ -> do-            e2 <- S.uninterruptibleSend s payload-              (intToCSize len)-              (S.noSignal)-            case e2 of-              Left err2 -> do-                debug "veryInternalSendAddr: encountered error after sending chunk on stream socket"-                handleSendException functionSendByteArray err2-              Right sz -> pure (Right sz)-      else handleSendException functionSendByteArray err1-    Right sz -> pure (Right sz)---- The maximum number of bytes to receive must be greater than zero.--- The operating system guarantees us that the returned actual number--- of bytes is less than or equal to the requested number of bytes.--- This function does not validate that the result size is greater--- than zero. Functions calling this must perform that check. This--- also does not trim the buffer. The caller must do that if it is--- necessary. This function does use the event manager to wait--- for the socket to be ready for reads.-internalReceiveMaximally ::-     Connection -- ^ Connection-  -> Int -- ^ Maximum number of bytes to receive-  -> MutableByteArray RealWorld -- ^ Receive buffer-  -> Int -- ^ Offset into buffer-  -> IO (Either (ReceiveException i) Int)-internalReceiveMaximally (Connection !fd) !maxSz !buf !off = do-  debug "receive: stream socket about to wait"-  threadWaitRead fd-  debug ("receive: stream socket is now readable, receiving up to " ++ show maxSz ++ " bytes at offset " ++ show off)-  e <- S.uninterruptibleReceiveMutableByteArray fd buf (intToCInt off) (intToCSize maxSz) mempty-  debug "receive: finished reading from stream socket"-  case e of-    Left err -> handleReceiveException "internalReceiveMaximally" err-    Right recvSz -> pure (Right (csizeToInt recvSz))--internalInterruptibleReceiveMaximally ::-     TVar Bool -- ^ If this completes, give up on receiving-  -> Connection -- ^ Connection-  -> Int -- ^ Maximum number of bytes to receive-  -> MutableByteArray RealWorld -- ^ Receive buffer-  -> Int -- ^ Offset into buffer-  -> IO (Either (ReceiveException 'Interruptible) Int)-{-# INLINE internalInterruptibleReceiveMaximally #-}-internalInterruptibleReceiveMaximally abandon (Connection !fd) !maxSz !buf !off = do-  shouldReceive <- interruptibleWaitRead abandon fd-  if shouldReceive-    then do-      e <- S.uninterruptibleReceiveMutableByteArray fd buf (intToCInt off) (intToCSize maxSz) mempty-      case e of-        Left err -> handleReceiveException "internalReceiveMaximally" err-        Right recvSz -> pure (Right (csizeToInt recvSz))-    else pure (Left ReceiveInterrupted)---- | Receive exactly the given number of bytes. If the remote application---   shuts down its end of the connection before sending the required---   number of bytes, this returns @'Left' 'ReceiveShutdown'@.-receiveByteArray ::-     Connection -- ^ Connection-  -> Int -- ^ Number of bytes to receive-  -> IO (Either (ReceiveException 'Uninterruptible) ByteArray)-receiveByteArray !conn !total =-  internalReceiveByteArray internalReceiveMaximally conn total---- | Variant of 'receiveByteArray' that support STM-style interrupts.-interruptibleReceiveByteArray ::-     TVar Bool-     -- ^ Interrupted. If this becomes 'True' give up and return-     --   @'Left' 'ReceiveInterrupted'@.-  -> Connection -- ^ Connection-  -> Int -- ^ Number of bytes to receive-  -> IO (Either (ReceiveException 'Interruptible) ByteArray)-interruptibleReceiveByteArray !abandon !conn !total =-  internalReceiveByteArray (internalInterruptibleReceiveMaximally abandon) conn total---- This is used by both receiveByteArray and interruptibleReceiveByteArray.-internalReceiveByteArray ::-     (Connection -> Int -> MutableByteArray RealWorld -> Int -> IO (Either (ReceiveException i) Int))-  -> Connection-  -> Int-  -> IO (Either (ReceiveException i) ByteArray)-internalReceiveByteArray recvMax !conn0 !total = do-  marr <- PM.newByteArray total-  go conn0 marr 0 total-  where-  go !conn !marr !off !remaining = case compare remaining 0 of-    GT -> do-      recvMax conn remaining marr off >>= \case-        Left err -> pure (Left err)-        Right sz -> if sz /= 0-          then go conn marr (off + sz) (remaining - sz)-          else pure (Left ReceiveShutdown)-    EQ -> do-      arr <- PM.unsafeFreezeByteArray marr-      pure (Right arr)-    LT -> throwIO $ SocketUnrecoverableException-      moduleSocketStreamIPv4-      functionReceiveByteArray-      [SCK.negativeSliceLength]---- | Receive exactly the given number of bytes.-receiveByteString :: -     Connection -- ^ Connection-  -> Int -- ^ Number of bytes to receive-  -> IO (Either (ReceiveException 'Uninterruptible) ByteString)-receiveByteString !conn !total = do-  marr@(MutableByteArray marr#) <- PM.newPinnedByteArray total-  receiveMutableByteArray conn marr >>= \case-    Left err -> pure (Left err)-    Right _ -> pure (Right (BI.PS (FP.ForeignPtr (byteArrayContents# (unsafeCoerce# marr#)) (FP.PlainPtr marr#)) 0 total))---- | Receive a number of bytes exactly equal to the size of the mutable---   byte array. If the remote application shuts down its end of the---   connection before sending the required number of bytes, this returns---   @'Left' ('SocketException' 'Receive' 'RemoteShutdown')@.-receiveMutableByteArray ::-     Connection-  -> MutableByteArray RealWorld-  -> IO (Either (ReceiveException 'Uninterruptible) ())-receiveMutableByteArray !conn0 !marr0 = do-  total <- PM.getSizeofMutableByteArray marr0-  go conn0 marr0 0 total-  where-  go !conn !marr !off !remaining = if remaining > 0-    then do-      internalReceiveMaximally conn remaining marr off >>= \case-        Left err -> pure (Left err)-        Right sz -> if sz /= 0-          then go conn marr (off + sz) (remaining - sz)-          else pure (Left ReceiveShutdown)-    else pure (Right ())---- | Receive up to the given number of bytes, using the given array and---   starting at the given offset.-receiveBoundedMutableByteArraySlice ::-     Connection -- ^ Connection-  -> Int -- ^ Maximum number of bytes to receive-  -> MutableByteArray RealWorld -- ^ Buffer in which the data are going to be stored-  -> Int -- ^ Offset in the buffer-  -> IO (Either (ReceiveException 'Uninterruptible) Int) -- ^ Either a socket exception or the number of bytes read-receiveBoundedMutableByteArraySlice !conn !total !marr !off-  | total > 0 = do-      internalReceiveMaximally conn total marr off >>= \case-        Left err -> pure (Left err)-        Right sz -> if sz /= 0-          then pure (Right sz)-          else pure (Left ReceiveShutdown)-  | total == 0 = pure (Right 0)-  | otherwise = throwIO $ SocketUnrecoverableException-      moduleSocketStreamIPv4-      functionReceiveMutableByteArraySlice-      [SCK.negativeSliceLength]---- | Receive up to the given number of bytes, using the given array and---   starting at the given offset. This can be interrupted by the---   completion of an 'STM' transaction.-interruptibleReceiveBoundedMutableByteArraySlice ::-     TVar Bool-     -- ^ Interrupted. If this becomes 'True' give up and return-     --   @'Left' 'ReceiveInterrupted'@.-  -> Connection -- ^ Connection-  -> Int -- ^ Maximum number of bytes to receive-  -> MutableByteArray RealWorld -- ^ Buffer in which the data are going to be stored-  -> Int -- ^ Offset in the buffer-  -> IO (Either (ReceiveException 'Interruptible) Int) -- ^ Either a socket exception or the number of bytes read-interruptibleReceiveBoundedMutableByteArraySlice !abandon !conn !total !marr !off-  | total > 0 = do-      internalInterruptibleReceiveMaximally abandon conn total marr off >>= \case-        Left err -> pure (Left err)-        Right sz -> if sz /= 0-          then pure (Right sz)-          else pure (Left ReceiveShutdown)-  | total == 0 = pure (Right 0)-  | otherwise = throwIO $ SocketUnrecoverableException-      moduleSocketStreamIPv4-      -- TODO: fix this function name in the error reporting-      functionReceiveMutableByteArraySlice-      [SCK.negativeSliceLength]---- | Receive up to the given number of bytes. If the remote application---   shuts down its end of the connection instead of sending any bytes,---   this returns---   @'Left' ('SocketException' 'Receive' 'RemoteShutdown')@.-receiveBoundedByteArray ::-     Connection -- ^ Connection-  -> Int -- ^ Maximum number of bytes to receive-  -> IO (Either (ReceiveException 'Uninterruptible) ByteArray)-receiveBoundedByteArray !conn !total-  | total > 0 = do-      m <- PM.newByteArray total-      receiveBoundedMutableByteArraySlice conn total m 0 >>= \case-        Left err -> pure (Left err)-        Right sz -> do-          shrinkMutableByteArray m sz-          Right <$> PM.unsafeFreezeByteArray m-  | total == 0 = pure (Right mempty)-  | otherwise = throwIO $ SocketUnrecoverableException-      moduleSocketStreamIPv4-      functionReceiveBoundedByteArray-      [SCK.negativeSliceLength]--endpointToSocketAddressInternet :: Endpoint -> S.SocketAddressInternet-endpointToSocketAddressInternet (Endpoint {address, port}) = S.SocketAddressInternet-  { port = S.hostToNetworkShort port-  , address = S.hostToNetworkLong (getIPv4 address)-  }--socketAddressInternetToEndpoint :: S.SocketAddressInternet -> Endpoint-socketAddressInternetToEndpoint (S.SocketAddressInternet {address,port}) = Endpoint-  { address = IPv4 (S.networkToHostLong address)-  , port = S.networkToHostShort port-  }--intToCInt :: Int -> CInt-intToCInt = fromIntegral--intToCSize :: Int -> CSize-intToCSize = fromIntegral--csizeToInt :: CSize -> Int-csizeToInt = fromIntegral--shrinkMutableByteArray :: MutableByteArray RealWorld -> Int -> IO ()-shrinkMutableByteArray (MutableByteArray arr) (I# sz) =-  PM.primitive_ (shrinkMutableByteArray# arr sz)--moduleSocketStreamIPv4 :: String-moduleSocketStreamIPv4 = "Socket.Stream.IPv4"--functionSendMutableByteArray :: String-functionSendMutableByteArray = "sendMutableByteArray"--functionSendByteArray :: String-functionSendByteArray = "sendByteArray"--functionWithListener :: String-functionWithListener = "withListener"--functionReceiveBoundedByteArray :: String-functionReceiveBoundedByteArray = "receiveBoundedByteArray"--functionReceiveByteArray :: String-functionReceiveByteArray = "receiveByteArray"--functionReceiveMutableByteArraySlice :: String-functionReceiveMutableByteArraySlice = "receiveMutableByteArraySlice"--describeErrorCode :: Errno -> String-describeErrorCode err@(Errno e) = "error code " ++ D.string err ++ " (" ++ show e ++ ")"--handleReceiveException :: String -> Errno -> IO (Either (ReceiveException i) a)-handleReceiveException func e-  | e == eCONNRESET = pure (Left ReceiveReset)-  | otherwise = throwIO $ SocketUnrecoverableException-      moduleSocketStreamIPv4-      func-      [describeErrorCode e]--handleSendException :: String -> Errno -> IO (Either (SendException i) a)-{-# INLINE handleSendException #-}-handleSendException func e-  | e == ePIPE = pure (Left SendShutdown)-  | e == eCONNRESET = pure (Left SendReset)-  | otherwise = throwIO $ SocketUnrecoverableException-      moduleSocketStreamIPv4-      func-      [describeErrorCode e]---- These are the exceptions that can happen as a result of a--- nonblocking @connect@ or as a result of subsequently calling--- @getsockopt@ to get the @SO_ERROR@ after the socket is ready--- for writes. For increased likelihood of correctness, we do--- not distinguish between which of these error codes can show--- up after which of those two calls. This means we are likely--- testing for some exceptions that cannot occur as a result of--- a particular call, but doing otherwise would be fraught with--- uncertainty.-handleConnectException :: String -> Errno -> IO (Either (ConnectException i) a)-handleConnectException func e-  | e == eACCES = pure (Left ConnectFirewalled)-  | e == ePERM = pure (Left ConnectFirewalled)-  | e == eNETUNREACH = pure (Left ConnectNetworkUnreachable)-  | e == eCONNREFUSED = pure (Left ConnectRefused)-  | e == eADDRNOTAVAIL = pure (Left ConnectEphemeralPortsExhausted)-  | e == eTIMEDOUT = pure (Left ConnectTimeout)-  | otherwise = throwIO $ SocketUnrecoverableException-      moduleSocketStreamIPv4-      func-      [describeErrorCode e]---- These are the exceptions that can happen as a result--- of calling @socket@ with the intent of using the socket--- to open a connection (not listen for inbound connections).-handleSocketConnectException :: String -> Errno -> IO (Either (ConnectException i) a)-handleSocketConnectException func e-  | e == eMFILE = pure (Left ConnectFileDescriptorLimit)-  | e == eNFILE = pure (Left ConnectFileDescriptorLimit)-  | otherwise = throwIO $ SocketUnrecoverableException-      moduleSocketStreamIPv4-      func-      [describeErrorCode e]---- These are the exceptions that can happen as a result--- of calling @socket@ with the intent of using the socket--- to listen for inbound connections.-handleSocketListenException :: String -> Errno -> IO (Either SocketException a)-handleSocketListenException func e-  | e == eMFILE = pure (Left SocketFileDescriptorLimit)-  | e == eNFILE = pure (Left SocketFileDescriptorLimit)-  | otherwise = throwIO $ SocketUnrecoverableException-      moduleSocketStreamIPv4-      func-      [describeErrorCode e]---- These are the exceptions that can happen as a result--- of calling @bind@ with the intent of using the socket--- to listen for inbound connections. This is also used--- to clean up the error codes of @listen@. The two can--- report some of the same error codes, and those happen--- to be the error codes we are interested in.------ NB: EACCES only happens on @bind@, not on @listen@.-handleBindListenException :: Word16 -> String -> Errno -> IO (Either SocketException a)-handleBindListenException thePort func e-  | e == eACCES = pure (Left SocketPermissionDenied)-  | e == eADDRINUSE = if thePort == 0-      then pure (Left SocketAddressInUse)-      else pure (Left SocketEphemeralPortsExhausted)-  | otherwise = throwIO $ SocketUnrecoverableException-      moduleSocketStreamIPv4-      func-      [describeErrorCode e]---- These are the exceptions that can happen as a result--- of calling @socket@ with the intent of using the socket--- to open a connection (not listen for inbound connections).-handleAcceptException :: String -> Errno -> IO (Either (AcceptException i) a)-handleAcceptException func e-  | e == eCONNABORTED = pure (Left AcceptConnectionAborted)-  | e == eMFILE = pure (Left AcceptFileDescriptorLimit)-  | e == eNFILE = pure (Left AcceptFileDescriptorLimit)-  | e == ePERM = pure (Left AcceptFirewalled)-  | otherwise = throwIO $ SocketUnrecoverableException-      moduleSocketStreamIPv4-      func-      [describeErrorCode e]--connectErrorOptionValueSize :: String-connectErrorOptionValueSize = "incorrectly sized value of SO_ERROR option"--interruptibleWaitRead :: TVar Bool -> Fd -> IO Bool-interruptibleWaitRead !abandon !fd = do-  (isReady,deregister) <- threadWaitReadSTM fd-  shouldReceive <- atomically-    ((bool retry (pure False) =<< readTVar abandon) <|> (isReady $> True))-  deregister-  pure shouldReceive--interruptibleWaitWrite :: TVar Bool -> Fd -> IO Bool-interruptibleWaitWrite !abandon !fd = do-  (isReady,deregister) <- threadWaitWriteSTM fd-  shouldSend <- atomically-    ((bool retry (pure False) =<< readTVar abandon) <|> (isReady $> True))-  deregister-  pure shouldSend--interruptibleWaitReadCounting :: TVar Int -> TVar Bool -> Fd -> IO Bool-interruptibleWaitReadCounting !counter !abandon !fd = do-  (isReady,deregister) <- threadWaitReadSTM fd-  shouldReceive <- atomically $ do-    readTVar abandon >>= \case-      False -> do-        isReady-        modifyTVar' counter (+1)-        pure True-      True -> pure False-  deregister-  pure shouldReceive+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}++module Socket.Stream.IPv4+  ( -- * Types+    Listener+  , Connection(..)+  , Peer(..)+    -- * Bracketed+    -- $brackeded+  , withListener+  , withAccepted+  , withConnection+  , forkAccepted+  , forkAcceptedUnmasked+  , interruptibleForkAcceptedUnmasked+    -- * Exceptions+  , SendException(..)+  , ReceiveException(..)+  , ConnectException(..)+  , SocketException(..)+  , AcceptException(..)+  , CloseException(..)+    -- * Type Arguments+  , Interruptibility(..)+  , Family(..)+  , Version(..)+    -- * Unbracketed+    -- $unbracketed+  , listen+  , unlisten+  , unlisten_+  , connect+  -- , interruptibleConnect+  , disconnect+  , disconnect_+  , accept+  , interruptibleAccept+  ) where++import Control.Concurrent (ThreadId)+import Control.Concurrent (forkIO, forkIOWithUnmask)+import Control.Exception (mask, mask_, onException, throwIO)+import Control.Monad.STM (atomically)+import Control.Concurrent.STM (TVar,modifyTVar')+import Data.Word (Word16)+import Foreign.C.Error (Errno(..), eAGAIN, eINPROGRESS, eWOULDBLOCK, eNOTCONN)+import Foreign.C.Error (eADDRINUSE,eHOSTUNREACH)+import Foreign.C.Error (eNFILE,eMFILE,eACCES,ePERM,eCONNABORTED)+import Foreign.C.Error (eTIMEDOUT,eADDRNOTAVAIL,eNETUNREACH,eCONNREFUSED)+import Foreign.C.Types (CInt)+import Net.Types (IPv4(..))+import Socket (Interruptibility(..))+import Socket (SocketUnrecoverableException(..),Family(Internet),Version(V4))+import Socket (cgetsockname,cclose)+import Socket.Error (die)+import Socket.Debug (debug)+import Socket.IPv4 (Peer(..),describeEndpoint)+import Socket.Stream (ConnectException(..),SocketException(..),AcceptException(..))+import Socket.Stream (SendException(..),ReceiveException(..),CloseException(..))+import Socket.Stream (Connection(..))+import System.Posix.Types(Fd)++import qualified Control.Concurrent.STM as STM+import qualified Data.Primitive as PM+import qualified Foreign.C.Error.Describe as D+import qualified Linux.Socket as L+import qualified Posix.Socket as S+import qualified Socket as SCK+import qualified Socket.EventManager as EM++-- | A socket that listens for incomming connections.+newtype Listener = Listener Fd++-- | Open a socket that can be used to listen for inbound connections.+-- Requirements:+--+-- * This function may only be called in contexts where exceptions+--   are masked.+-- * The caller /must/ be sure to call 'unlistener' on the resulting+--   'Listener' exactly once to close underlying file descriptor.+-- * The 'Listener' cannot be used after being given as an argument+--   to 'unlistener'.+--+-- Noncompliant use of this function leads to undefined behavior. Prefer+-- 'withListener' unless you are writing an integration with a+-- resource-management library.+listen :: Peer -> IO (Either SocketException (Listener, Word16))+listen endpoint@Peer{port = specifiedPort} = do+  debug ("listen: opening listen " ++ describeEndpoint endpoint)+  e1 <- S.uninterruptibleSocket S.internet+    (L.applySocketFlags (L.closeOnExec <> L.nonblocking) S.stream)+    S.defaultProtocol+  debug ("listen: opened listen " ++ describeEndpoint endpoint)+  case e1 of+    Left err -> handleSocketListenException SCK.functionWithListener err+    Right fd -> do+      e2 <- S.uninterruptibleBind fd+        (S.encodeSocketAddressInternet (endpointToSocketAddressInternet endpoint))+      debug ("listen: requested binding for listen " ++ describeEndpoint endpoint)+      case e2 of+        Left err -> do+          _ <- S.uninterruptibleClose fd+          handleBindListenException specifiedPort err+        Right _ -> S.uninterruptibleListen fd 16 >>= \case+          -- We hardcode the listen backlog to 16. The author is unfamiliar+          -- with use cases where gains are realized from tuning this parameter.+          -- Open an issue if this causes problems for anyone.+          Left err -> do+            _ <- S.uninterruptibleClose fd+            debug "listen: listen failed with error code"+            handleBindListenException specifiedPort err+          Right _ -> do+            -- The getsockname is copied from code in Socket.Datagram.IPv4.Undestined.+            -- Consider factoring this out.+            actualPort <- if specifiedPort == 0+              then S.uninterruptibleGetSocketName fd S.sizeofSocketAddressInternet >>= \case+                Left err -> throwIO $ SocketUnrecoverableException+                  moduleSocketStreamIPv4+                  functionWithListener+                  [cgetsockname,describeEndpoint endpoint,describeErrorCode err]+                Right (sockAddrRequiredSz,sockAddr) -> if sockAddrRequiredSz == S.sizeofSocketAddressInternet+                  then case S.decodeSocketAddressInternet sockAddr of+                    Just S.SocketAddressInternet{port = actualPort} -> do+                      let cleanActualPort = S.networkToHostShort actualPort+                      debug ("listen: successfully bound listen " ++ describeEndpoint endpoint ++ " and got port " ++ show cleanActualPort)+                      pure cleanActualPort+                    Nothing -> do+                      _ <- S.uninterruptibleClose fd+                      throwIO $ SocketUnrecoverableException+                        moduleSocketStreamIPv4+                        functionWithListener+                        [cgetsockname,"non-internet socket family"]+                  else do+                    _ <- S.uninterruptibleClose fd+                    throwIO $ SocketUnrecoverableException+                      moduleSocketStreamIPv4+                      functionWithListener+                      [cgetsockname,describeEndpoint endpoint,"socket address size"]+              else pure specifiedPort+            let !mngr = EM.manager+            debug ("listen: registering fd " ++ show fd)+            EM.register mngr fd+            pure (Right (Listener fd, actualPort))++-- | Close a listener. This throws an unrecoverable exception if+--   the socket cannot be closed.+unlisten :: Listener -> IO ()+unlisten (Listener fd) = S.uninterruptibleClose fd >>= \case+  Left err -> throwIO $ SocketUnrecoverableException+    moduleSocketStreamIPv4+    functionWithListener+    [cclose,describeErrorCode err]+  Right _ -> pure ()++-- | Close a listener. This does not check to see whether or not+-- the operating system successfully closed the socket. It never+-- throws exceptions of any kind. This should only be preferred+-- to 'unlistener' in exception-cleanup contexts where there is+-- already an exception that will be rethrown. See the implementation+-- of 'withListener' for an example of appropriate use of both+-- 'unlistener' and 'unlistener_'.+unlisten_ :: Listener -> IO ()+unlisten_ (Listener fd) = S.uninterruptibleErrorlessClose fd++-- | Open a socket that is used to listen for inbound connections.+withListener ::+     Peer+  -> (Listener -> Word16 -> IO a)+  -> IO (Either SocketException a)+withListener endpoint f = mask $ \restore -> do+  listen endpoint >>= \case+    Left err -> pure (Left err)+    Right (sck, actualPort) -> do+      a <- onException+        (restore (f sck actualPort))+        (unlisten_ sck)+      unlisten sck+      pure (Right a)++-- | Listen for an inbound connection.+accept :: Listener -> IO (Either (AcceptException 'Uninterruptible) (Connection,Peer))+accept (Listener !fd) = do+  -- Although this function must be called in a context where+  -- exceptions are masked, recall that EM.wait uses an STM+  -- action that might retry, meaning that this first part is+  -- still interruptible. This is a good thing in the case of+  -- this function.+  debug ("accept: about to create manager, fd=" ++ show fd)+  let !mngr = EM.manager+  debug ("accept: about to get reader, fd=" ++ show fd)+  -- The listener should already be registered, so we can just+  -- ask for the reader directly.+  !tv <- EM.reader mngr fd+  let go !oldToken = do+        debug ("accept: calling waitlessAccept for " ++ show fd)+        waitlessAccept fd >>= \case+          Left merr -> case merr of+            Nothing -> EM.unreadyAndWait oldToken tv >>= go+            Just err -> pure (Left err)+          Right r@(Connection conn,_) -> do+            debug ("accept: waitlessAccept succeeded for " ++ show fd)+            EM.register mngr conn+            pure (Right r)+  go =<< STM.readTVarIO tv++-- | Listen for an inbound connection. Can be interrupted by an+-- STM-style interrupt.+interruptibleAccept ::+     TVar Bool+     -- ^ Interrupted. If this becomes 'True' give up and return+     --   @'Left' 'AcceptInterrupted'@.+  -> Listener+  -> IO (Either (AcceptException 'Interruptible) (Connection,Peer))+interruptibleAccept !abandon (Listener fd) = do+  -- TODO: pull these out of the loop+  let !mngr = EM.manager+  tv <- EM.reader mngr fd+  token <- EM.interruptibleWait abandon tv+  if EM.isInterrupt token+    then pure (Left AcceptInterrupted)+    else waitlessAccept fd >>= \case+      Left merr -> case merr of+        Nothing -> do+          EM.unready token tv+          interruptibleAccept abandon (Listener fd)+        Just err -> pure (Left err)+      Right r@(Connection conn,_) -> do+        EM.register mngr conn+        pure (Right r)++-- Only used internally+interruptibleAcceptCounting :: +     TVar Int+  -> TVar Bool+  -> Listener+  -> IO (Either (AcceptException 'Interruptible) (Connection,Peer))+interruptibleAcceptCounting !counter !abandon (Listener !fd) = do+  -- TODO: pull these out of the loop+  let !mngr = EM.manager+  tv <- EM.reader mngr fd+  token <- EM.interruptibleWait abandon tv+  if EM.isInterrupt token+    then pure (Left AcceptInterrupted)+    else waitlessAccept fd >>= \case+      Left merr -> case merr of+        Nothing -> do+          EM.unready token tv+          interruptibleAcceptCounting counter abandon (Listener fd)+        Just err -> pure (Left err)+      Right r@(Connection conn,_) -> do+        EM.register mngr conn+        pure (Right r)++-- We use the maybe to mean that the user needs to wait again.+waitlessAccept :: Fd -> IO (Either (Maybe (AcceptException i)) (Connection,Peer))+waitlessAccept lstn = do+  L.uninterruptibleAccept4 lstn S.sizeofSocketAddressInternet (L.closeOnExec <> L.nonblocking) >>= \case+    Left err -> handleAcceptException err+    Right (sockAddrRequiredSz,sockAddr,acpt) -> if sockAddrRequiredSz == S.sizeofSocketAddressInternet+      then case S.decodeSocketAddressInternet sockAddr of+        Just sockAddrInet -> do+          let !acceptedEndpoint = socketAddressInternetToEndpoint sockAddrInet+          debug ("internalAccepted: successfully accepted connection from " ++ show acceptedEndpoint)+          pure (Right (Connection acpt, acceptedEndpoint))+        Nothing -> do+          _ <- S.uninterruptibleClose acpt+          throwIO $ SocketUnrecoverableException+            moduleSocketStreamIPv4+            SCK.functionWithAccepted+            [SCK.cgetsockname,SCK.nonInternetSocketFamily]+      else do+        _ <- S.uninterruptibleClose acpt+        throwIO $ SocketUnrecoverableException+          moduleSocketStreamIPv4+          SCK.functionWithAccepted+          [SCK.cgetsockname,SCK.socketAddressSize]++gracefulCloseA :: Fd -> IO (Either CloseException ())+gracefulCloseA fd = do+  let !mngr = EM.manager+  !tv <- EM.reader mngr fd+  token0 <- STM.readTVarIO tv+  S.uninterruptibleShutdown fd S.write >>= \case+    -- On Linux (not sure about others), calling shutdown+    -- on the write channel fails with with ENOTCONN if the+    -- write channel is already closed. It is common for this to+    -- happen (e.g. if the peer calls @close@ before the local+    -- process runs gracefulClose, the local operating system+    -- will have already closed the write channel). However,+    -- it does not pose a problem. We just proceed as we would+    -- have since either way we become certain that the write channel+    -- is closed.+    Left err -> if err == eNOTCONN+      then gracefulCloseB tv token0 fd+      else do+        _ <- S.uninterruptibleClose fd+        -- TODO: What about ENOTCONN? Can this happen if the remote+        -- side has already closed the connection?+        throwIO $ SocketUnrecoverableException+          moduleSocketStreamIPv4+          SCK.functionGracefulClose+          [SCK.cshutdown,describeErrorCode err]+    Right _ -> gracefulCloseB tv token0 fd++-- The second part of the shutdown function must call itself recursively+-- since we may receive false read-ready notifications at any time.+gracefulCloseB :: TVar EM.Token -> EM.Token -> Fd -> IO (Either CloseException ())+gracefulCloseB !tv !token0 !fd = do+  !buf <- PM.newByteArray 1+  -- We do not actually want to remove the bytes from the+  -- receive buffer, so we use MSG_PEEK. We are be certain+  -- to send a reset when a CloseException is reported.+  S.uninterruptibleReceiveMutableByteArray fd buf 0 1 S.peek >>= \case+    Left err1 -> if err1 == eWOULDBLOCK || err1 == eAGAIN+      then do+        token1 <- EM.persistentUnreadyAndWait token0 tv+        gracefulCloseB tv token1 fd+      else do+        _ <- S.uninterruptibleClose fd+        -- We treat all @recv@ errors except for the nonblocking+        -- notices as unrecoverable.+        throwIO $ SocketUnrecoverableException+          moduleSocketStreamIPv4+          SCK.functionGracefulClose+          [SCK.crecv,describeErrorCode err1]+    Right sz -> if sz == 0+      then S.uninterruptibleClose fd >>= \case+        Left err -> throwIO $ SocketUnrecoverableException+          moduleSocketStreamIPv4+          SCK.functionGracefulClose+          [SCK.cclose,describeErrorCode err]+        Right _ -> pure (Right ())+      else do+        debug ("Socket.Stream.IPv4.gracefulClose: remote not shutdown B")+        _ <- S.uninterruptibleClose fd+        pure (Left ClosePeerContinuedSending)++-- | Accept a connection on the listener and run the supplied callback+-- on it. This closes the connection when the callback finishes or if+-- an exception is thrown. Since this function blocks the thread until+-- the callback finishes, it is only suitable for stream socket clients+-- that handle one connection at a time. The variant 'forkAcceptedUnmasked'+-- is preferrable for servers that need to handle connections concurrently+-- (most use cases).+withAccepted ::+     Listener+  -> (Either CloseException () -> a -> IO b)+     -- ^ Callback to handle an ungraceful close. +  -> (Connection -> Peer -> IO a)+     -- ^ Callback to consume connection. Must not return the connection.+  -> IO (Either (AcceptException 'Uninterruptible) b)+withAccepted lstn@(Listener lstnFd) consumeException cb = do+  debug ("withAccepted: fd " ++ show lstnFd)+  r <- mask $ \restore -> do+    accept lstn >>= \case+      Left e -> pure (Left e)+      Right (conn, endpoint) -> do+        a <- onException (restore (cb conn endpoint)) (disconnect_ conn)+        e <- disconnect conn+        pure (Right (e,a))+  -- Notice that consumeException gets run in an unmasked context.+  case r of+    Left e -> pure (Left e)+    Right (e,a) -> fmap Right (consumeException e a)++-- | Accept a connection on the listener and run the supplied callback in+-- a new thread. Prefer 'forkAcceptedUnmasked' unless the masking state+-- needs to be preserved for the callback. Such a situation seems unlikely+-- to the author.+forkAccepted ::+     Listener+  -> (Either CloseException () -> a -> IO ())+     -- ^ Callback to handle an ungraceful close. +  -> (Connection -> Peer -> IO a)+     -- ^ Callback to consume connection. Must not return the connection.+  -> IO (Either (AcceptException 'Uninterruptible) ThreadId)+forkAccepted lstn consumeException cb =+  mask $ \restore -> accept lstn >>= \case+    Left e -> pure (Left e)+    Right (conn, endpoint) -> fmap Right $ forkIO $ do+      a <- onException (restore (cb conn endpoint)) (disconnect_ conn)+      e <- disconnect conn+      restore (consumeException e a)++-- | Accept a connection on the listener and run the supplied callback in+-- a new thread. The masking state is set to @Unmasked@ when running the+-- callback. Typically, @a@ is instantiated to @()@.+forkAcceptedUnmasked ::+     Listener+  -> (Either CloseException () -> a -> IO ())+     -- ^ Callback to handle an ungraceful close. +  -> (Connection -> Peer -> IO a)+     -- ^ Callback to consume connection. Must not return the connection.+  -> IO (Either (AcceptException 'Uninterruptible) ThreadId)+forkAcceptedUnmasked lstn consumeException cb =+  mask_ $ accept lstn >>= \case+    Left e -> pure (Left e)+    Right (conn, endpoint) -> fmap Right $ forkIOWithUnmask $ \unmask -> do+      a <- onException (unmask (cb conn endpoint)) (disconnect_ conn)+      e <- disconnect conn+      unmask (consumeException e a)++-- | Accept a connection on the listener and run the supplied callback in+-- a new thread. The masking state is set to @Unmasked@ when running the+-- callback. Typically, @a@ is instantiated to @()@.+--+-- ==== __Discussion__+--+-- Why is the @counter@ argument present? At first, it seems+-- like this is something that the API consumer should implement on+-- top of this library. The argument for the inclusion of the counter+-- is has two parts: (1) clients supporting graceful termination+-- always need these semantics and (2) these semantics cannot+-- be provided without building in @counter@ as a @TVar@.+--+-- 1. Clients supporting graceful termination always need these+--    semantics. To gracefully bring down a server that has been+--    accepting connections with a forking function, an application+--    must wait for all active connections to finish. Since all+--    connections run on separate threads, this can only be+--    accomplished by a concurrency primitive. The straightforward+--    solution is to wrap a counter with either @MVar@ or @TVar@.+--    To complete graceful termination, the application must+--    block until the counter reaches zero.+-- 2. These semantics cannot be provided without building in+--    @counter@ as a @TVar@. When @abandon@ becomes @True@,+--    graceful termination begins. From this point onward, if at+--    any point the counter reaches zero, the application consuming+--    this API will complete termination. Consequently, we need+--    the guarantee that the counter does not increment after+--    the @abandon@ transaction completes. If it did increment+--    in this forbidden way (e.g. if it was incremented some+--    unspecified amount of time after a connection was accepted),+--    there would be a race condition in which the application+--    may terminate without giving the newly accepted connection+--    a chance to finish. Fortunately, @STM@ gives us the+--    composable transaction we need to get this guarantee.+--    To wait for an inbound connection, we use:+--+--    > (isReady,deregister) <- threadWaitReadSTM fd+--    > shouldReceive <- atomically $ do+--    >   readTVar abandon >>= \case+--    >     True -> do+--    >       isReady+--    >       modifyTVar' counter (+1)+--    >       pure True+--    >     False -> pure False+--+--    This eliminates the window for the race condition. If a+--    connection is accepted, the counter is guaranteed to+--    be incremented _before_ @abandon@ becomes @True@.+--    However, this code would be more simple and would perform+--    better if GHC's event manager used TVar instead of STM.+interruptibleForkAcceptedUnmasked ::+     TVar Int+     -- ^ Connection counter. Incremented when connection+     --   is accepted. Decremented after connection is closed.+  -> TVar Bool+     -- ^ Interrupted. If this becomes 'True' give up and return+     --   @'Left' 'AcceptInterrupted'@.+  -> Listener+     -- ^ Connection listener+  -> (Either CloseException () -> a -> IO ())+     -- ^ Callback to handle an ungraceful close. +  -> (Connection -> Peer -> IO a)+     -- ^ Callback to consume connection. Must not return the connection.+  -> IO (Either (AcceptException 'Interruptible) ThreadId)+interruptibleForkAcceptedUnmasked !counter !abandon !lstn consumeException cb =+  mask_ $ interruptibleAcceptCounting counter abandon lstn >>= \case+    Left e -> do+      case e of+        AcceptInterrupted -> pure ()+        _ -> atomically (modifyTVar' counter (subtract 1))+      pure (Left e)+    Right (conn, endpoint) -> fmap Right $ forkIOWithUnmask $ \unmask -> do+      a <- onException+        (unmask (cb conn endpoint))+        (disconnect_ conn *> atomically (modifyTVar' counter (subtract 1)))+      e <- disconnect conn+      r <- unmask (consumeException e a)+      atomically (modifyTVar' counter (subtract 1))+      pure r++-- | Open a socket and connect to a peer. Requirements:+--+-- * This function may only be called in contexts where exceptions+--   are masked.+-- * The caller /must/ be sure to call 'disconnect' or 'disconnect_'+--   on the resulting 'Connection' exactly once to close underlying+--   file descriptor.+-- * The 'Connection' cannot be used after being given as an argument+--   to 'disconnect' or 'disconnect_'.+--+-- Noncompliant use of this function leads to undefined behavior. Prefer+-- 'withConnection' unless you are writing an integration with a+-- resource-management library.+connect ::+     Peer+     -- ^ Remote endpoint+  -> IO (Either (ConnectException ('Internet 'V4) 'Uninterruptible) Connection)+connect !remote = do+  beforeEstablishment remote >>= \case+    Left err -> pure (Left err)+    Right (fd,sockAddr) -> do+      let !mngr = EM.manager+      -- TODO: I believe it is sound to make both the write and+      -- read channels start off as not ready. After all, the+      -- socket is brand new and is not connected to a peer.+      -- Consequently, there's no way we could miss events.+      EM.register mngr fd+      tv <- EM.writer mngr fd+      debug ("connect: about to connect, fd=" ++ show fd)+      token0 <- STM.readTVarIO tv+      S.uninterruptibleConnect fd sockAddr >>= \case+        Left err2 -> if err2 == eINPROGRESS+          then do+            debug ("connect: EINPROGRESS, fd=" ++ show fd)+            -- When we receive EINPROGRESS, we have high confidence+            -- the that the socket is not yet ready (keeping in mind+            -- that it could have somehow become ready right after+            -- C's connect returned). Immidiately diving into+            -- afterEstablishment would result in a syscall to+            -- getsockopt. But what a waste that would be since it+            -- would almost certainly return EAGAIN. So, instead,+            -- we unready the write channel (taking the usual+            -- precautions) and then await readiness.+            token1 <- EM.unreadyAndWait token0 tv+            afterEstablishment tv token1 fd+          else do+            debug ("connect: failed, fd=" ++ show fd)+            S.uninterruptibleErrorlessClose fd+            handleConnectException SCK.functionWithConnection err2+        Right _ -> do+          debug ("connect: succeeded immidiately, fd=" ++ show fd)+          afterEstablishment tv token0 fd++-- | Variant of 'connect' that is interruptible using STM-style interrupts.+-- interruptibleConnect ::+--      TVar Bool+--      -- ^ Interrupted. If this becomes 'True', give up and return+--      --   @'Left' 'AcceptInterrupted'@.+--   -> Peer+--      -- ^ Remote endpoint+--   -> IO (Either (ConnectException 'Interruptible) Connection)+-- interruptibleConnect !abandon !remote = do+--   beforeEstablishment remote >>= \case+--     Left err -> pure (Left err)+--     Right (fd,sockAddr) -> S.uninterruptibleConnect fd sockAddr >>= \case+--       Left err2 -> if err2 == eINPROGRESS+--         then do+--           interruptibleWaitWrite abandon fd >>= \case+--             True -> afterEstablishment fd+--             False -> pure (Left ConnectInterrupted)+--         else do+--           S.uninterruptibleErrorlessClose fd+--           handleConnectException SCK.functionWithConnection err2+--       Right _ -> afterEstablishment fd++-- Internal function called by both connect and interruptibleConnect+-- before the connection is established. Creates the socket and prepares+-- the sockaddr.+beforeEstablishment :: Peer -> IO (Either (ConnectException ('Internet 'V4) i) (Fd,S.SocketAddress))+{-# INLINE beforeEstablishment #-}+beforeEstablishment !remote = do+  debug ("beforeEstablishment: opening connection " ++ show remote)+  e1 <- S.uninterruptibleSocket S.internet+    (L.applySocketFlags (L.closeOnExec <> L.nonblocking) S.stream)+    S.defaultProtocol+  debug ("beforeEstablishment: opened connection " ++ show remote)+  case e1 of+    Left err -> handleSocketConnectException SCK.functionWithConnection err+    Right fd -> do+      let sockAddr = id+            $ S.encodeSocketAddressInternet+            $ endpointToSocketAddressInternet+            $ remote+      pure (Right (fd,sockAddr))++-- Internal function called by both connect and interruptibleConnect+-- after the connection is established.+afterEstablishment ::+     TVar EM.Token -- token tvar +  -> EM.Token -- old token+  -> Fd+  -> IO (Either (ConnectException ('Internet 'V4) i) Connection)+afterEstablishment !tv !oldToken !fd = do+  debug ("afterEstablishment: finished waiting, fd=" ++ show fd)+  e <- S.uninterruptibleGetSocketOption fd+    S.levelSocket S.optionError (intToCInt (PM.sizeOf (undefined :: CInt)))+  case e of+    Left err -> do+      S.uninterruptibleErrorlessClose fd+      throwIO $ SocketUnrecoverableException+        moduleSocketStreamIPv4+        functionWithListener+        [SCK.cgetsockopt,describeErrorCode err]+    Right (sz,S.OptionValue val) -> if sz == intToCInt (PM.sizeOf (undefined :: CInt))+      then+        let err = PM.indexByteArray val 0 :: CInt in+        if | err == 0 -> do+               debug ("afterEstablishment: connection established, fd=" ++ show fd)+               pure (Right (Connection fd))+           | Errno err == eAGAIN || Errno err == eWOULDBLOCK -> do+               debug ("afterEstablishment: not ready yet, unreadying token and waiting, fd=" ++ show fd)+               EM.unready oldToken tv+               newToken <- EM.wait tv+               afterEstablishment tv newToken fd+           | otherwise -> do+               S.uninterruptibleErrorlessClose fd+               handleConnectException SCK.functionWithConnection (Errno err)+      else do+        S.uninterruptibleErrorlessClose fd+        throwIO $ SocketUnrecoverableException+          moduleSocketStreamIPv4+          functionWithListener+          [SCK.cgetsockopt,connectErrorOptionValueSize]++-- | Close a connection gracefully, reporting a 'CloseException' when+-- the connection has to be terminated by sending a TCP reset. This+-- uses a combination of @shutdown@, @recv@, @close@ to detect when+-- resets need to be sent.+disconnect :: Connection -> IO (Either CloseException ())+disconnect (Connection fd) = gracefulCloseA fd++-- | Close a connection. This does not check to see whether or not+-- the connection was brought down gracefully. It just calls @close@+-- and is likely to cause a TCP reset to be sent. It never+-- throws exceptions of any kind (even if @close@ fails).+-- This should only be preferred+-- to 'disconnect' in exception-cleanup contexts where there is+-- already an exception that will be rethrown. See the implementation+-- of 'withConnection' for an example of appropriate use of both+-- 'disconnect' and 'disconnect_'.+disconnect_ :: Connection -> IO ()+disconnect_ (Connection fd) = S.uninterruptibleErrorlessClose fd++-- | Establish a connection to a server.+withConnection ::+     Peer+     -- ^ Remote endpoint+  -> (Either CloseException () -> a -> IO b)+     -- ^ Callback to handle an ungraceful close. +  -> (Connection -> IO a)+     -- ^ Callback to consume connection. Must not return the connection.+  -> IO (Either (ConnectException ('Internet 'V4) 'Uninterruptible) b)+withConnection !remote g f = mask $ \restore -> do+  connect remote >>= \case+    Left err -> pure (Left err)+    Right conn -> do+      a <- onException (restore (f conn)) (disconnect_ conn)+      m <- disconnect conn+      b <- g m a+      pure (Right b)+    +endpointToSocketAddressInternet :: Peer -> S.SocketAddressInternet+endpointToSocketAddressInternet (Peer {address, port}) = S.SocketAddressInternet+  { port = S.hostToNetworkShort port+  , address = S.hostToNetworkLong (getIPv4 address)+  }++socketAddressInternetToEndpoint :: S.SocketAddressInternet -> Peer+socketAddressInternetToEndpoint (S.SocketAddressInternet {address,port}) = Peer+  { address = IPv4 (S.networkToHostLong address)+  , port = S.networkToHostShort port+  }++intToCInt :: Int -> CInt+intToCInt = fromIntegral++moduleSocketStreamIPv4 :: String+moduleSocketStreamIPv4 = "Socket.Stream.IPv4"++functionWithListener :: String+functionWithListener = "withListener"++describeErrorCode :: Errno -> String+describeErrorCode err@(Errno e) = "error code " ++ D.string err ++ " (" ++ show e ++ ")"++-- These are the exceptions that can happen as a result of a+-- nonblocking @connect@ or as a result of subsequently calling+-- @getsockopt@ to get the @SO_ERROR@ after the socket is ready+-- for writes. For increased likelihood of correctness, we do+-- not distinguish between which of these error codes can show+-- up after which of those two calls. This means we are likely+-- testing for some exceptions that cannot occur as a result of+-- a particular call, but doing otherwise would be fraught with+-- uncertainty.+handleConnectException :: String -> Errno -> IO (Either (ConnectException ('Internet 'V4) i) a)+handleConnectException func e+  | e == eACCES = pure (Left ConnectFirewalled)+  | e == ePERM = pure (Left ConnectFirewalled)+  | e == eNETUNREACH = pure (Left ConnectNetworkUnreachable)+  | e == eHOSTUNREACH = pure (Left ConnectHostUnreachable)+  | e == eCONNREFUSED = pure (Left ConnectRefused)+  | e == eADDRNOTAVAIL = pure (Left ConnectEphemeralPortsExhausted)+  | e == eTIMEDOUT = pure (Left ConnectTimeout)+  | otherwise = throwIO $ SocketUnrecoverableException+      moduleSocketStreamIPv4+      func+      [describeErrorCode e]++-- These are the exceptions that can happen as a result+-- of calling @socket@ with the intent of using the socket+-- to open a connection (not listen for inbound connections).+-- Since this library packs @socket@ and @connect@ into a+-- single function, we have to have a common type for+-- exceptions.+handleSocketConnectException ::+     String+  -> Errno+  -> IO (Either (ConnectException ('Internet 'V4) i) a)+handleSocketConnectException func e+  | e == eMFILE = pure (Left ConnectFileDescriptorLimit)+  | e == eNFILE = pure (Left ConnectFileDescriptorLimit)+  | otherwise = throwIO $ SocketUnrecoverableException+      moduleSocketStreamIPv4+      func+      [describeErrorCode e]++-- These are the exceptions that can happen as a result+-- of calling @socket@ with the intent of using the socket+-- to listen for inbound connections.+handleSocketListenException :: String -> Errno -> IO (Either SocketException a)+handleSocketListenException func e+  | e == eMFILE = pure (Left SocketFileDescriptorLimit)+  | e == eNFILE = pure (Left SocketFileDescriptorLimit)+  | otherwise = throwIO $ SocketUnrecoverableException+      moduleSocketStreamIPv4+      func+      [describeErrorCode e]++-- These are the exceptions that can happen as a result+-- of calling @bind@ with the intent of using the socket+-- to listen for inbound connections. This is also used+-- to clean up the error codes of @listen@. The two can+-- report some of the same error codes, and those happen+-- to be the error codes we are interested in.+--+-- NB: EACCES only happens on @bind@, not on @listen@.+handleBindListenException ::+     Word16+  -> Errno+  -> IO (Either SocketException a)+handleBindListenException !thePort !e+  | e == eACCES = pure (Left SocketPermissionDenied)+  | e == eADDRINUSE = if thePort == 0+      then pure (Left SocketEphemeralPortsExhausted)+      else pure (Left SocketAddressInUse)+  | otherwise = die+      ("Socket.Stream.IPv4.bindListen: " ++ describeErrorCode e)++-- These are the exceptions that can happen as a result+-- of calling @socket@ with the intent of using the socket+-- to open a connection (not listen for inbound connections).+handleAcceptException :: Errno -> IO (Either (Maybe (AcceptException i)) a)+handleAcceptException e+  | e == eAGAIN = pure (Left Nothing)+  | e == eWOULDBLOCK = pure (Left Nothing)+  | e == eCONNABORTED = pure (Left (Just AcceptConnectionAborted))+  | e == eMFILE = pure (Left (Just AcceptFileDescriptorLimit))+  | e == eNFILE = pure (Left (Just AcceptFileDescriptorLimit))+  | e == ePERM = pure (Left (Just AcceptFirewalled))+  | otherwise = die ("Socket.Stream.IPv4.accept: " ++ describeErrorCode e)++connectErrorOptionValueSize :: String+connectErrorOptionValueSize = "incorrectly sized value of SO_ERROR option"++{- $bracketed+ +Bracketed resource-acquisition functions ensure that a network socket+(represented by 'Listener' or 'Connection') gets closed if an exception+happens. This prevents file descriptor leaks. Note that functions in+this library generally do not throw exceptions. That is to say that the+exceptions these bracketed functions encounter will be the result of the+end user calling 'throwIO' inside the callback or calling 'throwTo' from+another thread.++-}  {- $unbracketed
+ src/Socket/Stream/Interruptible/Addr.hs view
@@ -0,0 +1,75 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}++module Socket.Stream.Interruptible.Addr+  ( send+  , receiveExactly+  , receiveOnce+  , receiveBetween+  ) where++import Data.Bytes.Types (UnmanagedBytes(..))+import Data.Primitive.Addr (Addr)+import Control.Concurrent.STM (TVar)+import Socket.Stream (Connection,ReceiveException,SendException)+import Socket (Interruptibility(Interruptible))++import qualified Socket.Stream.Interruptible.Addr.Send as Send+import qualified Socket.Stream.Interruptible.Addr.Receive as Receive++-- | Send an exact number of bytes starting from a given address. If needed,+--   this calls POSIX @send@ repeatedly until the requested number of bytes+--   has been sent.+send ::+     TVar Bool +     -- ^ Interrupt. On 'True', give up and return @'Left' 'SendInterrupted'@.+  -> Connection -- ^ Connection+  -> Addr -- ^ Start of buffer+  -> Int -- ^ Number of bytes to send+  -> IO (Either (SendException 'Interruptible) ())+{-# inline send #-}+send !tv !conn !addr !len = Send.send tv conn (UnmanagedBytes addr len)++-- | Receive the requested number of bytes into memory beginning at+--   the specified address. If needed, this may call @recv@ repeatedly until+--   the requested number of bytes have been received.+receiveExactly ::+     TVar Bool +     -- ^ Interrupt. On 'True', give up and return @'Left' 'ReceiveInterrupted'@.+  -> Connection -- ^ Connection+  -> Addr -- ^ Start of buffer+  -> Int -- ^ Exact number of bytes to receive+  -> IO (Either (ReceiveException 'Interruptible) ())+{-# inline receiveExactly #-}+receiveExactly !tv !conn !addr !len =+  Receive.receiveExactly tv conn (UnmanagedBytes addr len)++-- | Receive at most the specified number of bytes. This+-- only makes multiple calls to POSIX @recv@ if EAGAIN is returned. It makes at+-- most one @recv@ call that successfully fills the buffer.+receiveOnce ::+     TVar Bool +     -- ^ Interrupt. On 'True', give up and return @'Left' 'ReceiveInterrupted'@.+  -> Connection -- ^ Connection+  -> Addr -- ^ Start of buffer+  -> Int -- ^ Maximum number of bytes to receive+  -> IO (Either (ReceiveException 'Interruptible) Int)+{-# inline receiveOnce #-}+receiveOnce tv conn addr len =+  Receive.receiveOnce tv conn (UnmanagedBytes addr len)++-- | Receive a number of bytes that is between the inclusive lower and+--   upper bounds. If needed, this may call @recv@ repeatedly until the+--   minimum requested number of bytes have been received.+receiveBetween ::+     TVar Bool +     -- ^ Interrupt. On 'True', give up and return @'Left' 'ReceiveInterrupted'@.+  -> Connection -- ^ Connection+  -> Addr -- ^ Start of buffer+  -> Int+     -- ^ Minimum number of bytes to receive+  -> Int -- ^ Maximum number of bytes to receive+  -> IO (Either (ReceiveException 'Interruptible) Int)+{-# inline receiveBetween #-}+receiveBetween tv conn addr minLen maxLen =+  Receive.receiveBetween tv conn (UnmanagedBytes addr maxLen) minLen
+ src/Socket/Stream/Interruptible/ByteString.hs view
@@ -0,0 +1,97 @@+{-# language BangPatterns #-}+{-# language LambdaCase #-}+{-# language DataKinds #-}+{-# language MagicHash #-}++module Socket.Stream.Interruptible.ByteString+  ( send+  , receiveExactly+  , receiveOnce+  , receiveBetween+  ) where++import Data.ByteString.Unsafe (unsafeUseAsCStringLen)+import Data.ByteString.Internal (ByteString(PS))+import Data.Bytes.Types (UnmanagedBytes(..))+import Data.Primitive.Addr (Addr(..))+import Data.Primitive (MutableByteArray(..))+import Data.Bytes.Types (MutableBytes(..))+import Control.Concurrent.STM (TVar)+import GHC.Exts (Ptr(Ptr),RealWorld,byteArrayContents#,unsafeCoerce#)+import GHC.ForeignPtr (ForeignPtr(ForeignPtr),ForeignPtrContents(PlainPtr))+import Socket.Stream (Connection,ReceiveException,SendException)+import Socket (Interruptibility(Interruptible))++import qualified Data.Primitive as PM+import qualified Socket.Stream.Interruptible.Addr.Send as Send+import qualified Socket.Stream.Interruptible.MutableBytes.Receive as Receive++-- | Send a slice of a buffer. If needed, this calls POSIX @send@ repeatedly+--   until the entire contents of the buffer slice have been sent.+send ::+     TVar Bool +     -- ^ Interrupt. On 'True', give up and return @'Left' 'SendInterrupted'@.+  -> Connection -- ^ Connection+  -> ByteString -- ^ Slice of a buffer+  -> IO (Either (SendException 'Interruptible) ())+{-# inline send #-}+send !tv !conn !bs = unsafeUseAsCStringLen bs+  (\(Ptr addr#,len) -> Send.send tv conn (UnmanagedBytes (Addr addr#) len))++-- | Receive a number of bytes exactly equal to the length of the+--   buffer slice. If needed, this may call @recv@ repeatedly until+--   the requested number of bytes have been received.+receiveExactly ::+     TVar Bool +     -- ^ Interrupt. On 'True', give up and return @'Left' 'ReceiveInterrupted'@.+  -> Connection -- ^ Connection+  -> Int -- ^ Exact number of bytes to receive+  -> IO (Either (ReceiveException 'Interruptible) ByteString)+{-# inline receiveExactly #-}+receiveExactly !tv !conn !n = do+  !marr <- PM.newPinnedByteArray n+  Receive.receiveExactly tv conn (MutableBytes marr 0 n) >>= \case+    Left err -> pure (Left err)+    Right _ -> pure $! Right $! fromManaged marr 0 n++-- | Receive at most the specified number of bytes. This+-- only makes multiple calls to POSIX @recv@ if EAGAIN is returned. It makes at+-- most one @recv@ call that successfully fills the buffer.+receiveOnce ::+     TVar Bool +     -- ^ Interrupt. On 'True', give up and return @'Left' 'ReceiveInterrupted'@.+  -> Connection -- ^ Connection+  -> Int -- ^ Maximum number of bytes to receive+  -> IO (Either (ReceiveException 'Interruptible) ByteString)+{-# inline receiveOnce #-}+receiveOnce !tv !conn !n = do+  !marr0 <- PM.newPinnedByteArray n+  Receive.receiveOnce tv conn (MutableBytes marr0 0 n) >>= \case+    Left err -> pure (Left err)+    Right sz -> do+      marr1 <- PM.resizeMutableByteArray marr0 sz+      pure $! Right $! fromManaged marr1 0 sz++-- | Receive a number of bytes that is between the inclusive lower and+--   upper bounds. If needed, this may call @recv@ repeatedly until the+--   minimum requested number of bytes have been received.+receiveBetween ::+     TVar Bool +     -- ^ Interrupt. On 'True', give up and return @'Left' 'ReceiveInterrupted'@.+  -> Connection -- ^ Connection+  -> Int -- ^ Minimum number of bytes to receive+  -> Int -- ^ Maximum number of bytes to receive+  -> IO (Either (ReceiveException 'Interruptible) ByteString)+{-# inline receiveBetween #-}+receiveBetween !tv !conn !minLen !maxLen = do+  !marr0 <- PM.newPinnedByteArray maxLen+  Receive.receiveBetween tv conn (MutableBytes marr0 0 maxLen) minLen >>= \case+    Left err -> pure (Left err)+    Right sz -> do+      marr1 <- PM.resizeMutableByteArray marr0 sz+      pure $! Right $! fromManaged marr1 0 sz++fromManaged :: MutableByteArray RealWorld -> Int -> Int -> ByteString+{-# inline fromManaged #-}+fromManaged (MutableByteArray marr#) off len =+  PS (ForeignPtr (byteArrayContents# (unsafeCoerce# marr#)) (PlainPtr marr#)) off len
+ src/Socket/Stream/Interruptible/Bytes.hs view
@@ -0,0 +1,88 @@+{-# language BangPatterns #-}+{-# language LambdaCase #-}+{-# language DataKinds #-}++module Socket.Stream.Interruptible.Bytes+  ( send+  , receiveExactly+  , receiveOnce+  , receiveBetween+  ) where++import Data.Primitive (ByteArray)+import Data.Bytes.Types (MutableBytes(..),Bytes(..))+import Control.Concurrent.STM (TVar)+import Socket.Stream (Connection,ReceiveException,SendException)+import Socket (Interruptibility(Interruptible))++import qualified Data.Primitive as PM+import qualified Socket.Stream.Interruptible.Bytes.Send as Send+import qualified Socket.Stream.Interruptible.MutableBytes.Receive as Receive++-- | Send a slice of a buffer. If needed, this calls POSIX @send@ repeatedly+--   until the entire contents of the buffer slice have been sent.+send ::+     TVar Bool +     -- ^ Interrupt. On 'True', give up and return @'Left' 'SendInterrupted'@.+  -> Connection -- ^ Connection+  -> Bytes -- ^ Slice of a buffer+  -> IO (Either (SendException 'Interruptible) ())+{-# inline send #-}+send = Send.send++-- | Receive a number of bytes exactly equal to the length of the+--   buffer slice. If needed, this may call @recv@ repeatedly until+--   the requested number of bytes have been received.+receiveExactly ::+     TVar Bool +     -- ^ Interrupt. On 'True', give up and return @'Left' 'ReceiveInterrupted'@.+  -> Connection -- ^ Connection+  -> Int -- ^ Exact number of bytes to receive+  -> IO (Either (ReceiveException 'Interruptible) ByteArray)+{-# inline receiveExactly #-}+receiveExactly !tv !conn !n = do+  !marr <- PM.newByteArray n+  Receive.receiveExactly tv conn (MutableBytes marr 0 n) >>= \case+    Left err -> pure (Left err)+    Right _ -> do+      !arr <- PM.unsafeFreezeByteArray marr+      pure $! Right $! arr++-- | Receive at most the specified number of bytes. This+-- only makes multiple calls to POSIX @recv@ if EAGAIN is returned. It makes at+-- most one @recv@ call that successfully fills the buffer.+receiveOnce ::+     TVar Bool +     -- ^ Interrupt. On 'True', give up and return @'Left' 'ReceiveInterrupted'@.+  -> Connection -- ^ Connection+  -> Int -- ^ Maximum number of bytes to receive+  -> IO (Either (ReceiveException 'Interruptible) ByteArray)+{-# inline receiveOnce #-}+receiveOnce !tv !conn !n = do+  !marr0 <- PM.newByteArray n+  Receive.receiveOnce tv conn (MutableBytes marr0 0 n) >>= \case+    Left err -> pure (Left err)+    Right sz -> do+      marr1 <- PM.resizeMutableByteArray marr0 sz+      !arr <- PM.unsafeFreezeByteArray marr1+      pure $! Right $! arr++-- | Receive a number of bytes that is between the inclusive lower and+--   upper bounds. If needed, this may call @recv@ repeatedly until the+--   minimum requested number of bytes have been received.+receiveBetween ::+     TVar Bool +     -- ^ Interrupt. On 'True', give up and return @'Left' 'ReceiveInterrupted'@.+  -> Connection -- ^ Connection+  -> Int -- ^ Minimum number of bytes to receive+  -> Int -- ^ Maximum number of bytes to receive+  -> IO (Either (ReceiveException 'Interruptible) ByteArray)+{-# inline receiveBetween #-}+receiveBetween !tv !conn !minLen !maxLen = do+  !marr0 <- PM.newByteArray maxLen+  Receive.receiveBetween tv conn (MutableBytes marr0 0 maxLen) minLen >>= \case+    Left err -> pure (Left err)+    Right sz -> do+      marr1 <- PM.resizeMutableByteArray marr0 sz+      !arr <- PM.unsafeFreezeByteArray marr1+      pure $! Right $! arr
+ src/Socket/Stream/Interruptible/Hybrid.hs view
@@ -0,0 +1,23 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}++module Socket.Stream.Interruptible.Hybrid+  ( sendMutableBytesUnmanagedBytes+  ) where++import Control.Concurrent.STM (TVar)+import Data.Bytes.Types (MutableBytes,UnmanagedBytes)+import GHC.Exts (RealWorld)+import Socket (Interruptibility(Interruptible))+import Socket.Stream (Connection,SendException)++import qualified Socket.Stream.Interruptible.MutableBytes.Addr.Send as MBA++sendMutableBytesUnmanagedBytes ::+     TVar Bool+     -- ^ Interrupt. On 'True', give up and return @'Left' 'SendInterrupted'@.+  -> Connection -- ^ Connection+  -> MutableBytes RealWorld -- ^ First payload+  -> UnmanagedBytes -- ^ Second payload+  -> IO (Either (SendException 'Interruptible) ())+sendMutableBytesUnmanagedBytes = MBA.sendBoth
+ src/Socket/Stream/Interruptible/MutableBytes.hs view
@@ -0,0 +1,81 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}++module Socket.Stream.Interruptible.MutableBytes+  ( send+  , sendOnce+  , receiveExactly+  , receiveOnce+  , receiveBetween+  ) where++import Data.Bytes.Types (MutableBytes)+import GHC.Exts (RealWorld)+import Control.Concurrent.STM (TVar)+import Socket.Stream (Connection,ReceiveException,SendException)+import Socket (Interruptibility(Interruptible))++import qualified Socket.Stream.Interruptible.MutableBytes.Send as Send+import qualified Socket.Stream.Interruptible.MutableBytes.Receive as Receive++-- | Send a slice of a buffer. If needed, this calls POSIX @send@ repeatedly+--   until the entire contents of the buffer slice have been sent.+send ::+     TVar Bool +     -- ^ Interrupt. On 'True', give up and return @'Left' 'SendInterrupted'@.+  -> Connection -- ^ Connection+  -> MutableBytes RealWorld -- ^ Slice of a buffer+  -> IO (Either (SendException 'Interruptible) ())+{-# inline send #-}+send = Send.send++-- | Send as much of the buffer slice as there is space for in the+--   TCP send buffer. Returns the number of bytes sent.+sendOnce ::+     TVar Bool +     -- ^ Interrupt. On 'True', give up and return @'Left' 'SendInterrupted'@.+  -> Connection -- ^ Connection+  -> MutableBytes RealWorld -- ^ Slice of a buffer+  -> IO (Either (SendException 'Interruptible) Int)+{-# inline sendOnce #-}+sendOnce = Send.sendOnce++-- | Receive a number of bytes exactly equal to the length of the+--   buffer slice. If needed, this may call @recv@ repeatedly until+--   the requested number of bytes have been received.+receiveExactly ::+     TVar Bool +     -- ^ Interrupt. On 'True', give up and return @'Left' 'ReceiveInterrupted'@.+  -> Connection -- ^ Connection+  -> MutableBytes RealWorld -- ^ Slice of a buffer+  -> IO (Either (ReceiveException 'Interruptible) ())+{-# inline receiveExactly #-}+receiveExactly = Receive.receiveExactly++-- | Receive a number of bytes exactly equal to the length of the slice. This+-- only makes multiple calls to POSIX @recv@ if EAGAIN is returned. It makes at+-- most one @recv@ call that successfully fills the buffer.+receiveOnce ::+     TVar Bool +     -- ^ Interrupt. On 'True', give up and return @'Left' 'ReceiveInterrupted'@.+  -> Connection -- ^ Connection+  -> MutableBytes RealWorld -- ^ Slice of a buffer+  -> IO (Either (ReceiveException 'Interruptible) Int)+{-# inline receiveOnce #-}+receiveOnce = Receive.receiveOnce++-- | Receive a number of bytes that is at least the minimum size+--   and is at most the length of the slice. If needed, this may+--   call @recv@ repeatedly until the minimum requested number of+--   bytes have been received.+receiveBetween ::+     TVar Bool +     -- ^ Interrupt. On 'True', give up and return @'Left' 'ReceiveInterrupted'@.+  -> Connection -- ^ Connection+  -> MutableBytes RealWorld -- ^ Slice of a buffer+  -> Int+     -- ^ Minimum number of bytes to receive, must be less than or equal+     --   to the length of the slice.+  -> IO (Either (ReceiveException 'Interruptible) Int)+{-# inline receiveBetween #-}+receiveBetween = Receive.receiveBetween
+ src/Socket/Stream/Uninterruptible/Addr.hs view
@@ -0,0 +1,68 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}+{-# language MagicHash #-}++module Socket.Stream.Uninterruptible.Addr+  ( send+  , receiveExactly+  , receiveOnce+  , receiveBetween+  ) where++import Data.Bytes.Types (UnmanagedBytes(..))+import Data.Primitive.Addr (Addr)+import GHC.Exts (proxy#)+import Socket.Stream (Connection,ReceiveException,SendException)+import Socket (Interruptibility(Uninterruptible))++import qualified Socket.Stream.Uninterruptible.Addr.Send as Send+import qualified Socket.Stream.Uninterruptible.Addr.Receive as Receive++-- | Send an exact number of bytes starting from a given address. If needed,+--   this calls POSIX @send@ repeatedly until the requested number of bytes+--   has been sent.+send ::+     Connection -- ^ Connection+  -> Addr -- ^ Start of buffer+  -> Int -- ^ Number of bytes to send+  -> IO (Either (SendException 'Uninterruptible) ())+{-# inline send #-}+send !conn !addr !len = Send.send proxy# conn (UnmanagedBytes addr len)++-- | Receive the requested number of bytes into memory beginning at+--   the specified address. If needed, this may call @recv@ repeatedly until+--   the requested number of bytes have been received.+receiveExactly ::+     Connection -- ^ Connection+  -> Addr -- ^ Start of buffer+  -> Int -- ^ Exact number of bytes to receive+  -> IO (Either (ReceiveException 'Uninterruptible) ())+{-# inline receiveExactly #-}+receiveExactly !conn !addr !len =+  Receive.receiveExactly proxy# conn (UnmanagedBytes addr len)++-- | Receive at most the specified number of bytes. This+-- only makes multiple calls to POSIX @recv@ if EAGAIN is returned. It makes at+-- most one @recv@ call that successfully fills the buffer.+receiveOnce ::+     Connection -- ^ Connection+  -> Addr -- ^ Start of buffer+  -> Int -- ^ Maximum number of bytes to receive+  -> IO (Either (ReceiveException 'Uninterruptible) Int)+{-# inline receiveOnce #-}+receiveOnce conn addr len =+  Receive.receiveOnce proxy# conn (UnmanagedBytes addr len)++-- | Receive a number of bytes that is between the inclusive lower and+--   upper bounds. If needed, this may call @recv@ repeatedly until the+--   minimum requested number of bytes have been received.+receiveBetween ::+     Connection -- ^ Connection+  -> Addr -- ^ Start of buffer+  -> Int+     -- ^ Minimum number of bytes to receive+  -> Int -- ^ Maximum number of bytes to receive+  -> IO (Either (ReceiveException 'Uninterruptible) Int)+{-# inline receiveBetween #-}+receiveBetween conn addr minLen maxLen =+  Receive.receiveBetween proxy# conn (UnmanagedBytes addr maxLen) minLen
+ src/Socket/Stream/Uninterruptible/ByteString.hs view
@@ -0,0 +1,89 @@+{-# language BangPatterns #-}+{-# language LambdaCase #-}+{-# language DataKinds #-}+{-# language MagicHash #-}++module Socket.Stream.Uninterruptible.ByteString+  ( send+  , receiveExactly+  , receiveOnce+  , receiveBetween+  ) where++import Data.Bytes.Types (UnmanagedBytes(..))+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)+import Data.ByteString.Internal (ByteString(PS))+import Data.Primitive.Addr (Addr(..))+import Data.Primitive (MutableByteArray(..))+import Data.Bytes.Types (MutableBytes(..))+import GHC.Exts (Ptr(Ptr),RealWorld,byteArrayContents#,unsafeCoerce#,proxy#)+import GHC.ForeignPtr (ForeignPtr(ForeignPtr),ForeignPtrContents(PlainPtr))+import Socket.Stream (Connection,ReceiveException,SendException)+import Socket (Interruptibility(Uninterruptible))++import qualified Data.Primitive as PM+import qualified Socket.Stream.Uninterruptible.Addr.Send as Send+import qualified Socket.Stream.Uninterruptible.MutableBytes.Receive as Receive++-- | Send a slice of a buffer. If needed, this calls POSIX @send@ repeatedly+--   until the entire contents of the buffer slice have been sent.+send ::+     Connection -- ^ Connection+  -> ByteString -- ^ Slice of a buffer+  -> IO (Either (SendException 'Uninterruptible) ())+{-# inline send #-}+send !conn !bs = unsafeUseAsCStringLen bs+  (\(Ptr addr#,len) -> Send.send proxy# conn (UnmanagedBytes (Addr addr#) len))++-- | Receive a number of bytes exactly equal to the length of the+--   buffer slice. If needed, this may call @recv@ repeatedly until+--   the requested number of bytes have been received.+receiveExactly ::+     Connection -- ^ Connection+  -> Int -- ^ Exact number of bytes to receive+  -> IO (Either (ReceiveException 'Uninterruptible) ByteString)+{-# inline receiveExactly #-}+receiveExactly !conn !n = do+  !marr <- PM.newPinnedByteArray n+  Receive.receiveExactly proxy# conn (MutableBytes marr 0 n) >>= \case+    Left err -> pure (Left err)+    Right _ -> pure $! Right $! fromManaged marr 0 n++-- | Receive at most the specified number of bytes. This+-- only makes multiple calls to POSIX @recv@ if EAGAIN is returned. It makes at+-- most one @recv@ call that successfully fills the buffer.+receiveOnce ::+     Connection -- ^ Connection+  -> Int -- ^ Maximum number of bytes to receive+  -> IO (Either (ReceiveException 'Uninterruptible) ByteString)+{-# inline receiveOnce #-}+receiveOnce !conn !n = do+  !marr0 <- PM.newPinnedByteArray n+  Receive.receiveOnce proxy# conn (MutableBytes marr0 0 n) >>= \case+    Left err -> pure (Left err)+    Right sz -> do+      marr1 <- PM.resizeMutableByteArray marr0 sz+      pure $! Right $! fromManaged marr1 0 sz++-- | Receive a number of bytes that is between the inclusive lower and+--   upper bounds. If needed, this may call @recv@ repeatedly until the+--   minimum requested number of bytes have been received.+receiveBetween ::+     Connection -- ^ Connection+  -> Int -- ^ Minimum number of bytes to receive+  -> Int -- ^ Maximum number of bytes to receive+  -> IO (Either (ReceiveException 'Uninterruptible) ByteString)+{-# inline receiveBetween #-}+receiveBetween !conn !minLen !maxLen = do+  !marr0 <- PM.newPinnedByteArray maxLen+  Receive.receiveBetween proxy# conn (MutableBytes marr0 0 maxLen) minLen >>= \case+    Left err -> pure (Left err)+    Right sz -> do+      marr1 <- PM.resizeMutableByteArray marr0 sz+      pure $! Right $! fromManaged marr1 0 sz++fromManaged :: MutableByteArray RealWorld -> Int -> Int -> ByteString+{-# inline fromManaged #-}+fromManaged (MutableByteArray marr#) off len =+  PS (ForeignPtr (byteArrayContents# (unsafeCoerce# marr#)) (PlainPtr marr#)) off len+
+ src/Socket/Stream/Uninterruptible/Bytes.hs view
@@ -0,0 +1,88 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}+{-# language LambdaCase #-}+{-# language MagicHash #-}++-- | Communicate over a connection using immutable byte arrays.+-- Reception functions return 'ByteArray' instead of 'Bytes' since+-- this result always takes up the entirity of a 'ByteArray'. The+-- 'Bytes' would have redundant information since the offset would+-- be zero and the length would be the length of the 'ByteArray'+-- payload.+module Socket.Stream.Uninterruptible.Bytes+  ( send+  , receiveExactly+  , receiveOnce+  , receiveBetween+  ) where++import Data.Primitive (ByteArray)+import Data.Bytes.Types (MutableBytes(..),Bytes(..))+import GHC.Exts (proxy#)+import Socket.Stream (Connection,ReceiveException,SendException)+import Socket (Interruptibility(Uninterruptible))++import qualified Data.Primitive as PM+import qualified Socket.Stream.Uninterruptible.Bytes.Send as Send+import qualified Socket.Stream.Uninterruptible.MutableBytes.Receive as Receive++-- | Send a slice of a buffer. If needed, this calls POSIX @send@ repeatedly+--   until the entire contents of the buffer slice have been sent.+send ::+     Connection -- ^ Connection+  -> Bytes -- ^ Slice of a buffer+  -> IO (Either (SendException 'Uninterruptible) ())+{-# inline send #-}+send = Send.send proxy#++-- | Receive a number of bytes exactly equal to the length of the+--   buffer slice. If needed, this may call @recv@ repeatedly until+--   the requested number of bytes have been received.+receiveExactly ::+     Connection -- ^ Connection+  -> Int -- ^ Exact number of bytes to receive+  -> IO (Either (ReceiveException 'Uninterruptible) ByteArray)+{-# inline receiveExactly #-}+receiveExactly !conn !n = do+  !marr <- PM.newByteArray n+  Receive.receiveExactly proxy# conn (MutableBytes marr 0 n) >>= \case+    Left err -> pure (Left err)+    Right _ -> do+      !arr <- PM.unsafeFreezeByteArray marr+      pure $! Right $! arr++-- | Receive at most the specified number of bytes. This+-- only makes multiple calls to POSIX @recv@ if EAGAIN is returned. It makes at+-- most one @recv@ call that successfully fills the buffer.+receiveOnce ::+     Connection -- ^ Connection+  -> Int -- ^ Maximum number of bytes to receive+  -> IO (Either (ReceiveException 'Uninterruptible) ByteArray)+{-# inline receiveOnce #-}+receiveOnce !conn !n = do+  !marr0 <- PM.newByteArray n+  Receive.receiveOnce proxy# conn (MutableBytes marr0 0 n) >>= \case+    Left err -> pure (Left err)+    Right sz -> do+      marr1 <- PM.resizeMutableByteArray marr0 sz+      !arr <- PM.unsafeFreezeByteArray marr1+      pure $! Right $! arr++-- | Receive a number of bytes that is between the inclusive lower and+--   upper bounds. If needed, this may call @recv@ repeatedly until the+--   minimum requested number of bytes have been received.+receiveBetween ::+     Connection -- ^ Connection+  -> Int -- ^ Minimum number of bytes to receive+  -> Int -- ^ Maximum number of bytes to receive+  -> IO (Either (ReceiveException 'Uninterruptible) ByteArray)+{-# inline receiveBetween #-}+receiveBetween !conn !minLen !maxLen = do+  !marr0 <- PM.newByteArray maxLen+  Receive.receiveBetween proxy# conn (MutableBytes marr0 0 maxLen) minLen >>= \case+    Left err -> pure (Left err)+    Right sz -> do+      marr1 <- PM.resizeMutableByteArray marr0 sz+      !arr <- PM.unsafeFreezeByteArray marr1+      pure $! Right $! arr+
+ src/Socket/Stream/Uninterruptible/Hybrid.hs view
@@ -0,0 +1,22 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}+{-# language MagicHash #-}++module Socket.Stream.Uninterruptible.Hybrid+  ( sendMutableBytesUnmanagedBytes+  ) where++import Data.Bytes.Types (MutableBytes,UnmanagedBytes)+import GHC.Exts (RealWorld,proxy#)+import Socket (Interruptibility(Uninterruptible))+import Socket.Stream (Connection,SendException)++import qualified Socket.Stream.Uninterruptible.MutableBytes.Addr.Send as MBA++sendMutableBytesUnmanagedBytes ::+     Connection -- ^ Connection+  -> MutableBytes RealWorld -- ^ First payload+  -> UnmanagedBytes -- ^ Second payload+  -> IO (Either (SendException 'Uninterruptible) ())+sendMutableBytesUnmanagedBytes = MBA.sendBoth proxy#+
+ src/Socket/Stream/Uninterruptible/MutableBytes.hs view
@@ -0,0 +1,61 @@+{-# language BangPatterns #-}+{-# language DataKinds #-}+{-# language MagicHash #-}++module Socket.Stream.Uninterruptible.MutableBytes+  ( send+  , receiveExactly+  , receiveOnce+  , receiveBetween+  ) where++import Data.Bytes.Types (MutableBytes)+import GHC.Exts (RealWorld,proxy#)+import Socket.Stream (Connection,ReceiveException,SendException)+import Socket (Interruptibility(Uninterruptible))++import qualified Socket.Stream.Uninterruptible.MutableBytes.Send as Send+import qualified Socket.Stream.Uninterruptible.MutableBytes.Receive as Receive++-- | Send a slice of a buffer. If needed, this calls POSIX @send@ repeatedly+--   until the entire contents of the buffer slice have been sent.+send ::+     Connection -- ^ Connection+  -> MutableBytes RealWorld -- ^ Slice of a buffer+  -> IO (Either (SendException 'Uninterruptible) ())+{-# inline send #-}+send = Send.send proxy#++-- | Receive a number of bytes exactly equal to the length of the+--   buffer slice. If needed, this may call @recv@ repeatedly until+--   the requested number of bytes have been received.+receiveExactly ::+     Connection -- ^ Connection+  -> MutableBytes RealWorld -- ^ Slice of a buffer+  -> IO (Either (ReceiveException 'Uninterruptible) ())+{-# inline receiveExactly #-}+receiveExactly = Receive.receiveExactly proxy#++-- | Receive a number of bytes exactly equal to the length of the slice. This+-- only makes multiple calls to POSIX @recv@ if EAGAIN is returned. It makes at+-- most one @recv@ call that successfully fills the buffer.+receiveOnce ::+     Connection -- ^ Connection+  -> MutableBytes RealWorld -- ^ Slice of a buffer+  -> IO (Either (ReceiveException 'Uninterruptible) Int)+{-# inline receiveOnce #-}+receiveOnce = Receive.receiveOnce proxy#++-- | Receive a number of bytes that is at least the minimum size+--   and is at most the length of the slice. If needed, this may+--   call @recv@ repeatedly until the minimum requested number of+--   bytes have been received.+receiveBetween ::+     Connection -- ^ Connection+  -> MutableBytes RealWorld -- ^ Slice of a buffer+  -> Int+     -- ^ Minimum number of bytes to receive, must be less than or equal+     --   to the length of the slice.+  -> IO (Either (ReceiveException 'Uninterruptible) Int)+{-# inline receiveBetween #-}+receiveBetween = Receive.receiveBetween proxy#
test/Main.hs view
@@ -1,20 +1,27 @@ {-# language BangPatterns #-}-{-# language DerivingStrategies #-} {-# language DeriveAnyClass #-}+{-# language DerivingStrategies #-} {-# language LambdaCase #-}+{-# language MagicHash #-} {-# language ScopedTypeVariables #-} {-# language TypeFamilies #-}+{-# language UnboxedTuples #-} +import Control.Applicative (liftA3)+import Control.Concurrent (forkIO) import Control.Concurrent.Async (concurrently) import Control.Monad (replicateM_) import Control.Exception (Exception) import Control.Exception (throwIO)+import Control.Monad (when) import Control.Monad.ST (runST)-import Data.Bool (bool) import Data.ByteString (ByteString)-import Data.Primitive (ByteArray)+import Data.Bytes.Types (Bytes(..),MutableBytes(..),UnmanagedBytes(..))+import Data.Primitive (ByteArray,MutableByteArray(..))+import Data.Primitive.Addr (Addr(..)) import Data.Word (Word16,Word8) import GHC.Exts (RealWorld)+import GHC.IO (IO(..)) import System.Exit (exitFailure) import System.IO (stderr,hPutStrLn) import Test.Tasty@@ -22,39 +29,37 @@  import qualified Data.ByteString as B import qualified Data.Primitive as PM+import qualified Data.Primitive.Unlifted.Array as PM import qualified Data.Primitive.MVar as PM import qualified GHC.Exts as E import qualified Net.IPv4 as IPv4-import qualified Socket.Datagram.IPv4.Spoof as DIS-import qualified Socket.Datagram.IPv4.Undestined as DIU+import qualified Socket.Datagram.IPv4.Unconnected as DIU+import qualified Socket.Datagram.IPv4.Connected as DIC+import qualified Socket.Datagram.Uninterruptible.Bytes as DUB import qualified Socket.Stream.IPv4 as SI+import qualified Socket.Stream.Uninterruptible.Bytes as UB+import qualified Socket.Stream.Uninterruptible.MutableBytes as UMB+import qualified Socket.Stream.Uninterruptible.ByteString as UBS+import qualified Socket.Stream.Uninterruptible.Hybrid as UHYB  main :: IO ()-main = do-  canSpoof <- DIS.withSocket (const (pure ())) >>= \case-    Right () -> pure True-    Left e -> case e of-      DIS.SocketPermissionDenied -> pure False-      DIS.SocketFileDescriptorLimit -> do-        hPutStrLn stderr "All ephemeral ports are in use. Terminating."-        exitFailure-  defaultMain (tests canSpoof)+main = defaultMain tests -tests :: Bool -> TestTree-tests canSpoof = testGroup "socket"+tests :: TestTree+tests = testGroup "socket"   [ testGroup "datagram"     [ testGroup "ipv4"-      [ testGroup "undestined"+      [ testGroup "unconnected"         [ testCase "A" testDatagramUndestinedA         , testCase "B" testDatagramUndestinedB         , testCase "C" testDatagramUndestinedC+        , testCase "D" testDatagramUndestinedD+        , testCase "E" testDatagramUndestinedE+        , testCase "F" testDatagramUndestinedF         ]-      , testGroup "spoof" $ if canSpoof-          then-            [ testCase "A" testDatagramSpoofA-            , testCase "B" testDatagramSpoofB-            ]-          else []+      , testGroup "connected"+        [ testCase "A" testDatagramConnectedA+        ]       ]     ]   , testGroup "stream"@@ -66,10 +71,21 @@         , testCase "32MB" (testStreamB 32)         ]       , testCase "C" testStreamC+      , testCase "D" testStreamD+      , testCase "E" testStreamE+      , testGroup "F"+        [ testCase "3KB" (testStreamF 1)+        , testCase "3MB" (testStreamF (1 * 1024))+        , testCase "12MB" (testStreamF (4 * 1024))+        , testCase "48MB" (testStreamF (16 * 1024))+        ]       ]     ]   ] +unsliced :: ByteArray -> Bytes+unsliced arr = Bytes arr 0 (PM.sizeofByteArray arr)+ unhandled :: Exception e => IO (Either e a) -> IO a unhandled action = action >>= either throwIO pure @@ -86,94 +102,198 @@   deriving stock (Show,Eq)   deriving anyclass (Exception) +testDatagramConnectedA :: Assertion+testDatagramConnectedA = do+  (m :: PM.MVar RealWorld Word16) <- PM.newEmptyMVar+  (port,received) <- concurrently (sender m) (receiver m)+  received @=? DIU.Message (DIU.Peer IPv4.loopback port) message+  where+  message = E.fromList [0,1,2,3] :: ByteArray+  sz = PM.sizeofByteArray message+  sender :: PM.MVar RealWorld Word16 -> IO Word16+  sender m = do+    dstPort <- PM.takeMVar m+    unhandled $ DIC.withSocket (DUB.Peer IPv4.loopback 0) (DUB.Peer IPv4.loopback dstPort) $ \sock srcPort -> do+      unhandled $ DUB.send sock (unsliced message)+      pure srcPort+  receiver :: PM.MVar RealWorld Word16 -> IO DIU.Message+  receiver m = unhandled $ DIU.withSocket (DIU.Peer IPv4.loopback 0) $ \sock port -> do+    PM.putMVar m port+    unhandled $ DUB.receiveFromIPv4 sock sz+ testDatagramUndestinedA :: Assertion testDatagramUndestinedA = do   (m :: PM.MVar RealWorld Word16) <- PM.newEmptyMVar   (port,received) <- concurrently (sender m) (receiver m)-  received @=? DIU.Message (DIU.Endpoint IPv4.loopback port) message+  received @=? DIU.Message (DIU.Peer IPv4.loopback port) message   where   message = E.fromList [0,1,2,3] :: ByteArray   sz = PM.sizeofByteArray message   sender :: PM.MVar RealWorld Word16 -> IO Word16-  sender m = unhandled $ DIU.withSocket (DIU.Endpoint IPv4.loopback 0) $ \sock srcPort -> do+  sender m = unhandled $ DIU.withSocket (DUB.Peer IPv4.loopback 0) $ \sock srcPort -> do     dstPort <- PM.takeMVar m-    unhandled $ DIU.send sock (DIU.Endpoint IPv4.loopback dstPort) message 0 sz+    unhandled $ DUB.sendToIPv4 sock (DIU.Peer IPv4.loopback dstPort) (unsliced message)     pure srcPort   receiver :: PM.MVar RealWorld Word16 -> IO DIU.Message-  receiver m = unhandled $ DIU.withSocket (DIU.Endpoint IPv4.loopback 0) $ \sock port -> do+  receiver m = unhandled $ DIU.withSocket (DIU.Peer IPv4.loopback 0) $ \sock port -> do     PM.putMVar m port-    unhandled $ DIU.receiveByteArray sock sz+    unhandled $ DUB.receiveFromIPv4 sock sz  testDatagramUndestinedB :: Assertion testDatagramUndestinedB = do   (m :: PM.MVar RealWorld Word16) <- PM.newEmptyMVar   (n :: PM.MVar RealWorld ()) <- PM.newEmptyMVar-  (port,received) <- concurrently (sender m n) (receiver m n)-  received @=?-    ( DIU.Message (DIU.Endpoint IPv4.loopback port) message1-    , DIU.Message (DIU.Endpoint IPv4.loopback port) message2-    )+  ((),received) <- concurrently (sender m n) (receiver m n)+  let expected = (message1,message2)+  expected @=? received   where-  message1 = E.fromList [0,1,2,3] :: ByteArray-  message2 = E.fromList [4,5,6,8,9,10] :: ByteArray+  message1 = E.fromList [0..3] :: ByteArray+  message2 = E.fromList [4..11] :: ByteArray   sz1 = PM.sizeofByteArray message1   sz2 = PM.sizeofByteArray message2-  sender :: PM.MVar RealWorld Word16 -> PM.MVar RealWorld () -> IO Word16-  sender m n = unhandled $ DIU.withSocket (DIU.Endpoint IPv4.loopback 0) $ \sock srcPort -> do+  sender :: PM.MVar RealWorld Word16 -> PM.MVar RealWorld () -> IO ()+  sender m n = unhandled $ DIU.withSocket (DIU.Peer IPv4.loopback 0) $ \sock _ -> do     dstPort <- PM.takeMVar m-    unhandled $ DIU.send sock (DIU.Endpoint IPv4.loopback dstPort) message1 0 sz1-    unhandled $ DIU.send sock (DIU.Endpoint IPv4.loopback dstPort) message2 0 sz2+    unhandled $ DUB.sendToIPv4 sock (DIU.Peer IPv4.loopback dstPort) (unsliced message1)+    unhandled $ DUB.sendToIPv4 sock (DIU.Peer IPv4.loopback dstPort) (unsliced message2)     PM.putMVar n ()-    pure srcPort-  receiver :: PM.MVar RealWorld Word16 -> PM.MVar RealWorld () -> IO (DIU.Message,DIU.Message)-  receiver m n = unhandled $ DIU.withSocket (DIU.Endpoint IPv4.loopback 0) $ \sock port -> do+  receiver :: PM.MVar RealWorld Word16 -> PM.MVar RealWorld () -> IO (ByteArray,ByteArray)+  receiver m n = unhandled $ DIU.withSocket (DIU.Peer IPv4.loopback 0) $ \sock port -> do     PM.putMVar m port     PM.takeMVar n-    msgs <- unhandled $ DIU.receiveMany sock 3 (max sz1 sz2)-    if PM.sizeofArray msgs == 2-      then pure (PM.indexArray msgs 0, PM.indexArray msgs 1)-      else fail "received a number of messages other than 2"+    slab <- DUB.newPeerlessSlab 2 (max sz1 sz2)+    msgs <- unhandled $ DUB.receiveMany sock slab+    let msgCount = PM.sizeofUnliftedArray msgs+    if msgCount == 2+      then pure (PM.indexUnliftedArray msgs 0, PM.indexUnliftedArray msgs 1)+      else fail ("received a number of messages other than 2: " ++ show msgCount)        testDatagramUndestinedC :: Assertion testDatagramUndestinedC = do   (m :: PM.MVar RealWorld Word16) <- PM.newEmptyMVar   (n :: PM.MVar RealWorld ()) <- PM.newEmptyMVar   (port,received) <- concurrently (sender m n) (receiver m n)-  received @=?-    ( DIU.Message (DIU.Endpoint IPv4.loopback port) message1-    , DIU.Message (DIU.Endpoint IPv4.loopback port) message2-    , DIU.Message (DIU.Endpoint IPv4.loopback port) message3-    )+  let expected = +        ( DIU.Message (DIU.Peer IPv4.loopback port) message1+        , DIU.Message (DIU.Peer IPv4.loopback port) message2+        , DIU.Message (DIU.Peer IPv4.loopback port) message3+        , DIU.Message (DIU.Peer IPv4.loopback port) message4+        )+  expected @=? received   where   message1 = E.fromList (enumFromTo 0 9):: ByteArray-  message2 = E.fromList (enumFromTo 10 10) :: ByteArray-  message3 = E.fromList (enumFromTo 11 25) :: ByteArray+  message2 = E.fromList (enumFromTo 10 12) :: ByteArray+  message3 = E.fromList (enumFromTo 13 27) :: ByteArray+  message4 = E.fromList (enumFromTo 28 31) :: ByteArray   sz1 = PM.sizeofByteArray message1   sz2 = PM.sizeofByteArray message2   sz3 = PM.sizeofByteArray message3+  sz4 = PM.sizeofByteArray message4   sender :: PM.MVar RealWorld Word16 -> PM.MVar RealWorld () -> IO Word16-  sender m n = unhandled $ DIU.withSocket (DIU.Endpoint IPv4.loopback 0) $ \sock srcPort -> do+  sender m n = unhandled $ DIU.withSocket (DIU.Peer IPv4.loopback 0) $ \sock srcPort -> do     dstPort <- PM.takeMVar m-    unhandled $ DIU.send sock (DIU.Endpoint IPv4.loopback dstPort) message1 0 sz1-    unhandled $ DIU.send sock (DIU.Endpoint IPv4.loopback dstPort) message2 0 sz2-    unhandled $ DIU.send sock (DIU.Endpoint IPv4.loopback dstPort) message3 0 sz3+    unhandled $ DUB.sendToIPv4 sock (DIU.Peer IPv4.loopback dstPort) (unsliced message1)+    unhandled $ DUB.sendToIPv4 sock (DIU.Peer IPv4.loopback dstPort) (unsliced message2)+    unhandled $ DUB.sendToIPv4 sock (DIU.Peer IPv4.loopback dstPort) (unsliced message3)+    unhandled $ DUB.sendToIPv4 sock (DIU.Peer IPv4.loopback dstPort) (unsliced message4)     PM.putMVar n ()     pure srcPort-  receiver :: PM.MVar RealWorld Word16 -> PM.MVar RealWorld () -> IO (DIU.Message,DIU.Message,DIU.Message)-  receiver m n = unhandled $ DIU.withSocket (DIU.Endpoint IPv4.loopback 0) $ \sock port -> do+  receiver :: PM.MVar RealWorld Word16 -> PM.MVar RealWorld ()+           -> IO (DIU.Message,DIU.Message,DIU.Message,DIU.Message)+  receiver m n = unhandled $ DIU.withSocket (DIU.Peer IPv4.loopback 0) $ \sock port -> do     PM.putMVar m port     PM.takeMVar n-    msgsX <- unhandled $ DIU.receiveMany sock 2 (max sz1 sz2)-    (msg1,msg2) <- if PM.sizeofArray msgsX == 2-      then pure (PM.indexArray msgsX 0, PM.indexArray msgsX 1)-      else fail "received a number of messages other than 2"-    msgsY <- unhandled $ DIU.receiveMany sock 2 sz3-    msg3 <- if PM.sizeofArray msgsY == 1-      then pure (PM.indexArray msgsY 0)-      else fail "received a number of messages other than 2"-    pure (msg1,msg2,msg3)-      +    slab <- DUB.newIPv4Slab 3 (max sz1 (max sz2 (max sz3 sz4)))+    msgsX <- unhandled $ DUB.receiveManyFromIPv4 sock slab+    let msgCountX = PM.sizeofSmallArray msgsX+    (msg1,msg2,msg3) <- if PM.sizeofSmallArray msgsX == 3+      then pure (PM.indexSmallArray msgsX 0, PM.indexSmallArray msgsX 1, PM.indexSmallArray msgsX 2)+      else fail $ "received a number of messages other than 3: " ++ show msgCountX+    msgsY <- unhandled $ DUB.receiveManyFromIPv4 sock slab+    let msgCountY = PM.sizeofSmallArray msgsY+    msg4 <- if msgCountY == 1+      then pure (PM.indexSmallArray msgsY 0)+      else fail $ "received a number of messages other than 1: " ++ show msgCountY+    pure (msg1,msg2,msg3,msg4) +testDatagramUndestinedD :: Assertion+testDatagramUndestinedD = do+  (m :: PM.MVar RealWorld Word16) <- PM.newEmptyMVar+  ((),received) <- concurrently (sender m) (receiver m)+  let expected = (message1,message2,message3)+  expected @=? received+  where+  message1 = E.fromList (enumFromTo 0 15):: ByteArray+  message2 = E.fromList (enumFromTo 16 18) :: ByteArray+  message3 = E.fromList (enumFromTo 19 23) :: ByteArray+  sz1 = PM.sizeofByteArray message1+  sz2 = PM.sizeofByteArray message2+  sz3 = PM.sizeofByteArray message3+  sender :: PM.MVar RealWorld Word16 -> IO ()+  sender m = unhandled $ DIU.withSocket (DUB.Peer IPv4.loopback 0) $ \sock _ -> do+    dstPort <- PM.takeMVar m+    unhandled $ DUB.sendToIPv4 sock (DIU.Peer IPv4.loopback dstPort) (unsliced message1)+    unhandled $ DUB.sendToIPv4 sock (DIU.Peer IPv4.loopback dstPort) (unsliced message2)+    unhandled $ DUB.sendToIPv4 sock (DIU.Peer IPv4.loopback dstPort) (unsliced message3)+  receiver :: PM.MVar RealWorld Word16 -> IO (ByteArray,ByteArray,ByteArray)+  receiver m = unhandled $ DIU.withSocket (DIU.Peer IPv4.loopback 0) $ \sock port -> do+    PM.putMVar m port+    liftA3 (,,)+      (unhandled $ DUB.receive sock sz1)+      (unhandled $ DUB.receive sock sz2)+      (unhandled $ DUB.receive sock sz3)++testDatagramUndestinedE :: Assertion+testDatagramUndestinedE = do+  (m :: PM.MVar RealWorld Word16) <- PM.newEmptyMVar+  (n :: PM.MVar RealWorld ()) <- PM.newEmptyMVar+  ((),received) <- concurrently (sender m n) (receiver m n)+  let expected = (message1,message2,message3)+  expected @=? received+  where+  message1 = E.fromList (enumFromTo 0 9):: ByteArray+  message2 = E.fromList (enumFromTo 10 14) :: ByteArray+  message3 = E.fromList (enumFromTo 15 21) :: ByteArray+  sz1 = PM.sizeofByteArray message1+  sz2 = PM.sizeofByteArray message2+  sz3 = PM.sizeofByteArray message3+  sender :: PM.MVar RealWorld Word16 -> PM.MVar RealWorld () -> IO ()+  sender !m !n = unhandled $ DIU.withSocket (DUB.Peer IPv4.loopback 0) $ \sock _ -> do+    dstPort <- PM.takeMVar m+    unhandled $ DUB.sendToIPv4 sock (DIU.Peer IPv4.loopback dstPort) (unsliced message1)+    unhandled $ DUB.sendToIPv4 sock (DIU.Peer IPv4.loopback dstPort) (unsliced message2)+    unhandled $ DUB.sendToIPv4 sock (DIU.Peer IPv4.loopback dstPort) (unsliced message3)+    PM.putMVar n ()+  receiver :: PM.MVar RealWorld Word16 -> PM.MVar RealWorld () -> IO (ByteArray,ByteArray,ByteArray)+  receiver m n = unhandled $ DIU.withSocket (DIU.Peer IPv4.loopback 0) $ \sock port -> do+    PM.putMVar m port+    PM.takeMVar n+    slab <- DUB.newPeerlessSlab 1 (max sz1 (max sz2 sz3))+    msgsX <- unhandled $ DUB.receiveMany sock slab+    when (PM.sizeofUnliftedArray msgsX /= 1) $ fail "more than one message for X"+    msgsY <- unhandled $ DUB.receiveMany sock slab+    when (PM.sizeofUnliftedArray msgsX /= 1) $ fail "more than one message for Y"+    msgsZ <- unhandled $ DUB.receiveMany sock slab+    when (PM.sizeofUnliftedArray msgsX /= 1) $ fail "more than one message for Z"+    pure (PM.indexUnliftedArray msgsX 0,PM.indexUnliftedArray msgsY 0,PM.indexUnliftedArray msgsZ 0)++testDatagramUndestinedF :: Assertion+testDatagramUndestinedF = do+  (m :: PM.MVar RealWorld Word16) <- PM.newEmptyMVar+  ((),received) <- concurrently (sender m) (receiver m)+  let expected = (Left (DUB.ReceiveTruncated sz))+  expected @=? received+  where+  message = E.fromList (enumFromTo 0 11):: ByteArray+  sz = PM.sizeofByteArray message+  sender !m = unhandled $ DIU.withSocket (DUB.Peer IPv4.loopback 0) $ \sock _ -> do+    dstPort <- PM.takeMVar m+    unhandled $ DUB.sendToIPv4 sock (DIU.Peer IPv4.loopback dstPort) (unsliced message)+  receiver m = unhandled $ DIU.withSocket (DIU.Peer IPv4.loopback 0) $ \sock port -> do+    PM.putMVar m port+    slab <- DUB.newPeerlessSlab 1 (sz - 1)+    DUB.receiveMany sock slab+ -- This test involves a made up protocol that goes like this: -- The sender always starts by sending the length of the rest -- of the payload as a native-endian encoded machine-sized int.@@ -196,16 +316,16 @@   sender :: PM.MVar RealWorld Word16 -> IO ()   sender m = do     dstPort <- PM.takeMVar m-    unhandled $ SI.withConnection (DIU.Endpoint IPv4.loopback dstPort) unhandledClose $ \conn -> do-      unhandled $ SI.sendByteArray conn szb-      unhandled $ SI.sendByteArray conn message+    unhandled $ SI.withConnection (DIU.Peer IPv4.loopback dstPort) unhandledClose $ \conn -> do+      unhandled $ UB.send conn (unsliced szb)+      unhandled $ UB.send conn (unsliced message)   receiver :: PM.MVar RealWorld Word16 -> IO ByteArray-  receiver m = unhandled $ SI.withListener (SI.Endpoint IPv4.loopback 0) $ \listener port -> do+  receiver m = unhandled $ SI.withListener (SI.Peer IPv4.loopback 0) $ \listener port -> do     PM.putMVar m port     unhandled $ SI.withAccepted listener unhandledClose $ \conn _ -> do-      serializedSize <- unhandled $ SI.receiveByteArray conn (PM.sizeOf (undefined :: Int))+      serializedSize <- unhandled $ UB.receiveExactly conn (PM.sizeOf (undefined :: Int))       let theSize = PM.indexByteArray serializedSize 0 :: Int-      result <- unhandled $ SI.receiveByteArray conn theSize+      result <- unhandled $ UB.receiveExactly conn theSize       pure result  testStreamC :: Assertion@@ -218,14 +338,57 @@   sender :: PM.MVar RealWorld Word16 -> IO ()   sender m = do     dstPort <- PM.takeMVar m-    unhandled $ SI.withConnection (DIU.Endpoint IPv4.loopback dstPort) unhandledClose $ \conn -> do-      unhandled $ SI.sendByteString conn message+    unhandled $ SI.withConnection (DIU.Peer IPv4.loopback dstPort) unhandledClose $ \conn -> do+      unhandled $ UBS.send conn message   receiver :: PM.MVar RealWorld Word16 -> IO ByteString-  receiver m = unhandled $ SI.withListener (SI.Endpoint IPv4.loopback 0) $ \listener port -> do+  receiver m = unhandled $ SI.withListener (SI.Peer IPv4.loopback 0) $ \listener port -> do     PM.putMVar m port     unhandled $ SI.withAccepted listener unhandledClose $ \conn _ -> do-      unhandled $ SI.receiveByteString conn (B.length message)+      unhandled $ UBS.receiveExactly conn (B.length message) +-- This is intended to test creating sockets after other sockets have been+-- closed.+testStreamD :: Assertion+testStreamD = do+  (m :: PM.MVar RealWorld Word16) <- PM.newEmptyMVar+  ((),()) <- concurrently (server m) (client m)+  pure ()+  where+  message = E.fromList (replicate 50000 (0 :: Word8)) :: ByteArray+  totalConns = 20+  simultaneousClients = 5+  client :: PM.MVar RealWorld Word16 -> IO ()+  client m = do+    dstPort <- PM.takeMVar m+    counter <- PM.newEmptyMVar+    replicateM_ simultaneousClients $ forkIO $ do+      replicateM_ (div totalConns simultaneousClients) $ do+        _ <- unhandled $ SI.withConnection (DIU.Peer IPv4.loopback dstPort) unhandledClose $ \conn -> do+          let go = UB.send conn (unsliced message) >>= \case+                Left SI.SendShutdown -> pure ()+                Left e -> throwIO e+                Right () -> go+          go+        pure ()+      PM.putMVar counter ()+    replicateM_ simultaneousClients $ PM.takeMVar counter+  server :: PM.MVar RealWorld Word16 -> IO ()+  server m = unhandled $ SI.withListener (SI.Peer IPv4.loopback 0) $ \listener port -> do+    PM.putMVar m port+    counter <- PM.newEmptyMVar+    replicateM_ totalConns $ do+      SI.forkAcceptedUnmasked listener+        (\e () -> case e of+          Left SI.ClosePeerContinuedSending -> PM.putMVar counter ()+          Right () -> fail "testStreamD: unexpected behavior"+        )+        (\conn _ -> do+          _ <- unhandled $ UB.receiveExactly conn 1+          pure ()+        )+    replicateM_ totalConns $ PM.takeMVar counter++ -- The sender sends a large amount of traffic that may exceed -- the size of the operating system's TCP send buffer. The  -- amount is configurable because the test suite wants to@@ -241,10 +404,10 @@   sender :: PM.MVar RealWorld Word16 -> IO ()   sender m = do     dstPort <- PM.takeMVar m-    unhandled $ SI.withConnection (DIU.Endpoint IPv4.loopback dstPort) unhandledClose $ \conn -> do-      replicateM_ (32 * megabytes) $ unhandled $ SI.sendByteArray conn message+    unhandled $ SI.withConnection (DIU.Peer IPv4.loopback dstPort) unhandledClose $ \conn -> do+      replicateM_ (32 * megabytes) $ unhandled $ UB.send conn (unsliced message)   receiver :: PM.MVar RealWorld Word16 -> IO ()-  receiver m = unhandled $ SI.withListener (SI.Endpoint IPv4.loopback 0) $ \listener port -> do+  receiver m = unhandled $ SI.withListener (SI.Peer IPv4.loopback 0) $ \listener port -> do     PM.putMVar m port     unhandled $ SI.withAccepted listener unhandledClose $ \conn _ -> do       buffer <- PM.newByteArray chunkSize@@ -252,7 +415,8 @@             | remaining > 0 = do                 let recvSize = min remaining chunkSize                 PM.setByteArray buffer 0 chunkSize (0 :: Word8)-                bytesReceived <- unhandled (SI.receiveBoundedMutableByteArraySlice conn recvSize buffer 0)+                bytesReceived <- unhandled+                  (UMB.receiveOnce conn (MutableBytes buffer 0 recvSize))                 verifyClientSendBytes buffer bytesReceived >>= \case                   True -> receiveLoop (remaining - bytesReceived)                   False -> throwIO MagicByteMismatch@@ -273,67 +437,89 @@       if w == magicByte then go (ix - 1) else pure False     else pure True --- Here, the sender spoofs its ip address and port.-testDatagramSpoofA :: Assertion-testDatagramSpoofA = do+-- This tests that hybrid sending works correctly.+testStreamF :: Int -> Assertion+testStreamF megabytes = do   (m :: PM.MVar RealWorld Word16) <- PM.newEmptyMVar   ((),received) <- concurrently (sender m) (receiver m)-  received @=? DIU.Message-    (DIU.Endpoint (IPv4.fromOctets 8 7 6 5) 60000)-    payload+  expectedMut <- PM.newByteArray (3 * payloadBytes)+  PM.setByteArray expectedMut 0 (2 * payloadBytes) (0xE6 :: Word8)+  PM.setByteArray expectedMut (2 * payloadBytes) payloadBytes (0xB4 :: Word8)+  expected <- PM.unsafeFreezeByteArray expectedMut+  let lenExp = PM.sizeofByteArray expected+  let lenRec = PM.sizeofByteArray received+  when (lenExp /= lenRec) $ assertFailure $+    "Incorrect result: expected length " +++    show lenExp ++ " but got " ++ show lenRec+  when (expected /= received) $ do+    let ix = differentByte expected received lenExp+    assertFailure ("Incorrect result differing at byte " ++ show ix)   where-  sz = 16-  payload = E.fromList (enumFromTo (0 :: Word8) (fromIntegral sz - 1))+  payloadBytes = megabytes * 1024   sender :: PM.MVar RealWorld Word16 -> IO ()-  sender m = unhandled $ DIS.withSocket $ \sock -> do+  sender m = do     dstPort <- PM.takeMVar m-    marr <- PM.newByteArray sz-    PM.copyByteArray marr 0 payload 0 sz-    unhandled $ DIS.sendMutableByteArray sock-      (DIU.Endpoint (IPv4.fromOctets 8 7 6 5) 60000)-      (DIU.Endpoint IPv4.loopback dstPort)-      marr 0 sz-  receiver :: PM.MVar RealWorld Word16 -> IO DIU.Message-  receiver m = unhandled $ DIU.withSocket (DIU.Endpoint IPv4.loopback 0) $ \sock port -> do-    PM.putMVar m port-    unhandled $ DIU.receiveByteArray sock 500+    let peer = DIU.Peer IPv4.loopback dstPort+    bufA <- PM.newByteArray (2 * payloadBytes)+    PM.setByteArray bufA 0 (2 * payloadBytes) (0xE6 :: Word8)+    bufB <- PM.newPinnedByteArray payloadBytes+    PM.setByteArray bufB 0 payloadBytes (0xB4 :: Word8)+    unhandled $ SI.withConnection peer unhandledClose $ \conn -> do+      unhandled $ UHYB.sendMutableBytesUnmanagedBytes conn+        (MutableBytes bufA 0 (payloadBytes * 2))+        (UnmanagedBytes (ptrToAddr (PM.mutableByteArrayContents bufB)) payloadBytes)+      touchMutableByteArray bufB+  receiver :: PM.MVar RealWorld Word16 -> IO ByteArray+  receiver m = do+    let peer = (SI.Peer IPv4.loopback 0)+    unhandled $ SI.withListener peer $ \listener port -> do+      PM.putMVar m port+      unhandled $ SI.withAccepted listener unhandledClose $ \conn _ -> do+        unhandled $ UB.receiveExactly conn (payloadBytes * 3)       --- Here, the sender spoofs its ip address and port twice, picking a--- different port each time.-testDatagramSpoofB :: Assertion-testDatagramSpoofB = do+testStreamE :: Assertion+testStreamE = do   (m :: PM.MVar RealWorld Word16) <- PM.newEmptyMVar   ((),received) <- concurrently (sender m) (receiver m)-  received @=?-    ( DIU.Message-      (DIU.Endpoint (IPv4.fromOctets 8 7 6 5) 60000)-      payloadA-    , DIU.Message-      (DIU.Endpoint (IPv4.fromOctets 9 8 7 6) 59999)-      payloadB-    )+  received @=? (mconcat [messageA, messageB, messageC, messageD])   where-  sz = 16-  payloadA = E.fromList (enumFromTo (1 :: Word8) (fromIntegral sz))-  payloadB = E.fromList (enumFromTo (2 :: Word8) (fromIntegral sz + 1))+  messageA = E.fromList [0..17] :: ByteArray+  messageB = E.fromList [18..92] :: ByteArray+  messageC = E.fromList [93..182] :: ByteArray+  messageD = E.fromList [183..255] :: ByteArray   sender :: PM.MVar RealWorld Word16 -> IO ()-  sender m = unhandled $ DIS.withSocket $ \sock -> do+  sender m = do     dstPort <- PM.takeMVar m-    marrA <- PM.newByteArray sz-    marrB <- PM.newByteArray sz-    PM.copyByteArray marrA 0 payloadA 0 sz-    PM.copyByteArray marrB 0 payloadB 0 sz-    unhandled $ DIS.sendMutableByteArray sock-      (DIU.Endpoint (IPv4.fromOctets 8 7 6 5) 60000)-      (DIU.Endpoint IPv4.loopback dstPort)-      marrA 0 sz-    unhandled $ DIS.sendMutableByteArray sock-      (DIU.Endpoint (IPv4.fromOctets 9 8 7 6) 59999)-      (DIU.Endpoint IPv4.loopback dstPort)-      marrB 0 sz-  receiver :: PM.MVar RealWorld Word16 -> IO (DIU.Message,DIU.Message)-  receiver m = unhandled $ DIU.withSocket (DIU.Endpoint IPv4.loopback 0) $ \sock port -> do+    unhandled $ SI.withConnection (DIU.Peer IPv4.loopback dstPort) unhandledClose $ \conn -> do+      unhandled $ UB.send conn (unsliced messageA)+      unhandled $ UB.send conn (unsliced messageB)+      unhandled $ UB.send conn (unsliced messageC)+      unhandled $ UB.send conn (unsliced messageD)+  receiver :: PM.MVar RealWorld Word16 -> IO ByteArray+  receiver m = unhandled $ SI.withListener (SI.Peer IPv4.loopback 0) $ \listener port -> do     PM.putMVar m port-    msg1 <- unhandled $ DIU.receiveByteArray sock 500-    msg2 <- unhandled $ DIU.receiveByteArray sock 500-    return (msg1,msg2)+    unhandled $ SI.withAccepted listener unhandledClose $ \conn _ -> do+      marr <- PM.newByteArray 256+      x <- unhandled $ UMB.receiveBetween conn (MutableBytes marr 0 60) 20+      y <- unhandled $ UMB.receiveBetween conn (MutableBytes marr x 150) 100+      unhandled $ UMB.receiveExactly conn (MutableBytes marr (x + y) (256 - (x + y)))+      PM.unsafeFreezeByteArray marr++touchMutableByteArray :: MutableByteArray RealWorld -> IO ()+touchMutableByteArray (MutableByteArray x) = touchMutableByteArray# x++touchMutableByteArray# :: E.MutableByteArray# RealWorld -> IO ()+touchMutableByteArray# x = IO $ \s -> case E.touch# x s of s' -> (# s', () #)++ptrToAddr :: E.Ptr a -> Addr+ptrToAddr (E.Ptr x) = Addr x++differentByte :: ByteArray -> ByteArray -> Int -> Int+differentByte a b len = go 0 where+  go !ix = if ix < len+    then if PM.indexByteArray a ix == (PM.indexByteArray b ix :: Word8)+      then go (ix + 1)+      else ix+    else len+  +