690 lines
30 KiB
Haskell
690 lines
30 KiB
Haskell
-- 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.Monoid ((<>))
|
||
import Control.Applicative
|
||
import Network.Wai (pathInfo, requestHeaders)
|
||
import Network.Wai.Test (SResponse(simpleBody))
|
||
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 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 = "<html><head><title>foo</title></head><body><p>Hello World</p></body></html>"
|
||
query = "body > p"
|
||
in findBySelector_ html query @?= ["<p>Hello World</p>"]
|
||
it "HTML" $
|
||
let html = "<html><head><title>foo</title></head><body><br><p>Hello World</p></body></html>"
|
||
query = "body > p"
|
||
in findBySelector_ html query @?= ["<p>Hello World</p>"]
|
||
let query = "form.foo input[name=_token][type=hidden][value]"
|
||
html = "<input name='_token' type='hidden' value='foo'><form class='foo'><input name='_token' type='hidden' value='bar'></form>"
|
||
expected = "<input name=\"_token\" type=\"hidden\" value=\"bar\" />"
|
||
in it query $ findBySelector_ html (pack query) @?= [expected]
|
||
it "descendents and children" $
|
||
let html = "<html><p><b><i><u>hello</u></i></b></p></html>"
|
||
query = "p > b u"
|
||
in findBySelector_ html query @?= ["<u>hello</u>"]
|
||
it "hyphenated classes" $
|
||
let html = "<html><p class='foo-bar'><b><i><u>hello</u></i></b></p></html>"
|
||
query = "p.foo-bar u"
|
||
in findBySelector_ html query @?= ["<u>hello</u>"]
|
||
it "descendents" $
|
||
let html = "<html><p><b><i>hello</i></b></p></html>"
|
||
query = "p i"
|
||
in findBySelector_ html query @?= ["<i>hello</i>"]
|
||
describe "HTML parsing" $ do
|
||
it "XHTML" $
|
||
let html = "<html><head><title>foo</title></head><body><p>Hello World</p></body></html>"
|
||
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 = "<html><head><title>foo</title></head><body><br><p>Hello World</p></body></html>"
|
||
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 "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 "<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon and <span>O'Kon</span></p></body></html>"
|
||
|
||
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 "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 ("<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon and <span>O'Kon</span></p></body></html>" :: Text)
|
||
|
||
onStatic "htmlWithLink" $ dispatchTo $
|
||
return ("<html><head><title>A link</title></head><body><a href=\"/html\" id=\"thelink\">Link!</a></body></html>" :: Text)
|
||
onStatic "labels" $ dispatchTo $
|
||
return ("<html><label><input type='checkbox' name='fooname' id='foobar'>Foo Bar</label></html>" :: Text)
|
||
onStatic "labels2" $ dispatchTo $
|
||
return ("<html><label for='hobby'>hobby</label><label for='hobby2'>hobby2</label><input type='text' name='hobby' id='hobby'><input type='text' name='hobby2' id='hobby2'></html>" :: Text)
|
||
onStatic "label-contain" $ dispatchTo $
|
||
return ("<html><label for='hobby'>XXXhobbyXXX</label><input type='text' name='hobby' id='hobby'></html>" :: Text)
|
||
onStatic "label-contain-error" $ dispatchTo $
|
||
return ("<html><label for='hobby'>XXXhobbyXXX</label><label for='hobby2'>XXXhobby2XXX</label><input type='text' name='hobby' id='hobby'><input type='text' name='hobby2' id='hobby2'></html>" :: Text)
|
||
onStatic "selector-label-contain" $ dispatchTo $
|
||
return ("<html><div><label for='hobby-1'>XXXhobbyXXX</label><input type='text' name='hobby-1' id='hobby-1'></div><div id='hobby-container'><label for='hobby'>XXXhobbyXXX</label><input type='text' name='hobby' id='hobby'></div></html>" :: Text)
|
||
onStatic "selector-label-contain-error" $ dispatchTo $
|
||
return ("<html><div id='hobby-container'><label for='hobby-1'>XXXhobbyXXX</label><input type='text' name='hobby-1' id='hobby-1'></div><div id='hobby-container'><label for='hobby'>XXXhobbyXXX</label><input type='text' name='hobby' id='hobby'></div></html>" :: Text)
|
||
onStatic "label-prefix" $ dispatchTo $
|
||
return ("<html><label for='hobby'>hobbyXXX</label><input type='text' name='hobby' id='hobby'></html>" :: Text)
|
||
onStatic "label-prefix-error" $ dispatchTo $
|
||
return ("<html><label for='hobby'>hobbyXXX</label><label for='hobby2'>hobby2XXX</label><input type='text' name='hobby' id='hobby'><input type='text' name='hobby2' id='hobby2'></html>" :: Text)
|
||
onStatic "label-suffix" $ dispatchTo $
|
||
return ("<html><label for='hobby'>XXXhobby</label><input type='text' name='hobby' id='hobby'></html>" :: Text)
|
||
onStatic "label-suffix-error" $ dispatchTo $
|
||
return ("<html><label for='hobby'>XXXhobby</label><label for='hobby2'>XXXneo-hobby</label><input type='text' name='hobby' id='hobby'><input type='text' name='hobby2' id='hobby2'></html>" :: 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|
|
||
<p>
|
||
Welcome to my test application.
|
||
|]
|
||
|
||
postHomeR :: Handler Html
|
||
postHomeR = defaultLayout
|
||
[whamlet|
|
||
<p>
|
||
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|
|
||
<p>
|
||
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
|