foo

{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} import Test.HUnit hiding (Test) import Test.Hspec import Yesod.Core import Yesod.Form import Yesod.Test import Yesod.Test.CssQuery import Yesod.Test.TransversingCSS import Text.XML import Data.Text (Text, pack) import Data.Monoid ((<>)) import Control.Applicative import Network.Wai (pathInfo, requestHeaders) import Data.Maybe (fromMaybe) import Data.Either (isLeft, isRight) import Control.Exception.Lifted(try, SomeException) import Data.ByteString.Lazy.Char8 () import qualified Data.Map as Map import qualified Text.HTML.DOM as HD import Network.HTTP.Types.Status (status301, status303, unsupportedMediaType415) parseQuery_ = either error id . parseQuery findBySelector_ x = either error id . findBySelector x parseHtml_ = HD.parseLBS main :: IO () main = hspec $ do describe "CSS selector parsing" $ do it "elements" $ parseQuery_ "strong" @?= [[DeepChildren [ByTagName "strong"]]] it "child elements" $ parseQuery_ "strong > i" @?= [[DeepChildren [ByTagName "strong"], DirectChildren [ByTagName "i"]]] it "comma" $ parseQuery_ "strong.bar, #foo" @?= [[DeepChildren [ByTagName "strong", ByClass "bar"]], [DeepChildren [ById "foo"]]] describe "find by selector" $ do it "XHTML" $ let html = "foo

Hello World

" query = "body > p" in findBySelector_ html query @?= ["

Hello World

"] it "HTML" $ let html = "foo

Hello World

" query = "body > p" in findBySelector_ html query @?= ["

Hello World

"] let query = "form.foo input[name=_token][type=hidden][value]" html = "" expected = "" in it query $ findBySelector_ html (pack query) @?= [expected] it "descendents and children" $ let html = "

hello

" query = "p > b u" in findBySelector_ html query @?= ["hello"] it "hyphenated classes" $ let html = "

hello

" query = "p.foo-bar u" in findBySelector_ html query @?= ["hello"] it "descendents" $ let html = "

hello

" query = "p i" in findBySelector_ html query @?= ["hello"] describe "HTML parsing" $ do it "XHTML" $ let html = "foo

Hello World

" doc = Document (Prologue [] Nothing []) root [] root = Element "html" Map.empty [ NodeElement $ Element "head" Map.empty [ NodeElement $ Element "title" Map.empty [NodeContent "foo"] ] , NodeElement $ Element "body" Map.empty [ NodeElement $ Element "br" Map.empty [] , NodeElement $ Element "p" Map.empty [NodeContent "Hello World"] ] ] in parseHtml_ html @?= doc describe "basic usage" $ yesodSpec app $ do ydescribe "tests1" $ do yit "tests1a" $ do get ("/" :: Text) statusIs 200 bodyEquals "Hello world!" yit "tests1b" $ do get ("/foo" :: Text) statusIs 404 ydescribe "tests2" $ do 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 "post params" $ do post ("/post" :: Text) statusIs 500 request $ do setMethod "POST" setUrl $ LiteAppRoute ["post"] addPostParam "foo" "foobarbaz" statusIs 200 bodyEquals "foobarbaz" yit "labels" $ do get ("/form" :: Text) statusIs 200 request $ do setMethod "POST" setUrl ("/form" :: Text) byLabel "Some Label" "12345" fileByLabel "Some File" "test/main.hs" "text/plain" addToken statusIs 200 bodyEquals "12345" yit "finding html" $ do get ("/html" :: Text) statusIs 200 htmlCount "p" 2 htmlAllContain "p" "Hello" htmlAnyContain "p" "World" htmlAnyContain "p" "Moon" htmlNoneContain "p" "Sun" yit "finds the CSRF token by css selector" $ do get ("/form" :: Text) statusIs 200 request $ do setMethod "POST" setUrl ("/form" :: Text) byLabel "Some Label" "12345" fileByLabel "Some File" "test/main.hs" "text/plain" addToken_ "body" statusIs 200 bodyEquals "12345" ydescribe "utf8 paths" $ do yit "from path" $ do get ("/dynamic1/שלום" :: Text) statusIs 200 bodyEquals "שלום" yit "from path, type-safe URL" $ do get $ LiteAppRoute ["dynamic1", "שלום"] statusIs 200 printBody bodyEquals "שלום" yit "from WAI" $ do get ("/dynamic2/שלום" :: Text) statusIs 200 bodyEquals "שלום" ydescribe "labels" $ do yit "can click checkbox" $ do get ("/labels" :: Text) request $ do setMethod "POST" setUrl ("/labels" :: Text) byLabel "Foo Bar" "yes" ydescribe "Content-Type handling" $ do yit "can set a content-type" $ do request $ do setUrl ("/checkContentType" :: Text) addRequestHeader ("Expected-Content-Type","text/plain") addRequestHeader ("Content-Type","text/plain") statusIs 200 yit "adds the form-urlencoded Content-Type if you add parameters" $ do request $ do setUrl ("/checkContentType" :: Text) addRequestHeader ("Expected-Content-Type","application/x-www-form-urlencoded") addPostParam "foo" "foobarbaz" statusIs 200 yit "defaults to no Content-Type" $ do get ("/checkContentType" :: Text) statusIs 200 yit "returns a 415 for the wrong Content-Type" $ do -- Tests that the test handler is functioning request $ do setUrl ("/checkContentType" :: Text) addRequestHeader ("Expected-Content-Type","application/x-www-form-urlencoded") addRequestHeader ("Content-Type","text/plain") statusIs 415 describe "cookies" $ yesodSpec cookieApp $ do yit "should send the cookie #730" $ do get ("/" :: Text) statusIs 200 post ("/cookie/foo" :: Text) statusIs 303 get ("/" :: Text) statusIs 200 printBody bodyContains "Foo" describe "CSRF with cookies/headers" $ yesodSpec CsrfApp $ do yit "Should receive a CSRF cookie and add its value to the headers" $ do get ("/" :: Text) statusIs 200 request $ do setMethod "POST" setUrl ("/" :: Text) addTokenFromCookie statusIs 200 yit "Should 403 requests if we don't add the CSRF token" $ do get ("/" :: Text) statusIs 200 request $ do setMethod "POST" setUrl ("/" :: Text) statusIs 403 describe "test redirects" $ yesodSpec app $ do yit "follows 303 redirects when requested" $ do get ("/redirect303" :: Text) statusIs 303 r <- followRedirect liftIO $ assertBool "expected a Right from a 303 redirect" $ isRight r statusIs 200 bodyContains "we have been successfully redirected" yit "follows 301 redirects when requested" $ do get ("/redirect301" :: Text) statusIs 301 r <- followRedirect liftIO $ assertBool "expected a Right from a 301 redirect" $ isRight r statusIs 200 bodyContains "we have been successfully redirected" yit "returns a Left when no redirect was returned" $ do get ("/" :: Text) statusIs 200 r <- followRedirect liftIO $ assertBool "expected a Left when not a redirect" $ isLeft r instance RenderMessage LiteApp FormMessage where renderMessage _ _ = defaultFormMessage app :: LiteApp app = liteApp $ do dispatchTo $ do mfoo <- lookupGetParam "foo" case mfoo of Nothing -> return "Hello world!" Just foo -> return $ "foo=" <> foo onStatic "dynamic1" $ withDynamic $ \d -> dispatchTo $ return (d :: Text) onStatic "dynamic2" $ onStatic "שלום" $ dispatchTo $ do req <- waiRequest return $ pathInfo req !! 1 onStatic "post" $ dispatchTo $ do mfoo <- lookupPostParam "foo" case mfoo of Nothing -> error "No foo" Just foo -> return foo onStatic "redirect301" $ dispatchTo $ redirectWith status301 ("/redirectTarget" :: Text) >> return () onStatic "redirect303" $ dispatchTo $ redirectWith status303 ("/redirectTarget" :: Text) >> return () onStatic "redirectTarget" $ dispatchTo $ return ("we have been successfully redirected" :: Text) onStatic "form" $ dispatchTo $ do ((mfoo, widget), _) <- runFormPost $ renderDivs $ (,) <$> areq textField "Some Label" Nothing <*> areq fileField "Some File" Nothing case mfoo of FormSuccess (foo, _) -> return $ toHtml foo _ -> defaultLayout widget onStatic "html" $ dispatchTo $ return ("Hello

Hello World

Hello Moon

" :: Text) onStatic "labels" $ dispatchTo $ return ("Foo Bar" :: Text) onStatic "checkContentType" $ dispatchTo $ do headers <- requestHeaders <$> waiRequest let actual = lookup "Content-Type" headers expected = lookup "Expected-Content-Type" headers if actual == expected then return () else sendResponseStatus unsupportedMediaType415 () cookieApp :: LiteApp cookieApp = liteApp $ do dispatchTo $ fromMaybe "no message available" <$> getMessage onStatic "cookie" $ do onStatic "foo" $ dispatchTo $ do setMessage "Foo" redirect ("/cookie/home" :: Text) return () data CsrfApp = CsrfApp mkYesod "CsrfApp" [parseRoutes| / HomeR GET POST |] instance Yesod CsrfApp where yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware getHomeR :: Handler Html getHomeR = defaultLayout [whamlet|

Welcome to my test application. |] postHomeR :: Handler Html postHomeR = defaultLayout [whamlet|

Welcome to my test application. |]