~singpolyma/haskell-gnutls

0d7a60a1cc0b05f96e2f727941903e95baeb5f99 — John Millikin 8 years ago 6456ba5
Fix a crash due to out-of-order garbage collection of Session values.

GnuTLS has separate initialization and deinitialization procedures for
global and per-session state. Previously, haskell-gnutls used Haskell's
garbage collector (via ForeignPtr) to manage these separate states by
creating a dummy GlobalState type representing an initialized global
state. The Session type contained ForeignPtrs to the global and session
state, with the idea that GC would collect them both at the same time
(albeit in non-determinstic order).

It turns out that session deinitialization *requires* an initialized
global state, and calling gnutls_deinit() after gnutls_global_deinit()
can cause a crash.

This patch solves the crash by removing the GlobalState ForeignPtr hack,
and ensuring that gnutls_global_deinit() is always called after
gnutls_deinit().

Originally reported by Keven McKenzie and Joey Hess.
1 files changed, 7 insertions(+), 9 deletions(-)

M lib/Network/Protocol/TLS/GNU.hs
M lib/Network/Protocol/TLS/GNU.hs => lib/Network/Protocol/TLS/GNU.hs +7 -9
@@ 68,20 68,17 @@ globalInitMVar :: M.MVar ()
{-# NOINLINE globalInitMVar #-}
globalInitMVar = unsafePerformIO $ M.newMVar ()

newtype GlobalState = GlobalState (F.ForeignPtr ())

globalInit :: ErrorT Error IO GlobalState
globalInit :: ErrorT Error IO ()
globalInit = do
	let init_ = M.withMVar globalInitMVar $ \_ -> F.gnutls_global_init
	let deinit = M.withMVar globalInitMVar $ \_ -> F.gnutls_global_deinit
	F.ReturnCode rc <- liftIO init_
	when (rc < 0) $ E.throwError $ mapError rc
	fp <- liftIO $ FC.newForeignPtr F.nullPtr deinit
	return $ GlobalState fp

globalDeinit :: IO ()
globalDeinit = M.withMVar globalInitMVar $ \_ -> F.gnutls_global_deinit

data Session = Session
	{ sessionPtr :: F.ForeignPtr F.Session
	, sessionGlobalState :: GlobalState
	
	-- TLS credentials are not copied into the gnutls session struct,
	-- so pointers to them must be kept alive until the credentials


@@ 122,7 119,7 @@ runClient transport tls = do

newSession :: Transport -> F.ConnectionEnd -> IO (Either Error Session)
newSession transport end = F.alloca $ \sPtr -> runErrorT $ do
	global <- globalInit
	globalInit
	F.ReturnCode rc <- liftIO $ F.gnutls_init sPtr end
	when (rc < 0) $ E.throwError $ mapError rc
	liftIO $ do


@@ 136,9 133,10 @@ newSession transport end = F.alloca $ \sPtr -> runErrorT $ do
		creds <- newIORef []
		fp <- FC.newForeignPtr ptr $ do
			F.gnutls_deinit session
			globalDeinit
			F.freeHaskellFunPtr push
			F.freeHaskellFunPtr pull
		return (Session fp global creds)
		return (Session fp creds)

getSession :: TLS Session
getSession = TLS R.ask