forge/Vervis
1
0
Fork 0
Code Pull requests Activity

DB: Switch Collab and Permit to use Resource

Browse source 
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 2024-04-26 02:00:41 +03:00
parent 4881154579
commit 888a30e989
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
29 changed files with 805 additions and 807 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

147
migrations/611_2024-04-20_permit_resource.model Normal file
View 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

28
src/Vervis/API.hs
View file

@ -1009,15 +1009,15 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
(loomID, obiid, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do (loomID, obiid, deliverHttpCreate, deliverHttpGrant) <- runDBExcept $ do
-- Find the specified repo in DB -- 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 -- Make sure the repo has a single, full-access collab, granted to the
-- sender of this Create -- sender of this Create
maybeApproved <- lift $ runMaybeT $ do maybeApproved <- lift $ runMaybeT $ do
collabs <- lift $ selectList [CollabTopicRepoRepo ==. repoID] [] collabs <- lift $ selectKeysList [CollabTopic ==. repoResource repo] []
collabID <- collabID <-
case collabs of case collabs of
[Entity _ c] -> return $ collabTopicRepoCollab c [c] -> return c
_ -> mzero _ -> mzero
CollabRecipLocal _ recipID <- CollabRecipLocal _ recipID <-
MaybeT $ getValBy $ UniqueCollabRecipLocal collabID MaybeT $ getValBy $ UniqueCollabRecipLocal collabID
@ -1030,7 +1030,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
-- Insert new loom to DB -- Insert new loom to DB
obiidCreate <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now obiidCreate <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
(loomID, Entity loomActorID loomActor) <- (loomID, resourceID, Entity loomActorID loomActor) <-
lift $ insertLoom now name msummary obiidCreate repoID lift $ insertLoom now name msummary obiidCreate repoID
-- Insert the Create activity to author's outbox -- 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 -- Insert collaboration access for loom's creator
let loomOutboxID = actorOutbox loomActor let loomOutboxID = actorOutbox loomActor
obiidGrant <- lift $ insertEmptyOutboxItem loomOutboxID now obiidGrant <- lift $ insertEmptyOutboxItem loomOutboxID now
lift $ insertCollab loomID obiidGrant lift $ insertCollab resourceID obiidGrant
-- Insert a Grant activity to loom's outbox -- Insert a Grant activity to loom's outbox
let grantRecipActors = [LocalActorPerson senderHash] let grantRecipActors = [LocalActorPerson senderHash]
@ -1139,7 +1139,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
, loomRepo = repoID , loomRepo = repoID
, loomCreate = obiidCreate , loomCreate = obiidCreate
} }
return (loomID, actor) return (loomID, resourceID, actor)
prepareCreate name msummary loomHash repoHash = do prepareCreate name msummary loomHash repoHash = do
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
@ -1167,9 +1167,8 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips
} }
return action { actionSpecific = specific } return action { actionSpecific = specific }
insertCollab loomID obiidGrant = do insertCollab resourceID obiidGrant = do
cid <- insert $ Collab RoleAdmin cid <- insert $ Collab RoleAdmin resourceID
insert_ $ CollabTopicLoom cid loomID
insert_ $ CollabEnable cid obiidGrant insert_ $ CollabEnable cid obiidGrant
insert_ $ CollabRecipLocal cid pidUser insert_ $ CollabRecipLocal cid pidUser
insert_ $ CollabFulfillsLocalTopicCreation cid insert_ $ CollabFulfillsLocalTopicCreation cid
@ -1280,7 +1279,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
-- Insert new repo to DB -- Insert new repo to DB
obiidCreate <- obiidCreate <-
lift $ insertEmptyOutboxItem (actorOutbox senderActor) now lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
(repoID, Entity repoActorID repoActor) <- (repoID, resourceID, Entity repoActorID repoActor) <-
lift $ insertRepo now name msummary obiidCreate lift $ insertRepo now name msummary obiidCreate
-- Insert the Create activity to author's outbox -- 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 -- Insert collaboration access for repo's creator
let repoOutboxID = actorOutbox repoActor let repoOutboxID = actorOutbox repoActor
grantID <- lift $ insertEmptyOutboxItem repoOutboxID now grantID <- lift $ insertEmptyOutboxItem repoOutboxID now
lift $ insertCollab repoID grantID lift $ insertCollab resourceID grantID
-- Insert a Grant activity to repo's outbox -- Insert a Grant activity to repo's outbox
let grantRecipActors = [LocalActorPerson senderHash] let grantRecipActors = [LocalActorPerson senderHash]
@ -1379,7 +1378,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
, repoCreate = createID , repoCreate = createID
, repoLoom = Nothing , repoLoom = Nothing
} }
return (repoID, actor) return (repoID, resourceID, actor)
prepareCreate now name msummary repoHash = do prepareCreate now name msummary repoHash = do
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
@ -1405,9 +1404,8 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r
} }
return action { actionSpecific = specific } return action { actionSpecific = specific }
insertCollab repoID grantID = do insertCollab resourceID grantID = do
collabID <- insert $ Collab RoleAdmin collabID <- insert $ Collab RoleAdmin resourceID
insert_ $ CollabTopicRepo collabID repoID
insert_ $ CollabEnable collabID grantID insert_ $ CollabEnable collabID grantID
insert_ $ CollabRecipLocal collabID pidUser insert_ $ CollabRecipLocal collabID pidUser
insert_ $ CollabFulfillsLocalTopicCreation collabID insert_ $ CollabFulfillsLocalTopicCreation collabID

40
src/Vervis/Access.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- 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. - ♡ 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 Just (Entity rid repo) -> do
role <- do role <- do
case mpid of case mpid of
Just pid -> fromMaybe User <$> asCollab rid pid Just pid -> fromMaybe User <$> asCollab (repoResource repo) pid
Nothing -> pure Guest Nothing -> pure Guest
status <$> roleHasAccess role op status <$> roleHasAccess role op
where where
asCollab rid pid = do asCollab rid pid = do
fmap (const Developer) . listToMaybe <$> do fmap (const Developer) . listToMaybe <$> do
E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` enable) -> do E.select $ E.from $ \ (collab `E.InnerJoin` recip `E.InnerJoin` enable) -> do
E.on $ topic E.^. CollabTopicRepoCollab E.==. enable E.^. CollabEnableCollab E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab
E.on $ topic E.^. CollabTopicRepoCollab E.==. recip E.^. CollabRecipLocalCollab E.on $ collab E.^. CollabId E.==. recip E.^. CollabRecipLocalCollab
E.where_ $ 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 recip E.^. CollabRecipLocalPerson E.==. E.val pid
E.limit 1 E.limit 1
return $ topic E.^. CollabTopicRepoCollab return $ collab E.^. CollabId
checkRepoAccess checkRepoAccess
:: (MonadIO m, MonadSite m, YesodHashids (SiteEnv m)) :: (MonadIO m, MonadSite m, YesodHashids (SiteEnv m))
@ -188,20 +188,20 @@ checkRepoAccess mpid op repoHash = do
Just (Entity rid repo) -> do Just (Entity rid repo) -> do
role <- do role <- do
case mpid of case mpid of
Just pid -> fromMaybe User <$> asCollab rid pid Just pid -> fromMaybe User <$> asCollab (repoResource repo) pid
Nothing -> pure Guest Nothing -> pure Guest
status <$> roleHasAccess role op status <$> roleHasAccess role op
where where
asCollab rid pid = do asCollab rid pid = do
fmap (const Developer) . listToMaybe <$> do fmap (const Developer) . listToMaybe <$> do
E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` enable) -> do E.select $ E.from $ \ (collab `E.InnerJoin` recip `E.InnerJoin` enable) -> do
E.on $ topic E.^. CollabTopicRepoCollab E.==. enable E.^. CollabEnableCollab E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab
E.on $ topic E.^. CollabTopicRepoCollab E.==. recip E.^. CollabRecipLocalCollab E.on $ collab E.^. CollabId E.==. recip E.^. CollabRecipLocalCollab
E.where_ $ 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 recip E.^. CollabRecipLocalPerson E.==. E.val pid
E.limit 1 E.limit 1
return $ topic E.^. CollabTopicRepoCollab return $ collab E.^. CollabId
checkProjectAccess checkProjectAccess
:: (MonadIO m, MonadSite m, YesodHashids (SiteEnv m)) :: (MonadIO m, MonadSite m, YesodHashids (SiteEnv m))
@ -219,17 +219,17 @@ checkProjectAccess mpid op deckHash = do
Just (Entity jid project) -> do Just (Entity jid project) -> do
role <- do role <- do
case mpid of case mpid of
Just pid -> fromMaybe User <$> asCollab jid pid Just pid -> fromMaybe User <$> asCollab (deckResource project) pid
Nothing -> pure Guest Nothing -> pure Guest
status <$> roleHasAccess role op status <$> roleHasAccess role op
where where
asCollab jid pid = do asCollab rid pid = do
fmap (const Developer) . listToMaybe <$> do fmap (const Developer) . listToMaybe <$> do
E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` enable) -> do E.select $ E.from $ \ (collab `E.InnerJoin` recip `E.InnerJoin` enable) -> do
E.on $ topic E.^. CollabTopicDeckCollab E.==. enable E.^. CollabEnableCollab E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab
E.on $ topic E.^. CollabTopicDeckCollab E.==. recip E.^. CollabRecipLocalCollab E.on $ collab E.^. CollabId E.==. recip E.^. CollabRecipLocalCollab
E.where_ $ 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 recip E.^. CollabRecipLocalPerson E.==. E.val pid
E.limit 1 E.limit 1
return $ topic E.^. CollabTopicDeckCollab return $ collab E.^. CollabId

10
src/Vervis/Actor.hs
View file

@ -162,6 +162,11 @@ data LocalActorBy f
| LocalActorProject (f Project) | LocalActorProject (f Project)
deriving (Generic, FunctorB, ConstraintsB) 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 data LocalResourceBy f
= LocalResourceGroup (f Group) = LocalResourceGroup (f Group)
| LocalResourceRepo (f Repo) | LocalResourceRepo (f Repo)
@ -170,10 +175,7 @@ data LocalResourceBy f
| LocalResourceProject (f Project) | LocalResourceProject (f Project)
deriving (Generic, FunctorB, ConstraintsB) deriving (Generic, FunctorB, ConstraintsB)
deriving instance AllBF Eq f LocalActorBy => Eq (LocalActorBy f) deriving instance AllBF Eq f LocalResourceBy => Eq (LocalResourceBy 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)
type LocalActor = LocalActorBy KeyHashid type LocalActor = LocalActorBy KeyHashid

277
src/Vervis/Actor/Common.hs
View file

@ -231,14 +231,14 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m
topicAccept topicAccept
:: forall topic. :: forall topic.
(PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
=> (topic -> ActorId) => (topic -> ResourceId)
-> (forall f. f topic -> ComponentBy f) -> (forall f. f topic -> ComponentBy f)
-> UTCTime -> UTCTime
-> Key topic -> Key topic
-> Verse -> Verse
-> AP.Accept URIMode -> AP.Accept URIMode
-> ActE (Text, Act (), Next) -> 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 -- Check input
acceptee <- parseAccept accept acceptee <- parseAccept accept
@ -252,10 +252,11 @@ topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) acc
(AP.activityCapability $ actbActivity body) (AP.activityCapability $ actbActivity body)
-- Grab me from DB -- Grab me from DB
(recipActorID, recipActor) <- lift $ withDB $ do (resourceID, recipActorID, recipActor) <- lift $ withDB $ do
recip <- getJust recipKey resourceID <- grabResource <$> getJust recipKey
let actorID = topicActor recip Resource recipActorID <- getJust resourceID
(actorID,) <$> getJust actorID recipActor <- getJust recipActorID
return (resourceID, recipActorID, recipActor)
collabOrStem <- withDBExcept $ do collabOrStem <- withDBExcept $ do
@ -284,8 +285,8 @@ topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) acc
where where
topicResource :: forall f. f topic -> LocalActorBy f topicResource :: forall f. f topic -> LocalResourceBy f
topicResource = componentActor . topicComponent topicResource = componentResource . topicComponent
tryInviteCollab (Left (actorByKey, _actorEntity, itemID)) = tryInviteCollab (Left (actorByKey, _actorEntity, itemID)) =
(,Left actorByKey) . collabInviterLocalCollab <$> (,Left actorByKey) . collabInviterLocalCollab <$>
@ -346,7 +347,7 @@ topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) acc
audAccepter <- makeAudSenderWithFollowers authorIdMsig audAccepter <- makeAudSenderWithFollowers authorIdMsig
audApprover <- lift $ makeAudSenderOnly authorIdMsig audApprover <- lift $ makeAudSenderOnly authorIdMsig
recipHash <- encodeKeyHashid recipKey recipHash <- encodeKeyHashid recipKey
let topicByHash = topicResource recipHash let topicByHash = resourceToActor $ topicResource recipHash
senderHash <- bitraverse hashLocalActor pure sender senderHash <- bitraverse hashLocalActor pure sender
@ -480,7 +481,7 @@ topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) acc
_ -> error "topicAccept impossible" _ -> error "topicAccept impossible"
-- Prepare forwarding of Accept to my followers -- Prepare forwarding of Accept to my followers
let recipByID = topicResource recipKey let recipByID = resourceToActor $ topicResource recipKey
recipByHash <- hashLocalActor recipByID recipByHash <- hashLocalActor recipByID
let sieve = makeRecipientSet [] [localActorFollowers recipByHash] let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
@ -494,9 +495,9 @@ topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) acc
let inviterOrJoiner = either snd snd collab let inviterOrJoiner = either snd snd collab
isInvite = isLeft collab isInvite = isLeft collab
grant@(actionGrant, _, _, _) <- do grant@(actionGrant, _, _, _) <- do
Collab role <- lift $ getJust collabID Collab role _ <- lift $ getJust collabID
lift $ prepareGrant isInvite inviterOrJoiner role lift $ prepareGrant isInvite inviterOrJoiner role
let recipByKey = topicResource recipKey let recipByKey = resourceToActor $ topicResource recipKey
_luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant _luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant
return (grantID, grant) return (grantID, grant)
@ -505,7 +506,7 @@ topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) acc
case maybeNew of case maybeNew of
Nothing -> done "I already have this activity in my inbox" Nothing -> done "I already have this activity in my inbox"
Just (recipActorID, sieve, (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant))) -> do Just (recipActorID, sieve, (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant))) -> do
let recipByID = topicResource recipKey let recipByID = resourceToActor $ topicResource recipKey
forwardActivity authorIdMsig body recipByID recipActorID sieve forwardActivity authorIdMsig body recipByID recipActorID sieve
lift $ sendActivity lift $ sendActivity
recipByID recipActorID localRecipsGrant recipByID recipActorID localRecipsGrant
@ -544,7 +545,7 @@ topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) acc
audAccepter <- lift $ makeAudSenderOnly authorIdMsig audAccepter <- lift $ makeAudSenderOnly authorIdMsig
audMe <- audMe <-
AudLocal [] . pure . localActorFollowers . AudLocal [] . pure . localActorFollowers .
topicResource <$> resourceToActor . topicResource <$>
encodeKeyHashid recipKey encodeKeyHashid recipKey
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = 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 insert_ $ StemComponentGestureRemote stemID (remoteAuthorId author) acceptID
-- Prepare forwarding of Accept to my followers -- Prepare forwarding of Accept to my followers
let recipByID = topicResource recipKey let recipByID = resourceToActor $ topicResource recipKey
recipByHash <- hashLocalActor recipByID recipByHash <- hashLocalActor recipByID
let sieve = makeRecipientSet [] [localActorFollowers recipByHash] 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 -- Prepare an Accept activity and insert to my outbox
react@(actionReact, _, _, _) <- lift $ prepareReact project inviter react@(actionReact, _, _, _) <- lift $ prepareReact project inviter
let recipByKey = topicResource recipKey let recipByKey = resourceToActor $ topicResource recipKey
_luReact <- lift $ updateOutboxItem' recipByKey reactID actionReact _luReact <- lift $ updateOutboxItem' recipByKey reactID actionReact
return (reactID, react) 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" Nothing -> done "I already have this activity in my inbox"
Just Nothing -> done "Done" Just Nothing -> done "Done"
Just (Just (sieve, (reactID, (actionReact, localRecipsReact, remoteRecipsReact, fwdHostsReact)))) -> do Just (Just (sieve, (reactID, (actionReact, localRecipsReact, remoteRecipsReact, fwdHostsReact)))) -> do
let recipByID = topicResource recipKey let recipByID = resourceToActor $ topicResource recipKey
forwardActivity authorIdMsig body recipByID recipActorID sieve forwardActivity authorIdMsig body recipByID recipActorID sieve
lift $ sendActivity lift $ sendActivity
recipByID recipActorID localRecipsReact recipByID recipActorID localRecipsReact
@ -693,14 +694,14 @@ topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) acc
topicReject topicReject
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
=> (topic -> ActorId) => (topic -> ResourceId)
-> (forall f. f topic -> LocalActorBy f) -> (forall f. f topic -> LocalResourceBy f)
-> UTCTime -> UTCTime
-> Key topic -> Key topic
-> Verse -> Verse
-> AP.Reject URIMode -> AP.Reject URIMode
-> ActE (Text, Act (), Next) -> 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 -- Check input
rejectee <- parseReject reject rejectee <- parseReject reject
@ -716,10 +717,9 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
maybeNew <- withDBExcept $ do maybeNew <- withDBExcept $ do
-- Grab me from DB -- Grab me from DB
(recipActorID, recipActor) <- lift $ do resourceID <- lift $ grabResource <$> getJust recipKey
recip <- getJust recipKey Resource recipActorID <- lift $ getJust resourceID
let actorID = topicActor recip recipActor <- lift $ getJust recipActorID
(actorID,) <$> getJust actorID
-- Find the rejected activity in our DB -- Find the rejected activity in our DB
rejecteeDB <- do rejecteeDB <- do
@ -742,7 +742,7 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
collabFulfillsInviteCollab <$> getJust fulfillsID collabFulfillsInviteCollab <$> getJust fulfillsID
Right (fulfillsID, _, _, _) -> Right (fulfillsID, _, _, _) ->
collabFulfillsJoinCollab <$> getJust fulfillsID collabFulfillsJoinCollab <$> getJust fulfillsID
(deleteTopic, topic) <- lift $ getCollabTopic' collabID topic <- lift $ getCollabTopic collabID
unless (topicResource recipKey == topic) $ unless (topicResource recipKey == topic) $
throwE "Accept object is an Invite/Join for some other resource" 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 case idsForReject of
Left (fulfillsID, recipID, deleteInviter) -> lift $ do Left (fulfillsID, recipID, deleteInviter) -> lift $ do
bitraverse_ delete delete recipID bitraverse_ delete delete recipID
deleteTopic
deleteInviter deleteInviter
delete fulfillsID delete fulfillsID
Right (fulfillsID, deleteRecipJoin, deleteRecip) -> lift $ do Right (fulfillsID, deleteRecipJoin, deleteRecip) -> lift $ do
deleteRecipJoin deleteRecipJoin
deleteRecip deleteRecip
deleteTopic
delete fulfillsID delete fulfillsID
lift $ delete collabID lift $ delete collabID
-- Prepare forwarding of Reject to my followers -- Prepare forwarding of Reject to my followers
let recipByID = topicResource recipKey let recipByID = resourceToActor $ topicResource recipKey
recipByHash <- hashLocalActor recipByID recipByHash <- hashLocalActor recipByID
let sieve = makeRecipientSet [] [localActorFollowers recipByHash] let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
@ -832,7 +830,7 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
isInvite = isLeft collab isInvite = isLeft collab
newReject@(actionReject, _, _, _) <- newReject@(actionReject, _, _, _) <-
lift $ prepareReject isInvite inviterOrJoiner lift $ prepareReject isInvite inviterOrJoiner
let recipByKey = topicResource recipKey let recipByKey = resourceToActor $ topicResource recipKey
_luNewReject <- lift $ updateOutboxItem' recipByKey newRejectID actionReject _luNewReject <- lift $ updateOutboxItem' recipByKey newRejectID actionReject
return (newRejectID, newReject) return (newRejectID, newReject)
@ -841,7 +839,7 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
case maybeNew of case maybeNew of
Nothing -> done "I already have this activity in my inbox" Nothing -> done "I already have this activity in my inbox"
Just (recipActorID, sieve, (newRejectID, (action, localRecips, remoteRecips, fwdHosts))) -> do Just (recipActorID, sieve, (newRejectID, (action, localRecips, remoteRecips, fwdHosts))) -> do
let recipByID = topicResource recipKey let recipByID = resourceToActor $ topicResource recipKey
forwardActivity authorIdMsig body recipByID recipActorID sieve forwardActivity authorIdMsig body recipByID recipActorID sieve
lift $ sendActivity lift $ sendActivity
recipByID recipActorID localRecips recipByID recipActorID localRecips
@ -884,7 +882,7 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
audRejecter <- makeAudSenderWithFollowers authorIdMsig audRejecter <- makeAudSenderWithFollowers authorIdMsig
audForbidder <- lift $ makeAudSenderOnly authorIdMsig audForbidder <- lift $ makeAudSenderOnly authorIdMsig
recipHash <- encodeKeyHashid recipKey recipHash <- encodeKeyHashid recipKey
let topicByHash = topicResource recipHash let topicByHash = resourceToActor $ topicResource recipHash
senderHash <- bitraverse hashLocalActor pure sender senderHash <- bitraverse hashLocalActor pure sender
@ -949,21 +947,17 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje
topicInvite topicInvite
:: forall topic ct si. :: forall topic ct si.
( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic ( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic
, PersistRecordBackend ct SqlBackend
, PersistRecordBackend si SqlBackend , PersistRecordBackend si SqlBackend
) )
=> (topic -> ActorId) => (topic -> ResourceId)
-> (forall f. f topic -> ComponentBy f) -> (forall f. f topic -> ComponentBy f)
-> EntityField ct (Key topic)
-> EntityField ct CollabId
-> (CollabId -> Key topic -> ct)
-> (StemId -> Key topic -> si) -> (StemId -> Key topic -> si)
-> UTCTime -> UTCTime
-> Key topic -> Key topic
-> Verse -> Verse
-> AP.Invite URIMode -> AP.Invite URIMode
-> ActE (Text, Act (), Next) -> 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 -- Check invite
recipOrProject <- do recipOrProject <- do
@ -1094,10 +1088,9 @@ topicInvite grabActor topicComponent topicField topicCollabField collabTopicCtor
maybeNew <- withDBExcept $ do maybeNew <- withDBExcept $ do
-- Grab me from DB -- Grab me from DB
(topicActorID, topicActor) <- lift $ do resourceID <- lift $ grabResource <$> getJust topicKey
recip <- getJust topicKey Resource topicActorID <- lift $ getJust resourceID
let actorID = grabActor recip topicActor <- lift $ getJust topicActorID
(actorID,) <$> getJust actorID
case recipOrProjectDB of case recipOrProjectDB of
Left (role, capability, _targetByKey, targetDB) -> do Left (role, capability, _targetByKey, targetDB) -> do
@ -1110,21 +1103,21 @@ topicInvite grabActor topicComponent topicField topicCollabField collabTopicCtor
existingCollabIDs <- existingCollabIDs <-
lift $ case targetDB of lift $ case targetDB of
Left (GrantRecipPerson (Entity personID _)) -> Left (GrantRecipPerson (Entity personID _)) ->
E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do E.select $ E.from $ \ (collab `E.InnerJoin` recipl) -> do
E.on $ E.on $
topic E.^. topicCollabField E.==. collab E.^. CollabId E.==.
recipl E.^. CollabRecipLocalCollab recipl E.^. CollabRecipLocalCollab
E.where_ $ 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 recipl E.^. CollabRecipLocalPerson E.==. E.val personID
return $ recipl E.^. CollabRecipLocalCollab return $ recipl E.^. CollabRecipLocalCollab
Right remoteActorID -> Right remoteActorID ->
E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do E.select $ E.from $ \ (collab `E.InnerJoin` recipr) -> do
E.on $ E.on $
topic E.^. topicCollabField E.==. collab E.^. CollabId E.==.
recipr E.^. CollabRecipRemoteCollab recipr E.^. CollabRecipRemoteCollab
E.where_ $ 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 recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID
return $ recipr E.^. CollabRecipRemoteCollab return $ recipr E.^. CollabRecipRemoteCollab
case existingCollabIDs of case existingCollabIDs of
@ -1146,7 +1139,7 @@ topicInvite grabActor topicComponent topicField topicCollabField collabTopicCtor
sieve <- do sieve <- do
topicHash <- encodeKeyHashid topicKey topicHash <- encodeKeyHashid topicKey
let topicByHash = let topicByHash =
topicResource topicHash resourceToActor $ topicResource topicHash
return $ makeRecipientSet [] [localActorFollowers topicByHash] return $ makeRecipientSet [] [localActorFollowers topicByHash]
-- Insert Collab or Stem record to DB -- Insert Collab or Stem record to DB
@ -1155,9 +1148,9 @@ topicInvite grabActor topicComponent topicField topicCollabField collabTopicCtor
maybeAccept <- case recipOrProjectDB of maybeAccept <- case recipOrProjectDB of
Left (role, _capability, targetByKey, targetDB) -> Just <$> do Left (role, _capability, targetByKey, targetDB) -> Just <$> do
acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
insertCollab role targetDB inviteDB acceptID insertCollab resourceID role targetDB inviteDB acceptID
accept@(actionAccept, _, _, _) <- lift $ prepareAccept targetByKey accept@(actionAccept, _, _, _) <- lift $ prepareAccept targetByKey
let topicByKey = topicResource topicKey let topicByKey = resourceToActor $ topicResource topicKey
_luAccept <- updateOutboxItem' topicByKey acceptID actionAccept _luAccept <- updateOutboxItem' topicByKey acceptID actionAccept
return (acceptID, accept) return (acceptID, accept)
Right projectDB -> do Right projectDB -> do
@ -1169,7 +1162,7 @@ topicInvite grabActor topicComponent topicField topicCollabField collabTopicCtor
case maybeNew of case maybeNew of
Nothing -> done "I already have this activity in my inbox" Nothing -> done "I already have this activity in my inbox"
Just (topicActorID, sieve, maybeAccept) -> do Just (topicActorID, sieve, maybeAccept) -> do
let topicByID = topicResource topicKey let topicByID = resourceToActor $ topicResource topicKey
forwardActivity authorIdMsig body topicByID topicActorID sieve forwardActivity authorIdMsig body topicByID topicActorID sieve
lift $ for_ maybeAccept $ \ (acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> lift $ for_ maybeAccept $ \ (acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) ->
sendActivity sendActivity
@ -1179,13 +1172,12 @@ topicInvite grabActor topicComponent topicField topicCollabField collabTopicCtor
where where
topicResource :: forall f. f topic -> LocalActorBy f topicResource :: forall f. f topic -> LocalResourceBy f
topicResource = componentActor . topicComponent topicResource = componentResource . topicComponent
insertCollab role recipient inviteDB acceptID = do insertCollab resourceID role recipient inviteDB acceptID = do
collabID <- insert $ Collab role collabID <- insert $ Collab role resourceID
fulfillsID <- insert $ CollabFulfillsInvite collabID acceptID fulfillsID <- insert $ CollabFulfillsInvite collabID acceptID
insert_ $ collabTopicCtor collabID topicKey
case inviteDB of case inviteDB of
Left (_, _, inviteID) -> Left (_, _, inviteID) ->
insert_ $ CollabInviterLocal fulfillsID inviteID insert_ $ CollabInviterLocal fulfillsID inviteID
@ -1225,8 +1217,7 @@ topicInvite grabActor topicComponent topicField topicCollabField collabTopicCtor
Right (ObjURI h lu) -> return $ AudRemote h [lu] [] Right (ObjURI h lu) -> return $ AudRemote h [lu] []
audTopic <- audTopic <-
AudLocal [] . pure . localActorFollowers . AudLocal [] . pure . localActorFollowers .
topicResource <$> resourceToActor . topicResource <$> encodeKeyHashid topicKey
encodeKeyHashid topicKey
uInvite <- getActivityURI authorIdMsig uInvite <- getActivityURI authorIdMsig
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
@ -1247,19 +1238,15 @@ topicInvite grabActor topicComponent topicField topicCollabField collabTopicCtor
return (action, recipientSet, remoteActors, fwdHosts) return (action, recipientSet, remoteActors, fwdHosts)
topicRemove topicRemove
:: ( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
, PersistRecordBackend ct SqlBackend => (topic -> ResourceId)
) -> (forall f. f topic -> LocalResourceBy f)
=> (topic -> ActorId)
-> (forall f. f topic -> LocalActorBy f)
-> EntityField ct (Key topic)
-> EntityField ct CollabId
-> UTCTime -> UTCTime
-> Key topic -> Key topic
-> Verse -> Verse
-> AP.Remove URIMode -> AP.Remove URIMode
-> ActE (Text, Act (), Next) -> 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 -- Check capability
capability <- do capability <- do
@ -1310,10 +1297,9 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
memberByKey memberByKey
-- Grab me from DB -- Grab me from DB
(topicActorID, topicActor) <- lift $ do resourceID <- lift $ grabResource <$> getJust topicKey
recip <- getJust topicKey Resource topicActorID <- lift $ getJust resourceID
let actorID = grabActor recip topicActor <- lift $ getJust topicActorID
(actorID,) <$> getJust actorID
-- Verify the specified capability gives relevant access -- Verify the specified capability gives relevant access
verifyCapability' verifyCapability'
@ -1323,34 +1309,32 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
existingCollabIDs <- existingCollabIDs <-
lift $ case memberDB of lift $ case memberDB of
Left (Entity personID _) -> Left (Entity personID _) ->
fmap (map $ over _2 Left) $ fmap (map $ over _1 Left) $
E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do E.select $ E.from $ \ (collab `E.InnerJoin` recipl) -> do
E.on $ E.on $
topic E.^. topicCollabField E.==. collab E.^. CollabId E.==.
recipl E.^. CollabRecipLocalCollab recipl E.^. CollabRecipLocalCollab
E.where_ $ 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 recipl E.^. CollabRecipLocalPerson E.==. E.val personID
return return
( topic E.^. persistIdField ( recipl E.^. persistIdField
, recipl E.^. persistIdField
, recipl E.^. CollabRecipLocalCollab , recipl E.^. CollabRecipLocalCollab
) )
Right (Entity remoteActorID _, _) -> Right (Entity remoteActorID _, _) ->
fmap (map $ over _2 Right) $ fmap (map $ over _1 Right) $
E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do E.select $ E.from $ \ (collab `E.InnerJoin` recipr) -> do
E.on $ E.on $
topic E.^. topicCollabField E.==. collab E.^. CollabId E.==.
recipr E.^. CollabRecipRemoteCollab recipr E.^. CollabRecipRemoteCollab
E.where_ $ 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 recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID
return return
( topic E.^. persistIdField ( recipr E.^. persistIdField
, recipr E.^. persistIdField
, recipr E.^. CollabRecipRemoteCollab , recipr E.^. CollabRecipRemoteCollab
) )
(E.Value topicID, recipID, E.Value collabID) <- (recipID, E.Value collabID) <-
case existingCollabIDs of case existingCollabIDs of
[] -> throwE "Remove object isn't a member of me" [] -> throwE "Remove object isn't a member of me"
[collab] -> return collab [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 -- Verify that at least 1 more enabled Admin collab for me exists
otherCollabIDs <- otherCollabIDs <-
lift $ E.select $ E.from $ \ (topic `E.InnerJoin` enable) -> do lift $ E.select $ E.from $ \ (collab `E.InnerJoin` enable) -> do
E.on $ E.on $
topic E.^. topicCollabField E.==. collab E.^. CollabId E.==.
enable E.^. CollabEnableCollab enable E.^. CollabEnableCollab
E.where_ $ E.where_ $
topic E.^. topicField E.==. E.val topicKey E.&&. collab E.^. CollabTopic E.==. E.val resourceID E.&&.
topic E.^. topicCollabField E.!=. E.val collabID collab E.^. CollabId E.!=. E.val collabID
return $ topic E.^. topicCollabField return $ collab E.^. CollabId
when (null otherCollabIDs) $ when (null otherCollabIDs) $
throwE "No other admins exist, can't remove" throwE "No other admins exist, can't remove"
@ -1390,7 +1374,6 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
deleteBy $ UniqueCollabRecipRemoteJoinCollab r deleteBy $ UniqueCollabRecipRemoteJoinCollab r
deleteBy $ UniqueCollabRecipRemoteAcceptCollab r deleteBy $ UniqueCollabRecipRemoteAcceptCollab r
delete r delete r
delete topicID
fulfills <- do fulfills <- do
mf <- runMaybeT $ asum mf <- runMaybeT $ asum
[ Left <$> MaybeT (getKeyBy $ UniqueCollabFulfillsLocalTopicCreation collabID) [ Left <$> MaybeT (getKeyBy $ UniqueCollabFulfillsLocalTopicCreation collabID)
@ -1413,14 +1396,13 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
-- Prepare forwarding Remove to my followers -- Prepare forwarding Remove to my followers
sieve <- lift $ do sieve <- lift $ do
topicHash <- encodeKeyHashid topicKey topicHash <- encodeKeyHashid topicKey
let topicByHash = let topicByHash = resourceToActor $ topicResource topicHash
topicResource topicHash
return $ makeRecipientSet [] [localActorFollowers topicByHash] return $ makeRecipientSet [] [localActorFollowers topicByHash]
-- Prepare a Revoke activity and insert to my outbox -- Prepare a Revoke activity and insert to my outbox
revoke@(actionRevoke, _, _, _) <- revoke@(actionRevoke, _, _, _) <-
lift $ prepareRevoke memberDB grantID lift $ prepareRevoke memberDB grantID
let recipByKey = topicResource topicKey let recipByKey = resourceToActor $ topicResource topicKey
revokeID <- insertEmptyOutboxItem' (actorOutbox topicActor) now revokeID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
_luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke _luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke
@ -1429,7 +1411,7 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
case maybeNew of case maybeNew of
Nothing -> done "I already have this activity in my inbox" Nothing -> done "I already have this activity in my inbox"
Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke)) -> do Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke)) -> do
let topicByID = topicResource topicKey let topicByID = resourceToActor $ topicResource topicKey
forwardActivity authorIdMsig body topicByID topicActorID sieve forwardActivity authorIdMsig body topicByID topicActorID sieve
lift $ sendActivity lift $ sendActivity
topicByID topicActorID localRecipsRevoke topicByID topicActorID localRecipsRevoke
@ -1443,7 +1425,7 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
recipHash <- encodeKeyHashid topicKey recipHash <- encodeKeyHashid topicKey
let topicByHash = topicResource recipHash let topicByHash = resourceToActor $ topicResource recipHash
memberHash <- bitraverse (encodeKeyHashid . entityKey) pure member memberHash <- bitraverse (encodeKeyHashid . entityKey) pure member
@ -1479,20 +1461,15 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
return (action, recipientSet, remoteActors, fwdHosts) return (action, recipientSet, remoteActors, fwdHosts)
topicJoin topicJoin
:: ( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
, PersistRecordBackend ct SqlBackend => (topic -> ResourceId)
) -> (forall f. f topic -> LocalResourceBy f)
=> (topic -> ActorId)
-> (forall f. f topic -> LocalActorBy f)
-> EntityField ct (Key topic)
-> EntityField ct CollabId
-> (CollabId -> Key topic -> ct)
-> UTCTime -> UTCTime
-> Key topic -> Key topic
-> Verse -> Verse
-> AP.Join URIMode -> AP.Join URIMode
-> ActE (Text, Act (), Next) -> 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 -- Check input
(role, resource) <- parseJoin join (role, resource) <- parseJoin join
@ -1502,32 +1479,31 @@ topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor no
maybeNew <- withDBExcept $ do maybeNew <- withDBExcept $ do
-- Grab me from DB -- Grab me from DB
(topicActorID, topicActor) <- lift $ do resourceID <- lift $ grabResource <$> getJust topicKey
recip <- getJust topicKey Resource topicActorID <- lift $ getJust resourceID
let actorID = grabActor recip topicActor <- lift $ getJust topicActorID
(actorID,) <$> getJust actorID
-- Verify that target doesn't already have a Collab for me -- Verify that target doesn't already have a Collab for me
existingCollabIDs <- lift $ existingCollabIDs <- lift $
case authorIdMsig of case authorIdMsig of
Left (LocalActorPerson personID, _, _) -> Left (LocalActorPerson personID, _, _) ->
E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do E.select $ E.from $ \ (collab `E.InnerJoin` recipl) -> do
E.on $ E.on $
topic E.^. topicCollabField E.==. collab E.^. CollabId E.==.
recipl E.^. CollabRecipLocalCollab recipl E.^. CollabRecipLocalCollab
E.where_ $ 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 recipl E.^. CollabRecipLocalPerson E.==. E.val personID
return $ recipl E.^. CollabRecipLocalCollab return $ recipl E.^. CollabRecipLocalCollab
Left (_, _, _) -> pure [] Left (_, _, _) -> pure []
Right (author, _, _) -> do Right (author, _, _) -> do
let targetID = remoteAuthorId author let targetID = remoteAuthorId author
E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do E.select $ E.from $ \ (collab `E.InnerJoin` recipr) -> do
E.on $ E.on $
topic E.^. topicCollabField E.==. collab E.^. CollabId E.==.
recipr E.^. CollabRecipRemoteCollab recipr E.^. CollabRecipRemoteCollab
E.where_ $ 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 recipr E.^. CollabRecipRemoteActor E.==. E.val targetID
return $ recipr E.^. CollabRecipRemoteCollab return $ recipr E.^. CollabRecipRemoteCollab
case existingCollabIDs of case existingCollabIDs of
@ -1548,29 +1524,27 @@ topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor no
) )
pure pure
joinDB joinDB
lift $ insertCollab role joinDB' lift $ insertCollab resourceID role joinDB'
-- Prepare forwarding Join to my followers -- Prepare forwarding Join to my followers
sieve <- lift $ do sieve <- lift $ do
topicHash <- encodeKeyHashid topicKey topicHash <- encodeKeyHashid topicKey
let topicByHash = let topicByHash = resourceToActor $ topicResource topicHash
topicResource topicHash
return $ makeRecipientSet [] [localActorFollowers topicByHash] return $ makeRecipientSet [] [localActorFollowers topicByHash]
return (topicActorID, sieve) return (topicActorID, sieve)
case maybeNew of case maybeNew of
Nothing -> done "I already have this activity in my inbox" Nothing -> done "I already have this activity in my inbox"
Just (topicActorID, sieve) -> do Just (topicActorID, sieve) -> do
let topicByID = topicResource topicKey let topicByID = resourceToActor $ topicResource topicKey
forwardActivity authorIdMsig body topicByID topicActorID sieve forwardActivity authorIdMsig body topicByID topicActorID sieve
done "Recorded and forwarded the Join" done "Recorded and forwarded the Join"
where where
insertCollab role joinDB = do insertCollab resourceID role joinDB = do
collabID <- insert $ Collab role collabID <- insert $ Collab role resourceID
fulfillsID <- insert $ CollabFulfillsJoin collabID fulfillsID <- insert $ CollabFulfillsJoin collabID
insert_ $ collabTopicCtor collabID topicKey
case joinDB of case joinDB of
Left (personID, joinID) -> do Left (personID, joinID) -> do
recipID <- insert $ CollabRecipLocal collabID personID recipID <- insert $ CollabRecipLocal collabID personID
@ -1581,26 +1555,21 @@ topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor no
insert_ $ CollabRecipRemoteJoin recipID fulfillsID joinID insert_ $ CollabRecipRemoteJoin recipID fulfillsID joinID
topicCreateMe topicCreateMe
:: ( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
, PersistRecordBackend ct SqlBackend => (topic -> ResourceId)
) -> (forall f. f topic -> LocalResourceBy f)
=> (topic -> ActorId)
-> (forall f. f topic -> LocalActorBy f)
-> EntityField ct (Key topic)
-> (CollabId -> Key topic -> ct)
-> UTCTime -> UTCTime
-> Key topic -> Key topic
-> Verse -> Verse
-> ActE (Text, Act (), Next) -> 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 maybeNew <- withDBExcept $ do
-- Grab me from DB -- Grab me from DB
(recipActorID, recipActor) <- lift $ do resourceID <- lift $ grabResource <$> getJust recipKey
recip <- getJust recipKey Resource recipActorID <- lift $ getJust resourceID
let actorID = topicActor recip recipActor <- lift $ getJust recipActorID
(actorID,) <$> getJust actorID
-- Verify I'm in the initial just-been-created state -- Verify I'm in the initial just-been-created state
creatorActorID <- creatorActorID <-
@ -1611,7 +1580,7 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
mp <- lift $ getKeyBy $ UniquePersonActor creatorActorID mp <- lift $ getKeyBy $ UniquePersonActor creatorActorID
fromMaybeE mp "Granting access to local non-Person actors isn't suppported currently" fromMaybeE mp "Granting access to local non-Person actors isn't suppported currently"
existingCollabIDs <- existingCollabIDs <-
lift $ selectList [collabTopicFieldTopic ==. recipKey] [] lift $ selectList [CollabTopic ==. resourceID] []
unless (null existingCollabIDs) $ unless (null existingCollabIDs) $
error "Just-been-created but I somehow already have Collabs" 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 -- Create a Collab record and exit just-been-created state
grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now grantID <- insertEmptyOutboxItem' (actorOutbox recipActor) now
insertCollab creatorPersonID grantID insertCollab resourceID creatorPersonID grantID
update creatorActorID [ActorJustCreatedBy =. Nothing] update creatorActorID [ActorJustCreatedBy =. Nothing]
-- Prepare a Grant activity and insert to my outbox -- Prepare a Grant activity and insert to my outbox
grant@(actionGrant, _, _, _) <- lift prepareGrant grant@(actionGrant, _, _, _) <- lift prepareGrant
let recipByKey = topicResource recipKey let recipByKey = resourceToActor $ topicResource recipKey
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant _luGrant <- updateOutboxItem' recipByKey grantID actionGrant
return (recipActorID, grantID, grant) return (recipActorID, grantID, grant)
@ -1638,7 +1607,7 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
case maybeNew of case maybeNew of
Nothing -> done "I already have this activity in my inbox" Nothing -> done "I already have this activity in my inbox"
Just (recipActorID, grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) -> do Just (recipActorID, grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) -> do
let recipByID = topicResource recipKey let recipByID = resourceToActor $ topicResource recipKey
lift $ sendActivity lift $ sendActivity
recipByID recipActorID localRecipsGrant recipByID recipActorID localRecipsGrant
remoteRecipsGrant fwdHostsGrant grantID actionGrant remoteRecipsGrant fwdHostsGrant grantID actionGrant
@ -1646,9 +1615,8 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
where where
insertCollab personID grantID = do insertCollab resourceID personID grantID = do
collabID <- insert $ Collab AP.RoleAdmin collabID <- insert $ Collab AP.RoleAdmin resourceID
insert_ $ collabTopicCtor collabID recipKey
insert_ $ CollabEnable collabID grantID insert_ $ CollabEnable collabID grantID
insert_ $ CollabRecipLocal collabID personID insert_ $ CollabRecipLocal collabID personID
insert_ $ CollabFulfillsLocalTopicCreation collabID insert_ $ CollabFulfillsLocalTopicCreation collabID
@ -1661,7 +1629,7 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
recipHash <- encodeKeyHashid recipKey recipHash <- encodeKeyHashid recipKey
uCreator <- getActorURI authorIdMsig uCreator <- getActorURI authorIdMsig
uCreate <- getActivityURI authorIdMsig uCreate <- getActivityURI authorIdMsig
let topicByHash = topicResource recipHash let topicByHash = resourceToActor $ topicResource recipHash
audience = audience =
let audTopic = AudLocal [] [localActorFollowers topicByHash] let audTopic = AudLocal [] [localActorFollowers topicByHash]
in [audCreator, audTopic] in [audCreator, audTopic]
@ -1717,14 +1685,14 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now
componentGrant componentGrant
:: forall topic. :: forall topic.
(PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
=> (topic -> ActorId) => (topic -> ResourceId)
-> (forall f. f topic -> ComponentBy f) -> (forall f. f topic -> ComponentBy f)
-> UTCTime -> UTCTime
-> Key topic -> Key topic
-> Verse -> Verse
-> AP.Grant URIMode -> AP.Grant URIMode
-> ActE (Text, Act (), Next) -> 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 -- Check grant
project <- checkDelegatorGrant grant project <- checkDelegatorGrant grant
@ -1740,10 +1708,9 @@ componentGrant grabActor topicComponent now recipKey (Verse authorIdMsig body) g
maybeNew <- withDBExcept $ do maybeNew <- withDBExcept $ do
-- Grab me from DB -- Grab me from DB
(recipActorID, recipActor) <- lift $ do resourceID <- lift $ grabResource <$> getJust recipKey
recip <- getJust recipKey Resource recipActorID <- lift $ getJust resourceID
let actorID = grabActor recip recipActor <- lift $ getJust recipActorID
(actorID,) <$> getJust actorID
-- Find the fulfilled activity in our DB -- Find the fulfilled activity in our DB
fulfillsDB <- do fulfillsDB <- do
@ -1798,8 +1765,7 @@ componentGrant grabActor topicComponent now recipKey (Verse authorIdMsig body) g
-- Prepare forwarding to my followers -- Prepare forwarding to my followers
sieve <- do sieve <- do
recipHash <- encodeKeyHashid recipKey recipHash <- encodeKeyHashid recipKey
let recipByHash = let recipByHash = resourceToActor $ topicResource recipHash
topicResource recipHash
return $ makeRecipientSet [] [localActorFollowers recipByHash] return $ makeRecipientSet [] [localActorFollowers recipByHash]
-- Update the Stem record in DB -- Update the Stem record in DB
@ -1814,7 +1780,7 @@ componentGrant grabActor topicComponent now recipKey (Verse authorIdMsig body) g
chain <- do chain <- do
Stem role <- getJust stemID Stem role <- getJust stemID
chain@(actionChain, _, _, _) <- prepareChain role chain@(actionChain, _, _, _) <- prepareChain role
let recipByKey = topicResource recipKey let recipByKey = resourceToActor $ topicResource recipKey
_luChain <- updateOutboxItem' recipByKey chainID actionChain _luChain <- updateOutboxItem' recipByKey chainID actionChain
return chain return chain
@ -1823,7 +1789,7 @@ componentGrant grabActor topicComponent now recipKey (Verse authorIdMsig body) g
case maybeNew of case maybeNew of
Nothing -> done "I already have this activity in my inbox" Nothing -> done "I already have this activity in my inbox"
Just (recipActorID, sieve, chainID, (actionChain, localRecipsChain, remoteRecipsChain, fwdHostsChain)) -> do Just (recipActorID, sieve, chainID, (actionChain, localRecipsChain, remoteRecipsChain, fwdHostsChain)) -> do
let recipByID = topicResource recipKey let recipByID = resourceToActor $ topicResource recipKey
forwardActivity authorIdMsig body recipByID recipActorID sieve forwardActivity authorIdMsig body recipByID recipActorID sieve
lift $ sendActivity lift $ sendActivity
recipByID recipActorID localRecipsChain remoteRecipsChain recipByID recipActorID localRecipsChain remoteRecipsChain
@ -1832,8 +1798,8 @@ componentGrant grabActor topicComponent now recipKey (Verse authorIdMsig body) g
where where
topicResource :: forall f. f topic -> LocalActorBy f topicResource :: forall f. f topic -> LocalResourceBy f
topicResource = componentActor . topicComponent topicResource = componentResource . topicComponent
checkDelegatorGrant g = do checkDelegatorGrant g = do
(role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <- (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 () (Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure ()
_ -> throwE "Author and resource aren't the same project actor" _ -> throwE "Author and resource aren't the same project actor"
case recipient of case recipient of
Left la | topicResource recipKey == la -> pure () Left la | resourceToActor (topicResource recipKey) == la -> pure ()
_ -> throwE "Grant recipient isn't me" _ -> throwE "Grant recipient isn't me"
for_ mstart $ \ start -> for_ mstart $ \ start ->
unless (start < now) $ throwE "Start time is in the future" 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 audProject <- makeAudSenderWithFollowers authorIdMsig
audMe <- audMe <-
AudLocal [] . pure . localActorFollowers . AudLocal [] . pure . localActorFollowers .
topicResource <$> resourceToActor . topicResource <$> encodeKeyHashid recipKey
encodeKeyHashid recipKey
uProject <- lift $ getActorURI authorIdMsig uProject <- lift $ getActorURI authorIdMsig
uGrant <- lift $ getActivityURI authorIdMsig uGrant <- lift $ getActivityURI authorIdMsig
recipHash <- encodeKeyHashid recipKey recipHash <- encodeKeyHashid recipKey
let topicByHash = topicResource recipHash let topicByHash = resourceToActor $ topicResource recipHash
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audProject, audMe] collectAudience [audProject, audMe]

34
src/Vervis/Actor/Deck.hs
View file

@ -195,7 +195,7 @@ deckAdd now deckID (Verse authorIdMsig body) add = do
-- Verify the specified capability gives relevant access -- Verify the specified capability gives relevant access
verifyCapability' verifyCapability'
capability authorIdMsig (LocalActorDeck deckID) AP.RoleAdmin capability authorIdMsig (LocalResourceDeck deckID) AP.RoleAdmin
-- Insert the Add to my inbox -- Insert the Add to my inbox
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actor) False mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actor) False
@ -294,9 +294,7 @@ deckCreateMe
-> DeckId -> DeckId
-> Verse -> Verse
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
deckCreateMe = deckCreateMe = topicCreateMe deckResource LocalResourceDeck
topicCreateMe
deckActor LocalActorDeck CollabTopicDeckDeck CollabTopicDeck
deckCreate deckCreate
:: UTCTime :: UTCTime
@ -395,7 +393,7 @@ deckOffer now deckID (Verse authorIdMsig body) (AP.Offer object uTarget) = do
verifyCapability' verifyCapability'
lcap lcap
authorIdMsig authorIdMsig
(LocalActorDeck deckID) (LocalResourceDeck deckID)
AP.RoleReport AP.RoleReport
-- Prepare forwarding the Offer to my followers -- Prepare forwarding the Offer to my followers
@ -532,7 +530,7 @@ deckResolve now deckID (Verse authorIdMsig body) (AP.Resolve uObject) = do
verifyCapability'' verifyCapability''
uCap uCap
authorIdMsig authorIdMsig
(LocalActorDeck deckID) (LocalResourceDeck deckID)
AP.RoleTriage AP.RoleTriage
{- {-
@ -748,7 +746,7 @@ deckAccept
-> Verse -> Verse
-> AP.Accept URIMode -> AP.Accept URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
deckAccept = topicAccept deckActor ComponentDeck deckAccept = topicAccept deckResource ComponentDeck
-- Meaning: An actor rejected something -- Meaning: An actor rejected something
-- Behavior: -- Behavior:
@ -773,7 +771,7 @@ deckReject
-> Verse -> Verse
-> AP.Reject URIMode -> AP.Reject URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
deckReject = topicReject deckActor LocalActorDeck deckReject = topicReject deckResource LocalResourceDeck
-- Meaning: An actor A invited actor B to a resource -- Meaning: An actor A invited actor B to a resource
-- Behavior: -- Behavior:
@ -802,11 +800,7 @@ deckInvite
-> Verse -> Verse
-> AP.Invite URIMode -> AP.Invite URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
deckInvite = deckInvite = topicInvite deckResource ComponentDeck StemIdentDeck
topicInvite
deckActor ComponentDeck
CollabTopicDeckDeck CollabTopicDeckCollab
CollabTopicDeck StemIdentDeck
-- Meaning: An actor A is removing actor B from a resource -- Meaning: An actor A is removing actor B from a resource
-- Behavior: -- Behavior:
@ -825,10 +819,7 @@ deckRemove
-> Verse -> Verse
-> AP.Remove URIMode -> AP.Remove URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
deckRemove = deckRemove = topicRemove deckResource LocalResourceDeck
topicRemove
deckActor LocalActorDeck
CollabTopicDeckDeck CollabTopicDeckCollab
-- Meaning: An actor A asked to join a resource -- Meaning: An actor A asked to join a resource
-- Behavior: -- Behavior:
@ -842,10 +833,7 @@ deckJoin
-> Verse -> Verse
-> AP.Join URIMode -> AP.Join URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
deckJoin = deckJoin = topicJoin deckResource LocalResourceDeck
topicJoin
deckActor LocalActorDeck
CollabTopicDeckDeck CollabTopicDeckCollab CollabTopicDeck
-- Meaning: An actor is granting access-to-some-resource to another actor -- Meaning: An actor is granting access-to-some-resource to another actor
-- Behavior: -- Behavior:
@ -877,7 +865,7 @@ deckGrant
-> Verse -> Verse
-> AP.Grant URIMode -> AP.Grant URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
deckGrant = componentGrant deckActor ComponentDeck deckGrant = componentGrant deckResource ComponentDeck
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
-- Ambiguous: Following/Resolving -- Ambiguous: Following/Resolving
@ -1018,7 +1006,7 @@ deckUndo now recipDeckID (Verse authorIdMsig body) (AP.Undo uObject) = do
verifyCapability' verifyCapability'
capability capability
authorIdMsig authorIdMsig
(LocalActorDeck recipDeckID) (LocalResourceDeck recipDeckID)
AP.RoleTriage AP.RoleTriage
lift $ lift deleteFromDB lift $ lift deleteFromDB

65
src/Vervis/Actor/Group.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- 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. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -180,7 +180,7 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
verifyCapability' verifyCapability'
capability capability
authorIdMsig authorIdMsig
(LocalActorGroup groupID) (LocalResourceGroup groupID)
AP.RoleAdmin AP.RoleAdmin
return fulfillsID return fulfillsID
) )
@ -229,7 +229,7 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
-- In collab mode, prepare a regular Grant -- In collab mode, prepare a regular Grant
let isInvite = isLeft collab let isInvite = isLeft collab
grant@(actionGrant, _, _, _) <- do grant@(actionGrant, _, _, _) <- do
Collab role <- getJust collabID Collab role _ <- getJust collabID
prepareCollabGrant isInvite inviterOrJoiner role prepareCollabGrant isInvite inviterOrJoiner role
let recipByKey = LocalActorGroup groupID let recipByKey = LocalActorGroup groupID
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant _luGrant <- updateOutboxItem' recipByKey grantID actionGrant
@ -252,7 +252,7 @@ groupAccept now groupID (Verse authorIdMsig body) accept = do
verifyCollabTopic collabID = do verifyCollabTopic collabID = do
topic <- lift $ getCollabTopic collabID topic <- lift $ getCollabTopic collabID
unless (LocalActorGroup groupID == topic) $ unless (LocalResourceGroup groupID == topic) $
throwE "Accept object is an Invite/Join for some other resource" throwE "Accept object is an Invite/Join for some other resource"
verifyInviteCollabTopic fulfillsID = do verifyInviteCollabTopic fulfillsID = do
@ -376,10 +376,7 @@ groupCreateMe
-> GroupId -> GroupId
-> Verse -> Verse
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
groupCreateMe = groupCreateMe = topicCreateMe groupResource LocalResourceGroup
topicCreateMe
groupActor LocalActorGroup
CollabTopicGroupGroup CollabTopicGroup
groupCreate groupCreate
:: UTCTime :: UTCTime
@ -526,9 +523,9 @@ groupGrant now groupID (Verse authorIdMsig body) grant = do
throwE "Capability isn't mine" throwE "Capability isn't mine"
m <- lift $ getBy $ UniqueCollabEnableGrant $ snd capability m <- lift $ getBy $ UniqueCollabEnableGrant $ snd capability
fromMaybeE m "I don't have a Collab with this 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 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" throwE "Found a Collab for this direct-Grant but it's not mine"
recip <- lift $ getCollabRecip collabID recip <- lift $ getCollabRecip collabID
recipForCheck <- recipForCheck <-
@ -628,7 +625,7 @@ groupInvite now groupID (Verse authorIdMsig body) invite = do
(role, resourceOrComps, recipientOrComp) <- parseInvite author invite (role, resourceOrComps, recipientOrComp) <- parseInvite author invite
mode <- mode <-
case resourceOrComps of case resourceOrComps of
Left (Left (LocalActorGroup j)) | j == groupID -> Left (Left (LocalResourceGroup j)) | j == groupID ->
bitraverse bitraverse
(\case (\case
Left r -> pure r Left r -> pure r
@ -657,17 +654,16 @@ groupInvite now groupID (Verse authorIdMsig body) invite = do
maybeNew <- withDBExcept $ do maybeNew <- withDBExcept $ do
-- Grab me from DB -- Grab me from DB
(topicActorID, topicActor) <- lift $ do resourceID <- lift $ groupResource <$> getJust groupID
recip <- getJust groupID Resource topicActorID <- lift $ getJust resourceID
let actorID = groupActor recip topicActor <- lift $ getJust topicActorID
(actorID,) <$> getJust actorID
-- Verify the specified capability gives relevant access -- Verify the specified capability gives relevant access
verifyCapability' verifyCapability'
capability authorIdMsig (LocalActorGroup groupID) AP.RoleAdmin capability authorIdMsig (LocalResourceGroup groupID) AP.RoleAdmin
-- Verify that target doesn't already have a Collab for me -- Verify that target doesn't already have a Collab for me
existingCollabIDs <- lift $ getExistingCollabs invitedDB existingCollabIDs <- lift $ getExistingCollabs resourceID invitedDB
case existingCollabIDs of case existingCollabIDs of
[] -> pure () [] -> pure ()
[_] -> throwE "I already have a Collab for the target" [_] -> 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 -- Insert Collab or Component record to DB
acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
insertCollab role invitedDB inviteDB acceptID insertCollab resourceID role invitedDB inviteDB acceptID
-- Prepare forwarding Invite to my followers -- Prepare forwarding Invite to my followers
sieve <- do sieve <- do
@ -715,29 +711,28 @@ groupInvite now groupID (Verse authorIdMsig body) invite = do
Right Nothing -> throwE "Target isn't an actor" Right Nothing -> throwE "Target isn't an actor"
Right (Just actor) -> return $ entityKey actor Right (Just actor) -> return $ entityKey actor
getExistingCollabs (Left (GrantRecipPerson (Entity personID _))) = getExistingCollabs resourceID (Left (GrantRecipPerson (Entity personID _))) =
E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do E.select $ E.from $ \ (collab `E.InnerJoin` recipl) -> do
E.on $ E.on $
topic E.^. CollabTopicGroupCollab E.==. collab E.^. CollabId E.==.
recipl E.^. CollabRecipLocalCollab recipl E.^. CollabRecipLocalCollab
E.where_ $ 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 recipl E.^. CollabRecipLocalPerson E.==. E.val personID
return $ recipl E.^. CollabRecipLocalCollab return $ recipl E.^. CollabRecipLocalCollab
getExistingCollabs (Right remoteActorID) = getExistingCollabs resourceID (Right remoteActorID) =
E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do E.select $ E.from $ \ (collab `E.InnerJoin` recipr) -> do
E.on $ E.on $
topic E.^. CollabTopicGroupCollab E.==. collab E.^. CollabId E.==.
recipr E.^. CollabRecipRemoteCollab recipr E.^. CollabRecipRemoteCollab
E.where_ $ 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 recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID
return $ recipr E.^. CollabRecipRemoteCollab return $ recipr E.^. CollabRecipRemoteCollab
insertCollab role recipient inviteDB acceptID = do insertCollab resourceID role recipient inviteDB acceptID = do
collabID <- insert $ Collab role collabID <- insert $ Collab role resourceID
fulfillsID <- insert $ CollabFulfillsInvite collabID acceptID fulfillsID <- insert $ CollabFulfillsInvite collabID acceptID
insert_ $ CollabTopicGroup collabID groupID
case inviteDB of case inviteDB of
Left (_, _, inviteID) -> Left (_, _, inviteID) ->
insert_ $ CollabInviterLocal fulfillsID inviteID insert_ $ CollabInviterLocal fulfillsID inviteID
@ -797,10 +792,7 @@ groupJoin
-> Verse -> Verse
-> AP.Join URIMode -> AP.Join URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
groupJoin = groupJoin = topicJoin groupResource LocalResourceGroup
topicJoin
groupActor LocalActorGroup
CollabTopicGroupGroup CollabTopicGroupCollab CollabTopicGroup
-- Meaning: An actor rejected something -- Meaning: An actor rejected something
-- Behavior: -- Behavior:
@ -825,7 +817,7 @@ groupReject
-> Verse -> Verse
-> AP.Reject URIMode -> AP.Reject URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
groupReject = topicReject groupActor LocalActorGroup groupReject = topicReject groupResource LocalResourceGroup
-- Meaning: An actor A is removing actor B from a resource -- Meaning: An actor A is removing actor B from a resource
-- Behavior: -- Behavior:
@ -844,10 +836,7 @@ groupRemove
-> Verse -> Verse
-> AP.Remove URIMode -> AP.Remove URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
groupRemove = groupRemove = topicRemove groupResource LocalResourceGroup
topicRemove
groupActor LocalActorGroup
CollabTopicGroupGroup CollabTopicGroupCollab
-- Meaning: An actor is undoing some previous action -- Meaning: An actor is undoing some previous action
-- Behavior: -- Behavior:

4
src/Vervis/Actor/Loom.hs
View file

@ -279,7 +279,7 @@ loomOffer now loomID (Verse authorIdMsig body) (AP.Offer object uTarget) = do
verifyCapability' verifyCapability'
lcap lcap
authorIdMsig authorIdMsig
(LocalActorLoom loomID) (LocalResourceLoom loomID)
AP.RoleReport AP.RoleReport
-- Prepare forwarding the Offer to my followers -- Prepare forwarding the Offer to my followers
@ -485,7 +485,7 @@ loomResolve now loomID (Verse authorIdMsig body) (AP.Resolve uObject) = do
verifyCapability' verifyCapability'
capability capability
authorIdMsig authorIdMsig
(LocalActorLoom loomID) (LocalResourceLoom loomID)
AP.RoleTriage AP.RoleTriage
-- Prepare forwarding the Resolve to my followers & ticket -- Prepare forwarding the Resolve to my followers & ticket

32
src/Vervis/Actor/Person.hs
View file

@ -413,7 +413,7 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do
-- Verify topic is the Accept sender -- Verify topic is the Accept sender
case (bimap snd snd topic, bimap (view _1) (view _1) acceptDB) of 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 () (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
_ -> throwE "Accept sender isn't the Invite topic" _ -> throwE "Accept sender isn't the Invite topic"
@ -641,7 +641,7 @@ personInvite now recipPersonID (Verse authorIdMsig body) invite = do
case resource of case resource of
Left r -> Left r ->
case r of 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 _j -> pure Nothing
Right u@(ObjURI h luColl) -> do Right u@(ObjURI h luColl) -> do
manager <- asksEnv envHttpManager manager <- asksEnv envHttpManager
@ -679,7 +679,7 @@ personInvite now recipPersonID (Verse authorIdMsig body) invite = do
-- mode -- mode
checkExistingPermits checkExistingPermits
recipPersonID recipPersonID
(bimap (bmap entityKey) (view _2) resourceDB) (bimap localResourceID (view _2) resourceDB)
-- Prepare forwarding Invite to my followers -- Prepare forwarding Invite to my followers
recipPersonHash <- encodeKeyHashid recipPersonID recipPersonHash <- encodeKeyHashid recipPersonID
@ -710,15 +710,7 @@ personInvite now recipPersonID (Verse authorIdMsig body) invite = do
insertPermit resourceDB inviteDB role = do insertPermit resourceDB inviteDB role = do
permitID <- lift $ insert $ Permit recipPersonID role permitID <- lift $ insert $ Permit recipPersonID role
case resourceDB of case resourceDB of
Left la -> do Left lr -> lift $ insert_ $ PermitTopicLocal permitID (localResourceID lr)
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
Right (_, actorID, _) -> lift $ insert_ $ PermitTopicRemote permitID actorID Right (_, actorID, _) -> lift $ insert_ $ PermitTopicRemote permitID actorID
lift $ do lift $ do
fulfillsID <- insert $ PermitFulfillsInvite permitID fulfillsID <- insert $ PermitFulfillsInvite permitID
@ -965,7 +957,7 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
-- Verify the Grant sender is the Permit topic -- Verify the Grant sender is the Permit topic
case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of 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 () (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
_ -> throwE "Grant sender isn't the Permit topic" _ -> 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 -- Verify the Grant sender is the Permit topic
topic <- lift $ getPermitTopic permitID topic <- lift $ getPermitTopic permitID
case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of 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 () (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
_ -> throwE "Grant sender isn't the Permit topic" _ -> throwE "Grant sender isn't the Permit topic"
@ -1198,7 +1190,7 @@ personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke lus) = do
lift $ do lift $ do
topic <- lift $ getPermitTopic permitID topic <- lift $ getPermitTopic permitID
case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of 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 () (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
_ -> throwE "Revoke sender isn't the Permit topic" _ -> throwE "Revoke sender isn't the Permit topic"
@ -1222,7 +1214,7 @@ personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke lus) = do
lift $ do lift $ do
topic <- lift $ getPermitTopic permitID topic <- lift $ getPermitTopic permitID
case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of 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 () (Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
_ -> throwE "Revoke sender isn't the Permit topic" _ -> 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 $ UniquePermitFulfillsInvite permitID
deleteBy $ UniquePermitFulfillsJoin permitID deleteBy $ UniquePermitFulfillsJoin permitID
case topicAndEnable of case topicAndEnable of
Left (topicID, _) -> do Left (topicID, _) -> delete topicID
deleteBy $ UniquePermitTopicRepo topicID
deleteBy $ UniquePermitTopicDeck topicID
deleteBy $ UniquePermitTopicLoom topicID
deleteBy $ UniquePermitTopicProject topicID
deleteBy $ UniquePermitTopicGroup topicID
delete topicID
Right (topicID, _) -> delete topicID Right (topicID, _) -> delete topicID
delete permitID delete permitID
) )

63
src/Vervis/Actor/Person/Client.hs
View file

@ -261,7 +261,7 @@ clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts a
-- our DB. -- our DB.
targetDB <- targetDB <-
bitraverse 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 (\ u@(ObjURI h luComps) -> do
manager <- asksEnv envHttpManager manager <- asksEnv envHttpManager
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luComps 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 -- Verify that target and object are addressed by the Add
bitraverse_ bitraverse_
(verifyActorAddressed localRecips . bmap entityKey) (verifyActorAddressed localRecips . bmap entityKey . resourceToActor)
(\ (_, _, u) -> verifyRemoteAddressed remoteRecips u) (\ (_, _, u) -> verifyRemoteAddressed remoteRecips u)
targetDB targetDB
bitraverse_ bitraverse_
@ -323,7 +323,7 @@ clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts a
-- Prepare local recipients for Add delivery -- Prepare local recipients for Add delivery
sieve <- lift $ do sieve <- lift $ do
targetHash <- bitraverse (hashLocalActor . addTargetActor) pure target targetHash <- bitraverse (hashLocalActor . resourceToActor . addTargetResource) pure target
objectHash <- bitraverse hashLocalActor pure object objectHash <- bitraverse hashLocalActor pure object
senderHash <- encodeKeyHashid personMeID senderHash <- encodeKeyHashid personMeID
let sieveActors = catMaybes let sieveActors = catMaybes
@ -385,14 +385,13 @@ clientCreateDeck now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd
-- Insert new deck to DB -- Insert new deck to DB
createID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now createID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
wid <- findWorkflow wid <- findWorkflow
(deckID, deckFollowerSetID) <- (deckID, resourceID, deckFollowerSetID) <-
lift $ insertDeck now name msummary createID wid actorMeID lift $ insertDeck now name msummary createID wid actorMeID
-- Insert a Permit record -- Insert a Permit record
lift $ do lift $ do
permitID <- insert $ Permit personMeID AP.RoleAdmin permitID <- insert $ Permit personMeID AP.RoleAdmin
topicID <- insert $ PermitTopicLocal permitID topicID <- insert $ PermitTopicLocal permitID resourceID
insert_ $ PermitTopicDeck topicID deckID
insert_ $ PermitFulfillsTopicCreation permitID insert_ $ PermitFulfillsTopicCreation permitID
insert_ $ PermitPersonGesture permitID createID insert_ $ PermitPersonGesture permitID createID
@ -482,7 +481,7 @@ clientCreateDeck now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd
, deckWiki = Nothing , deckWiki = Nothing
, deckCreate = obiidCreate , deckCreate = obiidCreate
} }
return (did, fsid) return (did, rid, fsid)
prepareCreate name msummary deckHash = do prepareCreate name msummary deckHash = do
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
@ -560,13 +559,12 @@ clientCreateProject now personMeID (ClientMsg maybeCap localRecips remoteRecips
-- Insert new project to DB -- Insert new project to DB
createID <- insertEmptyOutboxItem' (actorOutbox actorMe) now createID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
(projectID, projectFollowerSetID) <- (projectID, resourceID, projectFollowerSetID) <-
insertProject now name msummary createID actorMeID insertProject now name msummary createID actorMeID
-- Insert a Permit record -- Insert a Permit record
permitID <- insert $ Permit personMeID AP.RoleAdmin permitID <- insert $ Permit personMeID AP.RoleAdmin
topicID <- insert $ PermitTopicLocal permitID topicID <- insert $ PermitTopicLocal permitID resourceID
insert_ $ PermitTopicProject topicID projectID
insert_ $ PermitFulfillsTopicCreation permitID insert_ $ PermitFulfillsTopicCreation permitID
insert_ $ PermitPersonGesture permitID createID insert_ $ PermitPersonGesture permitID createID
@ -649,7 +647,7 @@ clientCreateProject now personMeID (ClientMsg maybeCap localRecips remoteRecips
, projectResource = rid , projectResource = rid
, projectCreate = obiidCreate , projectCreate = obiidCreate
} }
return (did, fsid) return (did, rid, fsid)
prepareCreate name msummary projectHash = do prepareCreate name msummary projectHash = do
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
@ -727,13 +725,12 @@ clientCreateTeam now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd
-- Insert new team to DB -- Insert new team to DB
createID <- insertEmptyOutboxItem' (actorOutbox actorMe) now createID <- insertEmptyOutboxItem' (actorOutbox actorMe) now
(groupID, projectFollowerSetID) <- (groupID, resourceID, projectFollowerSetID) <-
insertTeam now name msummary createID actorMeID insertTeam now name msummary createID actorMeID
-- Insert a Permit record -- Insert a Permit record
permitID <- insert $ Permit personMeID AP.RoleAdmin permitID <- insert $ Permit personMeID AP.RoleAdmin
topicID <- insert $ PermitTopicLocal permitID topicID <- insert $ PermitTopicLocal permitID resourceID
insert_ $ PermitTopicGroup topicID groupID
insert_ $ PermitFulfillsTopicCreation permitID insert_ $ PermitFulfillsTopicCreation permitID
insert_ $ PermitPersonGesture permitID createID insert_ $ PermitPersonGesture permitID createID
@ -816,7 +813,7 @@ clientCreateTeam now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd
, groupResource = rid , groupResource = rid
, groupCreate = obiidCreate , groupCreate = obiidCreate
} }
return (gid, fsid) return (gid, rid, fsid)
prepareCreate name msummary groupHash = do prepareCreate name msummary groupHash = do
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
@ -922,7 +919,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
resourceDB <- resourceDB <-
bitraverse bitraverse
(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") (withDBExcept . flip getEntityE "Grant context project not found in DB")
) )
(\ u@(ObjURI h luColl) -> do (\ 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 -- Verify that resource and recipient are addressed by the Invite
bitraverse_ bitraverse_
(bitraverse_ (bitraverse_
(verifyActorAddressed localRecips . bmap entityKey) (verifyActorAddressed localRecips . bmap entityKey . resourceToActor)
(verifyProjectAddressed localRecips . entityKey) (verifyProjectAddressed localRecips . entityKey)
) )
(\ (_, _, u) -> verifyRemoteAddressed remoteRecips u) (\ (_, _, u) -> verifyRemoteAddressed remoteRecips u)
@ -997,7 +994,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
-- Prepare local recipients for Invite delivery -- Prepare local recipients for Invite delivery
sieve <- lift $ do 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 recipientHash <- bitraverse (bitraverse hashGrantRecip hashComponent) pure recipient
senderHash <- encodeKeyHashid personMeID senderHash <- encodeKeyHashid personMeID
let sieveActors = catMaybes let sieveActors = catMaybes
@ -1007,7 +1004,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
Right _ -> Nothing Right _ -> Nothing
, case recipientHash of , case recipientHash of
Left (Left (GrantRecipPerson p)) -> Just $ LocalActorPerson p Left (Left (GrantRecipPerson p)) -> Just $ LocalActorPerson p
Left (Right c) -> Just $ componentActor c Left (Right c) -> Just $ resourceToActor $ componentResource c
Right _ -> Nothing Right _ -> Nothing
] ]
sieveStages = catMaybes sieveStages = catMaybes
@ -1018,7 +1015,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
Right _ -> Nothing Right _ -> Nothing
, case recipientHash of , case recipientHash of
Left (Left (GrantRecipPerson p)) -> Just $ LocalStagePersonFollowers p Left (Left (GrantRecipPerson p)) -> Just $ LocalStagePersonFollowers p
Left (Right c) -> Just $ localActorFollowers $ componentActor c Left (Right c) -> Just $ localActorFollowers $ resourceToActor $ componentResource c
Right _ -> Nothing Right _ -> Nothing
] ]
return $ makeRecipientSet sieveActors sieveStages return $ makeRecipientSet sieveActors sieveStages
@ -1073,7 +1070,7 @@ clientJoin now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts
-- our DB. -- our DB.
resourceDB <- resourceDB <-
bitraverse bitraverse
(withDBExcept . flip getLocalActorEntityE "Join resource not found in DB") (withDBExcept . flip getLocalResourceEntityE "Join resource not found in DB")
(\ u@(ObjURI h luColl) -> do (\ u@(ObjURI h luColl) -> do
manager <- asksEnv envHttpManager manager <- asksEnv envHttpManager
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl 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 -- Verify that resource is addressed by the Join
bitraverse_ bitraverse_
(verifyActorAddressed localRecips . bmap entityKey) (verifyActorAddressed localRecips . bmap entityKey . resourceToActor)
(\ (_, _, u, _) -> verifyRemoteAddressed remoteRecips u) (\ (_, _, u, _) -> verifyRemoteAddressed remoteRecips u)
resourceDB resourceDB
@ -1126,14 +1123,14 @@ clientJoin now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts
-- mode -- mode
checkExistingPermits checkExistingPermits
personMeID personMeID
(bimap (bmap entityKey) (view _2) topicDB) (bimap localResourceID (view _2) topicDB)
-- Insert Permit record to DB -- Insert Permit record to DB
insertPermit topicDB joinID role insertPermit topicDB joinID role
-- Prepare local recipients for Join delivery -- Prepare local recipients for Join delivery
sieve <- lift $ do sieve <- lift $ do
resourceHash <- bitraverse hashLocalActor pure resource resourceHash <- bitraverse (hashLocalActor . resourceToActor) pure resource
senderHash <- encodeKeyHashid personMeID senderHash <- encodeKeyHashid personMeID
let sieveActors = catMaybes let sieveActors = catMaybes
[ case resourceHash of [ case resourceHash of
@ -1163,15 +1160,7 @@ clientJoin now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts
insertPermit resourceDB joinID role = do insertPermit resourceDB joinID role = do
permitID <- lift $ insert $ Permit personMeID role permitID <- lift $ insert $ Permit personMeID role
case resourceDB of case resourceDB of
Left la -> do Left lr -> lift $ insert_ $ PermitTopicLocal permitID (localResourceID lr)
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
Right (_, actorID, _) -> lift $ insert_ $ PermitTopicRemote permitID actorID Right (_, actorID, _) -> lift $ insert_ $ PermitTopicRemote permitID actorID
lift $ do lift $ do
insert_ $ PermitFulfillsJoin permitID 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 -- If resource collabs is remote, HTTP GET it to determine resource
resource' <- resource' <-
bitraverse bitraverse
(pure . either id addTargetActor) (pure . either id addTargetResource)
(\ (ObjURI h luColl) -> do (\ (ObjURI h luColl) -> do
manager <- asksEnv envHttpManager manager <- asksEnv envHttpManager
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl 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 -- Verify that resource is addressed by the Remove
bitraverse_ bitraverse_
(verifyActorAddressed localRecips) (verifyActorAddressed localRecips . resourceToActor)
(verifyRemoteAddressed remoteRecips) (verifyRemoteAddressed remoteRecips)
resource' resource'
@ -1315,7 +1304,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
-- If resource is local, find it in our DB -- If resource is local, find it in our DB
_resourceDB <- _resourceDB <-
bitraverse bitraverse
(flip getLocalActorEntityE "Resource not found in DB") (flip getLocalResourceEntityE "Resource not found in DB")
pure pure
resource' resource'
@ -1337,7 +1326,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
-- Prepare local recipients for Remove delivery -- Prepare local recipients for Remove delivery
sieve <- lift $ do sieve <- lift $ do
resourceHash <- bitraverse hashLocalActor pure resource' resourceHash <- bitraverse (hashLocalActor . resourceToActor) pure resource'
recipientHash <- bitraverse hashLocalActor pure member recipientHash <- bitraverse hashLocalActor pure member
senderHash <- encodeKeyHashid personMeID senderHash <- encodeKeyHashid personMeID
let sieveActors = catMaybes let sieveActors = catMaybes

183
src/Vervis/Actor/Project.hs
View file

@ -262,7 +262,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
verifyCollabTopic collabID = do verifyCollabTopic collabID = do
topic <- lift $ getCollabTopic collabID topic <- lift $ getCollabTopic collabID
unless (LocalActorProject projectID == topic) $ unless (LocalResourceProject projectID == topic) $
throwE "Accept object is an Invite/Join for some other resource" throwE "Accept object is an Invite/Join for some other resource"
verifyInviteCollabTopic fulfillsID = do verifyInviteCollabTopic fulfillsID = do
@ -485,7 +485,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
componentIsAuthor ident = componentIsAuthor ident =
let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig 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 :: Either (a, ProjectId) (b, RemoteActorId) -> Bool
theyIsAuthor ident = theyIsAuthor ident =
@ -524,7 +524,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
verifyCapability'' verifyCapability''
uCap uCap
authorIdMsig authorIdMsig
(LocalActorProject projectID) (LocalResourceProject projectID)
AP.RoleAdmin AP.RoleAdmin
return fulfillsID return fulfillsID
) )
@ -578,7 +578,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
-- Prepare a regular Grant -- Prepare a regular Grant
let isInvite = isLeft collab let isInvite = isLeft collab
grant@(actionGrant, _, _, _) <- lift $ do grant@(actionGrant, _, _, _) <- lift $ do
Collab role <- getJust collabID Collab role _ <- getJust collabID
prepareCollabGrant isInvite inviterOrJoiner role prepareCollabGrant isInvite inviterOrJoiner role
let recipByKey = LocalActorProject projectID let recipByKey = LocalActorProject projectID
_luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant _luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant
@ -632,7 +632,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
verifyCapability'' verifyCapability''
uCap uCap
authorIdMsig authorIdMsig
(LocalActorProject projectID) (LocalResourceProject projectID)
AP.RoleAdmin AP.RoleAdmin
) )
@ -770,7 +770,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
verifyCapability'' verifyCapability''
uCap uCap
authorIdMsig authorIdMsig
(LocalActorProject projectID) (LocalResourceProject projectID)
AP.RoleAdmin AP.RoleAdmin
return $ Right () return $ Right ()
(True, True) -> throwE "Child already enabled, not needing any further Accept" (True, True) -> throwE "Child already enabled, not needing any further Accept"
@ -819,7 +819,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
verifyCapability'' verifyCapability''
uCap uCap
authorIdMsig authorIdMsig
(LocalActorProject projectID) (LocalResourceProject projectID)
AP.RoleAdmin AP.RoleAdmin
return $ Right () return $ Right ()
(True, True) -> throwE "Just waiting for Grant from parent, or already have it, anyway not needing any further Accept" (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) <- (uComponent, audComponent) <-
case ident of case ident of
Left c -> do Left c -> do
a <- componentActor <$> hashComponent c a <- resourceToActor . componentResource <$> hashComponent c
return return
( encodeRouteHome $ renderLocalActor a ( encodeRouteHome $ renderLocalActor a
, AudLocal [a] [localActorFollowers a] , AudLocal [a] [localActorFollowers a]
@ -1546,7 +1546,7 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
(Left (ATProjectComponents j), _)| j == projectID -> do (Left (ATProjectComponents j), _)| j == projectID -> do
comp <- comp <-
bitraverse bitraverse
(\ la -> fromMaybeE (actorToComponent la) "Not a component") (\ la -> fromMaybeE (resourceToComponent =<< actorToResource la) "Not a component")
pure pure
object object
addComponent comp addComponent comp
@ -1746,7 +1746,7 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
verifyCapability'' verifyCapability''
uCap uCap
authorIdMsig authorIdMsig
(LocalActorProject projectID) (LocalResourceProject projectID)
AP.RoleAdmin AP.RoleAdmin
maybeNew <- withDBExcept $ do maybeNew <- withDBExcept $ do
@ -1856,7 +1856,7 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
verifyCapability'' verifyCapability''
uCap uCap
authorIdMsig authorIdMsig
(LocalActorProject projectID) (LocalResourceProject projectID)
AP.RoleTriage AP.RoleTriage
maybeNew <- withDBExcept $ do maybeNew <- withDBExcept $ do
@ -2104,10 +2104,7 @@ projectCreateMe
-> ProjectId -> ProjectId
-> Verse -> Verse
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
projectCreateMe = projectCreateMe = topicCreateMe projectResource LocalResourceProject
topicCreateMe
projectActor LocalActorProject
CollabTopicProjectProject CollabTopicProject
projectCreate projectCreate
:: UTCTime :: UTCTime
@ -2339,7 +2336,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
(pure . snd) (pure . snd)
(\ (_, raID) -> getRemoteActorURI =<< getJust raID) (\ (_, raID) -> getRemoteActorURI =<< getJust raID)
ident 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" throwE "Capability's component and Grant author aren't the same actor"
return (role, enableID, ident, identForCheck) return (role, enableID, ident, identForCheck)
@ -2348,10 +2345,9 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
maybeNew <- withDBExcept $ do maybeNew <- withDBExcept $ do
-- Grab me from DB -- Grab me from DB
(recipActorID, recipActor) <- lift $ do resourceID <- lift $ projectResource <$> getJust projectID
recip <- getJust projectID Resource recipActorID <- lift $ getJust resourceID
let actorID = projectActor recip recipActor <- lift $ getJust recipActorID
(actorID,) <$> getJust actorID
-- Verify I don't yet have a delegation from the component -- Verify I don't yet have a delegation from the component
maybeDeleg <- maybeDeleg <-
@ -2376,12 +2372,11 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
-- For each Collab in me, prepare a delegation-extension Grant -- For each Collab in me, prepare a delegation-extension Grant
localCollabs <- localCollabs <-
lift $ 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.^. CollabEnableId E.==. deleg E.^. CollabDelegLocalEnable
E.on $ enable E.^. CollabEnableCollab E.==. recipL E.^. CollabRecipLocalCollab E.on $ enable E.^. CollabEnableCollab E.==. recipL E.^. CollabRecipLocalCollab
E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab
E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId E.where_ $ collab E.^. CollabTopic E.==. E.val resourceID
E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID
return return
( collab E.^. CollabRole ( collab E.^. CollabRole
, recipL E.^. CollabRecipLocalPerson , recipL E.^. CollabRecipLocalPerson
@ -2398,12 +2393,11 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
remoteCollabs <- remoteCollabs <-
lift $ 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.^. CollabEnableId E.==. deleg E.^. CollabDelegRemoteEnable
E.on $ enable E.^. CollabEnableCollab E.==. recipR E.^. CollabRecipRemoteCollab E.on $ enable E.^. CollabEnableCollab E.==. recipR E.^. CollabRecipRemoteCollab
E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab
E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId E.where_ $ collab E.^. CollabTopic E.==. E.val resourceID
E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID
return return
( collab E.^. CollabRole ( collab E.^. CollabRole
, recipR E.^. CollabRecipRemoteActor , recipR E.^. CollabRecipRemoteActor
@ -2519,7 +2513,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
uComponent <- uComponent <-
case component of case component of
Left c -> do Left c -> do
a <- componentActor <$> hashComponent c a <- resourceToActor . componentResource <$> hashComponent c
return $ encodeRouteHome $ renderLocalActor a return $ encodeRouteHome $ renderLocalActor a
Right u -> pure u Right u -> pure u
@ -2584,7 +2578,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
uComponent <- uComponent <-
case component of case component of
Left c -> do Left c -> do
a <- componentActor <$> hashComponent c a <- resourceToActor . componentResource <$> hashComponent c
return $ encodeRouteHome $ renderLocalActor a return $ encodeRouteHome $ renderLocalActor a
Right u -> pure u Right u -> pure u
@ -2628,10 +2622,10 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
guard $ fst capability == LocalActorProject projectID guard $ fst capability == LocalActorProject projectID
-- I don't have a Collab with this capability -- I don't have a Collab with this capability
MaybeT $ getBy $ UniqueCollabEnableGrant $ snd capability MaybeT $ getBy $ UniqueCollabEnableGrant $ snd capability
Collab role <- lift $ lift $ getJust collabID Collab role _ <- lift $ lift $ getJust collabID
topic <- lift $ lift $ getCollabTopic collabID topic <- lift $ lift $ getCollabTopic collabID
-- Found a Collab for this direct-Grant but it's not mine -- 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 recip <- lift $ lift $ getCollabRecip collabID
recipForCheck <- recipForCheck <-
lift $ lift $ lift $ lift $
@ -2746,7 +2740,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
Left ci -> hashComponent ci Left ci -> hashComponent ci
Right _ -> error "Delegation-start Grant URI is local, but component found to be remote, impossible" Right _ -> error "Delegation-start Grant URI is local, but component found to be remote, impossible"
s <- encodeKeyHashid startID s <- encodeKeyHashid startID
return $ encodeRouteHome $ activityRoute (componentActor c) s return $ encodeRouteHome $ activityRoute (resourceToActor $ componentResource c) s
Right (E.Value remoteActivityID) -> do Right (E.Value remoteActivityID) -> do
ra <- getJust remoteActivityID ra <- getJust remoteActivityID
getRemoteActivityURI ra getRemoteActivityURI ra
@ -2829,7 +2823,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
uComponent <- uComponent <-
case component of case component of
Left c -> do Left c -> do
a <- componentActor <$> hashComponent c a <- resourceToActor . componentResource <$> hashComponent c
return $ encodeRouteHome $ renderLocalActor a return $ encodeRouteHome $ renderLocalActor a
Right u -> pure u Right u -> pure u
@ -2950,10 +2944,9 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
maybeNew <- withDBExcept $ do maybeNew <- withDBExcept $ do
-- Grab me from DB -- Grab me from DB
(recipActorID, recipActor) <- lift $ do resourceID <- lift $ projectResource <$> getJust projectID
recip <- getJust projectID Resource recipActorID <- lift $ getJust resourceID
let actorID = projectActor recip recipActor <- lift $ getJust recipActorID
(actorID,) <$> getJust actorID
topicWithAccept <- topicWithAccept <-
lift $ lift $
@ -2984,12 +2977,11 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
-- For each Collab in me, prepare a delegation-extension Grant -- For each Collab in me, prepare a delegation-extension Grant
localCollabs <- localCollabs <-
lift $ 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.^. CollabEnableId E.==. deleg E.^. CollabDelegLocalEnable
E.on $ enable E.^. CollabEnableCollab E.==. recipL E.^. CollabRecipLocalCollab E.on $ enable E.^. CollabEnableCollab E.==. recipL E.^. CollabRecipLocalCollab
E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab
E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId E.where_ $ collab E.^. CollabTopic E.==. E.val resourceID
E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID
return return
( collab E.^. CollabRole ( collab E.^. CollabRole
, recipL E.^. CollabRecipLocalPerson , recipL E.^. CollabRecipLocalPerson
@ -3010,12 +3002,11 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
remoteCollabs <- remoteCollabs <-
lift $ 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.^. CollabEnableId E.==. deleg E.^. CollabDelegRemoteEnable
E.on $ enable E.^. CollabEnableCollab E.==. recipR E.^. CollabRecipRemoteCollab E.on $ enable E.^. CollabEnableCollab E.==. recipR E.^. CollabRecipRemoteCollab
E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab
E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId E.where_ $ collab E.^. CollabTopic E.==. E.val resourceID
E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID
return return
( collab E.^. CollabRole ( collab E.^. CollabRole
, recipR E.^. CollabRecipRemoteActor , recipR E.^. CollabRecipRemoteActor
@ -3359,7 +3350,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
Left ci -> hashComponent ci Left ci -> hashComponent ci
Right _ -> error "Delegation-start Grant URI is local, but component found to be remote, impossible" Right _ -> error "Delegation-start Grant URI is local, but component found to be remote, impossible"
s <- encodeKeyHashid startID s <- encodeKeyHashid startID
return $ encodeRouteHome $ activityRoute (componentActor c) s return $ encodeRouteHome $ activityRoute (resourceToActor $ componentResource c) s
ext@(actionExt, _, _, _) <- ext@(actionExt, _, _, _) <-
prepareExtensionGrant componentIdent uStart (min role (componentRole component)) enableID destStartID prepareExtensionGrant componentIdent uStart (min role (componentRole component)) enableID destStartID
let recipByKey = LocalActorProject projectID let recipByKey = LocalActorProject projectID
@ -3471,7 +3462,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
uComponent <- uComponent <-
case component of case component of
Left c -> do Left c -> do
a <- componentActor <$> hashComponent c a <- resourceToActor . componentResource <$> hashComponent c
return $ encodeRouteHome $ renderLocalActor a return $ encodeRouteHome $ renderLocalActor a
Right u -> pure u Right u -> pure u
@ -3655,7 +3646,7 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
(role, resourceOrComps, recipientOrComp) <- parseInvite author invite (role, resourceOrComps, recipientOrComp) <- parseInvite author invite
mode <- mode <-
case resourceOrComps of case resourceOrComps of
Left (Left (LocalActorProject j)) | j == projectID -> Left (Left (LocalResourceProject j)) | j == projectID ->
Left <$> Left <$>
bitraverse bitraverse
(\case (\case
@ -3700,20 +3691,19 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
maybeNew <- withDBExcept $ do maybeNew <- withDBExcept $ do
-- Grab me from DB -- Grab me from DB
(topicActorID, topicActor) <- lift $ do resourceID <- lift $ projectResource <$> getJust projectID
recip <- getJust projectID Resource topicActorID <- lift $ getJust resourceID
let actorID = projectActor recip topicActor <- lift $ getJust topicActorID
(actorID,) <$> getJust actorID
-- Verify the specified capability gives relevant access -- Verify the specified capability gives relevant access
verifyCapability' verifyCapability'
capability authorIdMsig (LocalActorProject projectID) AP.RoleAdmin capability authorIdMsig (LocalResourceProject projectID) AP.RoleAdmin
case invitedDB of case invitedDB of
-- Verify that target doesn't already have a Collab for me -- Verify that target doesn't already have a Collab for me
Left collab -> do Left collab -> do
existingCollabIDs <- lift $ getExistingCollabs collab existingCollabIDs <- lift $ getExistingCollabs resourceID collab
case existingCollabIDs of case existingCollabIDs of
[] -> pure () [] -> pure ()
[_] -> throwE "I already have a Collab for the target" [_] -> 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 -- Insert Collab or Component record to DB
acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
case invitedDB of case invitedDB of
Left collab -> insertCollab role collab inviteDB acceptID Left collab -> insertCollab resourceID role collab inviteDB acceptID
Right component -> insertComponent component inviteDB acceptID Right component -> insertComponent component inviteDB acceptID
-- Prepare forwarding Invite to my followers -- 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 Nothing -> throwE "Target isn't an actor"
Right (Just actor) -> return $ entityKey actor Right (Just actor) -> return $ entityKey actor
getExistingCollabs (Left (GrantRecipPerson (Entity personID _))) = getExistingCollabs resourceID (Left (GrantRecipPerson (Entity personID _))) =
E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do E.select $ E.from $ \ (collab `E.InnerJoin` recipl) -> do
E.on $ E.on $
topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId E.==.
recipl E.^. CollabRecipLocalCollab recipl E.^. CollabRecipLocalCollab
E.where_ $ 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 recipl E.^. CollabRecipLocalPerson E.==. E.val personID
return $ recipl E.^. CollabRecipLocalCollab return $ recipl E.^. CollabRecipLocalCollab
getExistingCollabs (Right remoteActorID) = getExistingCollabs resourceID (Right remoteActorID) =
E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do E.select $ E.from $ \ (collab `E.InnerJoin` recipr) -> do
E.on $ E.on $
topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId E.==.
recipr E.^. CollabRecipRemoteCollab recipr E.^. CollabRecipRemoteCollab
E.where_ $ 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 recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID
return $ recipr E.^. CollabRecipRemoteCollab return $ recipr E.^. CollabRecipRemoteCollab
insertCollab role recipient inviteDB acceptID = do insertCollab resourceID role recipient inviteDB acceptID = do
collabID <- insert $ Collab role collabID <- insert $ Collab role resourceID
fulfillsID <- insert $ CollabFulfillsInvite collabID acceptID fulfillsID <- insert $ CollabFulfillsInvite collabID acceptID
insert_ $ CollabTopicProject collabID projectID
case inviteDB of case inviteDB of
Left (_, _, inviteID) -> Left (_, _, inviteID) ->
insert_ $ CollabInviterLocal fulfillsID inviteID insert_ $ CollabInviterLocal fulfillsID inviteID
@ -3840,7 +3829,7 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do
return $ AudRemote h [lu] [] return $ AudRemote h [lu] []
Right (Left componentByEnt) -> do Right (Left componentByEnt) -> do
componentByHash <- hashComponent $ bmap entityKey componentByEnt componentByHash <- hashComponent $ bmap entityKey componentByEnt
let actor = componentActor componentByHash let actor = resourceToActor $ componentResource componentByHash
return $ AudLocal [actor] [localActorFollowers actor] return $ AudLocal [actor] [localActorFollowers actor]
Right (Right remoteActorID) -> do Right (Right remoteActorID) -> do
ra <- getJust remoteActorID ra <- getJust remoteActorID
@ -3880,10 +3869,7 @@ projectJoin
-> Verse -> Verse
-> AP.Join URIMode -> AP.Join URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
projectJoin = projectJoin = topicJoin projectResource LocalResourceProject
topicJoin
projectActor LocalActorProject
CollabTopicProjectProject CollabTopicProjectCollab CollabTopicProject
-- Meaning: An actor rejected something -- Meaning: An actor rejected something
-- Behavior: -- Behavior:
@ -3908,7 +3894,7 @@ projectReject
-> Verse -> Verse
-> AP.Reject URIMode -> AP.Reject URIMode
-> ActE (Text, Act (), Next) -> ActE (Text, Act (), Next)
projectReject = topicReject projectActor LocalActorProject projectReject = topicReject projectResource LocalResourceProject
-- Meaning: An actor A is removing actor B from collection C -- Meaning: An actor A is removing actor B from collection C
-- Behavior: -- Behavior:
@ -3960,7 +3946,7 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
(collection, item) <- parseRemove author remove (collection, item) <- parseRemove author remove
case (collection, item) of case (collection, item) of
(Left (Left (LocalActorProject j)), _) | j == projectID -> (Left (Left (LocalResourceProject j)), _) | j == projectID ->
removeCollab item removeCollab item
(Left (Right (ATProjectChildren j)), _) | j == projectID -> (Left (Right (ATProjectChildren j)), _) | j == projectID ->
removeChildActive item removeChildActive item
@ -4009,7 +3995,7 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
verifyCapability'' verifyCapability''
uCap uCap
authorIdMsig authorIdMsig
(LocalActorProject projectID) (LocalResourceProject projectID)
AP.RoleAdmin AP.RoleAdmin
maybeNew <- withDBExcept $ do maybeNew <- withDBExcept $ do
@ -4028,43 +4014,40 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
memberByKey memberByKey
-- Grab me from DB -- Grab me from DB
(topicActorID, topicActor) <- lift $ do resourceID <- lift $ projectResource <$> getJust projectID
recip <- getJust projectID Resource topicActorID <- lift $ getJust resourceID
let actorID = projectActor recip topicActor <- lift $ getJust topicActorID
(actorID,) <$> getJust actorID
-- Find the collab that the member already has for me -- Find the collab that the member already has for me
existingCollabIDs <- existingCollabIDs <-
lift $ case memberDB of lift $ case memberDB of
Left (Entity personID _) -> Left (Entity personID _) ->
fmap (map $ over _2 Left) $ fmap (map $ over _1 Left) $
E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do E.select $ E.from $ \ (collab `E.InnerJoin` recipl) -> do
E.on $ E.on $
topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId E.==.
recipl E.^. CollabRecipLocalCollab recipl E.^. CollabRecipLocalCollab
E.where_ $ 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 recipl E.^. CollabRecipLocalPerson E.==. E.val personID
return return
( topic E.^. persistIdField ( recipl E.^. persistIdField
, recipl E.^. persistIdField
, recipl E.^. CollabRecipLocalCollab , recipl E.^. CollabRecipLocalCollab
) )
Right (Entity remoteActorID _, _) -> Right (Entity remoteActorID _, _) ->
fmap (map $ over _2 Right) $ fmap (map $ over _1 Right) $
E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do E.select $ E.from $ \ (collab `E.InnerJoin` recipr) -> do
E.on $ E.on $
topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId E.==.
recipr E.^. CollabRecipRemoteCollab recipr E.^. CollabRecipRemoteCollab
E.where_ $ 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 recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID
return return
( topic E.^. persistIdField ( recipr E.^. persistIdField
, recipr E.^. persistIdField
, recipr E.^. CollabRecipRemoteCollab , recipr E.^. CollabRecipRemoteCollab
) )
(E.Value topicID, recipID, E.Value collabID) <- (recipID, E.Value collabID) <-
case existingCollabIDs of case existingCollabIDs of
[] -> throwE "Remove object isn't a member of me" [] -> throwE "Remove object isn't a member of me"
[collab] -> return collab [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 -- Verify that at least 1 more enabled Admin collab for me exists
otherCollabIDs <- otherCollabIDs <-
lift $ E.select $ E.from $ \ (topic `E.InnerJoin` enable) -> do lift $ E.select $ E.from $ \ (collab `E.InnerJoin` enable) -> do
E.on $ E.on $
topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId E.==.
enable E.^. CollabEnableCollab enable E.^. CollabEnableCollab
E.where_ $ E.where_ $
topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&. collab E.^. CollabTopic E.==. E.val resourceID E.&&.
topic E.^. CollabTopicProjectCollab E.!=. E.val collabID collab E.^. CollabId E.!=. E.val collabID E.&&.
return $ topic E.^. CollabTopicProjectCollab collab E.^. CollabRole E.==. E.val AP.RoleAdmin
return $ collab E.^. CollabId
when (null otherCollabIDs) $ when (null otherCollabIDs) $
throwE "No other admins exist, can't remove" throwE "No other admins exist, can't remove"
@ -4104,7 +4088,6 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
deleteBy $ UniqueCollabRecipRemoteJoinCollab r deleteBy $ UniqueCollabRecipRemoteJoinCollab r
deleteBy $ UniqueCollabRecipRemoteAcceptCollab r deleteBy $ UniqueCollabRecipRemoteAcceptCollab r
delete r delete r
delete topicID
fulfills <- do fulfills <- do
mf <- runMaybeT $ asum mf <- runMaybeT $ asum
[ Left <$> MaybeT (getKeyBy $ UniqueCollabFulfillsLocalTopicCreation collabID) [ Left <$> MaybeT (getKeyBy $ UniqueCollabFulfillsLocalTopicCreation collabID)
@ -4235,7 +4218,7 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
verifyCapability'' verifyCapability''
uCap uCap
authorIdMsig authorIdMsig
(LocalActorProject projectID) (LocalResourceProject projectID)
AP.RoleAdmin AP.RoleAdmin
maybeNew <- withDBExcept $ do maybeNew <- withDBExcept $ do
@ -4518,7 +4501,7 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do
verifyCapability'' verifyCapability''
uCap uCap
authorIdMsig authorIdMsig
(LocalActorProject projectID) (LocalResourceProject projectID)
AP.RoleAdmin AP.RoleAdmin
maybeNew <- withDBExcept $ do maybeNew <- withDBExcept $ do

25
src/Vervis/Client.hs
View file

@ -1124,7 +1124,7 @@ invite personID uRecipient uResourceCollabs role = do
resource resource
resourceDB <- resourceDB <-
bitraverse bitraverse
VR.hashLocalActor VR.hashLocalResource
(\ u@(ObjURI h lu) -> do (\ u@(ObjURI h lu) -> do
instanceID <- instanceID <-
lift $ runDB $ either entityKey id <$> insertBy' (Instance h) lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
@ -1162,7 +1162,9 @@ invite personID uRecipient uResourceCollabs role = do
let audResource = let audResource =
case resourceDB of 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) -> Right (remoteActor, ObjURI h lu) ->
AudRemote h AudRemote h
[lu] [lu]
@ -1200,7 +1202,7 @@ add personID uRecipient uCollection role = do
-- determine the resourc & its managing actor & followers collection -- determine the resourc & its managing actor & followers collection
target' <- target' <-
bitraverse bitraverse
(pure . addTargetActor) (pure . resourceToActor . addTargetResource)
(\ (ObjURI h luColl) -> do (\ (ObjURI h luColl) -> do
manager <- asksSite appHttpManager manager <- asksSite appHttpManager
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl 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 via collection 'context'
resource' <- resource' <-
bitraverse bitraverse
(pure . either id addTargetActor) (pure . either id addTargetResource)
(\ (ObjURI h luColl) -> do (\ (ObjURI h luColl) -> do
manager <- asksSite appHttpManager manager <- asksSite appHttpManager
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl 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 -- managing actor & followers collection
resourceDB <- resourceDB <-
bitraverse bitraverse
VR.hashLocalActor VR.hashLocalResource
(\ u@(ObjURI h lu) -> do (\ u@(ObjURI h lu) -> do
instanceID <- instanceID <-
lift $ runDB $ either entityKey id <$> insertBy' (Instance h) lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
@ -1338,7 +1340,9 @@ remove personID uRecipient uCollection = do
let audResource = let audResource =
case resourceDB of 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) -> Right (remoteActor, ObjURI h lu) ->
AudRemote h AudRemote h
[lu] [lu]
@ -1484,13 +1488,13 @@ acceptProjectInvite personID component project uInvite = do
acceptPersonalInvite acceptPersonalInvite
:: PersonId :: PersonId
-> Either (LocalActorBy Key) RemoteActorId -> Either (LocalResourceBy Key) RemoteActorId
-> FedURI -> FedURI
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Accept URIMode) -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Accept URIMode)
acceptPersonalInvite personID resource uInvite = do acceptPersonalInvite personID resource uInvite = do
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
resource' <- bitraverse VR.hashLocalActor pure resource resource' <- bitraverse VR.hashLocalResource pure resource
let activity = AP.Accept uInvite Nothing let activity = AP.Accept uInvite Nothing
@ -1510,8 +1514,9 @@ acceptPersonalInvite personID resource uInvite = do
let audResource = let audResource =
case resourceDB of case resourceDB of
Left la -> Left lr ->
AudLocal [la] [localActorFollowers la] let la = resourceToActor lr
in AudLocal [la] [localActorFollowers la]
Right (remoteActor, ObjURI h lu) -> Right (remoteActor, ObjURI h lu) ->
AudRemote h AudRemote h
[lu] [lu]

79
src/Vervis/Data/Collab.hs
View file

@ -30,17 +30,15 @@ module Vervis.Data.Collab
, parseReject , parseReject
, parseRemove , parseRemove
, AddTarget (..) , AddTarget (..)
, addTargetActor , addTargetResource
, parseAdd , parseAdd
, grantResourceActorID
, ComponentBy (..) , ComponentBy (..)
, parseComponent , parseComponent
, hashComponent , hashComponent
, unhashComponentE , unhashComponentE
, componentActor , componentResource
, actorToComponent , resourceToComponent
) )
where where
@ -81,11 +79,11 @@ import Vervis.FedURI
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
parseGrantResourceCollabs (RepoCollabsR r) = Just $ LocalActorRepo r parseGrantResourceCollabs (RepoCollabsR r) = Just $ LocalResourceRepo r
parseGrantResourceCollabs (DeckCollabsR d) = Just $ LocalActorDeck d parseGrantResourceCollabs (DeckCollabsR d) = Just $ LocalResourceDeck d
parseGrantResourceCollabs (LoomCollabsR l) = Just $ LocalActorLoom l parseGrantResourceCollabs (LoomCollabsR l) = Just $ LocalResourceLoom l
parseGrantResourceCollabs (ProjectCollabsR l) = Just $ LocalActorProject l parseGrantResourceCollabs (ProjectCollabsR l) = Just $ LocalResourceProject l
parseGrantResourceCollabs (GroupMembersR l) = Just $ LocalActorGroup l parseGrantResourceCollabs (GroupMembersR l) = Just $ LocalResourceGroup l
parseGrantResourceCollabs _ = Nothing parseGrantResourceCollabs _ = Nothing
data GrantRecipBy f = GrantRecipPerson (f Person) data GrantRecipBy f = GrantRecipPerson (f Person)
@ -122,7 +120,7 @@ verifyRole = pure
parseTopic parseTopic
:: StageRoute Env ~ Route App :: StageRoute Env ~ Route App
=> FedURI -> ActE (Either (LocalActorBy Key) FedURI) => FedURI -> ActE (Either (LocalResourceBy Key) FedURI)
parseTopic u = do parseTopic u = do
t <- parseTopic' u t <- parseTopic' u
bitraverse bitraverse
@ -136,7 +134,7 @@ parseTopic u = do
parseTopic' parseTopic'
:: StageRoute Env ~ Route App :: StageRoute Env ~ Route App
=> FedURI => FedURI
-> ActE (Either (Either (LocalActorBy Key) ProjectId) FedURI) -> ActE (Either (Either (LocalResourceBy Key) ProjectId) FedURI)
parseTopic' u = do parseTopic' u = do
routeOrRemote <- parseFedURI u routeOrRemote <- parseFedURI u
bitraverse bitraverse
@ -148,7 +146,7 @@ parseTopic' u = do
fromMaybeE fromMaybeE
(parseGrantResourceCollabs route) (parseGrantResourceCollabs route)
"Not a shared resource collabs route" "Not a shared resource collabs route"
unhashLocalActorE unhashLocalResourceE
resourceHash resourceHash
"Contains invalid hashid" "Contains invalid hashid"
) )
@ -220,7 +218,7 @@ parseInvite
-> AP.Invite URIMode -> AP.Invite URIMode
-> ActE -> ActE
( AP.Role ( AP.Role
, Either (Either (LocalActorBy Key) ProjectId) FedURI , Either (Either (LocalResourceBy Key) ProjectId) FedURI
, Either (Either (GrantRecipBy Key) (ComponentBy Key)) FedURI , Either (Either (GrantRecipBy Key) (ComponentBy Key)) FedURI
) )
parseInvite sender (AP.Invite instrument object target) = parseInvite sender (AP.Invite instrument object target) =
@ -232,7 +230,7 @@ parseInvite sender (AP.Invite instrument object target) =
parseJoin parseJoin
:: StageRoute Env ~ Route App :: StageRoute Env ~ Route App
=> AP.Join URIMode => AP.Join URIMode
-> ActE (AP.Role, Either (LocalActorBy Key) FedURI) -> ActE (AP.Role, Either (LocalResourceBy Key) FedURI)
parseJoin (AP.Join instrument object) = parseJoin (AP.Join instrument object) =
(,) <$> verifyRole instrument (,) <$> verifyRole instrument
<*> nameExceptT "Join object" (parseTopic object) <*> nameExceptT "Join object" (parseTopic object)
@ -242,7 +240,7 @@ parseGrant
-> AP.Grant URIMode -> AP.Grant URIMode
-> ActE -> ActE
( AP.RoleExt ( AP.RoleExt
, Either (LocalActorBy Key) LocalURI , Either (LocalResourceBy Key) LocalURI
, Either (GrantRecipBy Key) FedURI , Either (GrantRecipBy Key) FedURI
, Maybe (LocalURI, Maybe Int) , Maybe (LocalURI, Maybe Int)
, Maybe UTCTime , Maybe UTCTime
@ -276,7 +274,7 @@ parseGrant h (AP.Grant object context target mresult mstart mend allows deleg) =
fromMaybeE fromMaybeE
(decodeRouteLocal lu) (decodeRouteLocal lu)
"Grant context isn't a valid route" "Grant context isn't a valid route"
parseLocalActorE' route parseLocalResourceE' route
else pure $ Right lu else pure $ Right lu
parseTarget u@(ObjURI h lu) = do parseTarget u@(ObjURI h lu) = do
hl <- hostIsLocal h hl <- hostIsLocal h
@ -375,7 +373,7 @@ parseCollabs route = do
fromMaybeE fromMaybeE
(parseGrantResourceCollabs route) (parseGrantResourceCollabs route)
"Not a shared resource collabs route" "Not a shared resource collabs route"
unhashLocalActorE unhashLocalResourceE
resourceHash resourceHash
"Contains invalid hashid" "Contains invalid hashid"
@ -384,7 +382,7 @@ parseRemove
=> Either (LocalActorBy Key) FedURI => Either (LocalActorBy Key) FedURI
-> AP.Remove URIMode -> AP.Remove URIMode
-> ActE -> ActE
( Either (Either (LocalActorBy Key) AddTarget) FedURI ( Either (Either (LocalResourceBy Key) AddTarget) FedURI
, Either (LocalActorBy Key) FedURI , Either (LocalActorBy Key) FedURI
) )
parseRemove sender (AP.Remove object origin) = parseRemove sender (AP.Remove object origin) =
@ -424,13 +422,13 @@ data AddTarget
| ATGroupChildren GroupId | ATGroupChildren GroupId
deriving Eq deriving Eq
addTargetActor :: AddTarget -> LocalActorBy Key addTargetResource :: AddTarget -> LocalResourceBy Key
addTargetActor = \case addTargetResource = \case
ATProjectComponents j -> LocalActorProject j ATProjectComponents j -> LocalResourceProject j
ATProjectParents j -> LocalActorProject j ATProjectParents j -> LocalResourceProject j
ATProjectChildren j -> LocalActorProject j ATProjectChildren j -> LocalResourceProject j
ATGroupParents g -> LocalActorGroup g ATGroupParents g -> LocalResourceGroup g
ATGroupChildren g -> LocalActorGroup g ATGroupChildren g -> LocalResourceGroup g
parseAdd parseAdd
:: StageRoute Env ~ Route App :: StageRoute Env ~ Route App
@ -451,7 +449,7 @@ parseAdd sender (AP.Add object target role _context) = do
when (sender == component) $ when (sender == component) $
throwE "Sender and component are the same" throwE "Sender and component are the same"
case collection of 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" throwE "Sender and target collection actor are the same"
_ -> pure () _ -> pure ()
return (component, collection, role) return (component, collection, role)
@ -484,14 +482,6 @@ parseAdd sender (AP.Add object target role _context) = do
pure pure
routeOrRemote 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 data ComponentBy f
= ComponentRepo (f Repo) = ComponentRepo (f Repo)
| ComponentDeck (f Deck) | ComponentDeck (f Deck)
@ -524,14 +514,13 @@ unhashComponent c = do
unhashComponentE c e = ExceptT $ maybe (Left e) Right <$> unhashComponent c unhashComponentE c e = ExceptT $ maybe (Left e) Right <$> unhashComponent c
componentActor (ComponentRepo r) = LocalActorRepo r componentResource (ComponentRepo r) = LocalResourceRepo r
componentActor (ComponentDeck d) = LocalActorDeck d componentResource (ComponentDeck d) = LocalResourceDeck d
componentActor (ComponentLoom l) = LocalActorLoom l componentResource (ComponentLoom l) = LocalResourceLoom l
actorToComponent = \case resourceToComponent = \case
LocalActorPerson _ -> Nothing LocalResourceRepo k -> Just $ ComponentRepo k
LocalActorRepo k -> Just $ ComponentRepo k LocalResourceDeck k -> Just $ ComponentDeck k
LocalActorDeck k -> Just $ ComponentDeck k LocalResourceLoom k -> Just $ ComponentLoom k
LocalActorLoom k -> Just $ ComponentLoom k LocalResourceProject _ -> Nothing
LocalActorProject _ -> Nothing LocalResourceGroup _ -> Nothing
LocalActorGroup _ -> Nothing

30
src/Vervis/Form/Tracker.hs
View file

@ -1,6 +1,7 @@
{- This file is part of Vervis. {- 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. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -125,10 +126,11 @@ deckInviteForm deckID = renderDivs $ DeckInvite
<*> areq selectRole "Role*" Nothing <*> areq selectRole "Role*" Nothing
where where
selectPerson = selectField $ do selectPerson = selectField $ do
l <- runDB $ E.select $ l <- runDB $ do
E.from $ \ (person `E.InnerJoin` actor `E.LeftOuterJoin` (recip `E.InnerJoin` topic)) -> do resourceID <- deckResource <$> getJust deckID
E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicDeckCollab E.&&. E.select $ E.from $ \ (person `E.InnerJoin` actor `E.LeftOuterJoin` (recip `E.InnerJoin` collab)) -> do
topic E.^. CollabTopicDeckDeck E.==. E.val deckID 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.^. PersonId E.==. recip E.^. CollabRecipLocalPerson
E.on $ person E.^. PersonActor E.==. actor E.^. ActorId E.on $ person E.^. PersonActor E.==. actor E.^. ActorId
E.where_ $ E.isNothing $ E.just $ recip E.^. CollabRecipLocalId E.where_ $ E.isNothing $ E.just $ recip E.^. CollabRecipLocalId
@ -157,10 +159,11 @@ projectInviteForm projectID = renderDivs $ ProjectInvite
<*> areq selectRole "Role*" Nothing <*> areq selectRole "Role*" Nothing
where where
selectPerson = selectField $ do selectPerson = selectField $ do
l <- runDB $ E.select $ l <- runDB $ do
E.from $ \ (person `E.InnerJoin` actor `E.LeftOuterJoin` (recip `E.InnerJoin` topic)) -> do resourceID <- projectResource <$> getJust projectID
E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicProjectCollab E.&&. E.select $ E.from $ \ (person `E.InnerJoin` actor `E.LeftOuterJoin` (recip `E.InnerJoin` collab)) -> do
topic E.^. CollabTopicProjectProject E.==. E.val projectID 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.^. PersonId E.==. recip E.^. CollabRecipLocalPerson
E.on $ person E.^. PersonActor E.==. actor E.^. ActorId E.on $ person E.^. PersonActor E.==. actor E.^. ActorId
E.where_ $ E.isNothing $ E.just $ recip E.^. CollabRecipLocalId E.where_ $ E.isNothing $ E.just $ recip E.^. CollabRecipLocalId
@ -192,10 +195,11 @@ groupInviteForm groupID = renderDivs $ GroupInvite
<*> areq selectRole "Role*" Nothing <*> areq selectRole "Role*" Nothing
where where
selectPerson = selectField $ do selectPerson = selectField $ do
l <- runDB $ E.select $ l <- runDB $ do
E.from $ \ (person `E.InnerJoin` actor `E.LeftOuterJoin` (recip `E.InnerJoin` topic)) -> do resourceID <- groupResource <$> getJust groupID
E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicGroupCollab E.&&. E.select $ E.from $ \ (person `E.InnerJoin` actor `E.LeftOuterJoin` (recip `E.InnerJoin` collab)) -> do
topic E.^. CollabTopicGroupGroup E.==. E.val groupID 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.^. PersonId E.==. recip E.^. CollabRecipLocalPerson
E.on $ person E.^. PersonActor E.==. actor E.^. ActorId E.on $ person E.^. PersonActor E.==. actor E.^. ActorId
E.where_ $ E.isNothing $ E.just $ recip E.^. CollabRecipLocalId E.where_ $ E.isNothing $ E.just $ recip E.^. CollabRecipLocalId

18
src/Vervis/Handler/Client.hs
View file

@ -186,14 +186,11 @@ getHomeR = do
) )
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
for ls $ \ (E.Value gestureID, E.Value role, E.Value topicID) -> do for ls $ \ (E.Value gestureID, E.Value role, E.Value topicID) -> do
topic <- getPermitTopicLocal topicID PermitTopicLocal _ resourceID <- getJust topicID
actorID <- do Resource actorID <- getJust resourceID
ma <- getLocalActorEntity topic
case ma of
Nothing -> error "Impossible, we should have found the local actor in DB"
Just a -> pure $ localActorID a
actor <- getJust actorID actor <- getJust actorID
delegator <- getKeyBy $ UniquePermitPersonSendDelegator gestureID delegator <- getKeyBy $ UniquePermitPersonSendDelegator gestureID
topic <- resourceToActor <$> getLocalResource resourceID
exts <- exts <-
case delegator of case delegator of
Nothing -> pure [] Nothing -> pure []
@ -274,14 +271,11 @@ getHomeR = do
, topic E.^. PermitTopicLocalId , topic E.^. PermitTopicLocalId
) )
for ls $ \ (E.Value fulfillsID, E.Value role, E.Value valid, E.Value accept, E.Value topicID) -> do for ls $ \ (E.Value fulfillsID, E.Value role, E.Value valid, E.Value accept, E.Value topicID) -> do
topic <- getPermitTopicLocal topicID PermitTopicLocal _ resourceID <- getJust topicID
actorID <- do Resource actorID <- getJust resourceID
ma <- getLocalActorEntity topic
case ma of
Nothing -> error "Impossible, we should have found the local actor in DB"
Just a -> pure $ localActorID a
actor <- getJust actorID actor <- getJust actorID
fulfillsHash <- encodeKeyHashid fulfillsID fulfillsHash <- encodeKeyHashid fulfillsID
topic <- resourceToActor <$> getLocalResource resourceID
return return
( fulfillsID ( fulfillsID
, role , role

12
src/Vervis/Handler/Cloth.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- 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. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -708,14 +708,14 @@ postClothApplyR loomHash clothHash = do
ep@(Entity personID person) <- requireAuth ep@(Entity personID person) <- requireAuth
(grantIDs, proposal, actor, loomID) <- runDB $ do (grantIDs, proposal, actor, loomID) <- runDB $ do
(Entity loomID _, _, _, _, _, proposal) <- getCloth404 loomHash clothHash (Entity loomID loom, _, _, _, _, proposal) <- getCloth404 loomHash clothHash
grantIDs <- grantIDs <-
E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` enable) -> do E.select $ E.from $ \ (collab `E.InnerJoin` recip `E.InnerJoin` enable) -> do
E.on $ topic E.^. CollabTopicLoomCollab E.==. enable E.^. CollabEnableCollab E.on $ collab E.^. CollabId E.==. enable E.^. CollabEnableCollab
E.on $ topic E.^. CollabTopicLoomCollab E.==. recip E.^. CollabRecipLocalCollab E.on $ collab E.^. CollabId E.==. recip E.^. CollabRecipLocalCollab
E.where_ $ 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 recip E.^. CollabRecipLocalPerson E.==. E.val personID
return $ enable E.^. CollabEnableGrant return $ enable E.^. CollabEnableGrant

35
src/Vervis/Handler/Deck.hs
View file

@ -417,8 +417,8 @@ getDeckCollabsR :: KeyHashid Deck -> Handler TypedContent
getDeckCollabsR deckHash = do getDeckCollabsR deckHash = do
deckID <- decodeKeyHashid404 deckHash deckID <- decodeKeyHashid404 deckHash
collabs <- runDB $ do collabs <- runDB $ do
_deck <- get404 deckID deck <- get404 deckID
grants <- getTopicGrants CollabTopicDeckCollab CollabTopicDeckDeck deckID grants <- getTopicGrants $ deckResource deck
for grants $ \ (role, actor, _ct, time) -> for grants $ \ (role, actor, _ct, time) ->
(role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor (role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor
h <- asksSite siteInstanceHost h <- asksSite siteInstanceHost
@ -457,21 +457,18 @@ getDeckCollabsR deckHash = do
deck <- get404 deckID deck <- get404 deckID
actor <- getJust $ deckActor deck actor <- getJust $ deckActor deck
collabs <- do collabs <- do
grants <- grants <- getTopicGrants $ deckResource deck
getTopicGrants CollabTopicDeckCollab CollabTopicDeckDeck deckID
for grants $ \ (role, actor, ct, time) -> for grants $ \ (role, actor, ct, time) ->
(,role,ct,time) <$> getPersonWidgetInfo actor (,role,ct,time) <$> getPersonWidgetInfo actor
invites <- do invites <- do
invites' <- invites' <- getTopicInvites $ deckResource deck
getTopicInvites CollabTopicDeckCollab CollabTopicDeckDeck deckID
for invites' $ \ (inviter, recip, time, role) -> (,,,) for invites' $ \ (inviter, recip, time, role) -> (,,,)
<$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter) <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter)
<*> getPersonWidgetInfo recip <*> getPersonWidgetInfo recip
<*> pure time <*> pure time
<*> pure role <*> pure role
joins <- do joins <- do
joins' <- joins' <- getTopicJoins $ deckResource deck
getTopicJoins CollabTopicDeckCollab CollabTopicDeckDeck deckID
for joins' $ \ (recip, time, role) -> for joins' $ \ (recip, time, role) ->
(,time,role) <$> getPersonWidgetInfo recip (,time,role) <$> getPersonWidgetInfo recip
return (deck, actor, collabs, invites, joins) return (deck, actor, collabs, invites, joins)
@ -506,7 +503,9 @@ postDeckInviteR deckHash = do
uResourceCollabs = encodeRouteHome $ DeckCollabsR deckHash uResourceCollabs = encodeRouteHome $ DeckCollabsR deckHash
C.invite personID uRecipient uResourceCollabs role C.invite personID uRecipient uResourceCollabs role
grantID <- do 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" fromMaybeE maybeItem "You need to be a collaborator in the Deck to invite people"
grantHash <- encodeKeyHashid grantID grantHash <- encodeKeyHashid grantID
let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash
@ -525,8 +524,8 @@ postDeckInviteR deckHash = do
setMessage "Invite sent" setMessage "Invite sent"
redirect $ DeckCollabsR deckHash redirect $ DeckCollabsR deckHash
postDeckRemoveR :: KeyHashid Deck -> CollabTopicDeckId -> Handler Html postDeckRemoveR :: KeyHashid Deck -> CollabId -> Handler Html
postDeckRemoveR deckHash ctID = do postDeckRemoveR deckHash collabID = do
deckID <- decodeKeyHashid404 deckHash deckID <- decodeKeyHashid404 deckHash
personEntity@(Entity personID person) <- requireAuth personEntity@(Entity personID person) <- requireAuth
@ -535,18 +534,20 @@ postDeckRemoveR deckHash ctID = do
result <- runExceptT $ do result <- runExceptT $ do
mpidOrU <- lift $ runDB $ runMaybeT $ do mpidOrU <- lift $ runDB $ runMaybeT $ do
CollabTopicDeck collabID deckID' <- MaybeT $ get ctID Collab _ resourceID <- MaybeT $ get collabID
guard $ deckID' == deckID d <- MaybeT $ get deckID
guard $ resourceID == deckResource d
_ <- MaybeT $ getBy $ UniqueCollabEnable collabID _ <- MaybeT $ getBy $ UniqueCollabEnable collabID
member <- member <-
Left <$> MaybeT (getValBy $ UniqueCollabRecipLocal collabID) <|> Left <$> MaybeT (getValBy $ UniqueCollabRecipLocal collabID) <|>
Right <$> MaybeT (getValBy $ UniqueCollabRecipRemote collabID) Right <$> MaybeT (getValBy $ UniqueCollabRecipRemote collabID)
lift $ lift $
(resourceID,) <$>
bitraverse bitraverse
(pure . collabRecipLocalPerson) (pure . collabRecipLocalPerson)
(getRemoteActorURI <=< getJust . collabRecipRemoteActor) (getRemoteActorURI <=< getJust . collabRecipRemoteActor)
member member
pidOrU <- maybe notFound pure mpidOrU (resourceID, pidOrU) <- maybe notFound pure mpidOrU
(maybeSummary, audience, remove) <- do (maybeSummary, audience, remove) <- do
uRecipient <- uRecipient <-
case pidOrU of case pidOrU of
@ -555,7 +556,7 @@ postDeckRemoveR deckHash ctID = do
let uResourceCollabs = encodeRouteHome $ DeckCollabsR deckHash let uResourceCollabs = encodeRouteHome $ DeckCollabsR deckHash
C.remove personID uRecipient uResourceCollabs C.remove personID uRecipient uResourceCollabs
grantID <- do 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" fromMaybeE maybeItem "You need to be a collaborator in the Deck to remove people"
grantHash <- encodeKeyHashid grantID grantHash <- encodeKeyHashid grantID
let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash
@ -651,7 +652,9 @@ postDeckApproveCompR deckHash stemHash = do
(maybeSummary, audience, accept) <- (maybeSummary, audience, accept) <-
C.acceptProjectInvite personID (LocalActorDeck deckID) jidOrURI uInvite C.acceptProjectInvite personID (LocalActorDeck deckID) jidOrURI uInvite
grantID <- do 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" fromMaybeE maybeItem "You need to be a collaborator in the Deck to remove people"
grantHash <- encodeKeyHashid grantID grantHash <- encodeKeyHashid grantID
let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash

32
src/Vervis/Handler/Group.hs
View file

@ -237,9 +237,8 @@ getGroupMembersR :: KeyHashid Group -> Handler TypedContent
getGroupMembersR groupHash = do getGroupMembersR groupHash = do
groupID <- decodeKeyHashid404 groupHash groupID <- decodeKeyHashid404 groupHash
members <- runDB $ do members <- runDB $ do
_group <- get404 groupID group <- get404 groupID
grants <- grants <- getTopicGrants $ groupResource group
getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID
for grants $ \ (role, actor, _ct, time) -> for grants $ \ (role, actor, _ct, time) ->
(role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor (role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor
h <- asksSite siteInstanceHost h <- asksSite siteInstanceHost
@ -278,21 +277,18 @@ getGroupMembersR groupHash = do
group <- get404 groupID group <- get404 groupID
actor <- getJust $ groupActor group actor <- getJust $ groupActor group
members <- do members <- do
grants <- grants <- getTopicGrants $ groupResource group
getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID
for grants $ \ (role, actor, ct, time) -> for grants $ \ (role, actor, ct, time) ->
(,role,ct,time) <$> getPersonWidgetInfo actor (,role,ct,time) <$> getPersonWidgetInfo actor
invites <- do invites <- do
invites' <- invites' <- getTopicInvites $ groupResource group
getTopicInvites CollabTopicGroupCollab CollabTopicGroupGroup groupID
for invites' $ \ (inviter, recip, time, role) -> (,,,) for invites' $ \ (inviter, recip, time, role) -> (,,,)
<$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter) <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter)
<*> getPersonWidgetInfo recip <*> getPersonWidgetInfo recip
<*> pure time <*> pure time
<*> pure role <*> pure role
joins <- do joins <- do
joins' <- joins' <- getTopicJoins $ groupResource group
getTopicJoins CollabTopicGroupCollab CollabTopicGroupGroup groupID
for joins' $ \ (recip, time, role) -> for joins' $ \ (recip, time, role) ->
(,time,role) <$> getPersonWidgetInfo recip (,time,role) <$> getPersonWidgetInfo recip
return (group, actor, members, invites, joins) return (group, actor, members, invites, joins)
@ -327,7 +323,9 @@ postGroupInviteR groupHash = do
uResourceCollabs = encodeRouteHome $ GroupMembersR groupHash uResourceCollabs = encodeRouteHome $ GroupMembersR groupHash
C.invite personID uRecipient uResourceCollabs role C.invite personID uRecipient uResourceCollabs role
grantID <- do 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" fromMaybeE maybeItem "You need to be a collaborator in the Group to invite people"
grantHash <- encodeKeyHashid grantID grantHash <- encodeKeyHashid grantID
let uCap = encodeRouteHome $ GroupOutboxItemR groupHash grantHash let uCap = encodeRouteHome $ GroupOutboxItemR groupHash grantHash
@ -346,8 +344,8 @@ postGroupInviteR groupHash = do
setMessage "Invite sent" setMessage "Invite sent"
redirect $ GroupMembersR groupHash redirect $ GroupMembersR groupHash
postGroupRemoveR :: KeyHashid Group -> CollabTopicGroupId -> Handler Html postGroupRemoveR :: KeyHashid Group -> CollabId -> Handler Html
postGroupRemoveR groupHash ctID = do postGroupRemoveR groupHash collabID = do
groupID <- decodeKeyHashid404 groupHash groupID <- decodeKeyHashid404 groupHash
personEntity@(Entity personID person) <- requireAuth personEntity@(Entity personID person) <- requireAuth
@ -356,18 +354,20 @@ postGroupRemoveR groupHash ctID = do
result <- runExceptT $ do result <- runExceptT $ do
mpidOrU <- lift $ runDB $ runMaybeT $ do mpidOrU <- lift $ runDB $ runMaybeT $ do
CollabTopicGroup collabID groupID' <- MaybeT $ get ctID Collab _ resourceID <- MaybeT $ get collabID
guard $ groupID' == groupID g <- MaybeT $ get groupID
guard $ resourceID == groupResource g
_ <- MaybeT $ getBy $ UniqueCollabEnable collabID _ <- MaybeT $ getBy $ UniqueCollabEnable collabID
member <- member <-
Left <$> MaybeT (getValBy $ UniqueCollabRecipLocal collabID) <|> Left <$> MaybeT (getValBy $ UniqueCollabRecipLocal collabID) <|>
Right <$> MaybeT (getValBy $ UniqueCollabRecipRemote collabID) Right <$> MaybeT (getValBy $ UniqueCollabRecipRemote collabID)
lift $ lift $
(resourceID,) <$>
bitraverse bitraverse
(pure . collabRecipLocalPerson) (pure . collabRecipLocalPerson)
(getRemoteActorURI <=< getJust . collabRecipRemoteActor) (getRemoteActorURI <=< getJust . collabRecipRemoteActor)
member member
pidOrU <- maybe notFound pure mpidOrU (resourceID, pidOrU) <- maybe notFound pure mpidOrU
(maybeSummary, audience, remove) <- do (maybeSummary, audience, remove) <- do
uRecipient <- uRecipient <-
case pidOrU of case pidOrU of
@ -376,7 +376,7 @@ postGroupRemoveR groupHash ctID = do
let uResourceCollabs = encodeRouteHome $ GroupMembersR groupHash let uResourceCollabs = encodeRouteHome $ GroupMembersR groupHash
C.remove personID uRecipient uResourceCollabs C.remove personID uRecipient uResourceCollabs
grantID <- do 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" fromMaybeE maybeItem "You need to be a collaborator in the Group to remove people"
grantHash <- encodeKeyHashid grantID grantHash <- encodeKeyHashid grantID
let uCap = encodeRouteHome $ GroupOutboxItemR groupHash grantHash let uCap = encodeRouteHome $ GroupOutboxItemR groupHash grantHash

6
src/Vervis/Handler/Loom.hs
View file

@ -302,15 +302,15 @@ postLoomNewR = do
actor <- runDB $ do actor <- runDB $ do
-- Find the specified repo in DB -- Find the specified repo in DB
_ <- getJust repoID repo <- getJust repoID
-- Make sure the repo has a single, full-access collab, granted to the -- Make sure the repo has a single, full-access collab, granted to the
-- creator of the loom -- creator of the loom
maybeApproved <- runMaybeT $ do maybeApproved <- runMaybeT $ do
collabs <- lift $ selectList [CollabTopicRepoRepo ==. repoID] [] collabs <- lift $ selectKeysList [CollabTopic ==. repoResource repo] []
collabID <- collabID <-
case collabs of case collabs of
[Entity _ c] -> return $ collabTopicRepoCollab c [c] -> return c
_ -> mzero _ -> mzero
CollabRecipLocal _ recipID <- CollabRecipLocal _ recipID <-
MaybeT $ getValBy $ UniqueCollabRecipLocal collabID MaybeT $ getValBy $ UniqueCollabRecipLocal collabID

45
src/Vervis/Handler/Project.hs
View file

@ -95,6 +95,7 @@ import Yesod.Form.Local
import Yesod.Persist.Local import Yesod.Persist.Local
import Vervis.Access import Vervis.Access
import Vervis.Actor (resourceToActor)
import Vervis.API import Vervis.API
import Vervis.Data.Collab import Vervis.Data.Collab
import Vervis.Federation.Auth import Vervis.Federation.Auth
@ -235,8 +236,8 @@ getProjectCollabsR :: KeyHashid Project -> Handler TypedContent
getProjectCollabsR projectHash = do getProjectCollabsR projectHash = do
projectID <- decodeKeyHashid404 projectHash projectID <- decodeKeyHashid404 projectHash
collabs <- runDB $ do collabs <- runDB $ do
_project <- get404 projectID project <- get404 projectID
grants <- getTopicGrants CollabTopicProjectCollab CollabTopicProjectProject projectID grants <- getTopicGrants $ projectResource project
for grants $ \ (role, actor, _ct, time) -> for grants $ \ (role, actor, _ct, time) ->
(role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor (role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor
h <- asksSite siteInstanceHost h <- asksSite siteInstanceHost
@ -275,21 +276,18 @@ getProjectCollabsR projectHash = do
project <- get404 projectID project <- get404 projectID
actor <- getJust $ projectActor project actor <- getJust $ projectActor project
collabs <- do collabs <- do
grants <- grants <- getTopicGrants $ projectResource project
getTopicGrants CollabTopicProjectCollab CollabTopicProjectProject projectID
for grants $ \ (role, actor, ct, time) -> for grants $ \ (role, actor, ct, time) ->
(,role,ct,time) <$> getPersonWidgetInfo actor (,role,ct,time) <$> getPersonWidgetInfo actor
invites <- do invites <- do
invites' <- invites' <- getTopicInvites $ projectResource project
getTopicInvites CollabTopicProjectCollab CollabTopicProjectProject projectID
for invites' $ \ (inviter, recip, time, role) -> (,,,) for invites' $ \ (inviter, recip, time, role) -> (,,,)
<$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter) <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter)
<*> getPersonWidgetInfo recip <*> getPersonWidgetInfo recip
<*> pure time <*> pure time
<*> pure role <*> pure role
joins <- do joins <- do
joins' <- joins' <- getTopicJoins $ projectResource project
getTopicJoins CollabTopicProjectCollab CollabTopicProjectProject projectID
for joins' $ \ (recip, time, role) -> for joins' $ \ (recip, time, role) ->
(,time,role) <$> getPersonWidgetInfo recip (,time,role) <$> getPersonWidgetInfo recip
return (project, actor, collabs, invites, joins) return (project, actor, collabs, invites, joins)
@ -324,7 +322,9 @@ postProjectInviteR projectHash = do
uResourceCollabs = encodeRouteHome $ ProjectCollabsR projectHash uResourceCollabs = encodeRouteHome $ ProjectCollabsR projectHash
C.invite personID uRecipient uResourceCollabs role C.invite personID uRecipient uResourceCollabs role
grantID <- do 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" fromMaybeE maybeItem "You need to be a collaborator in the Project to invite people"
grantHash <- encodeKeyHashid grantID grantHash <- encodeKeyHashid grantID
let uCap = encodeRouteHome $ ProjectOutboxItemR projectHash grantHash let uCap = encodeRouteHome $ ProjectOutboxItemR projectHash grantHash
@ -343,8 +343,8 @@ postProjectInviteR projectHash = do
setMessage "Invite sent" setMessage "Invite sent"
redirect $ ProjectCollabsR projectHash redirect $ ProjectCollabsR projectHash
postProjectRemoveR :: KeyHashid Project -> CollabTopicProjectId -> Handler Html postProjectRemoveR :: KeyHashid Project -> CollabId -> Handler Html
postProjectRemoveR projectHash ctID = do postProjectRemoveR projectHash collabID = do
projectID <- decodeKeyHashid404 projectHash projectID <- decodeKeyHashid404 projectHash
personEntity@(Entity personID person) <- requireAuth personEntity@(Entity personID person) <- requireAuth
@ -353,18 +353,20 @@ postProjectRemoveR projectHash ctID = do
result <- runExceptT $ do result <- runExceptT $ do
mpidOrU <- lift $ runDB $ runMaybeT $ do mpidOrU <- lift $ runDB $ runMaybeT $ do
CollabTopicProject collabID projectID' <- MaybeT $ get ctID Collab _ resourceID <- MaybeT $ get collabID
guard $ projectID' == projectID j <- MaybeT $ get projectID
guard $ resourceID == projectResource j
_ <- MaybeT $ getBy $ UniqueCollabEnable collabID _ <- MaybeT $ getBy $ UniqueCollabEnable collabID
member <- member <-
Left <$> MaybeT (getValBy $ UniqueCollabRecipLocal collabID) <|> Left <$> MaybeT (getValBy $ UniqueCollabRecipLocal collabID) <|>
Right <$> MaybeT (getValBy $ UniqueCollabRecipRemote collabID) Right <$> MaybeT (getValBy $ UniqueCollabRecipRemote collabID)
lift $ lift $
(resourceID,) <$>
bitraverse bitraverse
(pure . collabRecipLocalPerson) (pure . collabRecipLocalPerson)
(getRemoteActorURI <=< getJust . collabRecipRemoteActor) (getRemoteActorURI <=< getJust . collabRecipRemoteActor)
member member
pidOrU <- maybe notFound pure mpidOrU (resourceID, pidOrU) <- maybe notFound pure mpidOrU
(maybeSummary, audience, remove) <- do (maybeSummary, audience, remove) <- do
uRecipient <- uRecipient <-
case pidOrU of case pidOrU of
@ -373,7 +375,7 @@ postProjectRemoveR projectHash ctID = do
let uResourceCollabs = encodeRouteHome $ ProjectCollabsR projectHash let uResourceCollabs = encodeRouteHome $ ProjectCollabsR projectHash
C.remove personID uRecipient uResourceCollabs C.remove personID uRecipient uResourceCollabs
grantID <- do 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" fromMaybeE maybeItem "You need to be a collaborator in the Project to remove people"
grantHash <- encodeKeyHashid grantID grantHash <- encodeKeyHashid grantID
let uCap = encodeRouteHome $ ProjectOutboxItemR projectHash grantHash let uCap = encodeRouteHome $ ProjectOutboxItemR projectHash grantHash
@ -415,7 +417,8 @@ getProjectComponentsR projectHash = do
( encodeRouteHome ( encodeRouteHome
. renderLocalActor . renderLocalActor
. hashActor . hashActor
. componentActor . resourceToActor
. componentResource
) )
id id
) )
@ -533,10 +536,10 @@ getProjectCollabLiveR projectHash enableHash = do
projectID <- decodeKeyHashid404 projectHash projectID <- decodeKeyHashid404 projectHash
enableID <- decodeKeyHashid404 enableHash enableID <- decodeKeyHashid404 enableHash
runDB $ do runDB $ do
resourceID <- projectResource <$> get404 projectID
CollabEnable collabID _ <- get404 enableID CollabEnable collabID _ <- get404 enableID
CollabTopicProject _ j <- Collab _ resourceID' <- getJust collabID
getValBy404 $ UniqueCollabTopicProject collabID unless (resourceID == resourceID') notFound
unless (j == projectID) notFound
getProjectInviteCompR :: KeyHashid Project -> Handler Html getProjectInviteCompR :: KeyHashid Project -> Handler Html
getProjectInviteCompR projectHash = do getProjectInviteCompR projectHash = do
@ -558,7 +561,9 @@ postProjectInviteCompR projectHash = do
(maybeSummary, audience, invite) <- (maybeSummary, audience, invite) <-
C.inviteComponent personID projectID uComp C.inviteComponent personID projectID uComp
grantID <- do 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" fromMaybeE maybeItem "You need to be a collaborator in the Project to invite people"
grantHash <- encodeKeyHashid grantID grantHash <- encodeKeyHashid grantID
let uCap = encodeRouteHome $ ProjectOutboxItemR projectHash grantHash let uCap = encodeRouteHome $ ProjectOutboxItemR projectHash grantHash

8
src/Vervis/Handler/Repo.hs
View file

@ -730,10 +730,10 @@ postRepoLinkR repoHash loomHash = do
-- Make sure both repo and loom have a single, full-access collab, -- Make sure both repo and loom have a single, full-access collab,
-- granted to the logged-in person -- granted to the logged-in person
maybeApproved <- lift $ runMaybeT $ do maybeApproved <- lift $ runMaybeT $ do
collabs <- lift $ selectList [CollabTopicRepoRepo ==. repoID] [] collabs <- lift $ selectKeysList [CollabTopic ==. repoResource repo] []
collabID <- collabID <-
case collabs of case collabs of
[Entity _ c] -> return $ collabTopicRepoCollab c [c] -> return c
_ -> mzero _ -> mzero
CollabRecipLocal _ recipID <- CollabRecipLocal _ recipID <-
MaybeT $ getValBy $ UniqueCollabRecipLocal collabID MaybeT $ getValBy $ UniqueCollabRecipLocal collabID
@ -741,10 +741,10 @@ postRepoLinkR repoHash loomHash = do
_ <- MaybeT $ getBy $ UniqueCollabFulfillsLocalTopicCreation collabID _ <- MaybeT $ getBy $ UniqueCollabFulfillsLocalTopicCreation collabID
guard $ recipID == personID guard $ recipID == personID
collabs' <- lift $ selectList [CollabTopicLoomLoom ==. loomID] [] collabs' <- lift $ selectKeysList [CollabTopic ==. loomResource loom] []
collabID' <- collabID' <-
case collabs' of case collabs' of
[Entity _ c] -> return $ collabTopicLoomCollab c [c] -> return c
_ -> mzero _ -> mzero
CollabRecipLocal _ recipID' <- CollabRecipLocal _ recipID' <-
MaybeT $ getValBy $ UniqueCollabRecipLocal collabID' MaybeT $ getValBy $ UniqueCollabRecipLocal collabID'

8
src/Vervis/Handler/Ticket.hs
View file

@ -502,7 +502,9 @@ postTicketCloseR deckHash taskHash = do
result <- runExceptT $ do result <- runExceptT $ do
(maybeSummary, audience, detail) <- C.resolve personID uTicket (maybeSummary, audience, detail) <- C.resolve personID uTicket
grantID <- do 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" fromMaybeE maybeItem "You need to be a collaborator in the Deck to close tickets"
grantHash <- encodeKeyHashid grantID grantHash <- encodeKeyHashid grantID
let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash
@ -532,7 +534,9 @@ postTicketOpenR deckHash taskHash = do
result <- runExceptT $ do result <- runExceptT $ do
(maybeSummary, audience, undo) <- C.unresolve personHash uTicket (maybeSummary, audience, undo) <- C.unresolve personHash uTicket
grantID <- do 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" fromMaybeE maybeItem "You need to be a collaborator in the Deck to reopen tickets"
grantHash <- encodeKeyHashid grantID grantHash <- encodeKeyHashid grantID
let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash let uCap = encodeRouteHome $ DeckOutboxItemR deckHash grantHash

113
src/Vervis/Migration.hs
View file

@ -82,6 +82,7 @@ import Yesod.MonadSite
import Yesod.RenderSource import Yesod.RenderSource
import Data.Either.Local import Data.Either.Local
import Data.Maybe.Local
import Database.Persist.Local import Database.Persist.Local
import Vervis.FedURI import Vervis.FedURI
@ -3489,6 +3490,118 @@ changes hLocal ctx =
"Resource" "Resource"
-- 610 -- 610
, removeField "PermitTopicExtendResourceLocal" "actor" , 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 migrateDB

3
src/Vervis/Migration/Model2024.hs
View file

@ -63,3 +63,6 @@ makeEntitiesMigration "593"
makeEntitiesMigration "604" makeEntitiesMigration "604"
$(modelFile "migrations/604_2024-04-20_resource.model") $(modelFile "migrations/604_2024-04-20_resource.model")
makeEntitiesMigration "611"
$(modelFile "migrations/611_2024-04-20_permit_resource.model")

209
src/Vervis/Persist/Collab.hs
View file

@ -15,7 +15,6 @@
module Vervis.Persist.Collab module Vervis.Persist.Collab
( getCollabTopic ( getCollabTopic
, getCollabTopic'
, getCollabRecip , getCollabRecip
, getPermitTopicLocal , getPermitTopicLocal
, getPermitTopic , getPermitTopic
@ -94,31 +93,10 @@ import Vervis.Model
import Vervis.Persist.Actor import Vervis.Persist.Actor
getCollabTopic getCollabTopic
:: MonadIO m => CollabId -> ReaderT SqlBackend m (LocalActorBy Key) :: MonadIO m => CollabId -> ReaderT SqlBackend m (LocalResourceBy Key)
getCollabTopic = fmap snd . getCollabTopic' getCollabTopic collabID = do
Collab _ resourceID <- getJust collabID
getCollabTopic' getLocalResource resourceID
:: 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"
getCollabRecip getCollabRecip
:: MonadIO m :: MonadIO m
@ -135,32 +113,17 @@ getCollabRecip collabID =
getPermitTopicLocal getPermitTopicLocal
:: MonadIO m :: MonadIO m
=> PermitTopicLocalId => PermitTopicLocalId
-> ReaderT SqlBackend m (LocalActorBy Key) -> ReaderT SqlBackend m (LocalResourceBy Key)
getPermitTopicLocal localID = do getPermitTopicLocal localID = do
options <- PermitTopicLocal _ resourceID <- getJust localID
sequence getLocalResource resourceID
[ 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"
getPermitTopic getPermitTopic
:: MonadIO m :: MonadIO m
=> PermitId => PermitId
-> ReaderT SqlBackend m -> ReaderT SqlBackend m
(Either (Either
(PermitTopicLocalId, LocalActorBy Key) (PermitTopicLocalId, LocalResourceBy Key)
(PermitTopicRemoteId, RemoteActorId) (PermitTopicRemoteId, RemoteActorId)
) )
getPermitTopic permitID = do getPermitTopic permitID = do
@ -208,29 +171,23 @@ getComponentE (ComponentDeck k) e = ComponentDeck <$> getEntityE k e
getComponentE (ComponentLoom k) e = ComponentLoom <$> getEntityE k e getComponentE (ComponentLoom k) e = ComponentLoom <$> getEntityE k e
getTopicGrants getTopicGrants
:: ( MonadIO m :: MonadIO m
, PersistRecordBackend topic SqlBackend => ResourceId
, PersistRecordBackend resource SqlBackend -> ReaderT SqlBackend m [(AP.Role, Either PersonId RemoteActorId, CollabId, UTCTime)]
) getTopicGrants resourceID =
=> EntityField topic CollabId
-> EntityField topic (Key resource)
-> Key resource
-> ReaderT SqlBackend m [(AP.Role, Either PersonId RemoteActorId, Key topic, UTCTime)]
getTopicGrants topicCollabField topicActorField resourceID =
fmap (reverse . sortOn (view _1) . map adapt) $ 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.==. recipR E.?. CollabRecipRemoteCollab
E.on $ E.just (enable E.^. CollabEnableCollab) E.==. recipL E.?. CollabRecipLocalCollab E.on $ E.just (enable E.^. CollabEnableCollab) E.==. recipL E.?. CollabRecipLocalCollab
E.on $ enable E.^. CollabEnableGrant E.==. grant E.^. OutboxItemId 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.on $ topic E.^. topicCollabField E.==. collab E.^. CollabId E.where_ $ collab E.^. CollabTopic E.==. E.val resourceID
E.where_ $ topic E.^. topicActorField E.==. E.val resourceID
E.orderBy [E.desc $ enable E.^. CollabEnableId] E.orderBy [E.desc $ enable E.^. CollabEnableId]
return return
( collab E.^. CollabRole ( collab E.^. CollabRole
, recipL E.?. CollabRecipLocalPerson , recipL E.?. CollabRecipLocalPerson
, recipR E.?. CollabRecipRemoteActor , recipR E.?. CollabRecipRemoteActor
, topic E.^. persistIdField , collab E.^. CollabId
, grant E.^. OutboxItemPublished , grant E.^. OutboxItemPublished
) )
where where
@ -246,18 +203,13 @@ getTopicGrants topicCollabField topicActorField resourceID =
) )
getTopicInvites getTopicInvites
:: ( MonadIO m :: MonadIO m
, PersistRecordBackend topic SqlBackend => ResourceId
, PersistRecordBackend resource SqlBackend
)
=> EntityField topic CollabId
-> EntityField topic (Key resource)
-> Key resource
-> ReaderT SqlBackend m [(Either ActorId RemoteActorId, Either PersonId RemoteActorId, UTCTime, AP.Role)] -> ReaderT SqlBackend m [(Either ActorId RemoteActorId, Either PersonId RemoteActorId, UTCTime, AP.Role)]
getTopicInvites topicCollabField topicActorField resourceID = getTopicInvites resourceID =
fmap (map adapt) $ fmap (map adapt) $
E.select $ E.from $ 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` recipL `E.LeftOuterJoin` recipR
`E.LeftOuterJoin` (inviterL `E.InnerJoin` item `E.InnerJoin` actor) `E.LeftOuterJoin` (inviterL `E.InnerJoin` item `E.InnerJoin` actor)
`E.LeftOuterJoin` (inviterR `E.InnerJoin` activity) `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.^. CollabFulfillsInviteId) E.==. inviterL E.?. CollabInviterLocalCollab
E.on $ E.just (fulfills E.^. CollabFulfillsInviteCollab) E.==. recipR E.?. CollabRecipRemoteCollab E.on $ E.just (fulfills E.^. CollabFulfillsInviteCollab) E.==. recipR E.?. CollabRecipRemoteCollab
E.on $ E.just (fulfills E.^. CollabFulfillsInviteCollab) E.==. recipL E.?. CollabRecipLocalCollab E.on $ E.just (fulfills E.^. CollabFulfillsInviteCollab) E.==. recipL E.?. CollabRecipLocalCollab
E.on $ topic E.^. topicCollabField E.==. fulfills E.^. CollabFulfillsInviteCollab E.on $ collab E.^. CollabId E.==. fulfills E.^. CollabFulfillsInviteCollab
E.on $ E.just (topic E.^. topicCollabField) E.==. enable E.?. CollabEnableCollab E.on $ E.just (collab E.^. CollabId) E.==. enable E.?. CollabEnableCollab
E.on $ topic E.^. topicCollabField E.==. collab E.^. CollabId
E.where_ $ E.where_ $
topic E.^. topicActorField E.==. E.val resourceID E.&&. collab E.^. CollabTopic E.==. E.val resourceID E.&&.
E.isNothing (enable E.?. CollabEnableId) E.isNothing (enable E.?. CollabEnableId)
E.orderBy [E.asc $ fulfills E.^. CollabFulfillsInviteId] E.orderBy [E.asc $ fulfills E.^. CollabFulfillsInviteId]
return return
@ -314,18 +265,13 @@ getTopicInvites topicCollabField topicActorField resourceID =
) )
getTopicJoins getTopicJoins
:: ( MonadIO m :: MonadIO m
, PersistRecordBackend topic SqlBackend => ResourceId
, PersistRecordBackend resource SqlBackend
)
=> EntityField topic CollabId
-> EntityField topic (Key resource)
-> Key resource
-> ReaderT SqlBackend m [(Either PersonId RemoteActorId, UTCTime, AP.Role)] -> ReaderT SqlBackend m [(Either PersonId RemoteActorId, UTCTime, AP.Role)]
getTopicJoins topicCollabField topicActorField resourceID = getTopicJoins resourceID =
fmap (map adapt) $ fmap (map adapt) $
E.select $ E.from $ 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` (joinL `E.InnerJoin` recipL `E.InnerJoin` item)
`E.LeftOuterJoin` (joinR `E.InnerJoin` recipR `E.InnerJoin` activity) `E.LeftOuterJoin` (joinR `E.InnerJoin` recipR `E.InnerJoin` activity)
) -> do ) -> do
@ -335,11 +281,10 @@ getTopicJoins topicCollabField topicActorField resourceID =
E.on $ joinL E.?. CollabRecipLocalJoinJoin E.==. item E.?. OutboxItemId E.on $ joinL E.?. CollabRecipLocalJoinJoin E.==. item E.?. OutboxItemId
E.on $ joinL E.?. CollabRecipLocalJoinCollab E.==. recipL E.?. CollabRecipLocalId E.on $ joinL E.?. CollabRecipLocalJoinCollab E.==. recipL E.?. CollabRecipLocalId
E.on $ E.just (fulfills E.^. CollabFulfillsJoinId) E.==. joinL E.?. CollabRecipLocalJoinFulfills E.on $ E.just (fulfills E.^. CollabFulfillsJoinId) E.==. joinL E.?. CollabRecipLocalJoinFulfills
E.on $ topic E.^. topicCollabField E.==. fulfills E.^. CollabFulfillsJoinCollab E.on $ collab E.^. CollabId E.==. fulfills E.^. CollabFulfillsJoinCollab
E.on $ E.just (topic E.^. topicCollabField) E.==. enable E.?. CollabEnableCollab E.on $ E.just (collab E.^. CollabId) E.==. enable E.?. CollabEnableCollab
E.on $ topic E.^. topicCollabField E.==. collab E.^. CollabId
E.where_ $ E.where_ $
topic E.^. topicActorField E.==. E.val resourceID E.&&. collab E.^. CollabTopic E.==. E.val resourceID E.&&.
E.isNothing (enable E.?. CollabEnableId) E.isNothing (enable E.?. CollabEnableId)
E.orderBy [E.asc $ fulfills E.^. CollabFulfillsJoinId] E.orderBy [E.asc $ fulfills E.^. CollabFulfillsJoinId]
return return
@ -369,7 +314,7 @@ verifyCapability
:: MonadIO m :: MonadIO m
=> (LocalActorBy Key, OutboxItemId) => (LocalActorBy Key, OutboxItemId)
-> Either PersonId RemoteActorId -> Either PersonId RemoteActorId
-> LocalActorBy Key -> LocalResourceBy Key
-> AP.Role -> AP.Role
-> ExceptT Text (ReaderT SqlBackend m) () -> ExceptT Text (ReaderT SqlBackend m) ()
verifyCapability (capActor, capItem) actor resource requiredRole = do verifyCapability (capActor, capItem) actor resource requiredRole = do
@ -401,7 +346,7 @@ verifyCapability (capActor, capItem) actor resource requiredRole = do
topic <- lift $ getCollabTopic collabID topic <- lift $ getCollabTopic collabID
-- Verify that topic is indeed the sender of the Grant -- Verify that topic is indeed the sender of the Grant
unless (topic == capActor) $ unless (resourceToActor topic == capActor) $
error "Grant sender isn't the topic" error "Grant sender isn't the topic"
-- Verify the topic matches the resource specified -- 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" throwE "Capability topic is some other local resource"
-- Verify that the granted role is equal or greater than the required role -- 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) $ unless (givenRole >= requiredRole) $
throwE "The granted role doesn't allow the requested operation" throwE "The granted role doesn't allow the requested operation"
@ -419,7 +364,7 @@ verifyCapability'
-> Either -> Either
(LocalActorBy Key, ActorId, OutboxItemId) (LocalActorBy Key, ActorId, OutboxItemId)
(RemoteAuthor, LocalURI, Maybe ByteString) (RemoteAuthor, LocalURI, Maybe ByteString)
-> LocalActorBy Key -> LocalResourceBy Key
-> AP.Role -> AP.Role
-> ExceptT Text (ReaderT SqlBackend m) () -> ExceptT Text (ReaderT SqlBackend m) ()
verifyCapability' cap actor resource role = do verifyCapability' cap actor resource role = do
@ -435,30 +380,24 @@ verifyCapability' cap actor resource role = do
processRemote (author, _, _) = pure $ remoteAuthorId author processRemote (author, _, _) = pure $ remoteAuthorId author
getGrant getGrant
:: ( MonadIO m :: MonadIO m
, PersistRecordBackend topic SqlBackend => ResourceId
, PersistRecordBackend resource SqlBackend
, Show (Key resource)
)
=> EntityField topic CollabId
-> EntityField topic (Key resource)
-> Key resource
-> PersonId -> PersonId
-> ReaderT SqlBackend m (Maybe OutboxItemId) -> ReaderT SqlBackend m (Maybe OutboxItemId)
getGrant topicCollabField topicActorField resourceID personID = do getGrant resourceID personID = do
items <- 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.^. CollabEnableCollab E.==. recipL E.^. CollabRecipLocalCollab
E.on $ enable E.^. CollabEnableGrant E.==. grant E.^. OutboxItemId 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_ $ 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 recipL E.^. CollabRecipLocalPerson E.==. E.val personID
return $ grant E.^. OutboxItemId return $ grant E.^. OutboxItemId
case items of case items of
[] -> return Nothing [] -> return Nothing
[E.Value i] -> return $ Just i [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 getComponentIdent
:: MonadIO m :: MonadIO m
@ -649,7 +588,7 @@ checkExistingStems componentByID projectDB = do
const () <$> MaybeT (getBy $ UniqueStemProjectAcceptRemoteProject remoteID) const () <$> MaybeT (getBy $ UniqueStemProjectAcceptRemoteProject remoteID)
checkExistingPermits checkExistingPermits
:: PersonId -> Either (LocalActorBy Key) RemoteActorId -> ActDBE () :: PersonId -> Either ResourceId RemoteActorId -> ActDBE ()
checkExistingPermits personID topicDB = do checkExistingPermits personID topicDB = do
-- Find existing Permit records I have for this topic -- Find existing Permit records I have for this topic
@ -682,63 +621,13 @@ checkExistingPermits personID topicDB = do
where where
getExistingPermits (Left (LocalActorPerson _)) = pure [] getExistingPermits (Left resourceID) =
getExistingPermits (Left (LocalActorRepo repoID)) =
fmap (map $ bimap E.unValue (Left . E.unValue)) $ fmap (map $ bimap E.unValue (Left . E.unValue)) $
E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do E.select $ E.from $ \ (permit `E.InnerJoin` local) -> do
E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicRepoPermit
E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit
E.where_ $ E.where_ $
permit E.^. PermitPerson E.==. E.val personID E.&&. permit E.^. PermitPerson E.==. E.val personID E.&&.
topic E.^. PermitTopicRepoRepo E.==. E.val repoID local E.^. PermitTopicLocalTopic E.==. E.val resourceID
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
return return
( permit E.^. PermitId ( permit E.^. PermitId
, local E.^. PermitTopicLocalId , local E.^. PermitTopicLocalId
@ -1120,12 +1009,14 @@ getPermitsForResource personID actor = do
PermitTopicEnableLocal _ topicID _ <- getJust enableID PermitTopicEnableLocal _ topicID _ <- getJust enableID
byk <- getPermitTopicLocal topicID byk <- getPermitTopicLocal topicID
bye <- do bye <- do
m <- getLocalActorEntity byk m <- getLocalResourceEntity byk
case m of case m of
Nothing -> error "I just found this PermitTopicLocal in DB but now the specific actor ID isn't found" Nothing -> error "I just found this PermitTopicLocal in DB but now the specific actor ID isn't found"
Just bye -> pure bye Just bye -> pure bye
a <- getJust $ localActorID bye Resource aid <- getJust $ localResourceID bye
return (Left (byk, grantID), Left (byk, a)) a <- getJust aid
let byk' = resourceToActor byk
return (Left (byk', grantID), Left (byk', a))
Right (PermitTopicExtendRemote _ enableID grantID) -> do Right (PermitTopicExtendRemote _ enableID grantID) -> do
PermitTopicEnableRemote _ topicID _ <- getJust enableID PermitTopicEnableRemote _ topicID _ <- getJust enableID
PermitTopicRemote _ remoteActorID <- getJust topicID PermitTopicRemote _ remoteActorID <- getJust topicID

2
src/Vervis/Persist/Ticket.hs
View file

@ -179,7 +179,7 @@ checkApplyDB actor capID (repoID, maybeBranch) (loomID, clothID, bundleID) = do
case capID of case capID of
Left (capActor, _, capItem) -> return (capActor, capItem) Left (capActor, _, capItem) -> return (capActor, capItem)
Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local loom" 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 -- Get the patches from DB, verify VCS match just in case
diffs <- do diffs <- do

24
src/Vervis/Web/Collab.hs
View file

@ -92,7 +92,7 @@ verifyCapability''
-> Either -> Either
(LocalActorBy Key, ActorId, OutboxItemId) (LocalActorBy Key, ActorId, OutboxItemId)
(RemoteAuthor, LocalURI, Maybe ByteString) (RemoteAuthor, LocalURI, Maybe ByteString)
-> LocalActorBy Key -> LocalResourceBy Key
-> AP.Role -> AP.Role
-> ActE () -> ActE ()
verifyCapability'' uCap recipientActor resource requiredRole = do verifyCapability'' uCap recipientActor resource requiredRole = do
@ -100,7 +100,7 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
maxDepth <- appMaxGrantChainLength <$> asksEnv envSettings maxDepth <- appMaxGrantChainLength <$> asksEnv envSettings
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
uResource <- uResource <-
encodeRouteHome . VR.renderLocalActor <$> hashLocalActor resource encodeRouteHome . VR.renderLocalResource <$> hashLocalResource resource
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
grants <- traverseGrants maxDepth manager uResource now grants <- traverseGrants maxDepth manager uResource now
unless (checkRole grants) $ unless (checkRole grants) $
@ -198,7 +198,7 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
case cap of case cap of
Left (actor, _, itemID) -> return (actor, itemID) Left (actor, _, itemID) -> return (actor, itemID)
Right _ -> throwE "Remote, so definitely not by me" Right _ -> throwE "Remote, so definitely not by me"
unless (capActor == resource) $ unless (capActor == resourceToActor resource) $
throwE "Capability's actor isn't me, the resource" throwE "Capability's actor isn't me, the resource"
-- Options here: -- Options here:
@ -229,7 +229,7 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
-- Find the local topic, on which this Collab gives access -- Find the local topic, on which this Collab gives access
topic <- lift $ getCollabTopic collabID topic <- lift $ getCollabTopic collabID
-- Verify that topic is indeed the sender of the Grant -- Verify that topic is indeed the sender of the Grant
unless (topic == capActor) $ unless (resourceToActor topic == capActor) $
error "Grant sender isn't the topic" error "Grant sender isn't the topic"
-- Verify the topic matches the resource specified -- Verify the topic matches the resource specified
unless (topic == resource) $ unless (topic == resource) $
@ -237,7 +237,7 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
-- There are more Grants in the chain, so we're -- There are more Grants in the chain, so we're
-- looking for a Stem or Dest record -- looking for a Stem or Dest record
else case actorToComponent capActor of else case (resourceToComponent <=< actorToResource) capActor of
Just capTopic -> nameExceptT "Stem" $ do Just capTopic -> nameExceptT "Stem" $ do
-- Find the Stem record -- Find the Stem record
stemID <- do stemID <- do
@ -252,7 +252,7 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
unless (topic == capTopic) $ unless (topic == capTopic) $
error "Grant sender isn't the Stem ident" error "Grant sender isn't the Stem ident"
-- Verify the topic matches the resource specified -- Verify the topic matches the resource specified
unless (componentActor topic == resource) $ unless (componentResource topic == resource) $
throwE "Capability topic is some other local resource" throwE "Capability topic is some other local resource"
Nothing -> nameExceptT "Dest" $ do Nothing -> nameExceptT "Dest" $ do
-- Find the Dest record -- Find the Dest record
@ -266,11 +266,11 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
holder <- lift $ getDestHolder destID holder <- lift $ getDestHolder destID
let holderActor = let holderActor =
either either
(LocalActorProject . snd) (LocalResourceProject . snd)
(LocalActorGroup . snd) (LocalResourceGroup . snd)
holder holder
-- Verify that holder is indeed the sender of the Grant -- 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" error "Grant sender isn't the Dest holder"
-- Verify the topic matches the resource specified -- Verify the topic matches the resource specified
unless (holderActor == resource) $ unless (holderActor == resource) $
@ -283,7 +283,7 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
throwE "Chain is longer than the max depth" throwE "Chain is longer than the max depth"
case cap of case cap of
Left (actor, _, _) Left (actor, _, _)
| resource == actor -> | resourceToActor resource == actor ->
throwE "Grant.delegates specified but Grant's actor is me" throwE "Grant.delegates specified but Grant's actor is me"
_ -> return () _ -> return ()
(luResult, _) <- fromMaybeE (AP.grantResult grant) "Grant.result not specified" (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 -- We already checked that the activity exists in DB
-- So proceed to find the Stem or Dest record -- So proceed to find the Stem or Dest record
case actorToComponent capActor of case (resourceToComponent <=< actorToResource) capActor of
Just capTopic -> nameExceptT "Stem" $ do Just capTopic -> nameExceptT "Stem" $ do
-- Find the Stem record -- Find the Stem record
stemID <- do stemID <- do
@ -444,7 +444,7 @@ checkCapabilityBeforeExtending uCap extender = do
error "Grant sender isn't the Stem ident" error "Grant sender isn't the Stem ident"
-- Verify the topic matches the resource specified -- Verify the topic matches the resource specified
uTopic <- lift $ lift $ do uTopic <- lift $ lift $ do
actorR <- VR.renderLocalActor <$> hashLocalActor (componentActor topic) actorR <- VR.renderLocalResource <$> hashLocalResource (componentResource topic)
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
return $ encodeRouteHome actorR return $ encodeRouteHome actorR
unless (uTopic == AP.grantContext grant) $ unless (uTopic == AP.grantContext grant) $

64
th/models
View file

@ -592,6 +592,7 @@ RemoteMessage
Collab Collab
role Role role Role
topic ResourceId
-------------------------------- Collab reason ------------------------------- -------------------------------- Collab reason -------------------------------
@ -660,38 +661,6 @@ CollabRecipRemoteJoin
UniqueCollabRecipRemoteJoinFulfills fulfills UniqueCollabRecipRemoteJoinFulfills fulfills
UniqueCollabRecipRemoteJoinJoin join 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 ---------------------------- -------------------------------- Collab recipient ----------------------------
CollabRecipLocal CollabRecipLocal
@ -767,39 +736,10 @@ Permit
PermitTopicLocal PermitTopicLocal
permit PermitId permit PermitId
topic ResourceId
UniquePermitTopicLocal permit 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 PermitTopicRemote
permit PermitId permit PermitId
actor RemoteActorId actor RemoteActorId

6
th/routes
View file

@ -174,7 +174,7 @@
/groups/#GroupKeyHashid/members GroupMembersR GET /groups/#GroupKeyHashid/members GroupMembersR GET
/groups/#GroupKeyHashid/invite GroupInviteR GET POST /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 GroupChildrenR GET
/groups/#GroupKeyHashid/children/#DestUsStartKeyHashid/live GroupChildLiveR GET /groups/#GroupKeyHashid/children/#DestUsStartKeyHashid/live GroupChildLiveR GET
@ -237,7 +237,7 @@
/decks/#DeckKeyHashid/collabs DeckCollabsR GET /decks/#DeckKeyHashid/collabs DeckCollabsR GET
/decks/#DeckKeyHashid/invite DeckInviteR GET POST /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 DeckProjectsR GET
/decks/#DeckKeyHashid/projects/approve/#StemKeyHashid DeckApproveCompR POST /decks/#DeckKeyHashid/projects/approve/#StemKeyHashid DeckApproveCompR POST
@ -343,7 +343,7 @@
/projects/#ProjectKeyHashid/collabs ProjectCollabsR GET /projects/#ProjectKeyHashid/collabs ProjectCollabsR GET
/projects/#ProjectKeyHashid/invite ProjectInviteR GET POST /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/components ProjectComponentsR GET
/projects/#ProjectKeyHashid/collabs/#CollabEnableKeyHashid/live ProjectCollabLiveR GET /projects/#ProjectKeyHashid/collabs/#CollabEnableKeyHashid/live ProjectCollabLiveR GET