rhi/haskell-gnutls
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fix a crash due to out-of-order garbage collection of Session values.

Browse source 
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.
This commit is contained in:
John Millikin 2013-09-07 12:32:39 -07:00
parent 6456ba5220
commit 0d7a60a1cc
No known key found for this signature in database
GPG key ID: 59A38F85F9C7C59E
1 changed files with 7 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

16
lib/Network/Protocol/TLS/GNU.hs
View file

@ -68,20 +68,17 @@ globalInitMVar :: M.MVar ()
{-# NOINLINE globalInitMVar #-} {-# NOINLINE globalInitMVar #-}
globalInitMVar = unsafePerformIO $ M.newMVar () globalInitMVar = unsafePerformIO $ M.newMVar ()
newtype GlobalState = GlobalState (F.ForeignPtr ()) globalInit :: ErrorT Error IO ()
globalInit :: ErrorT Error IO GlobalState
globalInit = do globalInit = do
let init_ = M.withMVar globalInitMVar $ \_ -> F.gnutls_global_init let init_ = M.withMVar globalInitMVar $ \_ -> F.gnutls_global_init
let deinit = M.withMVar globalInitMVar $ \_ -> F.gnutls_global_deinit
F.ReturnCode rc <- liftIO init_ F.ReturnCode rc <- liftIO init_
when (rc < 0) $ E.throwError $ mapError rc 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 data Session = Session
{ sessionPtr :: F.ForeignPtr F.Session { sessionPtr :: F.ForeignPtr F.Session
, sessionGlobalState :: GlobalState
-- TLS credentials are not copied into the gnutls session struct, -- TLS credentials are not copied into the gnutls session struct,
-- so pointers to them must be kept alive until the credentials -- 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 -> F.ConnectionEnd -> IO (Either Error Session)
newSession transport end = F.alloca $ \sPtr -> runErrorT $ do newSession transport end = F.alloca $ \sPtr -> runErrorT $ do
global <- globalInit globalInit
F.ReturnCode rc <- liftIO $ F.gnutls_init sPtr end F.ReturnCode rc <- liftIO $ F.gnutls_init sPtr end
when (rc < 0) $ E.throwError $ mapError rc when (rc < 0) $ E.throwError $ mapError rc
liftIO $ do liftIO $ do
@ -136,9 +133,10 @@ newSession transport end = F.alloca $ \sPtr -> runErrorT $ do
creds <- newIORef [] creds <- newIORef []
fp <- FC.newForeignPtr ptr $ do fp <- FC.newForeignPtr ptr $ do
F.gnutls_deinit session F.gnutls_deinit session
globalDeinit
F.freeHaskellFunPtr push F.freeHaskellFunPtr push
F.freeHaskellFunPtr pull F.freeHaskellFunPtr pull
return (Session fp global creds) return (Session fp creds)
getSession :: TLS Session getSession :: TLS Session
getSession = TLS R.ask getSession = TLS R.ask