UninterruptibleMask.hs

-- | Coverage for 'Pqi.exec' called under
-- 'Control.Exception.uninterruptibleMask_', as @safe-exceptions@' 'bracket'
-- runs its release action.
--
-- The divergence: @pqi-native@'s send loop waits for the socket to become
-- writable or readable at once and then cancels the losing wait
-- (@awaitWritableOrReadable@ in @Pqi.Native.Transport@). On the non-threaded
-- RTS those waits come from base's @threadWaitReadSTM@\/@threadWaitWriteSTM@,
-- which fork a bare @forkIO@ helper and cancel it with @killThread@. The
-- helper inherits the caller's masking state, so from under an
-- @uninterruptibleMask@ the cancellation of the readable wait cannot be
-- delivered while the socket stays writable-but-not-readable - the steady
-- state of an idle connection being sent a query - and the send, and with it
-- the whole query, blocks forever. libpq has no Haskell masking state to
-- inherit and sends as usual. On the threaded RTS the waits are
-- event-manager registrations with no helper thread, so the divergence only
-- manifests in binaries built without @-threaded@.
--
-- Why this observation: 'System.Timeout.timeout' cannot break the hang (it
-- delivers its exception by @throwTo@, which the same masking state defers),
-- so the call runs in a forked thread under a watchdog that folds a true
-- hang into the compared observation, the way
-- "Pqi.Conformance.Scenario.LostConnection" folds a timeout. The observation
-- is the 'ResultObservation' of the query, or @TIMED OUT@ when the watchdog
-- fires. A hung call never unblocks - the query never reaches the server, so
-- nothing ever makes the cancelled wait's socket readable - which makes the
-- 5 s deadline unambiguous. On a hang the connection is deliberately left
-- open and unfinished: a thread of the candidate is stuck inside its send,
-- and closing the socket it is blocked on is territory this spec does not
-- need to enter. The leaked connection dies with the test process.
--
-- Where it surfaced: @pqi-native@ issue #17.
module Pqi.Conformance.Operation.Exec.UninterruptibleMask
  ( spec,
  )
where

import Control.Concurrent (forkIO, newEmptyMVar, takeMVar, tryPutMVar)
import Control.Exception (SomeException, try, uninterruptibleMask_)
import qualified Pqi
import Pqi.Conformance.Harness
import Pqi.Conformance.Observation
import Pqi.Conformance.Prelude
import Test.Hspec

spec :: Pqi.Adapter -> SpecWith ByteString
spec adapter =
  describe "exec" do
    describe "under uninterruptibleMask" do
      it "a query completes the same way the reference's does" \conninfo ->
        differentialConnect adapter conninfo \adapter' conninfo' -> do
          connection <- Pqi.connectdb adapter' conninfo'
          outcome <- bounded (Pqi.exec connection "select 1" >>= traverse observeResult)
          case outcome of
            TimedOut -> pure ()
            _ -> Pqi.finish connection
          pure (renderCall renderOutcome outcome)

-- | How long the call is allowed to take. The hang it detects is permanent -
-- the query never reaches the server, so nothing ever wakes the stuck wait -
-- so the deadline only needs to clear normal latency by a wide margin.
callDeadlineMicros :: Int
callDeadlineMicros = 5_000_000

-- | The outcome of one bounded call: the value, a synchronous exception (an
-- asynchronous one cannot surface - the call is under the mask the hang is
-- about), or a hang.
data Call a
  = Returned a
  | Threw String
  | TimedOut

-- | Run the action under 'uninterruptibleMask_' in a forked thread, with a
-- watchdog folding a hang into 'TimedOut'. The mask is the scenario, and
-- this is why 'System.Timeout.timeout' is no good here: it delivers its
-- exception by @throwTo@ to this very thread, which the mask defers. A hung
-- worker is left behind - blocked in the @throwTo@ of its cancellation,
-- inert and unkillable - and dies with the process.
bounded :: IO a -> IO (Call a)
bounded action = do
  outcome <- newEmptyMVar
  void
    $ forkIO do
      caught <- try @SomeException (uninterruptibleMask_ action)
      void $ tryPutMVar outcome (either (Threw . show) Returned caught)
  void
    $ forkIO do
      threadDelay callDeadlineMicros
      void $ tryPutMVar outcome TimedOut
  takeMVar outcome

renderCall :: (a -> String) -> Call a -> String
renderCall render = \case
  Returned value -> render value
  Threw exception -> "THREW " <> exception
  TimedOut -> "TIMED OUT after " <> show callDeadlineMicros <> "us"

renderOutcome :: Maybe ResultObservation -> String
renderOutcome = \case
  Nothing -> "Nothing"
  Just observation ->
    -- Only the error fields that are set, as everywhere else a result is
    -- rendered: all of them are always observed and nearly all are absent.
    "Just " <> show observation {errorFields = filter (isJust . snd) (errorFields observation)}