fr33domlover
/
yesod


			
							123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332
							{-# 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 = "<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 parseHtml_ 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 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 ("<html><head><title>Hello</title></head><body><p>Hello World</p><p>Hello Moon</p></body></html>" :: Text)

    onStatic "labels" $ dispatchTo $
        return ("<html><label><input type='checkbox' name='fooname' id='foobar'>Foo Bar</label></html>" :: 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|
        <p>
            Welcome to my test application.
    |]

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