We are no longer offering accounts on this server. Consider https://gitlab.freedesktop.org/ as a place to host projects.

BlogTest.hs 3.45 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module BlogTest
    ( blogSpecs
    ) where

import TestImport
import qualified Data.Map as M
import qualified Text.XML as XML
import qualified Text.HTML.DOM as HTML

import Database.Esqueleto hiding (get)

import Network.Wai.Test (SResponse (..))
import Data.Text as T
import Data.Text.Encoding
import qualified Data.ByteString.Char8 as BSC

import Control.Monad

import Data.Maybe (fromMaybe)

blogSpecs :: Spec
blogSpecs = do
    let postBlog route stmts = do
            get route
            statusIs 200

            [ form ] <- htmlQuery "form"

            let getAttrs = XML.elementAttributes . XML.documentRoot . HTML.parseLBS

            request $ do
                addNonce
                setMethod "POST"
                let route' = maybe (Left route) Right $ M.lookup "action" $ getAttrs form
                either setUrl setUrl route'
                addPostParam "mode" "post"
                stmts

            statusIsResp 302

        previewBlog route stmts = do
            get route
            statusIs 200

            [ form ] <- htmlQuery "form"

            let getAttrs = XML.elementAttributes . XML.documentRoot . HTML.parseLBS

            request $ do
                addNonce
                setMethod "POST"
                maybe (setUrl route) setUrl $ M.lookup "action" $ getAttrs form

                addPostParam "mode" "preview"
                stmts

            statusIs 200



    ydescribe "blog" $ do

        yit "loads the project page - no blog post" $ do
            login

            get $ ProjectR "snowdrift"

            statusIs 200

        {-
            htmlNoneContain "#post" "Above fold."
            htmlNoneContain "#post" "Below fold."
        -}


        yit "loads the project blog - no blog post" $ do
            login

            get $ ProjectBlogR "snowdrift"

            statusIs 200

            htmlNoneContain ".post" "Above fold."
            htmlNoneContain ".post" "Below fold."


        yit "previews blog post" $ do
            login

            previewBlog (NewProjectBlogPostR "snowdrift") $ do
                byLabel "Post Title" "Test"
                byLabel "Post Handle" "test"
                byLabel "Content" "Above fold.\n***\nBelow fold."

            bodyContains "Above fold."
            bodyContains "Below fold."


        yit "posts blog post" $ do
            login

            postBlog (NewProjectBlogPostR "snowdrift") $ do
                byLabel "Post Title" "Test"
                byLabel "Post Handle" "test"
                byLabel "Content" "Above fold.\n***\nBelow fold."

            Just route <- extractLocation

            get $ decodeUtf8 route

            statusIs 200

            htmlAnyContain ".post" "Above fold."
            htmlNoneContain ".post" "Below fold."

            get $ ProjectBlogPostR "snowdrift" "test"

            htmlAnyContain ".post" "Above fold."
            htmlAnyContain ".post" "Below fold."


        yit "loads the project blog - with blog post" $ do
            login

            get $ ProjectBlogR "snowdrift"

            statusIs 200

            htmlAnyContain ".post" "Above fold."
            htmlNoneContain ".post" "Below fold."

    {-
        yit "loads the project page - with blog post" $ do
            login

            get $ ProjectR "snowdrift"

            statusIs 200

            htmlAllContain "#post" "Above fold."
            htmlNoneContain "#post" "Below fold."
    -}