yesod-test can use type-safe URLs

2013-04-02 17:29:09 +03:00 · 2013-04-02 17:29:09 +03:00 · db53252960
commit db53252960
parent ad817275e8
3 changed files with 116 additions and 85 deletions
--- a/yesod-test/Yesod/Test.hs
+++ b/yesod-test/Yesod/Test.hs
@ -6,7 +6,7 @@ Yesod.Test is a pragmatic framework for testing web applications built
 using wai and persistent.

 By pragmatic I may also mean 'dirty'. It's main goal is to encourage integration
-and system testing of web applications by making everything /easy to test/. 
+and system testing of web applications by making everything /easy to test/.

 Your tests are like browser sessions that keep track of cookies and the last
 visited page. You can perform assertions on the content of HTML responses,
@ -84,7 +84,7 @@ import qualified Control.Monad.Trans.State as ST
 import Control.Monad.IO.Class
 import System.IO
 import Yesod.Test.TransversingCSS
-import Yesod.Core (toWaiAppPlain, YesodDispatch)
+import Yesod.Core
 import qualified Data.Text.Lazy as TL
 import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)
 import Text.XML.Cursor hiding (element)
@ -381,7 +381,7 @@ fileByLabel label path mime = do
  name <- nameFromLabel label
  fileByName name path mime

-- | Lookup a _nonce form field and add it's value to the params. 
+-- | Lookup a _nonce form field and add it's value to the params.
 -- Receives a CSS selector that should resolve to the form element containing the nonce.
 addNonce_ :: Query -> RequestBuilder ()
 addNonce_ scope = do
@ -396,107 +396,125 @@ addNonce :: RequestBuilder ()
 addNonce = addNonce_ ""

 -- | Perform a POST request to url, using params
-post :: BS8.ByteString -> RequestBuilder () -> YesodExample site ()
+post :: (Yesod site, RedirectUrl site url)
+     => url -> RequestBuilder () -> YesodExample site ()
 post url paramsBuild = do
  doRequest "POST" url paramsBuild

 -- | Perform a POST request without params
-post_ :: BS8.ByteString -> YesodExample site ()
+post_ :: (Yesod site, RedirectUrl site url) => url -> YesodExample site ()
 post_ = flip post $ return ()
- 
+
 -- | Perform a GET request to url, using params
-get :: BS8.ByteString -> RequestBuilder () -> YesodExample site ()
+get :: (Yesod site, RedirectUrl site url) => url -> RequestBuilder () -> YesodExample site ()
 get url paramsBuild = doRequest "GET" url paramsBuild

 -- | Perform a GET request without params
-get_ :: BS8.ByteString -> YesodExample site ()
+get_ :: (Yesod site, RedirectUrl site url) => url -> YesodExample site ()
 get_ = flip get $ return ()

 -- | General interface to performing requests, letting you specify the request method
-doRequest :: H.Method -> BS8.ByteString -> RequestBuilder a -> YesodExample site ()
+doRequest :: (Yesod site, RedirectUrl site url)
+          => H.Method -> url -> RequestBuilder a -> YesodExample site ()
 doRequest method url paramsBuild = doRequestHeaders method url [] paramsBuild

+fromHandler :: Yesod site => HandlerT site IO a -> YesodExample site a
+fromHandler h = do
+    site <- fmap yedSite ST.get
+    eres <- runFakeHandler
+        M.empty
+        (const $ error "Yesod.Test: No logger available")
+        site
+        h
+    either (error . show) return eres
+
 -- | General interface to performing requests, allowing you to add extra
 -- headers as well as letting you specify the request method.
-doRequestHeaders :: H.Method -> BS8.ByteString -> [H.Header] -> RequestBuilder a -> YesodExample site ()
-doRequestHeaders method url extrahead paramsBuild = do
-  YesodExampleData app conn oldCookies mRes <- ST.get
+doRequestHeaders :: (Yesod site, RedirectUrl site url)
+                 => H.Method
+                 -> url
+                 -> [H.Header]
+                 -> RequestBuilder a
+                 -> YesodExample site ()
+doRequestHeaders method url' extrahead paramsBuild = do
+    url <- fromHandler $ toTextUrl url'
+    let (urlPath, urlQuery) = T.break (== '?') url
+    YesodExampleData app conn oldCookies mRes <- ST.get

-  -- expire cookies and filter them for the current path. TODO: support max age
-  currentUtc <- liftIO getCurrentTime
-  let cookies = M.filter (checkCookieTime currentUtc) oldCookies
-      cookiesForPath = M.filter checkCookiePath cookies
+    -- expire cookies and filter them for the current path. TODO: support max age
+    currentUtc <- liftIO getCurrentTime
+    let cookies = M.filter (checkCookieTime currentUtc) oldCookies
+        cookiesForPath = M.filter (checkCookiePath url) cookies

-  RequestBuilderData parts _ <- liftIO $ ST.execStateT paramsBuild RequestBuilderData
-    { rbdPosts = []
-    , rbdResponse = mRes
-    }
-  let maker
-        | DL.any isFile parts = makeMultipart
-        | otherwise = makeSinglepart
-      req = maker cookiesForPath parts
+    RequestBuilderData parts _ <- liftIO $ ST.execStateT paramsBuild RequestBuilderData
+      { rbdPosts = []
+      , rbdResponse = mRes
+      }
+    let maker
+          | DL.any isFile parts = makeMultipart
+          | otherwise = makeSinglepart
+        req = maker cookiesForPath parts urlPath urlQuery

-  response <- liftIO $ runSession (srequest req) app
-  let newCookies = map (Cookie.parseSetCookie . snd) $ DL.filter (("Set-Cookie"==) . fst) $ simpleHeaders response
-      cookies' = M.fromList [(Cookie.setCookieName c, c) | c <- newCookies] `M.union` cookies
-  ST.put $ YesodExampleData app conn cookies' (Just response)
- where
-  isFile (ReqFilePart _ _ _ _) = True
-  isFile _ = False
+    response <- liftIO $ runSession (srequest req) app
+    let newCookies = map (Cookie.parseSetCookie . snd) $ DL.filter (("Set-Cookie"==) . fst) $ simpleHeaders response
+        cookies' = M.fromList [(Cookie.setCookieName c, c) | c <- newCookies] `M.union` cookies
+    ST.put $ YesodExampleData app conn cookies' (Just response)
+  where
+    isFile (ReqFilePart _ _ _ _) = True
+    isFile _ = False

-  checkCookieTime t c = case Cookie.setCookieExpires c of
-                            Nothing -> True
-                            Just t' -> t < t'
-  checkCookiePath c = case Cookie.setCookiePath c of
-                            Nothing -> True
-                            Just x  -> x `BS8.isPrefixOf` url
+    checkCookieTime t c = case Cookie.setCookieExpires c of
+                              Nothing -> True
+                              Just t' -> t < t'
+    checkCookiePath url c =
+      case Cookie.setCookiePath c of
+        Nothing -> True
+        Just x  -> x `BS8.isPrefixOf` TE.encodeUtf8 url

-  -- For building the multi-part requests
-  boundary :: String
-  boundary = "*******noneedtomakethisrandom"
-  separator = BS8.concat ["--", BS8.pack boundary, "\r\n"]
-  makeMultipart cookies parts =
-    flip SRequest (BSL8.fromChunks [multiPartBody parts]) $ mkRequest $
-      [ ("Cookie", Builder.toByteString $ Cookie.renderCookies
-            [(Cookie.setCookieName c, Cookie.setCookieValue c) | c <- map snd $ M.toList cookies])
-      , ("Content-Type", BS8.pack $ "multipart/form-data; boundary=" ++ boundary)
-      ] ++ extrahead
-  multiPartBody parts =
-    BS8.concat $ separator : [BS8.concat [multipartPart p, separator] | p <- parts]
-  multipartPart (ReqPlainPart k v) = BS8.concat
-    [ "Content-Disposition: form-data; "
-    , "name=\"", TE.encodeUtf8 k, "\"\r\n\r\n"
-    , TE.encodeUtf8 v, "\r\n"]
-  multipartPart (ReqFilePart k v bytes mime) = BS8.concat
-    [ "Content-Disposition: form-data; "
-    , "name=\"", TE.encodeUtf8 k, "\"; "
-    , "filename=\"", BS8.pack v, "\"\r\n"
-    , "Content-Type: ", TE.encodeUtf8 mime, "\r\n\r\n"
-    , BS8.concat $ BSL8.toChunks bytes, "\r\n"]
+    -- For building the multi-part requests
+    boundary :: String
+    boundary = "*******noneedtomakethisrandom"
+    separator = BS8.concat ["--", BS8.pack boundary, "\r\n"]
+    makeMultipart cookies parts urlPath urlQuery =
+      flip SRequest (BSL8.fromChunks [multiPartBody parts]) $ mkRequest
+        ([ ("Cookie", Builder.toByteString $ Cookie.renderCookies
+              [(Cookie.setCookieName c, Cookie.setCookieValue c) | c <- map snd $ M.toList cookies])
+        , ("Content-Type", BS8.pack $ "multipart/form-data; boundary=" ++ boundary)
+        ] ++ extrahead) urlPath urlQuery
+    multiPartBody parts =
+      BS8.concat $ separator : [BS8.concat [multipartPart p, separator] | p <- parts]
+    multipartPart (ReqPlainPart k v) = BS8.concat
+      [ "Content-Disposition: form-data; "
+      , "name=\"", TE.encodeUtf8 k, "\"\r\n\r\n"
+      , TE.encodeUtf8 v, "\r\n"]
+    multipartPart (ReqFilePart k v bytes mime) = BS8.concat
+      [ "Content-Disposition: form-data; "
+      , "name=\"", TE.encodeUtf8 k, "\"; "
+      , "filename=\"", BS8.pack v, "\"\r\n"
+      , "Content-Type: ", TE.encodeUtf8 mime, "\r\n\r\n"
+      , BS8.concat $ BSL8.toChunks bytes, "\r\n"]

-  -- For building the regular non-multipart requests
-  makeSinglepart cookies parts = SRequest (mkRequest $
-    [ ("Cookie", Builder.toByteString $ Cookie.renderCookies
-            [(Cookie.setCookieName c, Cookie.setCookieValue c) | c <- map snd $ M.toList cookies])
-    , ("Content-Type", "application/x-www-form-urlencoded")
-    ] ++ extrahead) $
-    BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&" $ map singlepartPart parts
+    -- For building the regular non-multipart requests
+    makeSinglepart cookies parts urlPath urlQuery = SRequest (mkRequest
+      ([ ("Cookie", Builder.toByteString $ Cookie.renderCookies
+              [(Cookie.setCookieName c, Cookie.setCookieValue c) | c <- map snd $ M.toList cookies])
+      , ("Content-Type", "application/x-www-form-urlencoded")
+      ] ++ extrahead) urlPath urlQuery) $
+      BSL8.fromChunks $ return $ TE.encodeUtf8 $ T.intercalate "&" $ map singlepartPart parts

-  singlepartPart (ReqFilePart _ _ _ _) = ""
-  singlepartPart (ReqPlainPart k v) = T.concat [k,"=",v]
+    singlepartPart (ReqFilePart _ _ _ _) = ""
+    singlepartPart (ReqPlainPart k v) = T.concat [k,"=",v]

-  -- General request making 
-  mkRequest headers = defaultRequest
-    { requestMethod = method
-    , remoteHost = Sock.SockAddrInet 1 2
-    , requestHeaders = headers
-    , rawPathInfo = urlPath
-    , pathInfo = DL.filter (/="") $ T.split (== '/') $ TE.decodeUtf8 urlPath
-    , rawQueryString = urlQuery
-    , queryString = H.parseQuery urlQuery
-    }
-
-  (urlPath, urlQuery) = BS8.break (== '?') url
+    -- General request making
+    mkRequest headers urlPath urlQuery = defaultRequest
+      { requestMethod = method
+      , remoteHost = Sock.SockAddrInet 1 2
+      , requestHeaders = headers
+      , rawPathInfo = TE.encodeUtf8 urlPath
+      , pathInfo = DL.filter (/="") $ T.split (== '/') urlPath
+      , rawQueryString = TE.encodeUtf8 urlQuery
+      , queryString = H.parseQuery $ TE.encodeUtf8 urlQuery
+      }

 -- Yes, just a shortcut
 failure :: (MonadIO a) => T.Text -> a b
--- a/yesod-test/test/main.hs
+++ b/yesod-test/test/main.hs
@ -3,11 +3,13 @@
 import Test.HUnit hiding (Test)
 import Test.Hspec

-import Yesod.Core (liteApp, dispatchTo, Html)
+import Yesod.Core
 import Yesod.Test
 import Yesod.Test.CssQuery
 import Yesod.Test.TransversingCSS
 import Text.XML
+import Data.Text (Text)
+import Data.Monoid ((<>))

 import Data.ByteString.Lazy.Char8 ()
 import qualified Data.Map as Map
@ -62,16 +64,26 @@ main = hspec $ do
                        ]
                    ]
             in parseHtml_ html @?= doc
-    let app = liteApp $ dispatchTo $ return ("Hello world!" :: Html)
+    let app = liteApp $ dispatchTo $ do
+            mfoo <- lookupGetParam "foo"
+            case mfoo of
+                Nothing -> return "Hello world!"
+                Just foo -> return $ "foo=" <> foo
    describe "basic usage" $ yesodSpec app $ do
        ydescribe "tests1" $ do
            yit "tests1a" $ do
-                get_ "/"
+                get_ ("/" :: Text)
                statusIs 200
                bodyEquals "Hello world!"
            yit "tests1b" $ do
-                get_ "/foo"
+                get_ ("/foo" :: Text)
                statusIs 404
        ydescribe "tests2" $ do
-            yit "tests2a" $ return ()
+            yit "type-safe URLs" $ do
+                get_ $ LiteAppRoute []
+                statusIs 200
+            yit "type-safe URLs with query-string" $ do
+                get_ (LiteAppRoute [], [("foo", "bar")])
+                statusIs 200
+                bodyEquals "foo=bar"
            yit "tests2b" $ return ()
--- a/yesod-test/yesod-test.cabal
+++ b/yesod-test/yesod-test.cabal
@ -58,6 +58,7 @@ test-suite test
                          , containers
                          , html-conduit
                          , yesod-core
+                          , text

 source-repository head
  type: git