diff --git a/Network/Socket/Options.hsc b/Network/Socket/Options.hsc --- a/Network/Socket/Options.hsc +++ b/Network/Socket/Options.hsc @@ -7,7 +7,7 @@ -- -- Documentation is currently lacking. For now, see @man 7 socket@ and -- @man 7 tcp@ of the Linux man-pages, or look up setsockopt in MSDN. -{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE CPP, ForeignFunctionInterface #-} module Network.Socket.Options ( -- * Getting options @@ -49,6 +49,13 @@ HasSocket(..), Seconds, Microseconds, + + -- * Setting socket timeouts + -- $timeouts + setSocketTimeouts, +##ifdef __GLASGOW_HASKELL__ + setHandleTimeouts, +##endif ) where #if mingw32_HOST_OS @@ -69,10 +76,17 @@ import Network.Socket.Internal (throwSocketErrorIfMinus1_) import System.Posix.Types (Fd(Fd)) -#ifdef __GLASGOW_HASKELL__ +##ifdef __GLASGOW_HASKELL__ import qualified GHC.IO.FD as FD -#endif +import System.IO (Handle) +##if mingw32_HOST_OS +import Data.Typeable (cast) +import GHC.IO.Handle.Internals (withHandle_) +import GHC.IO.Handle.Types (Handle__(Handle__, haDevice)) +##endif +##endif + -- | The getters and setters in this module can be used not only on 'Socket's, -- but on raw 'Fd's (file descriptors) as well. class HasSocket a where @@ -84,10 +98,10 @@ instance HasSocket Socket where getSocket = fdSocket -#ifdef __GLASGOW_HASKELL__ +##ifdef __GLASGOW_HASKELL__ instance HasSocket FD.FD where getSocket = FD.fdFD -#endif +##endif type Seconds = Int type Microseconds = Int64 @@ -309,3 +323,97 @@ -> CInt -- ^ l_onoff -> CInt -- ^ l_linger -> IO CInt + +------------------------------------------------------------------------ +-- Setting socket timeouts + +{- $timeouts + +The following functions are provided to work around a problem with network IO +on Windows. They are no-ops on other systems. Use them /in addition to/, not +/instead of/, asynchronous exceptions (e.g. "System.Timeout") to time out +network operations. + +The problem is that GHC currently does not have proper IO manager support for +Windows. On Unix, GHC uses non-blocking IO and @select@\/@epoll@\/@kqueue@ for +efficient multiplexing. On Windows, it uses blocking FFI (foreign function +interface) calls. An FFI call blocks the OS thread it is called from, and +cannot be interrupted by an asynchronous exception. This means that if a send +or receive operation hangs indefinitely, the thread hangs indefinitely, and +cannot be killed. Thus, the following timeout will not work on Windows, in a +program compiled with @-threaded@: + +@ +'System.Timeout.timeout' 120000000 $ 'Network.Socket.recv' sock len +@ + +In a program compiled without @-threaded@, the timeout will work, but it will +leak an OS thread until data arrives on the socket. + +We can work around the problem by performing the IO in another thread: + +>wrappedRecv :: Socket -> Int -> IO String +>wrappedRecv sock len = do +> mv <- newEmptyMVar +> bracket (forkIO $ recv sock len >>= putMVar mv) +> (forkIO . killThread) +> -- Call 'killThread' in a forked thread, as it will block until +> -- the exception has been delivered to the target thread. +> (\_ -> takeMVar mv) + +This will behave correctly, but it will leak an OS thread if +'Network.Socket.recv' hangs indefinitely. If about 1000 OS threads are hung on +'Network.Socket.recv' calls, the program will run out of address space and +crash (assuming 32-bit Windows, with default settings). + +Socket timeouts can be used to work around the problem. In a program compiled +for Windows with @-threaded@, when a receive or send operation times out, it +will fail with an exception, and will not leak an OS thread. Without +@-threaded@, it will leak an OS thread, unfortunately. + +Socket timeouts have no effect on 'Network.Socket.connect', which does seem to +time out on its own at some point. They also have no effect for +'System.IO.hWaitForInput' when an explicit timeout is given. + +-} + +-- | On Windows, set the socket's @SO_RCVTIMEO@ and @SO_SNDTIMEO@ values to the +-- ones given. On other platforms, do nothing. +setSocketTimeouts + :: HasSocket sock + => sock + -> Microseconds -- ^ Receive timeout + -> Microseconds -- ^ Send timeout + -> IO () +##if mingw32_HOST_OS +setSocketTimeouts sock recv_usec send_usec = do + setRecvTimeout sock recv_usec + setSendTimeout sock send_usec +##else +setSocketTimeouts _ _ _ = return () +##endif + + +##ifdef __GLASGOW_HASKELL__ + +-- | On Windows, set timeouts for a socket that has already been wrapped in a +-- 'Handle' by 'Network.connectTo' or 'Network.accept'. On other platforms, do +-- nothing. +setHandleTimeouts + :: Handle + -> Microseconds -- ^ Receive timeout + -> Microseconds -- ^ Send timeout + -> IO () +##if mingw32_HOST_OS +setHandleTimeouts h recv_usec send_usec = + withHandle_ "setHandleTimeouts" h $ \Handle__{haDevice = dev} -> + case cast dev of + Just fd | FD.fdIsSocket_ fd /= 0 -> do + setRecvTimeout fd recv_usec + setSendTimeout fd send_usec + _ -> return () +##else +setHandleTimeouts _ _ _ = return () +##endif + +##endif diff --git a/network-socket-options.cabal b/network-socket-options.cabal --- a/network-socket-options.cabal +++ b/network-socket-options.cabal @@ -1,5 +1,5 @@ name: network-socket-options -version: 0.1 +version: 0.2 synopsis: Type-safe, portable alternative to getSocketOption/setSocketOption description: The network package provides getSocketOption and setSocketOption functions. @@ -11,6 +11,9 @@ This package implements the getters and setters as separate functions. At the moment, it only provides socket options that are available for both Unix and Windows. + . + This package also provides a workaround needed to time out network + operations in Windows without leaking resources. homepage: https://github.com/joeyadams/haskell-network-socket-options license: BSD3 license-file: LICENSE @@ -22,6 +25,8 @@ cabal-version: >=1.8 extra-source-files: + testing/Log.hs + testing/hang.hs testing/trivial.hs source-repository head @@ -38,7 +43,7 @@ ghc-options: -Wall -fwarn-tabs - other-extensions: ForeignFunctionInterface + other-extensions: CPP, ForeignFunctionInterface build-depends: base == 4.* , network diff --git a/testing/Log.hs b/testing/Log.hs new file mode 100644 --- /dev/null +++ b/testing/Log.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Log ( + -- * Basic logging + logIO, + + -- * Logging with prepended context + MonadLog(..), + LogT(..), + withLogContext, +) where + +import Prelude hiding (log) + +import Control.Applicative (Applicative) +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.Trans.Reader (ReaderT(ReaderT)) +import Data.Time.LocalTime (getZonedTime) +import Data.Time.Format (formatTime) +import System.IO (hPutStrLn, stderr) +import System.Locale (defaultTimeLocale) + +-- | Write a message to standard error, prepending the time. +logIO :: String -> IO () +logIO msg = do + time <- getZonedTime + let time_str = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" time + hPutStrLn stderr $ time_str ++ " " ++ msg + +class Monad m => MonadLog m where + log :: String -> m () + +instance MonadLog IO where + log = logIO + +newtype LogT m a = LogT (ReaderT (String -> m ()) m a) + deriving (Functor, Applicative, Monad, MonadIO) + +instance MonadTrans LogT where + lift = LogT . ReaderT . const + +instance Monad m => MonadLog (LogT m) where + log msg = LogT $ ReaderT $ \f -> f msg + +withLogContext :: MonadLog m => String -> LogT m a -> m a +withLogContext ctx (LogT (ReaderT m)) = m (\msg -> log $ ctx ++ ": " ++ msg) diff --git a/testing/hang.hs b/testing/hang.hs new file mode 100644 --- /dev/null +++ b/testing/hang.hs @@ -0,0 +1,73 @@ +{- +When running this on Windows, watch the Handles and Threads counters in +Windows Task Manager. These are hidden by default, but can be displayed if you +go to View -> Select Columns. +-} +import Prelude hiding (log) +import Log + +import Control.Concurrent +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import Network +import Network.Socket.Options (setHandleTimeouts) +import System.IO + +class MonadFork m where + forkM :: m () -> m ThreadId + +instance MonadFork IO where + forkM = forkIO + +instance MonadFork m => MonadFork (LogT m) where + forkM (LogT (ReaderT m)) = LogT (ReaderT (forkM . m)) + +server :: Socket -> IO () +server sock = withLogContext "server" $ + let loop n = do + (h, host, port) <- liftIO $ accept sock + _ <- forkM $ withLogContext (show n) $ do + log $ "Received connection from " ++ host ++ ":" ++ show port + liftIO $ hSetBuffering h LineBuffering + log "Sending \"one\"" + liftIO $ hPutStrLn h "one" + log "Waiting 30 seconds" + liftIO $ threadDelay 30000000 + log "Sending \"two\"" + liftIO $ hPutStrLn h "two" + log "Closing the handle" + liftIO $ hClose h + log "Done" + loop $! n+1 + in loop (1 :: Integer) + +client :: Integer -> IO () +client n = withLogContext "client" $ + withLogContext (show n) $ do + log "Connecting to localhost:1234" + h <- liftIO $ connectTo "localhost" $ PortNumber 1234 + liftIO $ setHandleTimeouts h 1000000 1000000 + + log "Connected. Getting first line" + line1 <- liftIO $ hGetLine h + log $ "First line: " ++ line1 + + recv_tid <- forkM $ do + log "Getting second line" + line2 <- liftIO $ hGetLine h + log $ "Second line: " ++ line2 + + liftIO $ threadDelay 2000000 + log "Killing receiving thread" + liftIO $ killThread recv_tid + log "Done killing" + +main :: IO () +main = do + hSetBuffering stderr LineBuffering + + sock <- liftIO $ listenOn $ PortNumber 1234 + log "Listening on port 1234" + + _ <- forkIO $ server sock + mapM_ client [1..]