Client: Port/implement pseudo-client for unresolve-a-ticket

src/Vervis/Client.hs

@@ -26,11 +26,11 @@ module Vervis.Client
     --, followRepo
     , offerIssue
     , resolve
+    , unresolve
     --, undoFollowSharer
     --, undoFollowProject
     --, undoFollowTicket
     --, undoFollowRepo
-    --, unresolve
     , offerPatches
     , offerMerge
     , applyPatches
@@ -92,10 +92,13 @@ import Vervis.Data.Ticket
 import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
-import Vervis.Recipient
+import Vervis.Persist.Actor
+import Vervis.Recipient (Aud (..), LocalStageBy (..), collectAudience, renderLocalActor, localActorFollowers)
 import Vervis.RemoteActorStore
 import Vervis.Ticket
 
+import qualified Vervis.Recipient as VR
+
 makeServerInput
     :: (MonadSite m, SiteEnv m ~ App)
     => Maybe FedURI
@@ -370,28 +373,26 @@ resolve
     -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Resolve URIMode)
 resolve senderHash uObject = do
 
-    manager <- asksSite appHttpManager
+    encodeRouteHome <- getEncodeRouteHome
-    AP.Doc _ t <- withExceptT T.pack $ fetchAP manager (Left uObject)
+    (uTracker, audFollowers) <- do
-    uTracker <- fromMaybeE (AP.ticketContext t) "Ticket without context"
+        routeOrRemote <- parseFedURIOld uObject
-    audFollowers <- do
-        (hFollowers, tl) <- fromMaybeE (AP.ticketLocal t) "Ticket without id"
-        let luFollowers = AP.ticketParticipants tl
-        routeOrRemote <- parseFedURIOld $ ObjURI hFollowers luFollowers
         case routeOrRemote of
-            Left route ->
+            Left route -> do
-                case route of
+                wih <- fromMaybeE (parseWorkItem route) "Not a work item route"
-                    TicketFollowersR d t ->
+                wi <- runActE $ unhashWorkItemE wih "Work item invalid keyhashid"
-                        return $
+                let uTracker =
-                            AudLocal
+                        encodeRouteHome $ renderLocalActor $ workItemActor wih
-                                []
+                    audFollowers = AudLocal [] [workItemFollowers wih]
-                                [LocalStageTicketFollowers d t]
+                return (uTracker, audFollowers)
-                    ClothFollowersR l c ->
+            Right u -> do
-                        return $
+                manager <- asksSite appHttpManager
-                            AudLocal
+                AP.Doc _ t <- withExceptT T.pack $ fetchAP manager (Left u)
-                                []
+                uTracker <- fromMaybeE (AP.ticketContext t) "Ticket without context"
-                                [LocalStageClothFollowers l c]
+                audFollowers <- do
-                    _ -> throwE "Not a tickets followers route"
+                    (hFollowers, tl) <- fromMaybeE (AP.ticketLocal t) "Ticket without id"
-            Right u@(ObjURI h lu) -> return $ AudRemote h [] [lu]
+                    let luFollowers = AP.ticketParticipants tl
+                    return $ AudRemote hFollowers [] [luFollowers]
+                return (uTracker, audFollowers)
 
     tracker <- do
         tracker <- runActE $ checkTracker uTracker
@@ -428,6 +429,116 @@ resolve senderHash uObject = do
 
     return (Nothing, audience, AP.Resolve uObject)
 
+unresolve
+    :: KeyHashid Person
+    -> FedURI
+    -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Undo URIMode)
+unresolve senderHash uTicket = do
+
+    encodeRouteHome <- getEncodeRouteHome
+    (uTracker, audFollowers, uResolve) <- do
+        routeOrRemote <- parseFedURIOld uTicket
+        case routeOrRemote of
+            Left route -> do
+                wih <- fromMaybeE (parseWorkItem route) "Not a work item route"
+                wi <- runActE $ unhashWorkItemE wih "Work item invalid keyhashid"
+                let uTracker =
+                        encodeRouteHome $ renderLocalActor $ workItemActor wih
+                    audFollowers = AudLocal [] [workItemFollowers wih]
+                resolved <- runDBExcept $ do
+                    mresolved <-
+                        case wi of
+                            WorkItemTicket d t -> do
+                                (_, _, _, _, mresolved) <- do
+                                    mt <- lift $ getTicket d t
+                                    fromMaybeE mt "No such ticket in DB"
+                                return mresolved
+                            WorkItemCloth l c -> do
+                                (_, _, _, _, mresolved, _) <- do
+                                    mc <- lift $ getCloth l c
+                                    fromMaybeE mc "No such MR in DB"
+                                return mresolved
+                    (_, etrx) <- fromMaybeE mresolved "Ticket not resolved"
+                    lift $ bitraverse
+                        (\ (Entity _ trl) -> do
+                            let obiid = ticketResolveLocalActivity trl
+                            obid <- outboxItemOutbox <$> getJust obiid
+                            actorID <- do
+                                maybeActorID <- getKeyBy $ UniqueActorOutbox obid
+                                case maybeActorID of
+                                    Nothing -> error "Found outbox not used by any actor"
+                                    Just a -> return a
+                            actor <- getLocalActor actorID
+                            return (actor, obiid)
+                        )
+                        (\ (Entity _ trr) -> do
+                            roid <-
+                                remoteActivityIdent <$>
+                                    getJust (ticketResolveRemoteActivity trr)
+                            ro <- getJust roid
+                            i <- getJust $ remoteObjectInstance ro
+                            return (i, ro)
+                        )
+                        etrx
+                hashItem <- getEncodeKeyHashid
+                hashActor <- VR.getHashLocalActor
+                let uResolve =
+                        case resolved of
+                            Left (actor, obiid) ->
+                                encodeRouteHome $
+                                    activityRoute (hashActor actor) (hashItem obiid)
+                            Right (i, ro) ->
+                                ObjURI (instanceHost i) (remoteObjectIdent ro)
+                return (uTracker, audFollowers, uResolve)
+            Right u -> do
+                manager <- asksSite appHttpManager
+                AP.Doc _ t <- withExceptT T.pack $ fetchAP manager (Left u)
+                uTracker <- fromMaybeE (AP.ticketContext t) "Ticket without context"
+                audFollowers <- do
+                    (hFollowers, tl) <- fromMaybeE (AP.ticketLocal t) "Ticket without id"
+                    let luFollowers = AP.ticketParticipants tl
+                    return $ AudRemote hFollowers [] [luFollowers]
+                uResolve <-
+                    case AP.ticketResolved t of
+                        Just (Just u, _) -> return u
+                        _ -> throwE "No ticket resolve URI specified"
+                return (uTracker, audFollowers, uResolve)
+
+    tracker <- do
+        tracker <- runActE $ checkTracker uTracker
+        case tracker of
+            TrackerDeck deckID -> Left . Left <$> encodeKeyHashid deckID
+            TrackerLoom loomID -> Left . Right <$> encodeKeyHashid loomID
+            TrackerRemote (ObjURI hTracker luTracker) -> Right <$> do
+                instanceID <- lift $ runDB $ either entityKey id <$> insertBy' (Instance hTracker)
+                result <- ExceptT $ first (T.pack . displayException) <$> fetchRemoteActor instanceID hTracker luTracker
+                case result of
+                    Left Nothing -> throwE "Tracker @id mismatch"
+                    Left (Just err) -> throwE $ T.pack $ displayException err
+                    Right Nothing -> throwE "Tracker isn't an actor"
+                    Right (Just actor) -> return (entityVal actor, uTracker)
+
+    let audAuthor =
+            AudLocal [] [LocalStagePersonFollowers senderHash]
+        audTracker =
+            case tracker of
+                Left (Left deckHash) ->
+                    AudLocal
+                        [LocalActorDeck deckHash]
+                        [LocalStageDeckFollowers deckHash]
+                Left (Right loomHash) ->
+                    AudLocal
+                        [LocalActorLoom loomHash]
+                        [LocalStageLoomFollowers loomHash]
+                Right (remoteActor, ObjURI hTracker luTracker) ->
+                    AudRemote hTracker
+                        [luTracker]
+                        (maybeToList $ remoteActorFollowers remoteActor)
+
+        audience = [audAuthor, audTracker, audFollowers]
+
+    return (Nothing, audience, AP.Undo uResolve)
+
 {-
 undoFollow
     :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
@@ -568,73 +679,6 @@ undoFollowRepo shrAuthor pidAuthor shrFollowee rpFollowee =
         repoFollowers <$>
             fromMaybeE mr "Unfollow target no such local repo"
     -}
-
-unresolve
-    :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
-    => ShrIdent
-    -> FedURI
-    -> m (Either Text (Maybe TextHtml, Audience URIMode, Undo URIMode))
-unresolve shrUser uTicket = runExceptT $ do
-    error "Temporarily disabled"
-    {-
-    encodeRouteHome <- getEncodeRouteHome
-    wiFollowers <- askWorkItemFollowers
-    ticket <- parseWorkItem "Ticket" uTicket
-    WorkItemDetail ident context author <- runWorkerExcept $ getWorkItemDetail "Ticket" ticket
-    uResolve <-
-        case ident of
-            Left (_, ltid) -> runSiteDBExcept $ do
-                mtrid <- lift $ getKeyBy $ UniqueTicketResolve ltid
-                trid <- fromMaybeE mtrid "Ticket already isn't resolved"
-                trx <-
-                    lift $
-                    requireEitherAlt
-                        (getValBy $ UniqueTicketResolveLocal trid)
-                        (getValBy $ UniqueTicketResolveRemote trid)
-                        "No TRX"
-                        "Both TRL and TRR"
-                case trx of
-                    Left trl -> lift $ do
-                        let obiid = ticketResolveLocalActivity trl
-                        obid <- outboxItemOutbox <$> getJust obiid
-                        ent <- getOutboxActorEntity obid
-                        obikhid <- encodeKeyHashid obiid
-                        encodeRouteHome . flip outboxItemRoute obikhid <$>
-                            actorEntityPath ent
-                    Right trr -> lift $ do
-                        roid <-
-                            remoteActivityIdent <$>
-                                getJust (ticketResolveRemoteActivity trr)
-                        ro <- getJust roid
-                        i <- getJust $ remoteObjectInstance ro
-                        return $ ObjURI (instanceHost i) (remoteObjectIdent ro)
-            Right (u, _) -> do
-                manager <- asksSite appHttpManager
-                Doc _ t <- withExceptT T.pack $ AP.fetchAP manager $ Left u
-                case ticketResolved t of
-                    Nothing -> throwE "Ticket already isn't resolved"
-                    Just (muBy, _) -> fromMaybeE muBy "Ticket doesn't specify 'resolvedBy'"
-    let audAuthor =
-            AudLocal
-                [LocalActorSharer shrUser]
-                [LocalPersonCollectionSharerFollowers shrUser]
-        audTicketContext = contextAudience context
-        audTicketAuthor = authorAudience author
-        audTicketFollowers =
-            case ident of
-                Left (wi, _ltid) -> AudLocal [] [wiFollowers wi]
-                Right (ObjURI h _, luFollowers) -> AudRemote h [] [luFollowers]
-
-        (_, _, _, audLocal, audRemote) =
-            collectAudience $
-                audAuthor :
-                audTicketAuthor :
-                audTicketFollowers :
-                audTicketContext
-
-        recips = map encodeRouteHome audLocal ++ audRemote
-    return (Nothing, Audience recips [] [] [] [] [], Undo uResolve)
-    -}
 -}
 
 offerPatches
@@ -1315,7 +1359,7 @@ acceptProjectInvite personID component project uInvite = do
     encodeRouteHome <- getEncodeRouteHome
     theater <- asksSite appTheater
     env <- asksSite appEnv
-    component' <- Vervis.Recipient.hashLocalActor component
+    component' <- VR.hashLocalActor component
     project' <- bitraverse encodeKeyHashid pure project
 
     let activity = AP.Accept uInvite Nothing