iothunk and fixed some tests

Test/QuasiResource.hs

@@ -8,6 +8,7 @@ import Test.Framework (testGroup, Test)
 import Test.Framework.Providers.HUnit
 import Test.HUnit hiding (Test)
 import Data.List
+import Network.Wai (Method (..))
 
 data MyYesod = MyYesod
 
@@ -19,7 +20,7 @@ addHead' x = (cs "", x)
 addHead :: Monad m => HtmlObject -> m (Html, HtmlObject)
 addHead = return . addHead'
 
-getStatic :: Verb -> [String] -> Handler MyYesod (Html, HtmlObject)
+getStatic :: Method -> [String] -> Handler MyYesod (Html, HtmlObject)
 getStatic v p = addHead $ toHtmlObject ["getStatic", show v, show p]
 pageIndex :: Handler MyYesod (Html, HtmlObject)
 pageIndex = addHead $ toHtmlObject ["pageIndex"]
@@ -38,26 +39,26 @@ userVariable i s = addHead $ toHtmlObject ["userVariable", show i, s]
 userPage :: Integer -> [String] -> Handler MyYesod (Html, HtmlObject)
 userPage i p = addHead $ toHtmlObject ["userPage", show i, show p]
 
-instance Show (Verb -> Handler MyYesod ChooseRep) where
+instance Show (Method -> Handler MyYesod ChooseRep) where
     show _ = "verb -> handler"
-instance Show (Resource -> Verb -> Handler MyYesod ChooseRep) where
+instance Show (Resource -> Method -> Handler MyYesod ChooseRep) where
     show _ = "resource -> verb -> handler"
-handler :: Resource -> Verb -> Handler MyYesod ChooseRep
+handler :: Resource -> Method -> Handler MyYesod ChooseRep
 handler = [$mkResources|
 /static/*filepath/: getStatic
 /page/:
-    Get: pageIndex
-    Put: pageAdd
+    GET: pageIndex
+    PUT: pageAdd
 /page/$page/:
-    Get: pageDetail
-    Delete: pageDelete
-    Post: pageUpdate
+    GET: pageDetail
+    DELETE: pageDelete
+    POST: pageUpdate
 /user/#id/:
-    Get: userInfo
+    GET: userInfo
 /user/#id/profile/$variable/:
-    Get: userVariable
+    GET: userVariable
 /user/#id/page/*page/:
-    Get: userPage
+    GET: userPage
 |]
 
 ph :: [String] -> Handler MyYesod ChooseRep -> Assertion
@@ -71,7 +72,8 @@ ph ss h = do
     mapM_ (helper res') ss
       where
         helper haystack needle =
-            assertBool needle $ needle `isInfixOf` haystack
+            assertBool (show ("needle", needle, ss, haystack))
+                $ needle `isInfixOf` haystack
 
 myShow :: Response -> IO String
 myShow (Response sc hs ct c) = runContent c >>= \c' -> return $ unlines
@@ -83,13 +85,13 @@ myShow (Response sc hs ct c) = runContent c >>= \c' -> return $ unlines
 
 caseQuasi :: Assertion
 caseQuasi = do
-    ph ["200", "foo"] $ handler ["static", "foo", "bar", "baz"] Get
-    ph ["404"] $ handler ["foo", "bar", "baz"] Get
-    ph ["200", "pageIndex"] $ handler ["page"] Get
-    ph ["404"] $ handler ["user"] Get
-    ph ["404"] $ handler ["user", "five"] Get
-    ph ["200", "userInfo", "5"] $ handler ["user", "5"] Get
-    ph ["200", "userVar"] $ handler ["user", "5", "profile", "email"] Get
+    ph ["200", "foo"] $ handler ["static", "foo", "bar", "baz"] GET
+    ph ["404"] $ handler ["foo", "bar", "baz"] GET
+    ph ["200", "pageIndex"] $ handler ["page"] GET
+    ph ["404"] $ handler ["user"] GET
+    ph ["404"] $ handler ["user", "five"] GET
+    ph ["200", "userInfo", "5"] $ handler ["user", "5"] GET
+    ph ["200", "userVar"] $ handler ["user", "5", "profile", "email"] GET
 
 testSuite :: Test
 testSuite = testGroup "Test.QuasiResource"

Test/resource-patterns.yaml

@@ -1,10 +1,10 @@
 /static/*filepath/: getStatic
 /page/:
-    Get: pageIndex
-    Put: pageAdd
+    GET: pageIndex
+    PUT: pageAdd
 /page/$page/:
-    Get: pageDetail
-    Delete: pageDelete
-    Post: pageUpdate
+    GET: pageDetail
+    DELETE: pageDelete
+    POST: pageUpdate
 /user/#id/:
-    Get: userInfo
+    GET: userInfo

Yesod/Request.hs

@@ -103,6 +103,19 @@ postParams rr = do
     (pp, _) <- liftIO $ rawRequestBody rr
     return $ multiLookup pp
 
+-- | Produces a \"compute on demand\" value. The computation will be run once
+-- it is requested, and then the result will be stored. This will happen only
+-- once.
+iothunk :: IO a -> IO (IO a)
+iothunk = fmap go . newMVar . Left where
+    go :: MVar (Either (IO a) a) -> IO a
+    go mvar = modifyMVar mvar go'
+    go' :: Either (IO a) a -> IO (Either (IO a) a, a)
+    go' (Right val) = return (Right val, val)
+    go' (Left comp) = do
+        val <- comp
+        return (Right val, val)
+
 -- | All cookies with the given name.
 cookies :: RawRequest -> ParamName -> [ParamValue]
 cookies rr name = map snd . filter (fst `equals` name) . rawCookies $ rr
@@ -120,23 +133,20 @@ parseWaiRequest env session = do
         langs'' = case lookup langKey gets' of
                      Nothing -> langs'
                      Just x -> x : langs'
-    mrb <- newMVar $ Left env
-    return $ RawRequest gets' cookies' session (rbHelper mrb) env langs''
+    rbthunk <- iothunk $ rbHelper env
+    return $ RawRequest gets' cookies' session rbthunk env langs''
 
-rbHelper :: MVar (Either W.Request RequestBodyContents)
-         -> IO RequestBodyContents
-rbHelper mvar = modifyMVar mvar helper where
-    helper (Right bc) = return (Right bc, bc)
-    helper (Left env) = do
-        inputLBS <- WE.toLBS $ W.requestBody env -- FIXME
-        let clength = maybe "0" cs  $ lookup W.ReqContentLength
-                                    $ W.requestHeaders env
-        let ctype = maybe "" cs $ lookup W.ReqContentType $ W.requestHeaders env
-        let convertFileInfo (FileInfo a b c) = FileInfo (cs a) (cs b) c
-        let ret = map (cs *** cs) ***
-                  map (cs *** convertFileInfo)
-                $ parsePost ctype clength inputLBS
-        return (Right ret, ret)
+rbHelper :: W.Request -> IO RequestBodyContents
+rbHelper env = do
+    inputLBS <- WE.toLBS $ W.requestBody env -- FIXME
+    let clength = maybe "0" cs  $ lookup W.ReqContentLength
+                                $ W.requestHeaders env
+    let ctype = maybe "" cs $ lookup W.ReqContentType $ W.requestHeaders env
+    let convertFileInfo (FileInfo a b c) = FileInfo (cs a) (cs b) c
+    let ret = map (cs *** cs) ***
+              map (cs *** convertFileInfo)
+            $ parsePost ctype clength inputLBS
+    return ret
 
 #if TEST
 testSuite :: Test

Yesod/Resource.hs

@@ -496,12 +496,12 @@ caseFromYaml = do
     rp4 <- readRP "user/#id"
     let expected =
          [ RPNode rp1 $ AllMethods "getStatic"
-         , RPNode rp2 $ Methods [(Get, "pageIndex"), (Put, "pageAdd")]
-         , RPNode rp3 $ Methods [ (Get, "pageDetail")
-                              , (Delete, "pageDelete")
-                              , (Post, "pageUpdate")
+         , RPNode rp2 $ Methods [(GET, "pageIndex"), (PUT, "pageAdd")]
+         , RPNode rp3 $ Methods [ (GET, "pageDetail")
+                              , (DELETE, "pageDelete")
+                              , (POST, "pageUpdate")
                               ]
-         , RPNode rp4 $ Methods [(Get, "userInfo")]
+         , RPNode rp4 $ Methods [(GET, "userInfo")]
          ]
     contents' <- decodeFile "Test/resource-patterns.yaml"
     contents <- convertAttemptWrap (contents' :: TextObject)
@@ -519,7 +519,7 @@ caseCheckRPNodes = do
                ]
     Nothing @=? checkRPNodes bad1
     rp' <- readRP ""
-    let bad2 = [RPNode rp' $ Methods [(Get, "foo"), (Get, "bar")]]
+    let bad2 = [RPNode rp' $ Methods [(GET, "foo"), (GET, "bar")]]
     Nothing @=? checkRPNodes bad2
 
 caseReadRP :: Assertion

Yesod/Response.hs

@@ -65,11 +65,12 @@ import qualified Data.Text.Lazy.Encoding as DTLE
 import Web.Encodings (formatW3)
 import qualified Network.Wai as W
 import qualified Network.Wai.Enumerator as WE
-import Yesod.Request
 
 #if TEST
+import Yesod.Request hiding (testSuite)
 import Data.Object.Html hiding (testSuite)
 #else
+import Yesod.Request
 import Data.Object.Html
 #endif