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

Commit ab6967d3 authored by Mitchell Rosen's avatar Mitchell Rosen

Merge pull request #16 from wolftune/privacy

Privacy stuff (not full but just to enable /contact for now)
parents 19fd2f6f 428a8513
......@@ -261,7 +261,7 @@ postRetractComment = postClosureComment retractCommentForm newRetractedCommentCl
-- | Handle a POST to a /close or /retract URL.
-- Permission checking should occur *PRIOR TO* this function.
postClosureComment
:: (Maybe Markdown -> Form Markdown)
:: (Maybe Markdown -> Form NewClosure)
-> (UserId -> Markdown -> CommentId -> Handler CommentClosure)
-> (CommentActionPermissions -> Bool)
-> Entity User
......@@ -279,7 +279,7 @@ postClosureComment
comment_handler_info = do
((result, _), _) <- runFormPost (make_closure_form Nothing)
case result of
FormSuccess reason -> do
FormSuccess (NewClosure reason) -> do
new_comment_closure <- make_new_comment_closure user_id reason comment_id
lookupPostMode >>= \case
Just PostMode -> do
......@@ -320,7 +320,7 @@ postEditComment :: Entity User -> Entity Comment -> CommentHandlerInfo -> Handle
postEditComment user comment@(Entity comment_id _) comment_handler_info = do
((result, _), _) <- runFormPost (editCommentForm "")
case result of
FormSuccess new_text -> lookupPostMode >>= \case
FormSuccess (NewComment new_text _) -> lookupPostMode >>= \case
Just PostMode -> do
runSYDB (editCommentDB comment_id new_text)
alertSuccess "posted new edit"
......@@ -418,15 +418,15 @@ postNewComment mparent_id (Entity user_id user) discussion_id make_permissions_m
-- actually the same form with different titles.
((result, _), _) <- runFormPost commentReplyForm
case result of
FormSuccess contents -> lookupPostMode >>= \case
FormSuccess (NewComment contents visibility) -> lookupPostMode >>= \case
Just PostMode -> do
if userIsEstablished user
then do
comment_id <- runSDB (postApprovedCommentDB user_id mparent_id discussion_id contents)
comment_id <- runSDB (postApprovedCommentDB user_id mparent_id discussion_id contents visibility)
alertSuccess "comment posted"
return (Left comment_id)
else do
comment_id <- runSDB (postUnapprovedCommentDB user_id mparent_id discussion_id contents)
comment_id <- runSDB (postUnapprovedCommentDB user_id mparent_id discussion_id contents visibility)
alertSuccess "comment submitted for moderation"
return (Left comment_id)
_ -> do
......@@ -440,7 +440,7 @@ postNewComment mparent_id (Entity user_id user) discussion_id make_permissions_m
else (Nothing, Nothing)
comment = Entity
(Key $ PersistInt64 0)
(Comment now approved_ts approved_by discussion_id mparent_id user_id contents depth)
(Comment now approved_ts approved_by discussion_id mparent_id user_id contents depth visibility)
max_depth <- getMaxDepthDefault 0
......
......@@ -441,6 +441,28 @@ getProjectCommentR project_handle comment_id = do
defaultLayout $(widgetFile "project_discussion_wrapper")
--------------------------------------------------------------------------------
-- /c/#CommentId/approve
getApproveProjectCommentR :: Text -> CommentId -> Handler Html
getApproveProjectCommentR project_handle comment_id = do
(widget, _) <-
makeProjectCommentActionWidget
makeApproveCommentWidget
project_handle
comment_id
def
getMaxDepth
defaultLayout $(widgetFile "project_discussion_wrapper")
postApproveProjectCommentR :: Text -> CommentId -> Handler Html
postApproveProjectCommentR project_handle comment_id = do
(user@(Entity user_id _), _, comment) <- checkCommentRequireAuth project_handle comment_id
checkProjectCommentActionPermission can_approve user project_handle (Entity comment_id comment)
postApproveComment user_id comment_id comment
redirect (ProjectCommentR project_handle comment_id)
--------------------------------------------------------------------------------
-- /c/#CommentId/close
......@@ -547,28 +569,6 @@ postFlagProjectCommentR project_handle comment_id = do
Nothing -> redirect (ProjectDiscussionR project_handle)
Just widget -> defaultLayout $(widgetFile "project_discussion_wrapper")
--------------------------------------------------------------------------------
-- /moderate TODO: rename to /approve
getApproveProjectCommentR :: Text -> CommentId -> Handler Html
getApproveProjectCommentR project_handle comment_id = do
(widget, _) <-
makeProjectCommentActionWidget
makeApproveCommentWidget
project_handle
comment_id
def
getMaxDepth
defaultLayout $(widgetFile "project_discussion_wrapper")
postApproveProjectCommentR :: Text -> CommentId -> Handler Html
postApproveProjectCommentR project_handle comment_id = do
(user@(Entity user_id _), _, comment) <- checkCommentRequireAuth project_handle comment_id
checkProjectCommentActionPermission can_approve user project_handle (Entity comment_id comment)
postApproveComment user_id comment_id comment
redirect (ProjectCommentR project_handle comment_id)
--------------------------------------------------------------------------------
-- /c/#CommentId/reply
......@@ -682,6 +682,37 @@ getProjectCommentAddTagR project_handle comment_id = do
checkProjectCommentActionPermission can_add_tag user project_handle (Entity comment_id comment)
getProjectCommentAddTag comment_id project_id user_id
--------------------------------------------------------------------------------
-- /contact
-- ProjectContactR stuff posts a private new topic to project discussion
getProjectContactR :: Text -> Handler Html
getProjectContactR project_handle = do
(project_contact_form, _) <- generateFormPost projectContactForm
Entity _ project <- runYDB $ getBy404 (UniqueProjectHandle project_handle)
defaultLayout $ do
setTitle . toHtml $ "Contact " <> projectName project <> " | Snowdrift.coop"
$(widgetFile "project_contact")
postProjectContactR :: Text -> Handler Html
postProjectContactR project_handle = do
maybe_user_id <- maybeAuthId
((result, _), _) <- runFormPost projectContactForm
Entity _ project <- runYDB $ getBy404 (UniqueProjectHandle project_handle)
case result of
FormSuccess content -> do
_ <- runSDB (postApprovedCommentDB (fromMaybe anonymousUser maybe_user_id) Nothing (projectDiscussion project) content VisPrivate)
alertSuccess "Comment submitted. Thank you for your input!"
_ -> alertDanger "Error occurred when submitting form."
redirect $ ProjectContactR project_handle
--------------------------------------------------------------------------------
-- /d
......
......@@ -192,10 +192,10 @@ postUserBalanceR user_id = do
-- /#UserId/d
getUserDiscussionR :: UserId -> Handler Html
getUserDiscussionR user_id = error "TODO(mitchell)"
getUserDiscussionR _ = error "TODO(mitchell)"
postUserDiscussionR :: UserId -> Handler Html
postUserDiscussionR user_id = error "TODO(mitchell)"
postUserDiscussionR _ = error "TODO(mitchell)"
--------------------------------------------------------------------------------
-- /#UserId/edit
......
......@@ -167,7 +167,7 @@ postWikiR project_handle target = do
, "(this ticket was automatically generated)"
]
comment_id <- lift $ insert =<< makeApprovedComment user_id (wikiPageDiscussion page) Nothing comment_body 0
comment_id <- lift $ insert =<< makeApprovedComment user_id (wikiPageDiscussion page) Nothing comment_body 0 VisPublic
lift $ insert_ $ Ticket now now "edit conflict" comment_id
......
......@@ -2,7 +2,7 @@
module Model where
import Model.Comment.Internal (ClosureType, FlagReason)
import Model.Comment.Internal (ClosureType, FlagReason, Visibility)
import Model.Currency (Milray)
import Model.Established.Internal (Established(..))
import Model.Markdown.Diff (MarkdownDiff)
......
......@@ -179,8 +179,8 @@ newCommentClosure closure_type user_id reason comment_id =
(\now -> CommentClosure now user_id closure_type reason comment_id) `liftM` liftIO getCurrentTime
-- | Construct a comment, auto-approved by 'this' User (because they are established).
makeApprovedComment :: MonadIO m => UserId -> DiscussionId -> Maybe CommentId -> Markdown -> Int -> m Comment
makeApprovedComment user_id discussion_id parent_comment comment_text depth = do
makeApprovedComment :: MonadIO m => UserId -> DiscussionId -> Maybe CommentId -> Markdown -> Int -> Visibility -> m Comment
makeApprovedComment user_id discussion_id parent_comment comment_text depth visibility = do
now <- liftIO getCurrentTime
return $ Comment
now
......@@ -191,6 +191,7 @@ makeApprovedComment user_id discussion_id parent_comment comment_text depth = do
user_id
comment_text
depth
visibility
-- | Get the set of Users that have posted the given Foldable of comments.
makeCommentUsersSet :: Foldable f => f (Entity Comment) -> Set UserId
......@@ -238,8 +239,9 @@ insertApprovedCommentDB
-> UserId
-> Markdown
-> Int
-> Visibility
-> SDB CommentId
insertApprovedCommentDB created_ts discussion_id mparent_id user_id text depth =
insertApprovedCommentDB created_ts discussion_id mparent_id user_id text depth visibility =
insertCommentDB
(Just created_ts)
(Just user_id)
......@@ -250,6 +252,7 @@ insertApprovedCommentDB created_ts discussion_id mparent_id user_id text depth =
user_id
text
depth
visibility
insertUnapprovedCommentDB
:: UTCTime
......@@ -258,6 +261,7 @@ insertUnapprovedCommentDB
-> UserId
-> Markdown
-> Int
-> Visibility
-> SDB CommentId
insertUnapprovedCommentDB = insertCommentDB Nothing Nothing ECommentPending
......@@ -270,8 +274,9 @@ insertCommentDB :: Maybe UTCTime
-> UserId
-> Markdown
-> Int
-> Visibility
-> SDB CommentId
insertCommentDB mapproved_ts mapproved_by mk_event created_ts discussion_id mparent_id user_id text depth = do
insertCommentDB mapproved_ts mapproved_by mk_event created_ts discussion_id mparent_id user_id text depth visibility = do
let comment = Comment
created_ts
mapproved_ts
......@@ -281,6 +286,8 @@ insertCommentDB mapproved_ts mapproved_by mk_event created_ts discussion_id mpar
user_id
text
depth
visibility
comment_id <- lift $ insert comment
tell [mk_event comment_id comment]
return comment_id
......@@ -347,25 +354,26 @@ flagCommentDB comment_id permalink_route flagger_id reasons message = do
return True
-- | Post an new (approved) Comment.
postApprovedCommentDB :: UserId -> Maybe CommentId -> DiscussionId -> Markdown -> SDB CommentId
postApprovedCommentDB :: UserId -> Maybe CommentId -> DiscussionId -> Markdown -> Visibility -> SDB CommentId
postApprovedCommentDB = postComment insertApprovedCommentDB
postUnapprovedCommentDB :: UserId -> Maybe CommentId -> DiscussionId -> Markdown -> SDB CommentId
postUnapprovedCommentDB :: UserId -> Maybe CommentId -> DiscussionId -> Markdown -> Visibility -> SDB CommentId
postUnapprovedCommentDB = postComment insertUnapprovedCommentDB
postComment
:: (UTCTime -> DiscussionId -> Maybe CommentId -> UserId -> Markdown -> Int -> SDB CommentId)
:: (UTCTime -> DiscussionId -> Maybe CommentId -> UserId -> Markdown -> Int -> Visibility -> SDB CommentId)
-> UserId
-> Maybe CommentId
-> DiscussionId
-> Markdown
-> Visibility
-> SDB CommentId
postComment insert_comment user_id mparent_id discussion_id contents = do
postComment insert_comment user_id mparent_id discussion_id contents visibility = do
(now, depth) <- lift $ (,)
<$> liftIO getCurrentTime
<*> fetchCommentDepthFromMaybeParentIdDB mparent_id
comment_id <- insert_comment now discussion_id mparent_id user_id contents depth
comment_id <- insert_comment now discussion_id mparent_id user_id contents depth visibility
let content = T.lines (unMarkdown contents)
tickets = map T.strip $ mapMaybe (T.stripPrefix "ticket:") content
......
......@@ -36,9 +36,16 @@ makeEmptyCommentActionPermissionsMap :: MakeActionPermissionsMap
makeEmptyCommentActionPermissionsMap = return .
foldr (\(Entity comment_id _) -> M.insert comment_id emptyCommentActionPermissions) mempty
-- permissions for visitors who are not logged in
loggedOutCommentActionPermissions = emptyCommentActionPermissions { can_reply = True }
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.
makeProjectCommentActionPermissionsMap :: Maybe (Entity User) -> Text -> MakeActionPermissionsMap
makeProjectCommentActionPermissionsMap Nothing _ comments = makeEmptyCommentActionPermissionsMap comments
makeProjectCommentActionPermissionsMap Nothing _ comments = makeLoggedOutCommentActionPermissionsMap comments
makeProjectCommentActionPermissionsMap (Just (Entity viewer_id viewer)) project_handle comments = do
let map2 :: (a -> b) -> (a -> c) -> [a] -> ([b],[c])
map2 f g = foldr (\a (bs, cs) -> (f a : bs, g a : cs)) ([],[])
......
......@@ -5,12 +5,24 @@ import Prelude
import Database.Persist.TH
import Data.Text (Text)
import Yesod.Markdown (Markdown)
data ClosureType
= Retracted
| Closed
deriving (Read, Show)
derivePersistField "ClosureType"
-- VisPublic = visible to all | VisPrivate = visible to topic-poster and
-- those with provenance over the discussion (e.g. project team for project
-- discussion ) | VisInternal = visible only to those with provenance over
-- the discussion
data Visibility = VisPublic | VisPrivate | VisInternal deriving (Read, Show, Eq)
derivePersistField "Visibility"
newtype NewClosure = NewClosure Markdown
data NewComment = NewComment Markdown Visibility
data FlagReason
= FlagPersonalAttack
| FlagUnconstructiveCriticism
......
......@@ -62,19 +62,36 @@ exprCommentViewedBy user_id c = c ^. CommentId `in_`
where_ (vc ^. ViewCommentUser ==. val user_id)
return (vc ^. ViewCommentComment))
-- Is the root (earliest ancestor) of this comment posted by the given user?
exprCommentRootPostedBy :: UserId -> ExprCommentCond
exprCommentRootPostedBy user_id c = ((isNothing (c ^. CommentParent)) &&. c ^. CommentUser ==. val user_id) ||. c ^. CommentId `in_` sublist
where
sublist = subList_select $ from $ \ (comment_ancestor `InnerJoin` root) -> do
on_ $ root ^. CommentId ==. comment_ancestor ^. CommentAncestorAncestor
where_ $ isNothing (root ^. CommentParent)
&&. root ^. CommentUser ==. val user_id
return (comment_ancestor ^. CommentAncestorComment)
-- | SQL expression to filter a Comment (somewhere) on a Project based on "permissions", as follows:
-- If moderator, show all.
-- If logged in, show all approved (hiding flagged), plus own comments (unapproved + flagged).
-- If not logged in, show all approved (hiding flagged).
-- No matter what, hide rethreaded comments (they've essentially been replaced).
exprCommentProjectPermissionFilter :: Maybe UserId -> SqlExpr (Value ProjectId) -> ExprCommentCond
exprCommentProjectPermissionFilter muser_id project_id c = exprCommentNotRethreaded c &&. permissionFilter
exprCommentProjectPermissionFilter muser_id project_id c = exprCommentNotRethreaded c &&. permissionFilter &&. isVisible
where
permissionFilter :: SqlExpr (Value Bool)
permissionFilter = case muser_id of
Just user_id -> approvedAndNotFlagged ||. exprCommentPostedBy user_id c ||. exprUserIsModerator user_id project_id
Nothing -> approvedAndNotFlagged
-- isVisible when comment is public (VisPublic), or the viewer is
-- a project team member, or the viewer posted the topic initially
isVisible :: SqlExpr (Value Bool)
isVisible = seq (appendFile "testlog" $ "isVisible for " ++ show muser_id) $ case muser_id of
Just user_id -> c ^. CommentVisibility ==. val VisPublic ||. exprUserIsTeamMember user_id project_id ||. exprCommentRootPostedBy user_id c
Nothing -> c ^. CommentVisibility ==. val VisPublic
approvedAndNotFlagged :: SqlExpr (Value Bool)
approvedAndNotFlagged = exprCommentApproved c &&. not_ (exprCommentFlagged c)
......
module Model.User
( UserMap
-- Utility functions
, anonymousUser
, curUserIsEligibleEstablish
, updateUserPreview
, userCanAddTag
......@@ -65,6 +66,11 @@ import qualified Data.Set as S
import qualified Data.Text as T
import Yesod.Markdown (Markdown(..))
-- anonymousUser is a special user for items posted by visitors who are not
-- logged in, such as posting to /contact for a project
anonymousUser :: UserId
anonymousUser = Key $ PersistInt64 (-1)
type UserMap = Map UserId User
--------------------------------------------------------------------------------
......
......@@ -2,8 +2,6 @@ module Model.User.Internal where
import Prelude
import Model.Notification.Internal
import Data.Text (Text)
import Yesod.Markdown (Markdown)
......
module Model.User.Sql
( exprUserIsModerator
, exprUserIsTeamMember
, exprUserViewedComments
, exprUserViewedWikiEdits
) where
......@@ -9,6 +10,9 @@ import Import
exprUserIsModerator :: UserId -> SqlExpr (Value ProjectId) -> SqlExpr (Value Bool)
exprUserIsModerator = exprHasRole Moderator
exprUserIsTeamMember :: UserId -> SqlExpr (Value ProjectId) -> SqlExpr (Value Bool)
exprUserIsTeamMember = exprHasRole TeamMember
exprHasRole :: Role -> UserId -> SqlExpr (Value ProjectId) -> SqlExpr (Value Bool)
exprHasRole role user_id project_id =
exists $
......
......@@ -47,13 +47,36 @@ import qualified Data.Tree as Tree
disabledCommentForm :: Form Markdown
disabledCommentForm = renderBootstrap3 $ areq snowdriftMarkdownField ("Reply" { fsAttrs = [("disabled",""), ("class","form-control")] }) Nothing
commentForm :: SomeMessage App -> Maybe Markdown -> Form Markdown
commentForm label = renderBootstrap3 . areq' snowdriftMarkdownField label
closureForm :: SomeMessage App -> Maybe Markdown -> Form NewClosure
closureForm label message = renderBootstrap3 $ NewClosure <$> areq' snowdriftMarkdownField label message
commentForm :: SomeMessage App -> Maybe Markdown -> Form NewComment
commentForm label content = renderBootstrap3 $ NewComment
<$> areq' snowdriftMarkdownField label content
<*> pure VisPublic
-- TODO(aaron) turn below back on and delete the pure line above
-- to activate private commenting
-- <*> (toVisibility <$> areq' checkBoxField "Private?" Nothing)
-- where
-- toVisibility True = VisPrivate
-- toVisibility _ = VisPublic
commentFormWidget :: SomeMessage App -> Maybe Markdown -> Widget
commentFormWidget label = commentFormWidget' . commentForm label
commentFormWidget' :: Form Markdown -> Widget
-- intentional duplication of commentFormWidget' because some aspects
-- of closing and other markdown aren't identical (such as marking privacy)
closureFormWidget' :: Form NewClosure -> Widget
closureFormWidget' form = do
(widget, enctype) <- handlerToWidget $ generateFormPost form
[whamlet|
<div>
<form method="POST" enctype=#{enctype}>
^{widget}
<button type="submit" name="mode" value="preview">preview
|]
commentFormWidget' :: Form NewComment -> Widget
commentFormWidget' form = do
(widget, enctype) <- handlerToWidget $ generateFormPost form
[whamlet|
......@@ -63,29 +86,32 @@ commentFormWidget' form = do
<button type="submit" name="mode" value="preview">preview
|]
closeCommentForm :: Maybe Markdown -> Form Markdown
commentNewTopicForm :: Form Markdown
commentReplyForm :: Form Markdown
editCommentForm :: Markdown -> Form Markdown
retractCommentForm :: Maybe Markdown -> Form Markdown
closeCommentForm :: Maybe Markdown -> Form NewClosure
retractCommentForm :: Maybe Markdown -> Form NewClosure
commentNewTopicForm :: Form NewComment
commentReplyForm :: Form NewComment
editCommentForm :: Markdown -> Form NewComment
closeCommentForm = closureForm "Reason for closing:"
retractCommentForm = closureForm "Reason for retracting:"
closeCommentForm = commentForm "Reason for closing:"
commentNewTopicForm = commentForm "New Topic" Nothing
commentReplyForm = commentForm "Reply" Nothing
editCommentForm = commentForm "Edit" . Just
retractCommentForm = commentForm "Reason for retracting:"
closeCommentFormWidget :: Maybe Markdown -> Widget
retractCommentFormWidget :: Maybe Markdown -> Widget
commentNewTopicFormWidget :: Widget
commentReplyFormWidget :: Widget
editCommentFormWidget :: Markdown -> Widget
retractCommentFormWidget :: Maybe Markdown -> Widget
closeCommentFormWidget = commentFormWidget' . closeCommentForm
closeCommentFormWidget = closureFormWidget' . closeCommentForm
retractCommentFormWidget = closureFormWidget' . retractCommentForm
commentNewTopicFormWidget = commentFormWidget' commentNewTopicForm
commentReplyFormWidget = commentFormWidget' commentReplyForm
editCommentFormWidget = commentFormWidget' . editCommentForm
retractCommentFormWidget = commentFormWidget' . retractCommentForm
approveCommentFormWidget :: Widget
approveCommentFormWidget =
......@@ -331,7 +357,7 @@ commentWidget (Entity comment_id comment)
earlier_closures
user
mclosure
mticket
_ -- mticket
mflag
is_preview
inner_widget = do
......@@ -348,16 +374,18 @@ commentWidget (Entity comment_id comment)
M.lookup comment_id <$>
(fetchCommentCommentTagsDB comment_id >>= buildAnnotatedCommentTagsDB mviewer_id)
{-
let ticket_str = case mticket of
Just (Entity (Key (PersistInt64 tid)) _) -> T.pack $ show tid
_ -> "???"
-- error about ambiguity about monad type in this, needs to be adjusted to
-- fit the idea that comments aren't necessarily on wiki pages
-- prettyTicketLine line =
-- let pretty title = "<div class='ticket-title'>SD-" <> ticket_str <> ": " <> title <> "</div>"
-- in return $ maybe line pretty $ T.stripPrefix "ticket: " line
prettyTicketLine line =
let pretty title = "<div class='ticket-title'>SD-" <> ticket_str <> ": " <> title <> "</div>"
in return $ maybe line pretty $ T.stripPrefix "ticket: " line
-- commentTextTransform = prettyTicketLine
commentTextTransform = prettyTicketLine
-}
$(widgetFile "comment")
module View.Project
( editProjectForm
, projectContactForm
, inviteForm
, projectBlogForm
, projectConfirmSharesForm
......@@ -104,6 +105,9 @@ projectBlogForm defaults = renderBootstrap3 $
discussion_id (Markdown $ T.unlines top_content)
(if null bottom_content then Nothing else Just $ Markdown $ T.unlines bottom_content)
projectContactForm :: Form Markdown
projectContactForm = renderBootstrap3 $ areq' snowdriftMarkdownField "" Nothing
inviteForm :: Form (Text, Role)
inviteForm = renderBootstrap3 $ (,)
<$> areq' textField "About this invitation:" Nothing
......
......@@ -147,8 +147,8 @@ renderCommentPendingEvent comment_id comment user_map = do
|]
renderWikiPageEvent :: Text -> WikiPageId -> WikiPage -> UserMap -> Widget
renderWikiPageEvent project_handle _ wiki_page user_map = do
--
renderWikiPageEvent project_handle _ wiki_page _ = do
-- TODO(aaron)
-- The commented stuff here (and in the whamlet commented part)
-- is because there's no wikiPageUser yet and the
-- user_map is also not needed until this is active--
......
......@@ -225,6 +225,7 @@ Comment
user UserId
text Markdown
depth Int
visibility Visibility default='VisPublic'
deriving Eq Show
-- A comment has zero or more ancestors: its parent, grandparent, great
......
......@@ -56,6 +56,7 @@
/p/#Text/c/#CommentId/tag/#TagId ProjectCommentTagR GET POST
/p/#Text/c/#CommentId/tag/!apply ProjectCommentApplyTagR POST
/p/#Text/c/#CommentId/tag/!create ProjectCommentCreateTagR POST
/p/#Text/contact ProjectContactR GET POST
/p/#Text/d ProjectDiscussionR GET
/p/#Text/d/new NewProjectDiscussionR GET POST
/p/#Text/edit EditProjectR GET
......
insert into account (id, balance) values (-1, 0);
insert into discussion (id, nothing) values (-1, 0);
insert into "user" (id, ident, name, account, discussion) values (-1, 'anonymous', 'anonymous user', -1, -1);
ALTER TABLE "comment" ADD COLUMN "visibility" VARCHAR NOT NULL DEFAULT 'VisPublic';
......@@ -4,6 +4,6 @@
<br>
<br>
<form method=POST target=@{ContactR project_handle}>
^{contact_form}
<form method=POST target=@{ProjectContactR project_handle}>
^{project_contact_form}
<input type=submit value="send">
......@@ -92,7 +92,7 @@ blogSpecs = do
yit "previews blog post" $ [marked|
login
adminLogin
previewBlog (NewProjectBlogPostR "snowdrift") $ do
byLabel "Post Title" "Test"
......@@ -105,7 +105,7 @@ blogSpecs = do
yit "posts blog post" $ [marked|
login
adminLogin
postBlog (NewProjectBlogPostR "snowdrift") $ do
byLabel "Post Title" "Test"
......
......@@ -45,7 +45,7 @@ discussionSpecs = do
yit "loads the discussion page" $ [marked|
login
get $ DiscussWikiR "snowdrift" "about"
get $ WikiDiscussionR "snowdrift" "about"
statusIs 200
|]
......@@ -54,14 +54,14 @@ discussionSpecs = do
liftIO $ putStrLn "posting root comment"
postComment (NewDiscussWikiR "snowdrift" "about") $ byLabel "New Topic" "Thread 1 - root message"
postComment (NewWikiDiscussionR "snowdrift" "about") $ 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 (ReplyCommentR "snowdrift" "about" comment_id) $ byLabel "Reply" $ T.pack $ "Thread 1 - reply " ++ show (i :: Integer)
postComment (ReplyWikiCommentR "snowdrift" "about" comment_id) $ byLabel "Reply" $ T.pack $ "Thread 1 - reply " ++ show (i :: Integer)
return (i, comment_id)
......@@ -77,7 +77,7 @@ discussionSpecs = do
setUrl rethread_url
byLabel "New Parent Url" "/p/snowdrift/w/about/d"
byLabel "Reason" "testing"
addPostParam "mode" "rethread"
addPostParam "mode" "post"
statusIsResp 302
|]
......@@ -85,9 +85,9 @@ discussionSpecs = do
ydescribe "discussion - rethreading" $ do
let createComments = [marked|
postComment (NewDiscussWikiR "snowdrift" "about") $ byLabel "New Topic" "First message"
postComment (NewWikiDiscussionR "snowdrift" "about") $ byLabel "New Topic" "First message"
first <- getLatestCommentId
postComment (NewDiscussWikiR "snowdrift" "about") $ byLabel "New Topic" "Second message"
postComment (NewWikiDiscussionR "snowdrift" "about") $ byLabel "New Topic" "Second message"
second <- getLatestCommentId
return (first, second)
......@@ -105,11 +105,11 @@ discussionSpecs = do
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"
addPostParam "mode" "post"