~singpolyma/haskell-gnutls: Fix a crash due to out-of-order garbage collection of Session values.

0d7a60a1cc0b05f96e2f727941903e95baeb5f99 — John Millikin 11 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.

patch browse .tar.gz

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