packages feed

network-socket-options 0.1 → 0.2

raw patch · 4 files changed

+239/−7 lines, 4 files

Files

Network/Socket/Options.hsc view
@@ -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
network-socket-options.cabal view
@@ -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
+ testing/Log.hs view
@@ -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)
+ testing/hang.hs view
@@ -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..]