Cannot connect remotely with TLS on Windows (GHC bug...)

[dmjio]

@stepcut,

I have a client who is attempting to connect to an acid TLS server. A query is submitted by the client, but never makes it back from the server. Here is the client's debug output. The server hangs with Partial Input, never returning Done.

vagrant@VAGRANT-2008R2 /c/Users/dmj/SolidTranslate/packages/ST-Worker
$ dist/build/worker/worker.exe
started
"actorThread: waiting for something to do."
opened acid
"listener: listening for Response."
"listener: ccGetSome"
"actorThread: waiting for something to do."
"actor: begin."
"listener: listening for Response."
"actor: end."
"listener: ccGetSome"
"actorThread: sending command."
(RunQuery ("ST.DB.Ops.GetAWSKeys","\NUL\NUL\NUL\NUL"),"<-- CMD")

Here is the servers output:

vagrant@vagrant-ubuntu-trusty-64:/Users/dmj/SolidTranslate/packages/ST-DB$ rundb
("db -- ekg | db","localhost",8097,8098)
acidServerTLS: listenOn PortNumber 8098
acidServerTLS: initSSLContext
"processing state"
(Partial _,"<-- input")
"processing state"
(Partial _,"<-- input")

I've added debug statements to the code.

process :: SafeCopy st =>
           CommChannel  -- ^ a connected, authenticated communication channel
        -> AcidState st -- ^ state to share
        -> IO ()
process CommChannel{..} acidState
  = do chan <- newChan
       debugStrLn "processing state"
       forkIO $ forever $ do response <- join (readChan chan)
                             ccPut (encode response)
       worker chan (runGetPartial get Strict.empty)
  where worker chan inp
          = do
            debugStrLn (inp, "<-- input")
            case inp of
              Fail msg _    -> throwIO (SerializeError msg)
              Partial cont  -> do bs <- ccGetSome 1024
                                  if Strict.null bs then
                                      do debugStrLn "its null!"
                                         return ()
                                  else do
                                    debugStrLn "not null, got some"
                                    worker chan (cont bs)
              Done cmd rest -> do debugStrLn ("processing command", cmd)
                                  processCommand chan cmd
                                  worker chan (runGetPartial get rest)
        processCommand chan cmd = do
          debugStrLn (cmd, "<-- CMD")
          case cmd of
            RunQuery query -> do result <- queryCold acidState query
                                 writeChan chan (return $ Result result)
            RunUpdate update -> do result <- scheduleColdUpdate acidState update
                                   writeChan chan (liftM Result $ takeMVar result)
            CreateCheckpoint -> do createCheckpoint acidState
                                   writeChan chan (return Acknowledgement)
            CreateArchive -> do createArchive acidState
                                writeChan chan (return Acknowledgement)

[dmjio]

I've narrowed it down to the bs <- ccGetSome 1024 function. Seems that SSL.read is blocking.

[dmjio]

read :: SSL -> Int -> IO B.ByteString
read ssl nBytes = sslBlock (`tryRead` nBytes) ssl

Which goes back to

-- | Block until the operation is finished.
sslBlock :: (SSL -> IO (SSLResult a)) -> SSL -> IO a
sslBlock action ssl
    = do result <- action ssl
         case result of
           SSLDone r -> return r
           WantRead  -> threadWaitRead  (sslFd ssl) >> sslBlock action ssl
           WantWrite -> threadWaitWrite (sslFd ssl) >> sslBlock action ssl

Think threadWaitRead isn't implemented on Windows.

[dmjio]

According to this ticket it has been a bug for 8 years.
https://ghc.haskell.org/trac/ghc/ticket/2408

[stepcut]

Here is the implementation in base 4.7.0.0:

http://hackage.haskell.org/package/base-4.7.0.0/docs/src/Control-Concurrent.html#threadWaitRead

says you need to compile with -threaded for it to work. Are you compiling with -threaded? In theory it should be raising an error if you are not..

[dmjio]

Yea, looks like I have -threaded on http://lpaste.net/106752

[dmjio]

One of two things could be happening.

• An asynchronous exception is thrown (throwTo) and is never unmasked, causing indefinite thread blocking -- UPDATE: can't find throwTo anywhere so ruling this out
• io never returns, so putMVar never happens, causing takeMVar to block the thread indefinitely.

threaded = withThread (waitFd fd 0) -- This code gets called since -threaded is enabled

#ifdef mingw32_HOST_OS
foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool

withThread :: IO a -> IO a
withThread io = do
  m <- newEmptyMVar
 -- if the exception is asynchronous with throwTo mask_ will block is indefinitely
  _ <- mask_ $ forkIO $ try io >>= putMVar m -- io here isn't happening, or an exception is being raised
  x <- takeMVar m -- this blocks indefinitely
  case x of
    Right a -> return a
    Left e  -> throwIO (e :: IOException)

waitFd :: Fd -> CInt -> IO ()
waitFd fd write = do  -- this code must be the culprit, fdReady might never return
   throwErrnoIfMinus1_ "fdReady" $
        fdReady (fromIntegral fd) write iNFINITE 0

iNFINITE :: CInt
iNFINITE = 0xFFFFFFFF -- urgh -- "dmjio: this is actual code in base I didn't write urgh"

foreign import ccall safe "fdReady"
  fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
#endif

[dmjio]

So, it must be the ssl file descriptor never enters the ready state. threadWaitRead (sslFd ssl) via the call to fdReady, only thing I can think of. The network library calls ThreadWaitRead a lot, and I'm able to connect to a remote state w/o SSL. @stepcut have you ever used happstack over ssl on windows?

[dmjio]

I went into HsOpenSSL and started adding print statements. Strange part is that both client and server seem to be communicating initially, just that a query / update will not return to client entirely. This means the issue probably isn't threadWaitRead

("in ssl block",WantRead)
("in ssl block",WantRead)
("in ssl block",SSLDone ())
("in read",1024)
("in ssl block",SSLDone "password!@#$")
("in ssl block",SSLDone ())
"processing state"
(Partial _,"<-- input")
"getting some"
("in read",1024)
("in ssl block",WantRead)
("in ssl block",WantRead)
("in ssl block",WantRead)
("in ssl block",SSLDone ())
("in read",1024)
("in ssl block",SSLDone "password!@#$")
("in ssl block",SSLDone ())
"processing state"
(Partial _,"<-- input")
"getting some"
("in read",1024)
("in ssl block",WantRead)
acidServerTLS: shutdownClose. -- client disconnected here
acidServerTLS: shutdownClose.
("in ssl block",SSLDone ())
("in ssl block",SSLDone ())
("in ssl block",WantRead)
("in ssl block",WantRead)
("in ssl block",SSLDone ())
("in read",1024)
("in ssl block",WantRead)
("in ssl block",SSLDone "password!@#$")
("in ssl block",SSLDone ())
"processing state"
(Partial _,"<-- input")
"getting some"
("in read",1024)
("in ssl block",WantRead) -- blocks here for good

[dmjio]

The blocking occurs on the linux server... so it absolutely couldn't be threadWaitRead. Maybe the data sent by the client is malformed due to hsopenssl on windows.