Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Desperation tactic: try to force the garbage collector not to kill the

SSLContext before we're finished with it.

The hypothesis here is that the SSLContext (which has an MVar finalizer
attached to it) is getting GCed before all of the uses are finished with it,
which is causing our testsuite segfault-on-exit. If this hypothesis is correct,
then touching the context on session shutdown should force the context to
remain live.
  • Loading branch information...
commit bb94339aab4b1f6c964e2977364069137d3f4fbf 1 parent 3c7fcd9
@gregorycollins gregorycollins authored
Showing with 23 additions and 7 deletions.
  1. +1 −1  snap-server.cabal
  2. +22 −6 src/Snap/Internal/Http/Server/TLS.hs
View
2  snap-server.cabal
@@ -1,5 +1,5 @@
name: snap-server
-version: 0.9.2
+version: 0.9.2.1
synopsis: A fast, iteratee-based, epoll-enabled web server for the Snap Framework
description:
Snap is a simple and fast web development framework and server written in
View
28 src/Snap/Internal/Http/Server/TLS.hs
@@ -133,32 +133,48 @@ bindHttps bindAddress bindPort cert key = do
------------------------------------------------------------------------------
freePort :: ListenSocket -> IO ()
-freePort (ListenHttps sock _) = Socket.sClose sock
+freePort (ListenHttps sock ctx) = do
+ Socket.sClose sock
+ -- FIXME(greg): this is a desperation tactic. Better to find and kill the
+ -- hypothesized liveness bug in HsOpenSSL.
+ --
+ -- Touch the context so that the garbage collector doesn't zap it.
+ !_ <- contextGetCAStore ctx
+ return $! ()
freePort _ = return ()
------------------------------------------------------------------------------
+data SessionContext = SessionContext SSL SSLContext
+
+------------------------------------------------------------------------------
createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession
createSession (ListenHttps _ ctx) recvSize socket _ = do
csock <- mkSocket socket AF_INET Stream defaultProtocol Connected
handle (\(e::SomeException) -> Socket.sClose csock >> throwIO e) $ do
ssl <- connection ctx csock
accept ssl
- return $! NetworkSession socket (unsafeCoerce ssl) recvSize
+ let sctx = SessionContext ssl ctx
+ return $! NetworkSession socket (unsafeCoerce sctx) recvSize
createSession _ _ _ _ = error "can't call createSession on a ListenHttp"
------------------------------------------------------------------------------
endSession :: NetworkSession -> IO ()
-endSession (NetworkSession _ aSSL _) =
- shutdown (unsafeCoerce aSSL) Unidirectional
+endSession (NetworkSession _ aSSL _) = do
+ let (SessionContext ssl ctx) = unsafeCoerce aSSL
+ shutdown ssl Unidirectional
+ -- FIXME(greg): fix this properly, see above
+ -- Touch the context so that the garbage collector doesn't zap it.
+ !_ <- contextGetCAStore ctx
+ return $! ()
------------------------------------------------------------------------------
send :: IO () -> IO () -> NetworkSession -> ByteString -> IO ()
send tickleTimeout _ (NetworkSession _ aSSL sz) bs = go bs
where
- ssl = unsafeCoerce aSSL
+ (SessionContext ssl _) = unsafeCoerce aSSL
-- I think we have to chop the data into chunks here because HsOpenSSL
-- won't; of course, blaze-builder may already be doing this for us, but I
@@ -179,6 +195,6 @@ recv _ (NetworkSession _ aSSL recvLen) = do
b <- SSL.read ssl recvLen
return $! if S.null b then Nothing else Just b
where
- ssl = unsafeCoerce aSSL
+ (SessionContext ssl _) = unsafeCoerce aSSL
#endif
Please sign in to comment.
Something went wrong with that request. Please try again.