From 1708d804eac6da012239cb2393c6859fd642552d Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Thu, 14 Oct 2010 16:10:11 +0200
Subject: [PATCH] Added Handler finally test case (fails)

---
 Yesod.hs          |  3 ++-
 Yesod/Dispatch.hs |  4 +++-
 Yesod/Handler.hs  | 39 +++++++++++++++++++++++++++++++++++++--
 Yesod/Json.hs     |  2 +-
 Yesod/Yesod.hs    |  8 +++++---
 runtests.hs       |  2 ++
 6 files changed, 50 insertions(+), 8 deletions(-)

diff --git a/Yesod.hs b/Yesod.hs
index eabc19ab..f2e6916e 100644
--- a/Yesod.hs
+++ b/Yesod.hs
@@ -22,17 +22,18 @@ import Yesod.Content hiding (testSuite)
 import Yesod.Json hiding (testSuite)
 import Yesod.Dispatch hiding (testSuite)
 import Yesod.Yesod hiding (testSuite)
+import Yesod.Handler hiding (runHandler, testSuite)
 #else
 import Yesod.Content
 import Yesod.Json
 import Yesod.Dispatch
 import Yesod.Yesod
+import Yesod.Handler hiding (runHandler)
 #endif
 
 import Yesod.Request
 import Yesod.Form
 import Yesod.Widget
-import Yesod.Handler hiding (runHandler)
 import Network.Wai (Application)
 import Yesod.Hamlet
 import "transformers" Control.Monad.Trans.Class (lift)
diff --git a/Yesod/Dispatch.hs b/Yesod/Dispatch.hs
index 2ca147b5..70e514f5 100644
--- a/Yesod/Dispatch.hs
+++ b/Yesod/Dispatch.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module Yesod.Dispatch
     ( -- * Quasi-quoted routing
       parseRoutes
@@ -25,11 +26,12 @@ module Yesod.Dispatch
 
 #if TEST
 import Yesod.Yesod hiding (testSuite)
+import Yesod.Handler hiding (testSuite)
 #else
 import Yesod.Yesod
+import Yesod.Handler
 #endif
 
-import Yesod.Handler
 import Yesod.Request
 import Yesod.Internal
 
diff --git a/Yesod/Handler.hs b/Yesod/Handler.hs
index f460f2cd..462f3921 100644
--- a/Yesod/Handler.hs
+++ b/Yesod/Handler.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP #-}
 ---------------------------------------------------------
 --
 -- Module        : Yesod.Handler
@@ -72,17 +73,19 @@ module Yesod.Handler
     , YesodApp (..)
     , toMasterHandler
     , localNoCurrent
+#if TEST
+    , testSuite
+#endif
     ) where
 
 import Prelude hiding (catch)
 import Yesod.Request
-import Yesod.Content
 import Yesod.Internal
 import Data.List (foldl')
 import Data.Neither
 import Data.Time (UTCTime)
 
-import Control.Exception hiding (Handler, catch)
+import Control.Exception hiding (Handler, catch, finally)
 import qualified Control.Exception as E
 import Control.Applicative
 
@@ -100,6 +103,17 @@ import qualified Data.ByteString.Lazy.UTF8 as L
 
 import Text.Hamlet
 
+#if TEST
+import Test.Framework (testGroup, Test)
+import Test.Framework.Providers.HUnit (testCase)
+import Test.HUnit hiding (Test)
+import Yesod.Content hiding (testSuite)
+import "MonadCatchIO-transformers" Control.Monad.CatchIO (finally)
+import Data.IORef
+#else
+import Yesod.Content
+#endif
+
 -- | The type-safe URLs associated with a site argument.
 type family Route a
 
@@ -455,3 +469,24 @@ data RedirectType = RedirectPermanent
 localNoCurrent :: GHandler s m a -> GHandler s m a
 localNoCurrent =
     GHandler . local (\hd -> hd { handlerRoute = Nothing }) . unGHandler
+
+#if TEST
+
+testSuite :: Test
+testSuite = testGroup "Yesod.Handler"
+    [ testCase "finally" caseFinally
+    ]
+
+caseFinally :: Assertion
+caseFinally = do
+    i <- newIORef (1 :: Int)
+    let h = finally (do
+                liftIO $ writeIORef i 2
+                () <- redirectString RedirectTemporary ""
+                return ()) $ liftIO $ writeIORef i 3
+    let y = runHandler h undefined undefined undefined undefined undefined
+    _ <- unYesodApp y undefined undefined undefined
+    j <- readIORef i
+    j @?= 3
+
+#endif
diff --git a/Yesod/Json.hs b/Yesod/Json.hs
index 46b1ba00..fe96cfbd 100644
--- a/Yesod/Json.hs
+++ b/Yesod/Json.hs
@@ -20,7 +20,7 @@ module Yesod.Json
 
 import qualified Data.ByteString.Char8 as S
 import Data.Char (isControl)
-import Yesod.Handler
+import Yesod.Handler (GHandler)
 import Numeric (showHex)
 import Data.Monoid (Monoid (..))
 import Text.Blaze.Builder.Core
diff --git a/Yesod/Yesod.hs b/Yesod/Yesod.hs
index 4e44d1bc..4071d345 100644
--- a/Yesod/Yesod.hs
+++ b/Yesod/Yesod.hs
@@ -35,15 +35,16 @@ module Yesod.Yesod
 #if TEST
 import Yesod.Content hiding (testSuite)
 import Yesod.Json hiding (testSuite)
+import Yesod.Handler hiding (testSuite)
 #else
 import Yesod.Content
 import Yesod.Json
+import Yesod.Handler
 #endif
 
 import Yesod.Widget
 import Yesod.Request
 import Yesod.Hamlet
-import Yesod.Handler
 import qualified Network.Wai as W
 import Yesod.Internal
 import Web.ClientSession (getKey, defaultKeyFile)
@@ -261,10 +262,10 @@ applyLayout' title body = fmap chooseRep $ defaultLayout $ do
 defaultErrorHandler :: Yesod y => ErrorResponse -> GHandler sub y ChooseRep
 defaultErrorHandler NotFound = do
     r <- waiRequest
-    let path = BSU.toString $ pathInfo r
+    let path' = BSU.toString $ pathInfo r
     applyLayout' "Not Found" $ [$hamlet|
 %h1 Not Found
-%p $path$
+%p $path'$
 |]
   where
     pathInfo = W.pathInfo
@@ -398,6 +399,7 @@ data TmpRoute = TmpRoute deriving Eq
 type instance Route TmpYesod = TmpRoute
 instance Yesod TmpYesod where approot _ = ""
 
+propJoinSplitPath :: [String] -> Bool
 propJoinSplitPath ss =
     splitPath TmpYesod (BSU.fromString $ joinPath TmpYesod "" ss' [])
         == Right ss'
diff --git a/runtests.hs b/runtests.hs
index 7e06ab98..e3fe7bc8 100644
--- a/runtests.hs
+++ b/runtests.hs
@@ -5,6 +5,7 @@ import qualified Yesod.Json
 import qualified Yesod.Dispatch
 import qualified Yesod.Helpers.Static
 import qualified Yesod.Yesod
+import qualified Yesod.Handler
 
 main :: IO ()
 main = defaultMain
@@ -13,4 +14,5 @@ main = defaultMain
     , Yesod.Dispatch.testSuite
     , Yesod.Helpers.Static.testSuite
     , Yesod.Yesod.testSuite
+    , Yesod.Handler.testSuite
     ]