Commit ba91d9dc authored by David L. L. Thomas's avatar David L. L. Thomas

Discussion on blog posts

Closes SD-286
parent e6048dab
......@@ -54,6 +54,7 @@ import Handler.Notification
import Handler.PostLogin
import Handler.Privacy
import Handler.Project
import Handler.ProjectBlog
import Handler.RepoFeed
import Handler.ResetPassword
import Handler.SnowdriftEvent
......
This diff is collapsed.
This diff is collapsed.
......@@ -635,8 +635,8 @@ getMonolingualWikiR = redirectPolylingualWiki $ \case
Just (ApplicationsR _) -> error "the impossible happened"
Just (ApplicationR _ _) -> error "the impossible happened"
Just (ProjectBlogR _) -> error "the impossible happened"
Just (NewProjectBlogPostR _) -> error "the impossible happened"
Just (ProjectBlogPostR _ _) -> error "the impossible happened"
Just (NewBlogPostR _) -> error "the impossible happened"
Just (BlogPostR _ _) -> error "the impossible happened"
Just (ProjectPledgeButtonR _) -> error "the impossible happened"
Just (ProjectCommentR _ _) -> error "the impossible happened"
Just (ClaimProjectCommentR _ _) -> error "the impossible happened"
......@@ -691,6 +691,27 @@ getMonolingualWikiR = redirectPolylingualWiki $ \case
Just (EventBlogPostR _) -> error "the impossible happened"
Just RepoFeedR -> error "the impossible happened"
Just BuildFeedR -> error "the impossible happened"
Just (BlogPostDiscussionR _ _) -> error "the impossible happened"
Just (NewBlogPostDiscussionR _ _) -> error "the impossible happened"
Just (BlogPostCommentR _ _ _) -> error "the impossible happened"
Just (ClaimBlogPostCommentR _ _ _) -> error "the impossible happened"
Just (CloseBlogPostCommentR _ _ _) -> error "the impossible happened"
Just (DeleteBlogPostCommentR _ _ _) -> error "the impossible happened"
Just (EditBlogPostCommentR _ _ _) -> error "the impossible happened"
Just (FlagBlogPostCommentR _ _ _) -> error "the impossible happened"
Just (ApproveBlogPostCommentR _ _ _) -> error "the impossible happened"
Just (ReplyBlogPostCommentR _ _ _) -> error "the impossible happened"
Just (RethreadBlogPostCommentR _ _ _) -> error "the impossible happened"
Just (RetractBlogPostCommentR _ _ _) -> error "the impossible happened"
Just (BlogPostCommentAddTagR _ _ _) -> error "the impossible happened"
Just (BlogPostCommentTagsR _ _ _) -> error "the impossible happened"
Just (BlogPostCommentTagR _ _ _ _) -> error "the impossible happened"
Just (BlogPostCommentApplyTagR _ _ _) -> error "the impossible happened"
Just (BlogPostCommentCreateTagR _ _ _) -> error "the impossible happened"
Just (UnclaimBlogPostCommentR _ _ _) -> error "the impossible happened"
Just (WatchBlogPostCommentR _ _ _) -> error "the impossible happened"
Just (UnwatchBlogPostCommentR _ _ _) -> error "the impossible happened"
where
redirectSameParams url = do
......
......@@ -290,7 +290,9 @@ insertCommentDB mapproved_ts mapproved_by mk_event created_ts discussion_id mpar
-- | Fetch a comment from the DB, subject to viewing permissions.
fetchCommentDB :: CommentId -> ExprCommentCond -> DB (Either NoCommentReason Comment)
fetchCommentDB comment_id has_permission = get comment_id >>= \case
Nothing -> return (Left CommentNotFound)
Nothing -> do
liftIO $ appendFile "log" $ "comment not found: " ++ show comment_id ++ "\n"
return (Left CommentNotFound)
-- Hooray, the comment exists, now toss it and re-query the database with the
-- provided permission conditions. How else would we be able to differentiate
-- a non-existent comment and a comment the user doesn't have permission to
......@@ -788,11 +790,18 @@ makeCommentRouteDB :: [Language] -> CommentId -> DB (Maybe (Route App))
makeCommentRouteDB langs comment_id = get comment_id >>= \case
Nothing -> return Nothing
Just comment -> fetchDiscussionDB langs (commentDiscussion comment) >>= \case
DiscussionOnProject (Entity _ project) -> return (Just (ProjectCommentR (projectHandle project) comment_id))
DiscussionOnProject (Entity _ project) -> return $ Just $ ProjectCommentR (projectHandle project) comment_id
DiscussionOnWikiPage (Entity _ wiki_target) -> do
project <- getJust (wikiTargetProject wiki_target)
return (Just (WikiCommentR (projectHandle project) (wikiTargetLanguage wiki_target) (wikiTargetTarget wiki_target) comment_id))
project <- getJust $ wikiTargetProject wiki_target
return $ Just $ WikiCommentR (projectHandle project) (wikiTargetLanguage wiki_target) (wikiTargetTarget wiki_target) comment_id
DiscussionOnUser (Entity user_id _) -> do
return (Just (UserCommentR user_id comment_id))
return $ Just $ UserCommentR user_id comment_id
DiscussionOnBlogPost (Entity _ blog_post) -> do
project <- getJust $ blogPostProject blog_post
return $ Just $ BlogPostCommentR (projectHandle project) (blogPostHandle blog_post) comment_id
......@@ -47,7 +47,7 @@ makeLoggedOutCommentActionPermissionsMap :: MakeActionPermissionsMap
makeLoggedOutCommentActionPermissionsMap = return .
foldr (\(Entity comment_id _) -> M.insert comment_id loggedOutCommentActionPermissions) mempty
-- | Action permissions that apply to both a Project discussion and a Projects WikiPage discussion.
-- | Action permissions that apply to a Project discussion, and a Project's WikiPage discussion, and a Project's blog.
makeProjectCommentActionPermissionsMap :: Maybe (Entity User) -> Text -> CommentMods -> MakeActionPermissionsMap
makeProjectCommentActionPermissionsMap Nothing _ _ comments = makeLoggedOutCommentActionPermissionsMap comments
makeProjectCommentActionPermissionsMap (Just (Entity viewer_id viewer)) project_handle CommentMods{..} comments = do
......
module Model.Comment.HandlerInfo
( CommentHandlerInfo(..)
, projectCommentHandlerInfo
, projectBlogCommentHandlerInfo
, wikiPageCommentHandlerInfo
, userCommentHandlerInfo
) where
......@@ -29,6 +30,9 @@ projectCommentHandlerInfo muser project_id project_handle mods =
(projectCommentRoutes project_handle)
(makeProjectCommentActionPermissionsMap muser project_handle mods)
projectBlogCommentHandlerInfo :: Maybe (Entity User) -> ProjectId -> Text -> Text -> CommentMods -> CommentHandlerInfo
projectBlogCommentHandlerInfo muser project_id project_handle _ mods = projectCommentHandlerInfo muser project_id project_handle mods
wikiPageCommentHandlerInfo :: Maybe (Entity User) -> ProjectId -> Text -> Language -> Text -> CommentMods -> CommentHandlerInfo
wikiPageCommentHandlerInfo muser project_id project_handle language target mods =
CommentHandlerInfo
......
......@@ -48,6 +48,25 @@ projectCommentRoutes project_handle = CommentRoutes
, comment_route_unwatch = UnwatchProjectCommentR project_handle
}
blogPostCommentRoutes :: Text -> Text -> CommentRoutes
blogPostCommentRoutes project_handle post_name = CommentRoutes
{ comment_route_add_tag = BlogPostCommentAddTagR project_handle post_name
, comment_route_approve = ApproveBlogPostCommentR project_handle post_name
, comment_route_claim = ClaimBlogPostCommentR project_handle post_name
, comment_route_close = CloseBlogPostCommentR project_handle post_name
, comment_route_delete = DeleteBlogPostCommentR project_handle post_name
, comment_route_edit = EditBlogPostCommentR project_handle post_name
, comment_route_flag = FlagBlogPostCommentR project_handle post_name
, comment_route_permalink = BlogPostCommentR project_handle post_name
, comment_route_reply = ReplyBlogPostCommentR project_handle post_name
, comment_route_rethread = RethreadBlogPostCommentR project_handle post_name
, comment_route_retract = RetractBlogPostCommentR project_handle post_name
, comment_route_tag = BlogPostCommentTagR project_handle post_name
, comment_route_unclaim = UnclaimBlogPostCommentR project_handle post_name
, comment_route_watch = WatchBlogPostCommentR project_handle post_name
, comment_route_unwatch = UnwatchBlogPostCommentR project_handle post_name
}
wikiPageCommentRoutes :: Text -> Language -> Text -> CommentRoutes
wikiPageCommentRoutes project_handle language target = CommentRoutes
{ comment_route_add_tag = WikiCommentAddTagR project_handle language target
......
......@@ -15,7 +15,7 @@ import Model.Comment.Sql
import Control.Monad.Trans.Maybe
import qualified Data.Map as M
-- import qualified Data.Set as S
import qualified Data.Set as S
-- | An internal sum type that contains a constructer per database table that acts
-- as a "Discussion". This way, we get a relatively type-safe way of ensuring that
......@@ -27,6 +27,7 @@ data DiscussionType
= DiscussionTypeProject
| DiscussionTypeWikiPage
| DiscussionTypeUser
| DiscussionTypeBlogPost
deriving (Bounded, Enum)
-- | Similar to DiscussionType, but exported, and actually contains the data.
......@@ -34,6 +35,7 @@ data DiscussionOn
= DiscussionOnProject (Entity Project)
| DiscussionOnWikiPage (Entity WikiTarget)
| DiscussionOnUser (Entity User)
| DiscussionOnBlogPost (Entity BlogPost)
-- | Given a 'requested' DiscussionType, attempt to fetch the Discussion from that
-- table. If, say, the requested DiscussionType is DiscussionTypeProject, but the
......@@ -43,6 +45,7 @@ data DiscussionOn
-- TODO(mitchell): Make this function more type safe.
fetchDiscussionInternal :: [Language] -> DiscussionId -> DiscussionType -> DB (Maybe DiscussionOn)
fetchDiscussionInternal _ discussion_id DiscussionTypeProject = fmap (fmap DiscussionOnProject) $ getBy $ UniqueProjectDiscussion discussion_id
fetchDiscussionInternal _ discussion_id DiscussionTypeBlogPost = fmap (fmap DiscussionOnBlogPost) $ getBy $ UniqueBlogPostDiscussion discussion_id
fetchDiscussionInternal langs discussion_id DiscussionTypeWikiPage = do
maybe_wiki_page <- getBy $ UniqueWikiPageDiscussion discussion_id
case maybe_wiki_page of
......@@ -68,6 +71,14 @@ fetchDiscussionsInternal _ discussion_ids DiscussionTypeProject =
go :: Entity Project -> Map DiscussionId DiscussionOn -> Map DiscussionId DiscussionOn
go p@(Entity _ Project{..}) = M.insert projectDiscussion (DiscussionOnProject p)
fetchDiscussionsInternal _ discussion_ids DiscussionTypeBlogPost = fmap (foldr go mempty) $
select $ from $ \ bp -> do
where_ $ bp ^. BlogPostDiscussion `in_` valList discussion_ids
return bp
where
go :: Entity BlogPost -> Map DiscussionId DiscussionOn -> Map DiscussionId DiscussionOn
go p@(Entity _ BlogPost{..}) = M.insert blogPostDiscussion (DiscussionOnBlogPost p)
fetchDiscussionsInternal langs discussion_ids DiscussionTypeWikiPage = do
wiki_pages <- select $ from $ \ wp -> do
where_ $ wp ^. WikiPageDiscussion `in_` valList discussion_ids
......@@ -108,12 +119,10 @@ fetchDiscussionsDB :: [Language] -> [DiscussionId] -> DB (Map DiscussionId Discu
fetchDiscussionsDB langs discussion_ids = do
discussion_map <- mconcat <$> sequence (map (fetchDiscussionsInternal langs discussion_ids) [minBound..maxBound])
{- TODO - reintroduce check when we handle blog discussions
let missed_discussions = S.fromList discussion_ids S.\\ M.keysSet discussion_map
unless (S.null missed_discussions) $
error $ "fetchDiscussionsDB: some discussion not found: " ++ show missed_discussions
-}
return discussion_map
......
......@@ -46,9 +46,10 @@ fixLinks project' discussion_on line' = do
[ link
, "("
, let route = encodeUtf8 $ render $ case discussion_on of
DiscussionOnProject (Entity _ Project{..}) -> ProjectCommentR projectHandle comment_id
DiscussionOnWikiPage (Entity _ WikiTarget{..}) -> WikiCommentR project' wikiTargetLanguage wikiTargetTarget comment_id
DiscussionOnUser (Entity user_id _) -> UserCommentR user_id comment_id
DiscussionOnProject (Entity _ Project{..}) -> ProjectCommentR projectHandle comment_id
DiscussionOnWikiPage (Entity _ WikiTarget{..}) -> WikiCommentR project' wikiTargetLanguage wikiTargetTarget comment_id
DiscussionOnUser (Entity user_id _) -> UserCommentR user_id comment_id
DiscussionOnBlogPost (Entity _ BlogPost{..}) -> BlogPostCommentR project' blogPostHandle comment_id
in route <> path
, ")"
......@@ -156,6 +157,10 @@ fixTests = [minBound .. maxBound] >>= \case
[ ]
)]
DiscussionTypeBlogPost -> [(DiscussionOnBlogPost undefined,
[ ]
)]
testFixLinks :: Handler [(DiscussionOn, Text, Text, Text)]
testFixLinks = do
fmap (concat . concat) $ forM fixTests $ \ (discussion, examples) -> forM examples $ \ (input, output) -> do
......
......@@ -53,10 +53,12 @@ snowdriftEventToFeedEntry render project_handle user_map discussion_map _ _ url
maybe_user = M.lookup user_id user_map
username = maybe "<unknown user>" (userDisplayName . Entity user_id) maybe_user
discussion = case M.lookup (commentDiscussion comment) discussion_map of
Nothing -> "<unknown discussion>"
Just (DiscussionOnProject _) -> "project discussion"
Just (DiscussionOnWikiPage (Entity _ wiki_target)) -> "wiki discussion for \"" <> wikiTargetTarget wiki_target <> "\""
Just (DiscussionOnUser user_entity) -> "user discussion for " <> userDisplayName user_entity
Nothing -> "<unknown discussion>"
Just (DiscussionOnProject _) -> "project discussion"
Just (DiscussionOnWikiPage (Entity _ wiki_target)) -> "wiki discussion for \"" <> wikiTargetTarget wiki_target <> "\""
Just (DiscussionOnUser user_entity) -> "user discussion for " <> userDisplayName user_entity
Just (DiscussionOnBlogPost (Entity _ blog_post)) -> "discussion on blog post \"" <> blogPostTitle blog_post <> "\""
in Just $ FeedEntry
{ feedEntryLink = url
, feedEntryUpdated = maybe (commentCreatedTs comment) id $ commentApprovedTs comment
......
......@@ -82,6 +82,7 @@ library
Handler.PostLogin
Handler.Privacy
Handler.Project
Handler.ProjectBlog
Handler.RepoFeed
Handler.ResetPassword
Handler.SnowdriftEvent
......
......@@ -77,9 +77,10 @@ notificationEventHandler AppConfig{..} (ECommentPending comment_id comment) = ru
Nothing (Just comment_id) content
case discussion of
DiscussionOnProject project -> projectComment project
DiscussionOnWikiPage (Entity _ WikiTarget{..}) -> projectComment =<< Entity wikiTargetProject <$> getJust wikiTargetProject
DiscussionOnUser _ -> error ""
DiscussionOnProject project -> projectComment project
DiscussionOnWikiPage (Entity _ WikiTarget{..}) -> projectComment =<< Entity wikiTargetProject <$> getJust wikiTargetProject
DiscussionOnUser _ -> error ""
DiscussionOnBlogPost (Entity _ BlogPost{..}) -> projectComment =<< Entity blogPostProject <$> getJust blogPostProject
notificationEventHandler AppConfig{..} (ECommentApproved comment_id comment) = runSDB $ do
route_text <- lift (makeCommentRouteDB [LangEn] comment_id >>= lift . routeToText . fromJust)
......
......@@ -87,6 +87,16 @@ renderCommentPostedEvent
^{comment_widget}
|])
DiscussionOnBlogPost (Entity _ BlogPost{..}) ->
(blogPostCommentRoutes project_handle blogPostHandle, [whamlet|
<div .event>
On blog post
<a href=@{BlogPostDiscussionR project_handle blogPostHandle}>#{blogPostTitle}
:
^{comment_widget}
|])
comment_widget =
commentWidget
(Entity comment_id comment)
......@@ -273,7 +283,7 @@ renderBlogPostEvent (BlogPost {..}) = do
^{renderTime blogPostTs}
New blog post: #
$maybe Project{projectHandle = project_handle} <- maybe_project
<a href=@{ProjectBlogPostR project_handle blogPostHandle}>
<a href=@{BlogPostR project_handle blogPostHandle}>
#{blogPostTitle}
$nothing
......
......@@ -68,9 +68,6 @@
/p/#Text ProjectR GET POST
/p/#Text/applications ApplicationsR GET
/p/#Text/application/#VolunteerApplicationId ApplicationR GET
/p/#Text/blog ProjectBlogR GET
/p/#Text/blog/!new NewProjectBlogPostR GET POST
/p/#Text/blog/#Text ProjectBlogPostR GET
/p/#Text/button.png ProjectPledgeButtonR GET
/p/#Text/c/#CommentId ProjectCommentR GET
/p/#Text/c/#CommentId/claim ClaimProjectCommentR GET POST
......@@ -142,6 +139,34 @@
/p/#Text/w/#Language/#Text/c/#CommentId/watch WatchWikiCommentR GET POST
/p/#Text/w/#Language/#Text/c/#CommentId/unwatch UnwatchWikiCommentR GET POST
-- Project blog
/p/#Text/blog ProjectBlogR GET
/p/#Text/blog/!new NewBlogPostR GET POST
/p/#Text/blog/#Text BlogPostR GET
/p/#Text/blog/#Text/d BlogPostDiscussionR GET
/p/#Text/blog/#Text/d/new NewBlogPostDiscussionR GET POST
/p/#Text/blog/#Text/c/#CommentId BlogPostCommentR GET
/p/#Text/blog/#Text/c/#CommentId/claim ClaimBlogPostCommentR GET POST
/p/#Text/blog/#Text/c/#CommentId/close CloseBlogPostCommentR GET POST
/p/#Text/blog/#Text/c/#CommentId/delete DeleteBlogPostCommentR GET POST
/p/#Text/blog/#Text/c/#CommentId/edit EditBlogPostCommentR GET POST
/p/#Text/blog/#Text/c/#CommentId/flag FlagBlogPostCommentR GET POST
/p/#Text/blog/#Text/c/#CommentId/approve ApproveBlogPostCommentR GET POST
/p/#Text/blog/#Text/c/#CommentId/reply ReplyBlogPostCommentR GET POST
/p/#Text/blog/#Text/c/#CommentId/rethread RethreadBlogPostCommentR GET POST
/p/#Text/blog/#Text/c/#CommentId/retract RetractBlogPostCommentR GET POST
/p/#Text/blog/#Text/c/#CommentId/tag/!new BlogPostCommentAddTagR GET
/p/#Text/blog/#Text/c/#CommentId/tags BlogPostCommentTagsR GET
/p/#Text/blog/#Text/c/#CommentId/tag/#TagId BlogPostCommentTagR GET POST
/p/#Text/blog/#Text/c/#CommentId/tag/!apply BlogPostCommentApplyTagR POST
/p/#Text/blog/#Text/c/#CommentId/tag/!create BlogPostCommentCreateTagR POST
/p/#Text/blog/#Text/c/#CommentId/unclaim UnclaimBlogPostCommentR GET POST
/p/#Text/blog/#Text/c/#CommentId/watch WatchBlogPostCommentR GET POST
/p/#Text/blog/#Text/c/#CommentId/unwatch UnwatchBlogPostCommentR GET POST
/c/#CommentId CommentDirectLinkR GET DELETE
/c/#CommentId/tag/#TagId CommentTagR GET POST
......
Default: &defaults
host: "127.0.0.1"
port: 3000
approot: "http://localhost:3000"
approot: "http://niceness:3000"
copyright: "2012-2014 Snowdrift.coop"
source: "https://gitorious.org/snowdrift/snowdrift"
githubrepo: "dlthomas/snowdrift"
......@@ -13,6 +13,7 @@ Development:
<<: *defaults
Testing:
approot: "http://localhost:3000"
<<: *defaults
Staging:
......
......@@ -9,3 +9,7 @@
^{content}
<div .text-center>
<a href=@{BlogPostDiscussionR project_handle (blogPostHandle blog_post)}>
discuss this post
......@@ -5,7 +5,7 @@ $if null posts
$forall Entity _ post <- posts
<h2>
<a href=@{ProjectBlogPostR project_handle (blogPostHandle post)}>
<a href=@{BlogPostR project_handle (blogPostHandle post)}>
#{blogPostTitle post}
<small>
......@@ -16,7 +16,7 @@ $forall Entity _ post <- posts
$maybe _ <- blogPostBottomContent post
<div .text-center>
<a href=@{ProjectBlogPostR project_handle (blogPostHandle post)}#fold>
<a href=@{BlogPostR project_handle (blogPostHandle post)}#fold>
Continued, read more&hellip;
<hr>
......
<div .page-toolbox>
<div .page-tool>
<a href="@{BlogPostR project_handle post_name}"> back to blog post
<div .page-tool>
<a href="@{ProjectR project_handle}"> back to main project page
$if has_comments
<div .page-tool>
<a href="@{NewBlogPostDiscussionR project_handle post_name}"> new topic
<div .page-tool>
<a href="@{BlogPostDiscussionR project_handle post_name}?state=closed">
closed threads
^{comment_forest}
$if not has_comments
$if isJust muser
<form action="@{NewBlogPostDiscussionR project_handle post_name}" method="POST">
^{comment_form}
<input type="submit" name="mode" value="preview">
$else
<p>
There is no discussion here yet.
<a href=@{AuthR LoginR}>Sign in
to start a new topic.
<div .page-toolbox>
<div .page-tool>
<a href="@{BlogPostDiscussionR project_handle post_name}"> back to full discussion
^{widget}
......@@ -75,7 +75,7 @@ blogSpecs = do
yit "previews blog post" $ [marked|
loginAs AdminUser
previewBlog (NewProjectBlogPostR "snowdrift") $ do
previewBlog (NewBlogPostR "snowdrift") $ do
byLabel "Title for this blog post" "Test"
byLabel "Handle for the URL" "test"
byLabel "Content" "Above fold.\n***\nBelow fold."
......@@ -88,7 +88,7 @@ blogSpecs = do
yit "posts blog post" $ [marked|
loginAs AdminUser
postBlog (NewProjectBlogPostR "snowdrift") $ do
postBlog (NewBlogPostR "snowdrift") $ do
byLabel "Title for this blog post" "Test"
byLabel "Handle for the URL" "test"
byLabel "Content" "Above fold.\n***\nBelow fold."
......@@ -100,7 +100,7 @@ blogSpecs = do
htmlAnyContain ".blog-post-top" "Above fold."
htmlNoneContain ".blog-post-top" "Below fold."
get $ ProjectBlogPostR "snowdrift" "test"
get $ BlogPostR "snowdrift" "test"
htmlAnyContain ".blog-post" "Above fold."
htmlAnyContain ".blog-post" "Below fold."
......@@ -115,7 +115,7 @@ blogSpecs = do
htmlNoneContain ".blog-post-top" "Below fold."
|]
{-
{- TODO - enable if/when we include most recent blog post on project page (SD-284)
yit "loads the project page - with blog post" $ [marked|
loginAs TestUser
......
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
module DiscussionTest
( discussionSpecs
) where
import TestImport
import qualified Data.Map as M
import Network.Wai.Test (SResponse (..))
import Data.Text as T
import qualified Data.Text as T
import qualified Data.ByteString.Char8 as BSC
import Model.Language
import Model.Discussion
import Control.Monad
import Yesod (Yesod, RedirectUrl)
discussionSpecs :: Spec
discussionSpecs = do
ydescribe "discussion" $ do
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 ->
let user_id = Key $ PersistInt64 1
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
yit "loads the discussion page" $ [marked|
loginAs TestUser
get200 $ WikiDiscussionR "snowdrift" LangEn "about"
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)
|]
yit "posts and moves some comments" $ [marked|
......@@ -29,55 +81,49 @@ discussionSpecs = do
liftIO $ putStrLn "posting root comment"
postComment (NewWikiDiscussionR "snowdrift" LangEn "about") $ byLabel "New Topic" "Thread 1 - root message"
postComment new_thread_url $ byLabel "New Topic" "Thread 1 - root message"
liftIO $ putStrLn "posting reply comments"
comment_map <- fmap M.fromList $ forM [1..10] $ \ i -> do
comment_id <- getLatestCommentId
postComment (ReplyWikiCommentR "snowdrift" LangEn "about" comment_id) $ byLabel "Reply" $ T.pack $ "Thread 1 - reply " ++ show (i :: Integer)
comment_map <- fmap M.fromList $ forM [1..10] postReply
return (i, comment_id)
let rethread_url = RethreadWikiCommentR "snowdrift" LangEn "about" $ comment_map M.! 4
let reply_comment = comment_map M.! 4
get200 rethread_url
get200 $ comment_rethread_url reply_comment
withStatus 302 True $ request $ do
addNonce
setMethod "POST"
setUrl rethread_url
setUrl $ comment_rethread_url reply_comment
byLabel "New Parent Url" "/p/snowdrift/w/en/about/d"
byLabel "Reason" "testing"
addPostParam "mode" "post"
|]
ydescribe "discussion - rethreading" $ do
ydescribe (unwords ["discussion on", label, "- rethreading"]) $ do
let createComments = [marked|
postComment (NewWikiDiscussionR "snowdrift" LangEn "about") $ byLabel "New Topic" "First message"
first <- getLatestCommentId
postComment (NewWikiDiscussionR "snowdrift" LangEn "about") $ byLabel "New Topic" "Second message"
second <- getLatestCommentId
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
return (first, second)
return (first_message, second_message)
|]
testRethread first second = [marked|
let rethread_url c = RethreadWikiCommentR "snowdrift" LangEn "about" c
testRethread first_message second_message = [marked|
get200 $ rethread_url first
get200 $ comment_rethread_url first_message
withStatus 302 True $ request $ do
addNonce
setMethod "POST"
setUrl $ rethread_url first
byLabel "New Parent Url" $ T.pack $ "/p/snowdrift/w/en/about/c/" ++ (\ (PersistInt64 i) -> show i) (unKey second)
setUrl $ comment_rethread_url first_message
byLabel "New Parent Url" $ T.pack $ "/p/snowdrift/w/en/about/c/" ++ (\ (PersistInt64 i) -> show i) (unKey second_message)
byLabel "Reason" "testing"
addPostParam "mode" "post"
get200 $ WikiCommentR "snowdrift" LangEn "about" second
get200 $ comment_url second_message
printBody
......@@ -89,41 +135,41 @@ discussionSpecs = do
yit "can move newer comments under older" $ [marked|
loginAs TestUser
get200 $ NewWikiDiscussionR "snowdrift" LangEn "about"
get200 new_thread_url
(first, second) <- createComments
(first_message, second_message) <- createComments
testRethread first second
testRethread first_message second_message
|]
yit "can move older comments under newer" $ [marked|
loginAs TestUser
get200 $ NewWikiDiscussionR "snowdrift" LangEn "about"
get200 new_thread_url
(first, second) <- createComments
(first_message, second_message) <- createComments
testRethread second first
testRethread second_message first_message
|]
yit "can rethread across pages and the redirect still works" $ [marked|
loginAs TestUser
postComment (NewWikiDiscussionR "snowdrift" LangEn "about") $ byLabel "New Topic" "posting on about page"
originalId <- getLatestCommentId
postComment new_thread_url $ byLabel "New Topic" "posting on about page"
(originalId, True) <- getLatestCommentId
get200 $ RethreadWikiCommentR "snowdrift" LangEn "about" originalId
get200 $ comment_rethread_url originalId
withStatus 302 True $ request $ do
addNonce
setMethod "POST"
setUrl $ RethreadWikiCommentR "snowdrift" LangEn "about" originalId
setUrl $ comment_rethread_url originalId
byLabel "New Parent Url" "/p/snowdrift/w/en/intro/d"
byLabel "Reason" "testing cross-page rethreading"
addPostParam "mode" "post"
withStatus 301 True $ get $ WikiCommentR "snowdrift" LangEn "about" originalId
withStatus 301 True $ get $ comment_url originalId
Just location <- do
statusIsResp 301
......@@ -131,7 +177,7 @@ discussionSpecs = do
return $ lookup "Location" h
)
newId <- getLatestCommentId
(newId, True) <- getLatestCommentId
let new_url = BSC.unpack location
-- desired_url = "http://localhost:3000/p/snowdrift/w/intro/c/" ++ (\ (PersistInt64 i) -> show i) (unKey newId)
desired_url = "http://localhost:3000/c/" ++ (\ (PersistInt64 i) -> show i) (unKey newId)
......@@ -139,4 +185,3 @@ discussionSpecs = do
assertEqual ("Redirect not matching! (" ++ show new_url ++ " /= " ++ show desired_url ++ ")") new_url desired_url
|]
......@@ -5,7 +5,7 @@
module NotifyTest (notifySpecs) where
import TestImport hiding ((==.), (=.), update, notificationContent)
import TestImport hiding ((=.), update, notificationContent)
import Model.Language
import Model.Notification
......@@ -163,12 +163,12 @@ notifySpecs AppConfig {..} = do
testDB $ updateNotifPref mary_id NotifReply NotifDeliverWebsite
loginAs Bob
comment_id <- getLatestCommentId
(comment_id, True) <- getLatestCommentId
postComment
(snowdrift ReplyWikiCommentR comment_id) $
byLabel "Reply" "reply to the root comment"
reply_id <- getLatestCommentId
(reply_id, True) <- getLatestCommentId
hasNotif mary_id NotifReply (render $ CommentDirectLinkR reply_id)
"reply notification not found" True
|]
......@@ -190,7 +190,7 @@ notifySpecs AppConfig {..} = do
loginAs unestablished_user
postComment (snowdrift NewWikiDiscussionR) $
byLabel "New Topic" "unapproved comment"
comment_id <- getLatestCommentId
(comment_id, False) <- getLatestCommentId
user_id <- userId unestablished_user
hasNotif user_id NotifUnapprovedComment
(render $ snowdrift WikiCommentR comment_id)
......@@ -205,7 +205,7 @@ notifySpecs AppConfig {..} = do
loginAs Mary
postComment (snowdrift NewWikiDiscussionR) $
byLabel "New Topic" "parent comment"
parent_id <- getLatestCommentId
(parent_id, True) <- getLatestCommentId
loginAs Bob
bob_id <- userId Bob
......@@ -213,7 +213,7 @@ notifySpecs AppConfig {..} = do
NotifRethreadedComment NotifDeliverWebsite
postComment (snowdrift NewWikiDiscussionR) $
byLabel "New Topic" "rethreaded comment"
comment_id <- getLatestCommentId
(comment_id, True) <- getLatestCommentId
loginAs AdminUser
rethreadComment
......@@ -233,7 +233,7 @@ notifySpecs AppConfig {..} = do
loginAs Mary
postComment (snowdrift NewWikiDiscussionR) $
byLabel "New Topic" "flagged comment"
comment_id <- getLatestCommentId
(comment_id, True) <- getLatestCommentId
mary_id <- userId Mary
testDB $ updateNotifPref mary_id NotifFlag NotifDeliverWebsite
......@@ -251,7 +251,7 @@ notifySpecs AppConfig {..} = do
testDB $ updateNotifPref bob_id NotifFlagRepost NotifDeliverWebsite
loginAs Mary
comment_id <- getLatestCommentId
(comment_id, True) <- getLatestCommentId
editComment $ render $ snowdrift EditWikiCommentR comment_id
hasNotif bob_id NotifFlagRepost
......
......@@ -7,10 +7,13 @@ import TestImport.Internal
import Prelude hiding (exp)
import Control.Monad.Logger as TestImport
import Control.Arrow as TestImport
import Yesod (Yesod, RedirectUrl)
import Yesod.Test as TestImport
import Database.Esqueleto hiding (get)