UI: In ticket/MR pages, display when and by whom the ticket was resolved

This commit is contained in:
fr33domlover 2022-10-16 22:25:21 +00:00
parent 58ca5e998e
commit e638ff4117
6 changed files with 65 additions and 44 deletions

View file

@ -284,10 +284,10 @@ getClothR loomHash clothHash = do
where where
getClothHtml = do getClothHtml = do
mpid <- maybeAuthId mpid <- maybeAuthId
(ticket, targetRepo, author, tparams, eparams, cparams, moriginRepo, mbundle) <- handlerToWidget $ runDB $ do (ticket, targetRepo, author, tparams, eparams, cparams, resolved, moriginRepo, mbundle) <- handlerToWidget $ runDB $ do
(Entity _ loom, Entity _ cloth, Entity ticketID ticket, author, _maybe_ResolveAndEitherTrlOrTrr, proposal) <- (Entity _ loom, Entity _ cloth, Entity ticketID ticket, author, maybeResolve, proposal) <-
getCloth404 loomHash clothHash getCloth404 loomHash clothHash
(ticket,,,,,,,) (ticket,,,,,,,,)
<$> getLocalRepo' (loomRepo loom) (ticketLoomBranch cloth) <$> getLocalRepo' (loomRepo loom) (ticketLoomBranch cloth)
<*> bitraverse <*> bitraverse
(\ (Entity _ (TicketAuthorLocal _ personID _)) -> do (\ (Entity _ (TicketAuthorLocal _ personID _)) -> do
@ -304,6 +304,7 @@ getClothR loomHash clothHash = do
<*> getTicketTextParams ticketID --wid <*> getTicketTextParams ticketID --wid
<*> getTicketEnumParams ticketID --wid <*> getTicketEnumParams ticketID --wid
<*> getTicketClasses ticketID --wid <*> getTicketClasses ticketID --wid
<*> traverse getTicketResolve maybeResolve
<*> traverse <*> traverse
(bitraverse (bitraverse
(\ (Entity _(MergeOriginLocal _ originRepoID maybeBranch)) -> (\ (Entity _(MergeOriginLocal _ originRepoID maybeBranch)) ->
@ -327,9 +328,9 @@ getClothR loomHash clothHash = do
diffs = NE.map (patchContent . entityVal) $ NE.reverse patches diffs = NE.map (patchContent . entityVal) $ NE.reverse patches
(repoID, _, _, maybeBranch) = targetRepo (repoID, _, _, maybeBranch) = targetRepo
maybeErrorOrCanApply <- maybeErrorOrCanApply <-
case ticketStatus ticket of case resolved of
TSClosed -> pure Nothing Just _ -> pure Nothing
_ -> Just <$> runExceptT (canApplyPatches repoID maybeBranch diffs) Nothing -> Just <$> runExceptT (canApplyPatches repoID maybeBranch diffs)
return (bundleID, patchIDs, maybeErrorOrCanApply) return (bundleID, patchIDs, maybeErrorOrCanApply)
hashMessageKey <- handlerToWidget getEncodeKeyHashid hashMessageKey <- handlerToWidget getEncodeKeyHashid
let desc :: Widget let desc :: Widget

View file

@ -251,10 +251,10 @@ getTicketR deckHash ticketHash = do
where where
getTicketHtml = do getTicketHtml = do
mpid <- maybeAuthId mpid <- maybeAuthId
(ticket, author, tparams, eparams, cparams) <- handlerToWidget $ runDB $ do (ticket, author, tparams, eparams, cparams, resolved) <- handlerToWidget $ runDB $ do
(_deck, _ticketdeck, Entity ticketID ticket, author, _maybe_ResolveAndEitherTrlOrTrr) <- (_deck, _ticketdeck, Entity ticketID ticket, author, maybeResolve) <-
getTicket404 deckHash ticketHash getTicket404 deckHash ticketHash
(ticket,,,,) (ticket,,,,,)
<$> bitraverse <$> bitraverse
(\ (Entity _ (TicketAuthorLocal _ personID _)) -> do (\ (Entity _ (TicketAuthorLocal _ personID _)) -> do
p <- getJust personID p <- getJust personID
@ -270,6 +270,7 @@ getTicketR deckHash ticketHash = do
<*> getTicketTextParams ticketID --wid <*> getTicketTextParams ticketID --wid
<*> getTicketEnumParams ticketID --wid <*> getTicketEnumParams ticketID --wid
<*> getTicketClasses ticketID --wid <*> getTicketClasses ticketID --wid
<*> traverse getTicketResolve maybeResolve
hashMessageKey <- handlerToWidget getEncodeKeyHashid hashMessageKey <- handlerToWidget getEncodeKeyHashid
let desc :: Widget let desc :: Widget
desc = toWidget $ markupHTML $ ticketDescription ticket desc = toWidget $ markupHTML $ ticketDescription ticket

View file

@ -15,6 +15,7 @@
module Vervis.Persist.Actor module Vervis.Persist.Actor
( getLocalActor ( getLocalActor
, getLocalActorEnt
, getLocalActorEntity , getLocalActorEntity
, verifyLocalActivityExistsInDB , verifyLocalActivityExistsInDB
, getRemoteActorURI , getRemoteActorURI
@ -30,6 +31,7 @@ import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
import Data.Barbie
import Data.Text (Text) import Data.Text (Text)
import Data.Traversable import Data.Traversable
import Database.Persist import Database.Persist
@ -60,12 +62,16 @@ import Vervis.Settings
getLocalActor getLocalActor
:: MonadIO m => ActorId -> ReaderT SqlBackend m (LocalActorBy Key) :: MonadIO m => ActorId -> ReaderT SqlBackend m (LocalActorBy Key)
getLocalActor actorID = do getLocalActor = fmap (bmap entityKey) . getLocalActorEnt
mp <- getKeyBy $ UniquePersonActor actorID
mg <- getKeyBy $ UniqueGroupActor actorID getLocalActorEnt
mr <- getKeyBy $ UniqueRepoActor actorID :: MonadIO m => ActorId -> ReaderT SqlBackend m (LocalActorBy Entity)
md <- getKeyBy $ UniqueDeckActor actorID getLocalActorEnt actorID = do
ml <- getKeyBy $ UniqueLoomActor actorID mp <- getBy $ UniquePersonActor actorID
mg <- getBy $ UniqueGroupActor actorID
mr <- getBy $ UniqueRepoActor actorID
md <- getBy $ UniqueDeckActor actorID
ml <- getBy $ UniqueLoomActor actorID
return $ return $
case (mp, mg, mr, md, ml) of case (mp, mg, mr, md, ml) of
(Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId" (Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId"

View file

@ -47,6 +47,8 @@ module Vervis.Ticket
, parseProposalBundle , parseProposalBundle
, checkDepAndTarget , checkDepAndTarget
, getTicketResolve
) )
where where
@ -56,6 +58,7 @@ import Control.Monad.Trans.Class
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
import Data.Bitraversable
import Data.Either import Data.Either
import Data.Foldable (for_) import Data.Foldable (for_)
import Data.Maybe import Data.Maybe
@ -88,6 +91,7 @@ import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
import Vervis.Model.Workflow import Vervis.Model.Workflow
import Vervis.Paginate import Vervis.Paginate
import Vervis.Persist.Actor
import Vervis.Recipient import Vervis.Recipient
import Vervis.Widget.Ticket import Vervis.Widget.Ticket
@ -786,3 +790,29 @@ checkDepAndTarget
checkParentAndTarget (Left _) (Right _) = throwE "Local parent but remote target" checkParentAndTarget (Left _) (Right _) = throwE "Local parent but remote target"
checkParentAndTarget (Right _) (Left _) = throwE "Local target but remote parent" checkParentAndTarget (Right _) (Left _) = throwE "Local target but remote parent"
checkParentAndTarget (Right _) (Right _) = return () checkParentAndTarget (Right _) (Right _) = return ()
getTicketResolve (Entity _ tr, resolve) = do
time <- outboxItemPublished <$> getJust (ticketResolveAccept tr)
closer <- bitraverse getCloserLocal getCloserRemote resolve
return (time, closer)
where
getCloserLocal (Entity _ trl) = do
outboxID <-
outboxItemOutbox <$>
getJust (ticketResolveLocalActivity trl)
Entity actorID actor <- do
maybeActor <- getBy $ UniqueActorOutbox outboxID
case maybeActor of
Nothing -> error "No actor for outbox"
Just a -> pure a
actorByEntity <- getLocalActorEnt actorID
person <-
case actorByEntity of
LocalActorPerson p -> pure p
_ -> error "Surprise! Ticket closer isn't a Person"
return (person, actor)
getCloserRemote (Entity _ trr) = do
ra <- getJust $ ticketResolveRemoteActor trr
ro <- getJust $ remoteActorIdent ra
i <- getJust $ remoteObjectInstance ro
return (i, ro, ra)

View file

@ -130,20 +130,12 @@ $# .
<p> <p>
Status: # Status: #
$case ticketStatus ticket $maybe (closed, closer) <- resolved
$of TSNew Closed on #{showDate closed} by ^{personLinkFedW closer}
Open, new. $# ^{buttonW POST "Reopen this MR" (ProjectTicketOpenR loomHash clothHash)}
$nothing
$# ^{buttonW POST "Accept this ticket" (ProjectTicketAcceptR loomHash clothHash)} Open
$# ^{buttonW POST "Close this ticket" (ProjectTicketCloseR loomHash clothHash)} $# ^{buttonW POST "Close this MR" (ProjectTicketCloseR loomHash clothHash)}
$of TSTodo
Open, to do.
$# ^{buttonW POST "Close this ticket" (ProjectTicketCloseR loomHash clothHash)}
$of TSClosed
Closed on ___ by ___.
$# ^{buttonW POST "Reopen this ticket" (ProjectTicketOpenR loomHash clothHash)}
<h3>Custom fields <h3>Custom fields

View file

@ -65,21 +65,12 @@ $# .
<p> <p>
Status: # Status: #
$case ticketStatus ticket $maybe (closed, closer) <- resolved
$of TSNew Closed on #{showDate closed} by ^{personLinkFedW closer}
Open, new. $# ^{buttonW POST "Reopen this ticket" (ProjectTicketOpenR deckHash ticketHash)}
$nothing
$# ^{buttonW POST "Accept this ticket" (ProjectTicketAcceptR deckHash ticketHash)} Open
$# ^{buttonW POST "Close this ticket" (ProjectTicketCloseR deckHash ticketHash)} $# ^{buttonW POST "Close this ticket" (ProjectTicketCloseR deckHash ticketHash)}
$of TSTodo
Open, to do.
$# ^{buttonW POST "Close this ticket" (ProjectTicketCloseR deckHash ticketHash)}
$of TSClosed
Closed on ___ by ___.
$# ^{buttonW POST "Reopen this ticket" (ProjectTicketOpenR deckHash ticketHash)}
<h3>Custom fields <h3>Custom fields