diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,44 @@ +2025-02-04 Laurent P. René de Cotret 0.5.9 + +* Prevent asynchronous exceptions from `Network.Transport.Util.spawn` (#42). +* Addressed some compilation warnings (#467) + +2024-09-03 Laurent P. René de Cotret 0.5.8 + +* Bumped dependency bounds to support GHC 8.10.7 - GHC 9.10.1 +* Updated links to point to Distributed Haskell monorepo + +2024-03-25 David Simmons-Duffin 0.5.7 + +* Bump bytestring and deepseq versions to build with GHC 9.8. + +2022-08-30 Facundo Domínguez 0.5.6 + +* Fix extension fields in the cabal file (#41). + +2022-08-09 Facundo Domínguez 0.5.5 + +* Relax dependency bounds to build with ghc9 (#40). + +2019-05-12 Facundo Domínguez 0.5.4 + +* Fix documentation typo (#39). + +2019-05-12 Facundo Domínguez 0.5.3 + +* Relax upper bound of hashable. + +2017-07-25 Facundo Domínguez 0.5.2 + +* prependLength checks for overflow (5608f0f) +* Drop inlinePerformIO for unsafeDupablePerformIO (18bf80c) +* Have travis build n-t even with no tests (7ffe43e) + +2017-02-23 Facundo Domínguez 0.5.1 + +* Add {encode|decode}{Word|Enum|Num}{32|16}. +* Removed {encode|decode}Int{32|16} + 2016-01-28 Facundo Domínguez 0.4.4.0 * Add compatibility with ghc-8. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/network-transport.cabal b/network-transport.cabal --- a/network-transport.cabal +++ b/network-transport.cabal @@ -1,15 +1,15 @@ +cabal-version: 3.0 Name: network-transport -Version: 0.4.4.0 -Cabal-Version: >=1.6 +Version: 0.5.9 Build-Type: Simple -License: BSD3 +License: BSD-3-Clause License-File: LICENSE Copyright: Well-Typed LLP Author: Duncan Coutts, Nicolas Wu, Edsko de Vries -Maintainer: Facundo Domínguez +maintainer: The Distributed Haskell team Stability: experimental -Homepage: http://haskell-distributed.github.com -Bug-Reports: https://github.com/haskell-distributed/network-transport/issues +Homepage: https://haskell-distributed.github.io +Bug-Reports: https://github.com/haskell-distributed/distributed-process/issues Synopsis: Network abstraction layer Description: "Network.Transport" is a Network Abstraction Layer which provides the following high-level concepts: @@ -23,7 +23,7 @@ using the 'EndPointAddress' of the remote end. . * The 'EndPointAddress' can be serialised and sent over the - network, where as 'EndPoint's and connections cannot. + network, whereas 'EndPoint's and connections cannot. . * Connections between 'EndPoint's are unidirectional and lightweight. . @@ -55,33 +55,46 @@ This package provides the generic interface only; you will probably also want to install at least one transport implementation (network-transport-*). -Tested-With: GHC==7.6.3 GHC==7.8.4 GHC==7.10.3 +tested-with: GHC==8.10.7 GHC==9.0.2 GHC==9.2.8 GHC==9.4.5 GHC==9.6.4 GHC==9.8.2 GHC==9.10.1 GHC==9.12.1 Category: Network -extra-source-files: ChangeLog +extra-doc-files: ChangeLog -Source-Repository head +source-repository head Type: git - Location: https://github.com/haskell-distributed/network-transport + Location: https://github.com/haskell-distributed/distributed-process + SubDir: packages/network-transport +common warnings + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wredundant-constraints + -fhide-source-paths + -Wpartial-fields + -Wunused-packages + Library - Build-Depends: base >= 4.3 && < 5, - binary >= 0.5 && < 0.9, - bytestring >= 0.9 && < 0.11, - hashable >= 1.2.0.5 && < 1.3, - transformers >= 0.2 && < 0.6, - deepseq >= 1.0 && < 1.5 - if impl(ghc < 7.6) - Build-Depends: ghc-prim >= 0.2 && < 0.4 - Exposed-Modules: Network.Transport, + import: warnings + Build-Depends: base >= 4.14 && < 5, + binary >= 0.8 && < 0.9, + bytestring >= 0.10 && < 0.13, + hashable >= 1.2.0.5 && < 1.6, + transformers >= 0.2 && < 0.7, + deepseq >= 1.0 && < 1.7 + Exposed-Modules: Network.Transport Network.Transport.Util Network.Transport.Internal - Extensions: ForeignFunctionInterface, + Other-Extensions: ForeignFunctionInterface + Default-Extensions: RankNTypes, ScopedTypeVariables, DeriveDataTypeable, GeneralizedNewtypeDeriving, CPP - GHC-Options: -Wall -fno-warn-unused-do-bind + GHC-Options: -fno-warn-unused-do-bind HS-Source-Dirs: src + Default-Language: Haskell2010 if os(win32) extra-libraries: ws2_32 diff --git a/src/Network/Transport.hs b/src/Network/Transport.hs --- a/src/Network/Transport.hs +++ b/src/Network/Transport.hs @@ -29,7 +29,6 @@ import qualified Data.ByteString.Char8 as BSC (unpack) import Control.DeepSeq (NFData(rnf)) import Control.Exception (Exception) -import Control.Applicative ((<$>)) import Data.Typeable (Typeable) import Data.Binary (Binary(..)) import Data.Hashable diff --git a/src/Network/Transport/Internal.hs b/src/Network/Transport/Internal.hs --- a/src/Network/Transport/Internal.hs +++ b/src/Network/Transport/Internal.hs @@ -1,10 +1,15 @@ +{-# LANGUAGE CPP #-} -- | Internal functions module Network.Transport.Internal ( -- * Encoders/decoders - encodeInt32 - , decodeInt32 - , encodeInt16 - , decodeInt16 + encodeWord32 + , decodeWord32 + , encodeEnum32 + , decodeNum32 + , encodeWord16 + , decodeWord16 + , encodeEnum16 + , decodeNum16 , prependLength -- * Miscellaneous abstractions , mapIOException @@ -19,20 +24,16 @@ , tlog ) where -#if ! MIN_VERSION_base(4,6,0) -import Prelude hiding (catch) -#endif - import Foreign.Storable (pokeByteOff, peekByteOff) -import Foreign.C (CInt(..), CShort(..)) import Foreign.ForeignPtr (withForeignPtr) import Data.ByteString (ByteString) +import Data.List(foldl') import qualified Data.ByteString as BS (length) import qualified Data.ByteString.Internal as BSI ( unsafeCreate , toForeignPtr - , inlinePerformIO ) +import Data.Word (Word32, Word16) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Exception ( IOException @@ -48,62 +49,96 @@ import Control.Concurrent (ThreadId, forkIO) import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar) import GHC.IO (unsafeUnmask) +import System.IO.Unsafe (unsafeDupablePerformIO) import System.Timeout (timeout) --import Control.Concurrent (myThreadId) #ifdef mingw32_HOST_OS -foreign import stdcall unsafe "htonl" htonl :: CInt -> CInt -foreign import stdcall unsafe "ntohl" ntohl :: CInt -> CInt -foreign import stdcall unsafe "htons" htons :: CShort -> CShort -foreign import stdcall unsafe "ntohs" ntohs :: CShort -> CShort +foreign import stdcall unsafe "htonl" htonl :: Word32 -> Word32 +foreign import stdcall unsafe "ntohl" ntohl :: Word32 -> Word32 +foreign import stdcall unsafe "htons" htons :: Word16 -> Word16 +foreign import stdcall unsafe "ntohs" ntohs :: Word16 -> Word16 #else -foreign import ccall unsafe "htonl" htonl :: CInt -> CInt -foreign import ccall unsafe "ntohl" ntohl :: CInt -> CInt -foreign import ccall unsafe "htons" htons :: CShort -> CShort -foreign import ccall unsafe "ntohs" ntohs :: CShort -> CShort +foreign import ccall unsafe "htonl" htonl :: Word32 -> Word32 +foreign import ccall unsafe "ntohl" ntohl :: Word32 -> Word32 +foreign import ccall unsafe "htons" htons :: Word16 -> Word16 +foreign import ccall unsafe "ntohs" ntohs :: Word16 -> Word16 #endif -- | Serialize 32-bit to network byte order -encodeInt32 :: Enum a => a -> ByteString -encodeInt32 i32 = +encodeWord32 :: Word32 -> ByteString +encodeWord32 w32 = BSI.unsafeCreate 4 $ \p -> - pokeByteOff p 0 (htonl . fromIntegral . fromEnum $ i32) + pokeByteOff p 0 (htonl w32) -- | Deserialize 32-bit from network byte order --- Throws an IO exception if this is not a valid integer. -decodeInt32 :: Num a => ByteString -> a -decodeInt32 bs - | BS.length bs /= 4 = throw $ userError "decodeInt32: Invalid length" - | otherwise = BSI.inlinePerformIO $ do +-- Throws an IO exception if this is not exactly 32 bits. +decodeWord32 :: ByteString -> Word32 +decodeWord32 bs + | BS.length bs /= 4 = throw $ userError "decodeWord32: not 4 bytes" + | otherwise = unsafeDupablePerformIO $ do let (fp, offset, _) = BSI.toForeignPtr bs - withForeignPtr fp $ \p -> do - w32 <- peekByteOff p offset - return (fromIntegral . ntohl $ w32) + withForeignPtr fp $ \p -> ntohl <$> peekByteOff p offset -- | Serialize 16-bit to network byte order -encodeInt16 :: Enum a => a -> ByteString -encodeInt16 i16 = +encodeWord16 :: Word16 -> ByteString +encodeWord16 w16 = BSI.unsafeCreate 2 $ \p -> - pokeByteOff p 0 (htons . fromIntegral . fromEnum $ i16) + pokeByteOff p 0 (htons w16) -- | Deserialize 16-bit from network byte order --- Throws an IO exception if this is not a valid integer -decodeInt16 :: Num a => ByteString -> a -decodeInt16 bs - | BS.length bs /= 2 = throw $ userError "decodeInt16: Invalid length" - | otherwise = BSI.inlinePerformIO $ do +-- Throws an IO exception if this is not exactly 16 bits. +decodeWord16 :: ByteString -> Word16 +decodeWord16 bs + | BS.length bs /= 2 = throw $ userError "decodeWord16: not 2 bytes" + | otherwise = unsafeDupablePerformIO $ do let (fp, offset, _) = BSI.toForeignPtr bs - withForeignPtr fp $ \p -> do - w16 <- peekByteOff p offset - return (fromIntegral . ntohs $ w16) + withForeignPtr fp $ \p -> ntohs <$> peekByteOff p offset +-- | Encode an Enum in 32 bits by encoding its signed Int equivalent (beware +-- of truncation, an Enum may contain more than 2^32 points). +encodeEnum32 :: Enum a => a -> ByteString +encodeEnum32 = encodeWord32 . fromIntegral . fromEnum + +-- | Decode any Num type from 32 bits by using fromIntegral to convert from +-- a Word32. +decodeNum32 :: Num a => ByteString -> a +decodeNum32 = fromIntegral . decodeWord32 + +-- | Encode an Enum in 16 bits by encoding its signed Int equivalent (beware +-- of truncation, an Enum may contain more than 2^16 points). +encodeEnum16 :: Enum a => a -> ByteString +encodeEnum16 = encodeWord16 . fromIntegral . fromEnum + +-- | Decode any Num type from 16 bits by using fromIntegral to convert from +-- a Word16. +decodeNum16 :: Num a => ByteString -> a +decodeNum16 = fromIntegral . decodeWord16 + -- | Prepend a list of bytestrings with their total length +-- Will be an exception in case of overflow: the sum of the lengths of +-- the ByteStrings overflows Int, or that sum overflows Word32. prependLength :: [ByteString] -> [ByteString] -prependLength bss = encodeInt32 (sum . map BS.length $ bss) : bss +prependLength bss = case word32Length of + Nothing -> overflow + Just w32 -> encodeWord32 w32 : bss + where + intLength :: Int + intLength = foldl' safeAdd 0 . map BS.length $ bss + word32Length :: Maybe Word32 + word32Length = tryToEnum intLength + -- Non-negative integer addition with overflow check. + safeAdd :: Int -> Int -> Int + safeAdd i j + | r >= 0 = r + | otherwise = overflow + where + r = i + j + overflow = throw $ userError "prependLength: input is too long (overflow)" -- | Translate exceptions that arise in IO computations mapIOException :: Exception e => (IOException -> e) -> IO a -> IO a diff --git a/src/Network/Transport/Util.hs b/src/Network/Transport/Util.hs --- a/src/Network/Transport/Util.hs +++ b/src/Network/Transport/Util.hs @@ -11,23 +11,18 @@ ) import Control.Exception (throwIO) import Control.Concurrent (forkIO) -import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) --- | Fork a new thread, create a new end point on that thread, and run the specified IO operation on that thread. +-- | Create a new end point, fork a new thread, and run the specified IO operation on that thread. -- -- Returns the address of the new end point. spawn :: Transport -> (EndPoint -> IO ()) -> IO EndPointAddress spawn transport proc = do - addrMVar <- newEmptyMVar - forkIO $ do - mEndPoint <- newEndPoint transport - case mEndPoint of - Left err -> - putMVar addrMVar (Left err) - Right endPoint -> do - putMVar addrMVar (Right (address endPoint)) - proc endPoint - mAddr <- takeMVar addrMVar - case mAddr of - Left err -> throwIO err - Right addr -> return addr + -- `newEndPoint` used to be done in a separate thread, in case it was slow. + -- However, in this case, care must be taken to appropriately handle asynchronous exceptions. + -- Instead, for reliability, we now create the new endpoint in this thread. + mEndPoint <- newEndPoint transport + case mEndPoint of + Left err -> throwIO err + Right endPoint -> do + forkIO $ proc endPoint + return $ address endPoint