diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +## Version 3.2.5.0 + +* `gracefulClose` based on STM racing and `timeout`. + [#587](https://github.com/haskell/network/issues/587) + ## Version 3.2.4.0 * New API: setSockOptValue. diff --git a/Network/Socket/Shutdown.hs b/Network/Socket/Shutdown.hs --- a/Network/Socket/Shutdown.hs +++ b/Network/Socket/Shutdown.hs @@ -8,14 +8,20 @@ , gracefulClose ) where +import Control.Concurrent (yield) import qualified Control.Exception as E import Foreign.Marshal.Alloc (mallocBytes, free) +import System.Timeout -import Control.Concurrent (threadDelay, yield) +#if !defined(mingw32_HOST_OS) +import Control.Concurrent.STM +import qualified GHC.Event as Ev +#endif import Network.Socket.Buffer import Network.Socket.Imports import Network.Socket.Internal +import Network.Socket.STM import Network.Socket.Types data ShutdownCmd = ShutdownReceive @@ -59,19 +65,57 @@ -- FIN arrives meanwhile. yield -- Waiting TCP FIN. - E.bracket (mallocBytes bufSize) free recvEOFloop - recvEOFloop buf = loop 1 0 - where - loop delay tmout = do - -- We don't check the (positive) length. - -- In normal case, it's 0. That is, only FIN is received. - -- In error cases, data is available. But there is no - -- application which can read it. So, let's stop receiving - -- to prevent attacks. - r <- recvBufNoWait s buf bufSize - when (r == -1 && tmout < tmout0) $ do - threadDelay (delay * 1000) - loop (delay * 2) (tmout + delay) - -- Don't use 4092 here. The GHC runtime takes the global lock - -- if the length is over 3276 bytes in 32bit or 3272 bytes in 64bit. - bufSize = 1024 + E.bracket (mallocBytes bufSize) free (recvEOF s tmout0) + +recvEOF :: Socket -> Int -> Ptr Word8 -> IO () +#if !defined(mingw32_HOST_OS) +recvEOF s tmout0 buf = do + mevmgr <- Ev.getSystemEventManager + case mevmgr of + Nothing -> recvEOFloop s tmout0 buf + Just _ -> recvEOFevent s tmout0 buf +#else +recvEOF = recvEOFloop +#endif + +-- Don't use 4092 here. The GHC runtime takes the global lock +-- if the length is over 3276 bytes in 32bit or 3272 bytes in 64bit. +bufSize :: Int +bufSize = 1024 + +recvEOFloop :: Socket -> Int -> Ptr Word8 -> IO () +recvEOFloop s tmout0 buf = void $ timeout tmout0 $ recvBuf s buf bufSize + +#if !defined(mingw32_HOST_OS) +data Wait = MoreData | TimeoutTripped + +recvEOFevent :: Socket -> Int -> Ptr Word8 -> IO () +recvEOFevent s tmout0 buf = do + tmmgr <- Ev.getSystemTimerManager + tvar <- newTVarIO False + E.bracket (setup tmmgr tvar) teardown $ \(wait, _) -> do + waitRes <- wait + case waitRes of + TimeoutTripped -> return () + -- We don't check the (positive) length. + -- In normal case, it's 0. That is, only FIN is received. + -- In error cases, data is available. But there is no + -- application which can read it. So, let's stop receiving + -- to prevent attacks. + MoreData -> void $ recvBufNoWait s buf bufSize + where + setup tmmgr tvar = do + -- millisecond to microsecond + key <- Ev.registerTimeout tmmgr (tmout0 * 1000) $ + atomically $ writeTVar tvar True + (evWait, evCancel) <- waitAndCancelReadSocketSTM s + let toWait = do + tmout <- readTVar tvar + check tmout + toCancel = Ev.unregisterTimeout tmmgr key + wait = atomically ((toWait >> return TimeoutTripped) + <|> (evWait >> return MoreData)) + cancel = evCancel >> toCancel + return (wait, cancel) + teardown (_, cancel) = cancel +#endif diff --git a/configure b/configure --- a/configure +++ b/configure @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.72 for Haskell network package 3.2.4.0. +# Generated by GNU Autoconf 2.72 for Haskell network package 3.2.5.0. # # Report bugs to . # @@ -603,8 +603,8 @@ # Identity of this package. PACKAGE_NAME='Haskell network package' PACKAGE_TARNAME='network' -PACKAGE_VERSION='3.2.4.0' -PACKAGE_STRING='Haskell network package 3.2.4.0' +PACKAGE_VERSION='3.2.5.0' +PACKAGE_STRING='Haskell network package 3.2.5.0' PACKAGE_BUGREPORT='libraries@haskell.org' PACKAGE_URL='' @@ -1258,7 +1258,7 @@ # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -'configure' configures Haskell network package 3.2.4.0 to adapt to many kinds of systems. +'configure' configures Haskell network package 3.2.5.0 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1324,7 +1324,7 @@ if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of Haskell network package 3.2.4.0:";; + short | recursive ) echo "Configuration of Haskell network package 3.2.5.0:";; esac cat <<\_ACEOF @@ -1409,7 +1409,7 @@ test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -Haskell network package configure 3.2.4.0 +Haskell network package configure 3.2.5.0 generated by GNU Autoconf 2.72 Copyright (C) 2023 Free Software Foundation, Inc. @@ -1809,7 +1809,7 @@ This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by Haskell network package $as_me 3.2.4.0, which was +It was created by Haskell network package $as_me 3.2.5.0, which was generated by GNU Autoconf 2.72. Invocation command line was $ $0$ac_configure_args_raw @@ -4699,7 +4699,7 @@ # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by Haskell network package $as_me 3.2.4.0, which was +This file was extended by Haskell network package $as_me 3.2.5.0, which was generated by GNU Autoconf 2.72. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -4754,7 +4754,7 @@ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config='$ac_cs_config_escaped' ac_cs_version="\\ -Haskell network package config.status 3.2.4.0 +Haskell network package config.status 3.2.5.0 configured by $0, generated by GNU Autoconf 2.72, with options \\"\$ac_cs_config\\" diff --git a/configure.ac b/configure.ac --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ AC_INIT([Haskell network package], - [3.2.4.0], + [3.2.5.0], [libraries@haskell.org], [network]) diff --git a/network.cabal b/network.cabal --- a/network.cabal +++ b/network.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: network -version: 3.2.4.0 +version: 3.2.5.0 license: BSD3 license-file: LICENSE maintainer: Kazu Yamamoto, Tamar Christina