UI for publishing a Remove

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)

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)

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|
+            <h1>Remove someone from a resource
+            <form method=POST action=@{PublishRemoveR} enctype=#{enctype}>
+              ^{widget}
+              <input type=submit>
+        |]
+
+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

templates/personal-overview.hamlet

@@ -45,6 +45,9 @@ $#       Comment on a ticket or merge request
   <li>
     <a href=@{PublishInviteR}>
       Invite someone to a resource
+  <li>
+    <a href=@{PublishRemoveR}>
+      Remove someone from a resource
 
 <h2>Your teams
 

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 ------------------------------------------------------------------