Yesod scaffolded site slow to release database pool connection

Question

UPDATE

I have simplified the demonstration of this with an actual project created from the scaffold - you can check it out here: https://github.com/tetigi/yesod-bug-test

Follow the README to set up the repo and replicate the issue! Thanks :)

ORIGINAL POST

I've recently been trying to create a simple website using yesod - in one particular handler, it makes a couple of runDB calls (selecting and inserting some values into a ~200 item DB). However, on medium load, such as reloading the page rapidly in a browser, the page starts to hang.

Doing some debugging, I found that it seems the yesod app is not releasing the connections to the DB pool in a timely fashion and ends up waiting for them to release. To correborate this, I found the other following things:

• Reducing the DB pool to 2 gave me a freeze after only a couple of clicks
• The default (10) froze after about 5 seconds of clicking
• Increasing the DB pool to 100 gave me a much longer click period, up to about 10-15 seconds of rapid clicking
• The issue is the same whether I'm using postgres or sqlite
• In postgres, it was possible to see the 'COMMIT' transactions stacking up over time
• These transactions would eventually dissappear over time and the website would be responsive again

Is there something I'm missing here? The webpage does not do anything complicated, as the snippet below will show. Any ideas? As it stands, the website will be unuseable for multiple users until I find a way to fix this!

I'm using the standard scaffolded yesod application via stack as is recommended in the documentation.

Cheers!

Luke

Example handler code (abridged)

getCompareR :: Handler Html
getCompareR = do

    -- Get all entities from the db. Throws error if < 2 elems in the DB.
    entities <- fmap (\xs -> assert (length xs >= 2) xs) $ runDB $ selectList [] []

    -- Pick an entity at random
    Entity _ thisThingEntity <- liftIO $ runRVar (choice entities) DevRandom

    -- Pull out everything NOT the thing we just picked
    otherEntities <- runDB $ selectList [ComparisonHash !=. (comparisonHash thisThingEntity)] []

    -- Pick one at random
    Entity _ thatThingEntity <- liftIO $ runRVar (choice otherEntities) DevRandom

    -- Some stuff including some inserts
    -- ...
    -- ...

    runDB $ sequence [update thisId [ComparisonElo =. thisElo], update thatId [ComparisonElo =. thatElo]]

    -- Start laying out the webpage
    defaultLayout $ do
        -- Fill in the rest with compare.hamlet
        $(widgetFile "compare")

Answer 1

The issue lies within Data.Random - replacing the choice call with something like:

import System.Random (randomRIO)

...

 -- Pick an entity at random
randomInt1 <- liftIO $ randomRIO (0, length entities -1) 
let Entity _ thisThingEntity = entities !! randomInt1

Fixed everything and we no longer get slow down. Not really sure why Data.Random is doing this, but at least it works now!

Another interesting thing to note - the issue is NOT present on Mac OS X, only on Linux flavours (CentOS, Arch, Ubuntu being the ones we tried)