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

DiscussionTest.hs 5.31 KB
Newer Older
David L. L. Thomas's avatar
David L. L. Thomas committed
1
{-# LANGUAGE OverloadedStrings #-}
Mitchell Rosen's avatar
Mitchell Rosen committed
2
{-# LANGUAGE FlexibleContexts #-}
David L. L. Thomas's avatar
David L. L. Thomas committed
3 4 5 6 7
module DiscussionTest
    ( discussionSpecs
    ) where

import TestImport
David L. L. Thomas's avatar
David L. L. Thomas committed
8 9 10 11 12 13
import qualified Data.Map as M
import qualified Text.XML as XML
import qualified Text.HTML.DOM as HTML

import Database.Esqueleto hiding (get)

14
import Network.Wai.Test (SResponse (..))
David L. L. Thomas's avatar
David L. L. Thomas committed
15
import Data.Text as T
16
import qualified Data.ByteString.Char8 as BSC
David L. L. Thomas's avatar
David L. L. Thomas committed
17 18

import Control.Monad
David L. L. Thomas's avatar
David L. L. Thomas committed
19 20

discussionSpecs :: Spec
21 22 23 24 25 26 27 28 29 30 31 32
discussionSpecs = do
    let postComment route stmts = do
            get route
            statusIs 200

            [ form ] <- htmlQuery "form"

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

            request $ do
                addNonce
                setMethod "POST"
Mitchell Rosen's avatar
Mitchell Rosen committed
33
                maybe (setUrl route) setUrl (M.lookup "action" $ getAttrs form)
34 35 36
                addPostParam "mode" "post"
                stmts

37
            statusIsResp 302
38 39

        getLatestCommentId = do
40
            [ Value (Just comment_id) ] <- testDB $ select $ from $ \ comment -> return (max_ $ comment ^. CommentId)
41 42
            return comment_id

David L. L. Thomas's avatar
David L. L. Thomas committed
43
    ydescribe "discussion" $ do
David L. L. Thomas's avatar
David L. L. Thomas committed
44 45 46 47 48 49
        yit "loads the discussion page" $ do
            login

            get $ DiscussWikiR "snowdrift" "about"
            statusIs 200

50
        yit "posts and moves some comments" $ do
David L. L. Thomas's avatar
David L. L. Thomas committed
51 52
            login

53
            liftIO $ putStrLn "posting root comment"
David L. L. Thomas's avatar
David L. L. Thomas committed
54

55
            postComment (NewDiscussWikiR "snowdrift" "about") $ byLabel "New Topic" "Thread 1 - root message"
David L. L. Thomas's avatar
David L. L. Thomas committed
56

57
            liftIO $ putStrLn "posting reply comments"
David L. L. Thomas's avatar
David L. L. Thomas committed
58

David L. L. Thomas's avatar
David L. L. Thomas committed
59
            comment_map <- fmap M.fromList $ forM [1..10] $ \ i -> do
60
                comment_id <- getLatestCommentId
David L. L. Thomas's avatar
David L. L. Thomas committed
61

62
                postComment (ReplyCommentR "snowdrift" "about" comment_id) $ byLabel "Reply" $ T.pack $ "Thread 1 - reply " ++ show (i :: Integer)
David L. L. Thomas's avatar
David L. L. Thomas committed
63

David L. L. Thomas's avatar
David L. L. Thomas committed
64
                return (i, comment_id)
65

David L. L. Thomas's avatar
David L. L. Thomas committed
66 67 68 69 70 71 72 73 74 75 76 77 78 79
            let rethread_url = RethreadWikiCommentR "snowdrift" "about" $ comment_map M.! 4

            get rethread_url

            statusIs 200

            request $ do
                addNonce
                setMethod "POST"
                setUrl rethread_url
                byLabel "New Parent Url" "/p/snowdrift/w/about/d"
                byLabel "Reason" "testing"
                addPostParam "mode" "rethread"

80
            statusIsResp 302
81 82 83 84


    ydescribe "discussion - rethreading" $ do
        let createComments = do
85
                postComment (NewDiscussWikiR "snowdrift" "about") $ byLabel "New Topic" "First message"
86
                first <- getLatestCommentId
87
                postComment (NewDiscussWikiR "snowdrift" "about") $ byLabel "New Topic" "Second message"
88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105
                second <- getLatestCommentId

                return (first, second)

            testRethread first second = do
                let rethread_url c = RethreadWikiCommentR "snowdrift" "about" c

                get $ rethread_url first
                statusIs 200

                request $ do
                    addNonce
                    setMethod "POST"
                    setUrl $ rethread_url first
                    byLabel "New Parent Url" $ T.pack $ "/p/snowdrift/w/about/c/" ++ (\ (PersistInt64 i) -> show i) (unKey second)
                    byLabel "Reason" "testing"
                    addPostParam "mode" "rethread"

106
                statusIsResp 302
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

                get $ DiscussCommentR "snowdrift" "about" second
                statusIs 200

                printBody

                bodyContains "First message"
                bodyContains "Second message"


        yit "can move newer comments under older" $ do
            login

            get $ NewDiscussWikiR "snowdrift" "about"
            statusIs 200

            (first, second) <- createComments

            testRethread first second


        yit "can move older comments under newer" $ do
            login

            get $ NewDiscussWikiR "snowdrift" "about"
            statusIs 200

            (first, second) <- createComments

            testRethread second first
David L. L. Thomas's avatar
David L. L. Thomas committed
137

138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169
        yit "can rethread across pages and the redirect still works" $ do
            login

            postComment (NewDiscussWikiR "snowdrift" "about") $ byLabel "New Topic" "posting on about page"
            originalId <- getLatestCommentId

            get $ RethreadWikiCommentR "snowdrift" "about" originalId
            statusIs 200

            request $ do
                addNonce
                setMethod "POST"
                setUrl $ RethreadWikiCommentR "snowdrift" "about" originalId
                byLabel "New Parent Url" "/p/snowdrift/w/intro/d"
                byLabel "Reason" "testing cross-page rethreading"
                addPostParam "mode" "rethread"

            statusIsResp 302

            get $ DiscussCommentR "snowdrift" "about" originalId
            statusIsResp 301

            Just location <- do
                statusIsResp 301
                withResponse ( \ SResponse { simpleHeaders = h } ->
                                    return $ lookup "Location" h
                             )

            newId <- getLatestCommentId
            let new_url = BSC.unpack location
                desired_url = "http://localhost:3000/p/snowdrift/w/intro/c/" ++ (\ (PersistInt64 i) -> show i) (unKey newId)

Mitchell Rosen's avatar
Mitchell Rosen committed
170 171
            assertEqual ("Redirect not matching! (" ++ show new_url ++ " /=  " ++ show desired_url ++ ")") new_url desired_url

David L. L. Thomas's avatar
David L. L. Thomas committed
172