-- Ignore warnings about using deprecated byLabel/fileByLabel functions {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main ( main -- avoid warnings , resourcesRoutedApp , Widget ) where import Test.HUnit hiding (Test) import Test.Hspec import qualified Test.Hspec as 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.Char (toUpper) import Data.Monoid ((<>)) import Control.Applicative import Network.Wai (pathInfo, rawQueryString, requestHeaders) import Network.Wai.Test (SResponse(simpleBody)) import Numeric (showHex) import Data.Maybe (fromMaybe) import Data.Either (isLeft, isRight) import Test.HUnit.Lang import Data.ByteString.Lazy.Char8 () import qualified Data.Map as Map import qualified Text.HTML.DOM as HD import Network.HTTP.Types.Status (status200, status301, status303, status403, status422, unsupportedMediaType415) import UnliftIO.Exception (tryAny, SomeException, try, Exception) import Control.Monad.IO.Unlift (toIO) import qualified Web.Cookie as Cookie import Data.Maybe (isNothing) import qualified Data.Text as T import qualified Data.ByteString.Char8 as B8 import Yesod.Test.Internal (contentTypeHeaderIsUtf8) parseQuery_ :: Text -> [[SelectorGroup]] parseQuery_ = either error id . parseQuery findBySelector_ :: HtmlLBS -> Query -> [String] findBySelector_ x = either error id . findBySelector x data RoutedApp = RoutedApp { routedAppInteger :: Integer } defaultRoutedApp :: RoutedApp defaultRoutedApp = RoutedApp 0 mkYesod "RoutedApp" [parseRoutes| / HomeR GET POST /resources ResourcesR POST /resources/#Text ResourceR GET /get-integer IntegerR GET |] 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 "p" Map.empty [NodeContent "Hello World"] ] ] in HD.parseLBS html @?= doc it "HTML" $ 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 HD.parseLBS html @?= doc describe "identifying text-based bodies" $ do it "matches content-types with an explicit UTF-8 charset" $ do contentTypeHeaderIsUtf8 "application/custom; charset=UTF-8" @?= True contentTypeHeaderIsUtf8 "application/custom; charset=utf-8" @?= True it "matches content-types with an ASCII charset" $ do contentTypeHeaderIsUtf8 "application/custom; charset=us-ascii" @?= True it "matches content-types that we assume are UTF-8" $ do contentTypeHeaderIsUtf8 "text/html" @?= True contentTypeHeaderIsUtf8 "application/json" @?= True it "doesn't match content-type headers that are binary data" $ do contentTypeHeaderIsUtf8 "image/gif" @?= False contentTypeHeaderIsUtf8 "application/pdf" @?= False 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 yit "tests1c" $ do performMethod "DELETE" ("/" :: Text) statusIs 200 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"] -- If value uses special characters, addPostParam "foo" "foo+bar%41<&baz" statusIs 200 -- They pass through the server correctly. bodyEquals "foo+bar%41<&baz" yit "get params" $ do get ("/query" :: Text) statusIs 200 bodyEquals "" request $ do setMethod "GET" setUrl $ LiteAppRoute ["query"] -- If value uses special characters, addGetParam "foo" "foo+bar%41<&baz" addBareGetParam "goo+car%41<&caz" statusIs 200 -- They pass through the server correctly. let pctEnc c = "%" <> (map toUpper $ showHex (fromEnum c) "") plus = pctEnc '+' pct = pctEnc '%' lt = pctEnc '<' amp = pctEnc '&' bodyEquals $ mconcat [ "goo", plus, "car", pct, "41", lt, amp, "caz", "&foo=foo", plus, "bar", pct, "41", lt, amp, "baz"] yit "labels" $ do get ("/form" :: Text) statusIs 200 request $ do setMethod "POST" setUrl ("/form" :: Text) byLabel "Some Label" "foo+bar%41<&baz" fileByLabel "Some File" "test/main.hs" "text/plain" addToken statusIs 200 -- The '<' and '&' get encoded to HTML entities because -- "/form" (unlike "/post") uses toHtml. bodyEquals "foo+bar%41<&baz" yit "labels WForm" $ do get ("/wform" :: Text) statusIs 200 request $ do setMethod "POST" setUrl ("/wform" :: Text) byLabel "Some WLabel" "12345" fileByLabel "Some WFile" "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" htmlAllContain "span" "O'Kon" htmlAnyContain "p" "World" htmlAnyContain "p" "Moon" htmlAnyContain "p" "O'Kon" htmlNoneContain "p" "Sun" -- we found it so we know the -- matching on quotes works for NoneContain withRunInIO $ \runInIO -> shouldThrow (runInIO (htmlNoneContain "span" "O'Kon")) (\case HUnitFailure _ _ -> True) 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" yit "can follow a link via clickOn" $ do get ("/htmlWithLink" :: Text) clickOn "a#thelink" statusIs 200 bodyEquals "Hello

Hello World

Hello Moon and O'Kon

" get ("/htmlWithLink" :: Text) bad <- tryAny (clickOn "a#nonexistentlink") assertEq "bad link" (isLeft bad) True ydescribe "custom error message" $ do yit "returns the message pass to areqMsg" $ do get ("/form" :: Text) statusIs 200 request $ do setMethod "POST" setUrl ("/form" :: Text) addToken statusIs 200 htmlAnyContain ".errors" "Missing Label" yit "returns the message pass to mreqMsg" $ do get ("/mform" :: Text) statusIs 200 request $ do setMethod "POST" setUrl ("/mform" :: Text) addToken statusIs 200 htmlAnyContain ".errors" "Missing MLabel" yit "returns the message pass to wreqMsg" $ do get ("/wform" :: Text) statusIs 200 request $ do setMethod "POST" setUrl ("/wform" :: Text) addToken statusIs 200 htmlAnyContain ".errors" "Missing WLabel" 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 "byLabel-related tests" $ do yit "fails with \"More than one label contained\" error" $ do get ("/labels2" :: Text) (bad :: Either SomeException ()) <- try (request $ do setMethod "POST" setUrl ("labels2" :: Text) byLabel "hobby" "fishing") assertEq "failure wasn't called" (isLeft bad) True yit "byLabelExact performs an exact match over the given label name" $ do get ("/labels2" :: Text) (bad :: Either SomeException ()) <- try (request $ do setMethod "POST" setUrl ("labels2" :: Text) byLabelExact "hobby" "fishing") assertEq "failure was called" (isRight bad) True yit "byLabelContain looks for the labels which contain the given label name" $ do get ("/label-contain" :: Text) request $ do setMethod "POST" setUrl ("check-hobby" :: Text) byLabelContain "hobby" "fishing" res <- maybe "Couldn't get response" simpleBody <$> getResponse assertEq "hobby isn't set" res "fishing" yit "byLabelContain throws an error if it finds multiple labels" $ do (bad :: Either SomeException ()) <- try (request $ do setMethod "POST" setUrl ("label-contain-error" :: Text) byLabelContain "hobby" "fishing") assertEq "failure wasn't called" (isLeft bad) True yit "bySelectorLabelContain looks for the selector and label which contain the given label name" $ do get ("/selector-label-contain" :: Text) request $ do setMethod "POST" setUrl ("check-hobby" :: Text) bySelectorLabelContain "#hobby-container" "hobby" "fishing" res <- maybe "Couldn't get response" simpleBody <$> getResponse assertEq "hobby isn't set" res "fishing" yit "bySelectorLabelContain throws an error if the selector matches multiple elements" $ do get ("selector-label-contain-error" :: Text) (bad :: Either SomeException ()) <- try (request $ do setMethod "POST" setUrl ("check-hobby" :: Text) bySelectorLabelContain "#hobby-container" "hobby" "fishing") assertEq "failure wasn't called" (isLeft bad) True yit "byLabelPrefix matches over the prefix of the labels" $ do get ("/label-prefix" :: Text) request $ do setMethod "POST" setUrl ("check-hobby" :: Text) byLabelPrefix "hobby" "fishing" res <- maybe "Couldn't get response" simpleBody <$> getResponse assertEq "hobby isn't set" res "fishing" yit "byLabelPrefix throws an error if it finds multiple labels" $ do (bad :: Either SomeException ()) <- try (request $ do setMethod "POST" setUrl ("label-prefix-error" :: Text) byLabelPrefix "hobby" "fishing") assertEq "failure wasn't called" (isLeft bad) True yit "byLabelSuffix matches over the suffix of the labels" $ do get ("/label-suffix" :: Text) request $ do setMethod "POST" setUrl ("check-hobby" :: Text) byLabelSuffix "hobby" "fishing" res <- maybe "Couldn't get response" simpleBody <$> getResponse assertEq "hobby isn't set" res "fishing" yit "byLabelSuffix throws an error if it finds multiple labels" $ do (bad :: Either SomeException ()) <- try (request $ do setMethod "POST" setUrl ("label-suffix-error" :: Text) byLabelSuffix "hobby" "fishing") assertEq "failure wasn't called" (isLeft bad) True 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" yit "should 422 on the cookie named key" $ do get ("cookie/check-no-cookie" :: Text) statusIs 200 testSetCookie Cookie.defaultSetCookie { Cookie.setCookieName = "key" } get ("cookie/check-no-cookie" :: Text) statusIs 422 yit "should be able to delete a cookie" $ do testSetCookie Cookie.defaultSetCookie { Cookie.setCookieName = "key" } get ("cookie/check-no-cookie" :: Text) statusIs 422 testDeleteCookie "key" get ("cookie/check-no-cookie" :: Text) statusIs 200 yit "should be able to clear all cookies" $ do testSetCookie Cookie.defaultSetCookie { Cookie.setCookieName = "key" } get ("cookie/check-no-cookie" :: Text) statusIs 422 testClearCookies get ("cookie/check-no-cookie" :: Text) statusIs 200 yit "should be able to modify cookies" $ do testSetCookie Cookie.defaultSetCookie { Cookie.setCookieName = "key" } get ("cookie/check-no-cookie" :: Text) statusIs 422 testModifyCookies (\_ -> Map.empty) get ("cookie/check-no-cookie" :: Text) statusIs 200 describe "CSRF with cookies/headers" $ yesodSpec defaultRoutedApp $ 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 describe "route parsing in tests" $ yesodSpec defaultRoutedApp $ do yit "parses location header into a route" $ do -- get CSRF token get HomeR statusIs 200 request $ do setMethod "POST" setUrl $ ResourcesR addPostParam "foo" "bar" addTokenFromCookie statusIs 201 loc <- getLocation liftIO $ assertBool "expected location to be available" $ isRight loc let (Right (ResourceR t)) = loc liftIO $ assertBool "expected location header to contain post param" $ t == "bar" yit "returns a Left when no redirect was returned" $ do get HomeR statusIs 200 loc <- getLocation liftIO $ assertBool "expected a Left when not a redirect" $ isLeft loc describe "modifying site value" $ yesodSpec defaultRoutedApp $ do yit "can change site value" $ do get ("/get-integer" :: Text) bodyContains "0" testModifySite (\site -> pure (site { routedAppInteger = 1 }, id)) get ("/get-integer" :: Text) bodyContains "1" describe "Basic Authentication" $ yesodSpec app $ do yit "rejects no header" $ do get ("checkBasicAuth" :: Text) statusIs 403 yit "rejects incorrect header" $ do request $ do setUrl ("checkBasicAuth" :: Text) addBasicAuthHeader "Aladdin" "foo" statusIs 403 yit "accepts correct header" $ do request $ do setUrl ("checkBasicAuth" :: Text) addBasicAuthHeader "Aladdin" "OpenSesame" statusIs 200 describe "JSON parsing" $ yesodSpec app $ do yit "checks for a json array" $ do get ("get-json-response" :: Text) statusIs 200 xs <- requireJSONResponse assertEq "The value is [1]" xs [1 :: Integer] yit "checks for valid content-type" $ do get ("get-json-wrong-content-type" :: Text) statusIs 200 (requireJSONResponse :: YesodExample site [Integer]) `liftedShouldThrow` (\(e :: SomeException) -> True) yit "checks for valid JSON parse" $ do get ("get-json-response" :: Text) statusIs 200 (requireJSONResponse :: YesodExample site [Text]) `liftedShouldThrow` (\(e :: SomeException) -> True) 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 "query" . dispatchTo $ T.pack . B8.unpack . rawQueryString <$> waiRequest 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 $ (,) Control.Applicative.<$> areqMsg textField "Some Label" ("Missing Label" :: SomeMessage LiteApp) Nothing <*> areq fileField "Some File" Nothing case mfoo of FormSuccess (foo, _) -> return $ toHtml foo _ -> defaultLayout widget onStatic "mform" $ dispatchTo $ do ((mfoo, widget), _) <- runFormPost $ renderDivs $ formToAForm $ do (field1F, field1V) <- mreqMsg textField "Some MLabel" ("Missing MLabel" :: SomeMessage LiteApp) Nothing (field2F, field2V) <- mreq fileField "Some MFile" Nothing return ( (,) Control.Applicative.<$> field1F <*> field2F , [field1V, field2V] ) case mfoo of FormSuccess (foo, _) -> return $ toHtml foo _ -> defaultLayout widget onStatic "wform" $ dispatchTo $ do ((mfoo, widget), _) <- runFormPost $ renderDivs $ wFormToAForm $ do field1F <- wreqMsg textField "Some WLabel" ("Missing WLabel" :: SomeMessage LiteApp) Nothing field2F <- wreq fileField "Some WFile" Nothing return $ (,) Control.Applicative.<$> field1F <*> field2F case mfoo of FormSuccess (foo, _) -> return $ toHtml foo _ -> defaultLayout widget onStatic "html" $ dispatchTo $ return ("Hello

Hello World

Hello Moon and O'Kon

" :: Text) onStatic "htmlWithLink" $ dispatchTo $ return ("A linkLink!" :: Text) onStatic "labels" $ dispatchTo $ return ("" :: Text) onStatic "labels2" $ dispatchTo $ return ("" :: Text) onStatic "label-contain" $ dispatchTo $ return ("" :: Text) onStatic "label-contain-error" $ dispatchTo $ return ("" :: Text) onStatic "selector-label-contain" $ dispatchTo $ return ("
" :: Text) onStatic "selector-label-contain-error" $ dispatchTo $ return ("
" :: Text) onStatic "label-prefix" $ dispatchTo $ return ("" :: Text) onStatic "label-prefix-error" $ dispatchTo $ return ("" :: Text) onStatic "label-suffix" $ dispatchTo $ return ("" :: Text) onStatic "label-suffix-error" $ dispatchTo $ return ("" :: Text) onStatic "check-hobby" $ dispatchTo $ do hobby <- lookupPostParam "hobby" return $ fromMaybe "No hobby" hobby 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 () onStatic "checkBasicAuth" $ dispatchTo $ do headers <- requestHeaders <$> waiRequest let authHeader = lookup "Authorization" headers -- Copied from the Wikipedia Aladdin:OpenSesame example if authHeader == Just "Basic QWxhZGRpbjpPcGVuU2VzYW1l" then return () else sendResponseStatus status403 () onStatic "get-json-response" $ dispatchTo $ do (sendStatusJSON status200 ([1] :: [Integer])) :: LiteHandler Value onStatic "get-json-wrong-content-type" $ dispatchTo $ do return ("[1]" :: Text) 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 () onStatic "check-no-cookie" $ dispatchTo $ do mCookie <- lookupCookie "key" if isNothing mCookie then return () else sendResponseStatus status422 () instance Yesod RoutedApp 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. |] postResourcesR :: Handler () postResourcesR = do t <- runRequestBody >>= \case ([("foo", t)], _) -> return t _ -> liftIO $ fail "postResourcesR pattern match failure" sendResponseCreated $ ResourceR t getResourceR :: Text -> Handler Html getResourceR i = defaultLayout [whamlet|

Read item #{i}. |] getIntegerR :: Handler Text getIntegerR = do app <- getYesod pure $ T.pack $ show (routedAppInteger app) -- infix Copied from HSpec's version infix 1 `liftedShouldThrow` liftedShouldThrow :: (MonadUnliftIO m, HasCallStack, Exception e) => m a -> Hspec.Selector e -> m () liftedShouldThrow action sel = do ioAction <- toIO action liftIO $ ioAction `shouldThrow` sel