Ticket claim and unclaim routes with access checks

config/routes

@@ -96,6 +96,8 @@
 /s/#ShrIdent/p/#PrjIdent/t/#Int/edit         TicketEditR       GET
 /s/#ShrIdent/p/#PrjIdent/t/#Int/close        TicketCloseR      POST
 /s/#ShrIdent/p/#PrjIdent/t/#Int/open         TicketOpenR       POST
+/s/#ShrIdent/p/#PrjIdent/t/#Int/claim        TicketClaimR      POST
+/s/#ShrIdent/p/#PrjIdent/t/#Int/unclaim      TicketUnclaimR    POST
 /s/#ShrIdent/p/#PrjIdent/t/#Int/d            TicketDiscussionR GET POST
 /s/#ShrIdent/p/#PrjIdent/t/#Int/d/#Int       TicketMessageR    GET POST
 /s/#ShrIdent/p/#PrjIdent/t/#Int/d/!reply     TicketTopReplyR   GET

src/Vervis/Form/Ticket.hs

@@ -57,35 +57,6 @@ newTicketAForm = NewTicket
 newTicketForm :: Form NewTicket
 newTicketForm = renderDivs newTicketAForm
 
-{-
-editTicketAForm :: Ticket -> PersonId -> AForm Handler Ticket
-editTicketAForm ticket pid = fmap fixDone $ Ticket
-    <$> pure (ticketProject ticket)
-    <*> pure (ticketNumber ticket)
-    <*> pure (ticketCreated ticket)
-    <*> pure (ticketCreator ticket)
-    <*> areq textField "Title*" (Just $ ticketTitle ticket)
-    <*> ( maybe "" unTextarea <$>
-          aopt
-            textareaField
-            "Description (Markdown)"
-            (Just $ Just $ Textarea $ ticketDesc ticket)
-        )
-    <*> pure (ticketAssignee ticket)
-    <*> areq checkBoxField "Done*" (Just $ ticketDone ticket)
-    <*> now
-    <*> pure (ticketCloser ticket)
-    <*> pure (ticketDiscuss ticket)
-    where
-    fixDone result = case (ticketDone ticket, ticketDone result) of
-        (True,  True)  -> result { ticketClosed = ticketClosed ticket }
-        (False, False) -> result { ticketClosed = ticketClosed ticket }
-        (False, True)  -> result { ticketCloser = pid }
-        (True,  False) -> result { ticketClosed = defTime
-                                 , ticketCloser = ticketCreator ticket
-                                 }
--}
-
 editTicketContentAForm :: Ticket -> AForm Handler Ticket
 editTicketContentAForm ticket = Ticket
     <$> pure (ticketProject ticket)

src/Vervis/Foundation.hs

@@ -35,6 +35,7 @@ import Text.Jasmine.Local (discardm)
 import Vervis.Import.NoFoundation hiding (last)
 import Vervis.Model.Group
 import Vervis.Model.Ident
+import Vervis.Model.Role
 import Vervis.Widget (breadcrumbsW, revisionW)
 
 -- | The foundation datatype for your application. This can be a good place to
@@ -163,6 +164,8 @@ instance Yesod App where
         (TicketEditR user _ _    , _   ) -> person user
         (TicketCloseR user _ _   , _   ) -> person user
         (TicketOpenR user _ _    , _   ) -> person user
+        (TicketClaimR s j _      , _   ) -> projOp ProjOpClaimTicket s j
+        (TicketUnclaimR s j _    , _   ) -> projOp ProjOpUnclaimTicket s j
         (TicketDiscussionR _ _ _ , True) -> personAny
         (TicketMessageR _ _ _ _  , True) -> personAny
         (TicketTopReplyR _ _ _   , _   ) -> personAny
@@ -202,6 +205,21 @@ instance Yesod App where
                         then Authorized
                         else Unauthorized "Not the expected group role"
 
+        projOp
+            :: ProjectOperation -> ShrIdent -> PrjIdent -> Handler AuthResult
+        projOp op shr prj = personAnd $ \ (Entity pid _p) -> do
+            ma <- runDB $ runMaybeT $ do
+                Entity sid _s <- MaybeT $ getBy $ UniqueSharer shr
+                Entity jid _j <- MaybeT $ getBy $ UniqueProject prj sid
+                Entity _cid c <- MaybeT $ getBy $ UniqueProjectCollab jid pid
+                let role = projectCollabRole c
+                MaybeT $ getBy $ UniqueProjectAccess role op
+            return $ case ma of
+                Nothing ->
+                    Unauthorized
+                    "You need a project role with that operation enabled"
+                Just _  -> Authorized
+
     -- This function creates static content files in the static folder
     -- and names them based on a hash of their content. This allows
     -- expiration dates to be set far in the future without worry of
@@ -381,6 +399,8 @@ instance YesodBreadcrumbs App where
                                             )
         TicketCloseR _shar _proj _num    -> ("", Nothing)
         TicketOpenR _shar _proj _num     -> ("", Nothing)
+        TicketClaimR _shar _proj _num    -> ("", Nothing)
+        TicketUnclaimR _shar _proj _num  -> ("", Nothing)
         TicketDiscussionR shar proj num  -> ( "Discussion"
                                             , Just $ TicketR shar proj num
                                             )

src/Vervis/Handler/Ticket.hs

@@ -24,6 +24,8 @@ module Vervis.Handler.Ticket
     , getTicketEditR
     , postTicketCloseR
     , postTicketOpenR
+    , postTicketClaimR
+    , postTicketUnclaimR
     , getTicketDiscussionR
     , postTicketDiscussionR
     , getTicketMessageR
@@ -36,6 +38,7 @@ where
 import Prelude
 
 import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Logger (logWarn)
 import Data.Default.Class (def)
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
@@ -140,6 +143,7 @@ getTicketNewR shar proj = do
 
 getTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
 getTicketR shar proj num = do
+    pid <- requireAuthId
     (author, massignee, closer, ticket) <- runDB $ do
         ticket <- do
             Entity s _ <- getBy404 $ UniqueSharer shar
@@ -149,9 +153,10 @@ getTicketR shar proj num = do
         author <- do
             person <- get404 $ ticketCreator ticket
             get404 $ personIdent person
-        massignee <- for (ticketAssignee ticket) $ \ pid -> do
-            person <- get404 pid
-            get404 $ personIdent person
+        massignee <- for (ticketAssignee ticket) $ \ apid -> do
+            person <- get404 apid
+            sharer <- get404 $ personIdent person
+            return (sharer, apid == pid)
         closer <-
             if ticketDone ticket
                 then do
@@ -257,6 +262,50 @@ postTicketOpenR shr prj num = do
             else "Ticket is already open."
     redirect $ TicketR shr prj num
 
+postTicketClaimR :: ShrIdent -> PrjIdent -> Int -> Handler Html
+postTicketClaimR shr prj num = do
+    pid <- requireAuthId
+    mmsg <- runDB $ do
+        Entity tid ticket <- do
+            Entity s _ <- getBy404 $ UniqueSharer shr
+            Entity p _ <- getBy404 $ UniqueProject prj s
+            getBy404 $ UniqueTicket p num
+        case (ticketDone ticket, ticketAssignee ticket) of
+            (True, _) ->
+                return $
+                Just "The ticket is closed. Can’t claim closed tickets."
+            (False, Just _) ->
+                return $
+                Just "The ticket is already assigned to someone."
+            (False, Nothing) -> do
+                update tid [TicketAssignee =. Just pid]
+                return Nothing
+    setMessage $ fromMaybe "The ticket is now assigned to you." mmsg
+    redirect $ TicketR shr prj num
+
+postTicketUnclaimR :: ShrIdent -> PrjIdent -> Int -> Handler Html
+postTicketUnclaimR shr prj num = do
+    pid <- requireAuthId
+    mmsg <- runDB $ do
+        Entity tid ticket <- do
+            Entity s _ <- getBy404 $ UniqueSharer shr
+            Entity p _ <- getBy404 $ UniqueProject prj s
+            getBy404 $ UniqueTicket p num
+        case ((== pid) <$> ticketAssignee ticket, ticketDone ticket) of
+            (Nothing, _) ->
+                return $ Just "The ticket is already unassigned."
+            (Just False, _) ->
+                return $ Just "The ticket is assigned to someone else."
+            (Just True, True) -> do
+                $logWarn "Found a closed claimed ticket, this is invalid"
+                return $
+                    Just "The ticket is closed. Can’t unclaim closed tickets."
+            (Just True, False) -> do
+                update tid [TicketAssignee =. Nothing]
+                return Nothing
+    setMessage $ fromMaybe "The ticket is now unassigned." mmsg
+    redirect $ TicketR shr prj num
+
 selectDiscussionId :: ShrIdent -> PrjIdent -> Int -> AppDB DiscussionId
 selectDiscussionId shar proj tnum = do
     Entity sid _sharer <- getBy404 $ UniqueSharer shar

src/Vervis/Model/Role.hs

@@ -28,8 +28,8 @@ data RepoOperation = RepoOpPush deriving (Eq, Show, Read, Enum, Bounded)
 derivePersistField "RepoOperation"
 
 data ProjectOperation
-    = ProjOpAskToClaimTicket
-    | ProjOpClaimTicket
+    = ProjOpClaimTicket
+    | ProjOpUnclaimTicket
     deriving (Eq, Show, Read, Enum, Bounded)
 
 derivePersistField "ProjectOperation"

templates/ticket/one.hamlet

@@ -25,24 +25,33 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
 $if not $ ticketDone ticket
   <p>
-    $maybe assignee <- massignee
-      Assigned to ^{personLinkW assignee}
+    $maybe (assignee, me) <- massignee
+      $if me
+        Assigned to you.
+
+        <form method=POST action=@{TicketUnclaimR shar proj num}>
+          <input type=submit value="Unclaim this ticket">
+      $else
+        Assigned to ^{personLinkW assignee}.
     $nothing
-      Not assigned
+      Not assigned.
+
+      <form method=POST action=@{TicketClaimR shar proj num}>
+        <input type=submit value="Claim this ticket">
 
 <p>
-  Status:
+  Status: #
   $if ticketDone ticket
     Closed on #{showDate $ ticketClosed ticket} by
     ^{personLinkW closer}.
 
     <form method=POST action=@{TicketOpenR shar proj num}>
-      <input type=submit value="Reopen this ticket.">
+      <input type=submit value="Reopen this ticket">
   $else
     Open.
 
     <form method=POST action=@{TicketCloseR shar proj num}>
-      <input type=submit value="Close this ticket.">
+      <input type=submit value="Close this ticket">
 
 <h2>#{ticketTitle ticket}