From 0d7a60a1cc0b05f96e2f727941903e95baeb5f99 Mon Sep 17 00:00:00 2001
From: John Millikin <jmillikin@gmail.com>
Date: Sat, 7 Sep 2013 12:32:39 -0700
Subject: [PATCH] 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.
---
 lib/Network/Protocol/TLS/GNU.hs | 16 +++++++---------
 1 file changed, 7 insertions(+), 9 deletions(-)

diff --git a/lib/Network/Protocol/TLS/GNU.hs b/lib/Network/Protocol/TLS/GNU.hs
index 08882b0..3d4eab3 100644
--- a/lib/Network/Protocol/TLS/GNU.hs
+++ b/lib/Network/Protocol/TLS/GNU.hs
@@ -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
-- 
2.34.7