diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index a666838..b3de164 100644
--- a/src/Vervis/Foundation.hs
+++ b/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)
diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs
index ad525b9..69fbdce 100644
--- a/src/Vervis/Handler/Deck.hs
+++ b/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
+
diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs
index 87c92c1..2165882 100644
--- a/src/Vervis/Persist/Collab.hs
+++ b/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
)
diff --git a/templates/deck/collab/list.hamlet b/templates/deck/collab/list.hamlet
index 9fda8bf..6c6ae0b 100644
--- a/templates/deck/collab/list.hamlet
+++ b/templates/deck/collab/list.hamlet
@@ -21,11 +21,12 @@ $#