diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index ab9083b..206a745 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -38,6 +38,7 @@ module Vervis.Client , createLoom , createRepo , invite + , remove ) where @@ -1028,3 +1029,84 @@ invite personID uRecipient uResource = do audience = [audResource, audRecipient, audAuthor] return (Nothing, audience, activity) + +remove + :: PersonId + -> FedURI + -> FedURI + -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Remove URIMode) +remove personID uRecipient uResource = do + + theater <- asksSite appTheater + env <- asksSite appEnv + + let activity = AP.Remove uRecipient uResource + (resource, recipient) <- + runActE $ parseRemove (Left $ LocalActorPerson personID) activity + + -- If resource is remote, we need to get it from DB/HTTP to determine its + -- managing actor & followers collection + resourceDB <- + bitraverse + hashGrantResource + (\ u@(ObjURI h lu) -> do + instanceID <- + lift $ runDB $ either entityKey id <$> insertBy' (Instance h) + result <- + ExceptT $ first (T.pack . show) <$> + runAct (fetchRemoteResource instanceID h lu) + case result of + Left (Entity _ actor) -> + return (actor, u) + Right (_objectID, luManager, (Entity _ actor)) -> + return (actor, ObjURI h luManager) + ) + resource + + -- If target is remote, get it via HTTP/DB to determine its followers + -- collection + recipientDB <- + bitraverse + (runActE . hashGrantRecip) + (\ u@(ObjURI h lu) -> do + instanceID <- + lift $ runDB $ either entityKey id <$> insertBy' (Instance h) + result <- + ExceptT $ first (T.pack . displayException) <$> + fetchRemoteActor instanceID h lu + case result of + Left Nothing -> throwE "Recipient @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Recipient isn't an actor" + Right (Just actor) -> return (entityVal actor, u) + ) + recipient + + senderHash <- encodeKeyHashid personID + + let audResource = + case resourceDB of + Left (GrantResourceRepo r) -> + AudLocal [LocalActorRepo r] [LocalStageRepoFollowers r] + Left (GrantResourceDeck d) -> + AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d] + Left (GrantResourceLoom l) -> + AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l] + Right (remoteActor, ObjURI h lu) -> + AudRemote h + [lu] + (maybeToList $ remoteActorFollowers remoteActor) + audRecipient = + case recipientDB of + Left (GrantRecipPerson p) -> + AudLocal [] [LocalStagePersonFollowers p] + Right (remoteActor, ObjURI h lu) -> + AudRemote h + [lu] + (maybeToList $ remoteActorFollowers remoteActor) + audAuthor = + AudLocal [] [LocalStagePersonFollowers senderHash] + + audience = [audResource, audRecipient, audAuthor] + + return (Nothing, audience, activity) diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index cc8058b..a666838 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -849,6 +849,7 @@ instance YesodBreadcrumbs App where PublishOfferMergeR -> ("Open MR", Just HomeR) PublishMergeR -> ("Apply MR", Just HomeR) PublishInviteR -> ("Invite someone to a resource", Just HomeR) + PublishRemoveR -> ("Remove someone from a resource", Just HomeR) PersonR p -> ("Person ~" <> keyHashidText p, Just HomeR) PersonInboxR p -> ("Inbox", Just $ PersonR p) diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index c63dbde..edcdbcf 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -38,6 +38,9 @@ module Vervis.Handler.Client , getPublishInviteR , postPublishInviteR + + , getPublishRemoveR + , postPublishRemoveR ) where @@ -1200,3 +1203,44 @@ postPublishInviteR = do Right _ -> do setMessage "Invite activity sent" redirect HomeR + +removeForm = renderDivs $ (,,) + <$> areq fedUriField "(URI) Whom to remove" Nothing + <*> areq fedUriField "(URI) From which resource" Nothing + <*> areq capField "(URI) Grant activity to use for authorization" Nothing + +getPublishRemoveR :: Handler Html +getPublishRemoveR = do + ((_, widget), enctype) <- runFormPost removeForm + defaultLayout + [whamlet| +

Remove someone from a resource +
+ ^{widget} + + |] + +postPublishRemoveR :: Handler () +postPublishRemoveR = do + federation <- getsYesod $ appFederation . appSettings + unless federation badMethod + + (uRecipient, uResource, (uCap, cap)) <- + runFormPostRedirect PublishRemoveR removeForm + + (ep@(Entity pid _), a) <- getSender + senderHash <- encodeKeyHashid pid + + result <- runExceptT $ do + (maybeSummary, audience, rmv) <- remove pid uRecipient uResource + (localRecips, remoteRecips, fwdHosts, action) <- + makeServerInput (Just uCap) maybeSummary audience (AP.RemoveActivity rmv) + handleViaActor pid (Just cap) localRecips remoteRecips fwdHosts action + + case result of + Left err -> do + setMessage $ toHtml err + redirect PublishRemoveR + Right _ -> do + setMessage "Remove activity sent" + redirect HomeR diff --git a/templates/personal-overview.hamlet b/templates/personal-overview.hamlet index d74e094..72d7412 100644 --- a/templates/personal-overview.hamlet +++ b/templates/personal-overview.hamlet @@ -45,6 +45,9 @@ $# Comment on a ticket or merge request
  • Invite someone to a resource +
  • + + Remove someone from a resource

    Your teams diff --git a/th/routes b/th/routes index 7d8abd0..3361fff 100644 --- a/th/routes +++ b/th/routes @@ -133,6 +133,7 @@ /publish/offer-merge PublishOfferMergeR GET POST /publish/merge PublishMergeR GET POST /publish/invite PublishInviteR GET POST +/publish/remove PublishRemoveR GET POST ---- Person ------------------------------------------------------------------