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

David L. L. Thomas's avatar
David L. L. Thomas committed
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
David L. L. Thomas's avatar
David L. L. Thomas committed
18

19 20
import Model.Language

David L. L. Thomas's avatar
David L. L. Thomas committed
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
David L. L. Thomas's avatar
David L. L. Thomas committed
81

82
            liftIO $ putStrLn "posting root comment"
David L. L. Thomas's avatar
David L. L. Thomas committed
83

84
            postComment new_thread_url $ byLabel "New Topic" "Thread 1 - root message"
David L. L. Thomas's avatar
David L. L. Thomas committed
85

86
            liftIO $ putStrLn "posting reply comments"
David L. L. Thomas's avatar
David L. L. Thomas committed
87

88
            comment_map <- fmap M.fromList $ forM [1..10] postReply
David L. L. Thomas's avatar
David L. L. Thomas committed
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