UI: Deck, Group, Project: Enhance collaborators view, prepare to add teams
This commit is contained in:
Pere Lev
parent
7ade4984d7
commit
5c6e73a3d4
18 changed files with 638 additions and 767 deletions
|
|
@ -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`
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
255
src/Vervis/Serve/Collab.hs
Normal file
255
src/Vervis/Serve/Collab.hs
Normal 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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -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)}
|
||||
|
|
|
|||
|
|
@ -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">
|
||||
|
|
@ -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}
|
||||
|
|
@ -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}
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -249,6 +249,9 @@ library
|
|||
Vervis.RemoteActorStore.Types
|
||||
--Vervis.Repo
|
||||
Vervis.Secure
|
||||
|
||||
Vervis.Serve.Collab
|
||||
|
||||
Vervis.Settings
|
||||
Vervis.Settings.StaticFiles
|
||||
Vervis.Settings.TH
|
||||
|
|
|
|||
Loading…
Reference in a new issue