UI: In deck collaborator list, have a Remove button for each

src/Vervis/Foundation.hs

@@ -931,6 +931,7 @@ instance YesodBreadcrumbs App where
         DeckCollabsR d -> ("Collaborators", Just $ DeckR d)
 
         DeckInviteR d  -> ("Invite", Just $ DeckR d)
+        DeckRemoveR _ _ -> ("", Nothing)
 
         TicketR d t            -> ("#" <> keyHashidText t, Just $ DeckTicketsR d)
         TicketDiscussionR d t  -> ("Discussion", Just $ TicketR d t)

src/Vervis/Handler/Deck.hs

@@ -39,6 +39,7 @@ module Vervis.Handler.Deck
     , getDeckCollabsR
     , getDeckInviteR
     , postDeckInviteR
+    , postDeckRemoveR
 
 
 
@@ -59,8 +60,10 @@ module Vervis.Handler.Deck
     )
 where
 
+import Control.Applicative
 import Control.Monad
 import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
 import Data.Aeson
 import Data.Bitraversable
 import Data.ByteString (ByteString)
@@ -71,6 +74,7 @@ import Data.Text (Text)
 import Data.Time.Clock
 import Data.Traversable
 import Database.Persist
+import Network.HTTP.Types.Method
 import Text.Blaze.Html (Html)
 import Yesod.Auth (requireAuth)
 import Yesod.Core
@@ -121,6 +125,7 @@ import Vervis.Ticket
 import Vervis.TicketFilter
 import Vervis.Time
 import Vervis.Web.Actor
+import Vervis.Widget
 import Vervis.Widget.Person
 import Vervis.Widget.Ticket
 import Vervis.Widget.Tracker
@@ -407,7 +412,8 @@ getDeckCollabsR deckHash = do
         collabs <- do
             grants <-
                 getTopicGrants CollabTopicDeckCollab CollabTopicDeckDeck deckID
-            traverse (bitraverse getPersonWidgetInfo pure) grants
+            for grants $ \ (actor, ct, time) ->
+                (,ct,time) <$> getPersonWidgetInfo actor
         invites <- do
             invites' <-
                 getTopicInvites CollabTopicDeckCollab CollabTopicDeckDeck deckID
@@ -452,7 +458,7 @@ postDeckInviteR deckHash = do
                 uResource = encodeRouteHome $ DeckR deckHash
             C.invite personID uRecipient uResource
         grantID <- do
-            maybeItem <- lift $ runDB $ getGrant CollabTopicDeckCollab CollabTopicDeckDeck deckID recipPersonID
+            maybeItem <- lift $ runDB $ getGrant CollabTopicDeckCollab CollabTopicDeckDeck deckID personID
             fromMaybeE maybeItem "You need to be a collaborator in the Deck to invite people"
         grantHash <- encodeKeyHashid grantID
         let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash
@@ -471,6 +477,54 @@ postDeckInviteR deckHash = do
             setMessage "Invite sent"
             redirect $ DeckCollabsR deckHash
 
+postDeckRemoveR :: KeyHashid Deck -> CollabTopicDeckId -> Handler Html
+postDeckRemoveR deckHash ctID = do
+    deckID <- decodeKeyHashid404 deckHash
+
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+    encodeRouteHome <- getEncodeRouteHome
+
+    result <- runExceptT $ do
+        mpidOrU <- lift $ runDB $ runMaybeT $ do
+            CollabTopicDeck collabID deckID' <- MaybeT $ get ctID
+            guard $ deckID' == deckID
+            _ <- MaybeT $ getBy $ UniqueCollabEnable collabID
+            member <-
+                Left <$> MaybeT (getValBy $ UniqueCollabRecipLocal collabID) <|>
+                Right <$> MaybeT (getValBy $ UniqueCollabRecipRemote collabID)
+            lift $
+                bitraverse
+                    (pure . collabRecipLocalPerson)
+                    (getRemoteActorURI <=< getJust . collabRecipRemoteActor)
+                    member
+        pidOrU <- maybe notFound pure mpidOrU
+        (maybeSummary, audience, remove) <- do
+            uRecipient <-
+                case pidOrU of
+                    Left pid -> encodeRouteHome . PersonR <$> encodeKeyHashid pid
+                    Right u -> pure u
+            let uResource = encodeRouteHome $ DeckR deckHash
+            C.remove personID uRecipient uResource
+        grantID <- do
+            maybeItem <- lift $ runDB $ getGrant CollabTopicDeckCollab CollabTopicDeckDeck deckID personID
+            fromMaybeE maybeItem "You need to be a collaborator in the Deck to remove people"
+        grantHash <- encodeKeyHashid grantID
+        let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash
+        (localRecips, remoteRecips, fwdHosts, action) <-
+            C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove
+        let cap =
+                Left (LocalActorDeck deckID, LocalActorDeck deckHash, grantID)
+        handleViaActor
+            personID (Just cap) localRecips remoteRecips fwdHosts action
+
+    case result of
+        Left e -> do
+            setMessage $ toHtml e
+        Right removeID -> do
+            setMessage "Remove sent"
+    redirect $ DeckCollabsR deckHash
+
 
 
 

src/Vervis/Persist/Collab.hs

@@ -97,7 +97,7 @@ getTopicGrants
     => EntityField topic CollabId
     -> EntityField topic (Key resource)
     -> Key resource
-    -> ReaderT SqlBackend m [(Either PersonId RemoteActorId, UTCTime)]
+    -> ReaderT SqlBackend m [(Either PersonId RemoteActorId, Key topic, UTCTime)]
 getTopicGrants topicCollabField topicActorField resourceID =
     fmap (map adapt) $
     E.select $ E.from $ \ (topic `E.InnerJoin` enable `E.InnerJoin` grant `E.LeftOuterJoin` recipL `E.LeftOuterJoin` recipR) -> do
@@ -110,15 +110,17 @@ getTopicGrants topicCollabField topicActorField resourceID =
         return
             ( recipL E.?. CollabRecipLocalPerson
             , recipR E.?. CollabRecipRemoteActor
+            , topic E.^. persistIdField
             , grant E.^. OutboxItemPublished
             )
     where
-    adapt (E.Value maybePersonID, E.Value maybeRemoteActorID, E.Value time) =
+    adapt (E.Value maybePersonID, E.Value maybeRemoteActorID, E.Value ctID, E.Value time) =
         ( case (maybePersonID, maybeRemoteActorID) of
             (Nothing, Nothing) -> error "No recip"
             (Just personID, Nothing) -> Left personID
             (Nothing, Just remoteActorID) -> Right remoteActorID
             (Just _, Just _) -> error "Multi recip"
+        , ctID
         , time
         )
 

templates/deck/collab/list.hamlet

@@ -21,11 +21,12 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
     <th>Collaborator
     <th>Role
     <th>Since
-  $forall (person, since) <- collabs
+  $forall (person, ctID, since) <- collabs
     <tr>
       <td>^{personLinkFedW person}
       <td>Admin
       <td>#{showDate since}
+      <td>^{buttonW POST "Remove" (DeckRemoveR deckHash ctID)}
 
 <h2>Invites
 

th/routes

@@ -220,6 +220,7 @@
 
 /decks/#DeckKeyHashid/collabs                     DeckCollabsR    GET
 /decks/#DeckKeyHashid/invite                      DeckInviteR     GET POST
+/decks/#DeckKeyHashid/remove/#CollabTopicDeckId   DeckRemoveR     POST
 
 ---- Ticket ------------------------------------------------------------------