diff --git a/README.md b/README.md index e7a001d..ce14ca0 100644 --- a/README.md +++ b/README.md @@ -283,6 +283,7 @@ Haskell modules in `src`: - `Vervis.Data` - `Vervis.Persist` - `Vervis.Fetch` +- `Vervis.Serve` - `Vervis.Query` - `Vervis.Web` - Primary web app support modules: @@ -292,8 +293,7 @@ Haskell modules in `src`: - `Vervis.Model` - `Vervis.Migration` - Primary web app logic modules: - - `Vervis.API` - - `Vervis.Federation` + - `Vervis.Actor` - `Vervis.Handler` - `Vervis.Client` - `Vervis.Ssh` diff --git a/src/Vervis/Form/Tracker.hs b/src/Vervis/Form/Tracker.hs index d4466c9..2309bd7 100644 --- a/src/Vervis/Form/Tracker.hs +++ b/src/Vervis/Form/Tracker.hs @@ -30,6 +30,7 @@ module Vervis.Form.Tracker , projectInviteCompForm , GroupInvite (..) , groupInviteForm + , inviteForm --, NewProjectCollab (..) --, newProjectCollabForm --, editProjectForm @@ -217,6 +218,13 @@ groupInviteForm groupID = renderDivs $ GroupInvite l selectRole = selectField optionsEnum +inviteForm = renderDivs $ (,) + <$> areq fedUriField "Person*" Nothing + <*> areq selectRole "Role*" Nothing + where + selectRole :: Field Handler AP.Role + selectRole = selectField optionsEnum + {- editProjectAForm :: SharerId -> Entity Project -> AForm Handler Project editProjectAForm sid (Entity jid project) = Project diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index db4c49c..20d9142 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -960,8 +960,6 @@ instance YesodBreadcrumbs App where DeckNewR -> ("New Ticket Tracker", Just HomeR) DeckDeleteR _ -> ("", Nothing) DeckEditR d -> ("Edit", Just $ DeckR d) - DeckFollowR _ -> ("", Nothing) - DeckUnfollowR _ -> ("", Nothing) DeckStampR d k -> ("Stamp #" <> keyHashidText k, Just $ DeckR d) diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index 8fcf9d1..24bff28 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/src/Vervis/Handler/Deck.hs @@ -33,13 +33,10 @@ module Vervis.Handler.Deck , postDeckDeleteR , getDeckEditR , postDeckEditR - , postDeckFollowR - , postDeckUnfollowR , getDeckStampR , getDeckCollabsR - , getDeckInviteR , postDeckInviteR , postDeckRemoveR , getDeckProjectsR @@ -134,6 +131,7 @@ import Vervis.Paginate import Vervis.Persist.Actor import Vervis.Persist.Collab import Vervis.Recipient +import Vervis.Serve.Collab import Vervis.Settings import Vervis.Ticket import Vervis.TicketFilter @@ -419,175 +417,36 @@ postDeckEditR _ = do defaultLayout $(widgetFile "project/edit") -} -postDeckFollowR :: KeyHashid Deck -> Handler () -postDeckFollowR _ = error "Temporarily disabled" - -postDeckUnfollowR :: KeyHashid Deck -> Handler () -postDeckUnfollowR _ = error "Temporarily disabled" - getDeckStampR :: KeyHashid Deck -> KeyHashid SigKey -> Handler TypedContent getDeckStampR = servePerActorKey deckActor LocalActorDeck getDeckCollabsR :: KeyHashid Deck -> Handler TypedContent getDeckCollabsR deckHash = do deckID <- decodeKeyHashid404 deckHash - collabs <- runDB $ do + (deck, actor) <- runDB $ do deck <- get404 deckID - grants <- getTopicGrants $ deckResource deck - for grants $ \ (role, actor, _ct, time) -> - (role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor - h <- asksSite siteInstanceHost - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - hashPerson <- getEncodeKeyHashid - let makeItem (role, time, i) = AP.Relationship - { AP.relationshipId = Nothing - , AP.relationshipExtraTypes = [] - , AP.relationshipSubject = encodeRouteHome $ DeckR deckHash - , AP.relationshipProperty = Left AP.RelHasCollab - , AP.relationshipObject = - case i of - Left personID -> encodeRouteHome $ PersonR $ hashPerson personID - Right u -> u - , AP.relationshipAttributedTo = encodeRouteLocal $ DeckR deckHash - , AP.relationshipPublished = Just time - , AP.relationshipUpdated = Nothing - , AP.relationshipInstrument = Just role - } - collabsAP = AP.Collection - { AP.collectionId = encodeRouteLocal $ DeckCollabsR deckHash - , AP.collectionType = CollectionTypeUnordered - , AP.collectionTotalItems = Just $ length collabs - , AP.collectionCurrent = Nothing - , AP.collectionFirst = Nothing - , AP.collectionLast = Nothing - , AP.collectionItems = map (Doc h . makeItem) collabs - , AP.collectionContext = - Just $ encodeRouteLocal $ DeckR deckHash - } - provideHtmlAndAP collabsAP $ getHtml deckID - where - getHtml deckID = do - (deck, actor, collabs, invites, joins) <- handlerToWidget $ runDB $ do - deck <- get404 deckID - actor <- getJust $ deckActor deck - collabs <- do - grants <- getTopicGrants $ deckResource deck - for grants $ \ (role, actor, ct, time) -> - (,role,ct,time) <$> getPersonWidgetInfo actor - invites <- do - invites' <- getTopicInvites $ deckResource deck - for invites' $ \ (inviter, recip, time, role) -> (,,,) - <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter) - <*> getPersonWidgetInfo recip - <*> pure time - <*> pure role - joins <- do - joins' <- getTopicJoins $ deckResource deck - for joins' $ \ (recip, time, role) -> - (,time,role) <$> getPersonWidgetInfo recip - return (deck, actor, collabs, invites, joins) - $(widgetFile "deck/collab/list") - where - grabPerson actorID = do - actorByKey <- getLocalActor actorID - case actorByKey of - LocalActorPerson personID -> return personID - _ -> error "Surprise, local inviter actor isn't a Person" - -getDeckInviteR :: KeyHashid Deck -> Handler Html -getDeckInviteR deckHash = do - deckID <- decodeKeyHashid404 deckHash - ((_result, widget), enctype) <- runFormPost $ deckInviteForm deckID - defaultLayout $(widgetFile "deck/collab/new") + actor <- getJust $ deckActor deck + return (deck, actor) + serveCollabs + AP.RelHasCollab + (deckResource deck) + (DeckR deckHash) + (DeckCollabsR deckHash) + (DeckRemoveR deckHash) + (DeckInviteR deckHash) + (deckNavW (Entity deckID deck) actor) postDeckInviteR :: KeyHashid Deck -> Handler Html postDeckInviteR deckHash = do deckID <- decodeKeyHashid404 deckHash - DeckInvite recipPersonID role <- - runFormPostRedirect (DeckInviteR deckHash) $ deckInviteForm deckID - - personEntity@(Entity personID person) <- requireAuth - personHash <- encodeKeyHashid personID - recipPersonHash <- encodeKeyHashid recipPersonID - encodeRouteHome <- getEncodeRouteHome - - result <- runExceptT $ do - (maybeSummary, audience, invite) <- do - let uRecipient = encodeRouteHome $ PersonR recipPersonHash - uResourceCollabs = encodeRouteHome $ DeckCollabsR deckHash - C.invite personID uRecipient uResourceCollabs role - grantID <- do - maybeItem <- lift $ runDB $ do - resourceID <- deckResource <$> get404 deckID - getGrant resourceID personID - fromMaybeE maybeItem "You need to be a collaborator in the Deck to invite people" - grantHash <- encodeKeyHashid grantID - let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash - (localRecips, remoteRecips, fwdHosts, action) <- - C.makeServerInput (Just uCap) maybeSummary audience $ AP.InviteActivity invite - 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 - redirect $ DeckInviteR deckHash - Right inviteID -> do - setMessage "Invite sent" - redirect $ DeckCollabsR deckHash + resourceID <- runDB $ deckResource <$> get404 deckID + serveInviteCollab resourceID (DeckCollabsR deckHash) postDeckRemoveR :: KeyHashid Deck -> CollabId -> Handler Html postDeckRemoveR deckHash collabID = do deckID <- decodeKeyHashid404 deckHash - - personEntity@(Entity personID person) <- requireAuth - personHash <- encodeKeyHashid personID - encodeRouteHome <- getEncodeRouteHome - - result <- runExceptT $ do - mpidOrU <- lift $ runDB $ runMaybeT $ do - Collab _ resourceID <- MaybeT $ get collabID - d <- MaybeT $ get deckID - guard $ resourceID == deckResource d - _ <- MaybeT $ getBy $ UniqueCollabEnable collabID - member <- - Left <$> MaybeT (getValBy $ UniqueCollabRecipLocal collabID) <|> - Right <$> MaybeT (getValBy $ UniqueCollabRecipRemote collabID) - lift $ - (resourceID,) <$> - bitraverse - (pure . collabRecipLocalPerson) - (getRemoteActorURI <=< getJust . collabRecipRemoteActor) - member - (resourceID, pidOrU) <- maybe notFound pure mpidOrU - (maybeSummary, audience, remove) <- do - uRecipient <- - case pidOrU of - Left pid -> encodeRouteHome . PersonR <$> encodeKeyHashid pid - Right u -> pure u - let uResourceCollabs = encodeRouteHome $ DeckCollabsR deckHash - C.remove personID uRecipient uResourceCollabs - grantID <- do - maybeItem <- lift $ runDB $ getGrant resourceID 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 + resourceID <- runDB $ deckResource <$> get404 deckID + serveRemoveCollab resourceID (DeckCollabsR deckHash) collabID getDeckProjectsR :: KeyHashid Deck -> Handler Html getDeckProjectsR deckHash = do diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs index 759d5fc..da45b80 100644 --- a/src/Vervis/Handler/Group.hs +++ b/src/Vervis/Handler/Group.hs @@ -30,7 +30,6 @@ module Vervis.Handler.Group , getGroupStampR , getGroupMembersR - , getGroupInviteR , postGroupInviteR , postGroupRemoveR @@ -127,6 +126,7 @@ import Vervis.Paginate import Vervis.Persist.Actor import Vervis.Persist.Collab import Vervis.Recipient +import Vervis.Serve.Collab import Vervis.Settings import Vervis.Ticket import Vervis.TicketFilter @@ -251,163 +251,30 @@ getGroupStampR = servePerActorKey groupActor LocalActorGroup getGroupMembersR :: KeyHashid Group -> Handler TypedContent getGroupMembersR groupHash = do groupID <- decodeKeyHashid404 groupHash - members <- runDB $ do + (group, actor) <- runDB $ do group <- get404 groupID - grants <- getTopicGrants $ groupResource group - for grants $ \ (role, actor, _ct, time) -> - (role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor - h <- asksSite siteInstanceHost - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - hashPerson <- getEncodeKeyHashid - let makeItem (role, time, i) = AP.Relationship - { AP.relationshipId = Nothing - , AP.relationshipExtraTypes = [] - , AP.relationshipSubject = encodeRouteHome $ GroupR groupHash - , AP.relationshipProperty = Left AP.RelHasMember - , AP.relationshipObject = - case i of - Left personID -> encodeRouteHome $ PersonR $ hashPerson personID - Right u -> u - , AP.relationshipAttributedTo = encodeRouteLocal $ GroupR groupHash - , AP.relationshipPublished = Just time - , AP.relationshipUpdated = Nothing - , AP.relationshipInstrument = Just role - } - membersAP = AP.Collection - { AP.collectionId = encodeRouteLocal $ GroupMembersR groupHash - , AP.collectionType = CollectionTypeUnordered - , AP.collectionTotalItems = Just $ length members - , AP.collectionCurrent = Nothing - , AP.collectionFirst = Nothing - , AP.collectionLast = Nothing - , AP.collectionItems = map (Doc h . makeItem) members - , AP.collectionContext = - Just $ encodeRouteLocal $ GroupR groupHash - } - provideHtmlAndAP membersAP $ getHtml groupID - where - getHtml groupID = do - (group, actor, members, invites, joins) <- handlerToWidget $ runDB $ do - group <- get404 groupID - actor <- getJust $ groupActor group - members <- do - grants <- getTopicGrants $ groupResource group - for grants $ \ (role, actor, ct, time) -> - (,role,ct,time) <$> getPersonWidgetInfo actor - invites <- do - invites' <- getTopicInvites $ groupResource group - for invites' $ \ (inviter, recip, time, role) -> (,,,) - <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter) - <*> getPersonWidgetInfo recip - <*> pure time - <*> pure role - joins <- do - joins' <- getTopicJoins $ groupResource group - for joins' $ \ (recip, time, role) -> - (,time,role) <$> getPersonWidgetInfo recip - return (group, actor, members, invites, joins) - $(widgetFile "group/members") - where - grabPerson actorID = do - actorByKey <- getLocalActor actorID - case actorByKey of - LocalActorPerson personID -> return personID - _ -> error "Surprise, local inviter actor isn't a Person" - -getGroupInviteR :: KeyHashid Group -> Handler Html -getGroupInviteR groupHash = do - groupID <- decodeKeyHashid404 groupHash - ((_result, widget), enctype) <- runFormPost $ groupInviteForm groupID - defaultLayout $(widgetFile "group/member/new") + actor <- getJust $ groupActor group + return (group, actor) + serveCollabs + AP.RelHasMember + (groupResource group) + (GroupR groupHash) + (GroupMembersR groupHash) + (GroupRemoveR groupHash) + (GroupInviteR groupHash) + (groupNavW (Entity groupID group) actor) postGroupInviteR :: KeyHashid Group -> Handler Html postGroupInviteR groupHash = do groupID <- decodeKeyHashid404 groupHash - GroupInvite recipPersonID role <- - runFormPostRedirect (GroupInviteR groupHash) $ groupInviteForm groupID - - personEntity@(Entity personID person) <- requireAuth - personHash <- encodeKeyHashid personID - recipPersonHash <- encodeKeyHashid recipPersonID - encodeRouteHome <- getEncodeRouteHome - - result <- runExceptT $ do - (maybeSummary, audience, invite) <- do - let uRecipient = encodeRouteHome $ PersonR recipPersonHash - uResourceCollabs = encodeRouteHome $ GroupMembersR groupHash - C.invite personID uRecipient uResourceCollabs role - grantID <- do - maybeItem <- lift $ runDB $ do - resourceID <- groupResource <$> get404 groupID - getGrant resourceID personID - fromMaybeE maybeItem "You need to be a collaborator in the Group to invite people" - grantHash <- encodeKeyHashid grantID - let uCap = encodeRouteHome $ GroupOutboxItemR groupHash grantHash - (localRecips, remoteRecips, fwdHosts, action) <- - C.makeServerInput (Just uCap) maybeSummary audience $ AP.InviteActivity invite - let cap = - Left (LocalActorGroup groupID, LocalActorGroup groupHash, grantID) - handleViaActor - personID (Just cap) localRecips remoteRecips fwdHosts action - - case result of - Left e -> do - setMessage $ toHtml e - redirect $ GroupInviteR groupHash - Right inviteID -> do - setMessage "Invite sent" - redirect $ GroupMembersR groupHash + resourceID <- runDB $ groupResource <$> get404 groupID + serveInviteCollab resourceID (GroupMembersR groupHash) postGroupRemoveR :: KeyHashid Group -> CollabId -> Handler Html postGroupRemoveR groupHash collabID = do groupID <- decodeKeyHashid404 groupHash - - personEntity@(Entity personID person) <- requireAuth - personHash <- encodeKeyHashid personID - encodeRouteHome <- getEncodeRouteHome - - result <- runExceptT $ do - mpidOrU <- lift $ runDB $ runMaybeT $ do - Collab _ resourceID <- MaybeT $ get collabID - g <- MaybeT $ get groupID - guard $ resourceID == groupResource g - _ <- MaybeT $ getBy $ UniqueCollabEnable collabID - member <- - Left <$> MaybeT (getValBy $ UniqueCollabRecipLocal collabID) <|> - Right <$> MaybeT (getValBy $ UniqueCollabRecipRemote collabID) - lift $ - (resourceID,) <$> - bitraverse - (pure . collabRecipLocalPerson) - (getRemoteActorURI <=< getJust . collabRecipRemoteActor) - member - (resourceID, pidOrU) <- maybe notFound pure mpidOrU - (maybeSummary, audience, remove) <- do - uRecipient <- - case pidOrU of - Left pid -> encodeRouteHome . PersonR <$> encodeKeyHashid pid - Right u -> pure u - let uResourceCollabs = encodeRouteHome $ GroupMembersR groupHash - C.remove personID uRecipient uResourceCollabs - grantID <- do - maybeItem <- lift $ runDB $ getGrant resourceID personID - fromMaybeE maybeItem "You need to be a collaborator in the Group to remove people" - grantHash <- encodeKeyHashid grantID - let uCap = encodeRouteHome $ GroupOutboxItemR groupHash grantHash - (localRecips, remoteRecips, fwdHosts, action) <- - C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove - let cap = - Left (LocalActorGroup groupID, LocalActorGroup groupHash, grantID) - handleViaActor - personID (Just cap) localRecips remoteRecips fwdHosts action - - case result of - Left e -> do - setMessage $ toHtml e - Right removeID -> - setMessage "Remove sent" - redirect $ GroupMembersR groupHash + resourceID <- runDB $ groupResource <$> get404 groupID + serveRemoveCollab resourceID (GroupMembersR groupHash) collabID getGroupChildrenR :: KeyHashid Group -> Handler TypedContent getGroupChildrenR groupHash = do diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs index 5ea6a66..24c964a 100644 --- a/src/Vervis/Handler/Loom.hs +++ b/src/Vervis/Handler/Loom.hs @@ -102,6 +102,7 @@ import Vervis.Paginate import Vervis.Persist.Actor import Vervis.Persist.Collab import Vervis.Recipient +import Vervis.Serve.Collab import Vervis.Settings import Vervis.Ticket import Vervis.TicketFilter @@ -375,7 +376,7 @@ getLoomStampR :: KeyHashid Loom -> KeyHashid SigKey -> Handler TypedContent getLoomStampR = servePerActorKey loomActor LocalActorLoom getLoomCollabsR :: KeyHashid Loom -> Handler TypedContent -getLoomCollabsR loomHash = error "TODO getLoomCollabsR" +getLoomCollabsR loomHash = error "TODO" getLoomProjectsR :: KeyHashid Loom -> Handler Html getLoomProjectsR loomHash = do diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 36c07cd..9def7e7 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -31,7 +31,6 @@ module Vervis.Handler.Project , getProjectStampR , getProjectCollabsR - , getProjectInviteR , postProjectInviteR , postProjectRemoveR @@ -124,6 +123,7 @@ import Vervis.Paginate import Vervis.Persist.Actor import Vervis.Persist.Collab import Vervis.Recipient +import Vervis.Serve.Collab import Vervis.Settings import Vervis.Ticket import Vervis.TicketFilter @@ -251,163 +251,30 @@ getProjectStampR = servePerActorKey projectActor LocalActorProject getProjectCollabsR :: KeyHashid Project -> Handler TypedContent getProjectCollabsR projectHash = do projectID <- decodeKeyHashid404 projectHash - collabs <- runDB $ do + (project, actor) <- runDB $ do project <- get404 projectID - grants <- getTopicGrants $ projectResource project - for grants $ \ (role, actor, _ct, time) -> - (role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor - h <- asksSite siteInstanceHost - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - hashPerson <- getEncodeKeyHashid - let makeItem (role, time, i) = AP.Relationship - { AP.relationshipId = Nothing - , AP.relationshipExtraTypes = [] - , AP.relationshipSubject = encodeRouteHome $ ProjectR projectHash - , AP.relationshipProperty = Left AP.RelHasCollab - , AP.relationshipObject = - case i of - Left personID -> encodeRouteHome $ PersonR $ hashPerson personID - Right u -> u - , AP.relationshipAttributedTo = encodeRouteLocal $ ProjectR projectHash - , AP.relationshipPublished = Just time - , AP.relationshipUpdated = Nothing - , AP.relationshipInstrument = Just role - } - collabsAP = AP.Collection - { AP.collectionId = encodeRouteLocal $ ProjectCollabsR projectHash - , AP.collectionType = CollectionTypeUnordered - , AP.collectionTotalItems = Just $ length collabs - , AP.collectionCurrent = Nothing - , AP.collectionFirst = Nothing - , AP.collectionLast = Nothing - , AP.collectionItems = map (Doc h . makeItem) collabs - , AP.collectionContext = - Just $ encodeRouteLocal $ ProjectR projectHash - } - provideHtmlAndAP collabsAP $ getHtml projectID - where - getHtml projectID = do - (project, actor, collabs, invites, joins) <- handlerToWidget $ runDB $ do - project <- get404 projectID - actor <- getJust $ projectActor project - collabs <- do - grants <- getTopicGrants $ projectResource project - for grants $ \ (role, actor, ct, time) -> - (,role,ct,time) <$> getPersonWidgetInfo actor - invites <- do - invites' <- getTopicInvites $ projectResource project - for invites' $ \ (inviter, recip, time, role) -> (,,,) - <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter) - <*> getPersonWidgetInfo recip - <*> pure time - <*> pure role - joins <- do - joins' <- getTopicJoins $ projectResource project - for joins' $ \ (recip, time, role) -> - (,time,role) <$> getPersonWidgetInfo recip - return (project, actor, collabs, invites, joins) - $(widgetFile "project/collab/list") - where - grabPerson actorID = do - actorByKey <- getLocalActor actorID - case actorByKey of - LocalActorPerson personID -> return personID - _ -> error "Surprise, local inviter actor isn't a Person" - -getProjectInviteR :: KeyHashid Project -> Handler Html -getProjectInviteR projectHash = do - projectID <- decodeKeyHashid404 projectHash - ((_result, widget), enctype) <- runFormPost $ projectInviteForm projectID - defaultLayout $(widgetFile "project/collab/new") + actor <- getJust $ projectActor project + return (project, actor) + serveCollabs + AP.RelHasCollab + (projectResource project) + (ProjectR projectHash) + (ProjectCollabsR projectHash) + (ProjectRemoveR projectHash) + (ProjectInviteR projectHash) + (projectNavW (Entity projectID project) actor) postProjectInviteR :: KeyHashid Project -> Handler Html postProjectInviteR projectHash = do projectID <- decodeKeyHashid404 projectHash - ProjectInvite recipPersonID role <- - runFormPostRedirect (ProjectInviteR projectHash) $ projectInviteForm projectID - - personEntity@(Entity personID person) <- requireAuth - personHash <- encodeKeyHashid personID - recipPersonHash <- encodeKeyHashid recipPersonID - encodeRouteHome <- getEncodeRouteHome - - result <- runExceptT $ do - (maybeSummary, audience, invite) <- do - let uRecipient = encodeRouteHome $ PersonR recipPersonHash - uResourceCollabs = encodeRouteHome $ ProjectCollabsR projectHash - C.invite personID uRecipient uResourceCollabs role - grantID <- do - maybeItem <- lift $ runDB $ do - resourceID <- projectResource <$> get404 projectID - getGrant resourceID personID - fromMaybeE maybeItem "You need to be a collaborator in the Project to invite people" - grantHash <- encodeKeyHashid grantID - let uCap = encodeRouteHome $ ProjectOutboxItemR projectHash grantHash - (localRecips, remoteRecips, fwdHosts, action) <- - C.makeServerInput (Just uCap) maybeSummary audience $ AP.InviteActivity invite - let cap = - Left (LocalActorProject projectID, LocalActorProject projectHash, grantID) - handleViaActor - personID (Just cap) localRecips remoteRecips fwdHosts action - - case result of - Left e -> do - setMessage $ toHtml e - redirect $ ProjectInviteR projectHash - Right inviteID -> do - setMessage "Invite sent" - redirect $ ProjectCollabsR projectHash + resourceID <- runDB $ projectResource <$> get404 projectID + serveInviteCollab resourceID (ProjectCollabsR projectHash) postProjectRemoveR :: KeyHashid Project -> CollabId -> Handler Html postProjectRemoveR projectHash collabID = do projectID <- decodeKeyHashid404 projectHash - - personEntity@(Entity personID person) <- requireAuth - personHash <- encodeKeyHashid personID - encodeRouteHome <- getEncodeRouteHome - - result <- runExceptT $ do - mpidOrU <- lift $ runDB $ runMaybeT $ do - Collab _ resourceID <- MaybeT $ get collabID - j <- MaybeT $ get projectID - guard $ resourceID == projectResource j - _ <- MaybeT $ getBy $ UniqueCollabEnable collabID - member <- - Left <$> MaybeT (getValBy $ UniqueCollabRecipLocal collabID) <|> - Right <$> MaybeT (getValBy $ UniqueCollabRecipRemote collabID) - lift $ - (resourceID,) <$> - bitraverse - (pure . collabRecipLocalPerson) - (getRemoteActorURI <=< getJust . collabRecipRemoteActor) - member - (resourceID, pidOrU) <- maybe notFound pure mpidOrU - (maybeSummary, audience, remove) <- do - uRecipient <- - case pidOrU of - Left pid -> encodeRouteHome . PersonR <$> encodeKeyHashid pid - Right u -> pure u - let uResourceCollabs = encodeRouteHome $ ProjectCollabsR projectHash - C.remove personID uRecipient uResourceCollabs - grantID <- do - maybeItem <- lift $ runDB $ getGrant resourceID personID - fromMaybeE maybeItem "You need to be a collaborator in the Project to remove people" - grantHash <- encodeKeyHashid grantID - let uCap = encodeRouteHome $ ProjectOutboxItemR projectHash grantHash - (localRecips, remoteRecips, fwdHosts, action) <- - C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove - let cap = - Left (LocalActorProject projectID, LocalActorProject projectHash, grantID) - handleViaActor - personID (Just cap) localRecips remoteRecips fwdHosts action - - case result of - Left e -> do - setMessage $ toHtml e - Right removeID -> - setMessage "Remove sent" - redirect $ ProjectCollabsR projectHash + resourceID <- runDB $ projectResource <$> get404 projectID + serveRemoveCollab resourceID (ProjectCollabsR projectHash) collabID getProjectComponentsR :: KeyHashid Project -> Handler TypedContent getProjectComponentsR projectHash = do diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 6469537..d6a9b9b 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -189,6 +189,7 @@ import Vervis.Persist.Actor import Vervis.Persist.Collab import Vervis.Readme import Vervis.Recipient +import Vervis.Serve.Collab import Vervis.Settings import Vervis.SourceTree import Vervis.Style diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index a2a2838..8087911 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -23,9 +23,9 @@ module Vervis.Persist.Collab , getStemAdd , getGrantRecip , getComponentE - , getTopicGrants - , getTopicInvites - , getTopicJoins + , getCollabs + , getCollabInvites + , getCollabJoins , verifyCapability , verifyCapability' @@ -207,145 +207,270 @@ getComponentE (ComponentRepo k) e = ComponentRepo <$> getEntityE k e getComponentE (ComponentDeck k) e = ComponentDeck <$> getEntityE k e getComponentE (ComponentLoom k) e = ComponentLoom <$> getEntityE k e -getTopicGrants +getCollabs :: MonadIO m => ResourceId - -> ReaderT SqlBackend m [(AP.Role, Either PersonId RemoteActorId, CollabId, UTCTime)] -getTopicGrants resourceID = - fmap (reverse . sortOn (view _1) . map adapt) $ - E.select $ E.from $ \ (collab `E.InnerJoin` enable `E.InnerJoin` grant `E.LeftOuterJoin` recipL `E.LeftOuterJoin` recipR) -> do - E.on $ E.just (enable E.^. CollabEnableCollab) E.==. recipR E.?. CollabRecipRemoteCollab - E.on $ E.just (enable E.^. CollabEnableCollab) E.==. recipL E.?. CollabRecipLocalCollab - E.on $ enable E.^. CollabEnableGrant E.==. grant E.^. OutboxItemId - E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab - E.where_ $ collab E.^. CollabTopic E.==. E.val resourceID - E.orderBy [E.desc $ enable E.^. CollabEnableId] - return - ( collab E.^. CollabRole - , recipL E.?. CollabRecipLocalPerson - , recipR E.?. CollabRecipRemoteActor - , collab E.^. CollabId - , grant E.^. OutboxItemPublished - ) - where - adapt (E.Value role, E.Value maybePersonID, E.Value maybeRemoteActorID, E.Value ctID, E.Value time) = - ( role - , 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 + -> ReaderT SqlBackend m + [ ( AP.Role + , UTCTime + , Either (Entity Person, Actor) (Instance, RemoteObject, RemoteActor) + , CollabId + ) + ] +getCollabs resourceID = + fmap (sortOn $ view _2) $ liftA2 (++) + (map (\ (E.Value role, E.Value time, person, Entity _ actor, E.Value collabID) -> + (role, time, Left (person, actor), collabID) + ) + <$> getLocals ) + (map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra, E.Value collabID) -> + (role, time, Right (i, ro, ra), collabID) + ) + <$> getRemotes + ) + where + getLocals = + E.select $ E.from $ \ (collab `E.InnerJoin` enable `E.InnerJoin` grant `E.InnerJoin` recip `E.InnerJoin` person `E.InnerJoin` actor) -> do + E.on $ person E.^. PersonActor E.==. actor E.^. ActorId + E.on $ recip E.^. CollabRecipLocalPerson E.==. person E.^. PersonId + E.on $ collab E.^. CollabId E.==. recip E.^. CollabRecipLocalCollab + E.on $ enable E.^. CollabEnableGrant E.==. grant E.^. OutboxItemId + E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab + E.where_ $ collab E.^. CollabTopic E.==. E.val resourceID + E.orderBy [E.desc $ enable E.^. CollabEnableId] + return + ( collab E.^. CollabRole + , grant E.^. OutboxItemPublished + , person + , actor + , collab E.^. CollabId + ) + getRemotes = + E.select $ E.from $ \ (collab `E.InnerJoin` enable `E.InnerJoin` grant `E.InnerJoin` recip `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do + E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId + E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId + E.on $ recip E.^. CollabRecipRemoteActor E.==. ra E.^. RemoteActorId + E.on $ collab E.^. CollabId E.==. recip E.^. CollabRecipRemoteCollab + E.on $ enable E.^. CollabEnableGrant E.==. grant E.^. OutboxItemId + E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab + E.where_ $ collab E.^. CollabTopic E.==. E.val resourceID + E.orderBy [E.desc $ enable E.^. CollabEnableId] + return + ( collab E.^. CollabRole + , grant E.^. OutboxItemPublished + , i + , ro + , ra + , collab E.^. CollabId + ) -getTopicInvites +getCollabInvites :: MonadIO m => ResourceId - -> ReaderT SqlBackend m [(Either ActorId RemoteActorId, Either PersonId RemoteActorId, UTCTime, AP.Role)] -getTopicInvites resourceID = - fmap (map adapt) $ - E.select $ E.from $ - \ (collab `E.LeftOuterJoin` enable `E.InnerJoin` fulfills - `E.LeftOuterJoin` recipL `E.LeftOuterJoin` recipR - `E.LeftOuterJoin` (inviterL `E.InnerJoin` item `E.InnerJoin` actor) - `E.LeftOuterJoin` (inviterR `E.InnerJoin` activity) - ) -> do - E.on $ inviterR E.?. CollabInviterRemoteInvite E.==. activity E.?. RemoteActivityId - E.on $ E.just (fulfills E.^. CollabFulfillsInviteId) E.==. inviterR E.?. CollabInviterRemoteCollab - E.on $ item E.?. OutboxItemOutbox E.==. actor E.?. ActorOutbox - E.on $ inviterL E.?. CollabInviterLocalInvite E.==. item E.?. OutboxItemId - E.on $ E.just (fulfills E.^. CollabFulfillsInviteId) E.==. inviterL E.?. CollabInviterLocalCollab - E.on $ E.just (fulfills E.^. CollabFulfillsInviteCollab) E.==. recipR E.?. CollabRecipRemoteCollab - E.on $ E.just (fulfills E.^. CollabFulfillsInviteCollab) E.==. recipL E.?. CollabRecipLocalCollab - E.on $ collab E.^. CollabId E.==. fulfills E.^. CollabFulfillsInviteCollab - E.on $ E.just (collab E.^. CollabId) E.==. enable E.?. CollabEnableCollab - E.where_ $ - collab E.^. CollabTopic E.==. E.val resourceID E.&&. - E.isNothing (enable E.?. CollabEnableId) - E.orderBy [E.asc $ fulfills E.^. CollabFulfillsInviteId] - return - ( actor E.?. ActorId - , item E.?. OutboxItemPublished - , inviterR E.?. CollabInviterRemoteActor - , activity E.?. RemoteActivityReceived - , recipL E.?. CollabRecipLocalPerson - , recipR E.?. CollabRecipRemoteActor - , collab E.^. CollabRole - ) + -> ReaderT SqlBackend m + [ ( AP.Role + , UTCTime + , Either (Entity Person, Actor) (Instance, RemoteObject, RemoteActor) + , Either (Entity Person, Actor) (Instance, RemoteObject, RemoteActor) + , CollabId + ) + ] +getCollabInvites resourceID = sortOn (view _2) . concat <$> sequence + [ map + (\ (E.Value role, E.Value time, mperson_I, Entity _ actor_I, person, Entity _ actor, E.Value collabID) -> + let person_I = fromMaybe (error "getCollabInvites LL local inviter isn't a Person") mperson_I + in (role, time, Left (person_I, actor_I), Left (person, actor), collabID) + ) + <$> getLL + , map + (\ (E.Value role, E.Value time, Entity _ iI, Entity _ roI, Entity _ raI, person, Entity _ actor, E.Value collabID) -> + (role, time, Right (iI, roI, raI), Left (person, actor), collabID) + ) + <$> getLR + , map + (\ (E.Value role, E.Value time, mperson_I, Entity _ actor_I, Entity _ i, Entity _ ro, Entity _ ra, E.Value collabID) -> + let person_I = fromMaybe (error "getCollabInvites RL local inviter isn't a Person") mperson_I + in (role, time, Left (person_I, actor_I), Right (i, ro, ra), collabID) + ) + <$> getRL + , map + (\ (E.Value role, E.Value time, Entity _ iI, Entity _ roI, Entity _ raI, Entity _ i, Entity _ ro, Entity _ ra, E.Value collabID) -> + (role, time, Right (iI, roI, raI), Right (i, ro, ra), collabID) + ) + <$> getRR + ] where - adapt (E.Value inviterL, E.Value timeL, E.Value inviterR, E.Value timeR, E.Value recipL, E.Value recipR, E.Value role) = - let l = case (inviterL, timeL) of - (Nothing, Nothing) -> Nothing - (Just i, Just t) -> Just (i, t) - _ -> error "Impossible" - r = case (inviterR, timeR) of - (Nothing, Nothing) -> Nothing - (Just i, Just t) -> Just (i, t) - _ -> error "Impossible" - (inviter, time) = - case (l, r) of - (Nothing, Nothing) -> error "No inviter" - (Just (actorID, time), Nothing) -> - (Left actorID, time) - (Nothing, Just (remoteActorID, time)) -> - (Right remoteActorID, time) - (Just _, Just _) -> error "Multi inviter" - in ( inviter - , case (recipL, recipR) of - (Nothing, Nothing) -> error "No recip" - (Just personID, Nothing) -> Left personID - (Nothing, Just remoteActorID) -> Right remoteActorID - (Just _, Just _) -> error "Multi recip" - , time - , role - ) + getLL = + E.select $ E.from $ \ (collab `E.LeftOuterJoin` enable `E.InnerJoin` fulfills `E.InnerJoin` recip `E.InnerJoin` personR `E.InnerJoin` actorR `E.InnerJoin` inviter `E.InnerJoin` item `E.InnerJoin` actorI `E.LeftOuterJoin` personI) -> do + E.on $ E.just (actorI E.^. ActorId) E.==. personI E.?. PersonActor + E.on $ item E.^. OutboxItemOutbox E.==. actorI E.^. ActorOutbox + E.on $ inviter E.^. CollabInviterLocalInvite E.==. item E.^. OutboxItemId + E.on $ fulfills E.^. CollabFulfillsInviteId E.==. inviter E.^. CollabInviterLocalCollab + E.on $ personR E.^. PersonActor E.==. actorR E.^. ActorId + E.on $ recip E.^. CollabRecipLocalPerson E.==. personR E.^. PersonId + E.on $ collab E.^. CollabId E.==. recip E.^. CollabRecipLocalCollab + E.on $ collab E.^. CollabId E.==. fulfills E.^. CollabFulfillsInviteCollab + E.on $ E.just (collab E.^. CollabId) E.==. enable E.?. CollabEnableCollab + E.where_ $ + collab E.^. CollabTopic E.==. E.val resourceID E.&&. + E.isNothing (enable E.?. CollabEnableId) + E.orderBy [E.desc $ collab E.^. CollabId] + return + ( collab E.^. CollabRole + , item E.^. OutboxItemPublished + , personI + , actorI + , personR + , actorR + , collab E.^. CollabId + ) + getLR = + E.select $ E.from $ \ (collab `E.LeftOuterJoin` enable `E.InnerJoin` fulfills `E.InnerJoin` recip `E.InnerJoin` personR `E.InnerJoin` actorR `E.InnerJoin` inviter `E.InnerJoin` activity `E.InnerJoin` raI `E.InnerJoin` roI `E.InnerJoin` iI) -> do + E.on $ roI E.^. RemoteObjectInstance E.==. iI E.^. InstanceId + E.on $ raI E.^. RemoteActorIdent E.==. roI E.^. RemoteObjectId + E.on $ inviter E.^. CollabInviterRemoteActor E.==. raI E.^. RemoteActorId + E.on $ inviter E.^. CollabInviterRemoteInvite E.==. activity E.^. RemoteActivityId + E.on $ fulfills E.^. CollabFulfillsInviteId E.==. inviter E.^. CollabInviterRemoteCollab + E.on $ personR E.^. PersonActor E.==. actorR E.^. ActorId + E.on $ recip E.^. CollabRecipLocalPerson E.==. personR E.^. PersonId + E.on $ collab E.^. CollabId E.==. recip E.^. CollabRecipLocalCollab + E.on $ collab E.^. CollabId E.==. fulfills E.^. CollabFulfillsInviteCollab + E.on $ E.just (collab E.^. CollabId) E.==. enable E.?. CollabEnableCollab + E.where_ $ + collab E.^. CollabTopic E.==. E.val resourceID E.&&. + E.isNothing (enable E.?. CollabEnableId) + E.orderBy [E.desc $ collab E.^. CollabId] + return + ( collab E.^. CollabRole + , activity E.^. RemoteActivityReceived + , iI + , roI + , raI + , personR + , actorR + , collab E.^. CollabId + ) + getRL = + E.select $ E.from $ \ (collab `E.LeftOuterJoin` enable `E.InnerJoin` fulfills `E.InnerJoin` recip `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i `E.InnerJoin` inviter `E.InnerJoin` item `E.InnerJoin` actorI `E.LeftOuterJoin` personI) -> do + E.on $ E.just (actorI E.^. ActorId) E.==. personI E.?. PersonActor + E.on $ item E.^. OutboxItemOutbox E.==. actorI E.^. ActorOutbox + E.on $ inviter E.^. CollabInviterLocalInvite E.==. item E.^. OutboxItemId + E.on $ fulfills E.^. CollabFulfillsInviteId E.==. inviter E.^. CollabInviterLocalCollab + E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId + E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId + E.on $ recip E.^. CollabRecipRemoteActor E.==. ra E.^. RemoteActorId + E.on $ collab E.^. CollabId E.==. recip E.^. CollabRecipRemoteCollab + E.on $ collab E.^. CollabId E.==. fulfills E.^. CollabFulfillsInviteCollab + E.on $ E.just (collab E.^. CollabId) E.==. enable E.?. CollabEnableCollab + E.where_ $ + collab E.^. CollabTopic E.==. E.val resourceID E.&&. + E.isNothing (enable E.?. CollabEnableId) + E.orderBy [E.desc $ collab E.^. CollabId] + return + ( collab E.^. CollabRole + , item E.^. OutboxItemPublished + , personI + , actorI + , i + , ro + , ra + , collab E.^. CollabId + ) + getRR = + E.select $ E.from $ \ (collab `E.LeftOuterJoin` enable `E.InnerJoin` fulfills `E.InnerJoin` recip `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i `E.InnerJoin` inviter `E.InnerJoin` activity `E.InnerJoin` raI `E.InnerJoin` roI `E.InnerJoin` iI) -> do + E.on $ roI E.^. RemoteObjectInstance E.==. iI E.^. InstanceId + E.on $ raI E.^. RemoteActorIdent E.==. roI E.^. RemoteObjectId + E.on $ inviter E.^. CollabInviterRemoteActor E.==. raI E.^. RemoteActorId + E.on $ inviter E.^. CollabInviterRemoteInvite E.==. activity E.^. RemoteActivityId + E.on $ fulfills E.^. CollabFulfillsInviteId E.==. inviter E.^. CollabInviterRemoteCollab + E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId + E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId + E.on $ recip E.^. CollabRecipRemoteActor E.==. ra E.^. RemoteActorId + E.on $ collab E.^. CollabId E.==. recip E.^. CollabRecipRemoteCollab + E.on $ collab E.^. CollabId E.==. fulfills E.^. CollabFulfillsInviteCollab + E.on $ E.just (collab E.^. CollabId) E.==. enable E.?. CollabEnableCollab + E.where_ $ + collab E.^. CollabTopic E.==. E.val resourceID E.&&. + E.isNothing (enable E.?. CollabEnableId) + E.orderBy [E.desc $ collab E.^. CollabId] + return + ( collab E.^. CollabRole + , activity E.^. RemoteActivityReceived + , iI + , roI + , raI + , i + , ro + , ra + , collab E.^. CollabId + ) -getTopicJoins +getCollabJoins :: MonadIO m => ResourceId - -> ReaderT SqlBackend m [(Either PersonId RemoteActorId, UTCTime, AP.Role)] -getTopicJoins resourceID = - fmap (map adapt) $ - E.select $ E.from $ - \ (collab `E.LeftOuterJoin` enable `E.InnerJoin` fulfills - `E.LeftOuterJoin` (joinL `E.InnerJoin` recipL `E.InnerJoin` item) - `E.LeftOuterJoin` (joinR `E.InnerJoin` recipR `E.InnerJoin` activity) - ) -> do - E.on $ joinR E.?. CollabRecipRemoteJoinJoin E.==. activity E.?. RemoteActivityId - E.on $ joinR E.?. CollabRecipRemoteJoinCollab E.==. recipR E.?. CollabRecipRemoteId - E.on $ E.just (fulfills E.^. CollabFulfillsJoinId) E.==. joinR E.?. CollabRecipRemoteJoinFulfills - E.on $ joinL E.?. CollabRecipLocalJoinJoin E.==. item E.?. OutboxItemId - E.on $ joinL E.?. CollabRecipLocalJoinCollab E.==. recipL E.?. CollabRecipLocalId - E.on $ E.just (fulfills E.^. CollabFulfillsJoinId) E.==. joinL E.?. CollabRecipLocalJoinFulfills - E.on $ collab E.^. CollabId E.==. fulfills E.^. CollabFulfillsJoinCollab - E.on $ E.just (collab E.^. CollabId) E.==. enable E.?. CollabEnableCollab - E.where_ $ - collab E.^. CollabTopic E.==. E.val resourceID E.&&. - E.isNothing (enable E.?. CollabEnableId) - E.orderBy [E.asc $ fulfills E.^. CollabFulfillsJoinId] - return - ( recipL E.?. CollabRecipLocalPerson - , item E.?. OutboxItemPublished - , recipR E.?. CollabRecipRemoteActor - , activity E.?. RemoteActivityReceived - , collab E.^. CollabRole - ) + -> ReaderT SqlBackend m + [ ( AP.Role + , UTCTime + , Either (Entity Person, Actor) (Instance, RemoteObject, RemoteActor) + , CollabId + ) + ] +getCollabJoins resourceID = + fmap (sortOn $ view _2) $ liftA2 (++) + (map (\ (E.Value role, E.Value time, person, Entity _ actor, E.Value collabID) -> + (role, time, Left (person, actor), collabID) + ) + <$> getLocals + ) + (map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra, E.Value collabID) -> + (role, time, Right (i, ro, ra), collabID) + ) + <$> getRemotes + ) where - adapt (E.Value recipL, E.Value timeL, E.Value recipR, E.Value timeR, E.Value role) = - let l = case (recipL, timeL) of - (Nothing, Nothing) -> Nothing - (Just r, Just t) -> Just (r, t) - _ -> error "Impossible" - r = case (recipR, timeR) of - (Nothing, Nothing) -> Nothing - (Just r, Just t) -> Just (r, t) - _ -> error "Impossible" - in case (l, r) of - (Nothing, Nothing) -> error "No recip" - (Just (personID, time), Nothing) -> (Left personID, time, role) - (Nothing, Just (remoteActorID, time)) -> (Right remoteActorID, time, role) - (Just _, Just _) -> error "Multi recip" + getLocals = + E.select $ E.from $ \ (collab `E.LeftOuterJoin` enable `E.InnerJoin` fulfills `E.InnerJoin` join `E.InnerJoin` recip `E.InnerJoin` person `E.InnerJoin` actor `E.InnerJoin` item) -> do + E.on $ join E.^. CollabRecipLocalJoinJoin E.==. item E.^. OutboxItemId + E.on $ person E.^. PersonActor E.==. actor E.^. ActorId + E.on $ recip E.^. CollabRecipLocalPerson E.==. person E.^. PersonId + E.on $ join E.^. CollabRecipLocalJoinCollab E.==. recip E.^. CollabRecipLocalId + E.on $ fulfills E.^. CollabFulfillsJoinId E.==. join E.^. CollabRecipLocalJoinFulfills + E.on $ collab E.^. CollabId E.==. fulfills E.^. CollabFulfillsJoinCollab + E.on $ E.just (collab E.^. CollabId) E.==. enable E.?. CollabEnableCollab + E.where_ $ + collab E.^. CollabTopic E.==. E.val resourceID E.&&. + E.isNothing (enable E.?. CollabEnableId) + E.orderBy [E.desc $ collab E.^. CollabId] + return + ( collab E.^. CollabRole + , item E.^. OutboxItemPublished + , person + , actor + , collab E.^. CollabId + ) + getRemotes = + E.select $ E.from $ \ (collab `E.LeftOuterJoin` enable `E.InnerJoin` fulfills `E.InnerJoin` join `E.InnerJoin` recip `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i `E.InnerJoin` activity) -> do + E.on $ join E.^. CollabRecipRemoteJoinJoin E.==. activity E.^. RemoteActivityId + E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId + E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId + E.on $ recip E.^. CollabRecipRemoteActor E.==. ra E.^. RemoteActorId + E.on $ join E.^. CollabRecipRemoteJoinCollab E.==. recip E.^. CollabRecipRemoteId + E.on $ fulfills E.^. CollabFulfillsJoinId E.==. join E.^. CollabRecipRemoteJoinFulfills + E.on $ collab E.^. CollabId E.==. fulfills E.^. CollabFulfillsJoinCollab + E.on $ E.just (collab E.^. CollabId) E.==. enable E.?. CollabEnableCollab + E.where_ $ + collab E.^. CollabTopic E.==. E.val resourceID E.&&. + E.isNothing (enable E.?. CollabEnableId) + E.orderBy [E.desc $ collab E.^. CollabId] + return + ( collab E.^. CollabRole + , activity E.^. RemoteActivityReceived + , i + , ro + , ra + , collab E.^. CollabId + ) verifyCapability :: MonadIO m diff --git a/src/Vervis/Serve/Collab.hs b/src/Vervis/Serve/Collab.hs new file mode 100644 index 0000000..1c7b4ab --- /dev/null +++ b/src/Vervis/Serve/Collab.hs @@ -0,0 +1,255 @@ +{- This file is part of Vervis. + - + - Written in 2023, 2024 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Vervis.Serve.Collab + ( serveTeamsCollection + , serveCollabs + , serveInviteCollab + , serveRemoveCollab + ) +where + +import Control.Applicative +import Control.Exception.Base +import Control.Monad +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe +import Data.Aeson +import Data.Bifunctor +import Data.Bitraversable +import Data.ByteString (ByteString) +import Data.Default.Class +import Data.Foldable +import Data.Maybe (fromMaybe, isJust) +import Data.Text (Text) +import Data.Time.Clock +import Data.Traversable +import Database.Persist +import Network.HTTP.Client hiding (Proxy, proxy) +import Network.HTTP.Types.Method +import Network.HTTP.Types.Status +import Optics.Core +import Text.Blaze.Html (Html) +import Yesod.Auth +import Yesod.Core +import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound) +import Yesod.Form.Functions (runFormPost, runFormGet) +import Yesod.Form.Types (FormResult (..)) +import Yesod.Persist.Core (runDB, get404, getBy404) + +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Database.Esqueleto as E + +import Control.Concurrent.Actor +import Database.Persist.JSON +import Development.PatchMediaType +import Network.FedURI +import Web.ActivityPub hiding (Project (..), Repo (..), Actor (..), ActorDetail (..), ActorLocal (..)) +import Yesod.ActivityPub +import Yesod.FedURI +import Yesod.Hashids +import Yesod.MonadSite + +import qualified Web.ActivityPub as AP + +import Control.Monad.Trans.Except.Local +import Data.Either.Local +import Data.Paginate.Local +import Database.Persist.Local +import Yesod.Form.Local +import Yesod.Persist.Local + +import Vervis.Actor +import Vervis.Actor2 +import Vervis.API +import Vervis.Data.Actor +import Vervis.Data.Collab +import Vervis.FedURI +import Vervis.Form.Tracker +import Vervis.Foundation +import Vervis.Model +import Vervis.Persist.Actor +import Vervis.Persist.Collab +import Vervis.Settings +import Vervis.Ticket +import Vervis.TicketFilter +import Vervis.Time +import Vervis.Widget.Tracker + +import qualified Vervis.Client as C +import qualified Vervis.Recipient as VR + +serveTeamsCollection meR hereR resourceID = do + teams <- runDB $ getResourceTeams resourceID + h <- asksSite siteInstanceHost + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + hashGroup <- getEncodeKeyHashid + let makeItem (role, time, team, _) = AP.Relationship + { AP.relationshipId = Nothing + , AP.relationshipExtraTypes = [] + , AP.relationshipSubject = encodeRouteHome meR + , AP.relationshipProperty = Left AP.RelHasRecCollab + , AP.relationshipObject = + case team of + Left (groupID, _) -> + encodeRouteHome $ GroupR $ hashGroup groupID + Right (i, ro, _) -> + ObjURI (instanceHost i) (remoteObjectIdent ro) + , AP.relationshipAttributedTo = encodeRouteLocal meR + , AP.relationshipPublished = Just time + , AP.relationshipUpdated = Nothing + , AP.relationshipInstrument = Just role + } + teamsAP = AP.Collection + { AP.collectionId = encodeRouteLocal hereR + , AP.collectionType = CollectionTypeUnordered + , AP.collectionTotalItems = Just $ length teams + , AP.collectionCurrent = Nothing + , AP.collectionFirst = Nothing + , AP.collectionLast = Nothing + , AP.collectionItems = map (Doc h . makeItem) teams + , AP.collectionContext = Just $ encodeRouteLocal meR + } + provideHtmlAndAP teamsAP $ redirectToPrettyJSON hereR + +serveCollabs + :: AP.RelationshipProperty + -> ResourceId + -> Route App + -> Route App + -> (CollabId -> Route App) + -> Route App + -> Widget + -> Handler TypedContent +serveCollabs rel resourceID meR hereR removeR inviteR navW = do + collabs <- runDB $ getCollabs resourceID + h <- asksSite siteInstanceHost + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + hashPerson <- getEncodeKeyHashid + let makeItem (role, time, collab, _) = AP.Relationship + { AP.relationshipId = Nothing + , AP.relationshipExtraTypes = [] + , AP.relationshipSubject = encodeRouteHome meR + , AP.relationshipProperty = Left rel + , AP.relationshipObject = + case collab of + Left (Entity personID _, _) -> + encodeRouteHome $ PersonR $ hashPerson personID + Right (i, ro, _) -> + ObjURI (instanceHost i) (remoteObjectIdent ro) + , AP.relationshipAttributedTo = encodeRouteLocal meR + , AP.relationshipPublished = Just time + , AP.relationshipUpdated = Nothing + , AP.relationshipInstrument = Just role + } + collabsAP = AP.Collection + { AP.collectionId = encodeRouteLocal hereR + , AP.collectionType = CollectionTypeUnordered + , AP.collectionTotalItems = Just $ length collabs + , AP.collectionCurrent = Nothing + , AP.collectionFirst = Nothing + , AP.collectionLast = Nothing + , AP.collectionItems = map (Doc h . makeItem) collabs + , AP.collectionContext = Just $ encodeRouteLocal meR + } + provideHtmlAndAP collabsAP $ getHtml collabs + where + getHtml collabs = do + mp <- maybeAuthId + haveAdmin <- fmap isJust $ handlerToWidget $ runDB $ runMaybeT $ do + personID <- MaybeT $ pure mp + MaybeT $ getCapability personID (Left resourceID) AP.RoleAdmin + (invites, joins) <- handlerToWidget $ runDB $ do + invites <- getCollabInvites resourceID + joins <- getCollabJoins resourceID + return (invites, joins) + [whamlet| + ^{navW} + ^{collabsW haveAdmin collabs invites joins removeR inviteR} + |] + +serveInviteCollab :: ResourceId -> Route App -> Handler Html +serveInviteCollab resourceID collabsR = do + (uRecipient, role) <- runFormPostRedirect collabsR inviteForm + + personEntity@(Entity personID person) <- requireAuth + personHash <- encodeKeyHashid personID + encodeRouteHome <- getEncodeRouteHome + + result <- runExceptT $ do + (maybeSummary, audience, invite) <- do + let uResourceCollabs = encodeRouteHome collabsR + C.invite personID uRecipient uResourceCollabs role + cap <- do + maybeItem <- + lift $ runDB $ + getCapability personID (Left resourceID) AP.RoleAdmin + fromMaybeE maybeItem "You need admin access to the resource to invite people" + uCap <- lift $ renderActivityURI cap + (localRecips, remoteRecips, fwdHosts, action) <- + C.makeServerInput (Just uCap) maybeSummary audience $ AP.InviteActivity invite + let cap' = first (\ (la, i) -> (la, error "lah", i)) cap + handleViaActor + personID (Just cap') localRecips remoteRecips fwdHosts action + + case result of + Left e -> setMessage $ toHtml e + Right _inviteID -> setMessage "Invite sent" + redirect collabsR + +serveRemoveCollab :: ResourceId -> Route App -> CollabId -> Handler Html +serveRemoveCollab resourceID collabsR collabID = do + personEntity@(Entity personID person) <- requireAuth + personHash <- encodeKeyHashid personID + encodeRouteHome <- getEncodeRouteHome + + result <- runExceptT $ do + mpidOrU <- lift $ runDB $ runMaybeT $ do + Collab _ resourceID' <- MaybeT $ get collabID + guard $ resourceID' == resourceID + _ <- 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 uResourceCollabs = encodeRouteHome collabsR + C.remove personID uRecipient uResourceCollabs + cap <- do + maybeItem <- lift $ runDB $ getCapability personID (Left resourceID) AP.RoleAdmin + fromMaybeE maybeItem "You need to have admin access to the resource to remove collaborators" + uCap <- lift $ renderActivityURI cap + (localRecips, remoteRecips, fwdHosts, action) <- + C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove + let cap' = first (\ (la, i) -> (la, error "lah", i)) cap + handleViaActor + personID (Just cap') localRecips remoteRecips fwdHosts action + + case result of + Left e -> setMessage $ toHtml e + Right _removeID -> setMessage "Remove sent" + redirect collabsR diff --git a/src/Vervis/Web/Collab.hs b/src/Vervis/Web/Collab.hs index fa3de9f..a8db9de 100644 --- a/src/Vervis/Web/Collab.hs +++ b/src/Vervis/Web/Collab.hs @@ -16,7 +16,6 @@ module Vervis.Web.Collab ( verifyCapability'' , checkCapabilityBeforeExtending - , serveTeamsCollection ) where @@ -519,37 +518,3 @@ checkCapabilityBeforeExtending uCap extender = do AP.grantAllows grant == AP.Distribute && targetIsTeam && (AP.grantAllows h == AP.Distribute || AP.grantAllows h == AP.Invoke) - -serveTeamsCollection meR hereR resourceID = do - teams <- runDB $ getResourceTeams resourceID - h <- asksSite siteInstanceHost - encodeRouteLocal <- YF.getEncodeRouteLocal - encodeRouteHome <- YF.getEncodeRouteHome - hashGroup <- getEncodeKeyHashid - let makeItem (role, time, team, _) = AP.Relationship - { AP.relationshipId = Nothing - , AP.relationshipExtraTypes = [] - , AP.relationshipSubject = encodeRouteHome meR - , AP.relationshipProperty = Left AP.RelHasRecCollab - , AP.relationshipObject = - case team of - Left (groupID, _) -> - encodeRouteHome $ GroupR $ hashGroup groupID - Right (i, ro, _) -> - ObjURI (instanceHost i) (remoteObjectIdent ro) - , AP.relationshipAttributedTo = encodeRouteLocal meR - , AP.relationshipPublished = Just time - , AP.relationshipUpdated = Nothing - , AP.relationshipInstrument = Just role - } - teamsAP = AP.Collection - { AP.collectionId = encodeRouteLocal hereR - , AP.collectionType = CollectionTypeUnordered - , AP.collectionTotalItems = Just $ length teams - , AP.collectionCurrent = Nothing - , AP.collectionFirst = Nothing - , AP.collectionLast = Nothing - , AP.collectionItems = map (Doc h . makeItem) teams - , AP.collectionContext = Just $ encodeRouteLocal meR - } - provideHtmlAndAP teamsAP $ redirectToPrettyJSON hereR diff --git a/src/Vervis/Widget/Tracker.hs b/src/Vervis/Widget/Tracker.hs index a595ac7..483a9f7 100644 --- a/src/Vervis/Widget/Tracker.hs +++ b/src/Vervis/Widget/Tracker.hs @@ -23,13 +23,17 @@ module Vervis.Widget.Tracker , actorLinkFedW , groupNavW , personPermitsForResourceW + , collabsW ) where import Data.Bifunctor +import Data.Time.Clock import Database.Persist import Database.Persist.Types +import Network.HTTP.Types.Method import Yesod.Core.Widget +import Yesod.Form import Yesod.Persist.Core import Network.FedURI @@ -44,10 +48,14 @@ import Vervis.Actor import Vervis.Data.Actor import Vervis.Data.Collab import Vervis.FedURI +import Vervis.Form.Tracker import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident import Vervis.Settings +import Vervis.Time +import Vervis.Widget +import Vervis.Widget.Person import qualified Vervis.Recipient as VR @@ -215,3 +223,31 @@ personPermitsForResourceW permits = do \ via # [ ^{actorLinkFedW via} ] |] + +collabsW + :: Bool + -> [ ( AP.Role + , UTCTime + , Either (Entity Person, Actor) (Instance, RemoteObject, RemoteActor) + , CollabId + ) + ] + -> [ ( AP.Role + , UTCTime + , Either (Entity Person, Actor) (Instance, RemoteObject, RemoteActor) + , Either (Entity Person, Actor) (Instance, RemoteObject, RemoteActor) + , CollabId + ) + ] + -> [ ( AP.Role + , UTCTime + , Either (Entity Person, Actor) (Instance, RemoteObject, RemoteActor) + , CollabId + ) + ] + -> (CollabId -> Route App) + -> Route App + -> Widget +collabsW haveAdmin collabs invites joins removeR inviteR = do + ((_, widgetIC), enctypeIC) <- handlerToWidget $ runFormPost inviteForm + $(widgetFile "widget/collabs") diff --git a/templates/deck/collab/list.hamlet b/templates/deck/collab/list.hamlet index 9ced295..c5f24fe 100644 --- a/templates/deck/collab/list.hamlet +++ b/templates/deck/collab/list.hamlet @@ -1,6 +1,7 @@ $# This file is part of Vervis. $# -$# Written in 2016, 2019, 2022, 2023 by fr33domlover . +$# Written in 2016, 2019, 2022, 2023, 2024 +$# by fr33domlover . $# $# ♡ Copying is an act of love. Please copy, reuse and share. $# @@ -14,46 +15,4 @@ $# . ^{deckNavW (Entity deckID deck) actor} -

Collaborators - - - - -
Role - Collaborator - Since - $forall (person, role, ctID, since) <- collabs -
#{show role} - ^{personLinkFedW person} - #{showDate since} - ^{buttonW POST "Remove" (DeckRemoveR deckHash ctID)} - -

Invites - - - - -
Inviter - Invitee - Role - Time - $forall (inviter, invitee, time, role) <- invites -
^{personLinkFedW inviter} - ^{personLinkFedW invitee} - #{show role} - #{showDate time} - -Invite… - -

Joins - - - - -
Joiner - Role - Time - $forall (joiner, time, role) <- joins -
^{personLinkFedW joiner} - #{show role} - #{showDate time} +^{collabsW haveAdmin collabs invites joins (DeckRemoveR deckHash) (DeckInvite deckHash)} diff --git a/templates/deck/collab/new.hamlet b/templates/deck/collab/new.hamlet deleted file mode 100644 index 45dd9a1..0000000 --- a/templates/deck/collab/new.hamlet +++ /dev/null @@ -1,18 +0,0 @@ -$# This file is part of Vervis. -$# -$# Written in 2016, 2023 by fr33domlover . -$# -$# ♡ Copying is an act of love. Please copy, reuse and share. -$# -$# The author(s) have dedicated all copyright and related and neighboring -$# rights to this software to the public domain worldwide. This software is -$# distributed without any warranty. -$# -$# You should have received a copy of the CC0 Public Domain Dedication along -$# with this software. If not, see -$# . - -
- ^{widget} -
- diff --git a/templates/group/members.hamlet b/templates/group/members.hamlet deleted file mode 100644 index 6c22d53..0000000 --- a/templates/group/members.hamlet +++ /dev/null @@ -1,59 +0,0 @@ -$# This file is part of Vervis. -$# -$# Written in 2016, 2019, 2023 by fr33domlover . -$# -$# ♡ Copying is an act of love. Please copy, reuse and share. -$# -$# The author(s) have dedicated all copyright and related and neighboring -$# rights to this software to the public domain worldwide. This software is -$# distributed without any warranty. -$# -$# You should have received a copy of the CC0 Public Domain Dedication along -$# with this software. If not, see -$# . - -^{groupNavW (Entity groupID group) actor} - -

Members - - - - -
Role - Member - Since - $forall (person, role, ctID, since) <- members -
#{show role} - ^{personLinkFedW person} - #{showDate since} - ^{buttonW POST "Remove" (GroupRemoveR groupHash ctID)} - -

Invites - - - - -
Inviter - Invitee - Role - Time - $forall (inviter, invitee, time, role) <- invites -
^{personLinkFedW inviter} - ^{personLinkFedW invitee} - #{show role} - #{showDate time} - -Invite… - -

Joins - - - - -
Joiner - Role - Time - $forall (joiner, time, role) <- joins -
^{personLinkFedW joiner} - #{show role} - #{showDate time} diff --git a/templates/project/collab/list.hamlet b/templates/widget/collabs.hamlet similarity index 61% rename from templates/project/collab/list.hamlet rename to templates/widget/collabs.hamlet index 65842f4..26a1c9a 100644 --- a/templates/project/collab/list.hamlet +++ b/templates/widget/collabs.hamlet @@ -1,6 +1,7 @@ $# This file is part of Vervis. $# -$# Written in 2016, 2019, 2022, 2023 by fr33domlover . +$# Written in 2016, 2019, 2022, 2023, 2024 +$# by fr33domlover . $# $# ♡ Copying is an act of love. Please copy, reuse and share. $# @@ -12,48 +13,53 @@ $# You should have received a copy of the CC0 Public Domain Dedication along $# with this software. If not, see $# . -^{projectNavW (Entity projectID project) actor} -

Collaborators
Role - Collaborator Since - $forall (person, role, ctID, since) <- collabs + Collaborator + $if haveAdmin + Remove + $forall (role, since, person, collabID) <- collabs
#{show role} - ^{personLinkFedW person} #{showDate since} - ^{buttonW POST "Remove" (ProjectRemoveR projectHash ctID)} + ^{personLinkFedW person} + $if haveAdmin + ^{buttonW POST "Remove" (removeR collabID)} + +$if haveAdmin +

Invite a collaborator: + + ^{widgetIC} +

Invites
Inviter - Invitee Role Time - $forall (inviter, invitee, time, role) <- invites + Collaborator + $forall (role, time, inviter, invitee, _collabID) <- invites
^{personLinkFedW inviter} - ^{personLinkFedW invitee} #{show role} #{showDate time} - -Invite… + ^{personLinkFedW invitee}

Joins - -
Joiner Role Time - $forall (joiner, time, role) <- joins + Collaborator + $forall (role, time, person, _collabID) <- joins
^{personLinkFedW joiner} #{show role} #{showDate time} + ^{personLinkFedW person} diff --git a/th/routes b/th/routes index f3a6704..129b1eb 100644 --- a/th/routes +++ b/th/routes @@ -180,7 +180,7 @@ /groups/#GroupKeyHashid/stamps/#SigKeyKeyHashid GroupStampR GET /groups/#GroupKeyHashid/members GroupMembersR GET -/groups/#GroupKeyHashid/invite GroupInviteR GET POST +/groups/#GroupKeyHashid/invite GroupInviteR POST /groups/#GroupKeyHashid/remove/#CollabId GroupRemoveR POST /groups/#GroupKeyHashid/members/#CollabEnableKeyHashid/live GroupMemberLiveR GET @@ -257,13 +257,11 @@ /new-deck DeckNewR GET POST /decks/#DeckKeyHashid/delete DeckDeleteR POST /decks/#DeckKeyHashid/edit DeckEditR GET POST -/decks/#DeckKeyHashid/follow DeckFollowR POST -/decks/#DeckKeyHashid/unfollow DeckUnfollowR POST /decks/#DeckKeyHashid/stamps/#SigKeyKeyHashid DeckStampR GET /decks/#DeckKeyHashid/collabs DeckCollabsR GET -/decks/#DeckKeyHashid/invite DeckInviteR GET POST +/decks/#DeckKeyHashid/invite DeckInviteR POST /decks/#DeckKeyHashid/remove/#CollabId DeckRemoveR POST /decks/#DeckKeyHashid/projects DeckProjectsR GET @@ -387,7 +385,7 @@ /projects/#ProjectKeyHashid/stamps/#SigKeyKeyHashid ProjectStampR GET /projects/#ProjectKeyHashid/collabs ProjectCollabsR GET -/projects/#ProjectKeyHashid/invite ProjectInviteR GET POST +/projects/#ProjectKeyHashid/invite ProjectInviteR POST /projects/#ProjectKeyHashid/remove/#CollabId ProjectRemoveR POST /projects/#ProjectKeyHashid/components ProjectComponentsR GET diff --git a/vervis.cabal b/vervis.cabal index c01b314..7d24133 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -249,6 +249,9 @@ library Vervis.RemoteActorStore.Types --Vervis.Repo Vervis.Secure + + Vervis.Serve.Collab + Vervis.Settings Vervis.Settings.StaticFiles Vervis.Settings.TH