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

src/Vervis/Handler/Cloth.hs

@@ -284,10 +284,10 @@ getClothR loomHash clothHash = do
     where
     getClothHtml = do
         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
-            (ticket,,,,,,,)
+            (ticket,,,,,,,,)
                 <$> getLocalRepo' (loomRepo loom) (ticketLoomBranch cloth)
                 <*> bitraverse
                         (\ (Entity _ (TicketAuthorLocal _ personID _)) -> do
@@ -304,6 +304,7 @@ getClothR loomHash clothHash = do
                 <*> getTicketTextParams ticketID --wid
                 <*> getTicketEnumParams ticketID --wid
                 <*> getTicketClasses ticketID --wid
+                <*> traverse getTicketResolve maybeResolve
                 <*> traverse
                         (bitraverse
                                 (\ (Entity _(MergeOriginLocal _ originRepoID maybeBranch)) ->
@@ -327,9 +328,9 @@ getClothR loomHash clothHash = do
                 diffs = NE.map (patchContent . entityVal) $ NE.reverse patches
                 (repoID, _, _, maybeBranch) = targetRepo
             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)
         hashMessageKey <- handlerToWidget getEncodeKeyHashid
         let desc :: Widget

src/Vervis/Handler/Ticket.hs

@@ -251,10 +251,10 @@ getTicketR deckHash ticketHash = do
     where
     getTicketHtml = do
         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
-            (ticket,,,,)
+            (ticket,,,,,)
                 <$> bitraverse
                         (\ (Entity _ (TicketAuthorLocal _ personID _)) -> do
                             p <- getJust personID
@@ -270,6 +270,7 @@ getTicketR deckHash ticketHash = do
                 <*> getTicketTextParams ticketID --wid
                 <*> getTicketEnumParams ticketID --wid
                 <*> getTicketClasses ticketID --wid
+                <*> traverse getTicketResolve maybeResolve
         hashMessageKey <- handlerToWidget getEncodeKeyHashid
         let desc :: Widget
             desc = toWidget $ markupHTML $ ticketDescription ticket

src/Vervis/Persist/Actor.hs

@@ -15,6 +15,7 @@
 
 module Vervis.Persist.Actor
     ( getLocalActor
+    , getLocalActorEnt
     , getLocalActorEntity
     , verifyLocalActivityExistsInDB
     , getRemoteActorURI
@@ -30,6 +31,7 @@ import Control.Monad.Logger.CallStack
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Reader
+import Data.Barbie
 import Data.Text (Text)
 import Data.Traversable
 import Database.Persist
@@ -60,12 +62,16 @@ import Vervis.Settings
 
 getLocalActor
     :: 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 $
         case (mp, mg, mr, md, ml) of
             (Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId"

src/Vervis/Ticket.hs

@@ -47,6 +47,8 @@ module Vervis.Ticket
     , parseProposalBundle
 
     , checkDepAndTarget
+
+    , getTicketResolve
     )
 where
 
@@ -56,6 +58,7 @@ import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Reader
+import Data.Bitraversable
 import Data.Either
 import Data.Foldable (for_)
 import Data.Maybe
@@ -88,6 +91,7 @@ import Vervis.Model
 import Vervis.Model.Ident
 import Vervis.Model.Workflow
 import Vervis.Paginate
+import Vervis.Persist.Actor
 import Vervis.Recipient
 import Vervis.Widget.Ticket
 
@@ -786,3 +790,29 @@ checkDepAndTarget
     checkParentAndTarget (Left _) (Right _) = throwE "Local parent but remote target"
     checkParentAndTarget (Right _) (Left _) = throwE "Local target but remote parent"
     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)

templates/cloth/one.hamlet

@@ -130,20 +130,12 @@ $#       .
 
 <p>
   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

templates/ticket/one.hamlet

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