DB: Switch Collab and Permit to use Resource
Since collaborator live URIs were using CollabTopic*, this change breaks existing live URIs, which means all existing delegation chains are now broken. FYI if you're playing with your own Vervis deployment.
This commit is contained in:
Pere Lev
parent
4881154579
commit
888a30e989
29 changed files with 805 additions and 807 deletions
147
migrations/611_2024-04-20_permit_resource.model
Normal file
147
migrations/611_2024-04-20_permit_resource.model
Normal file
|
|
@ -0,0 +1,147 @@
|
|||
OutboxItem
|
||||
Workflow
|
||||
Permit
|
||||
|
||||
Inbox
|
||||
|
||||
Outbox
|
||||
|
||||
FollowerSet
|
||||
|
||||
Actor
|
||||
name Text
|
||||
desc Text
|
||||
createdAt UTCTime
|
||||
inbox InboxId
|
||||
outbox OutboxId
|
||||
followers FollowerSetId
|
||||
justCreatedBy ActorId Maybe
|
||||
|
||||
UniqueActorInbox inbox
|
||||
UniqueActorOutbox outbox
|
||||
UniqueActorFollowers followers
|
||||
|
||||
Resource
|
||||
actor ActorId
|
||||
|
||||
UniqueResource actor
|
||||
|
||||
Group
|
||||
actor ActorId
|
||||
resource ResourceId
|
||||
create OutboxItemId
|
||||
|
||||
UniqueGroupActor actor
|
||||
UniqueGroupCreate create
|
||||
|
||||
Project
|
||||
actor ActorId
|
||||
resource ResourceId
|
||||
create OutboxItemId
|
||||
|
||||
UniqueProjectActor actor
|
||||
UniqueProjectCreate create
|
||||
|
||||
Deck
|
||||
actor ActorId
|
||||
resource ResourceId
|
||||
workflow WorkflowId
|
||||
nextTicket Int
|
||||
wiki RepoId Maybe
|
||||
create OutboxItemId
|
||||
|
||||
UniqueDeckActor actor
|
||||
UniqueDeckCreate create
|
||||
|
||||
Loom
|
||||
nextTicket Int
|
||||
actor ActorId
|
||||
resource ResourceId
|
||||
repo RepoId
|
||||
create OutboxItemId
|
||||
|
||||
UniqueLoomActor actor
|
||||
UniqueLoomRepo repo
|
||||
UniqueLoomCreate create
|
||||
|
||||
Repo
|
||||
vcs VersionControlSystem
|
||||
project DeckId Maybe
|
||||
mainBranch Text
|
||||
actor ActorId
|
||||
resource ResourceId
|
||||
create OutboxItemId
|
||||
loom LoomId Maybe
|
||||
|
||||
UniqueRepoActor actor
|
||||
UniqueRepoCreate create
|
||||
|
||||
PermitTopicLocal
|
||||
permit PermitId
|
||||
topic ResourceId
|
||||
|
||||
UniquePermitTopicLocal permit
|
||||
|
||||
PermitTopicRepo
|
||||
permit PermitTopicLocalId
|
||||
repo RepoId
|
||||
|
||||
UniquePermitTopicRepo permit
|
||||
|
||||
PermitTopicDeck
|
||||
permit PermitTopicLocalId
|
||||
deck DeckId
|
||||
|
||||
UniquePermitTopicDeck permit
|
||||
|
||||
PermitTopicLoom
|
||||
permit PermitTopicLocalId
|
||||
loom LoomId
|
||||
|
||||
UniquePermitTopicLoom permit
|
||||
|
||||
PermitTopicProject
|
||||
permit PermitTopicLocalId
|
||||
project ProjectId
|
||||
|
||||
UniquePermitTopicProject permit
|
||||
|
||||
PermitTopicGroup
|
||||
permit PermitTopicLocalId
|
||||
group GroupId
|
||||
|
||||
UniquePermitTopicGroup permit
|
||||
|
||||
Collab
|
||||
role Role
|
||||
topic ResourceId
|
||||
|
||||
CollabTopicRepo
|
||||
collab CollabId
|
||||
repo RepoId
|
||||
|
||||
UniqueCollabTopicRepo collab
|
||||
|
||||
CollabTopicDeck
|
||||
collab CollabId
|
||||
deck DeckId
|
||||
|
||||
UniqueCollabTopicDeck collab
|
||||
|
||||
CollabTopicLoom
|
||||
collab CollabId
|
||||
loom LoomId
|
||||
|
||||
UniqueCollabTopicLoom collab
|
||||
|
||||
CollabTopicProject
|
||||
collab CollabId
|
||||
project ProjectId
|
||||
|
||||
UniqueCollabTopicProject collab
|
||||
|
||||
CollabTopicGroup
|
||||
collab CollabId
|
||||
group GroupId
|
||||
|
||||
UniqueCollabTopicGroup collab
|
||||
|
|
@ -1009,15 +1009,15 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
|
|||
(loomID, obiid, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do
|
||||
|
||||
-- Find the specified repo in DB
|
||||
_ <- getE repoID "No such repo in DB"
|
||||
repo <- getE repoID "No such repo in DB"
|
||||
|
||||
-- Make sure the repo has a single, full-access collab, granted to the
|
||||
-- sender of this Create
|
||||
maybeApproved <- lift $ runMaybeT $ do
|
||||
collabs <- lift $ selectList [CollabTopicRepoRepo ==. repoID] []
|
||||
collabs <- lift $ selectKeysList [CollabTopic ==. repoResource repo] []
|
||||
collabID <-
|
||||
case collabs of
|
||||
[Entity _ c] -> return $ collabTopicRepoCollab c
|
||||
[c] -> return c
|
||||
_ -> mzero
|
||||
CollabRecipLocal _ recipID <-
|
||||
MaybeT $ getValBy $ UniqueCollabRecipLocal collabID
|
||||
|
|
@ -1030,7 +1030,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
|
|||
|
||||
-- Insert new loom to DB
|
||||
obiidCreate <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
|
||||
(loomID, Entity loomActorID loomActor) <-
|
||||
(loomID, resourceID, Entity loomActorID loomActor) <-
|
||||
lift $ insertLoom now name msummary obiidCreate repoID
|
||||
|
||||
-- Insert the Create activity to author's outbox
|
||||
|
|
@ -1056,7 +1056,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
|
|||
-- Insert collaboration access for loom's creator
|
||||
let loomOutboxID = actorOutbox loomActor
|
||||
obiidGrant <- lift $ insertEmptyOutboxItem loomOutboxID now
|
||||
lift $ insertCollab loomID obiidGrant
|
||||
lift $ insertCollab resourceID obiidGrant
|
||||
|
||||
-- Insert a Grant activity to loom's outbox
|
||||
let grantRecipActors = [LocalActorPerson senderHash]
|
||||
|
|
@ -1139,7 +1139,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
|
|||
, loomRepo = repoID
|
||||
, loomCreate = obiidCreate
|
||||
}
|
||||
return (loomID, actor)
|
||||
return (loomID, resourceID, actor)
|
||||
|
||||
prepareCreate name msummary loomHash repoHash = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
|
@ -1167,9 +1167,8 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
|
|||
}
|
||||
return action { actionSpecific = specific }
|
||||
|
||||
insertCollab loomID obiidGrant = do
|
||||
cid <- insert $ Collab RoleAdmin
|
||||
insert_ $ CollabTopicLoom cid loomID
|
||||
insertCollab resourceID obiidGrant = do
|
||||
cid <- insert $ Collab RoleAdmin resourceID
|
||||
insert_ $ CollabEnable cid obiidGrant
|
||||
insert_ $ CollabRecipLocal cid pidUser
|
||||
insert_ $ CollabFulfillsLocalTopicCreation cid
|
||||
|
|
@ -1280,7 +1279,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
|
|||
-- Insert new repo to DB
|
||||
obiidCreate <-
|
||||
lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
|
||||
(repoID, Entity repoActorID repoActor) <-
|
||||
(repoID, resourceID, Entity repoActorID repoActor) <-
|
||||
lift $ insertRepo now name msummary obiidCreate
|
||||
|
||||
-- Insert the Create activity to author's outbox
|
||||
|
|
@ -1301,7 +1300,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
|
|||
-- Insert collaboration access for repo's creator
|
||||
let repoOutboxID = actorOutbox repoActor
|
||||
grantID <- lift $ insertEmptyOutboxItem repoOutboxID now
|
||||
lift $ insertCollab repoID grantID
|
||||
lift $ insertCollab resourceID grantID
|
||||
|
||||
-- Insert a Grant activity to repo's outbox
|
||||
let grantRecipActors = [LocalActorPerson senderHash]
|
||||
|
|
@ -1379,7 +1378,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
|
|||
, repoCreate = createID
|
||||
, repoLoom = Nothing
|
||||
}
|
||||
return (repoID, actor)
|
||||
return (repoID, resourceID, actor)
|
||||
|
||||
prepareCreate now name msummary repoHash = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
|
@ -1405,9 +1404,8 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
|
|||
}
|
||||
return action { actionSpecific = specific }
|
||||
|
||||
insertCollab repoID grantID = do
|
||||
collabID <- insert $ Collab RoleAdmin
|
||||
insert_ $ CollabTopicRepo collabID repoID
|
||||
insertCollab resourceID grantID = do
|
||||
collabID <- insert $ Collab RoleAdmin resourceID
|
||||
insert_ $ CollabEnable collabID grantID
|
||||
insert_ $ CollabRecipLocal collabID pidUser
|
||||
insert_ $ CollabFulfillsLocalTopicCreation collabID
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2019, 2022, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -157,20 +157,20 @@ checkRepoAccess' mpid op repoID = do
|
|||
Just (Entity rid repo) -> do
|
||||
role <- do
|
||||
case mpid of
|
||||
Just pid -> fromMaybe User <$> asCollab rid pid
|
||||
Just pid -> fromMaybe User <$> asCollab (repoResource repo) pid
|
||||
Nothing -> pure Guest
|
||||
status <$> roleHasAccess role op
|
||||
where
|
||||
asCollab rid pid = do
|
||||
fmap (const Developer) . listToMaybe <$> do
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` enable) -> do
|
||||
E.on $ topic E.^. CollabTopicRepoCollab E.==. enable E.^. CollabEnableCollab
|
||||
E.on $ topic E.^. CollabTopicRepoCollab E.==. recip E.^. CollabRecipLocalCollab
|
||||
E.select $ E.from $ \ (collab `E.InnerJoin` recip `E.InnerJoin` enable) -> do
|
||||
E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab
|
||||
E.on $ collab E.^. CollabId E.==. recip E.^. CollabRecipLocalCollab
|
||||
E.where_ $
|
||||
topic E.^. CollabTopicRepoRepo E.==. E.val rid E.&&.
|
||||
collab E.^. CollabTopic E.==. E.val rid E.&&.
|
||||
recip E.^. CollabRecipLocalPerson E.==. E.val pid
|
||||
E.limit 1
|
||||
return $ topic E.^. CollabTopicRepoCollab
|
||||
return $ collab E.^. CollabId
|
||||
|
||||
checkRepoAccess
|
||||
:: (MonadIO m, MonadSite m, YesodHashids (SiteEnv m))
|
||||
|
|
@ -188,20 +188,20 @@ checkRepoAccess mpid op repoHash = do
|
|||
Just (Entity rid repo) -> do
|
||||
role <- do
|
||||
case mpid of
|
||||
Just pid -> fromMaybe User <$> asCollab rid pid
|
||||
Just pid -> fromMaybe User <$> asCollab (repoResource repo) pid
|
||||
Nothing -> pure Guest
|
||||
status <$> roleHasAccess role op
|
||||
where
|
||||
asCollab rid pid = do
|
||||
fmap (const Developer) . listToMaybe <$> do
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` enable) -> do
|
||||
E.on $ topic E.^. CollabTopicRepoCollab E.==. enable E.^. CollabEnableCollab
|
||||
E.on $ topic E.^. CollabTopicRepoCollab E.==. recip E.^. CollabRecipLocalCollab
|
||||
E.select $ E.from $ \ (collab `E.InnerJoin` recip `E.InnerJoin` enable) -> do
|
||||
E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab
|
||||
E.on $ collab E.^. CollabId E.==. recip E.^. CollabRecipLocalCollab
|
||||
E.where_ $
|
||||
topic E.^. CollabTopicRepoRepo E.==. E.val rid E.&&.
|
||||
collab E.^. CollabTopic E.==. E.val rid E.&&.
|
||||
recip E.^. CollabRecipLocalPerson E.==. E.val pid
|
||||
E.limit 1
|
||||
return $ topic E.^. CollabTopicRepoCollab
|
||||
return $ collab E.^. CollabId
|
||||
|
||||
checkProjectAccess
|
||||
:: (MonadIO m, MonadSite m, YesodHashids (SiteEnv m))
|
||||
|
|
@ -219,17 +219,17 @@ checkProjectAccess mpid op deckHash = do
|
|||
Just (Entity jid project) -> do
|
||||
role <- do
|
||||
case mpid of
|
||||
Just pid -> fromMaybe User <$> asCollab jid pid
|
||||
Just pid -> fromMaybe User <$> asCollab (deckResource project) pid
|
||||
Nothing -> pure Guest
|
||||
status <$> roleHasAccess role op
|
||||
where
|
||||
asCollab jid pid = do
|
||||
asCollab rid pid = do
|
||||
fmap (const Developer) . listToMaybe <$> do
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` enable) -> do
|
||||
E.on $ topic E.^. CollabTopicDeckCollab E.==. enable E.^. CollabEnableCollab
|
||||
E.on $ topic E.^. CollabTopicDeckCollab E.==. recip E.^. CollabRecipLocalCollab
|
||||
E.select $ E.from $ \ (collab `E.InnerJoin` recip `E.InnerJoin` enable) -> do
|
||||
E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab
|
||||
E.on $ collab E.^. CollabId E.==. recip E.^. CollabRecipLocalCollab
|
||||
E.where_ $
|
||||
topic E.^. CollabTopicDeckDeck E.==. E.val jid E.&&.
|
||||
collab E.^. CollabTopic E.==. E.val rid E.&&.
|
||||
recip E.^. CollabRecipLocalPerson E.==. E.val pid
|
||||
E.limit 1
|
||||
return $ topic E.^. CollabTopicDeckCollab
|
||||
return $ collab E.^. CollabId
|
||||
|
|
|
|||
|
|
@ -162,6 +162,11 @@ data LocalActorBy f
|
|||
| LocalActorProject (f Project)
|
||||
deriving (Generic, FunctorB, ConstraintsB)
|
||||
|
||||
deriving instance AllBF Eq f LocalActorBy => Eq (LocalActorBy f)
|
||||
deriving instance AllBF Ord f LocalActorBy => Ord (LocalActorBy f)
|
||||
deriving instance AllBF Hashable f LocalActorBy => Hashable (LocalActorBy f)
|
||||
deriving instance AllBF Show f LocalActorBy => Show (LocalActorBy f)
|
||||
|
||||
data LocalResourceBy f
|
||||
= LocalResourceGroup (f Group)
|
||||
| LocalResourceRepo (f Repo)
|
||||
|
|
@ -170,10 +175,7 @@ data LocalResourceBy f
|
|||
| LocalResourceProject (f Project)
|
||||
deriving (Generic, FunctorB, ConstraintsB)
|
||||
|
||||
deriving instance AllBF Eq f LocalActorBy => Eq (LocalActorBy f)
|
||||
deriving instance AllBF Ord f LocalActorBy => Ord (LocalActorBy f)
|
||||
deriving instance AllBF Hashable f LocalActorBy => Hashable (LocalActorBy f)
|
||||
deriving instance AllBF Show f LocalActorBy => Show (LocalActorBy f)
|
||||
deriving instance AllBF Eq f LocalResourceBy => Eq (LocalResourceBy f)
|
||||
|
||||
type LocalActor = LocalActorBy KeyHashid
|
||||
|
||||
|
|
|
|||
|
|
@ -231,14 +231,14 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
|
|||
topicAccept
|
||||
:: forall topic.
|
||||
(PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
||||
=> (topic -> ActorId)
|
||||
=> (topic -> ResourceId)
|
||||
-> (forall f. f topic -> ComponentBy f)
|
||||
-> UTCTime
|
||||
-> Key topic
|
||||
-> Verse
|
||||
-> AP.Accept URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) accept = do
|
||||
topicAccept grabResource topicComponent now recipKey (Verse authorIdMsig body) accept = do
|
||||
|
||||
-- Check input
|
||||
acceptee <- parseAccept accept
|
||||
|
|
@ -252,10 +252,11 @@ topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) acc
|
|||
(AP.activityCapability $ actbActivity body)
|
||||
|
||||
-- Grab me from DB
|
||||
(recipActorID, recipActor) <- lift $ withDB $ do
|
||||
recip <- getJust recipKey
|
||||
let actorID = topicActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
(resourceID, recipActorID, recipActor) <- lift $ withDB $ do
|
||||
resourceID <- grabResource <$> getJust recipKey
|
||||
Resource recipActorID <- getJust resourceID
|
||||
recipActor <- getJust recipActorID
|
||||
return (resourceID, recipActorID, recipActor)
|
||||
|
||||
collabOrStem <- withDBExcept $ do
|
||||
|
||||
|
|
@ -284,8 +285,8 @@ topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) acc
|
|||
|
||||
where
|
||||
|
||||
topicResource :: forall f. f topic -> LocalActorBy f
|
||||
topicResource = componentActor . topicComponent
|
||||
topicResource :: forall f. f topic -> LocalResourceBy f
|
||||
topicResource = componentResource . topicComponent
|
||||
|
||||
tryInviteCollab (Left (actorByKey, _actorEntity, itemID)) =
|
||||
(,Left actorByKey) . collabInviterLocalCollab <$>
|
||||
|
|
@ -346,7 +347,7 @@ topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) acc
|
|||
audAccepter <- makeAudSenderWithFollowers authorIdMsig
|
||||
audApprover <- lift $ makeAudSenderOnly authorIdMsig
|
||||
recipHash <- encodeKeyHashid recipKey
|
||||
let topicByHash = topicResource recipHash
|
||||
let topicByHash = resourceToActor $ topicResource recipHash
|
||||
|
||||
senderHash <- bitraverse hashLocalActor pure sender
|
||||
|
||||
|
|
@ -480,7 +481,7 @@ topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) acc
|
|||
_ -> error "topicAccept impossible"
|
||||
|
||||
-- Prepare forwarding of Accept to my followers
|
||||
let recipByID = topicResource recipKey
|
||||
let recipByID = resourceToActor $ topicResource recipKey
|
||||
recipByHash <- hashLocalActor recipByID
|
||||
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
|
||||
|
||||
|
|
@ -494,9 +495,9 @@ topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) acc
|
|||
let inviterOrJoiner = either snd snd collab
|
||||
isInvite = isLeft collab
|
||||
grant@(actionGrant, _, _, _) <- do
|
||||
Collab role <- lift $ getJust collabID
|
||||
Collab role _ <- lift $ getJust collabID
|
||||
lift $ prepareGrant isInvite inviterOrJoiner role
|
||||
let recipByKey = topicResource recipKey
|
||||
let recipByKey = resourceToActor $ topicResource recipKey
|
||||
_luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant
|
||||
return (grantID, grant)
|
||||
|
||||
|
|
@ -505,7 +506,7 @@ topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) acc
|
|||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (recipActorID, sieve, (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant))) -> do
|
||||
let recipByID = topicResource recipKey
|
||||
let recipByID = resourceToActor $ topicResource recipKey
|
||||
forwardActivity authorIdMsig body recipByID recipActorID sieve
|
||||
lift $ sendActivity
|
||||
recipByID recipActorID localRecipsGrant
|
||||
|
|
@ -544,7 +545,7 @@ topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) acc
|
|||
audAccepter <- lift $ makeAudSenderOnly authorIdMsig
|
||||
audMe <-
|
||||
AudLocal [] . pure . localActorFollowers .
|
||||
topicResource <$>
|
||||
resourceToActor . topicResource <$>
|
||||
encodeKeyHashid recipKey
|
||||
|
||||
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
|
|
@ -660,7 +661,7 @@ topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) acc
|
|||
insert_ $ StemComponentGestureRemote stemID (remoteAuthorId author) acceptID
|
||||
|
||||
-- Prepare forwarding of Accept to my followers
|
||||
let recipByID = topicResource recipKey
|
||||
let recipByID = resourceToActor $ topicResource recipKey
|
||||
recipByHash <- hashLocalActor recipByID
|
||||
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
|
||||
|
||||
|
|
@ -672,7 +673,7 @@ topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) acc
|
|||
|
||||
-- Prepare an Accept activity and insert to my outbox
|
||||
react@(actionReact, _, _, _) <- lift $ prepareReact project inviter
|
||||
let recipByKey = topicResource recipKey
|
||||
let recipByKey = resourceToActor $ topicResource recipKey
|
||||
_luReact <- lift $ updateOutboxItem' recipByKey reactID actionReact
|
||||
return (reactID, react)
|
||||
|
||||
|
|
@ -684,7 +685,7 @@ topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) acc
|
|||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just Nothing -> done "Done"
|
||||
Just (Just (sieve, (reactID, (actionReact, localRecipsReact, remoteRecipsReact, fwdHostsReact)))) -> do
|
||||
let recipByID = topicResource recipKey
|
||||
let recipByID = resourceToActor $ topicResource recipKey
|
||||
forwardActivity authorIdMsig body recipByID recipActorID sieve
|
||||
lift $ sendActivity
|
||||
recipByID recipActorID localRecipsReact
|
||||
|
|
@ -693,14 +694,14 @@ topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) acc
|
|||
|
||||
topicReject
|
||||
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
||||
=> (topic -> ActorId)
|
||||
-> (forall f. f topic -> LocalActorBy f)
|
||||
=> (topic -> ResourceId)
|
||||
-> (forall f. f topic -> LocalResourceBy f)
|
||||
-> UTCTime
|
||||
-> Key topic
|
||||
-> Verse
|
||||
-> AP.Reject URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reject = do
|
||||
topicReject grabResource topicResource now recipKey (Verse authorIdMsig body) reject = do
|
||||
|
||||
-- Check input
|
||||
rejectee <- parseReject reject
|
||||
|
|
@ -716,10 +717,9 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
|
|||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(recipActorID, recipActor) <- lift $ do
|
||||
recip <- getJust recipKey
|
||||
let actorID = topicActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
resourceID <- lift $ grabResource <$> getJust recipKey
|
||||
Resource recipActorID <- lift $ getJust resourceID
|
||||
recipActor <- lift $ getJust recipActorID
|
||||
|
||||
-- Find the rejected activity in our DB
|
||||
rejecteeDB <- do
|
||||
|
|
@ -742,7 +742,7 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
|
|||
collabFulfillsInviteCollab <$> getJust fulfillsID
|
||||
Right (fulfillsID, _, _, _) ->
|
||||
collabFulfillsJoinCollab <$> getJust fulfillsID
|
||||
(deleteTopic, topic) <- lift $ getCollabTopic' collabID
|
||||
topic <- lift $ getCollabTopic collabID
|
||||
unless (topicResource recipKey == topic) $
|
||||
throwE "Accept object is an Invite/Join for some other resource"
|
||||
|
||||
|
|
@ -809,18 +809,16 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
|
|||
case idsForReject of
|
||||
Left (fulfillsID, recipID, deleteInviter) -> lift $ do
|
||||
bitraverse_ delete delete recipID
|
||||
deleteTopic
|
||||
deleteInviter
|
||||
delete fulfillsID
|
||||
Right (fulfillsID, deleteRecipJoin, deleteRecip) -> lift $ do
|
||||
deleteRecipJoin
|
||||
deleteRecip
|
||||
deleteTopic
|
||||
delete fulfillsID
|
||||
lift $ delete collabID
|
||||
|
||||
-- Prepare forwarding of Reject to my followers
|
||||
let recipByID = topicResource recipKey
|
||||
let recipByID = resourceToActor $ topicResource recipKey
|
||||
recipByHash <- hashLocalActor recipByID
|
||||
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
|
||||
|
||||
|
|
@ -832,7 +830,7 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
|
|||
isInvite = isLeft collab
|
||||
newReject@(actionReject, _, _, _) <-
|
||||
lift $ prepareReject isInvite inviterOrJoiner
|
||||
let recipByKey = topicResource recipKey
|
||||
let recipByKey = resourceToActor $ topicResource recipKey
|
||||
_luNewReject <- lift $ updateOutboxItem' recipByKey newRejectID actionReject
|
||||
return (newRejectID, newReject)
|
||||
|
||||
|
|
@ -841,7 +839,7 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
|
|||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (recipActorID, sieve, (newRejectID, (action, localRecips, remoteRecips, fwdHosts))) -> do
|
||||
let recipByID = topicResource recipKey
|
||||
let recipByID = resourceToActor $ topicResource recipKey
|
||||
forwardActivity authorIdMsig body recipByID recipActorID sieve
|
||||
lift $ sendActivity
|
||||
recipByID recipActorID localRecips
|
||||
|
|
@ -884,7 +882,7 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
|
|||
audRejecter <- makeAudSenderWithFollowers authorIdMsig
|
||||
audForbidder <- lift $ makeAudSenderOnly authorIdMsig
|
||||
recipHash <- encodeKeyHashid recipKey
|
||||
let topicByHash = topicResource recipHash
|
||||
let topicByHash = resourceToActor $ topicResource recipHash
|
||||
|
||||
senderHash <- bitraverse hashLocalActor pure sender
|
||||
|
||||
|
|
@ -949,21 +947,17 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
|
|||
topicInvite
|
||||
:: forall topic ct si.
|
||||
( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic
|
||||
, PersistRecordBackend ct SqlBackend
|
||||
, PersistRecordBackend si SqlBackend
|
||||
)
|
||||
=> (topic -> ActorId)
|
||||
=> (topic -> ResourceId)
|
||||
-> (forall f. f topic -> ComponentBy f)
|
||||
-> EntityField ct (Key topic)
|
||||
-> EntityField ct CollabId
|
||||
-> (CollabId -> Key topic -> ct)
|
||||
-> (StemId -> Key topic -> si)
|
||||
-> UTCTime
|
||||
-> Key topic
|
||||
-> Verse
|
||||
-> AP.Invite URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
topicInvite grabActor topicComponent topicField topicCollabField collabTopicCtor stemIdentCtor now topicKey (Verse authorIdMsig body) invite = do
|
||||
topicInvite grabResource topicComponent stemIdentCtor now topicKey (Verse authorIdMsig body) invite = do
|
||||
|
||||
-- Check invite
|
||||
recipOrProject <- do
|
||||
|
|
@ -1094,10 +1088,9 @@ topicInvite grabActor topicComponent topicField topicCollabField collabTopicCtor
|
|||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(topicActorID, topicActor) <- lift $ do
|
||||
recip <- getJust topicKey
|
||||
let actorID = grabActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
resourceID <- lift $ grabResource <$> getJust topicKey
|
||||
Resource topicActorID <- lift $ getJust resourceID
|
||||
topicActor <- lift $ getJust topicActorID
|
||||
|
||||
case recipOrProjectDB of
|
||||
Left (role, capability, _targetByKey, targetDB) -> do
|
||||
|
|
@ -1110,21 +1103,21 @@ topicInvite grabActor topicComponent topicField topicCollabField collabTopicCtor
|
|||
existingCollabIDs <-
|
||||
lift $ case targetDB of
|
||||
Left (GrantRecipPerson (Entity personID _)) ->
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do
|
||||
E.select $ E.from $ \ (collab `E.InnerJoin` recipl) -> do
|
||||
E.on $
|
||||
topic E.^. topicCollabField E.==.
|
||||
collab E.^. CollabId E.==.
|
||||
recipl E.^. CollabRecipLocalCollab
|
||||
E.where_ $
|
||||
topic E.^. topicField E.==. E.val topicKey E.&&.
|
||||
collab E.^. CollabTopic E.==. E.val resourceID E.&&.
|
||||
recipl E.^. CollabRecipLocalPerson E.==. E.val personID
|
||||
return $ recipl E.^. CollabRecipLocalCollab
|
||||
Right remoteActorID ->
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do
|
||||
E.select $ E.from $ \ (collab `E.InnerJoin` recipr) -> do
|
||||
E.on $
|
||||
topic E.^. topicCollabField E.==.
|
||||
collab E.^. CollabId E.==.
|
||||
recipr E.^. CollabRecipRemoteCollab
|
||||
E.where_ $
|
||||
topic E.^. topicField E.==. E.val topicKey E.&&.
|
||||
collab E.^. CollabTopic E.==. E.val resourceID E.&&.
|
||||
recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID
|
||||
return $ recipr E.^. CollabRecipRemoteCollab
|
||||
case existingCollabIDs of
|
||||
|
|
@ -1146,7 +1139,7 @@ topicInvite grabActor topicComponent topicField topicCollabField collabTopicCtor
|
|||
sieve <- do
|
||||
topicHash <- encodeKeyHashid topicKey
|
||||
let topicByHash =
|
||||
topicResource topicHash
|
||||
resourceToActor $ topicResource topicHash
|
||||
return $ makeRecipientSet [] [localActorFollowers topicByHash]
|
||||
|
||||
-- Insert Collab or Stem record to DB
|
||||
|
|
@ -1155,9 +1148,9 @@ topicInvite grabActor topicComponent topicField topicCollabField collabTopicCtor
|
|||
maybeAccept <- case recipOrProjectDB of
|
||||
Left (role, _capability, targetByKey, targetDB) -> Just <$> do
|
||||
acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
|
||||
insertCollab role targetDB inviteDB acceptID
|
||||
insertCollab resourceID role targetDB inviteDB acceptID
|
||||
accept@(actionAccept, _, _, _) <- lift $ prepareAccept targetByKey
|
||||
let topicByKey = topicResource topicKey
|
||||
let topicByKey = resourceToActor $ topicResource topicKey
|
||||
_luAccept <- updateOutboxItem' topicByKey acceptID actionAccept
|
||||
return (acceptID, accept)
|
||||
Right projectDB -> do
|
||||
|
|
@ -1169,7 +1162,7 @@ topicInvite grabActor topicComponent topicField topicCollabField collabTopicCtor
|
|||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (topicActorID, sieve, maybeAccept) -> do
|
||||
let topicByID = topicResource topicKey
|
||||
let topicByID = resourceToActor $ topicResource topicKey
|
||||
forwardActivity authorIdMsig body topicByID topicActorID sieve
|
||||
lift $ for_ maybeAccept $ \ (acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) ->
|
||||
sendActivity
|
||||
|
|
@ -1179,13 +1172,12 @@ topicInvite grabActor topicComponent topicField topicCollabField collabTopicCtor
|
|||
|
||||
where
|
||||
|
||||
topicResource :: forall f. f topic -> LocalActorBy f
|
||||
topicResource = componentActor . topicComponent
|
||||
topicResource :: forall f. f topic -> LocalResourceBy f
|
||||
topicResource = componentResource . topicComponent
|
||||
|
||||
insertCollab role recipient inviteDB acceptID = do
|
||||
collabID <- insert $ Collab role
|
||||
insertCollab resourceID role recipient inviteDB acceptID = do
|
||||
collabID <- insert $ Collab role resourceID
|
||||
fulfillsID <- insert $ CollabFulfillsInvite collabID acceptID
|
||||
insert_ $ collabTopicCtor collabID topicKey
|
||||
case inviteDB of
|
||||
Left (_, _, inviteID) ->
|
||||
insert_ $ CollabInviterLocal fulfillsID inviteID
|
||||
|
|
@ -1225,8 +1217,7 @@ topicInvite grabActor topicComponent topicField topicCollabField collabTopicCtor
|
|||
Right (ObjURI h lu) -> return $ AudRemote h [lu] []
|
||||
audTopic <-
|
||||
AudLocal [] . pure . localActorFollowers .
|
||||
topicResource <$>
|
||||
encodeKeyHashid topicKey
|
||||
resourceToActor . topicResource <$> encodeKeyHashid topicKey
|
||||
uInvite <- getActivityURI authorIdMsig
|
||||
|
||||
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
|
|
@ -1247,19 +1238,15 @@ topicInvite grabActor topicComponent topicField topicCollabField collabTopicCtor
|
|||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
topicRemove
|
||||
:: ( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic
|
||||
, PersistRecordBackend ct SqlBackend
|
||||
)
|
||||
=> (topic -> ActorId)
|
||||
-> (forall f. f topic -> LocalActorBy f)
|
||||
-> EntityField ct (Key topic)
|
||||
-> EntityField ct CollabId
|
||||
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
||||
=> (topic -> ResourceId)
|
||||
-> (forall f. f topic -> LocalResourceBy f)
|
||||
-> UTCTime
|
||||
-> Key topic
|
||||
-> Verse
|
||||
-> AP.Remove URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
topicRemove grabActor topicResource topicField topicCollabField now topicKey (Verse authorIdMsig body) remove = do
|
||||
topicRemove grabResource topicResource now topicKey (Verse authorIdMsig body) remove = do
|
||||
|
||||
-- Check capability
|
||||
capability <- do
|
||||
|
|
@ -1310,10 +1297,9 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
|
|||
memberByKey
|
||||
|
||||
-- Grab me from DB
|
||||
(topicActorID, topicActor) <- lift $ do
|
||||
recip <- getJust topicKey
|
||||
let actorID = grabActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
resourceID <- lift $ grabResource <$> getJust topicKey
|
||||
Resource topicActorID <- lift $ getJust resourceID
|
||||
topicActor <- lift $ getJust topicActorID
|
||||
|
||||
-- Verify the specified capability gives relevant access
|
||||
verifyCapability'
|
||||
|
|
@ -1323,34 +1309,32 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
|
|||
existingCollabIDs <-
|
||||
lift $ case memberDB of
|
||||
Left (Entity personID _) ->
|
||||
fmap (map $ over _2 Left) $
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do
|
||||
fmap (map $ over _1 Left) $
|
||||
E.select $ E.from $ \ (collab `E.InnerJoin` recipl) -> do
|
||||
E.on $
|
||||
topic E.^. topicCollabField E.==.
|
||||
collab E.^. CollabId E.==.
|
||||
recipl E.^. CollabRecipLocalCollab
|
||||
E.where_ $
|
||||
topic E.^. topicField E.==. E.val topicKey E.&&.
|
||||
collab E.^. CollabTopic E.==. E.val resourceID E.&&.
|
||||
recipl E.^. CollabRecipLocalPerson E.==. E.val personID
|
||||
return
|
||||
( topic E.^. persistIdField
|
||||
, recipl E.^. persistIdField
|
||||
( recipl E.^. persistIdField
|
||||
, recipl E.^. CollabRecipLocalCollab
|
||||
)
|
||||
Right (Entity remoteActorID _, _) ->
|
||||
fmap (map $ over _2 Right) $
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do
|
||||
fmap (map $ over _1 Right) $
|
||||
E.select $ E.from $ \ (collab `E.InnerJoin` recipr) -> do
|
||||
E.on $
|
||||
topic E.^. topicCollabField E.==.
|
||||
collab E.^. CollabId E.==.
|
||||
recipr E.^. CollabRecipRemoteCollab
|
||||
E.where_ $
|
||||
topic E.^. topicField E.==. E.val topicKey E.&&.
|
||||
collab E.^. CollabTopic E.==. E.val resourceID E.&&.
|
||||
recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID
|
||||
return
|
||||
( topic E.^. persistIdField
|
||||
, recipr E.^. persistIdField
|
||||
( recipr E.^. persistIdField
|
||||
, recipr E.^. CollabRecipRemoteCollab
|
||||
)
|
||||
(E.Value topicID, recipID, E.Value collabID) <-
|
||||
(recipID, E.Value collabID) <-
|
||||
case existingCollabIDs of
|
||||
[] -> throwE "Remove object isn't a member of me"
|
||||
[collab] -> return collab
|
||||
|
|
@ -1363,14 +1347,14 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
|
|||
|
||||
-- Verify that at least 1 more enabled Admin collab for me exists
|
||||
otherCollabIDs <-
|
||||
lift $ E.select $ E.from $ \ (topic `E.InnerJoin` enable) -> do
|
||||
lift $ E.select $ E.from $ \ (collab `E.InnerJoin` enable) -> do
|
||||
E.on $
|
||||
topic E.^. topicCollabField E.==.
|
||||
collab E.^. CollabId E.==.
|
||||
enable E.^. CollabEnableCollab
|
||||
E.where_ $
|
||||
topic E.^. topicField E.==. E.val topicKey E.&&.
|
||||
topic E.^. topicCollabField E.!=. E.val collabID
|
||||
return $ topic E.^. topicCollabField
|
||||
collab E.^. CollabTopic E.==. E.val resourceID E.&&.
|
||||
collab E.^. CollabId E.!=. E.val collabID
|
||||
return $ collab E.^. CollabId
|
||||
when (null otherCollabIDs) $
|
||||
throwE "No other admins exist, can't remove"
|
||||
|
||||
|
|
@ -1390,7 +1374,6 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
|
|||
deleteBy $ UniqueCollabRecipRemoteJoinCollab r
|
||||
deleteBy $ UniqueCollabRecipRemoteAcceptCollab r
|
||||
delete r
|
||||
delete topicID
|
||||
fulfills <- do
|
||||
mf <- runMaybeT $ asum
|
||||
[ Left <$> MaybeT (getKeyBy $ UniqueCollabFulfillsLocalTopicCreation collabID)
|
||||
|
|
@ -1413,14 +1396,13 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
|
|||
-- Prepare forwarding Remove to my followers
|
||||
sieve <- lift $ do
|
||||
topicHash <- encodeKeyHashid topicKey
|
||||
let topicByHash =
|
||||
topicResource topicHash
|
||||
let topicByHash = resourceToActor $ topicResource topicHash
|
||||
return $ makeRecipientSet [] [localActorFollowers topicByHash]
|
||||
|
||||
-- Prepare a Revoke activity and insert to my outbox
|
||||
revoke@(actionRevoke, _, _, _) <-
|
||||
lift $ prepareRevoke memberDB grantID
|
||||
let recipByKey = topicResource topicKey
|
||||
let recipByKey = resourceToActor $ topicResource topicKey
|
||||
revokeID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
|
||||
_luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke
|
||||
|
||||
|
|
@ -1429,7 +1411,7 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
|
|||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke)) -> do
|
||||
let topicByID = topicResource topicKey
|
||||
let topicByID = resourceToActor $ topicResource topicKey
|
||||
forwardActivity authorIdMsig body topicByID topicActorID sieve
|
||||
lift $ sendActivity
|
||||
topicByID topicActorID localRecipsRevoke
|
||||
|
|
@ -1443,7 +1425,7 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
|
|||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
||||
recipHash <- encodeKeyHashid topicKey
|
||||
let topicByHash = topicResource recipHash
|
||||
let topicByHash = resourceToActor $ topicResource recipHash
|
||||
|
||||
memberHash <- bitraverse (encodeKeyHashid . entityKey) pure member
|
||||
|
||||
|
|
@ -1479,20 +1461,15 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
|
|||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
topicJoin
|
||||
:: ( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic
|
||||
, PersistRecordBackend ct SqlBackend
|
||||
)
|
||||
=> (topic -> ActorId)
|
||||
-> (forall f. f topic -> LocalActorBy f)
|
||||
-> EntityField ct (Key topic)
|
||||
-> EntityField ct CollabId
|
||||
-> (CollabId -> Key topic -> ct)
|
||||
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
||||
=> (topic -> ResourceId)
|
||||
-> (forall f. f topic -> LocalResourceBy f)
|
||||
-> UTCTime
|
||||
-> Key topic
|
||||
-> Verse
|
||||
-> AP.Join URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor now topicKey (Verse authorIdMsig body) join = do
|
||||
topicJoin grabResource topicResource now topicKey (Verse authorIdMsig body) join = do
|
||||
|
||||
-- Check input
|
||||
(role, resource) <- parseJoin join
|
||||
|
|
@ -1502,32 +1479,31 @@ topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor no
|
|||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(topicActorID, topicActor) <- lift $ do
|
||||
recip <- getJust topicKey
|
||||
let actorID = grabActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
resourceID <- lift $ grabResource <$> getJust topicKey
|
||||
Resource topicActorID <- lift $ getJust resourceID
|
||||
topicActor <- lift $ getJust topicActorID
|
||||
|
||||
-- Verify that target doesn't already have a Collab for me
|
||||
existingCollabIDs <- lift $
|
||||
case authorIdMsig of
|
||||
Left (LocalActorPerson personID, _, _) ->
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do
|
||||
E.select $ E.from $ \ (collab `E.InnerJoin` recipl) -> do
|
||||
E.on $
|
||||
topic E.^. topicCollabField E.==.
|
||||
collab E.^. CollabId E.==.
|
||||
recipl E.^. CollabRecipLocalCollab
|
||||
E.where_ $
|
||||
topic E.^. topicField E.==. E.val topicKey E.&&.
|
||||
collab E.^. CollabTopic E.==. E.val resourceID E.&&.
|
||||
recipl E.^. CollabRecipLocalPerson E.==. E.val personID
|
||||
return $ recipl E.^. CollabRecipLocalCollab
|
||||
Left (_, _, _) -> pure []
|
||||
Right (author, _, _) -> do
|
||||
let targetID = remoteAuthorId author
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do
|
||||
E.select $ E.from $ \ (collab `E.InnerJoin` recipr) -> do
|
||||
E.on $
|
||||
topic E.^. topicCollabField E.==.
|
||||
collab E.^. CollabId E.==.
|
||||
recipr E.^. CollabRecipRemoteCollab
|
||||
E.where_ $
|
||||
topic E.^. topicField E.==. E.val topicKey E.&&.
|
||||
collab E.^. CollabTopic E.==. E.val resourceID E.&&.
|
||||
recipr E.^. CollabRecipRemoteActor E.==. E.val targetID
|
||||
return $ recipr E.^. CollabRecipRemoteCollab
|
||||
case existingCollabIDs of
|
||||
|
|
@ -1548,29 +1524,27 @@ topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor no
|
|||
)
|
||||
pure
|
||||
joinDB
|
||||
lift $ insertCollab role joinDB'
|
||||
lift $ insertCollab resourceID role joinDB'
|
||||
|
||||
-- Prepare forwarding Join to my followers
|
||||
sieve <- lift $ do
|
||||
topicHash <- encodeKeyHashid topicKey
|
||||
let topicByHash =
|
||||
topicResource topicHash
|
||||
let topicByHash = resourceToActor $ topicResource topicHash
|
||||
return $ makeRecipientSet [] [localActorFollowers topicByHash]
|
||||
return (topicActorID, sieve)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (topicActorID, sieve) -> do
|
||||
let topicByID = topicResource topicKey
|
||||
let topicByID = resourceToActor $ topicResource topicKey
|
||||
forwardActivity authorIdMsig body topicByID topicActorID sieve
|
||||
done "Recorded and forwarded the Join"
|
||||
|
||||
where
|
||||
|
||||
insertCollab role joinDB = do
|
||||
collabID <- insert $ Collab role
|
||||
insertCollab resourceID role joinDB = do
|
||||
collabID <- insert $ Collab role resourceID
|
||||
fulfillsID <- insert $ CollabFulfillsJoin collabID
|
||||
insert_ $ collabTopicCtor collabID topicKey
|
||||
case joinDB of
|
||||
Left (personID, joinID) -> do
|
||||
recipID <- insert $ CollabRecipLocal collabID personID
|
||||
|
|
@ -1581,26 +1555,21 @@ topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor no
|
|||
insert_ $ CollabRecipRemoteJoin recipID fulfillsID joinID
|
||||
|
||||
topicCreateMe
|
||||
:: ( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic
|
||||
, PersistRecordBackend ct SqlBackend
|
||||
)
|
||||
=> (topic -> ActorId)
|
||||
-> (forall f. f topic -> LocalActorBy f)
|
||||
-> EntityField ct (Key topic)
|
||||
-> (CollabId -> Key topic -> ct)
|
||||
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
||||
=> (topic -> ResourceId)
|
||||
-> (forall f. f topic -> LocalResourceBy f)
|
||||
-> UTCTime
|
||||
-> Key topic
|
||||
-> Verse
|
||||
-> ActE (Text, Act (), Next)
|
||||
topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now recipKey (Verse authorIdMsig body) = do
|
||||
topicCreateMe grabResource topicResource now recipKey (Verse authorIdMsig body) = do
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(recipActorID, recipActor) <- lift $ do
|
||||
recip <- getJust recipKey
|
||||
let actorID = topicActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
resourceID <- lift $ grabResource <$> getJust recipKey
|
||||
Resource recipActorID <- lift $ getJust resourceID
|
||||
recipActor <- lift $ getJust recipActorID
|
||||
|
||||
-- Verify I'm in the initial just-been-created state
|
||||
creatorActorID <-
|
||||
|
|
@ -1611,7 +1580,7 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
|
|||
mp <- lift $ getKeyBy $ UniquePersonActor creatorActorID
|
||||
fromMaybeE mp "Granting access to local non-Person actors isn't suppported currently"
|
||||
existingCollabIDs <-
|
||||
lift $ selectList [collabTopicFieldTopic ==. recipKey] []
|
||||
lift $ selectList [CollabTopic ==. resourceID] []
|
||||
unless (null existingCollabIDs) $
|
||||
error "Just-been-created but I somehow already have Collabs"
|
||||
|
||||
|
|
@ -1625,12 +1594,12 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
|
|||
|
||||
-- Create a Collab record and exit just-been-created state
|
||||
grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
insertCollab creatorPersonID grantID
|
||||
insertCollab resourceID creatorPersonID grantID
|
||||
update creatorActorID [ActorJustCreatedBy =. Nothing]
|
||||
|
||||
-- Prepare a Grant activity and insert to my outbox
|
||||
grant@(actionGrant, _, _, _) <- lift prepareGrant
|
||||
let recipByKey = topicResource recipKey
|
||||
let recipByKey = resourceToActor $ topicResource recipKey
|
||||
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
|
||||
|
||||
return (recipActorID, grantID, grant)
|
||||
|
|
@ -1638,7 +1607,7 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
|
|||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (recipActorID, grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) -> do
|
||||
let recipByID = topicResource recipKey
|
||||
let recipByID = resourceToActor $ topicResource recipKey
|
||||
lift $ sendActivity
|
||||
recipByID recipActorID localRecipsGrant
|
||||
remoteRecipsGrant fwdHostsGrant grantID actionGrant
|
||||
|
|
@ -1646,9 +1615,8 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
|
|||
|
||||
where
|
||||
|
||||
insertCollab personID grantID = do
|
||||
collabID <- insert $ Collab AP.RoleAdmin
|
||||
insert_ $ collabTopicCtor collabID recipKey
|
||||
insertCollab resourceID personID grantID = do
|
||||
collabID <- insert $ Collab AP.RoleAdmin resourceID
|
||||
insert_ $ CollabEnable collabID grantID
|
||||
insert_ $ CollabRecipLocal collabID personID
|
||||
insert_ $ CollabFulfillsLocalTopicCreation collabID
|
||||
|
|
@ -1661,7 +1629,7 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
|
|||
recipHash <- encodeKeyHashid recipKey
|
||||
uCreator <- getActorURI authorIdMsig
|
||||
uCreate <- getActivityURI authorIdMsig
|
||||
let topicByHash = topicResource recipHash
|
||||
let topicByHash = resourceToActor $ topicResource recipHash
|
||||
audience =
|
||||
let audTopic = AudLocal [] [localActorFollowers topicByHash]
|
||||
in [audCreator, audTopic]
|
||||
|
|
@ -1717,14 +1685,14 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
|
|||
componentGrant
|
||||
:: forall topic.
|
||||
(PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
||||
=> (topic -> ActorId)
|
||||
=> (topic -> ResourceId)
|
||||
-> (forall f. f topic -> ComponentBy f)
|
||||
-> UTCTime
|
||||
-> Key topic
|
||||
-> Verse
|
||||
-> AP.Grant URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
componentGrant grabActor topicComponent now recipKey (Verse authorIdMsig body) grant = do
|
||||
componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body) grant = do
|
||||
|
||||
-- Check grant
|
||||
project <- checkDelegatorGrant grant
|
||||
|
|
@ -1740,10 +1708,9 @@ componentGrant grabActor topicComponent now recipKey (Verse authorIdMsig body) g
|
|||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(recipActorID, recipActor) <- lift $ do
|
||||
recip <- getJust recipKey
|
||||
let actorID = grabActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
resourceID <- lift $ grabResource <$> getJust recipKey
|
||||
Resource recipActorID <- lift $ getJust resourceID
|
||||
recipActor <- lift $ getJust recipActorID
|
||||
|
||||
-- Find the fulfilled activity in our DB
|
||||
fulfillsDB <- do
|
||||
|
|
@ -1798,8 +1765,7 @@ componentGrant grabActor topicComponent now recipKey (Verse authorIdMsig body) g
|
|||
-- Prepare forwarding to my followers
|
||||
sieve <- do
|
||||
recipHash <- encodeKeyHashid recipKey
|
||||
let recipByHash =
|
||||
topicResource recipHash
|
||||
let recipByHash = resourceToActor $ topicResource recipHash
|
||||
return $ makeRecipientSet [] [localActorFollowers recipByHash]
|
||||
|
||||
-- Update the Stem record in DB
|
||||
|
|
@ -1814,7 +1780,7 @@ componentGrant grabActor topicComponent now recipKey (Verse authorIdMsig body) g
|
|||
chain <- do
|
||||
Stem role <- getJust stemID
|
||||
chain@(actionChain, _, _, _) <- prepareChain role
|
||||
let recipByKey = topicResource recipKey
|
||||
let recipByKey = resourceToActor $ topicResource recipKey
|
||||
_luChain <- updateOutboxItem' recipByKey chainID actionChain
|
||||
return chain
|
||||
|
||||
|
|
@ -1823,7 +1789,7 @@ componentGrant grabActor topicComponent now recipKey (Verse authorIdMsig body) g
|
|||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (recipActorID, sieve, chainID, (actionChain, localRecipsChain, remoteRecipsChain, fwdHostsChain)) -> do
|
||||
let recipByID = topicResource recipKey
|
||||
let recipByID = resourceToActor $ topicResource recipKey
|
||||
forwardActivity authorIdMsig body recipByID recipActorID sieve
|
||||
lift $ sendActivity
|
||||
recipByID recipActorID localRecipsChain remoteRecipsChain
|
||||
|
|
@ -1832,8 +1798,8 @@ componentGrant grabActor topicComponent now recipKey (Verse authorIdMsig body) g
|
|||
|
||||
where
|
||||
|
||||
topicResource :: forall f. f topic -> LocalActorBy f
|
||||
topicResource = componentActor . topicComponent
|
||||
topicResource :: forall f. f topic -> LocalResourceBy f
|
||||
topicResource = componentResource . topicComponent
|
||||
|
||||
checkDelegatorGrant g = do
|
||||
(role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <-
|
||||
|
|
@ -1854,7 +1820,7 @@ componentGrant grabActor topicComponent now recipKey (Verse authorIdMsig body) g
|
|||
(Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure ()
|
||||
_ -> throwE "Author and resource aren't the same project actor"
|
||||
case recipient of
|
||||
Left la | topicResource recipKey == la -> pure ()
|
||||
Left la | resourceToActor (topicResource recipKey) == la -> pure ()
|
||||
_ -> throwE "Grant recipient isn't me"
|
||||
for_ mstart $ \ start ->
|
||||
unless (start < now) $ throwE "Start time is in the future"
|
||||
|
|
@ -1895,12 +1861,11 @@ componentGrant grabActor topicComponent now recipKey (Verse authorIdMsig body) g
|
|||
audProject <- makeAudSenderWithFollowers authorIdMsig
|
||||
audMe <-
|
||||
AudLocal [] . pure . localActorFollowers .
|
||||
topicResource <$>
|
||||
encodeKeyHashid recipKey
|
||||
resourceToActor . topicResource <$> encodeKeyHashid recipKey
|
||||
uProject <- lift $ getActorURI authorIdMsig
|
||||
uGrant <- lift $ getActivityURI authorIdMsig
|
||||
recipHash <- encodeKeyHashid recipKey
|
||||
let topicByHash = topicResource recipHash
|
||||
let topicByHash = resourceToActor $ topicResource recipHash
|
||||
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audProject, audMe]
|
||||
|
|
|
|||
|
|
@ -195,7 +195,7 @@ deckAdd now deckID (Verse authorIdMsig body) add = do
|
|||
|
||||
-- Verify the specified capability gives relevant access
|
||||
verifyCapability'
|
||||
capability authorIdMsig (LocalActorDeck deckID) AP.RoleAdmin
|
||||
capability authorIdMsig (LocalResourceDeck deckID) AP.RoleAdmin
|
||||
|
||||
-- Insert the Add to my inbox
|
||||
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actor) False
|
||||
|
|
@ -294,9 +294,7 @@ deckCreateMe
|
|||
-> DeckId
|
||||
-> Verse
|
||||
-> ActE (Text, Act (), Next)
|
||||
deckCreateMe =
|
||||
topicCreateMe
|
||||
deckActor LocalActorDeck CollabTopicDeckDeck CollabTopicDeck
|
||||
deckCreateMe = topicCreateMe deckResource LocalResourceDeck
|
||||
|
||||
deckCreate
|
||||
:: UTCTime
|
||||
|
|
@ -395,7 +393,7 @@ deckOffer now deckID (Verse authorIdMsig body) (AP.Offer object uTarget) = do
|
|||
verifyCapability'
|
||||
lcap
|
||||
authorIdMsig
|
||||
(LocalActorDeck deckID)
|
||||
(LocalResourceDeck deckID)
|
||||
AP.RoleReport
|
||||
|
||||
-- Prepare forwarding the Offer to my followers
|
||||
|
|
@ -532,7 +530,7 @@ deckResolve now deckID (Verse authorIdMsig body) (AP.Resolve uObject) = do
|
|||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
(LocalActorDeck deckID)
|
||||
(LocalResourceDeck deckID)
|
||||
AP.RoleTriage
|
||||
|
||||
{-
|
||||
|
|
@ -748,7 +746,7 @@ deckAccept
|
|||
-> Verse
|
||||
-> AP.Accept URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
deckAccept = topicAccept deckActor ComponentDeck
|
||||
deckAccept = topicAccept deckResource ComponentDeck
|
||||
|
||||
-- Meaning: An actor rejected something
|
||||
-- Behavior:
|
||||
|
|
@ -773,7 +771,7 @@ deckReject
|
|||
-> Verse
|
||||
-> AP.Reject URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
deckReject = topicReject deckActor LocalActorDeck
|
||||
deckReject = topicReject deckResource LocalResourceDeck
|
||||
|
||||
-- Meaning: An actor A invited actor B to a resource
|
||||
-- Behavior:
|
||||
|
|
@ -802,11 +800,7 @@ deckInvite
|
|||
-> Verse
|
||||
-> AP.Invite URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
deckInvite =
|
||||
topicInvite
|
||||
deckActor ComponentDeck
|
||||
CollabTopicDeckDeck CollabTopicDeckCollab
|
||||
CollabTopicDeck StemIdentDeck
|
||||
deckInvite = topicInvite deckResource ComponentDeck StemIdentDeck
|
||||
|
||||
-- Meaning: An actor A is removing actor B from a resource
|
||||
-- Behavior:
|
||||
|
|
@ -825,10 +819,7 @@ deckRemove
|
|||
-> Verse
|
||||
-> AP.Remove URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
deckRemove =
|
||||
topicRemove
|
||||
deckActor LocalActorDeck
|
||||
CollabTopicDeckDeck CollabTopicDeckCollab
|
||||
deckRemove = topicRemove deckResource LocalResourceDeck
|
||||
|
||||
-- Meaning: An actor A asked to join a resource
|
||||
-- Behavior:
|
||||
|
|
@ -842,10 +833,7 @@ deckJoin
|
|||
-> Verse
|
||||
-> AP.Join URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
deckJoin =
|
||||
topicJoin
|
||||
deckActor LocalActorDeck
|
||||
CollabTopicDeckDeck CollabTopicDeckCollab CollabTopicDeck
|
||||
deckJoin = topicJoin deckResource LocalResourceDeck
|
||||
|
||||
-- Meaning: An actor is granting access-to-some-resource to another actor
|
||||
-- Behavior:
|
||||
|
|
@ -877,7 +865,7 @@ deckGrant
|
|||
-> Verse
|
||||
-> AP.Grant URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
deckGrant = componentGrant deckActor ComponentDeck
|
||||
deckGrant = componentGrant deckResource ComponentDeck
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Ambiguous: Following/Resolving
|
||||
|
|
@ -1018,7 +1006,7 @@ deckUndo now recipDeckID (Verse authorIdMsig body) (AP.Undo uObject) = do
|
|||
verifyCapability'
|
||||
capability
|
||||
authorIdMsig
|
||||
(LocalActorDeck recipDeckID)
|
||||
(LocalResourceDeck recipDeckID)
|
||||
AP.RoleTriage
|
||||
|
||||
lift $ lift deleteFromDB
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -180,7 +180,7 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
|
|||
verifyCapability'
|
||||
capability
|
||||
authorIdMsig
|
||||
(LocalActorGroup groupID)
|
||||
(LocalResourceGroup groupID)
|
||||
AP.RoleAdmin
|
||||
return fulfillsID
|
||||
)
|
||||
|
|
@ -229,7 +229,7 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
|
|||
-- In collab mode, prepare a regular Grant
|
||||
let isInvite = isLeft collab
|
||||
grant@(actionGrant, _, _, _) <- do
|
||||
Collab role <- getJust collabID
|
||||
Collab role _ <- getJust collabID
|
||||
prepareCollabGrant isInvite inviterOrJoiner role
|
||||
let recipByKey = LocalActorGroup groupID
|
||||
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
|
||||
|
|
@ -252,7 +252,7 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
|
|||
|
||||
verifyCollabTopic collabID = do
|
||||
topic <- lift $ getCollabTopic collabID
|
||||
unless (LocalActorGroup groupID == topic) $
|
||||
unless (LocalResourceGroup groupID == topic) $
|
||||
throwE "Accept object is an Invite/Join for some other resource"
|
||||
|
||||
verifyInviteCollabTopic fulfillsID = do
|
||||
|
|
@ -376,10 +376,7 @@ groupCreateMe
|
|||
-> GroupId
|
||||
-> Verse
|
||||
-> ActE (Text, Act (), Next)
|
||||
groupCreateMe =
|
||||
topicCreateMe
|
||||
groupActor LocalActorGroup
|
||||
CollabTopicGroupGroup CollabTopicGroup
|
||||
groupCreateMe = topicCreateMe groupResource LocalResourceGroup
|
||||
|
||||
groupCreate
|
||||
:: UTCTime
|
||||
|
|
@ -526,9 +523,9 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
|
|||
throwE "Capability isn't mine"
|
||||
m <- lift $ getBy $ UniqueCollabEnableGrant $ snd capability
|
||||
fromMaybeE m "I don't have a Collab with this capability"
|
||||
Collab role <- lift $ getJust collabID
|
||||
Collab role _ <- lift $ getJust collabID
|
||||
topic <- lift $ getCollabTopic collabID
|
||||
unless (topic == LocalActorGroup groupID) $
|
||||
unless (topic == LocalResourceGroup groupID) $
|
||||
throwE "Found a Collab for this direct-Grant but it's not mine"
|
||||
recip <- lift $ getCollabRecip collabID
|
||||
recipForCheck <-
|
||||
|
|
@ -628,7 +625,7 @@ groupInvite now groupID (Verse authorIdMsig body) invite = do
|
|||
(role, resourceOrComps, recipientOrComp) <- parseInvite author invite
|
||||
mode <-
|
||||
case resourceOrComps of
|
||||
Left (Left (LocalActorGroup j)) | j == groupID ->
|
||||
Left (Left (LocalResourceGroup j)) | j == groupID ->
|
||||
bitraverse
|
||||
(\case
|
||||
Left r -> pure r
|
||||
|
|
@ -657,17 +654,16 @@ groupInvite now groupID (Verse authorIdMsig body) invite = do
|
|||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(topicActorID, topicActor) <- lift $ do
|
||||
recip <- getJust groupID
|
||||
let actorID = groupActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
resourceID <- lift $ groupResource <$> getJust groupID
|
||||
Resource topicActorID <- lift $ getJust resourceID
|
||||
topicActor <- lift $ getJust topicActorID
|
||||
|
||||
-- Verify the specified capability gives relevant access
|
||||
verifyCapability'
|
||||
capability authorIdMsig (LocalActorGroup groupID) AP.RoleAdmin
|
||||
capability authorIdMsig (LocalResourceGroup groupID) AP.RoleAdmin
|
||||
|
||||
-- Verify that target doesn't already have a Collab for me
|
||||
existingCollabIDs <- lift $ getExistingCollabs invitedDB
|
||||
existingCollabIDs <- lift $ getExistingCollabs resourceID invitedDB
|
||||
case existingCollabIDs of
|
||||
[] -> pure ()
|
||||
[_] -> throwE "I already have a Collab for the target"
|
||||
|
|
@ -678,7 +674,7 @@ groupInvite now groupID (Verse authorIdMsig body) invite = do
|
|||
|
||||
-- Insert Collab or Component record to DB
|
||||
acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
|
||||
insertCollab role invitedDB inviteDB acceptID
|
||||
insertCollab resourceID role invitedDB inviteDB acceptID
|
||||
|
||||
-- Prepare forwarding Invite to my followers
|
||||
sieve <- do
|
||||
|
|
@ -715,29 +711,28 @@ groupInvite now groupID (Verse authorIdMsig body) invite = do
|
|||
Right Nothing -> throwE "Target isn't an actor"
|
||||
Right (Just actor) -> return $ entityKey actor
|
||||
|
||||
getExistingCollabs (Left (GrantRecipPerson (Entity personID _))) =
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do
|
||||
getExistingCollabs resourceID (Left (GrantRecipPerson (Entity personID _))) =
|
||||
E.select $ E.from $ \ (collab `E.InnerJoin` recipl) -> do
|
||||
E.on $
|
||||
topic E.^. CollabTopicGroupCollab E.==.
|
||||
collab E.^. CollabId E.==.
|
||||
recipl E.^. CollabRecipLocalCollab
|
||||
E.where_ $
|
||||
topic E.^. CollabTopicGroupGroup E.==. E.val groupID E.&&.
|
||||
collab E.^. CollabTopic E.==. E.val resourceID E.&&.
|
||||
recipl E.^. CollabRecipLocalPerson E.==. E.val personID
|
||||
return $ recipl E.^. CollabRecipLocalCollab
|
||||
getExistingCollabs (Right remoteActorID) =
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do
|
||||
getExistingCollabs resourceID (Right remoteActorID) =
|
||||
E.select $ E.from $ \ (collab `E.InnerJoin` recipr) -> do
|
||||
E.on $
|
||||
topic E.^. CollabTopicGroupCollab E.==.
|
||||
collab E.^. CollabId E.==.
|
||||
recipr E.^. CollabRecipRemoteCollab
|
||||
E.where_ $
|
||||
topic E.^. CollabTopicGroupGroup E.==. E.val groupID E.&&.
|
||||
collab E.^. CollabTopic E.==. E.val resourceID E.&&.
|
||||
recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID
|
||||
return $ recipr E.^. CollabRecipRemoteCollab
|
||||
|
||||
insertCollab role recipient inviteDB acceptID = do
|
||||
collabID <- insert $ Collab role
|
||||
insertCollab resourceID role recipient inviteDB acceptID = do
|
||||
collabID <- insert $ Collab role resourceID
|
||||
fulfillsID <- insert $ CollabFulfillsInvite collabID acceptID
|
||||
insert_ $ CollabTopicGroup collabID groupID
|
||||
case inviteDB of
|
||||
Left (_, _, inviteID) ->
|
||||
insert_ $ CollabInviterLocal fulfillsID inviteID
|
||||
|
|
@ -797,10 +792,7 @@ groupJoin
|
|||
-> Verse
|
||||
-> AP.Join URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
groupJoin =
|
||||
topicJoin
|
||||
groupActor LocalActorGroup
|
||||
CollabTopicGroupGroup CollabTopicGroupCollab CollabTopicGroup
|
||||
groupJoin = topicJoin groupResource LocalResourceGroup
|
||||
|
||||
-- Meaning: An actor rejected something
|
||||
-- Behavior:
|
||||
|
|
@ -825,7 +817,7 @@ groupReject
|
|||
-> Verse
|
||||
-> AP.Reject URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
groupReject = topicReject groupActor LocalActorGroup
|
||||
groupReject = topicReject groupResource LocalResourceGroup
|
||||
|
||||
-- Meaning: An actor A is removing actor B from a resource
|
||||
-- Behavior:
|
||||
|
|
@ -844,10 +836,7 @@ groupRemove
|
|||
-> Verse
|
||||
-> AP.Remove URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
groupRemove =
|
||||
topicRemove
|
||||
groupActor LocalActorGroup
|
||||
CollabTopicGroupGroup CollabTopicGroupCollab
|
||||
groupRemove = topicRemove groupResource LocalResourceGroup
|
||||
|
||||
-- Meaning: An actor is undoing some previous action
|
||||
-- Behavior:
|
||||
|
|
|
|||
|
|
@ -279,7 +279,7 @@ loomOffer now loomID (Verse authorIdMsig body) (AP.Offer object uTarget) = do
|
|||
verifyCapability'
|
||||
lcap
|
||||
authorIdMsig
|
||||
(LocalActorLoom loomID)
|
||||
(LocalResourceLoom loomID)
|
||||
AP.RoleReport
|
||||
|
||||
-- Prepare forwarding the Offer to my followers
|
||||
|
|
@ -485,7 +485,7 @@ loomResolve now loomID (Verse authorIdMsig body) (AP.Resolve uObject) = do
|
|||
verifyCapability'
|
||||
capability
|
||||
authorIdMsig
|
||||
(LocalActorLoom loomID)
|
||||
(LocalResourceLoom loomID)
|
||||
AP.RoleTriage
|
||||
|
||||
-- Prepare forwarding the Resolve to my followers & ticket
|
||||
|
|
|
|||
|
|
@ -413,7 +413,7 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do
|
|||
|
||||
-- Verify topic is the Accept sender
|
||||
case (bimap snd snd topic, bimap (view _1) (view _1) acceptDB) of
|
||||
(Left la, Left la') | la == la' -> pure ()
|
||||
(Left la, Left la') | resourceToActor la == la' -> pure ()
|
||||
(Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
|
||||
_ -> throwE "Accept sender isn't the Invite topic"
|
||||
|
||||
|
|
@ -641,7 +641,7 @@ personInvite now recipPersonID (Verse authorIdMsig body) invite = do
|
|||
case resource of
|
||||
Left r ->
|
||||
case r of
|
||||
Left la -> withDBExcept $ Just . (role,) . Left <$> getLocalActorEntityE la "Invite resource not found in DB"
|
||||
Left lr -> withDBExcept $ Just . (role,) . Left <$> getLocalResourceEntityE lr "Invite resource not found in DB"
|
||||
Right _j -> pure Nothing
|
||||
Right u@(ObjURI h luColl) -> do
|
||||
manager <- asksEnv envHttpManager
|
||||
|
|
@ -679,7 +679,7 @@ personInvite now recipPersonID (Verse authorIdMsig body) invite = do
|
|||
-- mode
|
||||
checkExistingPermits
|
||||
recipPersonID
|
||||
(bimap (bmap entityKey) (view _2) resourceDB)
|
||||
(bimap localResourceID (view _2) resourceDB)
|
||||
|
||||
-- Prepare forwarding Invite to my followers
|
||||
recipPersonHash <- encodeKeyHashid recipPersonID
|
||||
|
|
@ -710,15 +710,7 @@ personInvite now recipPersonID (Verse authorIdMsig body) invite = do
|
|||
insertPermit resourceDB inviteDB role = do
|
||||
permitID <- lift $ insert $ Permit recipPersonID role
|
||||
case resourceDB of
|
||||
Left la -> do
|
||||
localID <- lift $ insert $ PermitTopicLocal permitID
|
||||
case bmap entityKey la of
|
||||
LocalActorPerson _ -> throwE "insertPermit: Person not supported as a PermitTopicLocal type (you can't become a \"collaborator in a person\""
|
||||
LocalActorRepo r -> lift $ insert_ $ PermitTopicRepo localID r
|
||||
LocalActorDeck d -> lift $ insert_ $ PermitTopicDeck localID d
|
||||
LocalActorLoom l -> lift $ insert_ $ PermitTopicLoom localID l
|
||||
LocalActorProject j -> lift $ insert_ $ PermitTopicProject localID j
|
||||
LocalActorGroup g -> lift $ insert_ $ PermitTopicGroup localID g
|
||||
Left lr -> lift $ insert_ $ PermitTopicLocal permitID (localResourceID lr)
|
||||
Right (_, actorID, _) -> lift $ insert_ $ PermitTopicRemote permitID actorID
|
||||
lift $ do
|
||||
fulfillsID <- insert $ PermitFulfillsInvite permitID
|
||||
|
|
@ -965,7 +957,7 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
|
|||
|
||||
-- Verify the Grant sender is the Permit topic
|
||||
case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of
|
||||
(Left la, Left la') | la == la' -> pure ()
|
||||
(Left la, Left la') | resourceToActor la == la' -> pure ()
|
||||
(Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
|
||||
_ -> throwE "Grant sender isn't the Permit topic"
|
||||
|
||||
|
|
@ -980,7 +972,7 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
|
|||
-- Verify the Grant sender is the Permit topic
|
||||
topic <- lift $ getPermitTopic permitID
|
||||
case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of
|
||||
(Left la, Left la') | la == la' -> pure ()
|
||||
(Left la, Left la') | resourceToActor la == la' -> pure ()
|
||||
(Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
|
||||
_ -> throwE "Grant sender isn't the Permit topic"
|
||||
|
||||
|
|
@ -1198,7 +1190,7 @@ personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke lus) = do
|
|||
lift $ do
|
||||
topic <- lift $ getPermitTopic permitID
|
||||
case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of
|
||||
(Left la, Left la') | la == la' -> pure ()
|
||||
(Left la, Left la') | resourceToActor la == la' -> pure ()
|
||||
(Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
|
||||
_ -> throwE "Revoke sender isn't the Permit topic"
|
||||
|
||||
|
|
@ -1222,7 +1214,7 @@ personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke lus) = do
|
|||
lift $ do
|
||||
topic <- lift $ getPermitTopic permitID
|
||||
case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of
|
||||
(Left la, Left la') | la == la' -> pure ()
|
||||
(Left la, Left la') | resourceToActor la == la' -> pure ()
|
||||
(Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
|
||||
_ -> throwE "Revoke sender isn't the Permit topic"
|
||||
|
||||
|
|
@ -1267,13 +1259,7 @@ personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke lus) = do
|
|||
deleteBy $ UniquePermitFulfillsInvite permitID
|
||||
deleteBy $ UniquePermitFulfillsJoin permitID
|
||||
case topicAndEnable of
|
||||
Left (topicID, _) -> do
|
||||
deleteBy $ UniquePermitTopicRepo topicID
|
||||
deleteBy $ UniquePermitTopicDeck topicID
|
||||
deleteBy $ UniquePermitTopicLoom topicID
|
||||
deleteBy $ UniquePermitTopicProject topicID
|
||||
deleteBy $ UniquePermitTopicGroup topicID
|
||||
delete topicID
|
||||
Left (topicID, _) -> delete topicID
|
||||
Right (topicID, _) -> delete topicID
|
||||
delete permitID
|
||||
)
|
||||
|
|
|
|||
|
|
@ -261,7 +261,7 @@ clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts a
|
|||
-- our DB.
|
||||
targetDB <-
|
||||
bitraverse
|
||||
(withDBExcept . flip getLocalActorEntityE "Local target not found in DB" . addTargetActor)
|
||||
(withDBExcept . flip getLocalResourceEntityE "Local target not found in DB" . addTargetResource)
|
||||
(\ u@(ObjURI h luComps) -> do
|
||||
manager <- asksEnv envHttpManager
|
||||
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luComps
|
||||
|
|
@ -302,7 +302,7 @@ clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts a
|
|||
|
||||
-- Verify that target and object are addressed by the Add
|
||||
bitraverse_
|
||||
(verifyActorAddressed localRecips . bmap entityKey)
|
||||
(verifyActorAddressed localRecips . bmap entityKey . resourceToActor)
|
||||
(\ (_, _, u) -> verifyRemoteAddressed remoteRecips u)
|
||||
targetDB
|
||||
bitraverse_
|
||||
|
|
@ -323,7 +323,7 @@ clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts a
|
|||
|
||||
-- Prepare local recipients for Add delivery
|
||||
sieve <- lift $ do
|
||||
targetHash <- bitraverse (hashLocalActor . addTargetActor) pure target
|
||||
targetHash <- bitraverse (hashLocalActor . resourceToActor . addTargetResource) pure target
|
||||
objectHash <- bitraverse hashLocalActor pure object
|
||||
senderHash <- encodeKeyHashid personMeID
|
||||
let sieveActors = catMaybes
|
||||
|
|
@ -385,14 +385,13 @@ clientCreateDeck now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd
|
|||
-- Insert new deck to DB
|
||||
createID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
|
||||
wid <- findWorkflow
|
||||
(deckID, deckFollowerSetID) <-
|
||||
(deckID, resourceID, deckFollowerSetID) <-
|
||||
lift $ insertDeck now name msummary createID wid actorMeID
|
||||
|
||||
-- Insert a Permit record
|
||||
lift $ do
|
||||
permitID <- insert $ Permit personMeID AP.RoleAdmin
|
||||
topicID <- insert $ PermitTopicLocal permitID
|
||||
insert_ $ PermitTopicDeck topicID deckID
|
||||
topicID <- insert $ PermitTopicLocal permitID resourceID
|
||||
insert_ $ PermitFulfillsTopicCreation permitID
|
||||
insert_ $ PermitPersonGesture permitID createID
|
||||
|
||||
|
|
@ -482,7 +481,7 @@ clientCreateDeck now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd
|
|||
, deckWiki = Nothing
|
||||
, deckCreate = obiidCreate
|
||||
}
|
||||
return (did, fsid)
|
||||
return (did, rid, fsid)
|
||||
|
||||
prepareCreate name msummary deckHash = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
|
@ -560,13 +559,12 @@ clientCreateProject now personMeID (ClientMsg maybeCap localRecips remoteRecips
|
|||
|
||||
-- Insert new project to DB
|
||||
createID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
|
||||
(projectID, projectFollowerSetID) <-
|
||||
(projectID, resourceID, projectFollowerSetID) <-
|
||||
insertProject now name msummary createID actorMeID
|
||||
|
||||
-- Insert a Permit record
|
||||
permitID <- insert $ Permit personMeID AP.RoleAdmin
|
||||
topicID <- insert $ PermitTopicLocal permitID
|
||||
insert_ $ PermitTopicProject topicID projectID
|
||||
topicID <- insert $ PermitTopicLocal permitID resourceID
|
||||
insert_ $ PermitFulfillsTopicCreation permitID
|
||||
insert_ $ PermitPersonGesture permitID createID
|
||||
|
||||
|
|
@ -649,7 +647,7 @@ clientCreateProject now personMeID (ClientMsg maybeCap localRecips remoteRecips
|
|||
, projectResource = rid
|
||||
, projectCreate = obiidCreate
|
||||
}
|
||||
return (did, fsid)
|
||||
return (did, rid, fsid)
|
||||
|
||||
prepareCreate name msummary projectHash = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
|
@ -727,13 +725,12 @@ clientCreateTeam now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd
|
|||
|
||||
-- Insert new team to DB
|
||||
createID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
|
||||
(groupID, projectFollowerSetID) <-
|
||||
(groupID, resourceID, projectFollowerSetID) <-
|
||||
insertTeam now name msummary createID actorMeID
|
||||
|
||||
-- Insert a Permit record
|
||||
permitID <- insert $ Permit personMeID AP.RoleAdmin
|
||||
topicID <- insert $ PermitTopicLocal permitID
|
||||
insert_ $ PermitTopicGroup topicID groupID
|
||||
topicID <- insert $ PermitTopicLocal permitID resourceID
|
||||
insert_ $ PermitFulfillsTopicCreation permitID
|
||||
insert_ $ PermitPersonGesture permitID createID
|
||||
|
||||
|
|
@ -816,7 +813,7 @@ clientCreateTeam now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd
|
|||
, groupResource = rid
|
||||
, groupCreate = obiidCreate
|
||||
}
|
||||
return (gid, fsid)
|
||||
return (gid, rid, fsid)
|
||||
|
||||
prepareCreate name msummary groupHash = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
|
@ -922,7 +919,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
|
|||
resourceDB <-
|
||||
bitraverse
|
||||
(bitraverse
|
||||
(withDBExcept . flip getLocalActorEntityE "Grant resource not found in DB")
|
||||
(withDBExcept . flip getLocalResourceEntityE "Grant resource not found in DB")
|
||||
(withDBExcept . flip getEntityE "Grant context project not found in DB")
|
||||
)
|
||||
(\ u@(ObjURI h luColl) -> do
|
||||
|
|
@ -971,7 +968,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
|
|||
-- Verify that resource and recipient are addressed by the Invite
|
||||
bitraverse_
|
||||
(bitraverse_
|
||||
(verifyActorAddressed localRecips . bmap entityKey)
|
||||
(verifyActorAddressed localRecips . bmap entityKey . resourceToActor)
|
||||
(verifyProjectAddressed localRecips . entityKey)
|
||||
)
|
||||
(\ (_, _, u) -> verifyRemoteAddressed remoteRecips u)
|
||||
|
|
@ -997,7 +994,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
|
|||
|
||||
-- Prepare local recipients for Invite delivery
|
||||
sieve <- lift $ do
|
||||
resourceHash <- bitraverse (bitraverse hashLocalActor encodeKeyHashid) pure resource
|
||||
resourceHash <- bitraverse (bitraverse (hashLocalActor . resourceToActor) encodeKeyHashid) pure resource
|
||||
recipientHash <- bitraverse (bitraverse hashGrantRecip hashComponent) pure recipient
|
||||
senderHash <- encodeKeyHashid personMeID
|
||||
let sieveActors = catMaybes
|
||||
|
|
@ -1007,7 +1004,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
|
|||
Right _ -> Nothing
|
||||
, case recipientHash of
|
||||
Left (Left (GrantRecipPerson p)) -> Just $ LocalActorPerson p
|
||||
Left (Right c) -> Just $ componentActor c
|
||||
Left (Right c) -> Just $ resourceToActor $ componentResource c
|
||||
Right _ -> Nothing
|
||||
]
|
||||
sieveStages = catMaybes
|
||||
|
|
@ -1018,7 +1015,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
|
|||
Right _ -> Nothing
|
||||
, case recipientHash of
|
||||
Left (Left (GrantRecipPerson p)) -> Just $ LocalStagePersonFollowers p
|
||||
Left (Right c) -> Just $ localActorFollowers $ componentActor c
|
||||
Left (Right c) -> Just $ localActorFollowers $ resourceToActor $ componentResource c
|
||||
Right _ -> Nothing
|
||||
]
|
||||
return $ makeRecipientSet sieveActors sieveStages
|
||||
|
|
@ -1073,7 +1070,7 @@ clientJoin now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts
|
|||
-- our DB.
|
||||
resourceDB <-
|
||||
bitraverse
|
||||
(withDBExcept . flip getLocalActorEntityE "Join resource not found in DB")
|
||||
(withDBExcept . flip getLocalResourceEntityE "Join resource not found in DB")
|
||||
(\ u@(ObjURI h luColl) -> do
|
||||
manager <- asksEnv envHttpManager
|
||||
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
||||
|
|
@ -1098,7 +1095,7 @@ clientJoin now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts
|
|||
|
||||
-- Verify that resource is addressed by the Join
|
||||
bitraverse_
|
||||
(verifyActorAddressed localRecips . bmap entityKey)
|
||||
(verifyActorAddressed localRecips . bmap entityKey . resourceToActor)
|
||||
(\ (_, _, u, _) -> verifyRemoteAddressed remoteRecips u)
|
||||
resourceDB
|
||||
|
||||
|
|
@ -1126,14 +1123,14 @@ clientJoin now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts
|
|||
-- mode
|
||||
checkExistingPermits
|
||||
personMeID
|
||||
(bimap (bmap entityKey) (view _2) topicDB)
|
||||
(bimap localResourceID (view _2) topicDB)
|
||||
|
||||
-- Insert Permit record to DB
|
||||
insertPermit topicDB joinID role
|
||||
|
||||
-- Prepare local recipients for Join delivery
|
||||
sieve <- lift $ do
|
||||
resourceHash <- bitraverse hashLocalActor pure resource
|
||||
resourceHash <- bitraverse (hashLocalActor . resourceToActor) pure resource
|
||||
senderHash <- encodeKeyHashid personMeID
|
||||
let sieveActors = catMaybes
|
||||
[ case resourceHash of
|
||||
|
|
@ -1163,15 +1160,7 @@ clientJoin now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts
|
|||
insertPermit resourceDB joinID role = do
|
||||
permitID <- lift $ insert $ Permit personMeID role
|
||||
case resourceDB of
|
||||
Left la -> do
|
||||
localID <- lift $ insert $ PermitTopicLocal permitID
|
||||
case bmap entityKey la of
|
||||
LocalActorPerson _ -> throwE "insertPermit: Person not supported as a PermitTopicLocal type (you can't become a \"collaborator in a person\""
|
||||
LocalActorRepo r -> lift $ insert_ $ PermitTopicRepo localID r
|
||||
LocalActorDeck d -> lift $ insert_ $ PermitTopicDeck localID d
|
||||
LocalActorLoom l -> lift $ insert_ $ PermitTopicLoom localID l
|
||||
LocalActorProject j -> lift $ insert_ $ PermitTopicProject localID j
|
||||
LocalActorGroup g -> lift $ insert_ $ PermitTopicGroup localID g
|
||||
Left lr -> lift $ insert_ $ PermitTopicLocal permitID (localResourceID lr)
|
||||
Right (_, actorID, _) -> lift $ insert_ $ PermitTopicRemote permitID actorID
|
||||
lift $ do
|
||||
insert_ $ PermitFulfillsJoin permitID
|
||||
|
|
@ -1286,7 +1275,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
|
|||
-- If resource collabs is remote, HTTP GET it to determine resource
|
||||
resource' <-
|
||||
bitraverse
|
||||
(pure . either id addTargetActor)
|
||||
(pure . either id addTargetResource)
|
||||
(\ (ObjURI h luColl) -> do
|
||||
manager <- asksEnv envHttpManager
|
||||
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
||||
|
|
@ -1300,7 +1289,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
|
|||
|
||||
-- Verify that resource is addressed by the Remove
|
||||
bitraverse_
|
||||
(verifyActorAddressed localRecips)
|
||||
(verifyActorAddressed localRecips . resourceToActor)
|
||||
(verifyRemoteAddressed remoteRecips)
|
||||
resource'
|
||||
|
||||
|
|
@ -1315,7 +1304,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
|
|||
-- If resource is local, find it in our DB
|
||||
_resourceDB <-
|
||||
bitraverse
|
||||
(flip getLocalActorEntityE "Resource not found in DB")
|
||||
(flip getLocalResourceEntityE "Resource not found in DB")
|
||||
pure
|
||||
resource'
|
||||
|
||||
|
|
@ -1337,7 +1326,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
|
|||
|
||||
-- Prepare local recipients for Remove delivery
|
||||
sieve <- lift $ do
|
||||
resourceHash <- bitraverse hashLocalActor pure resource'
|
||||
resourceHash <- bitraverse (hashLocalActor . resourceToActor) pure resource'
|
||||
recipientHash <- bitraverse hashLocalActor pure member
|
||||
senderHash <- encodeKeyHashid personMeID
|
||||
let sieveActors = catMaybes
|
||||
|
|
|
|||
|
|
@ -262,7 +262,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
|
||||
verifyCollabTopic collabID = do
|
||||
topic <- lift $ getCollabTopic collabID
|
||||
unless (LocalActorProject projectID == topic) $
|
||||
unless (LocalResourceProject projectID == topic) $
|
||||
throwE "Accept object is an Invite/Join for some other resource"
|
||||
|
||||
verifyInviteCollabTopic fulfillsID = do
|
||||
|
|
@ -485,7 +485,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
|
||||
componentIsAuthor ident =
|
||||
let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig
|
||||
in author == bimap (componentActor . snd) snd ident
|
||||
in author == bimap (resourceToActor . componentResource . snd) snd ident
|
||||
|
||||
theyIsAuthor :: Either (a, ProjectId) (b, RemoteActorId) -> Bool
|
||||
theyIsAuthor ident =
|
||||
|
|
@ -524,7 +524,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
(LocalActorProject projectID)
|
||||
(LocalResourceProject projectID)
|
||||
AP.RoleAdmin
|
||||
return fulfillsID
|
||||
)
|
||||
|
|
@ -578,7 +578,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
-- Prepare a regular Grant
|
||||
let isInvite = isLeft collab
|
||||
grant@(actionGrant, _, _, _) <- lift $ do
|
||||
Collab role <- getJust collabID
|
||||
Collab role _ <- getJust collabID
|
||||
prepareCollabGrant isInvite inviterOrJoiner role
|
||||
let recipByKey = LocalActorProject projectID
|
||||
_luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant
|
||||
|
|
@ -632,7 +632,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
(LocalActorProject projectID)
|
||||
(LocalResourceProject projectID)
|
||||
AP.RoleAdmin
|
||||
)
|
||||
|
||||
|
|
@ -770,7 +770,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
(LocalActorProject projectID)
|
||||
(LocalResourceProject projectID)
|
||||
AP.RoleAdmin
|
||||
return $ Right ()
|
||||
(True, True) -> throwE "Child already enabled, not needing any further Accept"
|
||||
|
|
@ -819,7 +819,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
(LocalActorProject projectID)
|
||||
(LocalResourceProject projectID)
|
||||
AP.RoleAdmin
|
||||
return $ Right ()
|
||||
(True, True) -> throwE "Just waiting for Grant from parent, or already have it, anyway not needing any further Accept"
|
||||
|
|
@ -1036,7 +1036,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
(uComponent, audComponent) <-
|
||||
case ident of
|
||||
Left c -> do
|
||||
a <- componentActor <$> hashComponent c
|
||||
a <- resourceToActor . componentResource <$> hashComponent c
|
||||
return
|
||||
( encodeRouteHome $ renderLocalActor a
|
||||
, AudLocal [a] [localActorFollowers a]
|
||||
|
|
@ -1546,7 +1546,7 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
|
|||
(Left (ATProjectComponents j), _)| j == projectID -> do
|
||||
comp <-
|
||||
bitraverse
|
||||
(\ la -> fromMaybeE (actorToComponent la) "Not a component")
|
||||
(\ la -> fromMaybeE (resourceToComponent =<< actorToResource la) "Not a component")
|
||||
pure
|
||||
object
|
||||
addComponent comp
|
||||
|
|
@ -1746,7 +1746,7 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
|
|||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
(LocalActorProject projectID)
|
||||
(LocalResourceProject projectID)
|
||||
AP.RoleAdmin
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
|
@ -1856,7 +1856,7 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
|
|||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
(LocalActorProject projectID)
|
||||
(LocalResourceProject projectID)
|
||||
AP.RoleTriage
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
|
@ -2104,10 +2104,7 @@ projectCreateMe
|
|||
-> ProjectId
|
||||
-> Verse
|
||||
-> ActE (Text, Act (), Next)
|
||||
projectCreateMe =
|
||||
topicCreateMe
|
||||
projectActor LocalActorProject
|
||||
CollabTopicProjectProject CollabTopicProject
|
||||
projectCreateMe = topicCreateMe projectResource LocalResourceProject
|
||||
|
||||
projectCreate
|
||||
:: UTCTime
|
||||
|
|
@ -2339,7 +2336,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
(pure . snd)
|
||||
(\ (_, raID) -> getRemoteActorURI =<< getJust raID)
|
||||
ident
|
||||
unless (first componentActor identForCheck == bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig) $
|
||||
unless (first (resourceToActor . componentResource) identForCheck == bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig) $
|
||||
throwE "Capability's component and Grant author aren't the same actor"
|
||||
return (role, enableID, ident, identForCheck)
|
||||
|
||||
|
|
@ -2348,10 +2345,9 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(recipActorID, recipActor) <- lift $ do
|
||||
recip <- getJust projectID
|
||||
let actorID = projectActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
resourceID <- lift $ projectResource <$> getJust projectID
|
||||
Resource recipActorID <- lift $ getJust resourceID
|
||||
recipActor <- lift $ getJust recipActorID
|
||||
|
||||
-- Verify I don't yet have a delegation from the component
|
||||
maybeDeleg <-
|
||||
|
|
@ -2376,12 +2372,11 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
-- For each Collab in me, prepare a delegation-extension Grant
|
||||
localCollabs <-
|
||||
lift $
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` recipL `E.InnerJoin` deleg) -> do
|
||||
E.select $ E.from $ \ (collab `E.InnerJoin` enable `E.InnerJoin` recipL `E.InnerJoin` deleg) -> do
|
||||
E.on $ enable E.^. CollabEnableId E.==. deleg E.^. CollabDelegLocalEnable
|
||||
E.on $ enable E.^. CollabEnableCollab E.==. recipL E.^. CollabRecipLocalCollab
|
||||
E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab
|
||||
E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId
|
||||
E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID
|
||||
E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab
|
||||
E.where_ $ collab E.^. CollabTopic E.==. E.val resourceID
|
||||
return
|
||||
( collab E.^. CollabRole
|
||||
, recipL E.^. CollabRecipLocalPerson
|
||||
|
|
@ -2398,12 +2393,11 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
|
||||
remoteCollabs <-
|
||||
lift $
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` recipR `E.InnerJoin` deleg) -> do
|
||||
E.select $ E.from $ \ (collab `E.InnerJoin` enable `E.InnerJoin` recipR `E.InnerJoin` deleg) -> do
|
||||
E.on $ enable E.^. CollabEnableId E.==. deleg E.^. CollabDelegRemoteEnable
|
||||
E.on $ enable E.^. CollabEnableCollab E.==. recipR E.^. CollabRecipRemoteCollab
|
||||
E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab
|
||||
E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId
|
||||
E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID
|
||||
E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab
|
||||
E.where_ $ collab E.^. CollabTopic E.==. E.val resourceID
|
||||
return
|
||||
( collab E.^. CollabRole
|
||||
, recipR E.^. CollabRecipRemoteActor
|
||||
|
|
@ -2519,7 +2513,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
uComponent <-
|
||||
case component of
|
||||
Left c -> do
|
||||
a <- componentActor <$> hashComponent c
|
||||
a <- resourceToActor . componentResource <$> hashComponent c
|
||||
return $ encodeRouteHome $ renderLocalActor a
|
||||
Right u -> pure u
|
||||
|
||||
|
|
@ -2584,7 +2578,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
uComponent <-
|
||||
case component of
|
||||
Left c -> do
|
||||
a <- componentActor <$> hashComponent c
|
||||
a <- resourceToActor . componentResource <$> hashComponent c
|
||||
return $ encodeRouteHome $ renderLocalActor a
|
||||
Right u -> pure u
|
||||
|
||||
|
|
@ -2628,10 +2622,10 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
guard $ fst capability == LocalActorProject projectID
|
||||
-- I don't have a Collab with this capability
|
||||
MaybeT $ getBy $ UniqueCollabEnableGrant $ snd capability
|
||||
Collab role <- lift $ lift $ getJust collabID
|
||||
Collab role _ <- lift $ lift $ getJust collabID
|
||||
topic <- lift $ lift $ getCollabTopic collabID
|
||||
-- Found a Collab for this direct-Grant but it's not mine
|
||||
lift $ guard $ topic == LocalActorProject projectID
|
||||
lift $ guard $ topic == LocalResourceProject projectID
|
||||
recip <- lift $ lift $ getCollabRecip collabID
|
||||
recipForCheck <-
|
||||
lift $ lift $
|
||||
|
|
@ -2746,7 +2740,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
Left ci -> hashComponent ci
|
||||
Right _ -> error "Delegation-start Grant URI is local, but component found to be remote, impossible"
|
||||
s <- encodeKeyHashid startID
|
||||
return $ encodeRouteHome $ activityRoute (componentActor c) s
|
||||
return $ encodeRouteHome $ activityRoute (resourceToActor $ componentResource c) s
|
||||
Right (E.Value remoteActivityID) -> do
|
||||
ra <- getJust remoteActivityID
|
||||
getRemoteActivityURI ra
|
||||
|
|
@ -2829,7 +2823,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
uComponent <-
|
||||
case component of
|
||||
Left c -> do
|
||||
a <- componentActor <$> hashComponent c
|
||||
a <- resourceToActor . componentResource <$> hashComponent c
|
||||
return $ encodeRouteHome $ renderLocalActor a
|
||||
Right u -> pure u
|
||||
|
||||
|
|
@ -2950,10 +2944,9 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(recipActorID, recipActor) <- lift $ do
|
||||
recip <- getJust projectID
|
||||
let actorID = projectActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
resourceID <- lift $ projectResource <$> getJust projectID
|
||||
Resource recipActorID <- lift $ getJust resourceID
|
||||
recipActor <- lift $ getJust recipActorID
|
||||
|
||||
topicWithAccept <-
|
||||
lift $
|
||||
|
|
@ -2984,12 +2977,11 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
-- For each Collab in me, prepare a delegation-extension Grant
|
||||
localCollabs <-
|
||||
lift $
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` recipL `E.InnerJoin` deleg) -> do
|
||||
E.select $ E.from $ \ (collab `E.InnerJoin` enable `E.InnerJoin` recipL `E.InnerJoin` deleg) -> do
|
||||
E.on $ enable E.^. CollabEnableId E.==. deleg E.^. CollabDelegLocalEnable
|
||||
E.on $ enable E.^. CollabEnableCollab E.==. recipL E.^. CollabRecipLocalCollab
|
||||
E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab
|
||||
E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId
|
||||
E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID
|
||||
E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab
|
||||
E.where_ $ collab E.^. CollabTopic E.==. E.val resourceID
|
||||
return
|
||||
( collab E.^. CollabRole
|
||||
, recipL E.^. CollabRecipLocalPerson
|
||||
|
|
@ -3010,12 +3002,11 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
|
||||
remoteCollabs <-
|
||||
lift $
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` recipR `E.InnerJoin` deleg) -> do
|
||||
E.select $ E.from $ \ (collab `E.InnerJoin` enable `E.InnerJoin` recipR `E.InnerJoin` deleg) -> do
|
||||
E.on $ enable E.^. CollabEnableId E.==. deleg E.^. CollabDelegRemoteEnable
|
||||
E.on $ enable E.^. CollabEnableCollab E.==. recipR E.^. CollabRecipRemoteCollab
|
||||
E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab
|
||||
E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId
|
||||
E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID
|
||||
E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab
|
||||
E.where_ $ collab E.^. CollabTopic E.==. E.val resourceID
|
||||
return
|
||||
( collab E.^. CollabRole
|
||||
, recipR E.^. CollabRecipRemoteActor
|
||||
|
|
@ -3359,7 +3350,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
Left ci -> hashComponent ci
|
||||
Right _ -> error "Delegation-start Grant URI is local, but component found to be remote, impossible"
|
||||
s <- encodeKeyHashid startID
|
||||
return $ encodeRouteHome $ activityRoute (componentActor c) s
|
||||
return $ encodeRouteHome $ activityRoute (resourceToActor $ componentResource c) s
|
||||
ext@(actionExt, _, _, _) <-
|
||||
prepareExtensionGrant componentIdent uStart (min role (componentRole component)) enableID destStartID
|
||||
let recipByKey = LocalActorProject projectID
|
||||
|
|
@ -3471,7 +3462,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
uComponent <-
|
||||
case component of
|
||||
Left c -> do
|
||||
a <- componentActor <$> hashComponent c
|
||||
a <- resourceToActor . componentResource <$> hashComponent c
|
||||
return $ encodeRouteHome $ renderLocalActor a
|
||||
Right u -> pure u
|
||||
|
||||
|
|
@ -3655,7 +3646,7 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
|
|||
(role, resourceOrComps, recipientOrComp) <- parseInvite author invite
|
||||
mode <-
|
||||
case resourceOrComps of
|
||||
Left (Left (LocalActorProject j)) | j == projectID ->
|
||||
Left (Left (LocalResourceProject j)) | j == projectID ->
|
||||
Left <$>
|
||||
bitraverse
|
||||
(\case
|
||||
|
|
@ -3700,20 +3691,19 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
|
|||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(topicActorID, topicActor) <- lift $ do
|
||||
recip <- getJust projectID
|
||||
let actorID = projectActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
resourceID <- lift $ projectResource <$> getJust projectID
|
||||
Resource topicActorID <- lift $ getJust resourceID
|
||||
topicActor <- lift $ getJust topicActorID
|
||||
|
||||
-- Verify the specified capability gives relevant access
|
||||
verifyCapability'
|
||||
capability authorIdMsig (LocalActorProject projectID) AP.RoleAdmin
|
||||
capability authorIdMsig (LocalResourceProject projectID) AP.RoleAdmin
|
||||
|
||||
case invitedDB of
|
||||
|
||||
-- Verify that target doesn't already have a Collab for me
|
||||
Left collab -> do
|
||||
existingCollabIDs <- lift $ getExistingCollabs collab
|
||||
existingCollabIDs <- lift $ getExistingCollabs resourceID collab
|
||||
case existingCollabIDs of
|
||||
[] -> pure ()
|
||||
[_] -> throwE "I already have a Collab for the target"
|
||||
|
|
@ -3730,7 +3720,7 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
|
|||
-- Insert Collab or Component record to DB
|
||||
acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
|
||||
case invitedDB of
|
||||
Left collab -> insertCollab role collab inviteDB acceptID
|
||||
Left collab -> insertCollab resourceID role collab inviteDB acceptID
|
||||
Right component -> insertComponent component inviteDB acceptID
|
||||
|
||||
-- Prepare forwarding Invite to my followers
|
||||
|
|
@ -3768,29 +3758,28 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
|
|||
Right Nothing -> throwE "Target isn't an actor"
|
||||
Right (Just actor) -> return $ entityKey actor
|
||||
|
||||
getExistingCollabs (Left (GrantRecipPerson (Entity personID _))) =
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do
|
||||
getExistingCollabs resourceID (Left (GrantRecipPerson (Entity personID _))) =
|
||||
E.select $ E.from $ \ (collab `E.InnerJoin` recipl) -> do
|
||||
E.on $
|
||||
topic E.^. CollabTopicProjectCollab E.==.
|
||||
collab E.^. CollabId E.==.
|
||||
recipl E.^. CollabRecipLocalCollab
|
||||
E.where_ $
|
||||
topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&.
|
||||
collab E.^. CollabTopic E.==. E.val resourceID E.&&.
|
||||
recipl E.^. CollabRecipLocalPerson E.==. E.val personID
|
||||
return $ recipl E.^. CollabRecipLocalCollab
|
||||
getExistingCollabs (Right remoteActorID) =
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do
|
||||
getExistingCollabs resourceID (Right remoteActorID) =
|
||||
E.select $ E.from $ \ (collab `E.InnerJoin` recipr) -> do
|
||||
E.on $
|
||||
topic E.^. CollabTopicProjectCollab E.==.
|
||||
collab E.^. CollabId E.==.
|
||||
recipr E.^. CollabRecipRemoteCollab
|
||||
E.where_ $
|
||||
topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&.
|
||||
collab E.^. CollabTopic E.==. E.val resourceID E.&&.
|
||||
recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID
|
||||
return $ recipr E.^. CollabRecipRemoteCollab
|
||||
|
||||
insertCollab role recipient inviteDB acceptID = do
|
||||
collabID <- insert $ Collab role
|
||||
insertCollab resourceID role recipient inviteDB acceptID = do
|
||||
collabID <- insert $ Collab role resourceID
|
||||
fulfillsID <- insert $ CollabFulfillsInvite collabID acceptID
|
||||
insert_ $ CollabTopicProject collabID projectID
|
||||
case inviteDB of
|
||||
Left (_, _, inviteID) ->
|
||||
insert_ $ CollabInviterLocal fulfillsID inviteID
|
||||
|
|
@ -3840,7 +3829,7 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
|
|||
return $ AudRemote h [lu] []
|
||||
Right (Left componentByEnt) -> do
|
||||
componentByHash <- hashComponent $ bmap entityKey componentByEnt
|
||||
let actor = componentActor componentByHash
|
||||
let actor = resourceToActor $ componentResource componentByHash
|
||||
return $ AudLocal [actor] [localActorFollowers actor]
|
||||
Right (Right remoteActorID) -> do
|
||||
ra <- getJust remoteActorID
|
||||
|
|
@ -3880,10 +3869,7 @@ projectJoin
|
|||
-> Verse
|
||||
-> AP.Join URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
projectJoin =
|
||||
topicJoin
|
||||
projectActor LocalActorProject
|
||||
CollabTopicProjectProject CollabTopicProjectCollab CollabTopicProject
|
||||
projectJoin = topicJoin projectResource LocalResourceProject
|
||||
|
||||
-- Meaning: An actor rejected something
|
||||
-- Behavior:
|
||||
|
|
@ -3908,7 +3894,7 @@ projectReject
|
|||
-> Verse
|
||||
-> AP.Reject URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
projectReject = topicReject projectActor LocalActorProject
|
||||
projectReject = topicReject projectResource LocalResourceProject
|
||||
|
||||
-- Meaning: An actor A is removing actor B from collection C
|
||||
-- Behavior:
|
||||
|
|
@ -3960,7 +3946,7 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
|
|||
let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
|
||||
(collection, item) <- parseRemove author remove
|
||||
case (collection, item) of
|
||||
(Left (Left (LocalActorProject j)), _) | j == projectID ->
|
||||
(Left (Left (LocalResourceProject j)), _) | j == projectID ->
|
||||
removeCollab item
|
||||
(Left (Right (ATProjectChildren j)), _) | j == projectID ->
|
||||
removeChildActive item
|
||||
|
|
@ -4009,7 +3995,7 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
|
|||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
(LocalActorProject projectID)
|
||||
(LocalResourceProject projectID)
|
||||
AP.RoleAdmin
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
|
@ -4028,43 +4014,40 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
|
|||
memberByKey
|
||||
|
||||
-- Grab me from DB
|
||||
(topicActorID, topicActor) <- lift $ do
|
||||
recip <- getJust projectID
|
||||
let actorID = projectActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
resourceID <- lift $ projectResource <$> getJust projectID
|
||||
Resource topicActorID <- lift $ getJust resourceID
|
||||
topicActor <- lift $ getJust topicActorID
|
||||
|
||||
-- Find the collab that the member already has for me
|
||||
existingCollabIDs <-
|
||||
lift $ case memberDB of
|
||||
Left (Entity personID _) ->
|
||||
fmap (map $ over _2 Left) $
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do
|
||||
fmap (map $ over _1 Left) $
|
||||
E.select $ E.from $ \ (collab `E.InnerJoin` recipl) -> do
|
||||
E.on $
|
||||
topic E.^. CollabTopicProjectCollab E.==.
|
||||
collab E.^. CollabId E.==.
|
||||
recipl E.^. CollabRecipLocalCollab
|
||||
E.where_ $
|
||||
topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&.
|
||||
collab E.^. CollabTopic E.==. E.val resourceID E.&&.
|
||||
recipl E.^. CollabRecipLocalPerson E.==. E.val personID
|
||||
return
|
||||
( topic E.^. persistIdField
|
||||
, recipl E.^. persistIdField
|
||||
( recipl E.^. persistIdField
|
||||
, recipl E.^. CollabRecipLocalCollab
|
||||
)
|
||||
Right (Entity remoteActorID _, _) ->
|
||||
fmap (map $ over _2 Right) $
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do
|
||||
fmap (map $ over _1 Right) $
|
||||
E.select $ E.from $ \ (collab `E.InnerJoin` recipr) -> do
|
||||
E.on $
|
||||
topic E.^. CollabTopicProjectCollab E.==.
|
||||
collab E.^. CollabId E.==.
|
||||
recipr E.^. CollabRecipRemoteCollab
|
||||
E.where_ $
|
||||
topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&.
|
||||
collab E.^. CollabTopic E.==. E.val resourceID E.&&.
|
||||
recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID
|
||||
return
|
||||
( topic E.^. persistIdField
|
||||
, recipr E.^. persistIdField
|
||||
( recipr E.^. persistIdField
|
||||
, recipr E.^. CollabRecipRemoteCollab
|
||||
)
|
||||
(E.Value topicID, recipID, E.Value collabID) <-
|
||||
(recipID, E.Value collabID) <-
|
||||
case existingCollabIDs of
|
||||
[] -> throwE "Remove object isn't a member of me"
|
||||
[collab] -> return collab
|
||||
|
|
@ -4077,14 +4060,15 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
|
|||
|
||||
-- Verify that at least 1 more enabled Admin collab for me exists
|
||||
otherCollabIDs <-
|
||||
lift $ E.select $ E.from $ \ (topic `E.InnerJoin` enable) -> do
|
||||
lift $ E.select $ E.from $ \ (collab `E.InnerJoin` enable) -> do
|
||||
E.on $
|
||||
topic E.^. CollabTopicProjectCollab E.==.
|
||||
collab E.^. CollabId E.==.
|
||||
enable E.^. CollabEnableCollab
|
||||
E.where_ $
|
||||
topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&.
|
||||
topic E.^. CollabTopicProjectCollab E.!=. E.val collabID
|
||||
return $ topic E.^. CollabTopicProjectCollab
|
||||
collab E.^. CollabTopic E.==. E.val resourceID E.&&.
|
||||
collab E.^. CollabId E.!=. E.val collabID E.&&.
|
||||
collab E.^. CollabRole E.==. E.val AP.RoleAdmin
|
||||
return $ collab E.^. CollabId
|
||||
when (null otherCollabIDs) $
|
||||
throwE "No other admins exist, can't remove"
|
||||
|
||||
|
|
@ -4104,7 +4088,6 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
|
|||
deleteBy $ UniqueCollabRecipRemoteJoinCollab r
|
||||
deleteBy $ UniqueCollabRecipRemoteAcceptCollab r
|
||||
delete r
|
||||
delete topicID
|
||||
fulfills <- do
|
||||
mf <- runMaybeT $ asum
|
||||
[ Left <$> MaybeT (getKeyBy $ UniqueCollabFulfillsLocalTopicCreation collabID)
|
||||
|
|
@ -4235,7 +4218,7 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
|
|||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
(LocalActorProject projectID)
|
||||
(LocalResourceProject projectID)
|
||||
AP.RoleAdmin
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
|
@ -4518,7 +4501,7 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
|
|||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
(LocalActorProject projectID)
|
||||
(LocalResourceProject projectID)
|
||||
AP.RoleAdmin
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
|
|
|||
|
|
@ -1124,7 +1124,7 @@ invite personID uRecipient uResourceCollabs role = do
|
|||
resource
|
||||
resourceDB <-
|
||||
bitraverse
|
||||
VR.hashLocalActor
|
||||
VR.hashLocalResource
|
||||
(\ u@(ObjURI h lu) -> do
|
||||
instanceID <-
|
||||
lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
|
||||
|
|
@ -1162,7 +1162,9 @@ invite personID uRecipient uResourceCollabs role = do
|
|||
|
||||
let audResource =
|
||||
case resourceDB of
|
||||
Left la -> AudLocal [la] [localActorFollowers la]
|
||||
Left lr ->
|
||||
let la = resourceToActor lr
|
||||
in AudLocal [la] [localActorFollowers la]
|
||||
Right (remoteActor, ObjURI h lu) ->
|
||||
AudRemote h
|
||||
[lu]
|
||||
|
|
@ -1200,7 +1202,7 @@ add personID uRecipient uCollection role = do
|
|||
-- determine the resourc & its managing actor & followers collection
|
||||
target' <-
|
||||
bitraverse
|
||||
(pure . addTargetActor)
|
||||
(pure . resourceToActor . addTargetResource)
|
||||
(\ (ObjURI h luColl) -> do
|
||||
manager <- asksSite appHttpManager
|
||||
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
||||
|
|
@ -1286,7 +1288,7 @@ remove personID uRecipient uCollection = do
|
|||
-- resource via collection 'context'
|
||||
resource' <-
|
||||
bitraverse
|
||||
(pure . either id addTargetActor)
|
||||
(pure . either id addTargetResource)
|
||||
(\ (ObjURI h luColl) -> do
|
||||
manager <- asksSite appHttpManager
|
||||
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
|
||||
|
|
@ -1300,7 +1302,7 @@ remove personID uRecipient uCollection = do
|
|||
-- managing actor & followers collection
|
||||
resourceDB <-
|
||||
bitraverse
|
||||
VR.hashLocalActor
|
||||
VR.hashLocalResource
|
||||
(\ u@(ObjURI h lu) -> do
|
||||
instanceID <-
|
||||
lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
|
||||
|
|
@ -1338,7 +1340,9 @@ remove personID uRecipient uCollection = do
|
|||
|
||||
let audResource =
|
||||
case resourceDB of
|
||||
Left la -> AudLocal [la] [localActorFollowers la]
|
||||
Left lr ->
|
||||
let la = resourceToActor lr
|
||||
in AudLocal [la] [localActorFollowers la]
|
||||
Right (remoteActor, ObjURI h lu) ->
|
||||
AudRemote h
|
||||
[lu]
|
||||
|
|
@ -1484,13 +1488,13 @@ acceptProjectInvite personID component project uInvite = do
|
|||
|
||||
acceptPersonalInvite
|
||||
:: PersonId
|
||||
-> Either (LocalActorBy Key) RemoteActorId
|
||||
-> Either (LocalResourceBy Key) RemoteActorId
|
||||
-> FedURI
|
||||
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Accept URIMode)
|
||||
acceptPersonalInvite personID resource uInvite = do
|
||||
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
resource' <- bitraverse VR.hashLocalActor pure resource
|
||||
resource' <- bitraverse VR.hashLocalResource pure resource
|
||||
|
||||
let activity = AP.Accept uInvite Nothing
|
||||
|
||||
|
|
@ -1510,8 +1514,9 @@ acceptPersonalInvite personID resource uInvite = do
|
|||
|
||||
let audResource =
|
||||
case resourceDB of
|
||||
Left la ->
|
||||
AudLocal [la] [localActorFollowers la]
|
||||
Left lr ->
|
||||
let la = resourceToActor lr
|
||||
in AudLocal [la] [localActorFollowers la]
|
||||
Right (remoteActor, ObjURI h lu) ->
|
||||
AudRemote h
|
||||
[lu]
|
||||
|
|
|
|||
|
|
@ -30,17 +30,15 @@ module Vervis.Data.Collab
|
|||
, parseReject
|
||||
, parseRemove
|
||||
, AddTarget (..)
|
||||
, addTargetActor
|
||||
, addTargetResource
|
||||
, parseAdd
|
||||
|
||||
, grantResourceActorID
|
||||
|
||||
, ComponentBy (..)
|
||||
, parseComponent
|
||||
, hashComponent
|
||||
, unhashComponentE
|
||||
, componentActor
|
||||
, actorToComponent
|
||||
, componentResource
|
||||
, resourceToComponent
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -81,11 +79,11 @@ import Vervis.FedURI
|
|||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
|
||||
parseGrantResourceCollabs (RepoCollabsR r) = Just $ LocalActorRepo r
|
||||
parseGrantResourceCollabs (DeckCollabsR d) = Just $ LocalActorDeck d
|
||||
parseGrantResourceCollabs (LoomCollabsR l) = Just $ LocalActorLoom l
|
||||
parseGrantResourceCollabs (ProjectCollabsR l) = Just $ LocalActorProject l
|
||||
parseGrantResourceCollabs (GroupMembersR l) = Just $ LocalActorGroup l
|
||||
parseGrantResourceCollabs (RepoCollabsR r) = Just $ LocalResourceRepo r
|
||||
parseGrantResourceCollabs (DeckCollabsR d) = Just $ LocalResourceDeck d
|
||||
parseGrantResourceCollabs (LoomCollabsR l) = Just $ LocalResourceLoom l
|
||||
parseGrantResourceCollabs (ProjectCollabsR l) = Just $ LocalResourceProject l
|
||||
parseGrantResourceCollabs (GroupMembersR l) = Just $ LocalResourceGroup l
|
||||
parseGrantResourceCollabs _ = Nothing
|
||||
|
||||
data GrantRecipBy f = GrantRecipPerson (f Person)
|
||||
|
|
@ -122,7 +120,7 @@ verifyRole = pure
|
|||
|
||||
parseTopic
|
||||
:: StageRoute Env ~ Route App
|
||||
=> FedURI -> ActE (Either (LocalActorBy Key) FedURI)
|
||||
=> FedURI -> ActE (Either (LocalResourceBy Key) FedURI)
|
||||
parseTopic u = do
|
||||
t <- parseTopic' u
|
||||
bitraverse
|
||||
|
|
@ -136,7 +134,7 @@ parseTopic u = do
|
|||
parseTopic'
|
||||
:: StageRoute Env ~ Route App
|
||||
=> FedURI
|
||||
-> ActE (Either (Either (LocalActorBy Key) ProjectId) FedURI)
|
||||
-> ActE (Either (Either (LocalResourceBy Key) ProjectId) FedURI)
|
||||
parseTopic' u = do
|
||||
routeOrRemote <- parseFedURI u
|
||||
bitraverse
|
||||
|
|
@ -148,7 +146,7 @@ parseTopic' u = do
|
|||
fromMaybeE
|
||||
(parseGrantResourceCollabs route)
|
||||
"Not a shared resource collabs route"
|
||||
unhashLocalActorE
|
||||
unhashLocalResourceE
|
||||
resourceHash
|
||||
"Contains invalid hashid"
|
||||
)
|
||||
|
|
@ -220,7 +218,7 @@ parseInvite
|
|||
-> AP.Invite URIMode
|
||||
-> ActE
|
||||
( AP.Role
|
||||
, Either (Either (LocalActorBy Key) ProjectId) FedURI
|
||||
, Either (Either (LocalResourceBy Key) ProjectId) FedURI
|
||||
, Either (Either (GrantRecipBy Key) (ComponentBy Key)) FedURI
|
||||
)
|
||||
parseInvite sender (AP.Invite instrument object target) =
|
||||
|
|
@ -232,7 +230,7 @@ parseInvite sender (AP.Invite instrument object target) =
|
|||
parseJoin
|
||||
:: StageRoute Env ~ Route App
|
||||
=> AP.Join URIMode
|
||||
-> ActE (AP.Role, Either (LocalActorBy Key) FedURI)
|
||||
-> ActE (AP.Role, Either (LocalResourceBy Key) FedURI)
|
||||
parseJoin (AP.Join instrument object) =
|
||||
(,) <$> verifyRole instrument
|
||||
<*> nameExceptT "Join object" (parseTopic object)
|
||||
|
|
@ -242,7 +240,7 @@ parseGrant
|
|||
-> AP.Grant URIMode
|
||||
-> ActE
|
||||
( AP.RoleExt
|
||||
, Either (LocalActorBy Key) LocalURI
|
||||
, Either (LocalResourceBy Key) LocalURI
|
||||
, Either (GrantRecipBy Key) FedURI
|
||||
, Maybe (LocalURI, Maybe Int)
|
||||
, Maybe UTCTime
|
||||
|
|
@ -276,7 +274,7 @@ parseGrant h (AP.Grant object context target mresult mstart mend allows deleg) =
|
|||
fromMaybeE
|
||||
(decodeRouteLocal lu)
|
||||
"Grant context isn't a valid route"
|
||||
parseLocalActorE' route
|
||||
parseLocalResourceE' route
|
||||
else pure $ Right lu
|
||||
parseTarget u@(ObjURI h lu) = do
|
||||
hl <- hostIsLocal h
|
||||
|
|
@ -375,7 +373,7 @@ parseCollabs route = do
|
|||
fromMaybeE
|
||||
(parseGrantResourceCollabs route)
|
||||
"Not a shared resource collabs route"
|
||||
unhashLocalActorE
|
||||
unhashLocalResourceE
|
||||
resourceHash
|
||||
"Contains invalid hashid"
|
||||
|
||||
|
|
@ -384,7 +382,7 @@ parseRemove
|
|||
=> Either (LocalActorBy Key) FedURI
|
||||
-> AP.Remove URIMode
|
||||
-> ActE
|
||||
( Either (Either (LocalActorBy Key) AddTarget) FedURI
|
||||
( Either (Either (LocalResourceBy Key) AddTarget) FedURI
|
||||
, Either (LocalActorBy Key) FedURI
|
||||
)
|
||||
parseRemove sender (AP.Remove object origin) =
|
||||
|
|
@ -424,13 +422,13 @@ data AddTarget
|
|||
| ATGroupChildren GroupId
|
||||
deriving Eq
|
||||
|
||||
addTargetActor :: AddTarget -> LocalActorBy Key
|
||||
addTargetActor = \case
|
||||
ATProjectComponents j -> LocalActorProject j
|
||||
ATProjectParents j -> LocalActorProject j
|
||||
ATProjectChildren j -> LocalActorProject j
|
||||
ATGroupParents g -> LocalActorGroup g
|
||||
ATGroupChildren g -> LocalActorGroup g
|
||||
addTargetResource :: AddTarget -> LocalResourceBy Key
|
||||
addTargetResource = \case
|
||||
ATProjectComponents j -> LocalResourceProject j
|
||||
ATProjectParents j -> LocalResourceProject j
|
||||
ATProjectChildren j -> LocalResourceProject j
|
||||
ATGroupParents g -> LocalResourceGroup g
|
||||
ATGroupChildren g -> LocalResourceGroup g
|
||||
|
||||
parseAdd
|
||||
:: StageRoute Env ~ Route App
|
||||
|
|
@ -451,7 +449,7 @@ parseAdd sender (AP.Add object target role _context) = do
|
|||
when (sender == component) $
|
||||
throwE "Sender and component are the same"
|
||||
case collection of
|
||||
Left t | sender == Left (addTargetActor t) ->
|
||||
Left t | sender == Left (resourceToActor $ addTargetResource t) ->
|
||||
throwE "Sender and target collection actor are the same"
|
||||
_ -> pure ()
|
||||
return (component, collection, role)
|
||||
|
|
@ -484,14 +482,6 @@ parseAdd sender (AP.Add object target role _context) = do
|
|||
pure
|
||||
routeOrRemote
|
||||
|
||||
grantResourceActorID :: LocalActorBy Identity -> ActorId
|
||||
grantResourceActorID (LocalActorPerson (Identity p)) = personActor p
|
||||
grantResourceActorID (LocalActorRepo (Identity r)) = repoActor r
|
||||
grantResourceActorID (LocalActorDeck (Identity d)) = deckActor d
|
||||
grantResourceActorID (LocalActorLoom (Identity l)) = loomActor l
|
||||
grantResourceActorID (LocalActorProject (Identity j)) = projectActor j
|
||||
grantResourceActorID (LocalActorGroup (Identity g)) = groupActor g
|
||||
|
||||
data ComponentBy f
|
||||
= ComponentRepo (f Repo)
|
||||
| ComponentDeck (f Deck)
|
||||
|
|
@ -524,14 +514,13 @@ unhashComponent c = do
|
|||
|
||||
unhashComponentE c e = ExceptT $ maybe (Left e) Right <$> unhashComponent c
|
||||
|
||||
componentActor (ComponentRepo r) = LocalActorRepo r
|
||||
componentActor (ComponentDeck d) = LocalActorDeck d
|
||||
componentActor (ComponentLoom l) = LocalActorLoom l
|
||||
componentResource (ComponentRepo r) = LocalResourceRepo r
|
||||
componentResource (ComponentDeck d) = LocalResourceDeck d
|
||||
componentResource (ComponentLoom l) = LocalResourceLoom l
|
||||
|
||||
actorToComponent = \case
|
||||
LocalActorPerson _ -> Nothing
|
||||
LocalActorRepo k -> Just $ ComponentRepo k
|
||||
LocalActorDeck k -> Just $ ComponentDeck k
|
||||
LocalActorLoom k -> Just $ ComponentLoom k
|
||||
LocalActorProject _ -> Nothing
|
||||
LocalActorGroup _ -> Nothing
|
||||
resourceToComponent = \case
|
||||
LocalResourceRepo k -> Just $ ComponentRepo k
|
||||
LocalResourceDeck k -> Just $ ComponentDeck k
|
||||
LocalResourceLoom k -> Just $ ComponentLoom k
|
||||
LocalResourceProject _ -> Nothing
|
||||
LocalResourceGroup _ -> Nothing
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
-
|
||||
|
|
@ -125,10 +126,11 @@ deckInviteForm deckID = renderDivs $ DeckInvite
|
|||
<*> areq selectRole "Role*" Nothing
|
||||
where
|
||||
selectPerson = selectField $ do
|
||||
l <- runDB $ E.select $
|
||||
E.from $ \ (person `E.InnerJoin` actor `E.LeftOuterJoin` (recip `E.InnerJoin` topic)) -> do
|
||||
E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicDeckCollab E.&&.
|
||||
topic E.^. CollabTopicDeckDeck E.==. E.val deckID
|
||||
l <- runDB $ do
|
||||
resourceID <- deckResource <$> getJust deckID
|
||||
E.select $ E.from $ \ (person `E.InnerJoin` actor `E.LeftOuterJoin` (recip `E.InnerJoin` collab)) -> do
|
||||
E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId E.&&.
|
||||
collab E.^. CollabTopic E.==. E.val resourceID
|
||||
E.on $ person E.^. PersonId E.==. recip E.^. CollabRecipLocalPerson
|
||||
E.on $ person E.^. PersonActor E.==. actor E.^. ActorId
|
||||
E.where_ $ E.isNothing $ E.just $ recip E.^. CollabRecipLocalId
|
||||
|
|
@ -157,10 +159,11 @@ projectInviteForm projectID = renderDivs $ ProjectInvite
|
|||
<*> areq selectRole "Role*" Nothing
|
||||
where
|
||||
selectPerson = selectField $ do
|
||||
l <- runDB $ E.select $
|
||||
E.from $ \ (person `E.InnerJoin` actor `E.LeftOuterJoin` (recip `E.InnerJoin` topic)) -> do
|
||||
E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicProjectCollab E.&&.
|
||||
topic E.^. CollabTopicProjectProject E.==. E.val projectID
|
||||
l <- runDB $ do
|
||||
resourceID <- projectResource <$> getJust projectID
|
||||
E.select $ E.from $ \ (person `E.InnerJoin` actor `E.LeftOuterJoin` (recip `E.InnerJoin` collab)) -> do
|
||||
E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId E.&&.
|
||||
collab E.^. CollabTopic E.==. E.val resourceID
|
||||
E.on $ person E.^. PersonId E.==. recip E.^. CollabRecipLocalPerson
|
||||
E.on $ person E.^. PersonActor E.==. actor E.^. ActorId
|
||||
E.where_ $ E.isNothing $ E.just $ recip E.^. CollabRecipLocalId
|
||||
|
|
@ -192,10 +195,11 @@ groupInviteForm groupID = renderDivs $ GroupInvite
|
|||
<*> areq selectRole "Role*" Nothing
|
||||
where
|
||||
selectPerson = selectField $ do
|
||||
l <- runDB $ E.select $
|
||||
E.from $ \ (person `E.InnerJoin` actor `E.LeftOuterJoin` (recip `E.InnerJoin` topic)) -> do
|
||||
E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicGroupCollab E.&&.
|
||||
topic E.^. CollabTopicGroupGroup E.==. E.val groupID
|
||||
l <- runDB $ do
|
||||
resourceID <- groupResource <$> getJust groupID
|
||||
E.select $ E.from $ \ (person `E.InnerJoin` actor `E.LeftOuterJoin` (recip `E.InnerJoin` collab)) -> do
|
||||
E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId E.&&.
|
||||
collab E.^. CollabTopic E.==. E.val resourceID
|
||||
E.on $ person E.^. PersonId E.==. recip E.^. CollabRecipLocalPerson
|
||||
E.on $ person E.^. PersonActor E.==. actor E.^. ActorId
|
||||
E.where_ $ E.isNothing $ E.just $ recip E.^. CollabRecipLocalId
|
||||
|
|
|
|||
|
|
@ -186,14 +186,11 @@ getHomeR = do
|
|||
)
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
for ls $ \ (E.Value gestureID, E.Value role, E.Value topicID) -> do
|
||||
topic <- getPermitTopicLocal topicID
|
||||
actorID <- do
|
||||
ma <- getLocalActorEntity topic
|
||||
case ma of
|
||||
Nothing -> error "Impossible, we should have found the local actor in DB"
|
||||
Just a -> pure $ localActorID a
|
||||
PermitTopicLocal _ resourceID <- getJust topicID
|
||||
Resource actorID <- getJust resourceID
|
||||
actor <- getJust actorID
|
||||
delegator <- getKeyBy $ UniquePermitPersonSendDelegator gestureID
|
||||
topic <- resourceToActor <$> getLocalResource resourceID
|
||||
exts <-
|
||||
case delegator of
|
||||
Nothing -> pure []
|
||||
|
|
@ -274,14 +271,11 @@ getHomeR = do
|
|||
, topic E.^. PermitTopicLocalId
|
||||
)
|
||||
for ls $ \ (E.Value fulfillsID, E.Value role, E.Value valid, E.Value accept, E.Value topicID) -> do
|
||||
topic <- getPermitTopicLocal topicID
|
||||
actorID <- do
|
||||
ma <- getLocalActorEntity topic
|
||||
case ma of
|
||||
Nothing -> error "Impossible, we should have found the local actor in DB"
|
||||
Just a -> pure $ localActorID a
|
||||
PermitTopicLocal _ resourceID <- getJust topicID
|
||||
Resource actorID <- getJust resourceID
|
||||
actor <- getJust actorID
|
||||
fulfillsHash <- encodeKeyHashid fulfillsID
|
||||
topic <- resourceToActor <$> getLocalResource resourceID
|
||||
return
|
||||
( fulfillsID
|
||||
, role
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2020, 2022, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -708,14 +708,14 @@ postClothApplyR loomHash clothHash = do
|
|||
ep@(Entity personID person) <- requireAuth
|
||||
|
||||
(grantIDs, proposal, actor, loomID) <- runDB $ do
|
||||
(Entity loomID _, _, _, _, _, proposal) <- getCloth404 loomHash clothHash
|
||||
(Entity loomID loom, _, _, _, _, proposal) <- getCloth404 loomHash clothHash
|
||||
|
||||
grantIDs <-
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` enable) -> do
|
||||
E.on $ topic E.^. CollabTopicLoomCollab E.==. enable E.^. CollabEnableCollab
|
||||
E.on $ topic E.^. CollabTopicLoomCollab E.==. recip E.^. CollabRecipLocalCollab
|
||||
E.select $ E.from $ \ (collab `E.InnerJoin` recip `E.InnerJoin` enable) -> do
|
||||
E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab
|
||||
E.on $ collab E.^. CollabId E.==. recip E.^. CollabRecipLocalCollab
|
||||
E.where_ $
|
||||
topic E.^. CollabTopicLoomLoom E.==. E.val loomID E.&&.
|
||||
collab E.^. CollabTopic E.==. E.val (loomResource loom) E.&&.
|
||||
recip E.^. CollabRecipLocalPerson E.==. E.val personID
|
||||
return $ enable E.^. CollabEnableGrant
|
||||
|
||||
|
|
|
|||
|
|
@ -417,8 +417,8 @@ getDeckCollabsR :: KeyHashid Deck -> Handler TypedContent
|
|||
getDeckCollabsR deckHash = do
|
||||
deckID <- decodeKeyHashid404 deckHash
|
||||
collabs <- runDB $ do
|
||||
_deck <- get404 deckID
|
||||
grants <- getTopicGrants CollabTopicDeckCollab CollabTopicDeckDeck deckID
|
||||
deck <- get404 deckID
|
||||
grants <- getTopicGrants $ deckResource deck
|
||||
for grants $ \ (role, actor, _ct, time) ->
|
||||
(role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor
|
||||
h <- asksSite siteInstanceHost
|
||||
|
|
@ -457,21 +457,18 @@ getDeckCollabsR deckHash = do
|
|||
deck <- get404 deckID
|
||||
actor <- getJust $ deckActor deck
|
||||
collabs <- do
|
||||
grants <-
|
||||
getTopicGrants CollabTopicDeckCollab CollabTopicDeckDeck deckID
|
||||
grants <- getTopicGrants $ deckResource deck
|
||||
for grants $ \ (role, actor, ct, time) ->
|
||||
(,role,ct,time) <$> getPersonWidgetInfo actor
|
||||
invites <- do
|
||||
invites' <-
|
||||
getTopicInvites CollabTopicDeckCollab CollabTopicDeckDeck deckID
|
||||
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 CollabTopicDeckCollab CollabTopicDeckDeck deckID
|
||||
joins' <- getTopicJoins $ deckResource deck
|
||||
for joins' $ \ (recip, time, role) ->
|
||||
(,time,role) <$> getPersonWidgetInfo recip
|
||||
return (deck, actor, collabs, invites, joins)
|
||||
|
|
@ -506,7 +503,9 @@ postDeckInviteR deckHash = do
|
|||
uResourceCollabs = encodeRouteHome $ DeckCollabsR deckHash
|
||||
C.invite personID uRecipient uResourceCollabs role
|
||||
grantID <- do
|
||||
maybeItem <- lift $ runDB $ getGrant CollabTopicDeckCollab CollabTopicDeckDeck deckID personID
|
||||
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
|
||||
|
|
@ -525,8 +524,8 @@ postDeckInviteR deckHash = do
|
|||
setMessage "Invite sent"
|
||||
redirect $ DeckCollabsR deckHash
|
||||
|
||||
postDeckRemoveR :: KeyHashid Deck -> CollabTopicDeckId -> Handler Html
|
||||
postDeckRemoveR deckHash ctID = do
|
||||
postDeckRemoveR :: KeyHashid Deck -> CollabId -> Handler Html
|
||||
postDeckRemoveR deckHash collabID = do
|
||||
deckID <- decodeKeyHashid404 deckHash
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
|
|
@ -535,18 +534,20 @@ postDeckRemoveR deckHash ctID = do
|
|||
|
||||
result <- runExceptT $ do
|
||||
mpidOrU <- lift $ runDB $ runMaybeT $ do
|
||||
CollabTopicDeck collabID deckID' <- MaybeT $ get ctID
|
||||
guard $ deckID' == deckID
|
||||
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
|
||||
pidOrU <- maybe notFound pure mpidOrU
|
||||
(resourceID, pidOrU) <- maybe notFound pure mpidOrU
|
||||
(maybeSummary, audience, remove) <- do
|
||||
uRecipient <-
|
||||
case pidOrU of
|
||||
|
|
@ -555,7 +556,7 @@ postDeckRemoveR deckHash ctID = do
|
|||
let uResourceCollabs = encodeRouteHome $ DeckCollabsR deckHash
|
||||
C.remove personID uRecipient uResourceCollabs
|
||||
grantID <- do
|
||||
maybeItem <- lift $ runDB $ getGrant CollabTopicDeckCollab CollabTopicDeckDeck deckID personID
|
||||
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
|
||||
|
|
@ -651,7 +652,9 @@ postDeckApproveCompR deckHash stemHash = do
|
|||
(maybeSummary, audience, accept) <-
|
||||
C.acceptProjectInvite personID (LocalActorDeck deckID) jidOrURI uInvite
|
||||
grantID <- do
|
||||
maybeItem <- lift $ runDB $ getGrant CollabTopicDeckCollab CollabTopicDeckDeck deckID personID
|
||||
maybeItem <- lift $ runDB $ do
|
||||
resourceID <- deckResource <$> get404 deckID
|
||||
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
|
||||
|
|
|
|||
|
|
@ -237,9 +237,8 @@ getGroupMembersR :: KeyHashid Group -> Handler TypedContent
|
|||
getGroupMembersR groupHash = do
|
||||
groupID <- decodeKeyHashid404 groupHash
|
||||
members <- runDB $ do
|
||||
_group <- get404 groupID
|
||||
grants <-
|
||||
getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID
|
||||
group <- get404 groupID
|
||||
grants <- getTopicGrants $ groupResource group
|
||||
for grants $ \ (role, actor, _ct, time) ->
|
||||
(role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor
|
||||
h <- asksSite siteInstanceHost
|
||||
|
|
@ -278,21 +277,18 @@ getGroupMembersR groupHash = do
|
|||
group <- get404 groupID
|
||||
actor <- getJust $ groupActor group
|
||||
members <- do
|
||||
grants <-
|
||||
getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID
|
||||
grants <- getTopicGrants $ groupResource group
|
||||
for grants $ \ (role, actor, ct, time) ->
|
||||
(,role,ct,time) <$> getPersonWidgetInfo actor
|
||||
invites <- do
|
||||
invites' <-
|
||||
getTopicInvites CollabTopicGroupCollab CollabTopicGroupGroup groupID
|
||||
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 CollabTopicGroupCollab CollabTopicGroupGroup groupID
|
||||
joins' <- getTopicJoins $ groupResource group
|
||||
for joins' $ \ (recip, time, role) ->
|
||||
(,time,role) <$> getPersonWidgetInfo recip
|
||||
return (group, actor, members, invites, joins)
|
||||
|
|
@ -327,7 +323,9 @@ postGroupInviteR groupHash = do
|
|||
uResourceCollabs = encodeRouteHome $ GroupMembersR groupHash
|
||||
C.invite personID uRecipient uResourceCollabs role
|
||||
grantID <- do
|
||||
maybeItem <- lift $ runDB $ getGrant CollabTopicGroupCollab CollabTopicGroupGroup groupID personID
|
||||
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
|
||||
|
|
@ -346,8 +344,8 @@ postGroupInviteR groupHash = do
|
|||
setMessage "Invite sent"
|
||||
redirect $ GroupMembersR groupHash
|
||||
|
||||
postGroupRemoveR :: KeyHashid Group -> CollabTopicGroupId -> Handler Html
|
||||
postGroupRemoveR groupHash ctID = do
|
||||
postGroupRemoveR :: KeyHashid Group -> CollabId -> Handler Html
|
||||
postGroupRemoveR groupHash collabID = do
|
||||
groupID <- decodeKeyHashid404 groupHash
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
|
|
@ -356,18 +354,20 @@ postGroupRemoveR groupHash ctID = do
|
|||
|
||||
result <- runExceptT $ do
|
||||
mpidOrU <- lift $ runDB $ runMaybeT $ do
|
||||
CollabTopicGroup collabID groupID' <- MaybeT $ get ctID
|
||||
guard $ groupID' == groupID
|
||||
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
|
||||
pidOrU <- maybe notFound pure mpidOrU
|
||||
(resourceID, pidOrU) <- maybe notFound pure mpidOrU
|
||||
(maybeSummary, audience, remove) <- do
|
||||
uRecipient <-
|
||||
case pidOrU of
|
||||
|
|
@ -376,7 +376,7 @@ postGroupRemoveR groupHash ctID = do
|
|||
let uResourceCollabs = encodeRouteHome $ GroupMembersR groupHash
|
||||
C.remove personID uRecipient uResourceCollabs
|
||||
grantID <- do
|
||||
maybeItem <- lift $ runDB $ getGrant CollabTopicGroupCollab CollabTopicGroupGroup groupID personID
|
||||
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
|
||||
|
|
|
|||
|
|
@ -302,15 +302,15 @@ postLoomNewR = do
|
|||
actor <- runDB $ do
|
||||
|
||||
-- Find the specified repo in DB
|
||||
_ <- getJust repoID
|
||||
repo <- getJust repoID
|
||||
|
||||
-- Make sure the repo has a single, full-access collab, granted to the
|
||||
-- creator of the loom
|
||||
maybeApproved <- runMaybeT $ do
|
||||
collabs <- lift $ selectList [CollabTopicRepoRepo ==. repoID] []
|
||||
collabs <- lift $ selectKeysList [CollabTopic ==. repoResource repo] []
|
||||
collabID <-
|
||||
case collabs of
|
||||
[Entity _ c] -> return $ collabTopicRepoCollab c
|
||||
[c] -> return c
|
||||
_ -> mzero
|
||||
CollabRecipLocal _ recipID <-
|
||||
MaybeT $ getValBy $ UniqueCollabRecipLocal collabID
|
||||
|
|
|
|||
|
|
@ -95,6 +95,7 @@ import Yesod.Form.Local
|
|||
import Yesod.Persist.Local
|
||||
|
||||
import Vervis.Access
|
||||
import Vervis.Actor (resourceToActor)
|
||||
import Vervis.API
|
||||
import Vervis.Data.Collab
|
||||
import Vervis.Federation.Auth
|
||||
|
|
@ -235,8 +236,8 @@ getProjectCollabsR :: KeyHashid Project -> Handler TypedContent
|
|||
getProjectCollabsR projectHash = do
|
||||
projectID <- decodeKeyHashid404 projectHash
|
||||
collabs <- runDB $ do
|
||||
_project <- get404 projectID
|
||||
grants <- getTopicGrants CollabTopicProjectCollab CollabTopicProjectProject projectID
|
||||
project <- get404 projectID
|
||||
grants <- getTopicGrants $ projectResource project
|
||||
for grants $ \ (role, actor, _ct, time) ->
|
||||
(role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor
|
||||
h <- asksSite siteInstanceHost
|
||||
|
|
@ -275,21 +276,18 @@ getProjectCollabsR projectHash = do
|
|||
project <- get404 projectID
|
||||
actor <- getJust $ projectActor project
|
||||
collabs <- do
|
||||
grants <-
|
||||
getTopicGrants CollabTopicProjectCollab CollabTopicProjectProject projectID
|
||||
grants <- getTopicGrants $ projectResource project
|
||||
for grants $ \ (role, actor, ct, time) ->
|
||||
(,role,ct,time) <$> getPersonWidgetInfo actor
|
||||
invites <- do
|
||||
invites' <-
|
||||
getTopicInvites CollabTopicProjectCollab CollabTopicProjectProject projectID
|
||||
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 CollabTopicProjectCollab CollabTopicProjectProject projectID
|
||||
joins' <- getTopicJoins $ projectResource project
|
||||
for joins' $ \ (recip, time, role) ->
|
||||
(,time,role) <$> getPersonWidgetInfo recip
|
||||
return (project, actor, collabs, invites, joins)
|
||||
|
|
@ -324,7 +322,9 @@ postProjectInviteR projectHash = do
|
|||
uResourceCollabs = encodeRouteHome $ ProjectCollabsR projectHash
|
||||
C.invite personID uRecipient uResourceCollabs role
|
||||
grantID <- do
|
||||
maybeItem <- lift $ runDB $ getGrant CollabTopicProjectCollab CollabTopicProjectProject projectID personID
|
||||
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
|
||||
|
|
@ -343,8 +343,8 @@ postProjectInviteR projectHash = do
|
|||
setMessage "Invite sent"
|
||||
redirect $ ProjectCollabsR projectHash
|
||||
|
||||
postProjectRemoveR :: KeyHashid Project -> CollabTopicProjectId -> Handler Html
|
||||
postProjectRemoveR projectHash ctID = do
|
||||
postProjectRemoveR :: KeyHashid Project -> CollabId -> Handler Html
|
||||
postProjectRemoveR projectHash collabID = do
|
||||
projectID <- decodeKeyHashid404 projectHash
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
|
|
@ -353,18 +353,20 @@ postProjectRemoveR projectHash ctID = do
|
|||
|
||||
result <- runExceptT $ do
|
||||
mpidOrU <- lift $ runDB $ runMaybeT $ do
|
||||
CollabTopicProject collabID projectID' <- MaybeT $ get ctID
|
||||
guard $ projectID' == projectID
|
||||
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
|
||||
pidOrU <- maybe notFound pure mpidOrU
|
||||
(resourceID, pidOrU) <- maybe notFound pure mpidOrU
|
||||
(maybeSummary, audience, remove) <- do
|
||||
uRecipient <-
|
||||
case pidOrU of
|
||||
|
|
@ -373,7 +375,7 @@ postProjectRemoveR projectHash ctID = do
|
|||
let uResourceCollabs = encodeRouteHome $ ProjectCollabsR projectHash
|
||||
C.remove personID uRecipient uResourceCollabs
|
||||
grantID <- do
|
||||
maybeItem <- lift $ runDB $ getGrant CollabTopicProjectCollab CollabTopicProjectProject projectID personID
|
||||
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
|
||||
|
|
@ -415,7 +417,8 @@ getProjectComponentsR projectHash = do
|
|||
( encodeRouteHome
|
||||
. renderLocalActor
|
||||
. hashActor
|
||||
. componentActor
|
||||
. resourceToActor
|
||||
. componentResource
|
||||
)
|
||||
id
|
||||
)
|
||||
|
|
@ -533,10 +536,10 @@ getProjectCollabLiveR projectHash enableHash = do
|
|||
projectID <- decodeKeyHashid404 projectHash
|
||||
enableID <- decodeKeyHashid404 enableHash
|
||||
runDB $ do
|
||||
resourceID <- projectResource <$> get404 projectID
|
||||
CollabEnable collabID _ <- get404 enableID
|
||||
CollabTopicProject _ j <-
|
||||
getValBy404 $ UniqueCollabTopicProject collabID
|
||||
unless (j == projectID) notFound
|
||||
Collab _ resourceID' <- getJust collabID
|
||||
unless (resourceID == resourceID') notFound
|
||||
|
||||
getProjectInviteCompR :: KeyHashid Project -> Handler Html
|
||||
getProjectInviteCompR projectHash = do
|
||||
|
|
@ -558,7 +561,9 @@ postProjectInviteCompR projectHash = do
|
|||
(maybeSummary, audience, invite) <-
|
||||
C.inviteComponent personID projectID uComp
|
||||
grantID <- do
|
||||
maybeItem <- lift $ runDB $ getGrant CollabTopicProjectCollab CollabTopicProjectProject projectID personID
|
||||
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
|
||||
|
|
|
|||
|
|
@ -730,10 +730,10 @@ postRepoLinkR repoHash loomHash = do
|
|||
-- Make sure both repo and loom have a single, full-access collab,
|
||||
-- granted to the logged-in person
|
||||
maybeApproved <- lift $ runMaybeT $ do
|
||||
collabs <- lift $ selectList [CollabTopicRepoRepo ==. repoID] []
|
||||
collabs <- lift $ selectKeysList [CollabTopic ==. repoResource repo] []
|
||||
collabID <-
|
||||
case collabs of
|
||||
[Entity _ c] -> return $ collabTopicRepoCollab c
|
||||
[c] -> return c
|
||||
_ -> mzero
|
||||
CollabRecipLocal _ recipID <-
|
||||
MaybeT $ getValBy $ UniqueCollabRecipLocal collabID
|
||||
|
|
@ -741,10 +741,10 @@ postRepoLinkR repoHash loomHash = do
|
|||
_ <- MaybeT $ getBy $ UniqueCollabFulfillsLocalTopicCreation collabID
|
||||
guard $ recipID == personID
|
||||
|
||||
collabs' <- lift $ selectList [CollabTopicLoomLoom ==. loomID] []
|
||||
collabs' <- lift $ selectKeysList [CollabTopic ==. loomResource loom] []
|
||||
collabID' <-
|
||||
case collabs' of
|
||||
[Entity _ c] -> return $ collabTopicLoomCollab c
|
||||
[c] -> return c
|
||||
_ -> mzero
|
||||
CollabRecipLocal _ recipID' <-
|
||||
MaybeT $ getValBy $ UniqueCollabRecipLocal collabID'
|
||||
|
|
|
|||
|
|
@ -502,7 +502,9 @@ postTicketCloseR deckHash taskHash = do
|
|||
result <- runExceptT $ do
|
||||
(maybeSummary, audience, detail) <- C.resolve personID uTicket
|
||||
grantID <- do
|
||||
maybeItem <- lift $ runDB $ getGrant CollabTopicDeckCollab CollabTopicDeckDeck deckID personID
|
||||
maybeItem <- lift $ runDB $ do
|
||||
resourceID <- deckResource <$> get404 deckID
|
||||
getGrant resourceID personID
|
||||
fromMaybeE maybeItem "You need to be a collaborator in the Deck to close tickets"
|
||||
grantHash <- encodeKeyHashid grantID
|
||||
let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash
|
||||
|
|
@ -532,7 +534,9 @@ postTicketOpenR deckHash taskHash = do
|
|||
result <- runExceptT $ do
|
||||
(maybeSummary, audience, undo) <- C.unresolve personHash uTicket
|
||||
grantID <- do
|
||||
maybeItem <- lift $ runDB $ getGrant CollabTopicDeckCollab CollabTopicDeckDeck deckID personID
|
||||
maybeItem <- lift $ runDB $ do
|
||||
resourceID <- deckResource <$> get404 deckID
|
||||
getGrant resourceID personID
|
||||
fromMaybeE maybeItem "You need to be a collaborator in the Deck to reopen tickets"
|
||||
grantHash <- encodeKeyHashid grantID
|
||||
let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash
|
||||
|
|
|
|||
|
|
@ -82,6 +82,7 @@ import Yesod.MonadSite
|
|||
import Yesod.RenderSource
|
||||
|
||||
import Data.Either.Local
|
||||
import Data.Maybe.Local
|
||||
import Database.Persist.Local
|
||||
|
||||
import Vervis.FedURI
|
||||
|
|
@ -3489,6 +3490,118 @@ changes hLocal ctx =
|
|||
"Resource"
|
||||
-- 610
|
||||
, removeField "PermitTopicExtendResourceLocal" "actor"
|
||||
-- 611
|
||||
, addFieldRefRequired''
|
||||
"PermitTopicLocal"
|
||||
(do inboxID <- insert Inbox611
|
||||
outboxID <- insert Outbox611
|
||||
followerSetID <- insert FollowerSet611
|
||||
actorID <- insert $ Actor611 "" "" defaultTime inboxID outboxID followerSetID Nothing
|
||||
insertEntity $ Resource611 actorID
|
||||
)
|
||||
(Just $ \ (Entity tempResourceID (Resource611 tempActorID)) -> do
|
||||
l <- selectKeysList [] []
|
||||
for_ l $ \ k -> do
|
||||
resourceID <- do
|
||||
options <-
|
||||
sequence
|
||||
[ do
|
||||
ma <- fmap permitTopicRepo611Repo <$> getValBy (UniquePermitTopicRepo611 k)
|
||||
for ma $ fmap repo611Resource . getJust
|
||||
, do
|
||||
ma <- fmap permitTopicDeck611Deck <$> getValBy (UniquePermitTopicDeck611 k)
|
||||
for ma $ fmap deck611Resource . getJust
|
||||
, do
|
||||
ma <- fmap permitTopicLoom611Loom <$> getValBy (UniquePermitTopicLoom611 k)
|
||||
for ma $ fmap loom611Resource . getJust
|
||||
, do
|
||||
ma <- fmap permitTopicGroup611Group <$> getValBy (UniquePermitTopicGroup611 k)
|
||||
for ma $ fmap group611Resource . getJust
|
||||
, do
|
||||
ma <- fmap permitTopicProject611Project <$> getValBy (UniquePermitTopicProject611 k)
|
||||
for ma $ fmap project611Resource . getJust
|
||||
]
|
||||
exactlyOneJust
|
||||
options
|
||||
"Found Permit without topic"
|
||||
"Found Permit with multiple topics"
|
||||
update k [PermitTopicLocal611Topic =. resourceID]
|
||||
|
||||
Actor611 _ _ _ inboxID outboxID followerSetID _ <- getJust tempActorID
|
||||
delete tempResourceID
|
||||
delete tempActorID
|
||||
delete inboxID
|
||||
delete outboxID
|
||||
delete followerSetID
|
||||
)
|
||||
"topic"
|
||||
"Resource"
|
||||
-- 612
|
||||
, removeEntity "PermitTopicRepo"
|
||||
-- 613
|
||||
, removeEntity "PermitTopicDeck"
|
||||
-- 614
|
||||
, removeEntity "PermitTopicLoom"
|
||||
-- 615
|
||||
, removeEntity "PermitTopicProject"
|
||||
-- 616
|
||||
, removeEntity "PermitTopicGroup"
|
||||
-- 617
|
||||
, addFieldRefRequired''
|
||||
"Collab"
|
||||
(do inboxID <- insert Inbox611
|
||||
outboxID <- insert Outbox611
|
||||
followerSetID <- insert FollowerSet611
|
||||
actorID <- insert $ Actor611 "" "" defaultTime inboxID outboxID followerSetID Nothing
|
||||
insertEntity $ Resource611 actorID
|
||||
)
|
||||
(Just $ \ (Entity tempResourceID (Resource611 tempActorID)) -> do
|
||||
l <- selectKeysList [] []
|
||||
for_ l $ \ k -> do
|
||||
resourceID <- do
|
||||
options <-
|
||||
sequence
|
||||
[ do
|
||||
ma <- fmap collabTopicRepo611Repo <$> getValBy (UniqueCollabTopicRepo611 k)
|
||||
for ma $ fmap repo611Resource . getJust
|
||||
, do
|
||||
ma <- fmap collabTopicDeck611Deck <$> getValBy (UniqueCollabTopicDeck611 k)
|
||||
for ma $ fmap deck611Resource . getJust
|
||||
, do
|
||||
ma <- fmap collabTopicLoom611Loom <$> getValBy (UniqueCollabTopicLoom611 k)
|
||||
for ma $ fmap loom611Resource . getJust
|
||||
, do
|
||||
ma <- fmap collabTopicGroup611Group <$> getValBy (UniqueCollabTopicGroup611 k)
|
||||
for ma $ fmap group611Resource . getJust
|
||||
, do
|
||||
ma <- fmap collabTopicProject611Project <$> getValBy (UniqueCollabTopicProject611 k)
|
||||
for ma $ fmap project611Resource . getJust
|
||||
]
|
||||
exactlyOneJust
|
||||
options
|
||||
"Found Collab without topic"
|
||||
"Found Collab with multiple topics"
|
||||
update k [Collab611Topic =. resourceID]
|
||||
|
||||
Actor611 _ _ _ inboxID outboxID followerSetID _ <- getJust tempActorID
|
||||
delete tempResourceID
|
||||
delete tempActorID
|
||||
delete inboxID
|
||||
delete outboxID
|
||||
delete followerSetID
|
||||
)
|
||||
"topic"
|
||||
"Resource"
|
||||
-- 618
|
||||
, removeEntity "CollabTopicRepo"
|
||||
-- 619
|
||||
, removeEntity "CollabTopicDeck"
|
||||
-- 620
|
||||
, removeEntity "CollabTopicLoom"
|
||||
-- 621
|
||||
, removeEntity "CollabTopicProject"
|
||||
-- 622
|
||||
, removeEntity "CollabTopicGroup"
|
||||
]
|
||||
|
||||
migrateDB
|
||||
|
|
|
|||
|
|
@ -63,3 +63,6 @@ makeEntitiesMigration "593"
|
|||
|
||||
makeEntitiesMigration "604"
|
||||
$(modelFile "migrations/604_2024-04-20_resource.model")
|
||||
|
||||
makeEntitiesMigration "611"
|
||||
$(modelFile "migrations/611_2024-04-20_permit_resource.model")
|
||||
|
|
|
|||
|
|
@ -15,7 +15,6 @@
|
|||
|
||||
module Vervis.Persist.Collab
|
||||
( getCollabTopic
|
||||
, getCollabTopic'
|
||||
, getCollabRecip
|
||||
, getPermitTopicLocal
|
||||
, getPermitTopic
|
||||
|
|
@ -94,31 +93,10 @@ import Vervis.Model
|
|||
import Vervis.Persist.Actor
|
||||
|
||||
getCollabTopic
|
||||
:: MonadIO m => CollabId -> ReaderT SqlBackend m (LocalActorBy Key)
|
||||
getCollabTopic = fmap snd . getCollabTopic'
|
||||
|
||||
getCollabTopic'
|
||||
:: MonadIO m => CollabId -> ReaderT SqlBackend m (ReaderT SqlBackend m (), LocalActorBy Key)
|
||||
getCollabTopic' collabID = do
|
||||
maybeRepo <- getBy $ UniqueCollabTopicRepo collabID
|
||||
maybeDeck <- getBy $ UniqueCollabTopicDeck collabID
|
||||
maybeLoom <- getBy $ UniqueCollabTopicLoom collabID
|
||||
maybeProject <- getBy $ UniqueCollabTopicProject collabID
|
||||
maybeGroup <- getBy $ UniqueCollabTopicGroup collabID
|
||||
return $
|
||||
case (maybeRepo, maybeDeck, maybeLoom, maybeProject, maybeGroup) of
|
||||
(Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic"
|
||||
(Just (Entity k r), Nothing, Nothing, Nothing, Nothing) ->
|
||||
(delete k, LocalActorRepo $ collabTopicRepoRepo r)
|
||||
(Nothing, Just (Entity k d), Nothing, Nothing, Nothing) ->
|
||||
(delete k, LocalActorDeck $ collabTopicDeckDeck d)
|
||||
(Nothing, Nothing, Just (Entity k l), Nothing, Nothing) ->
|
||||
(delete k, LocalActorLoom $ collabTopicLoomLoom l)
|
||||
(Nothing, Nothing, Nothing, Just (Entity k l), Nothing) ->
|
||||
(delete k, LocalActorProject $ collabTopicProjectProject l)
|
||||
(Nothing, Nothing, Nothing, Nothing, Just (Entity k l)) ->
|
||||
(delete k, LocalActorGroup $ collabTopicGroupGroup l)
|
||||
_ -> error "Found Collab with multiple topics"
|
||||
:: MonadIO m => CollabId -> ReaderT SqlBackend m (LocalResourceBy Key)
|
||||
getCollabTopic collabID = do
|
||||
Collab _ resourceID <- getJust collabID
|
||||
getLocalResource resourceID
|
||||
|
||||
getCollabRecip
|
||||
:: MonadIO m
|
||||
|
|
@ -135,32 +113,17 @@ getCollabRecip collabID =
|
|||
getPermitTopicLocal
|
||||
:: MonadIO m
|
||||
=> PermitTopicLocalId
|
||||
-> ReaderT SqlBackend m (LocalActorBy Key)
|
||||
-> ReaderT SqlBackend m (LocalResourceBy Key)
|
||||
getPermitTopicLocal localID = do
|
||||
options <-
|
||||
sequence
|
||||
[ fmap (LocalActorRepo . permitTopicRepoRepo) <$>
|
||||
getValBy (UniquePermitTopicRepo localID)
|
||||
, fmap (LocalActorDeck . permitTopicDeckDeck) <$>
|
||||
getValBy (UniquePermitTopicDeck localID)
|
||||
, fmap (LocalActorLoom . permitTopicLoomLoom) <$>
|
||||
getValBy (UniquePermitTopicLoom localID)
|
||||
, fmap (LocalActorProject . permitTopicProjectProject) <$>
|
||||
getValBy (UniquePermitTopicProject localID)
|
||||
, fmap (LocalActorGroup . permitTopicGroupGroup) <$>
|
||||
getValBy (UniquePermitTopicGroup localID)
|
||||
]
|
||||
exactlyOneJust
|
||||
options
|
||||
"Found Permit without topic"
|
||||
"Found Permit with multiple topics"
|
||||
PermitTopicLocal _ resourceID <- getJust localID
|
||||
getLocalResource resourceID
|
||||
|
||||
getPermitTopic
|
||||
:: MonadIO m
|
||||
=> PermitId
|
||||
-> ReaderT SqlBackend m
|
||||
(Either
|
||||
(PermitTopicLocalId, LocalActorBy Key)
|
||||
(PermitTopicLocalId, LocalResourceBy Key)
|
||||
(PermitTopicRemoteId, RemoteActorId)
|
||||
)
|
||||
getPermitTopic permitID = do
|
||||
|
|
@ -208,29 +171,23 @@ getComponentE (ComponentDeck k) e = ComponentDeck <$> getEntityE k e
|
|||
getComponentE (ComponentLoom k) e = ComponentLoom <$> getEntityE k e
|
||||
|
||||
getTopicGrants
|
||||
:: ( MonadIO m
|
||||
, PersistRecordBackend topic SqlBackend
|
||||
, PersistRecordBackend resource SqlBackend
|
||||
)
|
||||
=> EntityField topic CollabId
|
||||
-> EntityField topic (Key resource)
|
||||
-> Key resource
|
||||
-> ReaderT SqlBackend m [(AP.Role, Either PersonId RemoteActorId, Key topic, UTCTime)]
|
||||
getTopicGrants topicCollabField topicActorField resourceID =
|
||||
:: 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 $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` grant `E.LeftOuterJoin` recipL `E.LeftOuterJoin` recipR) -> do
|
||||
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 $ topic E.^. topicCollabField E.==. enable E.^. CollabEnableCollab
|
||||
E.on $ topic E.^. topicCollabField E.==. collab E.^. CollabId
|
||||
E.where_ $ topic E.^. topicActorField E.==. E.val resourceID
|
||||
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
|
||||
, topic E.^. persistIdField
|
||||
, collab E.^. CollabId
|
||||
, grant E.^. OutboxItemPublished
|
||||
)
|
||||
where
|
||||
|
|
@ -246,18 +203,13 @@ getTopicGrants topicCollabField topicActorField resourceID =
|
|||
)
|
||||
|
||||
getTopicInvites
|
||||
:: ( MonadIO m
|
||||
, PersistRecordBackend topic SqlBackend
|
||||
, PersistRecordBackend resource SqlBackend
|
||||
)
|
||||
=> EntityField topic CollabId
|
||||
-> EntityField topic (Key resource)
|
||||
-> Key resource
|
||||
:: MonadIO m
|
||||
=> ResourceId
|
||||
-> ReaderT SqlBackend m [(Either ActorId RemoteActorId, Either PersonId RemoteActorId, UTCTime, AP.Role)]
|
||||
getTopicInvites topicCollabField topicActorField resourceID =
|
||||
getTopicInvites resourceID =
|
||||
fmap (map adapt) $
|
||||
E.select $ E.from $
|
||||
\ (topic `E.InnerJoin` collab `E.LeftOuterJoin` enable `E.InnerJoin` fulfills
|
||||
\ (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)
|
||||
|
|
@ -269,11 +221,10 @@ getTopicInvites topicCollabField topicActorField resourceID =
|
|||
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 $ topic E.^. topicCollabField E.==. fulfills E.^. CollabFulfillsInviteCollab
|
||||
E.on $ E.just (topic E.^. topicCollabField) E.==. enable E.?. CollabEnableCollab
|
||||
E.on $ topic E.^. topicCollabField E.==. collab E.^. CollabId
|
||||
E.on $ collab E.^. CollabId E.==. fulfills E.^. CollabFulfillsInviteCollab
|
||||
E.on $ E.just (collab E.^. CollabId) E.==. enable E.?. CollabEnableCollab
|
||||
E.where_ $
|
||||
topic E.^. topicActorField E.==. E.val resourceID E.&&.
|
||||
collab E.^. CollabTopic E.==. E.val resourceID E.&&.
|
||||
E.isNothing (enable E.?. CollabEnableId)
|
||||
E.orderBy [E.asc $ fulfills E.^. CollabFulfillsInviteId]
|
||||
return
|
||||
|
|
@ -314,18 +265,13 @@ getTopicInvites topicCollabField topicActorField resourceID =
|
|||
)
|
||||
|
||||
getTopicJoins
|
||||
:: ( MonadIO m
|
||||
, PersistRecordBackend topic SqlBackend
|
||||
, PersistRecordBackend resource SqlBackend
|
||||
)
|
||||
=> EntityField topic CollabId
|
||||
-> EntityField topic (Key resource)
|
||||
-> Key resource
|
||||
:: MonadIO m
|
||||
=> ResourceId
|
||||
-> ReaderT SqlBackend m [(Either PersonId RemoteActorId, UTCTime, AP.Role)]
|
||||
getTopicJoins topicCollabField topicActorField resourceID =
|
||||
getTopicJoins resourceID =
|
||||
fmap (map adapt) $
|
||||
E.select $ E.from $
|
||||
\ (topic `E.InnerJoin` collab `E.LeftOuterJoin` enable `E.InnerJoin` fulfills
|
||||
\ (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
|
||||
|
|
@ -335,11 +281,10 @@ getTopicJoins topicCollabField topicActorField resourceID =
|
|||
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 $ topic E.^. topicCollabField E.==. fulfills E.^. CollabFulfillsJoinCollab
|
||||
E.on $ E.just (topic E.^. topicCollabField) E.==. enable E.?. CollabEnableCollab
|
||||
E.on $ topic E.^. topicCollabField E.==. collab E.^. CollabId
|
||||
E.on $ collab E.^. CollabId E.==. fulfills E.^. CollabFulfillsJoinCollab
|
||||
E.on $ E.just (collab E.^. CollabId) E.==. enable E.?. CollabEnableCollab
|
||||
E.where_ $
|
||||
topic E.^. topicActorField E.==. E.val resourceID E.&&.
|
||||
collab E.^. CollabTopic E.==. E.val resourceID E.&&.
|
||||
E.isNothing (enable E.?. CollabEnableId)
|
||||
E.orderBy [E.asc $ fulfills E.^. CollabFulfillsJoinId]
|
||||
return
|
||||
|
|
@ -369,7 +314,7 @@ verifyCapability
|
|||
:: MonadIO m
|
||||
=> (LocalActorBy Key, OutboxItemId)
|
||||
-> Either PersonId RemoteActorId
|
||||
-> LocalActorBy Key
|
||||
-> LocalResourceBy Key
|
||||
-> AP.Role
|
||||
-> ExceptT Text (ReaderT SqlBackend m) ()
|
||||
verifyCapability (capActor, capItem) actor resource requiredRole = do
|
||||
|
|
@ -401,7 +346,7 @@ verifyCapability (capActor, capItem) actor resource requiredRole = do
|
|||
topic <- lift $ getCollabTopic collabID
|
||||
|
||||
-- Verify that topic is indeed the sender of the Grant
|
||||
unless (topic == capActor) $
|
||||
unless (resourceToActor topic == capActor) $
|
||||
error "Grant sender isn't the topic"
|
||||
|
||||
-- Verify the topic matches the resource specified
|
||||
|
|
@ -409,7 +354,7 @@ verifyCapability (capActor, capItem) actor resource requiredRole = do
|
|||
throwE "Capability topic is some other local resource"
|
||||
|
||||
-- Verify that the granted role is equal or greater than the required role
|
||||
Collab givenRole <- lift $ getJust collabID
|
||||
Collab givenRole _ <- lift $ getJust collabID
|
||||
unless (givenRole >= requiredRole) $
|
||||
throwE "The granted role doesn't allow the requested operation"
|
||||
|
||||
|
|
@ -419,7 +364,7 @@ verifyCapability'
|
|||
-> Either
|
||||
(LocalActorBy Key, ActorId, OutboxItemId)
|
||||
(RemoteAuthor, LocalURI, Maybe ByteString)
|
||||
-> LocalActorBy Key
|
||||
-> LocalResourceBy Key
|
||||
-> AP.Role
|
||||
-> ExceptT Text (ReaderT SqlBackend m) ()
|
||||
verifyCapability' cap actor resource role = do
|
||||
|
|
@ -435,30 +380,24 @@ verifyCapability' cap actor resource role = do
|
|||
processRemote (author, _, _) = pure $ remoteAuthorId author
|
||||
|
||||
getGrant
|
||||
:: ( MonadIO m
|
||||
, PersistRecordBackend topic SqlBackend
|
||||
, PersistRecordBackend resource SqlBackend
|
||||
, Show (Key resource)
|
||||
)
|
||||
=> EntityField topic CollabId
|
||||
-> EntityField topic (Key resource)
|
||||
-> Key resource
|
||||
:: MonadIO m
|
||||
=> ResourceId
|
||||
-> PersonId
|
||||
-> ReaderT SqlBackend m (Maybe OutboxItemId)
|
||||
getGrant topicCollabField topicActorField resourceID personID = do
|
||||
getGrant resourceID personID = do
|
||||
items <-
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` enable `E.InnerJoin` grant `E.InnerJoin` recipL) -> do
|
||||
E.select $ E.from $ \ (collab `E.InnerJoin` enable `E.InnerJoin` grant `E.InnerJoin` recipL) -> do
|
||||
E.on $ enable E.^. CollabEnableCollab E.==. recipL E.^. CollabRecipLocalCollab
|
||||
E.on $ enable E.^. CollabEnableGrant E.==. grant E.^. OutboxItemId
|
||||
E.on $ topic E.^. topicCollabField E.==. enable E.^. CollabEnableCollab
|
||||
E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab
|
||||
E.where_ $
|
||||
topic E.^. topicActorField E.==. E.val resourceID E.&&.
|
||||
collab E.^. CollabTopic E.==. E.val resourceID E.&&.
|
||||
recipL E.^. CollabRecipLocalPerson E.==. E.val personID
|
||||
return $ grant E.^. OutboxItemId
|
||||
case items of
|
||||
[] -> return Nothing
|
||||
[E.Value i] -> return $ Just i
|
||||
_ -> error $ "Multiple grants for a Person in resource#" ++ show resourceID
|
||||
_ -> error $ "Multiple grants for a Person in " ++ show resourceID
|
||||
|
||||
getComponentIdent
|
||||
:: MonadIO m
|
||||
|
|
@ -649,7 +588,7 @@ checkExistingStems componentByID projectDB = do
|
|||
const () <$> MaybeT (getBy $ UniqueStemProjectAcceptRemoteProject remoteID)
|
||||
|
||||
checkExistingPermits
|
||||
:: PersonId -> Either (LocalActorBy Key) RemoteActorId -> ActDBE ()
|
||||
:: PersonId -> Either ResourceId RemoteActorId -> ActDBE ()
|
||||
checkExistingPermits personID topicDB = do
|
||||
|
||||
-- Find existing Permit records I have for this topic
|
||||
|
|
@ -682,63 +621,13 @@ checkExistingPermits personID topicDB = do
|
|||
|
||||
where
|
||||
|
||||
getExistingPermits (Left (LocalActorPerson _)) = pure []
|
||||
getExistingPermits (Left (LocalActorRepo repoID)) =
|
||||
getExistingPermits (Left resourceID) =
|
||||
fmap (map $ bimap E.unValue (Left . E.unValue)) $
|
||||
E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do
|
||||
E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicRepoPermit
|
||||
E.select $ E.from $ \ (permit `E.InnerJoin` local) -> do
|
||||
E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit
|
||||
E.where_ $
|
||||
permit E.^. PermitPerson E.==. E.val personID E.&&.
|
||||
topic E.^. PermitTopicRepoRepo E.==. E.val repoID
|
||||
return
|
||||
( permit E.^. PermitId
|
||||
, local E.^. PermitTopicLocalId
|
||||
)
|
||||
getExistingPermits (Left (LocalActorDeck deckID)) =
|
||||
fmap (map $ bimap E.unValue (Left . E.unValue)) $
|
||||
E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do
|
||||
E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicDeckPermit
|
||||
E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit
|
||||
E.where_ $
|
||||
permit E.^. PermitPerson E.==. E.val personID E.&&.
|
||||
topic E.^. PermitTopicDeckDeck E.==. E.val deckID
|
||||
return
|
||||
( permit E.^. PermitId
|
||||
, local E.^. PermitTopicLocalId
|
||||
)
|
||||
getExistingPermits (Left (LocalActorLoom loomID)) =
|
||||
fmap (map $ bimap E.unValue (Left . E.unValue)) $
|
||||
E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do
|
||||
E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicLoomPermit
|
||||
E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit
|
||||
E.where_ $
|
||||
permit E.^. PermitPerson E.==. E.val personID E.&&.
|
||||
topic E.^. PermitTopicLoomLoom E.==. E.val loomID
|
||||
return
|
||||
( permit E.^. PermitId
|
||||
, local E.^. PermitTopicLocalId
|
||||
)
|
||||
getExistingPermits (Left (LocalActorProject projectID)) =
|
||||
fmap (map $ bimap E.unValue (Left . E.unValue)) $
|
||||
E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do
|
||||
E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicProjectPermit
|
||||
E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit
|
||||
E.where_ $
|
||||
permit E.^. PermitPerson E.==. E.val personID E.&&.
|
||||
topic E.^. PermitTopicProjectProject E.==. E.val projectID
|
||||
return
|
||||
( permit E.^. PermitId
|
||||
, local E.^. PermitTopicLocalId
|
||||
)
|
||||
getExistingPermits (Left (LocalActorGroup groupID)) =
|
||||
fmap (map $ bimap E.unValue (Left . E.unValue)) $
|
||||
E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do
|
||||
E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicGroupPermit
|
||||
E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit
|
||||
E.where_ $
|
||||
permit E.^. PermitPerson E.==. E.val personID E.&&.
|
||||
topic E.^. PermitTopicGroupGroup E.==. E.val groupID
|
||||
local E.^. PermitTopicLocalTopic E.==. E.val resourceID
|
||||
return
|
||||
( permit E.^. PermitId
|
||||
, local E.^. PermitTopicLocalId
|
||||
|
|
@ -1120,12 +1009,14 @@ getPermitsForResource personID actor = do
|
|||
PermitTopicEnableLocal _ topicID _ <- getJust enableID
|
||||
byk <- getPermitTopicLocal topicID
|
||||
bye <- do
|
||||
m <- getLocalActorEntity byk
|
||||
m <- getLocalResourceEntity byk
|
||||
case m of
|
||||
Nothing -> error "I just found this PermitTopicLocal in DB but now the specific actor ID isn't found"
|
||||
Just bye -> pure bye
|
||||
a <- getJust $ localActorID bye
|
||||
return (Left (byk, grantID), Left (byk, a))
|
||||
Resource aid <- getJust $ localResourceID bye
|
||||
a <- getJust aid
|
||||
let byk' = resourceToActor byk
|
||||
return (Left (byk', grantID), Left (byk', a))
|
||||
Right (PermitTopicExtendRemote _ enableID grantID) -> do
|
||||
PermitTopicEnableRemote _ topicID _ <- getJust enableID
|
||||
PermitTopicRemote _ remoteActorID <- getJust topicID
|
||||
|
|
|
|||
|
|
@ -179,7 +179,7 @@ checkApplyDB actor capID (repoID, maybeBranch) (loomID, clothID, bundleID) = do
|
|||
case capID of
|
||||
Left (capActor, _, capItem) -> return (capActor, capItem)
|
||||
Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local loom"
|
||||
verifyCapability capability actor (LocalActorLoom loomID) AP.RoleWrite
|
||||
verifyCapability capability actor (LocalResourceLoom loomID) AP.RoleWrite
|
||||
|
||||
-- Get the patches from DB, verify VCS match just in case
|
||||
diffs <- do
|
||||
|
|
|
|||
|
|
@ -92,7 +92,7 @@ verifyCapability''
|
|||
-> Either
|
||||
(LocalActorBy Key, ActorId, OutboxItemId)
|
||||
(RemoteAuthor, LocalURI, Maybe ByteString)
|
||||
-> LocalActorBy Key
|
||||
-> LocalResourceBy Key
|
||||
-> AP.Role
|
||||
-> ActE ()
|
||||
verifyCapability'' uCap recipientActor resource requiredRole = do
|
||||
|
|
@ -100,7 +100,7 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
|
|||
maxDepth <- appMaxGrantChainLength <$> asksEnv envSettings
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
uResource <-
|
||||
encodeRouteHome . VR.renderLocalActor <$> hashLocalActor resource
|
||||
encodeRouteHome . VR.renderLocalResource <$> hashLocalResource resource
|
||||
now <- liftIO getCurrentTime
|
||||
grants <- traverseGrants maxDepth manager uResource now
|
||||
unless (checkRole grants) $
|
||||
|
|
@ -198,7 +198,7 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
|
|||
case cap of
|
||||
Left (actor, _, itemID) -> return (actor, itemID)
|
||||
Right _ -> throwE "Remote, so definitely not by me"
|
||||
unless (capActor == resource) $
|
||||
unless (capActor == resourceToActor resource) $
|
||||
throwE "Capability's actor isn't me, the resource"
|
||||
|
||||
-- Options here:
|
||||
|
|
@ -229,7 +229,7 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
|
|||
-- Find the local topic, on which this Collab gives access
|
||||
topic <- lift $ getCollabTopic collabID
|
||||
-- Verify that topic is indeed the sender of the Grant
|
||||
unless (topic == capActor) $
|
||||
unless (resourceToActor topic == capActor) $
|
||||
error "Grant sender isn't the topic"
|
||||
-- Verify the topic matches the resource specified
|
||||
unless (topic == resource) $
|
||||
|
|
@ -237,7 +237,7 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
|
|||
|
||||
-- There are more Grants in the chain, so we're
|
||||
-- looking for a Stem or Dest record
|
||||
else case actorToComponent capActor of
|
||||
else case (resourceToComponent <=< actorToResource) capActor of
|
||||
Just capTopic -> nameExceptT "Stem" $ do
|
||||
-- Find the Stem record
|
||||
stemID <- do
|
||||
|
|
@ -252,7 +252,7 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
|
|||
unless (topic == capTopic) $
|
||||
error "Grant sender isn't the Stem ident"
|
||||
-- Verify the topic matches the resource specified
|
||||
unless (componentActor topic == resource) $
|
||||
unless (componentResource topic == resource) $
|
||||
throwE "Capability topic is some other local resource"
|
||||
Nothing -> nameExceptT "Dest" $ do
|
||||
-- Find the Dest record
|
||||
|
|
@ -266,11 +266,11 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
|
|||
holder <- lift $ getDestHolder destID
|
||||
let holderActor =
|
||||
either
|
||||
(LocalActorProject . snd)
|
||||
(LocalActorGroup . snd)
|
||||
(LocalResourceProject . snd)
|
||||
(LocalResourceGroup . snd)
|
||||
holder
|
||||
-- Verify that holder is indeed the sender of the Grant
|
||||
unless (holderActor == capActor) $
|
||||
unless (resourceToActor holderActor == capActor) $
|
||||
error "Grant sender isn't the Dest holder"
|
||||
-- Verify the topic matches the resource specified
|
||||
unless (holderActor == resource) $
|
||||
|
|
@ -283,7 +283,7 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
|
|||
throwE "Chain is longer than the max depth"
|
||||
case cap of
|
||||
Left (actor, _, _)
|
||||
| resource == actor ->
|
||||
| resourceToActor resource == actor ->
|
||||
throwE "Grant.delegates specified but Grant's actor is me"
|
||||
_ -> return ()
|
||||
(luResult, _) <- fromMaybeE (AP.grantResult grant) "Grant.result not specified"
|
||||
|
|
@ -428,7 +428,7 @@ checkCapabilityBeforeExtending uCap extender = do
|
|||
|
||||
-- We already checked that the activity exists in DB
|
||||
-- So proceed to find the Stem or Dest record
|
||||
case actorToComponent capActor of
|
||||
case (resourceToComponent <=< actorToResource) capActor of
|
||||
Just capTopic -> nameExceptT "Stem" $ do
|
||||
-- Find the Stem record
|
||||
stemID <- do
|
||||
|
|
@ -444,7 +444,7 @@ checkCapabilityBeforeExtending uCap extender = do
|
|||
error "Grant sender isn't the Stem ident"
|
||||
-- Verify the topic matches the resource specified
|
||||
uTopic <- lift $ lift $ do
|
||||
actorR <- VR.renderLocalActor <$> hashLocalActor (componentActor topic)
|
||||
actorR <- VR.renderLocalResource <$> hashLocalResource (componentResource topic)
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
return $ encodeRouteHome actorR
|
||||
unless (uTopic == AP.grantContext grant) $
|
||||
|
|
|
|||
66
th/models
66
th/models
|
|
@ -591,7 +591,8 @@ RemoteMessage
|
|||
------------------------------------------------------------------------------
|
||||
|
||||
Collab
|
||||
role Role
|
||||
role Role
|
||||
topic ResourceId
|
||||
|
||||
-------------------------------- Collab reason -------------------------------
|
||||
|
||||
|
|
@ -660,38 +661,6 @@ CollabRecipRemoteJoin
|
|||
UniqueCollabRecipRemoteJoinFulfills fulfills
|
||||
UniqueCollabRecipRemoteJoinJoin join
|
||||
|
||||
-------------------------------- Collab topic --------------------------------
|
||||
|
||||
CollabTopicRepo
|
||||
collab CollabId
|
||||
repo RepoId
|
||||
|
||||
UniqueCollabTopicRepo collab
|
||||
|
||||
CollabTopicDeck
|
||||
collab CollabId
|
||||
deck DeckId
|
||||
|
||||
UniqueCollabTopicDeck collab
|
||||
|
||||
CollabTopicLoom
|
||||
collab CollabId
|
||||
loom LoomId
|
||||
|
||||
UniqueCollabTopicLoom collab
|
||||
|
||||
CollabTopicProject
|
||||
collab CollabId
|
||||
project ProjectId
|
||||
|
||||
UniqueCollabTopicProject collab
|
||||
|
||||
CollabTopicGroup
|
||||
collab CollabId
|
||||
group GroupId
|
||||
|
||||
UniqueCollabTopicGroup collab
|
||||
|
||||
-------------------------------- Collab recipient ----------------------------
|
||||
|
||||
CollabRecipLocal
|
||||
|
|
@ -767,39 +736,10 @@ Permit
|
|||
|
||||
PermitTopicLocal
|
||||
permit PermitId
|
||||
topic ResourceId
|
||||
|
||||
UniquePermitTopicLocal permit
|
||||
|
||||
PermitTopicRepo
|
||||
permit PermitTopicLocalId
|
||||
repo RepoId
|
||||
|
||||
UniquePermitTopicRepo permit
|
||||
|
||||
PermitTopicDeck
|
||||
permit PermitTopicLocalId
|
||||
deck DeckId
|
||||
|
||||
UniquePermitTopicDeck permit
|
||||
|
||||
PermitTopicLoom
|
||||
permit PermitTopicLocalId
|
||||
loom LoomId
|
||||
|
||||
UniquePermitTopicLoom permit
|
||||
|
||||
PermitTopicProject
|
||||
permit PermitTopicLocalId
|
||||
project ProjectId
|
||||
|
||||
UniquePermitTopicProject permit
|
||||
|
||||
PermitTopicGroup
|
||||
permit PermitTopicLocalId
|
||||
group GroupId
|
||||
|
||||
UniquePermitTopicGroup permit
|
||||
|
||||
PermitTopicRemote
|
||||
permit PermitId
|
||||
actor RemoteActorId
|
||||
|
|
|
|||
|
|
@ -174,7 +174,7 @@
|
|||
|
||||
/groups/#GroupKeyHashid/members GroupMembersR GET
|
||||
/groups/#GroupKeyHashid/invite GroupInviteR GET POST
|
||||
/groups/#GroupKeyHashid/remove/#CollabTopicGroupId GroupRemoveR POST
|
||||
/groups/#GroupKeyHashid/remove/#CollabId GroupRemoveR POST
|
||||
|
||||
/groups/#GroupKeyHashid/children GroupChildrenR GET
|
||||
/groups/#GroupKeyHashid/children/#DestUsStartKeyHashid/live GroupChildLiveR GET
|
||||
|
|
@ -237,7 +237,7 @@
|
|||
|
||||
/decks/#DeckKeyHashid/collabs DeckCollabsR GET
|
||||
/decks/#DeckKeyHashid/invite DeckInviteR GET POST
|
||||
/decks/#DeckKeyHashid/remove/#CollabTopicDeckId DeckRemoveR POST
|
||||
/decks/#DeckKeyHashid/remove/#CollabId DeckRemoveR POST
|
||||
/decks/#DeckKeyHashid/projects DeckProjectsR GET
|
||||
|
||||
/decks/#DeckKeyHashid/projects/approve/#StemKeyHashid DeckApproveCompR POST
|
||||
|
|
@ -343,7 +343,7 @@
|
|||
|
||||
/projects/#ProjectKeyHashid/collabs ProjectCollabsR GET
|
||||
/projects/#ProjectKeyHashid/invite ProjectInviteR GET POST
|
||||
/projects/#ProjectKeyHashid/remove/#CollabTopicProjectId ProjectRemoveR POST
|
||||
/projects/#ProjectKeyHashid/remove/#CollabId ProjectRemoveR POST
|
||||
|
||||
/projects/#ProjectKeyHashid/components ProjectComponentsR GET
|
||||
/projects/#ProjectKeyHashid/collabs/#CollabEnableKeyHashid/live ProjectCollabLiveR GET
|
||||
|
|
|
|||
Loading…
Reference in a new issue