mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-26 14:44:51 +09:00
Merge remote-tracking branch 'upstream/main'
This commit is contained in:
commit
756d40793a
GPG key ID:
164DFF24E2D40139
39 changed files with 3177 additions and 386 deletions
300
migrations/565_2023-12-09_collab_permit.model
Normal file
300
migrations/565_2023-12-09_collab_permit.model
Normal file
|
|
@ -0,0 +1,300 @@
|
|||
Repo
|
||||
Deck
|
||||
Loom
|
||||
Project
|
||||
Group
|
||||
RemoteActor
|
||||
RemoteActivity
|
||||
Inbox
|
||||
FollowerSet
|
||||
|
||||
Outbox
|
||||
|
||||
OutboxItem
|
||||
outbox OutboxId
|
||||
activity PersistJSONObject
|
||||
published UTCTime
|
||||
|
||||
Actor
|
||||
name Text
|
||||
desc Text
|
||||
createdAt UTCTime
|
||||
inbox InboxId
|
||||
outbox OutboxId
|
||||
followers FollowerSetId
|
||||
justCreatedBy ActorId Maybe
|
||||
|
||||
UniqueActorInbox inbox
|
||||
UniqueActorOutbox outbox
|
||||
UniqueActorFollowers followers
|
||||
|
||||
Person
|
||||
username Username
|
||||
login Text
|
||||
passphraseHash ByteString
|
||||
email EmailAddress
|
||||
verified Bool
|
||||
verifiedKey Text
|
||||
verifiedKeyCreated UTCTime
|
||||
resetPassKey Text
|
||||
resetPassKeyCreated UTCTime
|
||||
actor ActorId
|
||||
-- reviewFollow Bool
|
||||
|
||||
UniquePersonUsername username
|
||||
UniquePersonLogin login
|
||||
UniquePersonEmail email
|
||||
UniquePersonActor actor
|
||||
|
||||
Collab
|
||||
role Role
|
||||
|
||||
CollabFulfillsLocalTopicCreation
|
||||
collab CollabId
|
||||
|
||||
UniqueCollabFulfillsLocalTopicCreation collab
|
||||
|
||||
CollabFulfillsInvite
|
||||
collab CollabId
|
||||
accept OutboxItemId
|
||||
|
||||
UniqueCollabFulfillsInvite collab
|
||||
UniqueCollabFulfillsInviteAccept accept
|
||||
|
||||
CollabInviterLocal
|
||||
collab CollabFulfillsInviteId
|
||||
invite OutboxItemId
|
||||
|
||||
UniqueCollabInviterLocal collab
|
||||
UniqueCollabInviterLocalInvite invite
|
||||
|
||||
CollabInviterRemote
|
||||
collab CollabFulfillsInviteId
|
||||
actor RemoteActorId
|
||||
invite RemoteActivityId
|
||||
|
||||
UniqueCollabInviterRemote collab
|
||||
UniqueCollabInviterRemoteInvite invite
|
||||
|
||||
CollabFulfillsJoin
|
||||
collab CollabId
|
||||
|
||||
UniqueCollabFulfillsJoin collab
|
||||
|
||||
CollabApproverLocal
|
||||
collab CollabFulfillsJoinId
|
||||
accept OutboxItemId
|
||||
|
||||
UniqueCollabApproverLocal collab
|
||||
UniqueCollabApproverLocalAccept accept
|
||||
|
||||
CollabApproverRemote
|
||||
collab CollabFulfillsJoinId
|
||||
actor RemoteActorId
|
||||
accept RemoteActivityId
|
||||
|
||||
UniqueCollabApproverRemote collab
|
||||
UniqueCollabApproverRemoteAccept accept
|
||||
|
||||
CollabRecipLocalJoin
|
||||
collab CollabRecipLocalId
|
||||
fulfills CollabFulfillsJoinId
|
||||
join OutboxItemId
|
||||
|
||||
UniqueCollabRecipLocalJoinCollab collab
|
||||
UniqueCollabRecipLocalJoinFulfills fulfills
|
||||
UniqueCollabRecipLocalJoinJoin join
|
||||
|
||||
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
|
||||
|
||||
CollabRecipLocal
|
||||
collab CollabId
|
||||
person PersonId
|
||||
|
||||
UniqueCollabRecipLocal collab
|
||||
|
||||
CollabRecipLocalAccept
|
||||
collab CollabRecipLocalId
|
||||
invite CollabFulfillsInviteId
|
||||
accept OutboxItemId
|
||||
|
||||
UniqueCollabRecipLocalAcceptCollab collab
|
||||
UniqueCollabRecipLocalAcceptInvite invite
|
||||
UniqueCollabRecipLocalAcceptAccept accept
|
||||
|
||||
CollabEnable
|
||||
collab CollabId
|
||||
grant OutboxItemId
|
||||
|
||||
UniqueCollabEnable collab
|
||||
UniqueCollabEnableGrant grant
|
||||
|
||||
CollabDelegLocal
|
||||
enable CollabEnableId
|
||||
recip CollabRecipLocalId
|
||||
grant OutboxItemId
|
||||
|
||||
UniqueCollabDelegLocal enable
|
||||
UniqueCollabDelegLocalRecip recip
|
||||
UniqueCollabDelegLocalGrant grant
|
||||
|
||||
Permit
|
||||
person PersonId
|
||||
role Role
|
||||
|
||||
PermitTopicLocal
|
||||
permit PermitId
|
||||
|
||||
UniquePermitTopicLocal permit
|
||||
|
||||
PermitTopicRepo
|
||||
permit PermitTopicLocalId
|
||||
repo RepoId
|
||||
|
||||
UniquePermitTopicRepo permit
|
||||
|
||||
PermitTopicDeck
|
||||
permit PermitTopicLocalId
|
||||
deck DeckId
|
||||
|
||||
UniquePermitTopicDeck permit
|
||||
|
||||
PermitTopicLoom
|
||||
permit PermitTopicLocalId
|
||||
loom LoomId
|
||||
|
||||
UniquePermitTopicLoom permit
|
||||
|
||||
PermitTopicProject
|
||||
permit PermitTopicLocalId
|
||||
project ProjectId
|
||||
|
||||
UniquePermitTopicProject permit
|
||||
|
||||
PermitTopicGroup
|
||||
permit PermitTopicLocalId
|
||||
group GroupId
|
||||
|
||||
UniquePermitTopicGroup permit
|
||||
|
||||
PermitTopicRemote
|
||||
permit PermitId
|
||||
actor RemoteActorId
|
||||
|
||||
UniquePermitTopicRemote permit
|
||||
|
||||
PermitFulfillsTopicCreation
|
||||
permit PermitId
|
||||
|
||||
UniquePermitFulfillsTopicCreation permit
|
||||
|
||||
PermitFulfillsInvite
|
||||
permit PermitId
|
||||
|
||||
UniquePermitFulfillsInvite permit
|
||||
|
||||
PermitFulfillsJoin
|
||||
permit PermitId
|
||||
|
||||
UniquePermitFulfillsJoin permit
|
||||
|
||||
PermitPersonGesture
|
||||
permit PermitId
|
||||
activity OutboxItemId
|
||||
|
||||
UniquePermitPersonGesture permit
|
||||
UniquePermitPersonGestureActivity activity
|
||||
|
||||
PermitTopicGestureLocal
|
||||
fulfills PermitFulfillsInviteId
|
||||
invite OutboxItemId
|
||||
|
||||
UniquePermitTopicGestureLocal fulfills
|
||||
UniquePermitTopicGestureLocalInvite invite
|
||||
|
||||
PermitTopicGestureRemote
|
||||
fulfills PermitFulfillsInviteId
|
||||
actor RemoteActorId
|
||||
invite RemoteActivityId
|
||||
|
||||
UniquePermitTopicGestureRemote fulfills
|
||||
UniquePermitTopicGestureRemoteInvite invite
|
||||
|
||||
PermitTopicAcceptLocal
|
||||
fulfills PermitFulfillsInviteId
|
||||
topic PermitTopicLocalId
|
||||
accept OutboxItemId
|
||||
|
||||
UniquePermitTopicAcceptLocal fulfills
|
||||
UniquePermitTopicAcceptLocalTopic topic
|
||||
UniquePermitTopicAcceptLocalAccept accept
|
||||
|
||||
PermitTopicEnableLocal
|
||||
permit PermitPersonGestureId
|
||||
topic PermitTopicLocalId
|
||||
grant OutboxItemId
|
||||
|
||||
UniquePermitTopicEnableLocal permit
|
||||
UniquePermitTopicEnableLocalTopic topic
|
||||
UniquePermitTopicEnableLocalGrant grant
|
||||
|
||||
PermitPersonSendDelegator
|
||||
permit PermitPersonGestureId
|
||||
grant OutboxItemId
|
||||
|
||||
UniquePermitPersonSendDelegator permit
|
||||
UniquePermitPersonSendDelegatorGrant grant
|
||||
|
||||
PermitTopicExtendLocal
|
||||
permit PermitPersonSendDelegatorId
|
||||
topic PermitTopicEnableLocalId
|
||||
grant OutboxItemId
|
||||
|
||||
UniquePermitTopicExtendLocalGrant grant
|
||||
|
||||
Component
|
||||
project ProjectId
|
||||
role Role
|
||||
|
||||
ComponentEnable
|
||||
component ComponentId
|
||||
grant OutboxItemId
|
||||
|
||||
UniqueComponentEnable component
|
||||
UniqueComponentEnableGrant grant
|
||||
|
||||
ComponentFurtherLocal
|
||||
component ComponentEnableId
|
||||
collab CollabDelegLocalId
|
||||
grant OutboxItemId
|
||||
|
||||
UniqueComponentFurtherLocal component collab
|
||||
UniqueComponentFurtherLocalGrant grant
|
||||
359
migrations/570_2023-12-09_source_dest.model
Normal file
359
migrations/570_2023-12-09_source_dest.model
Normal file
|
|
@ -0,0 +1,359 @@
|
|||
------------------------------------------------------------------------------
|
||||
-- Inheritance - Receiver tracking her givers
|
||||
-- (Project tracking its children)
|
||||
-- (Team tracking its parents)
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
Source
|
||||
role Role
|
||||
|
||||
SourceHolderProject
|
||||
source SourceId
|
||||
project ProjectId
|
||||
|
||||
UniqueSourceHolderProject source
|
||||
|
||||
SourceHolderGroup
|
||||
source SourceId
|
||||
group GroupId
|
||||
|
||||
UniqueSourceHolderGroup source
|
||||
|
||||
-------------------------------- Source topic --------------------------------
|
||||
|
||||
SourceTopicLocal
|
||||
source SourceId
|
||||
|
||||
UniqueSourceTopicLocal source
|
||||
|
||||
SourceTopicProject
|
||||
holder SourceHolderProjectId
|
||||
topic SourceTopicLocalId
|
||||
child ProjectId
|
||||
|
||||
UniqueSourceTopicProject holder
|
||||
UniqueSourceTopicProjectTopic topic
|
||||
|
||||
SourceTopicGroup
|
||||
holder SourceHolderGroupId
|
||||
topic SourceTopicLocalId
|
||||
parent GroupId
|
||||
|
||||
UniqueSourceTopicGroup holder
|
||||
UniqueSourceTopicGroupTopic topic
|
||||
|
||||
SourceTopicRemote
|
||||
source SourceId
|
||||
topic RemoteActorId
|
||||
|
||||
UniqueSourceTopicRemote source
|
||||
|
||||
-------------------------------- Source flow ---------------------------------
|
||||
|
||||
SourceOriginUs
|
||||
source SourceId
|
||||
|
||||
UniqueSourceOriginUs source
|
||||
|
||||
SourceOriginThem
|
||||
source SourceId
|
||||
|
||||
UniqueSourceOriginThem source
|
||||
|
||||
-- Our collaborator's gesture
|
||||
--
|
||||
-- OriginUs: The Add that started the sequence
|
||||
-- OriginThem: N/A (they send their Accept but we don't record it)
|
||||
|
||||
SourceUsGestureLocal
|
||||
us SourceOriginUsId
|
||||
add OutboxItemId
|
||||
|
||||
UniqueSourceUsGestureLocal us
|
||||
UniqueSourceUsGestureLocalAdd add
|
||||
|
||||
SourceUsGestureRemote
|
||||
us SourceOriginUsId
|
||||
actor RemoteActorId
|
||||
add RemoteActivityId
|
||||
|
||||
UniqueSourceUsGestureRemote us
|
||||
UniqueSourceUsGestureRemoteAdd add
|
||||
|
||||
-- Our accept
|
||||
--
|
||||
-- OriginUs: I checked the Add and sending my Accept
|
||||
-- OriginThem: N/A
|
||||
|
||||
SourceUsAccept
|
||||
us SourceOriginUsId
|
||||
accept OutboxItemId
|
||||
|
||||
UniqueSourceUsAccept us
|
||||
UniqueSourceUsAcceptAccept accept
|
||||
|
||||
-- Their collaborator's gesture
|
||||
--
|
||||
-- OriginUs: N/A (they send it but we don't record it)
|
||||
-- OriginThem: The Add that started the sequence
|
||||
|
||||
SourceThemGestureLocal
|
||||
them SourceOriginThemId
|
||||
add OutboxItemId
|
||||
|
||||
UniqueSourceThemGestureLocal them
|
||||
UniqueSourceThemGestureLocalAdd add
|
||||
|
||||
SourceThemGestureRemote
|
||||
them SourceOriginThemId
|
||||
actor RemoteActorId
|
||||
add RemoteActivityId
|
||||
|
||||
UniqueSourceThemGestureRemote them
|
||||
UniqueSourceThemGestureRemoteAdd add
|
||||
|
||||
-- Their accept
|
||||
--
|
||||
-- OriginUs: Seeing our accept and their collaborator's accept, they send their
|
||||
-- own accept
|
||||
-- OriginThem: Checking the Add, they send their Accept
|
||||
|
||||
SourceThemAcceptLocal
|
||||
topic SourceTopicLocalId
|
||||
accept OutboxItemId
|
||||
|
||||
UniqueSourceThemAcceptLocal topic
|
||||
UniqueSourceThemAcceptLocalAccept accept
|
||||
|
||||
SourceThemAcceptRemote
|
||||
topic SourceTopicRemoteId
|
||||
accept RemoteActivityId
|
||||
|
||||
UniqueSourceThemAcceptRemote topic
|
||||
UniqueSourceThemAcceptRemoteAccept accept
|
||||
|
||||
-------------------------------- Source enable -------------------------------
|
||||
|
||||
-- Witnesses that, seeing their approval and our collaborator's gesture, I've
|
||||
-- sent then a delegator-Grant and now officially considering them a source of
|
||||
-- us
|
||||
SourceUsSendDelegator
|
||||
source SourceId
|
||||
grant OutboxItemId
|
||||
|
||||
UniqueSourceUsSendDelegator source
|
||||
UniqueSourceUsSendDelegatorGrant grant
|
||||
|
||||
-- Witnesses that, using the delegator-Grant, they sent us a start-Grant or
|
||||
-- extension-Grant to delegate further
|
||||
|
||||
SourceThemDelegateLocal
|
||||
source SourceThemAcceptLocalId
|
||||
grant OutboxItemId
|
||||
|
||||
UniqueSourceThemDelegateLocal source
|
||||
UniqueSourceThemDelegateLocalGrant grant
|
||||
|
||||
SourceThemDelegateRemote
|
||||
source SourceThemAcceptRemoteId
|
||||
grant RemoteActivityId
|
||||
|
||||
UniqueSourceThemDelegateRemote source
|
||||
UniqueSourceThemDelegateRemoteGrant grant
|
||||
|
||||
-- Witnesses that, seeing the delegation from them, I've sent an
|
||||
-- extension-Grant to a Dest of mine
|
||||
|
||||
SourceUsGatherLocal
|
||||
deleg SourceUsSendDelegatorId
|
||||
dest DestThemSendDelegatorLocalId
|
||||
grant OutboxItemId
|
||||
|
||||
UniqueSourceUsGatherLocal grant
|
||||
|
||||
SourceUsGatherRemote
|
||||
deleg SourceUsSendDelegatorId
|
||||
dest DestThemSendDelegatorRemoteId
|
||||
grant RemoteActivityId
|
||||
|
||||
UniqueSourceUsGatherRemote grant
|
||||
|
||||
-- Witnesses that, seeing the delegation from them, I've sent a leaf-Grant to a
|
||||
-- direct-collaborator of mine
|
||||
|
||||
SourceUsLeafLocal
|
||||
deleg SourceUsSendDelegatorId
|
||||
collab CollabDelegLocalId
|
||||
grant OutboxItemId
|
||||
|
||||
UniqueSourceUsLeafLocal grant
|
||||
|
||||
SourceUsLeafRemote
|
||||
deleg SourceUsSendDelegatorId
|
||||
collab CollabDelegRemoteId
|
||||
grant RemoteActivityId
|
||||
|
||||
UniqueSourceUsLeafRemote grant
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Inheritance - Giver tracking her receivers
|
||||
-- (Project tracking its parents)
|
||||
-- (Team tracking its children)
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
Dest
|
||||
role Role
|
||||
|
||||
DestHolderProject
|
||||
dest DestId
|
||||
project ProjectId
|
||||
|
||||
UniqueDestHolderProject dest
|
||||
|
||||
DestHolderGroup
|
||||
dest DestId
|
||||
group GroupId
|
||||
|
||||
UniqueDestHolderGroup dest
|
||||
|
||||
---------------------------------- Dest topic --------------------------------
|
||||
|
||||
DestTopicLocal
|
||||
dest DestId
|
||||
|
||||
UniqueDestTopicLocal dest
|
||||
|
||||
DestTopicProject
|
||||
holder DestHolderProjectId
|
||||
topic DestTopicLocalId
|
||||
parent ProjectId
|
||||
|
||||
UniqueDestTopicProject holder
|
||||
UniqueDestTopicProjectTopic topic
|
||||
|
||||
DestTopicGroup
|
||||
holder DestHolderGroupId
|
||||
topic DestTopicLocalId
|
||||
child GroupId
|
||||
|
||||
UniqueDestTopicGroup holder
|
||||
UniqueDestTopicGroupTopic topic
|
||||
|
||||
DestTopicRemote
|
||||
dest DestId
|
||||
topic RemoteActorId
|
||||
|
||||
UniqueDestTopicRemote dest
|
||||
|
||||
---------------------------------- Dest flow ---------------------------------
|
||||
|
||||
DestOriginUs
|
||||
dest DestId
|
||||
|
||||
UniqueDestOriginUs dest
|
||||
|
||||
DestOriginThem
|
||||
dest DestId
|
||||
|
||||
UniqueDestOriginThem dest
|
||||
|
||||
-- Our collaborator's gesture
|
||||
--
|
||||
-- OriginUs: The Add that started the sequence
|
||||
-- OriginThem: Seeing the Add and their Accept, my collaborator has sent her
|
||||
-- Accept
|
||||
|
||||
DestUsGestureLocal
|
||||
dest DestId
|
||||
activity OutboxItemId
|
||||
|
||||
UniqueDestUsGestureLocal dest
|
||||
UniqueDestUsGestureLocalActivity activity
|
||||
|
||||
DestUsGestureRemote
|
||||
dest DestId
|
||||
actor RemoteActorId
|
||||
activity RemoteActivityId
|
||||
|
||||
UniqueDestUsGestureRemote dest
|
||||
UniqueDestUsGestureRemoteActivity activity
|
||||
|
||||
-- Our accept
|
||||
--
|
||||
-- OriginUs: Checking my collaborator's Add, I sent my Accept
|
||||
-- OriginThem: Seeing the Add, their Accept and my collaborator's Accept, I
|
||||
-- sent my Accept
|
||||
|
||||
DestUsAccept
|
||||
dest DestId
|
||||
accept OutboxItemId
|
||||
|
||||
UniqueDestUsAccept dest
|
||||
UniqueDestUsAcceptAccept accept
|
||||
|
||||
-- Their collaborator's gesture
|
||||
--
|
||||
-- OriginUs: N/A (they send it but we don't record it)
|
||||
-- OriginThem: The Add that started the sequence
|
||||
|
||||
DestThemGestureLocal
|
||||
them DestOriginThemId
|
||||
add OutboxItemId
|
||||
|
||||
UniqueDestThemGestureLocal them
|
||||
UniqueDestThemGestureLocalAdd add
|
||||
|
||||
DestThemGestureRemote
|
||||
them DestOriginThemId
|
||||
actor RemoteActorId
|
||||
add RemoteActivityId
|
||||
|
||||
UniqueDestThemGestureRemote them
|
||||
UniqueDestThemGestureRemoteAdd add
|
||||
|
||||
-- Their accept
|
||||
--
|
||||
-- OriginUs: N/A
|
||||
-- OriginThem: Seeing their collaborator's Add, they sent an Accept
|
||||
|
||||
DestThemAcceptLocal
|
||||
them DestOriginThemId
|
||||
topic DestTopicLocalId
|
||||
accept OutboxItemId
|
||||
|
||||
UniqueDestThemAcceptLocal them
|
||||
UniqueDestThemAcceptLocalTopic topic
|
||||
UniqueDestThemAcceptLocalAccept accept
|
||||
|
||||
DestThemAcceptRemote
|
||||
them DestOriginThemId
|
||||
topic DestTopicRemoteId
|
||||
accept RemoteActivityId
|
||||
|
||||
UniqueDestThemAcceptRemote them
|
||||
UniqueDestThemAcceptRemoteTopic topic
|
||||
UniqueDestThemAcceptRemoteAccept accept
|
||||
|
||||
---------------------------------- Dest enable -------------------------------
|
||||
|
||||
-- Witnesses that, seeing our approval and their collaborator's gesture,
|
||||
-- they've sent us a delegator-Grant, and we now officially consider them a
|
||||
-- dest of us
|
||||
|
||||
DestThemSendDelegatorLocal
|
||||
dest DestUsAcceptId
|
||||
topic DestTopicLocalId
|
||||
grant OutboxItemId
|
||||
|
||||
UniqueDestThemSendDelegatorLocal dest
|
||||
UniqueDestThemSendDelegatorLocalTopic topic
|
||||
UniqueDestThemSendDelegatorLocalGrant grant
|
||||
|
||||
DestThemSendDelegatorRemote
|
||||
dest DestUsAcceptId
|
||||
topic DestTopicRemoteId
|
||||
grant RemoteActivityId
|
||||
|
||||
UniqueDestThemSendDelegatorRemote dest
|
||||
UniqueDestThemSendDelegatorRemoteTopic topic
|
||||
UniqueDestThemSendDelegatorRemoteGrant grant
|
||||
|
|
@ -80,6 +80,8 @@ module Vervis.Actor
|
|||
, sendToLocalActors
|
||||
|
||||
, actorIsAddressed
|
||||
|
||||
, localActorType
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -714,3 +716,12 @@ actorIsAddressed recips = isJust . verify
|
|||
verify (LocalActorProject j) = do
|
||||
routes <- lookup j $ recipProjects recips
|
||||
guard $ routeProject routes
|
||||
|
||||
localActorType :: LocalActorBy f -> AP.ActorType
|
||||
localActorType = \case
|
||||
LocalActorPerson _ -> AP.ActorTypePerson
|
||||
LocalActorRepo _ -> AP.ActorTypeRepo
|
||||
LocalActorDeck _ -> AP.ActorTypeTicketTracker
|
||||
LocalActorLoom _ -> AP.ActorTypePatchTracker
|
||||
LocalActorProject _ -> AP.ActorTypeProject
|
||||
LocalActorGroup _ -> AP.ActorTypeTeam
|
||||
|
|
|
|||
|
|
@ -1379,6 +1379,8 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
|
|||
lift $ for maybeRemoveDB $ \ _removeDB -> do
|
||||
|
||||
-- Delete the whole Collab record
|
||||
deleteBy $ UniqueCollabDelegLocal enableID
|
||||
deleteBy $ UniqueCollabDelegRemote enableID
|
||||
delete enableID
|
||||
case recipID of
|
||||
Left (E.Value l) -> do
|
||||
|
|
@ -1853,8 +1855,7 @@ componentGrant grabActor topicComponent now recipKey (Verse authorIdMsig body) g
|
|||
(Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure ()
|
||||
_ -> throwE "Author and resource aren't the same project actor"
|
||||
case recipient of
|
||||
Left (GrantRecipComponent' c)
|
||||
| topicComponent recipKey == c -> pure ()
|
||||
Left la | topicResource recipKey == la -> pure ()
|
||||
_ -> throwE "Grant recipient isn't me"
|
||||
for_ mstart $ \ start ->
|
||||
unless (start < now) $ throwE "Start time is in the future"
|
||||
|
|
|
|||
|
|
@ -78,6 +78,292 @@ import Vervis.Persist.Collab
|
|||
import Vervis.Persist.Discussion
|
||||
import Vervis.Ticket
|
||||
|
||||
-- Meaning: An actor accepted something
|
||||
-- Behavior:
|
||||
-- * Check if I know the activity that's being Accepted:
|
||||
-- * Is it an Invite to be a collaborator in me?
|
||||
-- * Verify the Accept is by the Invite target
|
||||
-- * Is it a Join to be a collaborator in me?
|
||||
-- * Verify the Accept is authorized
|
||||
-- * If it's none of these, respond with error
|
||||
--
|
||||
-- * Verify the Collab isn't enabled yet
|
||||
--
|
||||
-- * Insert the Accept to my inbox
|
||||
--
|
||||
-- * Record the Accept and enable the Collab in DB
|
||||
--
|
||||
-- * Forward the Accept to my followers
|
||||
--
|
||||
-- * Possibly send a Grant:
|
||||
-- * For Invite-collab mode:
|
||||
-- * Regular collaborator-Grant
|
||||
-- * To: Accepter (i.e. Invite target)
|
||||
-- * CC: Invite sender, Accepter's followers, my followers
|
||||
-- * For Join-as-collab mode:
|
||||
-- * Regular collaborator-Grant
|
||||
-- * To: Join sender
|
||||
-- * CC: Accept sender, Join sender's followers, my followers
|
||||
groupAccept
|
||||
:: UTCTime
|
||||
-> GroupId
|
||||
-> Verse
|
||||
-> AP.Accept URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
groupAccept now groupID (Verse authorIdMsig body) accept = do
|
||||
|
||||
-- Check input
|
||||
acceptee <- parseAccept accept
|
||||
|
||||
-- Verify that the capability URI, if specified, is one of:
|
||||
-- * Outbox item URI of a local actor, i.e. a local activity
|
||||
-- * A remote URI
|
||||
maybeCap <-
|
||||
traverse
|
||||
(nameExceptT "Accept capability" . parseActivityURI')
|
||||
(AP.activityCapability $ actbActivity body)
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(recipActorID, recipActor) <- lift $ do
|
||||
recip <- getJust groupID
|
||||
let actorID = groupActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
|
||||
-- Find the accepted activity in our DB
|
||||
accepteeDB <- do
|
||||
a <- getActivity acceptee
|
||||
fromMaybeE a "Can't find acceptee in DB"
|
||||
|
||||
-- See if the accepted activity is an Invite or Join where my collabs
|
||||
-- URI is the resource, grabbing the Collab record from our DB,
|
||||
(collabID, fulfills, inviterOrJoiner) <- do
|
||||
let adapt = maybe (Right Nothing) (either Left (Right . Just))
|
||||
maybeCollab <-
|
||||
ExceptT $ fmap adapt $ runMaybeT $
|
||||
runExceptT (tryInviteCollab accepteeDB) <|>
|
||||
runExceptT (tryJoinCollab accepteeDB)
|
||||
fromMaybeE
|
||||
maybeCollab
|
||||
"Accepted activity isn't an Invite/Join I'm aware of"
|
||||
|
||||
collab <- bitraverse
|
||||
|
||||
-- If accepting an Invite, find the Collab recipient and verify
|
||||
-- it's the sender of the Accept
|
||||
(\ fulfillsID -> do
|
||||
recip <-
|
||||
lift $
|
||||
requireEitherAlt
|
||||
(getBy $ UniqueCollabRecipLocal collabID)
|
||||
(getBy $ UniqueCollabRecipRemote collabID)
|
||||
"Found Collab with no recip"
|
||||
"Found Collab with multiple recips"
|
||||
case (recip, authorIdMsig) of
|
||||
(Left (Entity crlid crl), Left (LocalActorPerson personID, _, _))
|
||||
| collabRecipLocalPerson crl == personID ->
|
||||
return (fulfillsID, Left crlid)
|
||||
(Right (Entity crrid crr), Right (author, _, _))
|
||||
| collabRecipRemoteActor crr == remoteAuthorId author ->
|
||||
return (fulfillsID, Right crrid)
|
||||
_ -> throwE "Accepting an Invite whose recipient is someone else"
|
||||
)
|
||||
|
||||
-- If accepting a Join, verify accepter has permission
|
||||
(\ fulfillsID -> do
|
||||
capID <- fromMaybeE maybeCap "No capability provided"
|
||||
capability <-
|
||||
case capID of
|
||||
Left (capActor, _, capItem) -> return (capActor, capItem)
|
||||
Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local resource"
|
||||
verifyCapability'
|
||||
capability
|
||||
authorIdMsig
|
||||
(LocalActorGroup groupID)
|
||||
AP.RoleAdmin
|
||||
return fulfillsID
|
||||
)
|
||||
|
||||
fulfills
|
||||
|
||||
-- In collab mode, verify the Collab isn't already validated
|
||||
maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID
|
||||
verifyNothingE maybeEnabled "I already sent a Grant for this Invite/Join"
|
||||
|
||||
maybeAcceptDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
|
||||
for maybeAcceptDB $ \ acceptDB -> do
|
||||
|
||||
(grantID, enableID) <- do
|
||||
|
||||
-- In collab mode, record the Accept and enable the Collab
|
||||
case (collab, acceptDB) of
|
||||
(Left (fulfillsID, Left recipID), Left (_, _, acceptID)) -> do
|
||||
maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID
|
||||
unless (isNothing maybeAccept) $
|
||||
throwE "This Invite already has an Accept by recip"
|
||||
(Left (fulfillsID, Right recipID), Right (_, _, acceptID)) -> do
|
||||
maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID
|
||||
unless (isJust maybeAccept) $
|
||||
throwE "This Invite already has an Accept by recip"
|
||||
(Right fulfillsID, Left (_, _, acceptID)) -> do
|
||||
maybeAccept <- lift $ insertUnique $ CollabApproverLocal fulfillsID acceptID
|
||||
unless (isJust maybeAccept) $
|
||||
throwE "This Join already has an Accept"
|
||||
(Right fulfillsID, Right (author, _, acceptID)) -> do
|
||||
maybeAccept <- lift $ insertUnique $ CollabApproverRemote fulfillsID (remoteAuthorId author) acceptID
|
||||
unless (isJust maybeAccept) $
|
||||
throwE "This Join already has an Accept"
|
||||
_ -> error "groupAccept impossible"
|
||||
grantID <- lift $ insertEmptyOutboxItem' (actorOutbox recipActor) now
|
||||
enableID <- lift $ insert $ CollabEnable collabID grantID
|
||||
return (grantID, enableID)
|
||||
|
||||
-- Prepare forwarding of Accept to my followers
|
||||
let recipByID = LocalActorGroup groupID
|
||||
recipByHash <- hashLocalActor recipByID
|
||||
let sieve = makeRecipientSet [] [localActorFollowers recipByHash]
|
||||
|
||||
maybeGrant <- lift $ do
|
||||
|
||||
-- In collab mode, prepare a regular Grant
|
||||
let isInvite = isLeft collab
|
||||
grant@(actionGrant, _, _, _) <- do
|
||||
Collab role <- getJust collabID
|
||||
prepareCollabGrant isInvite inviterOrJoiner role
|
||||
let recipByKey = LocalActorGroup groupID
|
||||
_luGrant <- updateOutboxItem' recipByKey grantID actionGrant
|
||||
return $ Just (grantID, grant)
|
||||
|
||||
return (recipActorID, sieve, maybeGrant)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (recipActorID, sieve, maybeGrant) -> do
|
||||
let recipByID = LocalActorGroup groupID
|
||||
forwardActivity authorIdMsig body recipByID recipActorID sieve
|
||||
lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) ->
|
||||
sendActivity
|
||||
recipByID recipActorID localRecipsGrant
|
||||
remoteRecipsGrant fwdHostsGrant grantID actionGrant
|
||||
done "Forwarded the Accept and maybe published a Grant"
|
||||
|
||||
where
|
||||
|
||||
verifyCollabTopic collabID = do
|
||||
topic <- lift $ getCollabTopic collabID
|
||||
unless (LocalActorGroup groupID == topic) $
|
||||
throwE "Accept object is an Invite/Join for some other resource"
|
||||
|
||||
verifyInviteCollabTopic fulfillsID = do
|
||||
collabID <- lift $ collabFulfillsInviteCollab <$> getJust fulfillsID
|
||||
verifyCollabTopic collabID
|
||||
return collabID
|
||||
|
||||
verifyJoinCollabTopic fulfillsID = do
|
||||
collabID <- lift $ collabFulfillsJoinCollab <$> getJust fulfillsID
|
||||
verifyCollabTopic collabID
|
||||
return collabID
|
||||
|
||||
tryInviteCollab (Left (actorByKey, _actorEntity, itemID)) = do
|
||||
fulfillsID <-
|
||||
lift $ collabInviterLocalCollab <$>
|
||||
MaybeT (getValBy $ UniqueCollabInviterLocalInvite itemID)
|
||||
collabID <-
|
||||
ExceptT $ lift $ runExceptT $ verifyInviteCollabTopic fulfillsID
|
||||
return (collabID, Left fulfillsID, Left actorByKey)
|
||||
tryInviteCollab (Right remoteActivityID) = do
|
||||
CollabInviterRemote fulfillsID actorID _ <-
|
||||
lift $ MaybeT $ getValBy $
|
||||
UniqueCollabInviterRemoteInvite remoteActivityID
|
||||
collabID <-
|
||||
ExceptT $ lift $ runExceptT $ verifyInviteCollabTopic fulfillsID
|
||||
sender <- lift $ lift $ do
|
||||
actor <- getJust actorID
|
||||
(,remoteActorFollowers actor) <$> getRemoteActorURI actor
|
||||
return (collabID, Left fulfillsID, Right sender)
|
||||
|
||||
tryJoinCollab (Left (actorByKey, _actorEntity, itemID)) = do
|
||||
fulfillsID <-
|
||||
lift $ collabRecipLocalJoinFulfills <$>
|
||||
MaybeT (getValBy $ UniqueCollabRecipLocalJoinJoin itemID)
|
||||
collabID <-
|
||||
ExceptT $ lift $ runExceptT $ verifyJoinCollabTopic fulfillsID
|
||||
return (collabID, Right fulfillsID, Left actorByKey)
|
||||
tryJoinCollab (Right remoteActivityID) = do
|
||||
CollabRecipRemoteJoin recipID fulfillsID _ <-
|
||||
lift $ MaybeT $ getValBy $
|
||||
UniqueCollabRecipRemoteJoinJoin remoteActivityID
|
||||
collabID <-
|
||||
ExceptT $ lift $ runExceptT $ verifyJoinCollabTopic fulfillsID
|
||||
joiner <- lift $ lift $ do
|
||||
remoteActorID <- collabRecipRemoteActor <$> getJust recipID
|
||||
actor <- getJust remoteActorID
|
||||
(,remoteActorFollowers actor) <$> getRemoteActorURI actor
|
||||
return (collabID, Right fulfillsID, Right joiner)
|
||||
|
||||
prepareCollabGrant isInvite sender role = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
||||
audAccepter <- makeAudSenderWithFollowers authorIdMsig
|
||||
audApprover <- lift $ makeAudSenderOnly authorIdMsig
|
||||
recipHash <- encodeKeyHashid groupID
|
||||
let topicByHash = LocalActorGroup recipHash
|
||||
|
||||
senderHash <- bitraverse hashLocalActor pure sender
|
||||
|
||||
uAccepter <- lift $ getActorURI authorIdMsig
|
||||
|
||||
let audience =
|
||||
if isInvite
|
||||
then
|
||||
let audInviter =
|
||||
case senderHash of
|
||||
Left actor -> AudLocal [actor] []
|
||||
Right (ObjURI h lu, _followers) ->
|
||||
AudRemote h [lu] []
|
||||
audTopic = AudLocal [] [localActorFollowers topicByHash]
|
||||
in [audInviter, audAccepter, audTopic]
|
||||
else
|
||||
let audJoiner =
|
||||
case senderHash of
|
||||
Left actor -> AudLocal [actor] [localActorFollowers actor]
|
||||
Right (ObjURI h lu, followers) ->
|
||||
AudRemote h [lu] (maybeToList followers)
|
||||
audTopic = AudLocal [] [localActorFollowers topicByHash]
|
||||
in [audJoiner, audApprover, audTopic]
|
||||
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience audience
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
action = AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = [AP.acceptObject accept]
|
||||
, AP.actionSpecific = AP.GrantActivity AP.Grant
|
||||
{ AP.grantObject = AP.RXRole role
|
||||
, AP.grantContext =
|
||||
encodeRouteHome $ renderLocalActor topicByHash
|
||||
, AP.grantTarget =
|
||||
if isInvite
|
||||
then uAccepter
|
||||
else case senderHash of
|
||||
Left actor ->
|
||||
encodeRouteHome $ renderLocalActor actor
|
||||
Right (ObjURI h lu, _) -> ObjURI h lu
|
||||
, AP.grantResult = Nothing
|
||||
, AP.grantStart = Just now
|
||||
, AP.grantEnd = Nothing
|
||||
, AP.grantAllows = AP.Invoke
|
||||
, AP.grantDelegates = Nothing
|
||||
}
|
||||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
-- Meaning: Someone has created a group with my ID URI
|
||||
-- Behavior:
|
||||
-- * Verify I'm in a just-been-created state
|
||||
|
|
@ -143,6 +429,426 @@ groupFollow now recipGroupID verse follow = do
|
|||
(\ _ -> pure [])
|
||||
now recipGroupID verse follow
|
||||
|
||||
-- Meaning: An actor is granting access-to-some-resource to another actor
|
||||
-- Behavior:
|
||||
-- * Option 1 - Collaborator sending me a delegator-Grant - Verify that:
|
||||
-- * The sender is a collaborator of mine, A
|
||||
-- * The Grant's context is A
|
||||
-- * The Grant's target is me
|
||||
-- * The Grant's usage is invoke & role is delegate
|
||||
-- * The Grant doesn't specify 'delegates'
|
||||
-- * The activity is authorized via a valid direct-Grant I had sent
|
||||
-- to A
|
||||
-- * Verify I don't yet have a delegator-Grant from A
|
||||
-- * Insert the Grant to my inbox
|
||||
-- * Record the delegator-Grant in the Collab record in DB
|
||||
-- * Forward the Grant to my followers
|
||||
--
|
||||
-- * If not 1, raise an error
|
||||
groupGrant
|
||||
:: UTCTime
|
||||
-> GroupId
|
||||
-> Verse
|
||||
-> AP.Grant URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
groupGrant now groupID (Verse authorIdMsig body) grant = do
|
||||
|
||||
-- Check capability
|
||||
capability <- do
|
||||
|
||||
-- Verify that a capability is provided
|
||||
uCap <- do
|
||||
let muCap = AP.activityCapability $ actbActivity body
|
||||
fromMaybeE muCap "No capability provided"
|
||||
|
||||
-- Verify the capability URI is one of:
|
||||
-- * Outbox item URI of a local actor, i.e. a local activity
|
||||
-- * A remote URI
|
||||
cap <- nameExceptT "Invite capability" $ parseActivityURI' uCap
|
||||
|
||||
-- Verify the capability is local
|
||||
case cap of
|
||||
Left (actorByKey, _, outboxItemID) ->
|
||||
return (actorByKey, outboxItemID)
|
||||
_ -> throwE "Capability is remote i.e. definitely not by me"
|
||||
|
||||
-- Check grant
|
||||
collab <- checkDelegator grant
|
||||
|
||||
handleCollab capability collab
|
||||
|
||||
where
|
||||
|
||||
checkDelegator g = do
|
||||
(role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <-
|
||||
parseGrant' g
|
||||
case role of
|
||||
AP.RXRole _ -> throwE "Role isn't delegator"
|
||||
AP.RXDelegator -> pure ()
|
||||
collab <-
|
||||
bitraverse
|
||||
(\case
|
||||
LocalActorPerson p -> pure p
|
||||
_ -> throwE "Local resource isn't a Person, therefore not a collaborator of mine"
|
||||
)
|
||||
pure
|
||||
resource
|
||||
case (collab, authorIdMsig) of
|
||||
(Left c, Left (a, _, _)) | LocalActorPerson c == a -> pure ()
|
||||
(Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure ()
|
||||
_ -> throwE "Author and context aren't the same actor"
|
||||
case recipient of
|
||||
Left (LocalActorGroup g) | g == groupID -> pure ()
|
||||
_ -> throwE "Target isn't me"
|
||||
for_ mstart $ \ start ->
|
||||
unless (start < now) $ throwE "Start time is in the future"
|
||||
for_ mend $ \ _ ->
|
||||
throwE "End time is specified"
|
||||
unless (usage == AP.Invoke) $
|
||||
throwE "Usage isn't Invoke"
|
||||
for_ mdeleg $ \ _ ->
|
||||
throwE "'delegates' is specified"
|
||||
return collab
|
||||
|
||||
handleCollab capability collab = do
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(recipActorID, recipActor) <- lift $ do
|
||||
recip <- getJust groupID
|
||||
let actorID = groupActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
|
||||
-- Find the Collab record from the capability
|
||||
Entity enableID (CollabEnable collabID _) <- do
|
||||
unless (fst capability == LocalActorGroup groupID) $
|
||||
throwE "Capability isn't mine"
|
||||
m <- lift $ getBy $ UniqueCollabEnableGrant $ snd capability
|
||||
fromMaybeE m "I don't have a Collab with this capability"
|
||||
Collab role <- lift $ getJust collabID
|
||||
topic <- lift $ getCollabTopic collabID
|
||||
unless (topic == LocalActorGroup groupID) $
|
||||
throwE "Found a Collab for this direct-Grant but it's not mine"
|
||||
recip <- lift $ getCollabRecip collabID
|
||||
recipForCheck <-
|
||||
lift $
|
||||
bitraverse
|
||||
(pure . collabRecipLocalPerson . entityVal)
|
||||
(getRemoteActorURI <=< getJust . collabRecipRemoteActor . entityVal)
|
||||
recip
|
||||
unless (recipForCheck == collab) $
|
||||
throwE "Capability's collaborator and Grant author aren't the same actor"
|
||||
|
||||
-- Verify I don't yet have a delegator-Grant from the collaborator
|
||||
maybeDeleg <-
|
||||
lift $ case bimap entityKey entityKey recip of
|
||||
Left localID -> (() <$) <$> getBy (UniqueCollabDelegLocalRecip localID)
|
||||
Right remoteID -> (() <$) <$> getBy (UniqueCollabDelegRemoteRecip remoteID)
|
||||
verifyNothingE maybeDeleg "I already have a delegator-Grant from this collaborator"
|
||||
|
||||
maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False
|
||||
for maybeGrantDB $ \ grantDB -> do
|
||||
|
||||
-- Record the delegator-Grant in the Collab record
|
||||
lift $ case (grantDB, bimap entityKey entityKey recip) of
|
||||
(Left (grantActor, _, grantID), Left localID) ->
|
||||
insert_ $ CollabDelegLocal enableID localID grantID
|
||||
(Right (_, _, grantID), Right remoteID) ->
|
||||
insert_ $ CollabDelegRemote enableID remoteID grantID
|
||||
_ -> error "groupGrant impossible 2"
|
||||
|
||||
-- Prepare forwarding of Accept to my followers
|
||||
groupHash <- encodeKeyHashid groupID
|
||||
let sieve = makeRecipientSet [] [LocalStageGroupFollowers groupHash]
|
||||
|
||||
-- For each parent group of mine, prepare a
|
||||
-- delegation-extension Grant
|
||||
extensions <- lift $ pure []
|
||||
|
||||
return (recipActorID, sieve, extensions)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (recipActorID, sieve, extensions) -> do
|
||||
let recipByID = LocalActorGroup groupID
|
||||
forwardActivity authorIdMsig body recipByID recipActorID sieve
|
||||
lift $ for_ extensions $
|
||||
\ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) ->
|
||||
sendActivity
|
||||
recipByID recipActorID localRecipsExt
|
||||
remoteRecipsExt fwdHostsExt extID actionExt
|
||||
done "Forwarded the delegator-Grant, updated DB"
|
||||
|
||||
-- Meaning: An actor A invited actor B to a resource
|
||||
-- Behavior:
|
||||
-- * Verify the resource is my collabs list
|
||||
-- * If resource is collabs and B is local, verify it's a Person
|
||||
-- * Verify A isn't inviting themselves
|
||||
-- * Verify A is authorized by me to invite collabs to me
|
||||
--
|
||||
-- * Verify B doesn't already have an invite/join/grant for me
|
||||
--
|
||||
-- * Insert the Invite to my inbox
|
||||
--
|
||||
-- * Insert a Collab record to DB
|
||||
--
|
||||
-- * Forward the Invite to my followers
|
||||
-- * Send Accept to A, B, my-followers
|
||||
groupInvite
|
||||
:: UTCTime
|
||||
-> GroupId
|
||||
-> Verse
|
||||
-> AP.Invite URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
groupInvite now groupID (Verse authorIdMsig body) invite = do
|
||||
|
||||
-- Check capability
|
||||
capability <- do
|
||||
|
||||
-- Verify that a capability is provided
|
||||
uCap <- do
|
||||
let muCap = AP.activityCapability $ actbActivity body
|
||||
fromMaybeE muCap "No capability provided"
|
||||
|
||||
-- Verify the capability URI is one of:
|
||||
-- * Outbox item URI of a local actor, i.e. a local activity
|
||||
-- * A remote URI
|
||||
cap <- nameExceptT "Invite capability" $ parseActivityURI' uCap
|
||||
|
||||
-- Verify the capability is local
|
||||
case cap of
|
||||
Left (actorByKey, _, outboxItemID) ->
|
||||
return (actorByKey, outboxItemID)
|
||||
_ -> throwE "Capability is remote i.e. definitely not by me"
|
||||
|
||||
-- Check invite
|
||||
(role, invited) <- do
|
||||
let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
|
||||
(role, resourceOrComps, recipientOrComp) <- parseInvite author invite
|
||||
mode <-
|
||||
case resourceOrComps of
|
||||
Left (Left (LocalActorGroup j)) | j == groupID ->
|
||||
bitraverse
|
||||
(\case
|
||||
Left r -> pure r
|
||||
Right _ -> throwE "Not accepting local component actors as collabs"
|
||||
)
|
||||
pure
|
||||
recipientOrComp
|
||||
_ -> throwE "Invite topic isn't my collabs URI"
|
||||
return (role, mode)
|
||||
|
||||
-- If target is local, find it in our DB
|
||||
-- If target is remote, HTTP GET it, verify it's an actor, and store in
|
||||
-- our DB (if it's already there, no need for HTTP)
|
||||
--
|
||||
-- NOTE: This is a blocking HTTP GET done right here in the Invite handler,
|
||||
-- which is NOT a good idea. Ideally, it would be done async, and the
|
||||
-- handler result (approve/disapprove the Invite) would be sent later in a
|
||||
-- separate (e.g. Accept) activity. But for the PoC level, the current
|
||||
-- situation will hopefully do.
|
||||
invitedDB <-
|
||||
bitraverse
|
||||
(withDBExcept . flip getGrantRecip "Invitee not found in DB")
|
||||
getRemoteActorFromURI
|
||||
invited
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(topicActorID, topicActor) <- lift $ do
|
||||
recip <- getJust groupID
|
||||
let actorID = groupActor recip
|
||||
(actorID,) <$> getJust actorID
|
||||
|
||||
-- Verify the specified capability gives relevant access
|
||||
verifyCapability'
|
||||
capability authorIdMsig (LocalActorGroup groupID) AP.RoleAdmin
|
||||
|
||||
-- Verify that target doesn't already have a Collab for me
|
||||
existingCollabIDs <- lift $ getExistingCollabs invitedDB
|
||||
case existingCollabIDs of
|
||||
[] -> pure ()
|
||||
[_] -> throwE "I already have a Collab for the target"
|
||||
_ -> error "Multiple collabs found for target"
|
||||
|
||||
maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
|
||||
lift $ for maybeInviteDB $ \ inviteDB -> do
|
||||
|
||||
-- Insert Collab or Component record to DB
|
||||
acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
|
||||
insertCollab role invitedDB inviteDB acceptID
|
||||
|
||||
-- Prepare forwarding Invite to my followers
|
||||
sieve <- do
|
||||
groupHash <- encodeKeyHashid groupID
|
||||
return $ makeRecipientSet [] [LocalStageGroupFollowers groupHash]
|
||||
|
||||
-- Prepare an Accept activity and insert to my outbox
|
||||
accept@(actionAccept, _, _, _) <- prepareAccept invitedDB
|
||||
_luAccept <- updateOutboxItem' (LocalActorGroup groupID) acceptID actionAccept
|
||||
|
||||
return (topicActorID, sieve, acceptID, accept)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (groupActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
|
||||
forwardActivity
|
||||
authorIdMsig body (LocalActorGroup groupID) groupActorID sieve
|
||||
lift $ sendActivity
|
||||
(LocalActorGroup groupID) groupActorID localRecipsAccept
|
||||
remoteRecipsAccept fwdHostsAccept acceptID actionAccept
|
||||
done "Recorded and forwarded the Invite, sent an Accept"
|
||||
|
||||
where
|
||||
|
||||
getRemoteActorFromURI (ObjURI h lu) = do
|
||||
instanceID <-
|
||||
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
|
||||
result <-
|
||||
ExceptT $ first (T.pack . displayException) <$>
|
||||
fetchRemoteActor' instanceID h lu
|
||||
case result of
|
||||
Left Nothing -> throwE "Target @id mismatch"
|
||||
Left (Just err) -> throwE $ T.pack $ displayException err
|
||||
Right Nothing -> throwE "Target isn't an actor"
|
||||
Right (Just actor) -> return $ entityKey actor
|
||||
|
||||
getExistingCollabs (Left (GrantRecipPerson (Entity personID _))) =
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do
|
||||
E.on $
|
||||
topic E.^. CollabTopicGroupCollab E.==.
|
||||
recipl E.^. CollabRecipLocalCollab
|
||||
E.where_ $
|
||||
topic E.^. CollabTopicGroupGroup E.==. E.val groupID E.&&.
|
||||
recipl E.^. CollabRecipLocalPerson E.==. E.val personID
|
||||
return $ recipl E.^. CollabRecipLocalCollab
|
||||
getExistingCollabs (Right remoteActorID) =
|
||||
E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do
|
||||
E.on $
|
||||
topic E.^. CollabTopicGroupCollab E.==.
|
||||
recipr E.^. CollabRecipRemoteCollab
|
||||
E.where_ $
|
||||
topic E.^. CollabTopicGroupGroup E.==. E.val groupID E.&&.
|
||||
recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID
|
||||
return $ recipr E.^. CollabRecipRemoteCollab
|
||||
|
||||
insertCollab role recipient inviteDB acceptID = do
|
||||
collabID <- insert $ Collab role
|
||||
fulfillsID <- insert $ CollabFulfillsInvite collabID acceptID
|
||||
insert_ $ CollabTopicGroup collabID groupID
|
||||
case inviteDB of
|
||||
Left (_, _, inviteID) ->
|
||||
insert_ $ CollabInviterLocal fulfillsID inviteID
|
||||
Right (author, _, inviteID) -> do
|
||||
let authorID = remoteAuthorId author
|
||||
insert_ $ CollabInviterRemote fulfillsID authorID inviteID
|
||||
case recipient of
|
||||
Left (GrantRecipPerson (Entity personID _)) ->
|
||||
insert_ $ CollabRecipLocal collabID personID
|
||||
Right remoteActorID ->
|
||||
insert_ $ CollabRecipRemote collabID remoteActorID
|
||||
|
||||
prepareAccept invitedDB = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
audInviter <- lift $ makeAudSenderOnly authorIdMsig
|
||||
audInvited <-
|
||||
case invitedDB of
|
||||
Left (GrantRecipPerson (Entity p _)) -> do
|
||||
ph <- encodeKeyHashid p
|
||||
return $ AudLocal [LocalActorPerson ph] []
|
||||
Right remoteActorID -> do
|
||||
ra <- getJust remoteActorID
|
||||
ObjURI h lu <- getRemoteActorURI ra
|
||||
return $ AudRemote h [lu] []
|
||||
audTopic <-
|
||||
AudLocal [] . pure . LocalStageGroupFollowers <$>
|
||||
encodeKeyHashid groupID
|
||||
uInvite <- lift $ getActivityURI authorIdMsig
|
||||
|
||||
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audInviter, audInvited, audTopic]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
action = AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = [uInvite]
|
||||
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||
{ AP.acceptObject = uInvite
|
||||
, AP.acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
-- Meaning: An actor A asked to join a resource
|
||||
-- Behavior:
|
||||
-- * Verify the resource is me
|
||||
-- * Verify A doesn't already have an invite/join/grant for me
|
||||
-- * Remember the join in DB
|
||||
-- * Forward the Join to my followers
|
||||
groupJoin
|
||||
:: UTCTime
|
||||
-> GroupId
|
||||
-> Verse
|
||||
-> AP.Join URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
groupJoin =
|
||||
topicJoin
|
||||
groupActor LocalActorGroup
|
||||
CollabTopicGroupGroup CollabTopicGroupCollab CollabTopicGroup
|
||||
|
||||
-- Meaning: An actor rejected something
|
||||
-- Behavior:
|
||||
-- * If it's on an Invite where I'm the resource:
|
||||
-- * Verify the Reject is by the Invite target
|
||||
-- * Remove the relevant Collab record from DB
|
||||
-- * Forward the Reject to my followers
|
||||
-- * Send a Reject on the Invite:
|
||||
-- * To: Rejecter (i.e. Invite target)
|
||||
-- * CC: Invite sender, Rejecter's followers, my followers
|
||||
-- * If it's on a Join where I'm the resource:
|
||||
-- * Verify the Reject is authorized
|
||||
-- * Remove the relevant Collab record from DB
|
||||
-- * Forward the Reject to my followers
|
||||
-- * Send a Reject:
|
||||
-- * To: Join sender
|
||||
-- * CC: Reject sender, Join sender's followers, my followers
|
||||
-- * Otherwise respond with error
|
||||
groupReject
|
||||
:: UTCTime
|
||||
-> GroupId
|
||||
-> Verse
|
||||
-> AP.Reject URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
groupReject = topicReject groupActor LocalActorGroup
|
||||
|
||||
-- Meaning: An actor A is removing actor B from a resource
|
||||
-- Behavior:
|
||||
-- * Verify the resource is me
|
||||
-- * Verify A isn't removing themselves
|
||||
-- * Verify A is authorized by me to remove actors from me
|
||||
-- * Verify B already has a Grant for me
|
||||
-- * Remove the whole Collab record from DB
|
||||
-- * Forward the Remove to my followers
|
||||
-- * Send a Revoke:
|
||||
-- * To: Actor B
|
||||
-- * CC: Actor A, B's followers, my followers
|
||||
groupRemove
|
||||
:: UTCTime
|
||||
-> GroupId
|
||||
-> Verse
|
||||
-> AP.Remove URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
groupRemove =
|
||||
topicRemove
|
||||
groupActor LocalActorGroup
|
||||
CollabTopicGroupGroup CollabTopicGroupCollab
|
||||
|
||||
-- Meaning: An actor is undoing some previous action
|
||||
-- Behavior:
|
||||
-- * If they're undoing their Following of me:
|
||||
|
|
@ -269,8 +975,14 @@ groupUndo now recipGroupID (Verse authorIdMsig body) (AP.Undo uObject) = do
|
|||
groupBehavior :: UTCTime -> GroupId -> VerseExt -> ActE (Text, Act (), Next)
|
||||
groupBehavior now groupID (Left verse@(Verse _authorIdMsig body)) =
|
||||
case AP.activitySpecific $ actbActivity body of
|
||||
AP.AcceptActivity accept -> groupAccept now groupID verse accept
|
||||
AP.CreateActivity create -> groupCreate now groupID verse create
|
||||
AP.FollowActivity follow -> groupFollow now groupID verse follow
|
||||
AP.GrantActivity grant -> groupGrant now groupID verse grant
|
||||
AP.InviteActivity invite -> groupInvite now groupID verse invite
|
||||
AP.JoinActivity join -> groupJoin now groupID verse join
|
||||
AP.RejectActivity reject -> groupReject now groupID verse reject
|
||||
AP.RemoveActivity remove -> groupRemove now groupID verse remove
|
||||
AP.UndoActivity undo -> groupUndo now groupID verse undo
|
||||
_ -> throwE "Unsupported activity type for Group"
|
||||
groupBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Group"
|
||||
|
|
|
|||
|
|
@ -28,6 +28,7 @@ import Control.Monad.Trans.Except
|
|||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Barbie
|
||||
import Data.Bifoldable
|
||||
import Data.Bifunctor
|
||||
import Data.Bitraversable
|
||||
import Data.ByteString (ByteString)
|
||||
|
|
@ -843,7 +844,7 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
|
|||
(role, resource, recip, _mresult, mstart, mend, usage, mdeleg) <-
|
||||
parseGrant' grant
|
||||
case (recip, authorIdMsig) of
|
||||
(Left (GrantRecipPerson' p), Left (LocalActorPerson p', _, _))
|
||||
(Left (LocalActorPerson p), Left (LocalActorPerson p', _, _))
|
||||
| p == p' ->
|
||||
throwE "Grant sender and target are the same local Person"
|
||||
(Right uRecip, Right (author, _, _))
|
||||
|
|
@ -863,7 +864,7 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
|
|||
-- For an extension-Grant, use 'capability' for that
|
||||
runMaybeT $ do
|
||||
guard $ usage == AP.Invoke
|
||||
guard $ recip == Left (GrantRecipPerson' recipPersonID)
|
||||
guard $ recip == Left (LocalActorPerson recipPersonID)
|
||||
lift $ do
|
||||
for_ mstart $ \ start ->
|
||||
unless (start <= now) $
|
||||
|
|
@ -1105,27 +1106,162 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do
|
|||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
-- Meaning: An actor has revoked some previously published Grants
|
||||
-- Behavior: Insert to my inbox
|
||||
-- Behavior:
|
||||
-- * Insert to my inbox
|
||||
-- * For each revoked activity:
|
||||
-- * If it's a direct-Grant given to me:
|
||||
-- * Verify the sender is the Permit topic
|
||||
-- * Delete the Permit record
|
||||
-- * If it's an extension-Grant given to me:
|
||||
-- * Verify the sender is the Permit topic
|
||||
-- * Delete the PermitTopicExtend* record
|
||||
personRevoke
|
||||
:: UTCTime
|
||||
-> PersonId
|
||||
-> Verse
|
||||
-> AP.Revoke URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke _lus) = do
|
||||
personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke lus) = do
|
||||
|
||||
maybeRevoke <- lift $ withDB $ do
|
||||
-- Check input
|
||||
grants <- nameExceptT "Revoke.object" $ do
|
||||
ObjURI h _ <- lift $ getActorURI authorIdMsig
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then
|
||||
for lus $ \ lu ->
|
||||
(\ (actor, _, item) -> Left (actor, item)) <$>
|
||||
parseLocalActivityURI' lu
|
||||
else
|
||||
pure $ Right . ObjURI h <$> lus
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(_personRecip, actorRecip) <- do
|
||||
(personRecip, actorRecip) <- lift $ do
|
||||
p <- getJust recipPersonID
|
||||
(p,) <$> getJust (personActor p)
|
||||
|
||||
insertToInbox now authorIdMsig body (actorInbox actorRecip) True
|
||||
-- Look for the revoked Grants in my Permit records
|
||||
grantsDB <- for grants $ \ grant -> runMaybeT $ do
|
||||
grantDB <- MaybeT $ getActivity grant
|
||||
found <-
|
||||
Left <$> tryDirect grantDB <|>
|
||||
Right <$> tryExtension grantDB
|
||||
bitraverse
|
||||
(\ (gestureID, topicAndEnable) -> do
|
||||
|
||||
case maybeRevoke of
|
||||
-- Verify the Permit is mine
|
||||
PermitPersonGesture permitID _ <- lift . lift $ getJust gestureID
|
||||
Permit p _ <- lift . lift $ getJust permitID
|
||||
guard $ p == recipPersonID
|
||||
|
||||
-- Verify the Revoke sender is the Permit topic
|
||||
lift $ do
|
||||
topic <- lift $ getPermitTopic permitID
|
||||
case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of
|
||||
(Left la, Left la') | la == la' -> pure ()
|
||||
(Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
|
||||
_ -> throwE "Revoke sender isn't the Permit topic"
|
||||
|
||||
-- Return data for Permit deletion
|
||||
return (permitID, gestureID, topicAndEnable)
|
||||
)
|
||||
(\ extend -> do
|
||||
|
||||
-- Verify the Permit is mine
|
||||
sendID <-
|
||||
lift . lift $ case extend of
|
||||
Left k -> permitTopicExtendLocalPermit <$> getJust k
|
||||
Right k -> permitTopicExtendRemotePermit <$> getJust k
|
||||
PermitPersonSendDelegator gestureID _ <- lift . lift $ getJust sendID
|
||||
PermitPersonGesture permitID _ <- lift . lift $ getJust gestureID
|
||||
Permit p _ <- lift . lift $ getJust permitID
|
||||
guard $ p == recipPersonID
|
||||
|
||||
-- Verify the Revoke sender is the Permit topic
|
||||
lift $ do
|
||||
topic <- lift $ getPermitTopic permitID
|
||||
case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of
|
||||
(Left la, Left la') | la == la' -> pure ()
|
||||
(Right raID, Right ra) | raID == remoteAuthorId ra -> pure ()
|
||||
_ -> throwE "Revoke sender isn't the Permit topic"
|
||||
|
||||
-- Return data for PermitTopicExtend* deletion
|
||||
return extend
|
||||
)
|
||||
found
|
||||
|
||||
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
|
||||
lift $ for mractid $ \ _revokeDB ->
|
||||
-- Delete revoked records from DB
|
||||
for grantsDB $ traverse_ $
|
||||
bitraverse_
|
||||
(\ (permitID, gestureID, topicAndEnable) -> do
|
||||
case topicAndEnable of
|
||||
Left (_, enableID) ->
|
||||
deleteWhere [PermitTopicExtendLocalTopic ==. enableID]
|
||||
Right (_, enableID) ->
|
||||
deleteWhere [PermitTopicExtendRemoteTopic ==. enableID]
|
||||
deleteBy $ UniquePermitPersonSendDelegator gestureID
|
||||
case topicAndEnable of
|
||||
Left (topicID, enableID) -> do
|
||||
delete enableID
|
||||
deleteBy $ UniquePermitTopicAcceptLocalTopic topicID
|
||||
Right (topicID, enableID) -> do
|
||||
delete enableID
|
||||
deleteBy $ UniquePermitTopicAcceptRemoteTopic topicID
|
||||
maybeInvite <- getKeyBy $ UniquePermitFulfillsInvite permitID
|
||||
for_ maybeInvite $ \ inviteID -> do
|
||||
deleteBy $ UniquePermitTopicGestureLocal inviteID
|
||||
deleteBy $ UniquePermitTopicGestureRemote inviteID
|
||||
delete gestureID
|
||||
deleteBy $ UniquePermitFulfillsTopicCreation permitID
|
||||
deleteBy $ UniquePermitFulfillsInvite permitID
|
||||
deleteBy $ UniquePermitFulfillsJoin permitID
|
||||
case topicAndEnable of
|
||||
Left (topicID, _) -> do
|
||||
deleteBy $ UniquePermitTopicRepo topicID
|
||||
deleteBy $ UniquePermitTopicDeck topicID
|
||||
deleteBy $ UniquePermitTopicLoom topicID
|
||||
deleteBy $ UniquePermitTopicProject topicID
|
||||
deleteBy $ UniquePermitTopicGroup topicID
|
||||
delete topicID
|
||||
Right (topicID, _) -> delete topicID
|
||||
delete permitID
|
||||
)
|
||||
(\case
|
||||
Left k -> delete k
|
||||
Right k -> delete k
|
||||
)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just _revokeDB -> done "Inserted to my inbox"
|
||||
Just _ -> done "Deleted any relevant Permit/Extend records"
|
||||
|
||||
where
|
||||
|
||||
tryDirect objectDB =
|
||||
case objectDB of
|
||||
Left (_actorByKey, _actorEntity, itemID) -> do
|
||||
Entity enableID (PermitTopicEnableLocal gestureID topicID _) <-
|
||||
MaybeT $ lift $ getBy $ UniquePermitTopicEnableLocalGrant itemID
|
||||
return (gestureID, Left (topicID, enableID))
|
||||
Right remoteActivityID -> do
|
||||
Entity enableID (PermitTopicEnableRemote gestureID topicID _) <-
|
||||
MaybeT $ lift $ getBy $ UniquePermitTopicEnableRemoteGrant remoteActivityID
|
||||
return (gestureID, Right (topicID, enableID))
|
||||
|
||||
tryExtension objectDB =
|
||||
case objectDB of
|
||||
Left (_actorByKey, _actorEntity, itemID) -> do
|
||||
Entity extendID (PermitTopicExtendLocal _ _ _) <-
|
||||
MaybeT $ lift $ getBy $ UniquePermitTopicExtendLocalGrant itemID
|
||||
return $ Left extendID
|
||||
Right remoteActivityID -> do
|
||||
Entity extendID (PermitTopicExtendRemote _ _ _) <-
|
||||
MaybeT $ lift $ getBy $ UniquePermitTopicExtendRemoteGrant remoteActivityID
|
||||
return $ Right extendID
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Main behavior function
|
||||
|
|
|
|||
|
|
@ -360,6 +360,7 @@ clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts a
|
|||
-- Meaning: The human wants to create a ticket tracker
|
||||
-- Behavior:
|
||||
-- * Create a deck on DB
|
||||
-- * Create a Permit record in DB
|
||||
-- * Launch a deck actor
|
||||
-- * Record a FollowRequest in DB
|
||||
-- * Create and send Create and Follow to it
|
||||
|
|
@ -389,6 +390,14 @@ clientCreateDeck now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd
|
|||
(deckID, deckFollowerSetID) <-
|
||||
lift $ insertDeck now name msummary createID wid actorMeID
|
||||
|
||||
-- Insert a Permit record
|
||||
lift $ do
|
||||
permitID <- insert $ Permit personMeID AP.RoleAdmin
|
||||
topicID <- insert $ PermitTopicLocal permitID
|
||||
insert_ $ PermitTopicDeck topicID deckID
|
||||
insert_ $ PermitFulfillsTopicCreation permitID
|
||||
insert_ $ PermitPersonGesture permitID createID
|
||||
|
||||
-- Insert the Create activity to my outbox
|
||||
deckHash <- encodeKeyHashid deckID
|
||||
actionCreate <- prepareCreate name msummary deckHash
|
||||
|
|
@ -525,6 +534,7 @@ clientCreateDeck now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd
|
|||
-- Meaning: The human wants to create a project
|
||||
-- Behavior:
|
||||
-- * Create a project on DB
|
||||
-- * Create a Permit record in DB
|
||||
-- * Launch a project actor
|
||||
-- * Record a FollowRequest in DB
|
||||
-- * Create and send Create and Follow to it
|
||||
|
|
@ -553,6 +563,13 @@ clientCreateProject now personMeID (ClientMsg maybeCap localRecips remoteRecips
|
|||
(projectID, projectFollowerSetID) <-
|
||||
insertProject now name msummary createID actorMeID
|
||||
|
||||
-- Insert a Permit record
|
||||
permitID <- insert $ Permit personMeID AP.RoleAdmin
|
||||
topicID <- insert $ PermitTopicLocal permitID
|
||||
insert_ $ PermitTopicProject topicID projectID
|
||||
insert_ $ PermitFulfillsTopicCreation permitID
|
||||
insert_ $ PermitPersonGesture permitID createID
|
||||
|
||||
-- Insert the Create activity to my outbox
|
||||
projectHash <- lift $ encodeKeyHashid projectID
|
||||
actionCreate <- lift $ prepareCreate name msummary projectHash
|
||||
|
|
@ -682,6 +699,7 @@ clientCreateProject now personMeID (ClientMsg maybeCap localRecips remoteRecips
|
|||
-- Meaning: The human wants to create a team
|
||||
-- Behavior:
|
||||
-- * Create a team on DB
|
||||
-- * Create a Permit record in DB
|
||||
-- * Launch a team actor
|
||||
-- * Record a FollowRequest in DB
|
||||
-- * Create and send Create and Follow to it
|
||||
|
|
@ -710,6 +728,13 @@ clientCreateTeam now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd
|
|||
(groupID, projectFollowerSetID) <-
|
||||
insertTeam now name msummary createID actorMeID
|
||||
|
||||
-- Insert a Permit record
|
||||
permitID <- insert $ Permit personMeID AP.RoleAdmin
|
||||
topicID <- insert $ PermitTopicLocal permitID
|
||||
insert_ $ PermitTopicGroup topicID groupID
|
||||
insert_ $ PermitFulfillsTopicCreation permitID
|
||||
insert_ $ PermitPersonGesture permitID createID
|
||||
|
||||
-- Insert the Create activity to my outbox
|
||||
groupHash <- lift $ encodeKeyHashid groupID
|
||||
actionCreate <- lift $ prepareCreate name msummary groupHash
|
||||
|
|
|
|||
|
|
@ -295,7 +295,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do
|
|||
case (collab, acceptDB) of
|
||||
(Left (fulfillsID, Left recipID), Left (_, _, acceptID)) -> do
|
||||
maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID fulfillsID acceptID
|
||||
unless (isNothing maybeAccept) $
|
||||
unless (isJust maybeAccept) $
|
||||
throwE "This Invite already has an Accept by recip"
|
||||
(Left (fulfillsID, Right recipID), Right (_, _, acceptID)) -> do
|
||||
maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID fulfillsID acceptID
|
||||
|
|
@ -978,7 +978,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
(Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure ()
|
||||
_ -> throwE "Author and context aren't the same actor"
|
||||
case recipient of
|
||||
Left (GrantRecipProject' j) | j == projectID -> pure ()
|
||||
Left (LocalActorProject j) | j == projectID -> pure ()
|
||||
_ -> throwE "Target isn't me"
|
||||
for_ mstart $ \ start ->
|
||||
unless (start < now) $ throwE "Start time is in the future"
|
||||
|
|
@ -1009,7 +1009,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
|
|||
(Right u, Right (ra, _, _)) | remoteAuthorURI ra == u -> pure ()
|
||||
_ -> throwE "Author and context aren't the same actor"
|
||||
case recipient of
|
||||
Left (GrantRecipProject' j) | j == projectID -> pure ()
|
||||
Left (LocalActorProject j) | j == projectID -> pure ()
|
||||
_ -> throwE "Target isn't me"
|
||||
for_ mstart $ \ start ->
|
||||
unless (start < now) $ throwE "Start time is in the future"
|
||||
|
|
|
|||
|
|
@ -43,6 +43,7 @@ module Vervis.Client
|
|||
, remove
|
||||
, inviteComponent
|
||||
, acceptProjectInvite
|
||||
, acceptPersonalInvite
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -1410,3 +1411,44 @@ acceptProjectInvite personID component project uInvite = do
|
|||
audience = [audComp, audProject, audAuthor]
|
||||
|
||||
return (Nothing, audience, activity)
|
||||
|
||||
acceptPersonalInvite
|
||||
:: PersonId
|
||||
-> Either (LocalActorBy Key) RemoteActorId
|
||||
-> FedURI
|
||||
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Accept URIMode)
|
||||
acceptPersonalInvite personID resource uInvite = do
|
||||
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
resource' <- bitraverse VR.hashLocalActor pure resource
|
||||
|
||||
let activity = AP.Accept uInvite Nothing
|
||||
|
||||
-- If resource is remote, get it from DB to determine its followers
|
||||
-- collection
|
||||
resourceDB <-
|
||||
bitraverse
|
||||
pure
|
||||
(\ remoteActorID -> lift $ runDB $ do
|
||||
ra <- getJust remoteActorID
|
||||
u <- getRemoteActorURI ra
|
||||
return (ra, u)
|
||||
)
|
||||
resource'
|
||||
|
||||
senderHash <- encodeKeyHashid personID
|
||||
|
||||
let audResource =
|
||||
case resourceDB of
|
||||
Left la ->
|
||||
AudLocal [la] [localActorFollowers la]
|
||||
Right (remoteActor, ObjURI h lu) ->
|
||||
AudRemote h
|
||||
[lu]
|
||||
(maybeToList $ remoteActorFollowers remoteActor)
|
||||
audAuthor =
|
||||
AudLocal [] [LocalStagePersonFollowers senderHash]
|
||||
|
||||
audience = [audResource, audAuthor]
|
||||
|
||||
return (Nothing, audience, activity)
|
||||
|
|
|
|||
|
|
@ -39,9 +39,6 @@ module Vervis.Data.Collab
|
|||
, unhashComponentE
|
||||
, componentActor
|
||||
, actorToComponent
|
||||
|
||||
, GrantRecipBy' (..)
|
||||
, hashGrantRecip'
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -301,7 +298,7 @@ parseGrant'
|
|||
-> ActE
|
||||
( AP.RoleExt
|
||||
, Either (LocalActorBy Key) FedURI
|
||||
, Either (GrantRecipBy' Key) FedURI
|
||||
, Either (LocalActorBy Key) FedURI
|
||||
, Maybe (LocalURI, Maybe Int)
|
||||
, Maybe UTCTime
|
||||
, Maybe UTCTime
|
||||
|
|
@ -333,7 +330,7 @@ parseGrant' (AP.Grant object context target mresult mstart mend allows deleg) =
|
|||
"Grant context isn't a valid route"
|
||||
parseLocalActorE' route
|
||||
else pure $ Right u
|
||||
parseTarget u@(ObjURI h lu) = do
|
||||
parseTarget u@(ObjURI h lu) = nameExceptT "Grant target" $ do
|
||||
hl <- hostIsLocal h
|
||||
if hl
|
||||
then Left <$> do
|
||||
|
|
@ -341,13 +338,7 @@ parseGrant' (AP.Grant object context target mresult mstart mend allows deleg) =
|
|||
fromMaybeE
|
||||
(decodeRouteLocal lu)
|
||||
"Grant target isn't a valid route"
|
||||
recipHash <-
|
||||
fromMaybeE
|
||||
(parseGrantRecip' route)
|
||||
"Grant target isn't a grant recipient route"
|
||||
unhashGrantRecipE'
|
||||
recipHash
|
||||
"Grant target contains invalid hashid"
|
||||
parseLocalActorE' route
|
||||
else pure $ Right u
|
||||
|
||||
parseAccept (AP.Accept object mresult) = do
|
||||
|
|
@ -471,38 +462,3 @@ actorToComponent = \case
|
|||
LocalActorLoom k -> Just $ ComponentLoom k
|
||||
LocalActorProject _ -> Nothing
|
||||
LocalActorGroup _ -> Nothing
|
||||
|
||||
data GrantRecipBy' f
|
||||
= GrantRecipPerson' (f Person)
|
||||
| GrantRecipProject' (f Project)
|
||||
| GrantRecipComponent' (ComponentBy f)
|
||||
deriving (Generic, FunctorB, TraversableB, ConstraintsB)
|
||||
|
||||
deriving instance AllBF Eq f GrantRecipBy' => Eq (GrantRecipBy' f)
|
||||
|
||||
parseGrantRecip' (PersonR p) = Just $ GrantRecipPerson' p
|
||||
parseGrantRecip' (ProjectR j) = Just $ GrantRecipProject' j
|
||||
parseGrantRecip' r = GrantRecipComponent' <$> parseComponent r
|
||||
|
||||
hashGrantRecip' (GrantRecipPerson' k) =
|
||||
GrantRecipPerson' <$> WAP.encodeKeyHashid k
|
||||
hashGrantRecip' (GrantRecipProject' k) =
|
||||
GrantRecipProject' <$> WAP.encodeKeyHashid k
|
||||
hashGrantRecip' (GrantRecipComponent' byk) =
|
||||
GrantRecipComponent' <$> hashComponent byk
|
||||
|
||||
unhashGrantRecipPure' ctx = f
|
||||
where
|
||||
f (GrantRecipPerson' p) =
|
||||
GrantRecipPerson' <$> decodeKeyHashidPure ctx p
|
||||
f (GrantRecipProject' p) =
|
||||
GrantRecipProject' <$> decodeKeyHashidPure ctx p
|
||||
f (GrantRecipComponent' c) =
|
||||
GrantRecipComponent' <$> unhashComponentPure ctx c
|
||||
|
||||
unhashGrantRecip' resource = do
|
||||
ctx <- asksEnv WAP.stageHashidsContext
|
||||
return $ unhashGrantRecipPure' ctx resource
|
||||
|
||||
unhashGrantRecipE' resource e =
|
||||
ExceptT $ maybe (Left e) Right <$> unhashGrantRecip' resource
|
||||
|
|
|
|||
|
|
@ -1,150 +0,0 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
- The author(s) have dedicated all copyright and related and neighboring
|
||||
- rights to this software to the public domain worldwide. This software is
|
||||
- distributed without any warranty.
|
||||
-
|
||||
- You should have received a copy of the CC0 Public Domain Dedication along
|
||||
- with this software. If not, see
|
||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
|
||||
module Vervis.Federation.Collab
|
||||
( --personInviteF
|
||||
--topicInviteF
|
||||
|
||||
-- repoJoinF
|
||||
--, deckJoinF
|
||||
--, loomJoinF
|
||||
|
||||
--, repoAcceptF
|
||||
--, deckAcceptF
|
||||
--, loomAcceptF
|
||||
|
||||
--, personGrantF
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Exception hiding (Handler)
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Class
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Barbie
|
||||
import Data.Bifunctor
|
||||
import Data.Bitraversable
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Either
|
||||
import Data.Foldable
|
||||
import Data.Functor.Identity
|
||||
import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock
|
||||
import Data.Traversable
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
import Yesod.Persist.Core
|
||||
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Database.Persist.JSON
|
||||
import Development.PatchMediaType
|
||||
import Network.FedURI
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
import Yesod.MonadSite
|
||||
|
||||
import qualified Web.ActivityPub as AP
|
||||
|
||||
import Control.Monad.Trans.Except.Local
|
||||
import Data.Either.Local
|
||||
import Data.Tuple.Local
|
||||
import Database.Persist.Local
|
||||
import Yesod.Persist.Local
|
||||
|
||||
import Vervis.Access
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.Actor (RemoteAuthor (..), ActivityBody (..))
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.Data.Collab
|
||||
import Vervis.Web.Delivery
|
||||
import Vervis.FedURI
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Federation.Util
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Persist.Actor
|
||||
import Vervis.Persist.Collab
|
||||
import Vervis.Recipient
|
||||
import Vervis.RemoteActorStore
|
||||
|
||||
{-
|
||||
repoJoinF
|
||||
:: UTCTime
|
||||
-> KeyHashid Repo
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.Join URIMode
|
||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||
repoJoinF = topicJoinF repoActor GrantResourceRepo
|
||||
|
||||
deckJoinF
|
||||
:: UTCTime
|
||||
-> KeyHashid Deck
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.Join URIMode
|
||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||
deckJoinF = topicJoinF deckActor GrantResourceDeck
|
||||
|
||||
loomJoinF
|
||||
:: UTCTime
|
||||
-> KeyHashid Loom
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.Join URIMode
|
||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||
loomJoinF = topicJoinF loomActor GrantResourceLoom
|
||||
-}
|
||||
|
||||
{-
|
||||
repoAcceptF
|
||||
:: UTCTime
|
||||
-> KeyHashid Repo
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.Accept URIMode
|
||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||
repoAcceptF = topicAcceptF repoActor GrantResourceRepo
|
||||
|
||||
loomAcceptF
|
||||
:: UTCTime
|
||||
-> KeyHashid Loom
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.Accept URIMode
|
||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||
loomAcceptF = topicAcceptF loomActor GrantResourceLoom
|
||||
-}
|
||||
|
|
@ -27,6 +27,8 @@ module Vervis.Form.Tracker
|
|||
, ProjectInvite (..)
|
||||
, projectInviteForm
|
||||
, projectInviteCompForm
|
||||
, GroupInvite (..)
|
||||
, groupInviteForm
|
||||
--, NewProjectCollab (..)
|
||||
--, newProjectCollabForm
|
||||
--, editProjectForm
|
||||
|
|
@ -179,6 +181,38 @@ projectInviteForm projectID = renderDivs $ ProjectInvite
|
|||
projectInviteCompForm :: Form FedURI
|
||||
projectInviteCompForm = renderDivs $ areq fedUriField "Component URI*" Nothing
|
||||
|
||||
data GroupInvite = GroupInvite
|
||||
{ giPerson :: PersonId
|
||||
, giRole :: AP.Role
|
||||
}
|
||||
|
||||
groupInviteForm :: GroupId -> Form GroupInvite
|
||||
groupInviteForm groupID = renderDivs $ GroupInvite
|
||||
<$> areq selectPerson "Person*" Nothing
|
||||
<*> areq selectRole "Role*" Nothing
|
||||
where
|
||||
selectPerson = selectField $ do
|
||||
l <- runDB $ E.select $
|
||||
E.from $ \ (person `E.InnerJoin` actor `E.LeftOuterJoin` (recip `E.InnerJoin` topic)) -> do
|
||||
E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicGroupCollab E.&&.
|
||||
topic E.^. CollabTopicGroupGroup E.==. E.val groupID
|
||||
E.on $ person E.^. PersonId E.==. recip E.^. CollabRecipLocalPerson
|
||||
E.on $ person E.^. PersonActor E.==. actor E.^. ActorId
|
||||
E.where_ $ E.isNothing $ E.just $ recip E.^. CollabRecipLocalId
|
||||
return (person, actor)
|
||||
optionsPairs $
|
||||
map (\ (Entity pid p, Entity _ a) ->
|
||||
( T.concat
|
||||
[ actorName a
|
||||
, " ~"
|
||||
, username2text $ personUsername p
|
||||
]
|
||||
, pid
|
||||
)
|
||||
)
|
||||
l
|
||||
selectRole = selectField optionsEnum
|
||||
|
||||
{-
|
||||
editProjectAForm :: SharerId -> Entity Project -> AForm Handler Project
|
||||
editProjectAForm sid (Entity jid project) = Project
|
||||
|
|
|
|||
|
|
@ -160,6 +160,9 @@ type SigKeyKeyHashid = KeyHashid SigKey
|
|||
type ProjectKeyHashid = KeyHashid Project
|
||||
type CollabEnableKeyHashid = KeyHashid CollabEnable
|
||||
type StemKeyHashid = KeyHashid Stem
|
||||
type PermitFulfillsInviteKeyHashid = KeyHashid PermitFulfillsInvite
|
||||
type DestThemSendDelegatorLocalKeyHashid = KeyHashid DestThemSendDelegatorLocal
|
||||
type DestThemSendDelegatorRemoteKeyHashid = KeyHashid DestThemSendDelegatorRemote
|
||||
|
||||
-- This is where we define all of the routes in our application. For a full
|
||||
-- explanation of the syntax, please see:
|
||||
|
|
@ -856,6 +859,8 @@ instance YesodBreadcrumbs App where
|
|||
PublishRemoveR -> ("Remove someone from a resource", Just HomeR)
|
||||
PublishResolveR -> ("Close a ticket", Just HomeR)
|
||||
|
||||
AcceptInviteR _ -> ("", Nothing)
|
||||
|
||||
PersonR p -> ("Person ~" <> keyHashidText p, Just HomeR)
|
||||
PersonInboxR p -> ("Inbox", Just $ PersonR p)
|
||||
PersonOutboxR p -> ("Outbox", Just $ PersonR p)
|
||||
|
|
@ -883,7 +888,14 @@ instance YesodBreadcrumbs App where
|
|||
|
||||
GroupStampR g k -> ("Stamp #" <> keyHashidText k, Just $ GroupR g)
|
||||
|
||||
GroupMembersR g -> ("Members", Just $ GroupR g)
|
||||
GroupMembersR g -> ("Members", Just $ GroupR g)
|
||||
GroupInviteR g -> ("Invite", Just $ GroupR g)
|
||||
GroupRemoveR _ _ -> ("", Nothing)
|
||||
|
||||
GroupChildrenR j -> ("Child teams", Just $ GroupR j)
|
||||
GroupChildLocalLiveR j d -> ("Local " <> keyHashidText d, Just $ GroupChildrenR j)
|
||||
GroupChildRemoteLiveR j d -> ("Remote " <> keyHashidText d, Just $ GroupChildrenR j)
|
||||
GroupParentsR j -> ("Parent teams", Just $ GroupR j)
|
||||
|
||||
RepoR r -> ("Repo ^" <> keyHashidText r, Just HomeR)
|
||||
RepoInboxR r -> ("Inbox", Just $ RepoR r)
|
||||
|
|
@ -1020,3 +1032,8 @@ instance YesodBreadcrumbs App where
|
|||
ProjectCollabLiveR j c -> (keyHashidText c, Just $ ProjectCollabsR j)
|
||||
|
||||
ProjectInviteCompR d -> ("Invite", Just $ ProjectComponentsR d)
|
||||
|
||||
ProjectChildrenR j -> ("Child projects", Just $ ProjectR j)
|
||||
ProjectParentsR j -> ("Parent projects", Just $ ProjectR j)
|
||||
ProjectParentLocalLiveR j d -> ("Local " <> keyHashidText d, Just $ ProjectParentsR j)
|
||||
ProjectParentRemoteLiveR j d -> ("Remote " <> keyHashidText d, Just $ ProjectParentsR j)
|
||||
|
|
|
|||
|
|
@ -44,6 +44,8 @@ module Vervis.Handler.Client
|
|||
|
||||
, getPublishResolveR
|
||||
, postPublishResolveR
|
||||
|
||||
, postAcceptInviteR
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -53,12 +55,15 @@ import Control.Monad
|
|||
import Control.Monad.Trans.Except
|
||||
import Data.Bifunctor
|
||||
import Data.Bitraversable
|
||||
import Data.Function
|
||||
import Data.List
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock
|
||||
import Data.Traversable
|
||||
import Database.Persist
|
||||
import Network.HTTP.Types.Method
|
||||
import Text.Blaze.Html (preEscapedToHtml)
|
||||
import Optics.Core
|
||||
import Yesod.Auth
|
||||
import Yesod.Auth.Account
|
||||
import Yesod.Auth.Account.Message
|
||||
|
|
@ -77,6 +82,7 @@ import Network.FedURI
|
|||
import Web.Text
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.Auth.Unverified
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
import Yesod.MonadSite
|
||||
import Yesod.RenderSource
|
||||
|
|
@ -89,6 +95,7 @@ import Data.EventTime.Local
|
|||
import Database.Persist.Local
|
||||
import Yesod.Form.Local
|
||||
|
||||
import Vervis.Actor
|
||||
import Vervis.API
|
||||
import Vervis.Client
|
||||
import Vervis.Data.Actor
|
||||
|
|
@ -98,12 +105,17 @@ import Vervis.Form.Ticket
|
|||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
import Vervis.Persist.Actor
|
||||
import Vervis.Persist.Collab
|
||||
import Vervis.Recipient
|
||||
import Vervis.Settings
|
||||
import Vervis.Web.Actor
|
||||
import Vervis.Widget
|
||||
import Vervis.Widget.Tracker
|
||||
|
||||
import qualified Vervis.Client as C
|
||||
import qualified Vervis.Recipient as VR
|
||||
|
||||
-- | Account verification email resend form
|
||||
getResendVerifyEmailR :: Handler Html
|
||||
getResendVerifyEmailR = do
|
||||
|
|
@ -130,64 +142,208 @@ getHomeR = do
|
|||
where
|
||||
personalOverview :: Entity Person -> Handler Html
|
||||
personalOverview (Entity pid _person) = do
|
||||
(repos, decks, looms, projects, groups) <- runDB $ (,,,,)
|
||||
<$> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` repo `E.InnerJoin` actor) -> do
|
||||
E.on $ repo E.^. RepoActor E.==. actor E.^. ActorId
|
||||
E.on $ topic E.^. CollabTopicRepoRepo E.==. repo E.^. RepoId
|
||||
E.on $ topic E.^. CollabTopicRepoCollab E.==. enable E.^. CollabEnableCollab
|
||||
E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicRepoCollab
|
||||
E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId
|
||||
E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid
|
||||
E.orderBy [E.asc $ repo E.^. RepoId]
|
||||
return (repo, actor, collab)
|
||||
)
|
||||
<*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` deck `E.InnerJoin` actor) -> do
|
||||
E.on $ deck E.^. DeckActor E.==. actor E.^. ActorId
|
||||
E.on $ topic E.^. CollabTopicDeckDeck E.==. deck E.^. DeckId
|
||||
E.on $ topic E.^. CollabTopicDeckCollab E.==. enable E.^. CollabEnableCollab
|
||||
E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicDeckCollab
|
||||
E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId
|
||||
E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid
|
||||
E.orderBy [E.asc $ deck E.^. DeckId]
|
||||
return (deck, actor, collab)
|
||||
)
|
||||
<*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` loom `E.InnerJoin` actor) -> do
|
||||
E.on $ loom E.^. LoomActor E.==. actor E.^. ActorId
|
||||
E.on $ topic E.^. CollabTopicLoomLoom E.==. loom E.^. LoomId
|
||||
E.on $ topic E.^. CollabTopicLoomCollab E.==. enable E.^. CollabEnableCollab
|
||||
E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicLoomCollab
|
||||
E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId
|
||||
E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid
|
||||
E.orderBy [E.asc $ loom E.^. LoomId]
|
||||
return (loom, actor, collab)
|
||||
)
|
||||
<*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` project `E.InnerJoin` actor) -> do
|
||||
E.on $ project E.^. ProjectActor E.==. actor E.^. ActorId
|
||||
E.on $ topic E.^. CollabTopicProjectProject E.==. project E.^. ProjectId
|
||||
E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab
|
||||
E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicProjectCollab
|
||||
E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId
|
||||
E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid
|
||||
E.orderBy [E.asc $ project E.^. ProjectId]
|
||||
return (project, actor, collab)
|
||||
)
|
||||
<*> (E.select $ E.from $ \ (recip `E.InnerJoin` collab `E.InnerJoin` topic `E.InnerJoin` enable `E.InnerJoin` group `E.InnerJoin` actor) -> do
|
||||
E.on $ group E.^. GroupActor E.==. actor E.^. ActorId
|
||||
E.on $ topic E.^. CollabTopicGroupGroup E.==. group E.^. GroupId
|
||||
E.on $ topic E.^. CollabTopicGroupCollab E.==. enable E.^. CollabEnableCollab
|
||||
E.on $ recip E.^. CollabRecipLocalCollab E.==. topic E.^. CollabTopicGroupCollab
|
||||
E.on $ recip E.^. CollabRecipLocalCollab E.==. collab E.^. CollabId
|
||||
E.where_ $ recip E.^. CollabRecipLocalPerson E.==. E.val pid
|
||||
E.orderBy [E.asc $ group E.^. GroupId]
|
||||
return (group, actor, collab)
|
||||
)
|
||||
hashRepo <- getEncodeKeyHashid
|
||||
hashDeck <- getEncodeKeyHashid
|
||||
hashLoom <- getEncodeKeyHashid
|
||||
hashProject <- getEncodeKeyHashid
|
||||
hashGroup <- getEncodeKeyHashid
|
||||
(permits, invites) <- runDB $ do
|
||||
permits <- do
|
||||
locals <- do
|
||||
ls <- E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable) -> do
|
||||
E.on $ topic E.^. PermitTopicLocalId E.==. enable E.^. PermitTopicEnableLocalTopic
|
||||
E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicLocalPermit
|
||||
E.where_ $ permit E.^. PermitPerson E.==. E.val pid
|
||||
E.orderBy [E.asc $ enable E.^. PermitTopicEnableLocalId]
|
||||
return
|
||||
( enable E.^. PermitTopicEnableLocalPermit
|
||||
, permit E.^. PermitRole
|
||||
, topic E.^. PermitTopicLocalId
|
||||
)
|
||||
for ls $ \ (E.Value gestureID, E.Value role, E.Value topicID) -> do
|
||||
topic <- getPermitTopicLocal topicID
|
||||
actorID <- do
|
||||
ma <- getLocalActorEntity topic
|
||||
case ma of
|
||||
Nothing -> error "Impossible, we should have found the local actor in DB"
|
||||
Just a -> pure $ localActorID a
|
||||
actor <- getJust actorID
|
||||
delegator <- getKeyBy $ UniquePermitPersonSendDelegator gestureID
|
||||
exts <-
|
||||
case delegator of
|
||||
Nothing -> pure []
|
||||
Just sendID -> do
|
||||
topicHash <- VR.hashLocalActor topic
|
||||
hashItem <- getEncodeKeyHashid
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
map (encodeRouteHome . activityRoute topicHash . hashItem . permitTopicExtendLocalGrant . entityVal) <$>
|
||||
selectList [PermitTopicExtendLocalPermit ==. sendID] [Asc PermitTopicExtendLocalId]
|
||||
return
|
||||
( gestureID
|
||||
, role
|
||||
, delegator
|
||||
, localActorType topic
|
||||
, Left (topic, actor)
|
||||
, exts
|
||||
)
|
||||
remotes <- do
|
||||
rs <- E.select $ E.from $ \ (permit `E.InnerJoin` topic `E.InnerJoin` enable) -> do
|
||||
E.on $ topic E.^. PermitTopicRemoteId E.==. enable E.^. PermitTopicEnableRemoteTopic
|
||||
E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicRemotePermit
|
||||
E.where_ $ permit E.^. PermitPerson E.==. E.val pid
|
||||
E.orderBy [E.asc $ enable E.^. PermitTopicEnableRemoteId]
|
||||
return
|
||||
( enable E.^. PermitTopicEnableRemotePermit
|
||||
, permit E.^. PermitRole
|
||||
, topic E.^. PermitTopicRemoteActor
|
||||
)
|
||||
for rs $ \ (E.Value gestureID, E.Value role, E.Value remoteActorID) -> do
|
||||
remoteActor <- getJust remoteActorID
|
||||
remoteObject <- getJust $ remoteActorIdent remoteActor
|
||||
inztance <- getJust $ remoteObjectInstance remoteObject
|
||||
delegator <- getKeyBy $ UniquePermitPersonSendDelegator gestureID
|
||||
exts <-
|
||||
case delegator of
|
||||
Nothing -> pure []
|
||||
Just sendID -> do
|
||||
es <- selectList [PermitTopicExtendRemotePermit ==. sendID] [Asc PermitTopicExtendRemoteId]
|
||||
for es $ \ (Entity _ (PermitTopicExtendRemote _ _ grantID)) -> do
|
||||
grant <- getJust grantID
|
||||
getRemoteActivityURI grant
|
||||
return
|
||||
( gestureID
|
||||
, role
|
||||
, delegator
|
||||
, remoteActorType remoteActor
|
||||
, Right (inztance, remoteObject, remoteActor)
|
||||
, exts
|
||||
)
|
||||
return $ locals ++ remotes
|
||||
invites <- do
|
||||
locals <- do
|
||||
ls <- E.select $ E.from $ \ (permit `E.InnerJoin` fulfills `E.InnerJoin` topic `E.LeftOuterJoin` enable `E.LeftOuterJoin` valid `E.LeftOuterJoin` accept) -> do
|
||||
E.on $ E.just (permit E.^. PermitId) E.==. accept E.?. PermitPersonGesturePermit
|
||||
E.on $ E.just (topic E.^. PermitTopicLocalId) E.==. valid E.?. PermitTopicAcceptLocalTopic
|
||||
E.on $ E.just (topic E.^. PermitTopicLocalId) E.==. enable E.?. PermitTopicEnableLocalTopic
|
||||
E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicLocalPermit
|
||||
E.on $ permit E.^. PermitId E.==. fulfills E.^. PermitFulfillsInvitePermit
|
||||
E.where_ $
|
||||
permit E.^. PermitPerson E.==. E.val pid E.&&.
|
||||
E.isNothing (enable E.?. PermitTopicEnableLocalId)
|
||||
E.orderBy [E.asc $ permit E.^. PermitId]
|
||||
return
|
||||
( fulfills E.^. PermitFulfillsInviteId
|
||||
, permit E.^. PermitRole
|
||||
, valid E.?. PermitTopicAcceptLocalId
|
||||
, accept E.?. PermitPersonGestureId
|
||||
, topic E.^. PermitTopicLocalId
|
||||
)
|
||||
for ls $ \ (E.Value fulfillsID, E.Value role, E.Value valid, E.Value accept, E.Value topicID) -> do
|
||||
topic <- getPermitTopicLocal topicID
|
||||
actorID <- do
|
||||
ma <- getLocalActorEntity topic
|
||||
case ma of
|
||||
Nothing -> error "Impossible, we should have found the local actor in DB"
|
||||
Just a -> pure $ localActorID a
|
||||
actor <- getJust actorID
|
||||
fulfillsHash <- encodeKeyHashid fulfillsID
|
||||
return
|
||||
( fulfillsID
|
||||
, role
|
||||
, () <$ valid
|
||||
, accept
|
||||
, fulfillsHash
|
||||
, Left (topic, actor)
|
||||
)
|
||||
remotes <- do
|
||||
rs <- E.select $ E.from $ \ (permit `E.InnerJoin` fulfills `E.InnerJoin` topic `E.LeftOuterJoin` enable `E.LeftOuterJoin` valid `E.LeftOuterJoin` accept) -> do
|
||||
E.on $ E.just (permit E.^. PermitId) E.==. accept E.?. PermitPersonGesturePermit
|
||||
E.on $ E.just (topic E.^. PermitTopicRemoteId) E.==. valid E.?. PermitTopicAcceptRemoteTopic
|
||||
E.on $ E.just (topic E.^. PermitTopicRemoteId) E.==. enable E.?. PermitTopicEnableRemoteTopic
|
||||
E.on $ permit E.^. PermitId E.==. topic E.^. PermitTopicRemotePermit
|
||||
E.on $ permit E.^. PermitId E.==. fulfills E.^. PermitFulfillsInvitePermit
|
||||
E.where_ $
|
||||
permit E.^. PermitPerson E.==. E.val pid E.&&.
|
||||
E.isNothing (enable E.?. PermitTopicEnableRemoteId)
|
||||
E.orderBy [E.asc $ permit E.^. PermitId]
|
||||
return
|
||||
( fulfills E.^. PermitFulfillsInviteId
|
||||
, permit E.^. PermitRole
|
||||
, valid E.?. PermitTopicAcceptRemoteId
|
||||
, accept E.?. PermitPersonGestureId
|
||||
, topic E.^. PermitTopicRemoteActor
|
||||
)
|
||||
for rs $ \ (E.Value fulfillsID, E.Value role, E.Value valid, E.Value accept, E.Value remoteActorID) -> do
|
||||
remoteActor <- getJust remoteActorID
|
||||
remoteObject <- getJust $ remoteActorIdent remoteActor
|
||||
inztance <- getJust $ remoteObjectInstance remoteObject
|
||||
fulfillsHash <- encodeKeyHashid fulfillsID
|
||||
return
|
||||
( fulfillsID
|
||||
, role
|
||||
, () <$ valid
|
||||
, accept
|
||||
, fulfillsHash
|
||||
, Right (inztance, remoteObject, remoteActor)
|
||||
)
|
||||
return $ sortOn (view _1) $ locals ++ remotes
|
||||
return (permits, invites)
|
||||
let (people, repos, decks, looms, projects, groups, others) =
|
||||
partitionByActorType (view _4) (view _1) permits
|
||||
if null people
|
||||
then pure ()
|
||||
else error "Bug: Person as a PermitTopic"
|
||||
defaultLayout $(widgetFile "personal-overview")
|
||||
|
||||
where
|
||||
|
||||
partitionByActorType
|
||||
:: Eq b
|
||||
=> (a -> AP.ActorType)
|
||||
-> (a -> b)
|
||||
-> [a]
|
||||
-> ([a], [a], [a], [a], [a], [a], [a])
|
||||
partitionByActorType typ key xs =
|
||||
let p = filter ((== AP.ActorTypePerson) . typ) xs
|
||||
r = filter ((== AP.ActorTypeRepo) . typ) xs
|
||||
d = filter ((== AP.ActorTypeTicketTracker) . typ) xs
|
||||
l = filter ((== AP.ActorTypePatchTracker) . typ) xs
|
||||
j = filter ((== AP.ActorTypeProject) . typ) xs
|
||||
g = filter ((== AP.ActorTypeTeam) . typ) xs
|
||||
x = deleteFirstsBy ((==) `on` key) xs (p ++ r ++ d ++ l ++ j ++ g)
|
||||
in (p, r, d, l, j, g, x)
|
||||
|
||||
item (_gestureID, role, deleg, _typ, actor, exts) =
|
||||
[whamlet|
|
||||
<span>
|
||||
[
|
||||
#{show role}
|
||||
] #
|
||||
$maybe _ <- deleg
|
||||
\ [D] #
|
||||
$nothing
|
||||
\ [_] #
|
||||
^{actorLinkFedW actor}
|
||||
<ul>
|
||||
$forall u <- exts
|
||||
<li>
|
||||
<a href="#{renderObjURI u}">
|
||||
#{renderObjURI u}
|
||||
|]
|
||||
|
||||
invite (_fulfillsID, role, valid, accept, fulfillsHash, actor) =
|
||||
[whamlet|
|
||||
<span>
|
||||
[
|
||||
#{show role}
|
||||
] #
|
||||
$maybe _ <- valid
|
||||
\ [Valid] #
|
||||
$nothing
|
||||
\ [Not validated] #
|
||||
$maybe _ <- accept
|
||||
\ [You've accepted] #
|
||||
$nothing
|
||||
^{buttonW POST "Accept" (AcceptInviteR fulfillsHash)}
|
||||
$#\ [Reject Button] #
|
||||
^{actorLinkFedW actor}
|
||||
|]
|
||||
|
||||
getBrowseR :: Handler Html
|
||||
getBrowseR = do
|
||||
(people, groups, repos, decks, looms, projects) <- runDB $
|
||||
|
|
@ -1251,9 +1407,6 @@ getPublishInviteR = do
|
|||
|
||||
postPublishInviteR :: Handler ()
|
||||
postPublishInviteR = do
|
||||
federation <- getsYesod $ appFederation . appSettings
|
||||
unless federation badMethod
|
||||
|
||||
(uRecipient, uResourceCollabs, role, (uCap, cap)) <-
|
||||
runFormPostRedirect PublishInviteR inviteForm
|
||||
|
||||
|
|
@ -1353,3 +1506,50 @@ postPublishResolveR = do
|
|||
Right _ -> do
|
||||
setMessage "Resolve activity sent"
|
||||
redirect HomeR
|
||||
|
||||
postAcceptInviteR :: KeyHashid PermitFulfillsInvite -> Handler ()
|
||||
postAcceptInviteR fulfillsHash = do
|
||||
fulfillsID <- decodeKeyHashid404 fulfillsHash
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
result <- runExceptT $ do
|
||||
(uInvite, topic) <- lift $ runDB $ do
|
||||
PermitFulfillsInvite permitID <- get404 fulfillsID
|
||||
Permit p _ <- getJust permitID
|
||||
unless (p == personID) notFound
|
||||
uInvite <- do
|
||||
i <-
|
||||
requireEitherAlt
|
||||
(getValBy $ UniquePermitTopicGestureLocal fulfillsID)
|
||||
(getValBy $ UniquePermitTopicGestureRemote fulfillsID)
|
||||
"Invite not found"
|
||||
"Multiple invites"
|
||||
case i of
|
||||
Left (PermitTopicGestureLocal _ inviteID) -> do
|
||||
outboxID <- outboxItemOutbox <$> getJust inviteID
|
||||
actorID <- getKeyByJust $ UniqueActorOutbox outboxID
|
||||
actor <- getLocalActor actorID
|
||||
actorHash <- VR.hashLocalActor actor
|
||||
inviteHash <- encodeKeyHashid inviteID
|
||||
return $ encodeRouteHome $
|
||||
activityRoute actorHash inviteHash
|
||||
Right (PermitTopicGestureRemote _ _ inviteID) -> do
|
||||
invite <- getJust inviteID
|
||||
getRemoteActivityURI invite
|
||||
topic <- bimap snd snd <$> getPermitTopic permitID
|
||||
return (uInvite, topic)
|
||||
(maybeSummary, audience, accept) <-
|
||||
C.acceptPersonalInvite personID topic uInvite
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput Nothing maybeSummary audience $
|
||||
AP.AcceptActivity accept
|
||||
handleViaActor
|
||||
personID Nothing localRecips remoteRecips fwdHosts action
|
||||
|
||||
case result of
|
||||
Left e -> setMessage $ toHtml e
|
||||
Right _acceptID -> setMessage "Accept sent"
|
||||
redirect HomeR
|
||||
|
|
|
|||
|
|
@ -109,7 +109,6 @@ import Yesod.Persist.Local
|
|||
import Vervis.Access
|
||||
import Vervis.API
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Federation.Collab
|
||||
import Vervis.Federation.Discussion
|
||||
import Vervis.Federation.Offer
|
||||
import Vervis.Federation.Ticket
|
||||
|
|
|
|||
|
|
@ -28,7 +28,14 @@ module Vervis.Handler.Group
|
|||
, getGroupStampR
|
||||
|
||||
, getGroupMembersR
|
||||
, getGroupInviteR
|
||||
, postGroupInviteR
|
||||
, postGroupRemoveR
|
||||
|
||||
, getGroupChildrenR
|
||||
, getGroupChildLocalLiveR
|
||||
, getGroupChildRemoteLiveR
|
||||
, getGroupParentsR
|
||||
|
||||
|
||||
|
||||
|
|
@ -55,12 +62,14 @@ import Data.Bitraversable
|
|||
import Data.ByteString (ByteString)
|
||||
import Data.Default.Class
|
||||
import Data.Foldable
|
||||
import Data.List
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock
|
||||
import Data.Traversable
|
||||
import Database.Persist
|
||||
import Network.HTTP.Types.Method
|
||||
import Optics.Core
|
||||
import Text.Blaze.Html (Html)
|
||||
import Yesod.Auth (requireAuth)
|
||||
import Yesod.Core
|
||||
|
|
@ -94,7 +103,6 @@ import Vervis.Access
|
|||
import Vervis.API
|
||||
import Vervis.Data.Collab
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Federation.Collab
|
||||
import Vervis.Federation.Discussion
|
||||
import Vervis.Federation.Offer
|
||||
import Vervis.Federation.Ticket
|
||||
|
|
@ -188,8 +196,8 @@ getGroupR groupHash = do
|
|||
}
|
||||
groupAP = AP.Team
|
||||
{ AP.teamActor = actorAP
|
||||
, AP.teamChildren = []
|
||||
, AP.teamParents = []
|
||||
, AP.teamChildren = encodeRouteLocal $ GroupChildrenR groupHash
|
||||
, AP.teamParents = encodeRouteLocal $ GroupParentsR groupHash
|
||||
, AP.teamMembers = encodeRouteLocal $ GroupMembersR groupHash
|
||||
}
|
||||
|
||||
|
|
@ -291,7 +299,307 @@ getGroupMembersR groupHash = do
|
|||
LocalActorPerson personID -> return personID
|
||||
_ -> error "Surprise, local inviter actor isn't a Person"
|
||||
|
||||
getGroupInviteR :: KeyHashid Group -> Handler Html
|
||||
getGroupInviteR groupHash = do
|
||||
groupID <- decodeKeyHashid404 groupHash
|
||||
((_result, widget), enctype) <- runFormPost $ groupInviteForm groupID
|
||||
defaultLayout $(widgetFile "group/member/new")
|
||||
|
||||
postGroupInviteR :: KeyHashid Group -> Handler Html
|
||||
postGroupInviteR groupHash = do
|
||||
groupID <- decodeKeyHashid404 groupHash
|
||||
GroupInvite recipPersonID role <-
|
||||
runFormPostRedirect (GroupInviteR groupHash) $ groupInviteForm groupID
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
recipPersonHash <- encodeKeyHashid recipPersonID
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
result <- runExceptT $ do
|
||||
(maybeSummary, audience, invite) <- do
|
||||
let uRecipient = encodeRouteHome $ PersonR recipPersonHash
|
||||
uResourceCollabs = encodeRouteHome $ GroupMembersR groupHash
|
||||
C.invite personID uRecipient uResourceCollabs role
|
||||
grantID <- do
|
||||
maybeItem <- lift $ runDB $ getGrant CollabTopicGroupCollab CollabTopicGroupGroup groupID personID
|
||||
fromMaybeE maybeItem "You need to be a collaborator in the Group to invite people"
|
||||
grantHash <- encodeKeyHashid grantID
|
||||
let uCap = encodeRouteHome $ GroupOutboxItemR groupHash grantHash
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput (Just uCap) maybeSummary audience $ AP.InviteActivity invite
|
||||
let cap =
|
||||
Left (LocalActorGroup groupID, LocalActorGroup groupHash, grantID)
|
||||
handleViaActor
|
||||
personID (Just cap) localRecips remoteRecips fwdHosts action
|
||||
|
||||
case result of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
redirect $ GroupInviteR groupHash
|
||||
Right inviteID -> do
|
||||
setMessage "Invite sent"
|
||||
redirect $ GroupMembersR groupHash
|
||||
|
||||
postGroupRemoveR :: KeyHashid Group -> CollabTopicGroupId -> Handler Html
|
||||
postGroupRemoveR groupHash ctID = do
|
||||
groupID <- decodeKeyHashid404 groupHash
|
||||
|
||||
personEntity@(Entity personID person) <- requireAuth
|
||||
personHash <- encodeKeyHashid personID
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
result <- runExceptT $ do
|
||||
mpidOrU <- lift $ runDB $ runMaybeT $ do
|
||||
CollabTopicGroup collabID groupID' <- MaybeT $ get ctID
|
||||
guard $ groupID' == groupID
|
||||
_ <- MaybeT $ getBy $ UniqueCollabEnable collabID
|
||||
member <-
|
||||
Left <$> MaybeT (getValBy $ UniqueCollabRecipLocal collabID) <|>
|
||||
Right <$> MaybeT (getValBy $ UniqueCollabRecipRemote collabID)
|
||||
lift $
|
||||
bitraverse
|
||||
(pure . collabRecipLocalPerson)
|
||||
(getRemoteActorURI <=< getJust . collabRecipRemoteActor)
|
||||
member
|
||||
pidOrU <- maybe notFound pure mpidOrU
|
||||
(maybeSummary, audience, remove) <- do
|
||||
uRecipient <-
|
||||
case pidOrU of
|
||||
Left pid -> encodeRouteHome . PersonR <$> encodeKeyHashid pid
|
||||
Right u -> pure u
|
||||
let uResourceCollabs = encodeRouteHome $ GroupMembersR groupHash
|
||||
C.remove personID uRecipient uResourceCollabs
|
||||
grantID <- do
|
||||
maybeItem <- lift $ runDB $ getGrant CollabTopicGroupCollab CollabTopicGroupGroup groupID personID
|
||||
fromMaybeE maybeItem "You need to be a collaborator in the Group to remove people"
|
||||
grantHash <- encodeKeyHashid grantID
|
||||
let uCap = encodeRouteHome $ GroupOutboxItemR groupHash grantHash
|
||||
(localRecips, remoteRecips, fwdHosts, action) <-
|
||||
C.makeServerInput (Just uCap) maybeSummary audience $ AP.RemoveActivity remove
|
||||
let cap =
|
||||
Left (LocalActorGroup groupID, LocalActorGroup groupHash, grantID)
|
||||
handleViaActor
|
||||
personID (Just cap) localRecips remoteRecips fwdHosts action
|
||||
|
||||
case result of
|
||||
Left e -> do
|
||||
setMessage $ toHtml e
|
||||
Right removeID ->
|
||||
setMessage "Remove sent"
|
||||
redirect $ GroupMembersR groupHash
|
||||
|
||||
getGroupChildrenR :: KeyHashid Group -> Handler TypedContent
|
||||
getGroupChildrenR groupHash = do
|
||||
groupID <- decodeKeyHashid404 groupHash
|
||||
(actor, group, children) <- runDB $ do
|
||||
group <- get404 groupID
|
||||
actor <- getJust $ groupActor group
|
||||
children <- getChildren groupID
|
||||
return (actor, group, children)
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hashGroup <- getEncodeKeyHashid
|
||||
h <- asksSite siteInstanceHost
|
||||
let makeId (Left (childID, _)) =
|
||||
encodeRouteHome $ GroupR $ hashGroup childID
|
||||
makeId (Right (i, ro, _)) =
|
||||
ObjURI (instanceHost i) (remoteObjectIdent ro)
|
||||
makeItem (role, time, i) = AP.Relationship
|
||||
{ AP.relationshipId = Nothing
|
||||
, AP.relationshipExtraTypes = []
|
||||
, AP.relationshipSubject = encodeRouteHome $ GroupR groupHash
|
||||
, AP.relationshipProperty = Left AP.RelHasChild
|
||||
, AP.relationshipObject = makeId i
|
||||
, AP.relationshipAttributedTo = encodeRouteLocal $ GroupR groupHash
|
||||
, AP.relationshipPublished = Just time
|
||||
, AP.relationshipUpdated = Nothing
|
||||
, AP.relationshipInstrument = Just role
|
||||
}
|
||||
childrenAP = Collection
|
||||
{ collectionId = encodeRouteLocal $ GroupChildrenR groupHash
|
||||
, collectionType = CollectionTypeUnordered
|
||||
, collectionTotalItems = Just $ length children
|
||||
, collectionCurrent = Nothing
|
||||
, collectionFirst = Nothing
|
||||
, collectionLast = Nothing
|
||||
, collectionItems = map (Doc h . makeItem) children
|
||||
, collectionContext =
|
||||
Just $ encodeRouteLocal $ GroupR groupHash
|
||||
}
|
||||
provideHtmlAndAP childrenAP $ getHtml groupID group actor children
|
||||
|
||||
where
|
||||
|
||||
getChildren groupID = fmap (sortOn $ view _2) $ liftA2 (++)
|
||||
(map (\ (E.Value role, E.Value time, E.Value child, Entity _ actor) ->
|
||||
(role, time, Left (child, actor))
|
||||
)
|
||||
<$> getLocals groupID
|
||||
)
|
||||
(map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra) ->
|
||||
(role, time, Right (i, ro, ra))
|
||||
)
|
||||
<$> getRemotes groupID
|
||||
)
|
||||
|
||||
getLocals groupID =
|
||||
E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` group `E.InnerJoin` actor `E.InnerJoin` accept `E.InnerJoin` deleg `E.InnerJoin` grant) -> do
|
||||
E.on $ deleg E.^. DestThemSendDelegatorLocalGrant E.==. grant E.^. OutboxItemId
|
||||
E.on $ accept E.^. DestUsAcceptId E.==. deleg E.^. DestThemSendDelegatorLocalDest
|
||||
E.on $ dest E.^. DestId E.==. accept E.^. DestUsAcceptDest
|
||||
E.on $ group E.^. GroupActor E.==. actor E.^. ActorId
|
||||
E.on $ topic E.^. DestTopicGroupChild E.==. group E.^. GroupId
|
||||
E.on $ holder E.^. DestHolderGroupId E.==. topic E.^. DestTopicGroupHolder
|
||||
E.on $ dest E.^. DestId E.==. holder E.^. DestHolderGroupDest
|
||||
E.where_ $ holder E.^. DestHolderGroupGroup E.==. E.val groupID
|
||||
E.orderBy [E.asc $ grant E.^. OutboxItemPublished]
|
||||
return
|
||||
( dest E.^. DestRole
|
||||
, grant E.^. OutboxItemPublished
|
||||
, topic E.^. DestTopicGroupChild
|
||||
, actor
|
||||
)
|
||||
|
||||
getRemotes groupID =
|
||||
E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` deleg `E.InnerJoin` grant `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
|
||||
E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
|
||||
E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
|
||||
E.on $ topic E.^. DestTopicRemoteTopic E.==. ra E.^. RemoteActorId
|
||||
E.on $ deleg E.^. DestThemSendDelegatorRemoteGrant E.==. grant E.^. RemoteActivityId
|
||||
E.on $ accept E.^. DestUsAcceptId E.==. deleg E.^. DestThemSendDelegatorRemoteDest
|
||||
E.on $ dest E.^. DestId E.==. accept E.^. DestUsAcceptDest
|
||||
E.on $ dest E.^. DestId E.==. topic E.^. DestTopicRemoteDest
|
||||
E.on $ dest E.^. DestId E.==. holder E.^. DestHolderGroupDest
|
||||
E.where_ $ holder E.^. DestHolderGroupGroup E.==. E.val groupID
|
||||
E.orderBy [E.asc $ grant E.^. RemoteActivityReceived]
|
||||
return
|
||||
( dest E.^. DestRole
|
||||
, grant E.^. RemoteActivityReceived
|
||||
, i
|
||||
, ro
|
||||
, ra
|
||||
)
|
||||
|
||||
getHtml groupID group actor children = do
|
||||
$(widgetFile "group/children")
|
||||
|
||||
getGroupChildLocalLiveR :: KeyHashid Group -> KeyHashid DestThemSendDelegatorLocal -> Handler ()
|
||||
getGroupChildLocalLiveR groupHash delegHash = do
|
||||
groupID <- decodeKeyHashid404 groupHash
|
||||
delegID <- decodeKeyHashid404 delegHash
|
||||
runDB $ do
|
||||
_ <- get404 groupID
|
||||
DestThemSendDelegatorLocal _ localID _ <- get404 delegID
|
||||
DestTopicLocal destID <- getJust localID
|
||||
Entity _ (DestHolderGroup _ g) <-
|
||||
getBy404 $ UniqueDestHolderGroup destID
|
||||
unless (g == groupID) notFound
|
||||
|
||||
getGroupChildRemoteLiveR :: KeyHashid Group -> KeyHashid DestThemSendDelegatorRemote -> Handler ()
|
||||
getGroupChildRemoteLiveR groupHash delegHash = do
|
||||
groupID <- decodeKeyHashid404 groupHash
|
||||
delegID <- decodeKeyHashid404 delegHash
|
||||
runDB $ do
|
||||
_ <- get404 groupID
|
||||
DestThemSendDelegatorRemote _ remoteID _ <- get404 delegID
|
||||
DestTopicRemote destID _ <- getJust remoteID
|
||||
Entity _ (DestHolderGroup _ g) <-
|
||||
getBy404 $ UniqueDestHolderGroup destID
|
||||
unless (g == groupID) notFound
|
||||
|
||||
getGroupParentsR :: KeyHashid Group -> Handler TypedContent
|
||||
getGroupParentsR groupHash = do
|
||||
groupID <- decodeKeyHashid404 groupHash
|
||||
(actor, group, parents) <- runDB $ do
|
||||
group <- get404 groupID
|
||||
actor <- getJust $ groupActor group
|
||||
parents <- getParents groupID
|
||||
return (actor, group, parents)
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
hashGroup <- getEncodeKeyHashid
|
||||
h <- asksSite siteInstanceHost
|
||||
let makeId (Left (parentID, _)) =
|
||||
encodeRouteHome $ GroupR $ hashGroup parentID
|
||||
makeId (Right (i, ro, _)) =
|
||||
ObjURI (instanceHost i) (remoteObjectIdent ro)
|
||||
makeItem (role, time, i) = AP.Relationship
|
||||
{ AP.relationshipId = Nothing
|
||||
, AP.relationshipExtraTypes = []
|
||||
, AP.relationshipSubject = encodeRouteHome $ GroupR groupHash
|
||||
, AP.relationshipProperty = Left AP.RelHasParent
|
||||
, AP.relationshipObject = makeId i
|
||||
, AP.relationshipAttributedTo = encodeRouteLocal $ GroupR groupHash
|
||||
, AP.relationshipPublished = Just time
|
||||
, AP.relationshipUpdated = Nothing
|
||||
, AP.relationshipInstrument = Just role
|
||||
}
|
||||
parentsAP = Collection
|
||||
{ collectionId = encodeRouteLocal $ GroupParentsR groupHash
|
||||
, collectionType = CollectionTypeUnordered
|
||||
, collectionTotalItems = Just $ length parents
|
||||
, collectionCurrent = Nothing
|
||||
, collectionFirst = Nothing
|
||||
, collectionLast = Nothing
|
||||
, collectionItems = map (Doc h . makeItem) parents
|
||||
, collectionContext =
|
||||
Just $ encodeRouteLocal $ GroupR groupHash
|
||||
}
|
||||
provideHtmlAndAP parentsAP $ getHtml groupID group actor parents
|
||||
|
||||
where
|
||||
|
||||
getParents groupID = fmap (sortOn $ view _2) $ liftA2 (++)
|
||||
(map (\ (E.Value role, E.Value time, E.Value parent, Entity _ actor) ->
|
||||
(role, time, Left (parent, actor))
|
||||
)
|
||||
<$> getLocals groupID
|
||||
)
|
||||
(map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra) ->
|
||||
(role, time, Right (i, ro, ra))
|
||||
)
|
||||
<$> getRemotes groupID
|
||||
)
|
||||
|
||||
getLocals groupID =
|
||||
E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` group `E.InnerJoin` actor `E.InnerJoin` deleg `E.InnerJoin` grant) -> do
|
||||
E.on $ deleg E.^. SourceUsSendDelegatorGrant E.==. grant E.^. OutboxItemId
|
||||
E.on $ source E.^. SourceId E.==. deleg E.^. SourceUsSendDelegatorSource
|
||||
E.on $ group E.^. GroupActor E.==. actor E.^. ActorId
|
||||
E.on $ topic E.^. SourceTopicGroupParent E.==. group E.^. GroupId
|
||||
E.on $ holder E.^. SourceHolderGroupId E.==. topic E.^. SourceTopicGroupHolder
|
||||
E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderGroupSource
|
||||
E.where_ $ holder E.^. SourceHolderGroupGroup E.==. E.val groupID
|
||||
E.orderBy [E.asc $ deleg E.^. SourceUsSendDelegatorId]
|
||||
return
|
||||
( source E.^. SourceRole
|
||||
, grant E.^. OutboxItemPublished
|
||||
, topic E.^. SourceTopicGroupParent
|
||||
, actor
|
||||
)
|
||||
|
||||
getRemotes groupID =
|
||||
E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` deleg `E.InnerJoin` grant `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
|
||||
E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
|
||||
E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
|
||||
E.on $ topic E.^. SourceTopicRemoteTopic E.==. ra E.^. RemoteActorId
|
||||
E.on $ deleg E.^. SourceUsSendDelegatorGrant E.==. grant E.^. OutboxItemId
|
||||
E.on $ source E.^. SourceId E.==. deleg E.^. SourceUsSendDelegatorSource
|
||||
E.on $ source E.^. SourceId E.==. topic E.^. SourceTopicRemoteSource
|
||||
E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderGroupSource
|
||||
E.where_ $ holder E.^. SourceHolderGroupGroup E.==. E.val groupID
|
||||
E.orderBy [E.asc $ deleg E.^. SourceUsSendDelegatorId]
|
||||
return
|
||||
( source E.^. SourceRole
|
||||
, grant E.^. OutboxItemPublished
|
||||
, i
|
||||
, ro
|
||||
, ra
|
||||
)
|
||||
|
||||
getHtml groupID group actor parents = do
|
||||
$(widgetFile "group/parents")
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -78,7 +78,6 @@ import Yesod.Persist.Local
|
|||
import Vervis.Access
|
||||
import Vervis.API
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Federation.Collab
|
||||
import Vervis.Federation.Discussion
|
||||
import Vervis.Federation.Offer
|
||||
import Vervis.Federation.Ticket
|
||||
|
|
|
|||
|
|
@ -73,7 +73,6 @@ import Vervis.ActivityPub
|
|||
import Vervis.API
|
||||
import Vervis.Data.Actor
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Federation.Collab
|
||||
import Vervis.Federation.Discussion
|
||||
import Vervis.Federation.Offer
|
||||
import Vervis.FedURI
|
||||
|
|
|
|||
|
|
@ -38,6 +38,11 @@ module Vervis.Handler.Project
|
|||
|
||||
, getProjectInviteCompR
|
||||
, postProjectInviteCompR
|
||||
|
||||
, getProjectChildrenR
|
||||
, getProjectParentsR
|
||||
, getProjectParentLocalLiveR
|
||||
, getProjectParentRemoteLiveR
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -51,12 +56,14 @@ import Data.Bitraversable
|
|||
import Data.ByteString (ByteString)
|
||||
import Data.Default.Class
|
||||
import Data.Foldable
|
||||
import Data.List
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock
|
||||
import Data.Traversable
|
||||
import Database.Persist
|
||||
import Network.HTTP.Types.Method
|
||||
import Optics.Core
|
||||
import Text.Blaze.Html (Html)
|
||||
import Yesod.Auth (requireAuth)
|
||||
import Yesod.Core
|
||||
|
|
@ -90,7 +97,6 @@ import Vervis.Access
|
|||
import Vervis.API
|
||||
import Vervis.Data.Collab
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Federation.Collab
|
||||
import Vervis.Federation.Discussion
|
||||
import Vervis.Federation.Offer
|
||||
import Vervis.Federation.Ticket
|
||||
|
|
@ -153,8 +159,8 @@ getProjectR projectHash = do
|
|||
}
|
||||
}
|
||||
, AP.projectTracker = Nothing
|
||||
, AP.projectChildren = []
|
||||
, AP.projectParents = []
|
||||
, AP.projectChildren = encodeRouteLocal $ ProjectChildrenR projectHash
|
||||
, AP.projectParents = encodeRouteLocal $ ProjectParentsR projectHash
|
||||
, AP.projectComponents =
|
||||
encodeRouteLocal $ ProjectComponentsR projectHash
|
||||
, AP.projectCollaborators =
|
||||
|
|
@ -564,3 +570,215 @@ postProjectInviteCompR projectHash = do
|
|||
Right inviteID -> do
|
||||
setMessage "Invite sent"
|
||||
redirect $ ProjectComponentsR projectHash
|
||||
|
||||
getProjectChildrenR :: KeyHashid Project -> Handler TypedContent
|
||||
getProjectChildrenR projectHash = do
|
||||
projectID <- decodeKeyHashid404 projectHash
|
||||
(actor, project, children) <- runDB $ do
|
||||
project <- get404 projectID
|
||||
actor <- getJust $ projectActor project
|
||||
children <- getChildren projectID
|
||||
return (actor, project, children)
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
hashProject <- getEncodeKeyHashid
|
||||
h <- asksSite siteInstanceHost
|
||||
let makeId (Left (childID, _)) =
|
||||
encodeRouteHome $ ProjectR $ hashProject childID
|
||||
makeId (Right (i, ro, _)) =
|
||||
ObjURI (instanceHost i) (remoteObjectIdent ro)
|
||||
makeItem (role, time, i) = AP.Relationship
|
||||
{ AP.relationshipId = Nothing
|
||||
, AP.relationshipExtraTypes = []
|
||||
, AP.relationshipSubject = encodeRouteHome $ ProjectR projectHash
|
||||
, AP.relationshipProperty = Left AP.RelHasChild
|
||||
, AP.relationshipObject = makeId i
|
||||
, AP.relationshipAttributedTo = encodeRouteLocal $ ProjectR projectHash
|
||||
, AP.relationshipPublished = Just time
|
||||
, AP.relationshipUpdated = Nothing
|
||||
, AP.relationshipInstrument = Just role
|
||||
}
|
||||
childrenAP = Collection
|
||||
{ collectionId = encodeRouteLocal $ ProjectChildrenR projectHash
|
||||
, collectionType = CollectionTypeUnordered
|
||||
, collectionTotalItems = Just $ length children
|
||||
, collectionCurrent = Nothing
|
||||
, collectionFirst = Nothing
|
||||
, collectionLast = Nothing
|
||||
, collectionItems = map (Doc h . makeItem) children
|
||||
, collectionContext =
|
||||
Just $ encodeRouteLocal $ ProjectR projectHash
|
||||
}
|
||||
provideHtmlAndAP childrenAP $ getHtml projectID project actor children
|
||||
|
||||
where
|
||||
|
||||
getChildren projectID = fmap (sortOn $ view _2) $ liftA2 (++)
|
||||
(map (\ (E.Value role, E.Value time, E.Value child, Entity _ actor) ->
|
||||
(role, time, Left (child, actor))
|
||||
)
|
||||
<$> getLocals projectID
|
||||
)
|
||||
(map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra) ->
|
||||
(role, time, Right (i, ro, ra))
|
||||
)
|
||||
<$> getRemotes projectID
|
||||
)
|
||||
|
||||
getLocals projectID =
|
||||
E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` project `E.InnerJoin` actor `E.InnerJoin` deleg `E.InnerJoin` grant) -> do
|
||||
E.on $ deleg E.^. SourceUsSendDelegatorGrant E.==. grant E.^. OutboxItemId
|
||||
E.on $ source E.^. SourceId E.==. deleg E.^. SourceUsSendDelegatorSource
|
||||
E.on $ project E.^. ProjectActor E.==. actor E.^. ActorId
|
||||
E.on $ topic E.^. SourceTopicProjectChild E.==. project E.^. ProjectId
|
||||
E.on $ holder E.^. SourceHolderProjectId E.==. topic E.^. SourceTopicProjectHolder
|
||||
E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderProjectSource
|
||||
E.where_ $ holder E.^. SourceHolderProjectProject E.==. E.val projectID
|
||||
E.orderBy [E.asc $ deleg E.^. SourceUsSendDelegatorId]
|
||||
return
|
||||
( source E.^. SourceRole
|
||||
, grant E.^. OutboxItemPublished
|
||||
, topic E.^. SourceTopicProjectChild
|
||||
, actor
|
||||
)
|
||||
|
||||
getRemotes projectID =
|
||||
E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` deleg `E.InnerJoin` grant `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
|
||||
E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
|
||||
E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
|
||||
E.on $ topic E.^. SourceTopicRemoteTopic E.==. ra E.^. RemoteActorId
|
||||
E.on $ deleg E.^. SourceUsSendDelegatorGrant E.==. grant E.^. OutboxItemId
|
||||
E.on $ source E.^. SourceId E.==. deleg E.^. SourceUsSendDelegatorSource
|
||||
E.on $ source E.^. SourceId E.==. topic E.^. SourceTopicRemoteSource
|
||||
E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderProjectSource
|
||||
E.where_ $ holder E.^. SourceHolderProjectProject E.==. E.val projectID
|
||||
E.orderBy [E.asc $ deleg E.^. SourceUsSendDelegatorId]
|
||||
return
|
||||
( source E.^. SourceRole
|
||||
, grant E.^. OutboxItemPublished
|
||||
, i
|
||||
, ro
|
||||
, ra
|
||||
)
|
||||
|
||||
getHtml projectID project actor children = do
|
||||
$(widgetFile "project/children")
|
||||
|
||||
getProjectParentsR :: KeyHashid Project -> Handler TypedContent
|
||||
getProjectParentsR projectHash = do
|
||||
projectID <- decodeKeyHashid404 projectHash
|
||||
(actor, project, parents) <- runDB $ do
|
||||
project <- get404 projectID
|
||||
actor <- getJust $ projectActor project
|
||||
parents <- getParents projectID
|
||||
return (actor, project, parents)
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
hashProject <- getEncodeKeyHashid
|
||||
h <- asksSite siteInstanceHost
|
||||
let makeId (Left (parentID, _)) =
|
||||
encodeRouteHome $ ProjectR $ hashProject parentID
|
||||
makeId (Right (i, ro, _)) =
|
||||
ObjURI (instanceHost i) (remoteObjectIdent ro)
|
||||
makeItem (role, time, i) = AP.Relationship
|
||||
{ AP.relationshipId = Nothing
|
||||
, AP.relationshipExtraTypes = []
|
||||
, AP.relationshipSubject = encodeRouteHome $ ProjectR projectHash
|
||||
, AP.relationshipProperty = Left AP.RelHasParent
|
||||
, AP.relationshipObject = makeId i
|
||||
, AP.relationshipAttributedTo = encodeRouteLocal $ ProjectR projectHash
|
||||
, AP.relationshipPublished = Just time
|
||||
, AP.relationshipUpdated = Nothing
|
||||
, AP.relationshipInstrument = Just role
|
||||
}
|
||||
parentsAP = Collection
|
||||
{ collectionId = encodeRouteLocal $ ProjectParentsR projectHash
|
||||
, collectionType = CollectionTypeUnordered
|
||||
, collectionTotalItems = Just $ length parents
|
||||
, collectionCurrent = Nothing
|
||||
, collectionFirst = Nothing
|
||||
, collectionLast = Nothing
|
||||
, collectionItems = map (Doc h . makeItem) parents
|
||||
, collectionContext =
|
||||
Just $ encodeRouteLocal $ ProjectR projectHash
|
||||
}
|
||||
provideHtmlAndAP parentsAP $ getHtml projectID project actor parents
|
||||
|
||||
where
|
||||
|
||||
getParents projectID = fmap (sortOn $ view _2) $ liftA2 (++)
|
||||
(map (\ (E.Value role, E.Value time, E.Value parent, Entity _ actor) ->
|
||||
(role, time, Left (parent, actor))
|
||||
)
|
||||
<$> getLocals projectID
|
||||
)
|
||||
(map (\ (E.Value role, E.Value time, Entity _ i, Entity _ ro, Entity _ ra) ->
|
||||
(role, time, Right (i, ro, ra))
|
||||
)
|
||||
<$> getRemotes projectID
|
||||
)
|
||||
|
||||
getLocals projectID =
|
||||
E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` project `E.InnerJoin` actor `E.InnerJoin` accept `E.InnerJoin` deleg `E.InnerJoin` grant) -> do
|
||||
E.on $ deleg E.^. DestThemSendDelegatorLocalGrant E.==. grant E.^. OutboxItemId
|
||||
E.on $ accept E.^. DestUsAcceptId E.==. deleg E.^. DestThemSendDelegatorLocalDest
|
||||
E.on $ dest E.^. DestId E.==. accept E.^. DestUsAcceptDest
|
||||
E.on $ project E.^. ProjectActor E.==. actor E.^. ActorId
|
||||
E.on $ topic E.^. DestTopicProjectParent E.==. project E.^. ProjectId
|
||||
E.on $ holder E.^. DestHolderProjectId E.==. topic E.^. DestTopicProjectHolder
|
||||
E.on $ dest E.^. DestId E.==. holder E.^. DestHolderProjectDest
|
||||
E.where_ $ holder E.^. DestHolderProjectProject E.==. E.val projectID
|
||||
E.orderBy [E.asc $ grant E.^. OutboxItemPublished]
|
||||
return
|
||||
( dest E.^. DestRole
|
||||
, grant E.^. OutboxItemPublished
|
||||
, topic E.^. DestTopicProjectParent
|
||||
, actor
|
||||
)
|
||||
|
||||
getRemotes projectID =
|
||||
E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` deleg `E.InnerJoin` grant `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
|
||||
E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
|
||||
E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
|
||||
E.on $ topic E.^. DestTopicRemoteTopic E.==. ra E.^. RemoteActorId
|
||||
E.on $ deleg E.^. DestThemSendDelegatorRemoteGrant E.==. grant E.^. RemoteActivityId
|
||||
E.on $ accept E.^. DestUsAcceptId E.==. deleg E.^. DestThemSendDelegatorRemoteDest
|
||||
E.on $ dest E.^. DestId E.==. accept E.^. DestUsAcceptDest
|
||||
E.on $ dest E.^. DestId E.==. topic E.^. DestTopicRemoteDest
|
||||
E.on $ dest E.^. DestId E.==. holder E.^. DestHolderProjectDest
|
||||
E.where_ $ holder E.^. DestHolderProjectProject E.==. E.val projectID
|
||||
E.orderBy [E.asc $ grant E.^. RemoteActivityReceived]
|
||||
return
|
||||
( dest E.^. DestRole
|
||||
, grant E.^. RemoteActivityReceived
|
||||
, i
|
||||
, ro
|
||||
, ra
|
||||
)
|
||||
|
||||
getHtml projectID project actor parents = do
|
||||
$(widgetFile "project/parents")
|
||||
|
||||
getProjectParentLocalLiveR :: KeyHashid Project -> KeyHashid DestThemSendDelegatorLocal -> Handler ()
|
||||
getProjectParentLocalLiveR projectHash delegHash = do
|
||||
projectID <- decodeKeyHashid404 projectHash
|
||||
delegID <- decodeKeyHashid404 delegHash
|
||||
runDB $ do
|
||||
_ <- get404 projectID
|
||||
DestThemSendDelegatorLocal _ localID _ <- get404 delegID
|
||||
DestTopicLocal destID <- getJust localID
|
||||
Entity _ (DestHolderProject _ j) <-
|
||||
getBy404 $ UniqueDestHolderProject destID
|
||||
unless (j == projectID) notFound
|
||||
|
||||
getProjectParentRemoteLiveR :: KeyHashid Project -> KeyHashid DestThemSendDelegatorRemote -> Handler ()
|
||||
getProjectParentRemoteLiveR projectHash delegHash = do
|
||||
projectID <- decodeKeyHashid404 projectHash
|
||||
delegID <- decodeKeyHashid404 delegHash
|
||||
runDB $ do
|
||||
_ <- get404 projectID
|
||||
DestThemSendDelegatorRemote _ remoteID _ <- get404 delegID
|
||||
DestTopicRemote destID _ <- getJust remoteID
|
||||
Entity _ (DestHolderProject _ j) <-
|
||||
getBy404 $ UniqueDestHolderProject destID
|
||||
unless (j == projectID) notFound
|
||||
|
|
|
|||
|
|
@ -165,7 +165,6 @@ import Vervis.Access
|
|||
import Vervis.ActivityPub
|
||||
import Vervis.API
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Federation.Collab
|
||||
import Vervis.Federation.Offer
|
||||
import Vervis.FedURI
|
||||
import Vervis.Form.Repo
|
||||
|
|
|
|||
|
|
@ -3121,6 +3121,83 @@ changes hLocal ctx =
|
|||
, addUnique' "ComponentFurtherRemote" "" ["component", "collab"]
|
||||
-- 564
|
||||
, addEntities model_564_permit
|
||||
-- 565
|
||||
, removeUnique' "PermitTopicExtendLocal" ""
|
||||
-- 566
|
||||
, removeUnique' "PermitTopicExtendLocal" "Topic"
|
||||
-- 567
|
||||
, removeUnique' "PermitTopicExtendRemote" ""
|
||||
-- 568
|
||||
, removeUnique' "PermitTopicExtendRemote" "Topic"
|
||||
-- 569
|
||||
, unchecked $ lift $ do
|
||||
recips <- selectList [] []
|
||||
for_ recips $ \ (Entity recipID (CollabRecipLocal565 collabID personID)) -> do
|
||||
Collab565 role <- getJust collabID
|
||||
permitID <- insert $ Permit565 personID role
|
||||
topicID <- insert $ PermitTopicLocal565 permitID
|
||||
|
||||
mr <- getValBy $ UniqueCollabTopicRepo565 collabID
|
||||
for_ mr $ \ (CollabTopicRepo565 _ repoID) ->
|
||||
insert_ $ PermitTopicRepo565 topicID repoID
|
||||
md <- getValBy $ UniqueCollabTopicDeck565 collabID
|
||||
for_ md $ \ (CollabTopicDeck565 _ deckID) ->
|
||||
insert_ $ PermitTopicDeck565 topicID deckID
|
||||
ml <- getValBy $ UniqueCollabTopicLoom565 collabID
|
||||
for_ ml $ \ (CollabTopicLoom565 _ loomID) ->
|
||||
insert_ $ PermitTopicLoom565 topicID loomID
|
||||
mj <- getValBy $ UniqueCollabTopicProject565 collabID
|
||||
for_ mj $ \ (CollabTopicProject565 _ projectID) ->
|
||||
insert_ $ PermitTopicProject565 topicID projectID
|
||||
mg <- getValBy $ UniqueCollabTopicGroup565 collabID
|
||||
for_ mg $ \ (CollabTopicGroup565 _ groupID) ->
|
||||
insert_ $ PermitTopicGroup565 topicID groupID
|
||||
|
||||
fc <- getKeyBy $ UniqueCollabFulfillsLocalTopicCreation565 collabID
|
||||
g1 <- for fc $ \ fulfillsID -> do
|
||||
insert_ $ PermitFulfillsTopicCreation565 permitID
|
||||
actorID <- person565Actor <$> getJust personID
|
||||
outboxID <- actor565Outbox <$> getJust actorID
|
||||
let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
|
||||
createID <- insert $ OutboxItem565 outboxID doc defaultTime
|
||||
insert $ PermitPersonGesture565 permitID createID
|
||||
|
||||
fi <- getBy $ UniqueCollabFulfillsInvite565 collabID
|
||||
g2 <- for fi $ \ (Entity fulfillsID (CollabFulfillsInvite565 _ acceptID)) -> do
|
||||
pfi <- insert $ PermitFulfillsInvite565 permitID
|
||||
l <- getValBy $ UniqueCollabInviterLocal565 fulfillsID
|
||||
for_ l $ \ (CollabInviterLocal565 _ inviteID) ->
|
||||
insert_ $ PermitTopicGestureLocal565 pfi inviteID
|
||||
r <- getValBy $ UniqueCollabInviterRemote565 fulfillsID
|
||||
for_ r $ \ (CollabInviterRemote565 _ actorID inviteID) ->
|
||||
insert_ $ PermitTopicGestureRemote565 pfi actorID inviteID
|
||||
insert_ $ PermitTopicAcceptLocal565 pfi topicID acceptID
|
||||
a <- getValBy $ UniqueCollabRecipLocalAcceptCollab565 recipID
|
||||
for a $ \ (CollabRecipLocalAccept565 _ _ acceptID) ->
|
||||
insert $ PermitPersonGesture565 permitID acceptID
|
||||
|
||||
fj <- getKeyBy $ UniqueCollabFulfillsJoin565 collabID
|
||||
g3 <- for fj $ \ fulfillsID -> do
|
||||
CollabRecipLocalJoin565 _ _ joinID <- getValByJust $ UniqueCollabRecipLocalJoinCollab565 recipID
|
||||
insert $ PermitPersonGesture565 permitID joinID
|
||||
|
||||
me <- getValBy $ UniqueCollabEnable565 collabID
|
||||
for_ (liftA2 (,) me (g1 <|> join g2 <|> g3)) $ \ (CollabEnable565 _ grantID, gestureID) -> do
|
||||
enableID <- insert $ PermitTopicEnableLocal565 gestureID topicID grantID
|
||||
d <- getBy $ UniqueCollabDelegLocalRecip565 recipID
|
||||
for_ d $ \ (Entity cdl (CollabDelegLocal565 _ _ delegID)) -> do
|
||||
sendID <- insert $ PermitPersonSendDelegator565 gestureID delegID
|
||||
for_ mj $ \ (CollabTopicProject565 _ projectID) -> do
|
||||
gs <- E.select $ E.from $ \ (enable `E.InnerJoin` comp `E.InnerJoin` further) -> do
|
||||
E.on $ enable E.^. ComponentEnable565Id E.==. further E.^. ComponentFurtherLocal565Component
|
||||
E.on $ enable E.^. ComponentEnable565Component E.==. comp E.^. Component565Id
|
||||
E.where_ $
|
||||
comp E.^. Component565Project E.==. E.val projectID E.&&.
|
||||
further E.^. ComponentFurtherLocal565Collab E.==. E.val cdl
|
||||
return $ further E.^. ComponentFurtherLocal565Grant
|
||||
insertMany_ $ map (PermitTopicExtendLocal565 sendID enableID . E.unValue) gs
|
||||
-- 570
|
||||
, addEntities model_570_source_dest
|
||||
]
|
||||
|
||||
migrateDB
|
||||
|
|
|
|||
|
|
@ -67,6 +67,7 @@ module Vervis.Migration.Entities
|
|||
, model_551_group_collab
|
||||
, model_552_collab_deleg
|
||||
, model_564_permit
|
||||
, model_570_source_dest
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -260,3 +261,6 @@ model_552_collab_deleg = $(schema "552_2023-11-21_collab_deleg")
|
|||
|
||||
model_564_permit :: [Entity SqlBackend]
|
||||
model_564_permit = $(schema "564_2023-11-22_permit")
|
||||
|
||||
model_570_source_dest :: [Entity SqlBackend]
|
||||
model_570_source_dest = $(schema "570_2023-12-09_source_dest")
|
||||
|
|
|
|||
|
|
@ -537,3 +537,6 @@ makeEntitiesMigration "553"
|
|||
|
||||
makeEntitiesMigration "554"
|
||||
$(modelFile "migrations/554_2023-11-21_further_local_deleg.model")
|
||||
|
||||
makeEntitiesMigration "565"
|
||||
$(modelFile "migrations/565_2023-12-09_collab_permit.model")
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@ module Vervis.Persist.Collab
|
|||
( getCollabTopic
|
||||
, getCollabTopic'
|
||||
, getCollabRecip
|
||||
, getPermitTopicLocal
|
||||
, getPermitTopic
|
||||
, getStemIdent
|
||||
, getStemProject
|
||||
|
|
@ -112,6 +113,29 @@ getCollabRecip collabID =
|
|||
"Collab without recip"
|
||||
"Collab with both local and remote recip"
|
||||
|
||||
getPermitTopicLocal
|
||||
:: MonadIO m
|
||||
=> PermitTopicLocalId
|
||||
-> ReaderT SqlBackend m (LocalActorBy Key)
|
||||
getPermitTopicLocal localID = do
|
||||
options <-
|
||||
sequence
|
||||
[ fmap (LocalActorRepo . permitTopicRepoRepo) <$>
|
||||
getValBy (UniquePermitTopicRepo localID)
|
||||
, fmap (LocalActorDeck . permitTopicDeckDeck) <$>
|
||||
getValBy (UniquePermitTopicDeck localID)
|
||||
, fmap (LocalActorLoom . permitTopicLoomLoom) <$>
|
||||
getValBy (UniquePermitTopicLoom localID)
|
||||
, fmap (LocalActorProject . permitTopicProjectProject) <$>
|
||||
getValBy (UniquePermitTopicProject localID)
|
||||
, fmap (LocalActorGroup . permitTopicGroupGroup) <$>
|
||||
getValBy (UniquePermitTopicGroup localID)
|
||||
]
|
||||
exactlyOneJust
|
||||
options
|
||||
"Found Permit without topic"
|
||||
"Found Permit with multiple topics"
|
||||
|
||||
getPermitTopic
|
||||
:: MonadIO m
|
||||
=> PermitId
|
||||
|
|
@ -128,25 +152,7 @@ getPermitTopic permitID = do
|
|||
"Permit without topic"
|
||||
"Permit with both local and remote topic"
|
||||
bitraverse
|
||||
(\ localID -> (localID,) <$> do
|
||||
options <-
|
||||
sequence
|
||||
[ fmap (LocalActorRepo . permitTopicRepoRepo) <$>
|
||||
getValBy (UniquePermitTopicRepo localID)
|
||||
, fmap (LocalActorDeck . permitTopicDeckDeck) <$>
|
||||
getValBy (UniquePermitTopicDeck localID)
|
||||
, fmap (LocalActorLoom . permitTopicLoomLoom) <$>
|
||||
getValBy (UniquePermitTopicLoom localID)
|
||||
, fmap (LocalActorProject . permitTopicProjectProject) <$>
|
||||
getValBy (UniquePermitTopicProject localID)
|
||||
, fmap (LocalActorGroup . permitTopicGroupGroup) <$>
|
||||
getValBy (UniquePermitTopicGroup localID)
|
||||
]
|
||||
exactlyOneJust
|
||||
options
|
||||
"Found Permit without topic"
|
||||
"Found Permit with multiple topics"
|
||||
)
|
||||
(\ localID -> (localID,) <$> getPermitTopicLocal localID)
|
||||
(\ (Entity topicID (PermitTopicRemote _ actorID)) ->
|
||||
return (topicID, actorID)
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -31,6 +31,8 @@ import Network.FedURI
|
|||
import Yesod.Auth.Unverified
|
||||
import Yesod.Hashids
|
||||
|
||||
import qualified Web.ActivityPub as AP
|
||||
|
||||
import Database.Persist.Local
|
||||
|
||||
import Vervis.Foundation
|
||||
|
|
@ -54,13 +56,22 @@ personLinkFedW (Left (ep, a)) = personLinkW ep a
|
|||
personLinkFedW (Right (inztance, object, actor)) =
|
||||
[whamlet|
|
||||
<a href="#{renderObjURI uActor}">
|
||||
#{marker $ remoteActorType actor} #
|
||||
$maybe name <- remoteActorName actor
|
||||
#{name}
|
||||
#{name} @ #{renderAuthority $ instanceHost inztance}
|
||||
$nothing
|
||||
#{renderAuthority $ instanceHost inztance}#{localUriPath $ remoteObjectIdent object}
|
||||
|]
|
||||
where
|
||||
uActor = ObjURI (instanceHost inztance) (remoteObjectIdent object)
|
||||
marker = \case
|
||||
AP.ActorTypePerson -> '~'
|
||||
AP.ActorTypeRepo -> '^'
|
||||
AP.ActorTypeTicketTracker -> '='
|
||||
AP.ActorTypePatchTracker -> '+'
|
||||
AP.ActorTypeProject -> '$'
|
||||
AP.ActorTypeTeam -> '&'
|
||||
AP.ActorTypeOther _ -> '?'
|
||||
|
||||
followW :: Route App -> Route App -> FollowerSetId -> Widget
|
||||
followW followRoute unfollowRoute fsid = do
|
||||
|
|
|
|||
|
|
@ -19,19 +19,28 @@ module Vervis.Widget.Tracker
|
|||
, projectNavW
|
||||
, componentLinkFedW
|
||||
, projectLinkFedW
|
||||
, groupLinkFedW
|
||||
, actorLinkFedW
|
||||
, groupNavW
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Bifunctor
|
||||
import Database.Persist
|
||||
import Database.Persist.Types
|
||||
import Yesod.Core.Widget
|
||||
import Yesod.Persist.Core
|
||||
|
||||
import Network.FedURI
|
||||
import Yesod.Hashids
|
||||
|
||||
import qualified Web.ActivityPub as AP
|
||||
|
||||
import Vervis.Actor
|
||||
import Vervis.Data.Collab
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
import Vervis.Settings
|
||||
|
||||
deckNavW :: Entity Deck -> Actor -> Widget
|
||||
|
|
@ -94,19 +103,72 @@ componentLinkFedW (Right (inztance, object, actor)) =
|
|||
projectLinkFedW
|
||||
:: Either (ProjectId, Actor) (Instance, RemoteObject, RemoteActor)
|
||||
-> Widget
|
||||
projectLinkFedW (Left (j, actor)) = do
|
||||
h <- encodeKeyHashid j
|
||||
projectLinkFedW = actorLinkFedW . bimap (first LocalActorProject) id
|
||||
|
||||
groupLinkFedW
|
||||
:: Either (GroupId, Actor) (Instance, RemoteObject, RemoteActor)
|
||||
-> Widget
|
||||
groupLinkFedW = actorLinkFedW . bimap (first LocalActorGroup) id
|
||||
|
||||
actorLinkW :: LocalActorBy Key -> Actor -> Widget
|
||||
actorLinkW (LocalActorPerson k) actor = do
|
||||
p <- handlerToWidget $ runDB $ getJust k
|
||||
h <- encodeKeyHashid k
|
||||
[whamlet|
|
||||
<a href=@{PersonR h}>
|
||||
~#{username2text $ personUsername p} #{actorName actor}
|
||||
|]
|
||||
actorLinkW (LocalActorRepo k) actor = do
|
||||
h <- encodeKeyHashid k
|
||||
[whamlet|
|
||||
<a href=@{RepoR h}>
|
||||
^#{keyHashidText h} #{actorName actor}
|
||||
|]
|
||||
actorLinkW (LocalActorDeck k) actor = do
|
||||
h <- encodeKeyHashid k
|
||||
[whamlet|
|
||||
<a href=@{DeckR h}>
|
||||
=#{keyHashidText h} #{actorName actor}
|
||||
|]
|
||||
actorLinkW (LocalActorLoom k) actor = do
|
||||
h <- encodeKeyHashid k
|
||||
[whamlet|
|
||||
<a href=@{LoomR h}>
|
||||
+#{keyHashidText h} #{actorName actor}
|
||||
|]
|
||||
actorLinkW (LocalActorProject k) actor = do
|
||||
h <- encodeKeyHashid k
|
||||
[whamlet|
|
||||
<a href=@{ProjectR h}>
|
||||
\$#{keyHashidText h} #{actorName actor}
|
||||
|]
|
||||
projectLinkFedW (Right (inztance, object, actor)) =
|
||||
actorLinkW (LocalActorGroup k) actor = do
|
||||
h <- encodeKeyHashid k
|
||||
[whamlet|
|
||||
<a href=@{GroupR h}>
|
||||
&#{keyHashidText h} #{actorName actor}
|
||||
|]
|
||||
|
||||
actorLinkFedW
|
||||
:: Either (LocalActorBy Key, Actor) (Instance, RemoteObject, RemoteActor)
|
||||
-> Widget
|
||||
actorLinkFedW (Left (c, a)) = actorLinkW c a
|
||||
actorLinkFedW (Right (inztance, object, actor)) =
|
||||
[whamlet|
|
||||
<a href="#{renderObjURI uActor}">
|
||||
#{marker $ remoteActorType actor} #
|
||||
$maybe name <- remoteActorName actor
|
||||
#{name}
|
||||
#{name} @ #{renderAuthority $ instanceHost inztance}
|
||||
$nothing
|
||||
#{renderAuthority $ instanceHost inztance}#{localUriPath $ remoteObjectIdent object}
|
||||
|]
|
||||
where
|
||||
uActor = ObjURI (instanceHost inztance) (remoteObjectIdent object)
|
||||
marker = \case
|
||||
AP.ActorTypePerson -> '~'
|
||||
AP.ActorTypeRepo -> '^'
|
||||
AP.ActorTypeTicketTracker -> '='
|
||||
AP.ActorTypePatchTracker -> '+'
|
||||
AP.ActorTypeProject -> '$'
|
||||
AP.ActorTypeTeam -> '&'
|
||||
AP.ActorTypeOther _ -> '?'
|
||||
|
|
|
|||
|
|
@ -880,8 +880,8 @@ instance ActivityPub ResourceWithCollections where
|
|||
data Project u = Project
|
||||
{ projectActor :: Actor u
|
||||
, projectTracker :: Maybe (ObjURI u)
|
||||
, projectChildren :: [ObjURI u]
|
||||
, projectParents :: [ObjURI u]
|
||||
, projectChildren :: LocalURI
|
||||
, projectParents :: LocalURI
|
||||
, projectComponents :: LocalURI
|
||||
, projectCollaborators :: LocalURI
|
||||
}
|
||||
|
|
@ -895,36 +895,22 @@ instance ActivityPub Project where
|
|||
fmap (h,) $
|
||||
Project a
|
||||
<$> o .:? "ticketsTrackedBy"
|
||||
<*> (do c <- o .: "subprojects"
|
||||
typ <- c .: "type"
|
||||
unless (typ == ("Collection" :: Text)) $
|
||||
fail "subprojects.type isn't Collection"
|
||||
items <- c .: "items"
|
||||
mtotal <- c .:? "totalItems"
|
||||
for_ mtotal $ \ total ->
|
||||
unless (length items == total) $
|
||||
fail "Incorrect totalItems"
|
||||
return items
|
||||
)
|
||||
<*> o .:? "context" .!= []
|
||||
<*> withAuthorityO h (o .: "subprojects")
|
||||
<*> withAuthorityO h (o .: "context")
|
||||
<*> withAuthorityO h (o .: "components")
|
||||
<*> withAuthorityO h (o .: "collaborators")
|
||||
toSeries h (Project actor tracker children parents components collabs)
|
||||
= toSeries h actor
|
||||
<> "ticketsTrackedBy" .=? tracker
|
||||
<> "subprojects" `pair` pairs
|
||||
( "type" .= ("Collection" :: Text)
|
||||
<> "items" .= children
|
||||
<> "totalItems" .= length children
|
||||
)
|
||||
<> "context" .= parents
|
||||
<> "subprojects" .= ObjURI h children
|
||||
<> "context" .= ObjURI h parents
|
||||
<> "components" .= ObjURI h components
|
||||
<> "collaborators" .= ObjURI h collabs
|
||||
|
||||
data Team u = Team
|
||||
{ teamActor :: Actor u
|
||||
, teamChildren :: [ObjURI u]
|
||||
, teamParents :: [ObjURI u]
|
||||
, teamChildren :: LocalURI
|
||||
, teamParents :: LocalURI
|
||||
, teamMembers :: LocalURI
|
||||
}
|
||||
|
||||
|
|
@ -936,27 +922,13 @@ instance ActivityPub Team where
|
|||
fail "Actor type isn't Team"
|
||||
fmap (h,) $
|
||||
Team a
|
||||
<$> (do c <- o .: "subteams"
|
||||
typ <- c .: "type"
|
||||
unless (typ == ("Collection" :: Text)) $
|
||||
fail "subteams.type isn't Collection"
|
||||
items <- c .: "items"
|
||||
mtotal <- c .:? "totalItems"
|
||||
for_ mtotal $ \ total ->
|
||||
unless (length items == total) $
|
||||
fail "Incorrect totalItems"
|
||||
return items
|
||||
)
|
||||
<*> o .:? "context" .!= []
|
||||
<$> withAuthorityO h (o .: "subteams")
|
||||
<*> withAuthorityO h (o .: "context")
|
||||
<*> withAuthorityO h (o .: "members")
|
||||
toSeries h (Team actor children parents members)
|
||||
= toSeries h actor
|
||||
<> "subteams" `pair` pairs
|
||||
( "type" .= ("Collection" :: Text)
|
||||
<> "items" .= children
|
||||
<> "totalItems" .= length children
|
||||
)
|
||||
<> "context" .= parents
|
||||
<> "subteams" .= ObjURI h children
|
||||
<> "context" .= ObjURI h parents
|
||||
<> "members" .= ObjURI h members
|
||||
|
||||
data Audience u = Audience
|
||||
|
|
@ -1120,7 +1092,7 @@ instance ActivityPub Note where
|
|||
<> "mediaType" .= ("text/html" :: Text)
|
||||
|
||||
data RelationshipProperty =
|
||||
RelDependsOn | RelHasCollab | RelHasMember
|
||||
RelDependsOn | RelHasCollab | RelHasMember | RelHasChild | RelHasParent
|
||||
deriving Eq
|
||||
|
||||
instance FromJSON RelationshipProperty where
|
||||
|
|
@ -1130,6 +1102,8 @@ instance FromJSON RelationshipProperty where
|
|||
| t == "dependsOn" = pure RelDependsOn
|
||||
| t == "hasCollaborator" = pure RelHasCollab
|
||||
| t == "hasMember" = pure RelHasMember
|
||||
| t == "hasChild" = pure RelHasChild
|
||||
| t == "hasParent" = pure RelHasParent
|
||||
| otherwise = fail $ "Unrecognized relationship: " ++ T.unpack t
|
||||
|
||||
instance ToJSON RelationshipProperty where
|
||||
|
|
@ -1139,6 +1113,8 @@ instance ToJSON RelationshipProperty where
|
|||
RelDependsOn -> "dependsOn" :: Text
|
||||
RelHasCollab -> "hasCollaborator"
|
||||
RelHasMember -> "hasMember"
|
||||
RelHasChild -> "hasChild"
|
||||
RelHasParent -> "hasParent"
|
||||
|
||||
data Relationship u = Relationship
|
||||
{ relationshipId :: Maybe (ObjURI u)
|
||||
|
|
|
|||
28
templates/group/children.hamlet
Normal file
28
templates/group/children.hamlet
Normal file
|
|
@ -0,0 +1,28 @@
|
|||
$# This file is part of Vervis.
|
||||
$#
|
||||
$# Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
$#
|
||||
$# ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
$#
|
||||
$# The author(s) have dedicated all copyright and related and neighboring
|
||||
$# rights to this software to the public domain worldwide. This software is
|
||||
$# distributed without any warranty.
|
||||
$#
|
||||
$# You should have received a copy of the CC0 Public Domain Dedication along
|
||||
$# with this software. If not, see
|
||||
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
|
||||
^{groupNavW (Entity groupID group) actor}
|
||||
|
||||
<h2>Children
|
||||
|
||||
<table>
|
||||
<tr>
|
||||
<th>Role
|
||||
<th>Since
|
||||
<th>Child
|
||||
$forall (role, since, child) <- children
|
||||
<tr>
|
||||
<td>#{show role}
|
||||
<td>#{showDate since}
|
||||
<td>^{groupLinkFedW child}
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
$# This file is part of Vervis.
|
||||
$#
|
||||
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
|
||||
$# Written in 2016, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
$#
|
||||
$# ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
$#
|
||||
|
|
@ -12,7 +12,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
|
|||
$# with this software. If not, see
|
||||
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
|
||||
<form method=POST action=@{GroupMembersR shar} enctype=#{enctype}>
|
||||
<form method=POST action=@{GroupInviteR groupHash} enctype=#{enctype}>
|
||||
^{widget}
|
||||
<div class="submit">
|
||||
<input type="submit">
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|||
<td>#{show role}
|
||||
<td>^{personLinkFedW person}
|
||||
<td>#{showDate since}
|
||||
$#<td>^{buttonW POST "Remove" (GroupRemoveR groupHash ctID)}
|
||||
<td>^{buttonW POST "Remove" (GroupRemoveR groupHash ctID)}
|
||||
|
||||
<h2>Invites
|
||||
|
||||
|
|
@ -43,7 +43,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|||
<td>#{show role}
|
||||
<td>#{showDate time}
|
||||
|
||||
$#<a href=@{ProjectInviteR projectHash}>Invite…
|
||||
<a href=@{GroupInviteR groupHash}>Invite…
|
||||
|
||||
<h2>Joins
|
||||
|
||||
|
|
|
|||
|
|
@ -30,5 +30,11 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|||
<span>
|
||||
<a href=@{GroupMembersR groupHash}>
|
||||
[🤝 Members]
|
||||
<span>
|
||||
<a href=@{GroupChildrenR groupHash}>
|
||||
[🐛 Children]
|
||||
<span>
|
||||
<a href=@{GroupParentsR groupHash}>
|
||||
[🦋 Parents]
|
||||
<span>
|
||||
[✏ Edit]
|
||||
|
|
|
|||
28
templates/group/parents.hamlet
Normal file
28
templates/group/parents.hamlet
Normal file
|
|
@ -0,0 +1,28 @@
|
|||
$# This file is part of Vervis.
|
||||
$#
|
||||
$# Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
$#
|
||||
$# ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
$#
|
||||
$# The author(s) have dedicated all copyright and related and neighboring
|
||||
$# rights to this software to the public domain worldwide. This software is
|
||||
$# distributed without any warranty.
|
||||
$#
|
||||
$# You should have received a copy of the CC0 Public Domain Dedication along
|
||||
$# with this software. If not, see
|
||||
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
|
||||
^{groupNavW (Entity groupID group) actor}
|
||||
|
||||
<h2>Parents
|
||||
|
||||
<table>
|
||||
<tr>
|
||||
<th>Role
|
||||
<th>Since
|
||||
<th>Child
|
||||
$forall (role, since, parent) <- parents
|
||||
<tr>
|
||||
<td>#{show role}
|
||||
<td>#{showDate since}
|
||||
<td>^{groupLinkFedW parent}
|
||||
|
|
@ -67,54 +67,48 @@ $# Comment on a ticket or merge request
|
|||
<h2>Your teams
|
||||
|
||||
<ul>
|
||||
$forall (Entity groupID _, Entity _ actor, Entity _ (Collab role)) <- groups
|
||||
$forall i <- groups
|
||||
<li>
|
||||
[
|
||||
#{show role}
|
||||
]
|
||||
<a href=@{GroupR $ hashGroup groupID}>
|
||||
&#{keyHashidText $ hashGroup groupID} #{actorName actor}
|
||||
^{item i}
|
||||
|
||||
<h2>Your repos
|
||||
|
||||
<ul>
|
||||
$forall (Entity repoID _, Entity _ actor, Entity _ (Collab role)) <- repos
|
||||
$forall i <- repos
|
||||
<li>
|
||||
[
|
||||
#{show role}
|
||||
]
|
||||
<a href=@{RepoR $ hashRepo repoID}>
|
||||
^#{keyHashidText $ hashRepo repoID} #{actorName actor}
|
||||
^{item i}
|
||||
|
||||
<h2>Your ticket trackers
|
||||
|
||||
<ul>
|
||||
$forall (Entity deckID _, Entity _ actor, Entity _ (Collab role)) <- decks
|
||||
$forall i <- decks
|
||||
<li>
|
||||
[
|
||||
#{show role}
|
||||
]
|
||||
<a href=@{DeckR $ hashDeck deckID}>
|
||||
=#{keyHashidText $ hashDeck deckID} #{actorName actor}
|
||||
^{item i}
|
||||
|
||||
<h2>Your patch trackers
|
||||
|
||||
<ul>
|
||||
$forall (Entity loomID _, Entity _ actor, Entity _ (Collab role)) <- looms
|
||||
$forall i <- looms
|
||||
<li>
|
||||
[
|
||||
#{show role}
|
||||
]
|
||||
<a href=@{LoomR $ hashLoom loomID}>
|
||||
+#{keyHashidText $ hashLoom loomID} #{actorName actor}
|
||||
^{item i}
|
||||
|
||||
<h2>Your projects
|
||||
|
||||
<ul>
|
||||
$forall (Entity projectID _, Entity _ actor, Entity _ (Collab role)) <- projects
|
||||
$forall i <- projects
|
||||
<li>
|
||||
[
|
||||
#{show role}
|
||||
]
|
||||
<a href=@{ProjectR $ hashProject projectID}>
|
||||
\$#{keyHashidText $ hashProject projectID} #{actorName actor}
|
||||
^{item i}
|
||||
|
||||
<h2>Your resources of unrecognized type
|
||||
|
||||
<ul>
|
||||
$forall i <- others
|
||||
<li>
|
||||
^{item i}
|
||||
|
||||
<h2>Your invites
|
||||
|
||||
<ul>
|
||||
$forall i <- invites
|
||||
<li>
|
||||
^{invite i}
|
||||
|
|
|
|||
28
templates/project/children.hamlet
Normal file
28
templates/project/children.hamlet
Normal file
|
|
@ -0,0 +1,28 @@
|
|||
$# This file is part of Vervis.
|
||||
$#
|
||||
$# Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
$#
|
||||
$# ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
$#
|
||||
$# The author(s) have dedicated all copyright and related and neighboring
|
||||
$# rights to this software to the public domain worldwide. This software is
|
||||
$# distributed without any warranty.
|
||||
$#
|
||||
$# You should have received a copy of the CC0 Public Domain Dedication along
|
||||
$# with this software. If not, see
|
||||
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
|
||||
^{projectNavW (Entity projectID project) actor}
|
||||
|
||||
<h2>Children
|
||||
|
||||
<table>
|
||||
<tr>
|
||||
<th>Role
|
||||
<th>Since
|
||||
<th>Child
|
||||
$forall (role, since, child) <- children
|
||||
<tr>
|
||||
<td>#{show role}
|
||||
<td>#{showDate since}
|
||||
<td>^{projectLinkFedW child}
|
||||
28
templates/project/parents.hamlet
Normal file
28
templates/project/parents.hamlet
Normal file
|
|
@ -0,0 +1,28 @@
|
|||
$# This file is part of Vervis.
|
||||
$#
|
||||
$# Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
$#
|
||||
$# ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
$#
|
||||
$# The author(s) have dedicated all copyright and related and neighboring
|
||||
$# rights to this software to the public domain worldwide. This software is
|
||||
$# distributed without any warranty.
|
||||
$#
|
||||
$# You should have received a copy of the CC0 Public Domain Dedication along
|
||||
$# with this software. If not, see
|
||||
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
|
||||
^{projectNavW (Entity projectID project) actor}
|
||||
|
||||
<h2>Parents
|
||||
|
||||
<table>
|
||||
<tr>
|
||||
<th>Role
|
||||
<th>Since
|
||||
<th>Child
|
||||
$forall (role, since, parent) <- parents
|
||||
<tr>
|
||||
<td>#{show role}
|
||||
<td>#{showDate since}
|
||||
<td>^{projectLinkFedW parent}
|
||||
|
|
@ -28,6 +28,12 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|||
<span>
|
||||
<a href=@{ProjectComponentsR projectHash}>
|
||||
[🧩 Components]
|
||||
<span>
|
||||
<a href=@{ProjectChildrenR projectHash}>
|
||||
[🐛 Children]
|
||||
<span>
|
||||
<a href=@{ProjectParentsR projectHash}>
|
||||
[🦋 Parents]
|
||||
<span>
|
||||
[No wiki]
|
||||
<span>
|
||||
|
|
|
|||
364
th/models
364
th/models
|
|
@ -920,8 +920,6 @@ PermitTopicExtendLocal
|
|||
topic PermitTopicEnableLocalId
|
||||
grant OutboxItemId
|
||||
|
||||
UniquePermitTopicExtendLocal permit
|
||||
UniquePermitTopicExtendLocalTopic topic
|
||||
UniquePermitTopicExtendLocalGrant grant
|
||||
|
||||
PermitTopicExtendRemote
|
||||
|
|
@ -929,8 +927,6 @@ PermitTopicExtendRemote
|
|||
topic PermitTopicEnableRemoteId
|
||||
grant RemoteActivityId
|
||||
|
||||
UniquePermitTopicExtendRemote permit
|
||||
UniquePermitTopicExtendRemoteTopic topic
|
||||
UniquePermitTopicExtendRemoteGrant grant
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
|
|
@ -1271,3 +1267,363 @@ StemDelegateLocal
|
|||
|
||||
UniqueStemDelegateLocal stem
|
||||
UniqueStemDelegateLocalGrant grant
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Inheritance - Receiver tracking her givers
|
||||
-- (Project tracking its children)
|
||||
-- (Team tracking its parents)
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
Source
|
||||
role Role
|
||||
|
||||
SourceHolderProject
|
||||
source SourceId
|
||||
project ProjectId
|
||||
|
||||
UniqueSourceHolderProject source
|
||||
|
||||
SourceHolderGroup
|
||||
source SourceId
|
||||
group GroupId
|
||||
|
||||
UniqueSourceHolderGroup source
|
||||
|
||||
-------------------------------- Source topic --------------------------------
|
||||
|
||||
SourceTopicLocal
|
||||
source SourceId
|
||||
|
||||
UniqueSourceTopicLocal source
|
||||
|
||||
SourceTopicProject
|
||||
holder SourceHolderProjectId
|
||||
topic SourceTopicLocalId
|
||||
child ProjectId
|
||||
|
||||
UniqueSourceTopicProject holder
|
||||
UniqueSourceTopicProjectTopic topic
|
||||
|
||||
SourceTopicGroup
|
||||
holder SourceHolderGroupId
|
||||
topic SourceTopicLocalId
|
||||
parent GroupId
|
||||
|
||||
UniqueSourceTopicGroup holder
|
||||
UniqueSourceTopicGroupTopic topic
|
||||
|
||||
SourceTopicRemote
|
||||
source SourceId
|
||||
topic RemoteActorId
|
||||
|
||||
UniqueSourceTopicRemote source
|
||||
|
||||
-------------------------------- Source flow ---------------------------------
|
||||
|
||||
SourceOriginUs
|
||||
source SourceId
|
||||
|
||||
UniqueSourceOriginUs source
|
||||
|
||||
SourceOriginThem
|
||||
source SourceId
|
||||
|
||||
UniqueSourceOriginThem source
|
||||
|
||||
-- Our collaborator's gesture
|
||||
--
|
||||
-- OriginUs: The Add that started the sequence
|
||||
-- OriginThem: N/A (they send their Accept but we don't record it)
|
||||
|
||||
SourceUsGestureLocal
|
||||
us SourceOriginUsId
|
||||
add OutboxItemId
|
||||
|
||||
UniqueSourceUsGestureLocal us
|
||||
UniqueSourceUsGestureLocalAdd add
|
||||
|
||||
SourceUsGestureRemote
|
||||
us SourceOriginUsId
|
||||
actor RemoteActorId
|
||||
add RemoteActivityId
|
||||
|
||||
UniqueSourceUsGestureRemote us
|
||||
UniqueSourceUsGestureRemoteAdd add
|
||||
|
||||
-- Our accept
|
||||
--
|
||||
-- OriginUs: I checked the Add and sending my Accept
|
||||
-- OriginThem: N/A
|
||||
|
||||
SourceUsAccept
|
||||
us SourceOriginUsId
|
||||
accept OutboxItemId
|
||||
|
||||
UniqueSourceUsAccept us
|
||||
UniqueSourceUsAcceptAccept accept
|
||||
|
||||
-- Their collaborator's gesture
|
||||
--
|
||||
-- OriginUs: N/A (they send it but we don't record it)
|
||||
-- OriginThem: The Add that started the sequence
|
||||
|
||||
SourceThemGestureLocal
|
||||
them SourceOriginThemId
|
||||
add OutboxItemId
|
||||
|
||||
UniqueSourceThemGestureLocal them
|
||||
UniqueSourceThemGestureLocalAdd add
|
||||
|
||||
SourceThemGestureRemote
|
||||
them SourceOriginThemId
|
||||
actor RemoteActorId
|
||||
add RemoteActivityId
|
||||
|
||||
UniqueSourceThemGestureRemote them
|
||||
UniqueSourceThemGestureRemoteAdd add
|
||||
|
||||
-- Their accept
|
||||
--
|
||||
-- OriginUs: Seeing our accept and their collaborator's accept, they send their
|
||||
-- own accept
|
||||
-- OriginThem: Checking the Add, they send their Accept
|
||||
|
||||
SourceThemAcceptLocal
|
||||
topic SourceTopicLocalId
|
||||
accept OutboxItemId
|
||||
|
||||
UniqueSourceThemAcceptLocal topic
|
||||
UniqueSourceThemAcceptLocalAccept accept
|
||||
|
||||
SourceThemAcceptRemote
|
||||
topic SourceTopicRemoteId
|
||||
accept RemoteActivityId
|
||||
|
||||
UniqueSourceThemAcceptRemote topic
|
||||
UniqueSourceThemAcceptRemoteAccept accept
|
||||
|
||||
-------------------------------- Source enable -------------------------------
|
||||
|
||||
-- Witnesses that, seeing their approval and our collaborator's gesture, I've
|
||||
-- sent them a delegator-Grant and now officially considering them a source of
|
||||
-- us
|
||||
SourceUsSendDelegator
|
||||
source SourceId
|
||||
grant OutboxItemId
|
||||
|
||||
UniqueSourceUsSendDelegator source
|
||||
UniqueSourceUsSendDelegatorGrant grant
|
||||
|
||||
-- Witnesses that, using the delegator-Grant, they sent us a start-Grant or
|
||||
-- extension-Grant to delegate further
|
||||
|
||||
SourceThemDelegateLocal
|
||||
source SourceThemAcceptLocalId
|
||||
grant OutboxItemId
|
||||
|
||||
UniqueSourceThemDelegateLocal source
|
||||
UniqueSourceThemDelegateLocalGrant grant
|
||||
|
||||
SourceThemDelegateRemote
|
||||
source SourceThemAcceptRemoteId
|
||||
grant RemoteActivityId
|
||||
|
||||
UniqueSourceThemDelegateRemote source
|
||||
UniqueSourceThemDelegateRemoteGrant grant
|
||||
|
||||
-- Witnesses that, seeing the delegation from them, I've sent an
|
||||
-- extension-Grant to a Dest of mine
|
||||
|
||||
SourceUsGatherLocal
|
||||
deleg SourceUsSendDelegatorId
|
||||
dest DestThemSendDelegatorLocalId
|
||||
grant OutboxItemId
|
||||
|
||||
UniqueSourceUsGatherLocal grant
|
||||
|
||||
SourceUsGatherRemote
|
||||
deleg SourceUsSendDelegatorId
|
||||
dest DestThemSendDelegatorRemoteId
|
||||
grant RemoteActivityId
|
||||
|
||||
UniqueSourceUsGatherRemote grant
|
||||
|
||||
-- Witnesses that, seeing the delegation from them, I've sent a leaf-Grant to a
|
||||
-- direct-collaborator of mine
|
||||
|
||||
SourceUsLeafLocal
|
||||
deleg SourceUsSendDelegatorId
|
||||
collab CollabDelegLocalId
|
||||
grant OutboxItemId
|
||||
|
||||
UniqueSourceUsLeafLocal grant
|
||||
|
||||
SourceUsLeafRemote
|
||||
deleg SourceUsSendDelegatorId
|
||||
collab CollabDelegRemoteId
|
||||
grant RemoteActivityId
|
||||
|
||||
UniqueSourceUsLeafRemote grant
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- Inheritance - Giver tracking her receivers
|
||||
-- (Project tracking its parents)
|
||||
-- (Team tracking its children)
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
Dest
|
||||
role Role
|
||||
|
||||
DestHolderProject
|
||||
dest DestId
|
||||
project ProjectId
|
||||
|
||||
UniqueDestHolderProject dest
|
||||
|
||||
DestHolderGroup
|
||||
dest DestId
|
||||
group GroupId
|
||||
|
||||
UniqueDestHolderGroup dest
|
||||
|
||||
---------------------------------- Dest topic --------------------------------
|
||||
|
||||
DestTopicLocal
|
||||
dest DestId
|
||||
|
||||
UniqueDestTopicLocal dest
|
||||
|
||||
DestTopicProject
|
||||
holder DestHolderProjectId
|
||||
topic DestTopicLocalId
|
||||
parent ProjectId
|
||||
|
||||
UniqueDestTopicProject holder
|
||||
UniqueDestTopicProjectTopic topic
|
||||
|
||||
DestTopicGroup
|
||||
holder DestHolderGroupId
|
||||
topic DestTopicLocalId
|
||||
child GroupId
|
||||
|
||||
UniqueDestTopicGroup holder
|
||||
UniqueDestTopicGroupTopic topic
|
||||
|
||||
DestTopicRemote
|
||||
dest DestId
|
||||
topic RemoteActorId
|
||||
|
||||
UniqueDestTopicRemote dest
|
||||
|
||||
---------------------------------- Dest flow ---------------------------------
|
||||
|
||||
DestOriginUs
|
||||
dest DestId
|
||||
|
||||
UniqueDestOriginUs dest
|
||||
|
||||
DestOriginThem
|
||||
dest DestId
|
||||
|
||||
UniqueDestOriginThem dest
|
||||
|
||||
-- Our collaborator's gesture
|
||||
--
|
||||
-- OriginUs: The Add that started the sequence
|
||||
-- OriginThem: Seeing the Add and their Accept, my collaborator has sent her
|
||||
-- Accept
|
||||
|
||||
DestUsGestureLocal
|
||||
dest DestId
|
||||
activity OutboxItemId
|
||||
|
||||
UniqueDestUsGestureLocal dest
|
||||
UniqueDestUsGestureLocalActivity activity
|
||||
|
||||
DestUsGestureRemote
|
||||
dest DestId
|
||||
actor RemoteActorId
|
||||
activity RemoteActivityId
|
||||
|
||||
UniqueDestUsGestureRemote dest
|
||||
UniqueDestUsGestureRemoteActivity activity
|
||||
|
||||
-- Our accept
|
||||
--
|
||||
-- OriginUs: Checking my collaborator's Add, I sent my Accept
|
||||
-- OriginThem: Seeing the Add, their Accept and my collaborator's Accept, I
|
||||
-- sent my Accept
|
||||
|
||||
DestUsAccept
|
||||
dest DestId
|
||||
accept OutboxItemId
|
||||
|
||||
UniqueDestUsAccept dest
|
||||
UniqueDestUsAcceptAccept accept
|
||||
|
||||
-- Their collaborator's gesture
|
||||
--
|
||||
-- OriginUs: N/A (they send it but we don't record it)
|
||||
-- OriginThem: The Add that started the sequence
|
||||
|
||||
DestThemGestureLocal
|
||||
them DestOriginThemId
|
||||
add OutboxItemId
|
||||
|
||||
UniqueDestThemGestureLocal them
|
||||
UniqueDestThemGestureLocalAdd add
|
||||
|
||||
DestThemGestureRemote
|
||||
them DestOriginThemId
|
||||
actor RemoteActorId
|
||||
add RemoteActivityId
|
||||
|
||||
UniqueDestThemGestureRemote them
|
||||
UniqueDestThemGestureRemoteAdd add
|
||||
|
||||
-- Their accept
|
||||
--
|
||||
-- OriginUs: N/A
|
||||
-- OriginThem: Seeing their collaborator's Add, they sent an Accept
|
||||
|
||||
DestThemAcceptLocal
|
||||
them DestOriginThemId
|
||||
topic DestTopicLocalId
|
||||
accept OutboxItemId
|
||||
|
||||
UniqueDestThemAcceptLocal them
|
||||
UniqueDestThemAcceptLocalTopic topic
|
||||
UniqueDestThemAcceptLocalAccept accept
|
||||
|
||||
DestThemAcceptRemote
|
||||
them DestOriginThemId
|
||||
topic DestTopicRemoteId
|
||||
accept RemoteActivityId
|
||||
|
||||
UniqueDestThemAcceptRemote them
|
||||
UniqueDestThemAcceptRemoteTopic topic
|
||||
UniqueDestThemAcceptRemoteAccept accept
|
||||
|
||||
---------------------------------- Dest enable -------------------------------
|
||||
|
||||
-- Witnesses that, seeing our approval and their collaborator's gesture,
|
||||
-- they've sent us a delegator-Grant, and we now officially consider them a
|
||||
-- dest of us
|
||||
|
||||
DestThemSendDelegatorLocal
|
||||
dest DestUsAcceptId
|
||||
topic DestTopicLocalId
|
||||
grant OutboxItemId
|
||||
|
||||
UniqueDestThemSendDelegatorLocal dest
|
||||
UniqueDestThemSendDelegatorLocalTopic topic
|
||||
UniqueDestThemSendDelegatorLocalGrant grant
|
||||
|
||||
DestThemSendDelegatorRemote
|
||||
dest DestUsAcceptId
|
||||
topic DestTopicRemoteId
|
||||
grant RemoteActivityId
|
||||
|
||||
UniqueDestThemSendDelegatorRemote dest
|
||||
UniqueDestThemSendDelegatorRemoteTopic topic
|
||||
UniqueDestThemSendDelegatorRemoteGrant grant
|
||||
|
|
|
|||
14
th/routes
14
th/routes
|
|
@ -136,6 +136,8 @@
|
|||
/publish/remove PublishRemoveR GET POST
|
||||
/publish/resolve PublishResolveR GET POST
|
||||
|
||||
/accept-invite/#PermitFulfillsInviteKeyHashid AcceptInviteR POST
|
||||
|
||||
---- Person ------------------------------------------------------------------
|
||||
|
||||
/people/#PersonKeyHashid PersonR GET
|
||||
|
|
@ -169,6 +171,13 @@
|
|||
/groups/#GroupKeyHashid/stamps/#SigKeyKeyHashid GroupStampR GET
|
||||
|
||||
/groups/#GroupKeyHashid/members GroupMembersR GET
|
||||
/groups/#GroupKeyHashid/invite GroupInviteR GET POST
|
||||
/groups/#GroupKeyHashid/remove/#CollabTopicGroupId GroupRemoveR POST
|
||||
|
||||
/groups/#GroupKeyHashid/children GroupChildrenR GET
|
||||
/groups/#GroupKeyHashid/children/local/#DestThemSendDelegatorLocalKeyHashid/live GroupChildLocalLiveR GET
|
||||
/groups/#GroupKeyHashid/children/remote/#DestThemSendDelegatorRemoteKeyHashid/live GroupChildRemoteLiveR GET
|
||||
/groups/#GroupKeyHashid/parents GroupParentsR GET
|
||||
|
||||
---- Repo --------------------------------------------------------------------
|
||||
|
||||
|
|
@ -339,3 +348,8 @@
|
|||
/projects/#ProjectKeyHashid/collabs/#CollabEnableKeyHashid/live ProjectCollabLiveR GET
|
||||
|
||||
/projects/#ProjectKeyHashid/invite-component ProjectInviteCompR GET POST
|
||||
|
||||
/projects/#ProjectKeyHashid/children ProjectChildrenR GET
|
||||
/projects/#ProjectKeyHashid/parents ProjectParentsR GET
|
||||
/projects/#ProjectKeyHashid/parents/local/#DestThemSendDelegatorLocalKeyHashid/live ProjectParentLocalLiveR GET
|
||||
/projects/#ProjectKeyHashid/parents/remote/#DestThemSendDelegatorRemoteKeyHashid/live ProjectParentRemoteLiveR GET
|
||||
|
|
|
|||
|
|
@ -171,7 +171,6 @@ library
|
|||
|
||||
--Vervis.Federation
|
||||
Vervis.Federation.Auth
|
||||
Vervis.Federation.Collab
|
||||
Vervis.Federation.Discussion
|
||||
Vervis.Federation.Offer
|
||||
--Vervis.Federation.Push
|
||||
|
|
|
|||
Loading…
Reference in a new issue