DiscussionTest.hs 6.52 KB
Newer Older
1
{-# LANGUAGE OverloadedStrings #-}
Mitchell Rosen's avatar
Mitchell Rosen committed
2
{-# LANGUAGE FlexibleContexts #-}
3 4 5
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}

6 7 8 9 10
module DiscussionTest
    ( discussionSpecs
    ) where

import TestImport
11
import Import (key)
12

13 14
import qualified Data.Map as M

15
import Network.Wai.Test (SResponse (..))
16
import qualified Data.Text as T
17
import qualified Data.ByteString.Char8 as BSC
18

19 20
import Model.Language

21
import Control.Monad
22

23
import Yesod (RedirectUrl)
24

25
discussionSpecs :: Spec
26
discussionSpecs = do
27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50
    forM_ [minBound..maxBound] $ \case
        DiscussionTypeWikiPage -> runDiscussionTest "wiki page"
            (WikiDiscussionR "snowdrift" LangEn "about")
            (WikiCommentR "snowdrift" LangEn "about")
            (NewWikiDiscussionR "snowdrift" LangEn "about")
            (ReplyWikiCommentR "snowdrift" LangEn "about")
            (RethreadWikiCommentR "snowdrift" LangEn "about")

        DiscussionTypeBlogPost -> do
            runDiscussionTest "blog post"
                (BlogPostDiscussionR "snowdrift" "test")
                (BlogPostCommentR "snowdrift" "test")
                (NewBlogPostDiscussionR "snowdrift" "test")
                (ReplyBlogPostCommentR "snowdrift" "test")
                (RethreadBlogPostCommentR "snowdrift" "test")

        DiscussionTypeProject -> runDiscussionTest "project"
            (ProjectDiscussionR "snowdrift")
            (ProjectCommentR "snowdrift")
            (NewProjectDiscussionR "snowdrift")
            (ReplyProjectCommentR "snowdrift")
            (RethreadProjectCommentR "snowdrift")

        DiscussionTypeUser ->
51
            let user_id = key $ PersistInt64 1
52 53 54 55 56 57 58 59 60 61 62
             in runDiscussionTest "user"
                    (UserDiscussionR user_id)
                    (UserCommentR user_id)
                    (NewUserDiscussionR user_id)
                    (ReplyUserCommentR user_id)
                    (RethreadUserCommentR user_id)


runDiscussionTest :: (Show url, RedirectUrl App url) => String -> url -> (CommentId -> url) -> url -> (CommentId -> url) -> (CommentId -> url) -> Spec
runDiscussionTest label discussion_page_url comment_url new_thread_url comment_reply_url comment_rethread_url = do
    ydescribe (unwords ["discussion on", label]) $ do
63
        yit "loads the discussion page" $ [marked|
David L. L. Thomas's avatar
David L. L. Thomas committed
64
            loginAs TestUser
65

66 67 68 69 70 71 72 73 74 75 76
            get200 discussion_page_url
        |]

        let postReply i = [marked|
                (comment_id, approved) <- getLatestCommentId

                when (not approved) $ error $ "comment not approved: " ++ show comment_id

                postComment (comment_reply_url comment_id) $ byLabel "Reply" $ T.pack $ "Thread 1 - reply " ++ show (i :: Integer)

                return (i, comment_id)
77
        |]
78

79
        yit "posts and moves some comments" $ [marked|
David L. L. Thomas's avatar
David L. L. Thomas committed
80
            loginAs TestUser
81

82
            liftIO $ putStrLn "posting root comment"
83

84
            postComment new_thread_url $ byLabel "New Topic" "Thread 1 - root message"
85

86
            liftIO $ putStrLn "posting reply comments"
87

88
            comment_map <- fmap M.fromList $ forM [1..10] postReply
89

90
            let reply_comment = comment_map M.! 4
David L. L. Thomas's avatar
David L. L. Thomas committed
91

92
            get200 $ comment_rethread_url reply_comment
David L. L. Thomas's avatar
David L. L. Thomas committed
93

94
            withStatus 303 True $ request $ do
95
                addNonce
David L. L. Thomas's avatar
David L. L. Thomas committed
96
                setMethod "POST"
97
                setUrl $ comment_rethread_url reply_comment
98
                byLabel "New Parent Url" "/p/snowdrift/w/en/about/d"
David L. L. Thomas's avatar
David L. L. Thomas committed
99
                byLabel "Reason" "testing"
David L. L. Thomas's avatar
David L. L. Thomas committed
100
                addPostParam "mode" "post"
101
        |]
102 103


104
    ydescribe (unwords ["discussion on", label, "- rethreading"]) $ do
105
        let createComments = [marked|
106 107 108 109
                postComment new_thread_url $ byLabel "New Topic" "First message"
                (first_message, True) <- getLatestCommentId
                postComment new_thread_url $ byLabel "New Topic" "Second message"
                (second_message, True) <- getLatestCommentId
110

111
                return (first_message, second_message)
112
            |]
113

114
            testRethread first_message second_message = [marked|
115

116
                get200 $ comment_rethread_url first_message
117

118
                withStatus 303 True $ request $ do
119
                    addNonce
120
                    setMethod "POST"
121
                    setUrl $ comment_rethread_url first_message
122
                    byLabel "New Parent Url" $ T.pack $ "/p/snowdrift/w/en/about/c/" ++ (\ (PersistInt64 i) -> show i) (toPersistValue second_message)
123
                    byLabel "Reason" "testing"
David L. L. Thomas's avatar
David L. L. Thomas committed
124
                    addPostParam "mode" "post"
125

126
                get200 $ comment_url second_message
127 128 129 130 131

                printBody

                bodyContains "First message"
                bodyContains "Second message"
132
            |]
133 134


135
        yit "can move newer comments under older" $ [marked|
David L. L. Thomas's avatar
David L. L. Thomas committed
136
            loginAs TestUser
137

138
            get200 new_thread_url
139

140
            (first_message, second_message) <- createComments
141

142
            testRethread first_message second_message
143
        |]
144 145


146
        yit "can move older comments under newer" $ [marked|
David L. L. Thomas's avatar
David L. L. Thomas committed
147
            loginAs TestUser
148

149
            get200 new_thread_url
150

151
            (first_message, second_message) <- createComments
152

153
            testRethread second_message first_message
154
        |]
David L. L. Thomas's avatar
David L. L. Thomas committed
155

156
        yit "can rethread across pages and the redirect still works" $ [marked|
David L. L. Thomas's avatar
David L. L. Thomas committed
157
            loginAs TestUser
158

159 160
            postComment new_thread_url $ byLabel "New Topic" "posting on about page"
            (originalId, True) <- getLatestCommentId
161

162
            get200 $ comment_rethread_url originalId
163

164
            withStatus 303 True $ request $ do
165
                addNonce
166
                setMethod "POST"
167
                setUrl $ comment_rethread_url originalId
168
                byLabel "New Parent Url" "/p/snowdrift/w/en/intro/d"
169
                byLabel "Reason" "testing cross-page rethreading"
David L. L. Thomas's avatar
David L. L. Thomas committed
170
                addPostParam "mode" "post"
171

172
            withStatus 301 True $ get $ comment_url originalId
173 174 175 176 177 178 179

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

180
            (newId, True) <- getLatestCommentId
181
            let new_url = BSC.unpack location
182 183
                -- desired_url = "http://localhost:3000/p/snowdrift/w/intro/c/" ++ (\ (PersistInt64 i) -> show i) (toPersistValue newId)
                desired_url = "http://localhost:3000/c/" ++ (\ (PersistInt64 i) -> show i) (toPersistValue newId)
184

Mitchell Rosen's avatar
Mitchell Rosen committed
185
            assertEqual ("Redirect not matching! (" ++ show new_url ++ " /=  " ++ show desired_url ++ ")") new_url desired_url
186
        |]
Mitchell Rosen's avatar
Mitchell Rosen committed
187