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 @@ $# . Collaborator Role Since - $forall (person, since) <- collabs + $forall (person, ctID, since) <- collabs ^{personLinkFedW person} Admin #{showDate since} + ^{buttonW POST "Remove" (DeckRemoveR deckHash ctID)}

Invites diff --git a/th/routes b/th/routes index 3361fff..0091aab 100644 --- a/th/routes +++ b/th/routes @@ -220,6 +220,7 @@ /decks/#DeckKeyHashid/collabs DeckCollabsR GET /decks/#DeckKeyHashid/invite DeckInviteR GET POST +/decks/#DeckKeyHashid/remove/#CollabTopicDeckId DeckRemoveR POST ---- Ticket ------------------------------------------------------------------