Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP

Loading…

Fix space leak caused by updateMeasure #8

Merged
merged 4 commits into from

2 participants

@joeyadams

updateMeasure calls modifyIORef, which does not force the value. Since the Measurement is almost never examined by the program, this results in a memory leak.

In a test program I wrote, a server sending thousands of packets to a client leaks memory pretty quickly (~150 bytes per send, on my 64-bit system). After applying the space leak fix in this pull request, the program successfully sent 1000000 messages to itself using just under 10MB.

This pull request also includes a couple other improvements:

  • Use modifyMVar in the usingState function. This is more concise as well as exception-safe.

  • Minor documentation fixes.

joeyadams added some commits
@joeyadams joeyadams Fix space leak caused by updateMeasure
modifyIORef does not force the value, so if the Measurement object is updated a
bunch of times but never examined, the program will leak memory.
23e91ae
@joeyadams joeyadams Use modifyMVar in usingState for exception safety
Also, force the state value, to avoid potential space leaks.
c1ce196
@joeyadams joeyadams Add links to the 'BufferMode' type in 'client' and 'server' cbfe10e
@joeyadams joeyadams Fix spelling of negotiate/negotiation in documentation 3d0071d
@vincenthz vincenthz merged commit 3d0071d into from
@vincenthz
Owner

thanks, nice catch for the leak and nice improvements

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Commits on Mar 10, 2012
  1. @joeyadams

    Fix space leak caused by updateMeasure

    joeyadams authored
    modifyIORef does not force the value, so if the Measurement object is updated a
    bunch of times but never examined, the program will leak memory.
  2. @joeyadams

    Use modifyMVar in usingState for exception safety

    joeyadams authored
    Also, force the state value, to avoid potential space leaks.
  3. @joeyadams
  4. @joeyadams
This page is out of date. Refresh to see the latest.
View
17 Network/TLS/Context.hs
@@ -56,7 +56,7 @@ import qualified Data.ByteString as B
import Control.Concurrent.MVar
import Control.Monad.State
-import Control.Exception (throwIO, Exception(), onException)
+import Control.Exception (throwIO, Exception())
import Data.IORef
import System.IO (Handle, hSetBuffering, BufferMode(..), hFlush)
import Prelude hiding (catch)
@@ -152,7 +152,9 @@ data TLSCtx a = TLSCtx
}
updateMeasure :: MonadIO m => TLSCtx c -> (Measurement -> Measurement) -> m ()
-updateMeasure ctx f = liftIO $ modifyIORef (ctxMeasurement ctx) f
+updateMeasure ctx f = liftIO $ do
+ x <- readIORef (ctxMeasurement ctx)
+ writeIORef (ctxMeasurement ctx) $! f x
withMeasure :: MonadIO m => TLSCtx c -> (Measurement -> IO a) -> m a
withMeasure ctx f = liftIO (readIORef (ctxMeasurement ctx) >>= f)
@@ -209,13 +211,10 @@ throwCore = liftIO . throwIO
usingState :: MonadIO m => TLSCtx c -> TLSSt a -> m (Either TLSError a)
-usingState ctx f = liftIO (takeMVar mvar) >>= \st -> liftIO $ onException (execAndStore st) (putMVar mvar st)
- where
- mvar = ctxState ctx
- execAndStore st = do
- let (a, newst) = runTLSState f st
- putMVar mvar newst
- return a
+usingState ctx f =
+ liftIO $ modifyMVar (ctxState ctx) $ \st ->
+ let (a, newst) = runTLSState f st
+ in newst `seq` return (newst, a)
usingState_ :: MonadIO m => TLSCtx c -> TLSSt a -> m a
usingState_ ctx f = do
View
12 Network/TLS/Core.hs
@@ -186,7 +186,7 @@ clientWith params rng connection flushF sendF recvF =
where st = (newTLSState rng) { stClientContext = True }
-- | Create a new Client context with a configuration, a RNG, and a Handle.
--- It reconfigures the handle buffermode to noBuffering
+-- It reconfigures the handle's 'System.IO.BufferMode' to @NoBuffering@.
client :: (MonadIO m, CryptoRandomGen g)
=> TLSParams -- ^ parameters to use for this context
-> g -- ^ random number generator associated with the context
@@ -202,7 +202,7 @@ serverWith params rng connection flushF sendF recvF =
where st = (newTLSState rng) { stClientContext = False }
-- | Create a new Server context with a configuration, a RNG, and a Handle.
--- It reconfigures the handle buffermode to noBuffering
+-- It reconfigures the handle's 'System.IO.BufferMode' to @NoBuffering@.
server :: (MonadIO m, CryptoRandomGen g) => TLSParams -> g -> Handle -> m (TLSCtx Handle)
server params rng handle = liftIO $ newCtx handle params st
where st = (newTLSState rng) { stClientContext = False }
@@ -477,7 +477,7 @@ handshakeServer ctx = do
_ -> fail ("unexpected handshake received, excepting client hello and received " ++ show hss)
-- | Handshake for a new TLS connection
--- This is to be called at the beginning of a connection, and during renegociation
+-- This is to be called at the beginning of a connection, and during renegotiation
handshake :: MonadIO m => TLSCtx c -> m ()
handshake ctx = do
cc <- usingState_ ctx (stClientContext <$> get)
@@ -500,17 +500,17 @@ sendData ctx dataToSend = checkValid ctx >> mapM_ sendDataChunk (L.toChunks data
sendDataChunk remain
| otherwise = sendPacket ctx $ AppData d
--- | recvData get data out of Data packet, and automatically renegociate if
+-- | recvData get data out of Data packet, and automatically renegotiate if
-- a Handshake ClientHello is received
recvData :: MonadIO m => TLSCtx c -> m B.ByteString
recvData ctx = do
checkValid ctx
pkt <- recvPacket ctx
case pkt of
- -- on server context receiving a client hello == renegociation
+ -- on server context receiving a client hello == renegotiation
Right (Handshake [ch@(ClientHello _ _ _ _ _ _)]) ->
handshakeServerWith ctx ch >> recvData ctx
- -- on client context, receiving a hello request == renegociation
+ -- on client context, receiving a hello request == renegotiation
Right (Handshake [HelloRequest]) ->
handshakeClient ctx >> recvData ctx
Right (Alert [(AlertLevel_Fatal, _)]) -> do
View
2  Network/TLS/Receiving.hs
@@ -104,7 +104,7 @@ processServerHello (ServerHello sver ran _ _ _ ex) = do
processServerHello _ = error "processServerHello called on wrong type"
-- process the client key exchange message. the protocol expects the initial
--- client version received in ClientHello, not the negociated version.
+-- client version received in ClientHello, not the negotiated version.
-- in case the version mismatch, generate a random master secret
processClientKeyXchg :: ByteString -> TLSSt ()
processClientKeyXchg encryptedPremaster = do
Something went wrong with that request. Please try again.