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

Commit 3a5f795b authored by Mitchell Rosen's avatar Mitchell Rosen

begun work on ticket claiming

parent e9fdcb27
......@@ -15,6 +15,7 @@ module Handler.Comment
, getMaxDepthNoLimit
, getProjectCommentAddTag
, makeApproveCommentWidget
, makeClaimCommentWidget
, makeCloseCommentWidget
, makeCommentForestWidget
, makeCommentTreeWidget
......@@ -28,6 +29,7 @@ module Handler.Comment
, postCommentApplyTag
, postCommentCreateTag
, postApproveComment
, postClaimComment
, postCloseComment
, postDeleteComment
, postEditComment
......@@ -197,6 +199,7 @@ makeCommentActionWidget
form_widget
makeApproveCommentWidget :: MakeCommentActionWidget
makeClaimCommentWidget :: MakeCommentActionWidget
makeCloseCommentWidget :: MakeCommentActionWidget
makeEditCommentWidget :: MakeCommentActionWidget
makeFlagCommentWidget :: MakeCommentActionWidget
......@@ -206,6 +209,7 @@ makeRethreadCommentWidget :: MakeCommentActionWidget
makeRetractCommentWidget :: MakeCommentActionWidget
makeApproveCommentWidget = makeCommentActionWidget can_approve approveCommentFormWidget
makeClaimCommentWidget = makeCommentActionWidget can_claim (claimCommentFormWidget Nothing)
makeCloseCommentWidget = makeCommentActionWidget can_close (closeCommentFormWidget Nothing)
makeFlagCommentWidget = makeCommentActionWidget can_flag (flagCommentFormWidget Nothing Nothing)
makeDeleteCommentWidget = makeCommentActionWidget can_delete deleteCommentFormWidget
......@@ -254,6 +258,30 @@ postApproveComment user_id comment_id comment = do
runSDB (approveCommentDB user_id comment_id comment)
alertSuccess "comment approved"
postClaimComment :: Entity User -> CommentId -> Comment -> CommentHandlerInfo -> Handler (Maybe (Widget, Widget))
postClaimComment user@(Entity user_id _) comment_id comment comment_handler_info = do
((result, _), _) <- runFormPost (claimCommentForm Nothing)
case result of
FormSuccess mnote -> do
lookupPostMode >>= \case
Just PostMode -> do
runDB (userClaimCommentDB user_id comment_id mnote)
return Nothing
_ -> do
(form, _) <- generateFormPost (claimCommentForm (Just mnote))
(comment_widget, _) <-
makeCommentActionWidget
can_claim
mempty
(Entity comment_id comment)
user
comment_handler_info
def -- TODO(mitchell): adjust for new claim
(getMaxDepthDefault 0)
True
return (Just (comment_widget, form))
_ -> error "Error when submitting form."
postCloseComment, postRetractComment :: Entity User -> CommentId -> Comment -> CommentHandlerInfo -> Handler (Maybe (Widget, Widget))
postCloseComment = postClosureComment closeCommentForm newClosedCommentClosure can_close
postRetractComment = postClosureComment retractCommentForm newRetractedCommentClosure can_retract
......@@ -623,7 +651,7 @@ deleteCommentDirectLinkR comment_id = do
unless ok (permissionDenied "You don't have permission to delete that comment.")
--------------------------------------------------------------------------------
-- /c/
-- /c/#CommentId
getCommentTagR :: CommentId -> TagId -> Handler Html
getCommentTagR comment_id tag_id = do
......@@ -637,4 +665,3 @@ getCommentTagR comment_id tag_id = do
renderTag (AnnotatedTag tag _ _ user_votes) = do
let tag_name = tagName $ entityVal tag
defaultLayout $(widgetFile "tag")
......@@ -464,6 +464,36 @@ postApproveProjectCommentR project_handle comment_id = do
postApproveComment user_id comment_id comment
redirect (ProjectCommentR project_handle comment_id)
--------------------------------------------------------------------------------
-- /c/#CommentId/claim
getClaimProjectCommentR :: Text -> CommentId -> Handler Html
getClaimProjectCommentR project_handle comment_id = do
(widget, _) <-
makeProjectCommentActionWidget
makeClaimCommentWidget
project_handle
comment_id
def
getMaxDepth
defaultLayout $ do
$(widgetFile "project_discussion_wrapper")
-- toWidget $(cassiusFile "templates/comment.cassius") -- TODO(mitchell): need this?
postClaimProjectCommentR :: Text -> CommentId -> Handler Html
postClaimProjectCommentR project_handle comment_id = do
(user, (Entity project_id _), comment) <- checkCommentRequireAuth project_handle comment_id
checkProjectCommentActionPermission can_claim user project_handle (Entity comment_id comment)
postClaimComment
user
comment_id
comment
(projectCommentHandlerInfo (Just user) project_id project_handle)
>>= \case
Nothing -> redirect (ProjectCommentR project_handle comment_id)
Just (widget, form) -> defaultLayout $ previewWidget form "claim" ($(widgetFile "project_discussion_wrapper"))
--------------------------------------------------------------------------------
-- /c/#CommentId/close
......@@ -683,6 +713,12 @@ getProjectCommentAddTagR project_handle comment_id = do
checkProjectCommentActionPermission can_add_tag user project_handle (Entity comment_id comment)
getProjectCommentAddTag comment_id project_id user_id
getUnclaimProjectCommentR :: Text -> CommentId -> Handler Html
getUnclaimProjectCommentR = undefined
postUnclaimProjectCommentR :: Text -> CommentId -> Handler Html
postUnclaimProjectCommentR = undefined
--------------------------------------------------------------------------------
-- /contact
......
......@@ -148,6 +148,37 @@ getWikiCommentR project_handle target comment_id = do
$(widgetFile "wiki_discussion_wrapper")
toWidget $(cassiusFile "templates/comment.cassius")
--------------------------------------------------------------------------------
-- /claim
getClaimWikiCommentR :: Text -> Text -> CommentId -> Handler Html
getClaimWikiCommentR project_handle target comment_id = do
(widget, _) <-
makeWikiPageCommentActionWidget
makeClaimCommentWidget
project_handle
target
comment_id
def
getMaxDepth
defaultLayout $ do
$(widgetFile "wiki_discussion_wrapper")
toWidget $(cassiusFile "templates/comment.cassius")
postClaimWikiCommentR :: Text -> Text -> CommentId -> Handler Html
postClaimWikiCommentR project_handle target comment_id = do
(user, (Entity project_id _), _, comment) <- checkCommentPageRequireAuth project_handle target comment_id
checkProjectCommentActionPermission can_claim user project_handle (Entity comment_id comment)
postClaimComment
user
comment_id
comment
(wikiPageCommentHandlerInfo (Just user) project_id project_handle target)
>>= \case
Nothing -> redirect (WikiCommentR project_handle target comment_id)
Just (widget, form) -> defaultLayout $ previewWidget form "claim" ($(widgetFile "wiki_discussion_wrapper"))
--------------------------------------------------------------------------------
-- /close
......@@ -413,6 +444,12 @@ getWikiCommentAddTagR project_handle target comment_id = do
checkProjectCommentActionPermission can_add_tag user project_handle (Entity comment_id comment)
getProjectCommentAddTag comment_id project_id user_id
getUnclaimWikiCommentR :: Text -> Text -> CommentId -> Handler Html
getUnclaimWikiCommentR = undefined
postUnclaimWikiCommentR :: Text -> Text -> CommentId -> Handler Html
postUnclaimWikiCommentR = undefined
--------------------------------------------------------------------------------
-- DEPRECATED
......
......@@ -45,6 +45,7 @@ module Model.Comment
, fetchCommentsInDB
, fetchCommentsWithChildrenInDB
, filterCommentsDB
, makeClaimedTicketMapDB
, makeClosureMapDB
, makeCommentRouteDB
, makeFlagMapDB
......@@ -581,6 +582,13 @@ makeTicketMapDB comment_ids = fmap (M.fromList . map ((ticketComment . entityVal
where_ (t ^. TicketComment `in_` valList comment_ids)
return t
makeClaimedTicketMapDB :: [CommentId] -> DB (Map CommentId (Entity TicketClaiming))
makeClaimedTicketMapDB comment_ids = fmap (M.fromList . map (\(Value x, y) -> (x, y))) $
select $
from $ \tc -> do
where_ (tc ^. TicketClaimingTicket `in_` valList comment_ids)
return (tc ^. TicketClaimingTicket, tc)
-- | Given a collection of CommentId, make a FlagMap. Comments that are not flagged
-- will simply not be in the map.
makeFlagMapDB :: (IsList c, CommentId ~ Item c) => c -> DB FlagMap
......
......@@ -19,6 +19,7 @@ type ActionPermissionsMap = Map CommentId CommentActionPermissions
data CommentActionPermissions = CommentActionPermissions
{ can_add_tag :: Bool
, can_approve :: Bool
, can_claim :: Bool
, can_close :: Bool
, can_delete :: Bool
, can_edit :: Bool
......@@ -27,10 +28,12 @@ data CommentActionPermissions = CommentActionPermissions
, can_reply :: Bool
, can_rethread :: Bool
, can_retract :: Bool
, can_unclaim :: Bool
}
emptyCommentActionPermissions :: CommentActionPermissions
emptyCommentActionPermissions = CommentActionPermissions False False False False False False False False False False
emptyCommentActionPermissions =
CommentActionPermissions False False False False False False False False False False False False
-- | Comment action permissions for a logged out user.
loggedOutCommentActionPermissions :: CommentActionPermissions
......@@ -49,14 +52,16 @@ makeProjectCommentActionPermissionsMap (Just (Entity viewer_id viewer)) project_
(comment_ids, user_ids) = map2 entityKey (commentUser . entityVal) comments
(viewer_is_mod, user_map, closure_map, flag_map, comments_with_children) <- runYDB $ do
(viewer_is_mod, user_map, claimed_map, closure_map, flag_map, ticket_map, comments_with_children) <- runYDB $ do
Entity project_id _ <- getBy404 (UniqueProjectHandle project_handle)
(,,,,) <$> userIsProjectModeratorDB viewer_id project_id
<*> (entitiesMap <$> fetchUsersInDB user_ids)
<*> makeClosureMapDB comment_ids
<*> makeFlagMapDB comment_ids
<*> (S.fromList <$> fetchCommentsWithChildrenInDB comment_ids)
(,,,,,,) <$> userIsProjectModeratorDB viewer_id project_id
<*> (entitiesMap <$> fetchUsersInDB user_ids)
<*> makeClaimedTicketMapDB comment_ids
<*> makeClosureMapDB comment_ids
<*> makeFlagMapDB comment_ids
<*> makeTicketMapDB comment_ids
<*> (S.fromList <$> fetchCommentsWithChildrenInDB comment_ids)
let viewer_is_established = userIsEstablished viewer
viewer_can_close = userCanCloseComment viewer
......@@ -70,6 +75,7 @@ makeProjectCommentActionPermissionsMap (Just (Entity viewer_id viewer)) project_
in M.insert comment_id (CommentActionPermissions
{ can_add_tag = viewer_is_established
, can_approve = viewer_is_mod && not (commentIsApproved comment)
, can_claim = M.member comment_id ticket_map && M.notMember comment_id claimed_map
, can_close = viewer_can_close && M.notMember comment_id closure_map
, can_delete = viewer_id == user_id && S.notMember comment_id comments_with_children
, can_edit = userCanEditComment viewer_id comment
......@@ -78,6 +84,9 @@ makeProjectCommentActionPermissionsMap (Just (Entity viewer_id viewer)) project_
, can_reply = True
, can_rethread = viewer_is_mod || viewer_id == user_id
, can_retract = viewer_id == user_id
, can_unclaim = maybe False
(\(Entity _ t) -> ticketClaimingUser t == viewer_id)
(M.lookup comment_id claimed_map)
})
return (foldr step mempty comments)
......@@ -9,6 +9,7 @@ data CommentRoutes = CommentRoutes
{ comment_route_add_tag :: CommentId -> Route App
, comment_route_approve :: CommentId -> Route App
, comment_route_close :: CommentId -> Route App
, comment_route_claim :: CommentId -> Route App
, comment_route_delete :: CommentId -> Route App
, comment_route_edit :: CommentId -> Route App
, comment_route_flag :: CommentId -> Route App
......@@ -17,26 +18,20 @@ data CommentRoutes = CommentRoutes
, comment_route_rethread :: CommentId -> Route App
, comment_route_retract :: CommentId -> Route App
, comment_route_tag :: CommentId -> TagId -> Route App
, comment_route_unclaim :: CommentId -> Route App
}
dummyCommentRoutes :: CommentRoutes
dummyCommentRoutes = CommentRoutes
(const HomeR)
(const HomeR)
(const HomeR)
(const HomeR)
(const HomeR)
(const HomeR)
(const HomeR)
(const HomeR)
(const HomeR)
(const HomeR)
(\_ _ -> HomeR)
dummyCommentRoutes =
CommentRoutes (const HomeR) (const HomeR) (const HomeR) (const HomeR) (const HomeR) (const HomeR)
(const HomeR) (const HomeR) (const HomeR) (const HomeR) (const HomeR) (\_ _ -> HomeR)
(const HomeR)
projectCommentRoutes :: Text -> CommentRoutes
projectCommentRoutes project_handle = CommentRoutes
{ comment_route_add_tag = ProjectCommentAddTagR project_handle
, comment_route_approve = ApproveProjectCommentR project_handle
, comment_route_claim = ClaimProjectCommentR project_handle
, comment_route_close = CloseProjectCommentR project_handle
, comment_route_delete = DeleteProjectCommentR project_handle
, comment_route_edit = EditProjectCommentR project_handle
......@@ -46,12 +41,14 @@ projectCommentRoutes project_handle = CommentRoutes
, comment_route_rethread = RethreadProjectCommentR project_handle
, comment_route_retract = RetractProjectCommentR project_handle
, comment_route_tag = ProjectCommentTagR project_handle
, comment_route_unclaim = UnclaimProjectCommentR project_handle
}
wikiPageCommentRoutes :: Text -> Text -> CommentRoutes
wikiPageCommentRoutes project_handle target = CommentRoutes
{ comment_route_add_tag = WikiCommentAddTagR project_handle target
, comment_route_approve = ApproveWikiCommentR project_handle target
, comment_route_claim = ClaimWikiCommentR project_handle target
, comment_route_close = CloseWikiCommentR project_handle target
, comment_route_delete = DeleteWikiCommentR project_handle target
, comment_route_edit = EditWikiCommentR project_handle target
......@@ -61,4 +58,5 @@ wikiPageCommentRoutes project_handle target = CommentRoutes
, comment_route_rethread = RethreadWikiCommentR project_handle target
, comment_route_retract = RetractWikiCommentR project_handle target
, comment_route_tag = WikiCommentTagR project_handle target
, comment_route_unclaim = UnclaimWikiCommentR project_handle target
}
......@@ -28,6 +28,7 @@ module Model.User
, fetchUsersInDB
, updateUserDB
, userCanDeleteCommentDB
, userClaimCommentDB
, userHasRoleDB
, userHasRolesAnyDB
, userIsAffiliatedWithProjectDB
......@@ -388,6 +389,10 @@ userCanDeleteCommentDB user_id (Entity comment_id comment) =
then return True
else return False
userClaimCommentDB :: UserId -> CommentId -> Maybe Text -> DB ()
userClaimCommentDB user_id comment_id mnote = liftIO getCurrentTime >>= \now ->
insert_ (TicketClaiming now user_id comment_id mnote)
-- | Fetch a User's number of unviewed comments on each WikiPage of a Project.
fetchNumUnviewedCommentsOnProjectWikiPagesDB :: UserId -> ProjectId -> DB (Map WikiPageId Int)
fetchNumUnviewedCommentsOnProjectWikiPagesDB user_id project_id = fmap (M.fromList . map unwrapValues) $
......
module View.Comment
( approveCommentFormWidget
, closeCommentForm
, closeCommentFormWidget
, commentForestWidget
, commentForm
( commentForm
, commentFormWidget
, commentNewTopicForm
, commentNewTopicFormWidget
, commentReplyForm
, commentReplyFormWidget
, commentForestWidget
, commentTreeWidget
, commentWidget
, createCommentTagForm
, deleteCommentFormWidget
, disabledCommentForm
-- Comment action forms
, claimCommentForm
, closeCommentForm
, commentNewTopicForm
, commentReplyForm
, createCommentTagForm
, editCommentForm
, editCommentFormWidget
, flagCommentForm
, flagCommentFormWidget
, newCommentTagForm
, orderingNewestFirst
, rethreadCommentForm
, rethreadCommentFormWidget
, retractCommentForm
-- Comment action form widgets
, approveCommentFormWidget
, claimCommentFormWidget
, closeCommentFormWidget
, commentNewTopicFormWidget
, commentReplyFormWidget
, deleteCommentFormWidget
, editCommentFormWidget
, flagCommentFormWidget
, rethreadCommentFormWidget
, retractCommentFormWidget
-- Misc
, orderingNewestFirst
) where
import Import
......@@ -76,7 +81,7 @@ closureFormWidget' form = do
<button type="submit" name="mode" value="preview">preview
|]
commentFormWidget' :: Form NewComment -> Widget
commentFormWidget' :: Form a -> Widget
commentFormWidget' form = do
(widget, enctype) <- handlerToWidget $ generateFormPost form
[whamlet|
......@@ -89,9 +94,9 @@ commentFormWidget' form = do
closeCommentForm :: Maybe Markdown -> Form NewClosure
retractCommentForm :: Maybe Markdown -> Form NewClosure
commentNewTopicForm :: Form NewComment
commentReplyForm :: Form NewComment
editCommentForm :: Markdown -> Form NewComment
commentNewTopicForm :: Form NewComment
commentReplyForm :: Form NewComment
editCommentForm :: Markdown -> Form NewComment
closeCommentForm = closureForm "Reason for closing:"
retractCommentForm = closureForm "Reason for retracting:"
......@@ -100,15 +105,17 @@ commentNewTopicForm = commentForm "New Topic" Nothing
commentReplyForm = commentForm "Reply" Nothing
editCommentForm = commentForm "Edit" . Just
closeCommentFormWidget :: Maybe Markdown -> Widget
retractCommentFormWidget :: Maybe Markdown -> Widget
commentNewTopicFormWidget :: Widget
commentReplyFormWidget :: Widget
editCommentFormWidget :: Markdown -> Widget
claimCommentFormWidget :: Maybe (Maybe Text) -> Widget
closeCommentFormWidget :: Maybe Markdown -> Widget
retractCommentFormWidget :: Maybe Markdown -> Widget
commentNewTopicFormWidget :: Widget
commentReplyFormWidget :: Widget
editCommentFormWidget :: Markdown -> Widget
closeCommentFormWidget = closureFormWidget' . closeCommentForm
retractCommentFormWidget = closureFormWidget' . retractCommentForm
claimCommentFormWidget = commentFormWidget' . claimCommentForm
commentNewTopicFormWidget = commentFormWidget' commentNewTopicForm
commentReplyFormWidget = commentFormWidget' commentReplyForm
editCommentFormWidget = commentFormWidget' . editCommentForm
......@@ -120,6 +127,9 @@ approveCommentFormWidget =
<button type="submit" name="mode" value="post">approve post
|]
claimCommentForm :: Maybe (Maybe Text) -> Form (Maybe Text)
claimCommentForm = renderBootstrap3 . aopt' textField "Note (optional)"
rethreadCommentForm :: Form (Text, Text)
rethreadCommentForm = renderBootstrap3 $ (,)
<$> areq' textField "New Parent Url" Nothing
......
......@@ -320,6 +320,14 @@ Ticket
UniqueTicket comment
TicketClaiming
ts UTCTime
user UserId
ticket CommentId
note Text Maybe
UniqueTicketClaiming ticket
Build
bootTime UTCTime
base Text
......
......@@ -43,6 +43,7 @@
/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
/p/#Text/c/#CommentId/close CloseProjectCommentR GET POST
/p/#Text/c/#CommentId/delete DeleteProjectCommentR GET POST
/p/#Text/c/#CommentId/edit EditProjectCommentR GET POST
......@@ -56,6 +57,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/c/#CommentId/unclaim UnclaimProjectCommentR GET POST
/p/#Text/contact ProjectContactR GET POST
/p/#Text/d ProjectDiscussionR GET
/p/#Text/d/new NewProjectDiscussionR GET POST
......@@ -79,6 +81,7 @@
/p/#Text/w/#Text WikiR GET POST
/p/#Text/w/#Text/c/#CommentId WikiCommentR GET
/p/#Text/w/#Text/c/#CommentId/claim ClaimWikiCommentR GET POST
/p/#Text/w/#Text/c/#CommentId/close CloseWikiCommentR GET POST
/p/#Text/w/#Text/c/#CommentId/delete DeleteWikiCommentR GET POST
/p/#Text/w/#Text/c/#CommentId/edit EditWikiCommentR GET POST
......@@ -92,6 +95,7 @@
/p/#Text/w/#Text/c/#CommentId/tag/#TagId WikiCommentTagR GET POST
/p/#Text/w/#Text/c/#CommentId/tag/!apply WikiCommentApplyTagR POST
/p/#Text/w/#Text/c/#CommentId/tag/!create WikiCommentCreateTagR POST
/p/#Text/w/#Text/c/#CommentId/unclaim UnclaimWikiCommentR GET POST
/p/#Text/w/#Text/d WikiDiscussionR GET
/p/#Text/w/#Text/d/new NewWikiDiscussionR GET POST
/p/#Text/w/#Text/diff/#WikiEditId/#WikiEditId WikiDiffR GET
......
CREATe TABLE "ticket_claiming"("id" SERIAL PRIMARY KEY UNIQUE,"ts" TIMESTAMP NOT NULL,"user" INT8 NOT NULL,"ticket" INT8 NOT NULL,"note" VARCHAR NULL);
ALTER TABLE "ticket_claiming" ADD CONSTRAINT "unique_ticket_claiming" UNIQUE("ticket");
ALTER TABLE "ticket_claiming" ADD CONSTRAINT "ticket_claiming_user_fkey" FOREIGN KEY("user") REFERENCES "user"("id");
ALTER TABLE "ticket_claiming" ADD CONSTRAINT "ticket_claiming_ticket_fkey" FOREIGN KEY("ticket") REFERENCES "comment"("id");
......@@ -109,6 +109,16 @@
<a href="@{comment_route_flag comment_id}">
flag
$if can_claim
<div .comment-action>
<a href="@{comment_route_claim comment_id}">
claim
$if can_unclaim
<div .comment-action>
<a href="@{comment_route_unclaim comment_id}">
unclaim
$if can_reply
<div .comment-action>
<a href="@{comment_route_reply comment_id}">
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment