UI: Deck, Group, Project: Enhance collaborators view, prepare to add teams

This commit is contained in:
Pere Lev 2024-05-16 15:19:01 +03:00
parent 7ade4984d7
commit 5c6e73a3d4
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
18 changed files with 638 additions and 767 deletions

View file

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

View file

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

View file

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

View file

@ -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 <- 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, actor) <- 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")
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

View file

@ -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 <- 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, actor) <- 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")
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

View file

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

View file

@ -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 <- 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, actor) <- 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")
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

View file

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

View file

@ -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
-> 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
, recipL E.?. CollabRecipLocalPerson
, recipR E.?. CollabRecipRemoteActor
, collab E.^. CollabId
, grant E.^. OutboxItemPublished
, person
, actor
, collab E.^. CollabId
)
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
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
-> 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
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.asc $ fulfills E.^. CollabFulfillsInviteId]
E.orderBy [E.desc $ collab E.^. CollabId]
return
( actor E.?. ActorId
, item E.?. OutboxItemPublished
, inviterR E.?. CollabInviterRemoteActor
, activity E.?. RemoteActivityReceived
, recipL E.?. CollabRecipLocalPerson
, recipR E.?. CollabRecipRemoteActor
, collab E.^. CollabRole
( collab E.^. CollabRole
, item E.^. OutboxItemPublished
, personI
, actorI
, personR
, actorR
, collab E.^. CollabId
)
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
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
-> 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
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.asc $ fulfills E.^. CollabFulfillsJoinId]
E.orderBy [E.desc $ collab E.^. CollabId]
return
( recipL E.?. CollabRecipLocalPerson
, item E.?. OutboxItemPublished
, recipR E.?. CollabRecipRemoteActor
, activity E.?. RemoteActivityReceived
, collab E.^. CollabRole
( 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
)
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"
verifyCapability
:: MonadIO m

255
src/Vervis/Serve/Collab.hs Normal file
View file

@ -0,0 +1,255 @@
{- This file is part of Vervis.
-
- Written in 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
-
- 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
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
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

View file

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

View file

@ -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")

View file

@ -1,6 +1,7 @@
$# This file is part of Vervis.
$#
$# Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
$# Written in 2016, 2019, 2022, 2023, 2024
$# by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
@ -14,46 +15,4 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
^{deckNavW (Entity deckID deck) actor}
<h2>Collaborators
<table>
<tr>
<th>Role
<th>Collaborator
<th>Since
$forall (person, role, ctID, since) <- collabs
<tr>
<td>#{show role}
<td>^{personLinkFedW person}
<td>#{showDate since}
<td>^{buttonW POST "Remove" (DeckRemoveR deckHash ctID)}
<h2>Invites
<table>
<tr>
<th>Inviter
<th>Invitee
<th>Role
<th>Time
$forall (inviter, invitee, time, role) <- invites
<tr>
<td>^{personLinkFedW inviter}
<td>^{personLinkFedW invitee}
<td>#{show role}
<td>#{showDate time}
<a href=@{DeckInviteR deckHash}>Invite…
<h2>Joins
<table>
<tr>
<th>Joiner
<th>Role
<th>Time
$forall (joiner, time, role) <- joins
<tr>
<td>^{personLinkFedW joiner}
<td>#{show role}
<td>#{showDate time}
^{collabsW haveAdmin collabs invites joins (DeckRemoveR deckHash) (DeckInvite deckHash)}

View file

@ -1,18 +0,0 @@
$# This file is part of Vervis.
$#
$# Written in 2016, 2023 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ 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
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<form method=POST action=@{DeckInviteR deckHash} enctype=#{enctype}>
^{widget}
<div class="submit">
<input type="submit">

View file

@ -1,59 +0,0 @@
$# This file is part of Vervis.
$#
$# Written in 2016, 2019, 2023 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ 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
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
^{groupNavW (Entity groupID group) actor}
<h2>Members
<table>
<tr>
<th>Role
<th>Member
<th>Since
$forall (person, role, ctID, since) <- members
<tr>
<td>#{show role}
<td>^{personLinkFedW person}
<td>#{showDate since}
<td>^{buttonW POST "Remove" (GroupRemoveR groupHash ctID)}
<h2>Invites
<table>
<tr>
<th>Inviter
<th>Invitee
<th>Role
<th>Time
$forall (inviter, invitee, time, role) <- invites
<tr>
<td>^{personLinkFedW inviter}
<td>^{personLinkFedW invitee}
<td>#{show role}
<td>#{showDate time}
<a href=@{GroupInviteR groupHash}>Invite…
<h2>Joins
<table>
<tr>
<th>Joiner
<th>Role
<th>Time
$forall (joiner, time, role) <- joins
<tr>
<td>^{personLinkFedW joiner}
<td>#{show role}
<td>#{showDate time}

View file

@ -1,6 +1,7 @@
$# This file is part of Vervis.
$#
$# Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
$# Written in 2016, 2019, 2022, 2023, 2024
$# by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ 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
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
^{projectNavW (Entity projectID project) actor}
<h2>Collaborators
<table>
<tr>
<th>Role
<th>Collaborator
<th>Since
$forall (person, role, ctID, since) <- collabs
<th>Collaborator
$if haveAdmin
<th>Remove
$forall (role, since, person, collabID) <- collabs
<tr>
<td>#{show role}
<td>^{personLinkFedW person}
<td>#{showDate since}
<td>^{buttonW POST "Remove" (ProjectRemoveR projectHash ctID)}
<td>^{personLinkFedW person}
$if haveAdmin
<td>^{buttonW POST "Remove" (removeR collabID)}
$if haveAdmin
<p>Invite a collaborator:
<form method=POST action=@{inviteR} enctype=#{enctypeIC}>
^{widgetIC}
<input type=submit>
<h2>Invites
<table>
<tr>
<th>Inviter
<th>Invitee
<th>Role
<th>Time
$forall (inviter, invitee, time, role) <- invites
<th>Collaborator
$forall (role, time, inviter, invitee, _collabID) <- invites
<tr>
<td>^{personLinkFedW inviter}
<td>^{personLinkFedW invitee}
<td>#{show role}
<td>#{showDate time}
<a href=@{ProjectInviteR projectHash}>Invite…
<td>^{personLinkFedW invitee}
<h2>Joins
<table>
<tr>
<th>Joiner
<th>Role
<th>Time
$forall (joiner, time, role) <- joins
<th>Collaborator
$forall (role, time, person, _collabID) <- joins
<tr>
<td>^{personLinkFedW joiner}
<td>#{show role}
<td>#{showDate time}
<td>^{personLinkFedW person}

View file

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

View file

@ -249,6 +249,9 @@ library
Vervis.RemoteActorStore.Types
--Vervis.Repo
Vervis.Secure
Vervis.Serve.Collab
Vervis.Settings
Vervis.Settings.StaticFiles
Vervis.Settings.TH