Pure values don't timeout

[tom-bop]

This code - which never terminates - doesn't time out correctly (or at all):

import qualified Data.List as L

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

However! If we replace ($) with ($!) it times out correctly.

Here's an eventually-terminating example with the same behavior:

import Data.String (fromString)

do setTimeout 5
   writeBS $ fromString $ show $ product [1..99999999]

I think the problem is that Snap's being insufficiently strict. Here's an example of the same problem without Snap at all:

>  :m + System.Timeout
>  import qualified Data.List as L
>  timeout 1000000 (pure $ if L.find (==1) (repeat 0) == Just 1 then "A" else "B")
Just "^CInterrupted.

Where, again, if we force it to WHNF with ($!) it returns what we expect (Nothing after 1 second)

You can test this with Snap.Test, but the issue's also there when "really" using the handler.

[tom-bop]

We probably want to fully-evaluate the result though (and not just to WHNF), given that the goal of timeout is to terminate the computation if it takes too long regardless of the reason.

[mightybyte]

Pinging @gregorycollins

[tom-bop]

Here's a full reproducer @gregorycollins :

{-# LANGUAGE OverloadedStrings #-}

import Snap.Core
import Snap.Http.Server

import qualified Data.List as L

main = quickHttpServe $ route [
     ("hmm", hmm)
   ]

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

Then try e.g. curl 'localhost:8000/hmm'

[sopvop]

That's the way GHC RTS works. GHC does all thread related operations on memory allocation, and your example does not allocate memory thanks to stream fusion.

[cdsmith]

The fact that this times out correctly with $! suggests it's not completely uninterruptible. Rather, the timeout is being enforced around the handler, but not the evaluation of the thunk to produce the response after the handler returns.

[mightybyte]

I talked with @gregorycollins about this. We don't see a way to fix this given the way the GHC RTS works as pointed out by @sopvop. It's almost certainly not appropriate for Snap to all values to WHNF before using them because it's certainly not just writeBS that is susceptible to this. Such a change would have an unknown impact on virtually every Snap application ever written. All this for a problem that you already know how to work around with a simple $!. The vast majority of real-world handlers will have memory allocation and this will not be an issue. This seems like one of those places where you just have to understand how the RTS works and code accordingly to make your long-running pure computations are something that the RTS can break out of.

[mightybyte]

Also, if Snap reduced all values to WHNF, I don't think that would solve the problem because your program could still inject a pure non-terminating subexpression anywhere deeper in the evaluation tree that would trigger this. Taking the next obvious step of fully evaluating everything everywhere would impose an NFData constraint everywhere which would definitely not be acceptable. This is a problem that has to be solved at the user level, not the snap level.

[tom-bop]

@mightybyte @gregorycollins sorry if this is a little hand-wavy, but isn't it possible to force evaluation "later in the pipeline", i.e. when Snap constructs the response ByteString? (Maybe in/around processRequest or runServerHandler in snap-server/src/Snap/Internal/Http/Server/Session.hs?)

That way, you don't need to force (or deepseq) anything other than the final response ByteString (which already has an NFData instance if it's needed), and the timeout duration refers simply to the entire lifecycle of the request.

A practical benefit of making pure timeouts work is that currently specially-crafted requests can force vulnerable handlers to run basically forever.

[mightybyte]

@tom-bop If you open a PR on snap-server, that will make it much easier to have a more concrete conversation about the idea.

[tom-bop]

Thanks, added here: https://github.com/snapframework/snap-server/issues/118