yesod-test-1.6.19: test/main.hs
-- 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, isNothing)
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 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 = "<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 "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 "<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"
yit "can click radio button" $ do
get ("/labels-radio-buttons" :: Text)
request $ do
setMethod "POST"
setUrl ("/labels-radio-buttons" :: Text)
chooseByLabel "Blue"
addToken
bodyContains "colorRadioButton = Just Blue"
yit "can click check boxes" $ do
get ("/labels-checkboxes" :: Text)
request $ do
setMethod "POST"
setUrl ("/labels-checkboxes" :: Text)
checkByLabel "Red"
checkByLabel "Gray"
addToken
bodyContains "colorCheckBoxes = [Gray,Red]"
yit "can select from select list" $ do
get ("/labels-select" :: Text)
request $ do
setMethod "POST"
setUrl ("/labels-select" :: Text)
addToken
selectByLabel "Selection List" "Blue"
bodyContains "SelectionForm {colorSelection = Blue}"
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 ("<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)
onStatic "labels-radio-buttons" $ dispatchTo $ do
((result, widget), _) <- runFormPost
$ renderDivs
$ RadioButtonForm <$> aopt (radioField' optionsEnum) "Color" Nothing
case result of
FormSuccess color -> return $ toHtml $ show color
_ -> defaultLayout [whamlet|$newline never
<p>
^{toHtml $ show result}
<form method=post action="labels-radio-buttons">
^{widget}
|]
onStatic "labels-checkboxes" $ dispatchTo $ do
((result, widget), _) <- runFormPost
$ renderDivs
$ CheckboxesForm <$> areq (checkboxesField' optionsEnum) "Checkboxes" (Just [Blue, Black])
case result of
FormSuccess color -> return $ toHtml $ show color
_ -> defaultLayout [whamlet|$newline never
<p>
^{toHtml $ show result}
<form method=post action="labels-checkboxes">
^{widget}
|]
onStatic "labels-select" $ dispatchTo $ do
((result, widget), _) <- runFormPost
$ renderDivs
$ SelectionForm <$> areq (selectField optionsEnum) "Selection List" Nothing
case result of
FormSuccess color -> return $ toHtml $ show color
_ -> defaultLayout [whamlet|$newline never
<p>
^{toHtml $ show result}
<form method=post action="labels-checkboxes">
^{widget}
|]
data Color = Red | Blue | Gray | Black
deriving (Show, Eq, Enum, Bounded)
newtype RadioButtonForm = RadioButtonForm { colorRadioButton :: Maybe Color } deriving Show
newtype CheckboxesForm = CheckboxesForm { colorCheckBoxes :: [Color] } deriving Show
newtype SelectionForm = SelectionForm {colorSelection :: Color } deriving Show
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