Timeout for pure values

[tom-bop]

Continuing the conversation from here: snapframework/snap-core#283

tl;dr Handlers seem not to correctly time out if computing a pure value causes them to overrun their time deadline.

Repro:

{-# LANGUAGE OverloadedStrings #-}

import Snap.Core
import Snap.Http.Server

import qualified Data.List as L

main = quickHttpServe hmm

hmm :: Snap ()
hmm = do
   setTimeout 5
   writeBS $ if L.find (==1) (repeat 0) == Just 1 then "A" else "B"

If you curl 'localhost:8000', it won't time out in 5 seconds, or seemingly ever. If you change writeBS $ to writeBS $!, though, forcing the value to WHNF is enough to properly time out.

The problem, I hypothesize, is that the hmm function is immediately returning a thunk, and thus not timing out.

My (hand-wavy) proposal is to force to WHNF (or normal form) the ByteString response body, in order to correctly time out. This'll prevent malicious input (to vulnerable handlers) from creating "permanent" un-killed response threads.

Functions I might try and update are processRequest or runServerHandler in Snap.Internal.Http.Server.Session.

I can try to hack on this but it'd be good to know if it's the right way forward first.

[mightybyte]

Sure. I think this is worth investigating. One thing I'm curious about is whether you can come up with another handler for which $! does not solve the problem. If so, that would be an even better thing to test your fix on.

[tom-bop]

Here's an example that still fails to timeout with ($!):

{-# LANGUAGE OverloadedStrings #-}

import Snap.Core
import Snap.Http.Server

import qualified Data.ByteString.Lazy as LBS
import qualified Data.List as L

main = quickHttpServe hmm

hmm :: Snap ()
hmm = do
   setTimeout 5
   let x = if L.find (==1) (repeat 0) == Just 1 then "A" else "B"
   writeLBS $! 33 `LBS.cons` x

(Again just curl 'localhost:8000')

[gregorycollins]

Before we attempt any fixes it's important to understand why this is happening -- there might not be anything that can be done about it. The GHC runtime relies on calls into the allocator to do scheduling or to check for delivery of async exceptions. See the ghc commentary. Tight loops that don't allocate won't get exceptions and never yield, it's a known problem. See also https://ghc.haskell.org/trac/ghc/ticket/367.

You could try building with -fno-omit-yields, but that's a compromise because it will slow down generated code.

The question is why it works in one position but not the other. You'd think that the scheduler would get stuck either way -- maybe there's some inlining happening in one case but not the other, or maybe our exception masking is different in one phase (monad computation) vs the other (response delivery).

[tom-audm]

Building with -fno-omit-yields does not fix the problem, which makes me wonder if it is not (entirely) that known GHC issue.

I've also, in less-simple repro cases, observed the same behavior with code that's not a tight non-allocating loop. If it helps I can provide an example.

[gregorycollins]

In this case, yes, please. We may be gobbling the ThreadKilled exception