diff --git a/migrations/565_2023-12-09_collab_permit.model b/migrations/565_2023-12-09_collab_permit.model new file mode 100644 index 0000000..c8a2f97 --- /dev/null +++ b/migrations/565_2023-12-09_collab_permit.model @@ -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 diff --git a/migrations/570_2023-12-09_source_dest.model b/migrations/570_2023-12-09_source_dest.model new file mode 100644 index 0000000..f0f054e --- /dev/null +++ b/migrations/570_2023-12-09_source_dest.model @@ -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 diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs index 04c4921..22b1f72 100644 --- a/src/Vervis/Actor.hs +++ b/src/Vervis/Actor.hs @@ -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 diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index 145727a..364758c 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -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" diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index 931d35e..22ab360 100644 --- a/src/Vervis/Actor/Group.hs +++ b/src/Vervis/Actor/Group.hs @@ -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" diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index db8c47e..a8ec28a 100644 --- a/src/Vervis/Actor/Person.hs +++ b/src/Vervis/Actor/Person.hs @@ -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 diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index a0adfc4..8db73f2 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/src/Vervis/Actor/Person/Client.hs @@ -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 diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index 8248c3f..65ea074 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -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" diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index d1afb26..261c9bd 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -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) diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index ed315b6..4d094d9 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -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 diff --git a/src/Vervis/Federation/Collab.hs b/src/Vervis/Federation/Collab.hs deleted file mode 100644 index a8c2544..0000000 --- a/src/Vervis/Federation/Collab.hs +++ /dev/null @@ -1,150 +0,0 @@ -{- This file is part of Vervis. - - - - Written in 2022, 2023 by fr33domlover . - - - - ♡ 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 - - . - -} - -{-# 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 --} diff --git a/src/Vervis/Form/Tracker.hs b/src/Vervis/Form/Tracker.hs index 98c2c68..6d206d6 100644 --- a/src/Vervis/Form/Tracker.hs +++ b/src/Vervis/Form/Tracker.hs @@ -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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index ebb12e3..f28de99 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -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) diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 4bf69bd..65c7f09 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -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| + + [ + #{show role} + ] # + $maybe _ <- deleg + \ [D] # + $nothing + \ [_] # + ^{actorLinkFedW actor} +