From 71b62e03635eed7d4e172aa819b58595c8374e5b Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Wed, 17 Feb 2010 14:52:23 +0200 Subject: [PATCH] iothunk and fixed some tests --- Test/QuasiResource.hs | 42 +++++++++++++++++++------------------ Test/resource-patterns.yaml | 12 +++++------ Yesod/Request.hs | 42 +++++++++++++++++++++++-------------- Yesod/Resource.hs | 12 +++++------ Yesod/Response.hs | 3 ++- 5 files changed, 62 insertions(+), 49 deletions(-) diff --git a/Test/QuasiResource.hs b/Test/QuasiResource.hs index 56d9af56..c07a3644 100644 --- a/Test/QuasiResource.hs +++ b/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" diff --git a/Test/resource-patterns.yaml b/Test/resource-patterns.yaml index 3865b7a0..fb2eda77 100644 --- a/Test/resource-patterns.yaml +++ b/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 diff --git a/Yesod/Request.hs b/Yesod/Request.hs index 589aaeb8..bde85422 100644 --- a/Yesod/Request.hs +++ b/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 diff --git a/Yesod/Resource.hs b/Yesod/Resource.hs index fc30cb27..45d220bf 100644 --- a/Yesod/Resource.hs +++ b/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 diff --git a/Yesod/Response.hs b/Yesod/Response.hs index 085cc6b2..219fec73 100644 --- a/Yesod/Response.hs +++ b/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