git.iko.soy/streamly
on master help sign in
Close the socket on exception
96aa91dHarendra Kumar
src/Streamly/Internal/Network/Socket.hs+16−11
compare with master
unifiedsplit
@@ -66,6 +66,7 @@ module Streamly.Internal.Network.Socket
66where
66where
67
67
68import Control.Concurrent (threadWaitWrite, rtsSupportsBoundThreads)
68import Control.Concurrent (threadWaitWrite, rtsSupportsBoundThreads)
69+import Control.Exception (onException)
69import Control.Monad.Catch (MonadCatch, finally, MonadMask)
70import Control.Monad.Catch (MonadCatch, finally, MonadMask)
70import Control.Monad.IO.Class (MonadIO(..))
71import Control.Monad.IO.Class (MonadIO(..))
71import Control.Monad (when)
72import Control.Monad (when)
@@ -146,21 +147,26 @@ initListener :: Int -> SockSpec -> SockAddr -> IO Socket
146initListener listenQLen SockSpec{..} addr =
147initListener listenQLen SockSpec{..} addr =
147 withSocketsDo $ do
148 withSocketsDo $ do
148 sock <- socket sockFamily sockType sockProto
149 sock <- socket sockFamily sockType sockProto
149− mapM_ (\(opt, val) -> setSocketOption sock opt val) sockOpts
150+ use sock `onException` Net.close sock
150− bind sock addr
151− Net.listen sock listenQLen
152 return sock
151 return sock
153
152
153+ where
154+
155+ use sock = do
156+ mapM_ (\(opt, val) -> setSocketOption sock opt val) sockOpts
157+ bind sock addr
158+ Net.listen sock listenQLen
159+
154{-# INLINE listenTuples #-}
160{-# INLINE listenTuples #-}
155listenTuples :: MonadIO m
161listenTuples :: MonadIO m
156 => Unfold m (Int, SockSpec, SockAddr) (Socket, SockAddr)
162 => Unfold m (Int, SockSpec, SockAddr) (Socket, SockAddr)
157listenTuples = Unfold step inject
163listenTuples = Unfold step inject
158 where
164 where
165+ inject (listenQLen, spec, addr) =
159− inject (listenQLen, spec, addr) = liftIO $ initListener listenQLen spec addr
166+ liftIO $ initListener listenQLen spec addr
160
167
161 step listener = do
168 step listener = do
162− r <- liftIO $ Net.accept listener
169+ r <- liftIO $ (Net.accept listener `onException` Net.close listener)
163− -- XXX error handling
164 return $ D.Yield r listener
170 return $ D.Yield r listener
165
171
166-- | Unfold a three tuple @(listenQLen, spec, addr)@ into a stream of connected
172-- | Unfold a three tuple @(listenQLen, spec, addr)@ into a stream of connected
@@ -185,13 +191,11 @@ recvConnectionTuplesWith tcpListenQ spec addr = S.unfoldrM step Nothing
185 where
191 where
186 step Nothing = do
192 step Nothing = do
187 listener <- liftIO $ initListener tcpListenQ spec addr
193 listener <- liftIO $ initListener tcpListenQ spec addr
188− r <- liftIO $ Net.accept listener
194+ r <- liftIO $ (Net.accept listener `onException` Net.close listener)
189− -- XXX error handling
190 return $ Just (r, Just listener)
195 return $ Just (r, Just listener)
191
196
192 step (Just listener) = do
197 step (Just listener) = do
193− r <- liftIO $ Net.accept listener
198+ r <- liftIO $ (Net.accept listener `onException` Net.close listener)
194− -- XXX error handling
195 return $ Just (r, Just listener)
199 return $ Just (r, Just listener)
196
200
197-- | Start a TCP stream server that listens for connections on the supplied
201-- | Start a TCP stream server that listens for connections on the supplied
@@ -202,7 +206,8 @@ recvConnectionTuplesWith tcpListenQ spec addr = S.unfoldrM step Nothing
202-- /Internal/
206-- /Internal/
203{-# INLINE connections #-}
207{-# INLINE connections #-}
204connections :: MonadAsync m => Int -> SockSpec -> SockAddr -> SerialT m Socket
208connections :: MonadAsync m => Int -> SockSpec -> SockAddr -> SerialT m Socket
209+connections tcpListenQ spec addr =
205−connections tcpListenQ spec addr = fst <$> recvConnectionTuplesWith tcpListenQ spec addr
210+ fst <$> recvConnectionTuplesWith tcpListenQ spec addr
206
211
207-------------------------------------------------------------------------------
212-------------------------------------------------------------------------------
208-- Array IO (Input)
213-- Array IO (Input)