diff --git a/bench/Http.hs b/bench/Http.hs new file mode 100644 --- /dev/null +++ b/bench/Http.hs @@ -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" diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -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 diff --git a/sockets.cabal b/sockets.cabal --- a/sockets.cabal +++ b/sockets.cabal @@ -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 diff --git a/src-buffer/Socket/Buffer.hsig b/src-buffer/Socket/Buffer.hsig new file mode 100644 --- /dev/null +++ b/src-buffer/Socket/Buffer.hsig @@ -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 diff --git a/src-datagram-receive-many/Datagram/Receive/Many/Indefinite.hs b/src-datagram-receive-many/Datagram/Receive/Many/Indefinite.hs new file mode 100644 --- /dev/null +++ b/src-datagram-receive-many/Datagram/Receive/Many/Indefinite.hs @@ -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# #) diff --git a/src-datagram-receive/Datagram/Receive.hsig b/src-datagram-receive/Datagram/Receive.hsig new file mode 100644 --- /dev/null +++ b/src-datagram-receive/Datagram/Receive.hsig @@ -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) diff --git a/src-datagram-receive/Datagram/Receive/Indefinite.hs b/src-datagram-receive/Datagram/Receive/Indefinite.hs new file mode 100644 --- /dev/null +++ b/src-datagram-receive/Datagram/Receive/Indefinite.hs @@ -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 ++ ")" + diff --git a/src-datagram-send/Datagram/Send.hsig b/src-datagram-send/Datagram/Send.hsig new file mode 100644 --- /dev/null +++ b/src-datagram-send/Datagram/Send.hsig @@ -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) diff --git a/src-datagram-send/Datagram/Send/Indefinite.hs b/src-datagram-send/Datagram/Send/Indefinite.hs new file mode 100644 --- /dev/null +++ b/src-datagram-send/Datagram/Send/Indefinite.hs @@ -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 ++ ")" diff --git a/src-debug/Socket/Debug.hs b/src-debug/Socket/Debug.hs --- a/src-debug/Socket/Debug.hs +++ b/src-debug/Socket/Debug.hs @@ -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 diff --git a/src-err/Socket/Error.hs b/src-err/Socket/Error.hs new file mode 100644 --- /dev/null +++ b/src-err/Socket/Error.hs @@ -0,0 +1,6 @@ +module Socket.Error + ( die + ) where + +die :: String -> IO a +die = fail diff --git a/src-internal/Hybrid/Send/MutableBytes/AddrLength.hs b/src-internal/Hybrid/Send/MutableBytes/AddrLength.hs new file mode 100644 --- /dev/null +++ b/src-internal/Hybrid/Send/MutableBytes/AddrLength.hs @@ -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 diff --git a/src-internal/Socket.hs b/src-internal/Socket.hs new file mode 100644 --- /dev/null +++ b/src-internal/Socket.hs @@ -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" diff --git a/src-internal/Socket/AddrLength.hs b/src-internal/Socket/AddrLength.hs new file mode 100644 --- /dev/null +++ b/src-internal/Socket/AddrLength.hs @@ -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 diff --git a/src-internal/Socket/Bytes.hs b/src-internal/Socket/Bytes.hs new file mode 100644 --- /dev/null +++ b/src-internal/Socket/Bytes.hs @@ -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 + diff --git a/src-internal/Socket/Connected/Bytes.hs b/src-internal/Socket/Connected/Bytes.hs new file mode 100644 --- /dev/null +++ b/src-internal/Socket/Connected/Bytes.hs @@ -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 diff --git a/src-internal/Socket/Connected/MutableBytes.hs b/src-internal/Socket/Connected/MutableBytes.hs new file mode 100644 --- /dev/null +++ b/src-internal/Socket/Connected/MutableBytes.hs @@ -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 + + + diff --git a/src-internal/Socket/Datagram.hs b/src-internal/Socket/Datagram.hs new file mode 100644 --- /dev/null +++ b/src-internal/Socket/Datagram.hs @@ -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) diff --git a/src-internal/Socket/Destined/IPv4/Bytes.hs b/src-internal/Socket/Destined/IPv4/Bytes.hs new file mode 100644 --- /dev/null +++ b/src-internal/Socket/Destined/IPv4/Bytes.hs @@ -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 diff --git a/src-internal/Socket/Destined/IPv4/MutableBytes.hs b/src-internal/Socket/Destined/IPv4/MutableBytes.hs new file mode 100644 --- /dev/null +++ b/src-internal/Socket/Destined/IPv4/MutableBytes.hs @@ -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 diff --git a/src-internal/Socket/Discard.hs b/src-internal/Socket/Discard.hs new file mode 100644 --- /dev/null +++ b/src-internal/Socket/Discard.hs @@ -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# #) diff --git a/src-internal/Socket/EventManager.hs b/src-internal/Socket/EventManager.hs new file mode 100644 --- /dev/null +++ b/src-internal/Socket/EventManager.hs @@ -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)) #) + diff --git a/src-internal/Socket/IPv4.hs b/src-internal/Socket/IPv4.hs new file mode 100644 --- /dev/null +++ b/src-internal/Socket/IPv4.hs @@ -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 + -- + -- 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# #) diff --git a/src-internal/Socket/Interruptible.hs b/src-internal/Socket/Interruptible.hs new file mode 100644 --- /dev/null +++ b/src-internal/Socket/Interruptible.hs @@ -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 diff --git a/src-internal/Socket/MutableBytes.hs b/src-internal/Socket/MutableBytes.hs new file mode 100644 --- /dev/null +++ b/src-internal/Socket/MutableBytes.hs @@ -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 diff --git a/src-internal/Socket/MutableBytes/Peerless.hs b/src-internal/Socket/MutableBytes/Peerless.hs new file mode 100644 --- /dev/null +++ b/src-internal/Socket/MutableBytes/Peerless.hs @@ -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 diff --git a/src-internal/Socket/MutableBytes/SocketAddressInternet.hs b/src-internal/Socket/MutableBytes/SocketAddressInternet.hs new file mode 100644 --- /dev/null +++ b/src-internal/Socket/MutableBytes/SocketAddressInternet.hs @@ -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 diff --git a/src-internal/Socket/Stream.hs b/src-internal/Socket/Stream.hs new file mode 100644 --- /dev/null +++ b/src-internal/Socket/Stream.hs @@ -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 +-- +-- 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 +-- +-- 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 + -- . + -- 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 +-- 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) diff --git a/src-internal/Socket/Uninterruptible.hs b/src-internal/Socket/Uninterruptible.hs new file mode 100644 --- /dev/null +++ b/src-internal/Socket/Uninterruptible.hs @@ -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 + diff --git a/src-interrupt/Socket/Interrupt.hsig b/src-interrupt/Socket/Interrupt.hsig new file mode 100644 --- /dev/null +++ b/src-interrupt/Socket/Interrupt.hsig @@ -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) () diff --git a/src-mmsg/Socket/Datagram/IPv4/Undestined/Multiple.hs b/src-mmsg/Socket/Datagram/IPv4/Undestined/Multiple.hs deleted file mode 100644 --- a/src-mmsg/Socket/Datagram/IPv4/Undestined/Multiple.hs +++ /dev/null @@ -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 - diff --git a/src-mmsg/Socket/Datagram/Interruptible/MutableBytes/Many.hs b/src-mmsg/Socket/Datagram/Interruptible/MutableBytes/Many.hs new file mode 100644 --- /dev/null +++ b/src-mmsg/Socket/Datagram/Interruptible/MutableBytes/Many.hs @@ -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" diff --git a/src-mmsg/Socket/Datagram/Uninterruptible/MutableBytes/Many.hs b/src-mmsg/Socket/Datagram/Uninterruptible/MutableBytes/Many.hs new file mode 100644 --- /dev/null +++ b/src-mmsg/Socket/Datagram/Uninterruptible/MutableBytes/Many.hs @@ -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# #) diff --git a/src-no-mmsg/Socket/Datagram/IPv4/Undestined/Multiple.hs b/src-no-mmsg/Socket/Datagram/IPv4/Undestined/Multiple.hs deleted file mode 100644 --- a/src-no-mmsg/Socket/Datagram/IPv4/Undestined/Multiple.hs +++ /dev/null @@ -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 - diff --git a/src-no-mmsg/Socket/Datagram/Interruptible/MutableBytes/Many.hs b/src-no-mmsg/Socket/Datagram/Interruptible/MutableBytes/Many.hs new file mode 100644 --- /dev/null +++ b/src-no-mmsg/Socket/Datagram/Interruptible/MutableBytes/Many.hs @@ -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 diff --git a/src-no-mmsg/Socket/Datagram/Uninterruptible/MutableBytes/Many.hs b/src-no-mmsg/Socket/Datagram/Uninterruptible/MutableBytes/Many.hs new file mode 100644 --- /dev/null +++ b/src-no-mmsg/Socket/Datagram/Uninterruptible/MutableBytes/Many.hs @@ -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 diff --git a/src-noerr/Socket/Error.hs b/src-noerr/Socket/Error.hs new file mode 100644 --- /dev/null +++ b/src-noerr/Socket/Error.hs @@ -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"))) diff --git a/src-production/Socket/Debug.hs b/src-production/Socket/Debug.hs --- a/src-production/Socket/Debug.hs +++ b/src-production/Socket/Debug.hs @@ -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 diff --git a/src-stream-receive/Stream/Receive.hsig b/src-stream-receive/Stream/Receive.hsig new file mode 100644 --- /dev/null +++ b/src-stream-receive/Stream/Receive.hsig @@ -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) diff --git a/src-stream-receive/Stream/Receive/Indefinite.hs b/src-stream-receive/Stream/Receive/Indefinite.hs new file mode 100644 --- /dev/null +++ b/src-stream-receive/Stream/Receive/Indefinite.hs @@ -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 ++ ")" + + diff --git a/src-stream-send-two/Stream/Send/B.hsig b/src-stream-send-two/Stream/Send/B.hsig new file mode 100644 --- /dev/null +++ b/src-stream-send-two/Stream/Send/B.hsig @@ -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) diff --git a/src-stream-send-two/Stream/Send/Buffer/A.hsig b/src-stream-send-two/Stream/Send/Buffer/A.hsig new file mode 100644 --- /dev/null +++ b/src-stream-send-two/Stream/Send/Buffer/A.hsig @@ -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 diff --git a/src-stream-send-two/Stream/Send/Buffer/B.hsig b/src-stream-send-two/Stream/Send/Buffer/B.hsig new file mode 100644 --- /dev/null +++ b/src-stream-send-two/Stream/Send/Buffer/B.hsig @@ -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 diff --git a/src-stream-send-two/Stream/Send/Two.hsig b/src-stream-send-two/Stream/Send/Two.hsig new file mode 100644 --- /dev/null +++ b/src-stream-send-two/Stream/Send/Two.hsig @@ -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) diff --git a/src-stream-send-two/Stream/Send/Two/Indefinite.hs b/src-stream-send-two/Stream/Send/Two/Indefinite.hs new file mode 100644 --- /dev/null +++ b/src-stream-send-two/Stream/Send/Two/Indefinite.hs @@ -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 ++ ")" diff --git a/src-stream-send/Stream/Send.hsig b/src-stream-send/Stream/Send.hsig new file mode 100644 --- /dev/null +++ b/src-stream-send/Stream/Send.hsig @@ -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) diff --git a/src-stream-send/Stream/Send/Indefinite.hs b/src-stream-send/Stream/Send/Indefinite.hs new file mode 100644 --- /dev/null +++ b/src-stream-send/Stream/Send/Indefinite.hs @@ -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 ++ ")" + + diff --git a/src/Socket.hs b/src/Socket.hs deleted file mode 100644 --- a/src/Socket.hs +++ /dev/null @@ -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" diff --git a/src/Socket/Address.hs b/src/Socket/Address.hs new file mode 100644 --- /dev/null +++ b/src/Socket/Address.hs @@ -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) + } diff --git a/src/Socket/Datagram.hs b/src/Socket/Datagram.hs deleted file mode 100644 --- a/src/Socket/Datagram.hs +++ /dev/null @@ -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) diff --git a/src/Socket/Datagram/IPv4/Connected.hs b/src/Socket/Datagram/IPv4/Connected.hs new file mode 100644 --- /dev/null +++ b/src/Socket/Datagram/IPv4/Connected.hs @@ -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) diff --git a/src/Socket/Datagram/IPv4/Spoof.hs b/src/Socket/Datagram/IPv4/Spoof.hs deleted file mode 100644 --- a/src/Socket/Datagram/IPv4/Spoof.hs +++ /dev/null @@ -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] - diff --git a/src/Socket/Datagram/IPv4/Unconnected.hs b/src/Socket/Datagram/IPv4/Unconnected.hs new file mode 100644 --- /dev/null +++ b/src/Socket/Datagram/IPv4/Unconnected.hs @@ -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) diff --git a/src/Socket/Datagram/IPv4/Undestined.hs b/src/Socket/Datagram/IPv4/Undestined.hs deleted file mode 100644 --- a/src/Socket/Datagram/IPv4/Undestined.hs +++ /dev/null @@ -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] - diff --git a/src/Socket/Datagram/IPv4/Undestined/Internal.hs b/src/Socket/Datagram/IPv4/Undestined/Internal.hs deleted file mode 100644 --- a/src/Socket/Datagram/IPv4/Undestined/Internal.hs +++ /dev/null @@ -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) - - diff --git a/src/Socket/Datagram/Interruptible/Bytes.hs b/src/Socket/Datagram/Interruptible/Bytes.hs new file mode 100644 --- /dev/null +++ b/src/Socket/Datagram/Interruptible/Bytes.hs @@ -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) diff --git a/src/Socket/Datagram/Interruptible/MutableBytes.hs b/src/Socket/Datagram/Interruptible/MutableBytes.hs new file mode 100644 --- /dev/null +++ b/src/Socket/Datagram/Interruptible/MutableBytes.hs @@ -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 + diff --git a/src/Socket/Datagram/Slab.hs b/src/Socket/Datagram/Slab.hs new file mode 100644 --- /dev/null +++ b/src/Socket/Datagram/Slab.hs @@ -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 diff --git a/src/Socket/Datagram/Uninterruptible/Bytes.hs b/src/Socket/Datagram/Uninterruptible/Bytes.hs new file mode 100644 --- /dev/null +++ b/src/Socket/Datagram/Uninterruptible/Bytes.hs @@ -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) diff --git a/src/Socket/Datagram/Uninterruptible/MutableBytes.hs b/src/Socket/Datagram/Uninterruptible/MutableBytes.hs new file mode 100644 --- /dev/null +++ b/src/Socket/Datagram/Uninterruptible/MutableBytes.hs @@ -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 + diff --git a/src/Socket/IPv4.hs b/src/Socket/IPv4.hs deleted file mode 100644 --- a/src/Socket/IPv4.hs +++ /dev/null @@ -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 - -- - -- 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 diff --git a/src/Socket/Stream.hs b/src/Socket/Stream.hs deleted file mode 100644 --- a/src/Socket/Stream.hs +++ /dev/null @@ -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 --- --- 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 --- --- 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 - -- . - -- 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 --- 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) diff --git a/src/Socket/Stream/IPv4.hs b/src/Socket/Stream/IPv4.hs --- a/src/Socket/Stream/IPv4.hs +++ b/src/Socket/Stream/IPv4.hs @@ -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 diff --git a/src/Socket/Stream/Interruptible/Addr.hs b/src/Socket/Stream/Interruptible/Addr.hs new file mode 100644 --- /dev/null +++ b/src/Socket/Stream/Interruptible/Addr.hs @@ -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 diff --git a/src/Socket/Stream/Interruptible/ByteString.hs b/src/Socket/Stream/Interruptible/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Socket/Stream/Interruptible/ByteString.hs @@ -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 diff --git a/src/Socket/Stream/Interruptible/Bytes.hs b/src/Socket/Stream/Interruptible/Bytes.hs new file mode 100644 --- /dev/null +++ b/src/Socket/Stream/Interruptible/Bytes.hs @@ -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 diff --git a/src/Socket/Stream/Interruptible/Hybrid.hs b/src/Socket/Stream/Interruptible/Hybrid.hs new file mode 100644 --- /dev/null +++ b/src/Socket/Stream/Interruptible/Hybrid.hs @@ -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 diff --git a/src/Socket/Stream/Interruptible/MutableBytes.hs b/src/Socket/Stream/Interruptible/MutableBytes.hs new file mode 100644 --- /dev/null +++ b/src/Socket/Stream/Interruptible/MutableBytes.hs @@ -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 diff --git a/src/Socket/Stream/Uninterruptible/Addr.hs b/src/Socket/Stream/Uninterruptible/Addr.hs new file mode 100644 --- /dev/null +++ b/src/Socket/Stream/Uninterruptible/Addr.hs @@ -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 diff --git a/src/Socket/Stream/Uninterruptible/ByteString.hs b/src/Socket/Stream/Uninterruptible/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/Socket/Stream/Uninterruptible/ByteString.hs @@ -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 + diff --git a/src/Socket/Stream/Uninterruptible/Bytes.hs b/src/Socket/Stream/Uninterruptible/Bytes.hs new file mode 100644 --- /dev/null +++ b/src/Socket/Stream/Uninterruptible/Bytes.hs @@ -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 + diff --git a/src/Socket/Stream/Uninterruptible/Hybrid.hs b/src/Socket/Stream/Uninterruptible/Hybrid.hs new file mode 100644 --- /dev/null +++ b/src/Socket/Stream/Uninterruptible/Hybrid.hs @@ -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# + diff --git a/src/Socket/Stream/Uninterruptible/MutableBytes.hs b/src/Socket/Stream/Uninterruptible/MutableBytes.hs new file mode 100644 --- /dev/null +++ b/src/Socket/Stream/Uninterruptible/MutableBytes.hs @@ -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# diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 + +