diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs
index 32f6b7b..b28e90f 100644
--- a/src/Vervis/API.hs
+++ b/src/Vervis/API.hs
@@ -27,7 +27,6 @@ module Vervis.API
, createRepositoryC
, followC
--, offerDepC
- , undoC
)
where
@@ -1973,176 +1972,3 @@ insertAcceptOnTicketStatus shrUser wi (WorkItemDetail _ ctx author) obiidResolve
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (doc, recipientSet, remoteActors, fwdHosts)
-}
-
-undoC
- :: Entity Person
- -> Actor
- -> Maybe
- (Either
- (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
- FedURI
- )
- -> RecipientRoutes
- -> [(Host, NonEmpty LocalURI)]
- -> [Host]
- -> AP.Action URIMode
- -> AP.Undo URIMode
- -> ExceptT Text Handler OutboxItemId
-undoC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips remoteRecips fwdHosts action (AP.Undo uObject) = do
-
- -- Check input
- undone <-
- first (\ (actor, _, item) -> (actor, item)) <$>
- parseActivityURI uObject
-
- now <- liftIO getCurrentTime
- senderHash <- encodeKeyHashid senderPersonID
-
- (undoID, deliverHttpUndo, maybeDeliverHttpAccept) <- runDBExcept $ do
-
- -- Find the undone activity in our DB
- undoneDB <- do
- a <- getActivity undone
- fromMaybeE a "Can't find undone in DB"
-
- -- See if the undone activity is a Follow/Resolve on a local target
- -- If it is, verify the relevant actor is addressed, verify
- -- permissions, and perform the actual undoing in the DB
- maybeUndoLocal <- do
- maybeUndo <-
- lift $ runMaybeT $
- Left <$> MaybeT (tryUnfollow undoneDB) <|>
- Right <$> MaybeT (tryUnresolve undoneDB)
- case maybeUndo of
- Nothing -> pure Nothing
- Just (Left (updateDB, actorID, Left followerSetID)) -> do
- actorByKey <- lift $ getLocalActor actorID
- unless (actorByKey == LocalActorPerson senderPersonID) $
- throwE "Tryin to undo a Follow of someone else"
- (fByKey, fActorID, _) <- do
- followee <- lift $ getFollowee' followerSetID
- getFollowee followee
- fByHash <- hashLocalActor fByKey
- unless (actorIsAddressed localRecips fByHash) $
- throwE "Followee's actor not addressed by the Undo"
- lift updateDB
- fActor <- lift $ getJust fActorID
- return $ Just
- ( fByKey
- , Entity fActorID fActor
- , makeRecipientSet
- [fByHash]
- [LocalStagePersonFollowers senderHash]
- , [LocalActorPerson senderHash]
- , []
- )
- Just (Left (updateDB, actorID, Right uTarget)) -> do
- actorByKey <- lift $ getLocalActor actorID
- unless (actorByKey == LocalActorPerson senderPersonID) $
- throwE "Trying to undo a Follow of someone else"
- verifyRemoteAddressed remoteRecips uTarget
- lift updateDB
- return Nothing
- Just (Right (updateDB, ticketID)) -> do
- wiByKey <- lift $ getWorkItem ticketID
- wiByHash <- lift $ lift $ VA2.runAct $ hashWorkItem wiByKey
- let resource = workItemResource wiByKey
- actorByKey = workItemActor wiByKey
- actorByHash = workItemActor wiByHash
- unless (actorIsAddressed localRecips actorByHash) $
- throwE "Work item's actor not addressed by the Undo"
- capID <- fromMaybeE maybeCap "No capability provided"
- capability <-
- case capID of
- Left (capActor, _, capItem) -> return (capActor, capItem)
- Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local tracker"
- verifyCapability capability (Left senderPersonID) resource RoleTriage
- lift updateDB
- actorID <- do
- maybeActor <- lift $ getLocalActorEntity actorByKey
- case localActorID <$> maybeActor of
- Nothing -> error "Actor entity not in DB"
- Just aid -> pure aid
- actor <- lift $ getJust actorID
- return $ Just
- ( actorByKey
- , Entity actorID actor
- , makeRecipientSet
- [actorByHash]
- [ localActorFollowers actorByHash
- , workItemFollowers wiByHash
- , LocalStagePersonFollowers senderHash
- ]
- , [LocalActorPerson senderHash]
- , [ localActorFollowers actorByHash
- , workItemFollowers wiByHash
- , LocalStagePersonFollowers senderHash
- ]
- )
-
- -- Insert the Undo activity to author's outbox
- undoID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
- luUndo <- lift $ updateOutboxItem (LocalActorPerson senderPersonID) undoID action
-
- -- Deliver the Undo activity to local recipients, and schedule delivery
- -- for unavailable remote recipients
- deliverHttpUndo <- do
- let sieve =
- case maybeUndoLocal of
- Nothing ->
- makeRecipientSet
- [] [LocalStagePersonFollowers senderHash]
- Just (_, _, s, _, _) -> s
- localRecipsFinal = localRecipSieve sieve False localRecips
- deliverActivityDB
- (LocalActorPerson senderHash) (personActor senderPerson)
- localRecipsFinal remoteRecips fwdHosts undoID action
-
- maybeDeliverHttpAccept <- for maybeUndoLocal $ \ (actorByKey, Entity actorID actor, _, acceptActors, acceptStages) -> do
-
- -- Verify the relevant actor has received the Undp
- verifyActorHasItem actorID undoID "Actor didn't receive the Undo"
-
- -- Insert an Accept activity to actor's outbox
- acceptID <- lift $ insertEmptyOutboxItem (actorOutbox actor) now
- actionAccept <- prepareAccept luUndo acceptActors acceptStages
- _luAccept <- lift $ updateOutboxItem actorByKey acceptID actionAccept
-
- -- Deliver the Accept activity to local recipients, and schedule
- -- delivery for unavailable remote recipients
- let localRecipsAccept = makeRecipientSet acceptActors acceptStages
- actorByHash <- hashLocalActor actorByKey
- deliverActivityDB
- actorByHash actorID localRecipsAccept [] []
- acceptID actionAccept
-
- -- Return instructions for HTTP delivery to remote recipients
- return (undoID, deliverHttpUndo, maybeDeliverHttpAccept)
-
- -- Launch asynchronous HTTP delivery of Undo and Accept
- lift $ do
- forkWorker "undoC: async HTTP Undo delivery" deliverHttpUndo
- for_ maybeDeliverHttpAccept $
- forkWorker "undoC: async HTTP Accept delivery"
-
- return undoID
-
- where
-
- prepareAccept luUndo actors stages = do
- encodeRouteHome <- getEncodeRouteHome
- hLocal <- asksSite siteInstanceHost
- let recips =
- map encodeRouteHome $
- map renderLocalActor actors ++
- map renderLocalStage stages
- return AP.Action
- { AP.actionCapability = Nothing
- , AP.actionSummary = Nothing
- , AP.actionAudience = Audience recips [] [] [] [] []
- , AP.actionFulfills = []
- , AP.actionSpecific = AP.AcceptActivity AP.Accept
- { AP.acceptObject = ObjURI hLocal luUndo
- , AP.acceptResult = Nothing
- }
- }
diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs
index 1b458fa..0d3977b 100644
--- a/src/Vervis/Actor/Person/Client.hs
+++ b/src/Vervis/Actor/Person/Client.hs
@@ -1009,7 +1009,7 @@ clientResolve
-> ActE OutboxItemId
clientResolve now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) (AP.Resolve uObject) = do
- (actorMeID, localRecipsFinal, acceptID) <- withDBExcept $ do
+ (actorMeID, localRecipsFinal, resolveID) <- withDBExcept $ do
-- Grab me from DB
(personMe, actorMe) <- lift $ do
@@ -1028,8 +1028,42 @@ clientResolve now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHos
lift $ sendActivity
(LocalActorPerson personMeID) actorMeID localRecipsFinal remoteRecips
- fwdHosts acceptID action
- return acceptID
+ fwdHosts resolveID action
+ return resolveID
+
+-- Meaning: The human wants to unfollow or unresolve
+-- Behavior:
+-- * Insert the Undo to my inbox
+-- * Asynchrnously deliver without filter
+clientUndo
+ :: UTCTime
+ -> PersonId
+ -> ClientMsg
+ -> AP.Undo URIMode
+ -> ActE OutboxItemId
+clientUndo now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) (AP.Undo uObject) = do
+
+ (actorMeID, localRecipsFinal, undoID) <- withDBExcept $ do
+
+ -- Grab me from DB
+ (personMe, actorMe) <- lift $ do
+ p <- getJust personMeID
+ (p,) <$> getJust (personActor p)
+
+ -- Insert the Undo activity to my outbox
+ acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
+ _luAccept <- lift $ updateOutboxItem' (LocalActorPerson personMeID) acceptID action
+
+ return
+ ( personActor personMe
+ , localRecips
+ , acceptID
+ )
+
+ lift $ sendActivity
+ (LocalActorPerson personMeID) actorMeID localRecipsFinal remoteRecips
+ fwdHosts undoID action
+ return undoID
clientBehavior :: UTCTime -> PersonId -> ClientMsg -> ActE (Text, Act (), Next)
clientBehavior now personID msg =
@@ -1042,4 +1076,5 @@ clientBehavior now personID msg =
AP.OfferActivity offer -> clientOffer now personID msg offer
AP.RemoveActivity remove -> clientRemove now personID msg remove
AP.ResolveActivity resolve -> clientResolve now personID msg resolve
+ AP.UndoActivity undo -> clientUndo now personID msg undo
_ -> throwE "Unsupported activity type for C2S"
diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs
index 01a16d1..d8a4130 100644
--- a/src/Vervis/Client.hs
+++ b/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
@@ -365,33 +368,32 @@ offerIssue senderHash title desc uTracker = do
return (Nothing, audience, ticket)
resolve
- :: KeyHashid Person
+ :: PersonId
-> FedURI
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Resolve URIMode)
-resolve senderHash uObject = do
+resolve senderID uObject = do
- manager <- asksSite appHttpManager
- AP.Doc _ t <- withExceptT T.pack $ fetchAP manager (Left uObject)
- uTracker <- fromMaybeE (AP.ticketContext t) "Ticket without context"
- audFollowers <- do
- (hFollowers, tl) <- fromMaybeE (AP.ticketLocal t) "Ticket without id"
- let luFollowers = AP.ticketParticipants tl
- routeOrRemote <- parseFedURIOld $ ObjURI hFollowers luFollowers
+ senderHash <- encodeKeyHashid senderID
+ encodeRouteHome <- getEncodeRouteHome
+ (uTracker, audFollowers) <- do
+ routeOrRemote <- parseFedURIOld uObject
case routeOrRemote of
- Left route ->
- case route of
- TicketFollowersR d t ->
- return $
- AudLocal
- []
- [LocalStageTicketFollowers d t]
- ClothFollowersR l c ->
- return $
- AudLocal
- []
- [LocalStageClothFollowers l c]
- _ -> throwE "Not a tickets followers route"
- Right u@(ObjURI h lu) -> return $ AudRemote h [] [lu]
+ 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]
+ return (uTracker, audFollowers)
+ 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]
+ return (uTracker, audFollowers)
tracker <- do
tracker <- runActE $ checkTracker uTracker
@@ -428,6 +430,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 +680,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 +1360,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
diff --git a/src/Vervis/Federation/Offer.hs b/src/Vervis/Federation/Offer.hs
index 1ed7838..dc1979f 100644
--- a/src/Vervis/Federation/Offer.hs
+++ b/src/Vervis/Federation/Offer.hs
@@ -26,7 +26,6 @@ module Vervis.Federation.Offer
--, repoFollowF
--personUndoF
- --deckUndoF
loomUndoF
, repoUndoF
)
diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index 5e1cd5c..4963e87 100644
--- a/src/Vervis/Foundation.hs
+++ b/src/Vervis/Foundation.hs
@@ -854,6 +854,7 @@ instance YesodBreadcrumbs App where
PublishMergeR -> ("Apply MR", Just HomeR)
PublishInviteR -> ("Invite someone to a resource", Just HomeR)
PublishRemoveR -> ("Remove someone from a resource", Just HomeR)
+ PublishResolveR -> ("Close a ticket", Just HomeR)
PersonR p -> ("Person ~" <> keyHashidText p, Just HomeR)
PersonInboxR p -> ("Inbox", Just $ PersonR p)
@@ -951,6 +952,7 @@ instance YesodBreadcrumbs App where
TicketNewR d -> ("New Ticket", Just $ DeckR d)
TicketCloseR _ _ -> ("", Nothing)
+ TicketOpenR _ _ -> ("", Nothing)
TicketFollowR _ _ -> ("", Nothing)
TicketUnfollowR _ _ -> ("", Nothing)
TicketReplyR d t -> ("Reply", Just $ TicketR d t)
diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs
index ebc524c..26fe558 100644
--- a/src/Vervis/Handler/Client.hs
+++ b/src/Vervis/Handler/Client.hs
@@ -41,6 +41,9 @@ module Vervis.Handler.Client
, getPublishRemoveR
, postPublishRemoveR
+
+ , getPublishResolveR
+ , postPublishResolveR
)
where
@@ -1268,3 +1271,42 @@ postPublishRemoveR = do
Right _ -> do
setMessage "Remove activity sent"
redirect HomeR
+
+resolveForm = renderDivs $ (,)
+ <$> areq fedUriField "(URI) Ticket to close" Nothing
+ <*> areq capField "(URI) Grant activity to use for authorization" Nothing
+
+getPublishResolveR :: Handler Html
+getPublishResolveR = do
+ ((_, widget), enctype) <- runFormPost resolveForm
+ defaultLayout
+ [whamlet|
+ Close a ticket
+