From 0d7a60a1cc0b05f96e2f727941903e95baeb5f99 Mon Sep 17 00:00:00 2001 From: John Millikin 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.38.5