Trying to reproduce the StackOverflow problem - Nice version

gistfile1.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}


------------------------------------------------------------------------------
import           Control.Monad.State
import           Data.Lens.Template
import qualified Data.Map as Map
import           Data.Text as T


------------------------------------------------------------------------------
import           Snap.Core
import           Snap.Snaplet
import qualified Snap.Test as ST
import           Snap.Snaplet.Test


------------------------------------------------------------------------------
import           Test.Framework (Test, defaultMain)
import           Test.Framework.Providers.HUnit
import           Test.HUnit hiding (Test)


                            ----------------
                            -- SNAP WORLD --
                            ----------------

put23 :: Snap ()
put23 = writeText "23"


------------------------------------------------------------------------------
testPut23 :: Assertion
testPut23 = do
    res <- ST.runHandler (ST.get "" Map.empty) put23
    ST.assertSuccess res
    ST.assertBodyContains "23" res


                            -------------------
                            -- Snaplet World --
                            -------------------


data App = App
    { _counter :: Int
    }

makeLenses[''App]


------------------------------------------------------------------------------
foo :: Handler App App ()
foo = do
    app <- get
    -- Remember: writeText adds the given strict 'T.Text' to the body of
    -- the 'Response' stored in the 'Snap' monad state.
    writeText $ T.pack $ show $ _counter app


------------------------------------------------------------------------------
putHello :: Handler App App ()
putHello = writeText "hello"


------------------------------------------------------------------------------
counterInit :: SnapletInit App App
counterInit = makeSnaplet "app" empty Nothing $ return $ App 5


------------------------------------------------------------------------------
testInc :: Assertion
testInc = do
    res <- runHandler (ST.get "" Map.empty) foo counterInit
    case res of
      (Left e) -> assertFailure $ show e
      (Right r) -> do
          ST.assertSuccess r
          ST.assertBodyContains "5" r


------------------------------------------------------------------------------
testPutHello :: Assertion
testPutHello = do
    res <- runHandler (ST.get "" Map.empty) putHello counterInit
    case res of
      (Left e) -> assertFailure $ show e
      (Right r) -> do
          ST.assertSuccess r
          ST.assertBodyContains "hello" r


------------------------------------------------------------------------------
tests :: [Test]
tests = [ testCase "simple Snap test" testPut23
        , testCase "simple snaplet test" testInc
        , testCase "test put hello" testPutHello
        ] 


------------------------------------------------------------------------------
main :: IO ()
main = defaultMain tests