diff --git a/migrations/549_2023-11-21_group_create.model b/migrations/549_2023-11-21_group_create.model new file mode 100644 index 0000000..c7b1eef --- /dev/null +++ b/migrations/549_2023-11-21_group_create.model @@ -0,0 +1,47 @@ +Inbox +FollowerSet + +Actor + name Text + desc Text + createdAt UTCTime + inbox InboxId + outbox OutboxId + followers FollowerSetId + justCreatedBy ActorId Maybe + + UniqueActorInbox inbox + UniqueActorOutbox outbox + UniqueActorFollowers followers + +Outbox + +OutboxItem + outbox OutboxId + activity PersistJSONObject + published UTCTime + +Group + actor ActorId + create OutboxItemId + + UniqueGroupActor actor + UniqueGroupCreate create + +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 diff --git a/migrations/551_2023-11-21_group_collab.model b/migrations/551_2023-11-21_group_collab.model new file mode 100644 index 0000000..b0c77d0 --- /dev/null +++ b/migrations/551_2023-11-21_group_collab.model @@ -0,0 +1,5 @@ +CollabTopicGroup + collab CollabId + group GroupId + + UniqueCollabTopicGroup collab diff --git a/migrations/552_2023-11-21_collab_deleg.model b/migrations/552_2023-11-21_collab_deleg.model new file mode 100644 index 0000000..9b3bc77 --- /dev/null +++ b/migrations/552_2023-11-21_collab_deleg.model @@ -0,0 +1,17 @@ +CollabDelegLocal + enable CollabEnableId + recip CollabRecipLocalId + grant OutboxItemId + + UniqueCollabDelegLocal enable + UniqueCollabDelegLocalRecip recip + UniqueCollabDelegLocalGrant grant + +CollabDelegRemote + enable CollabEnableId + recip CollabRecipRemoteId + grant RemoteActivityId + + UniqueCollabDelegRemote enable + UniqueCollabDelegRemoteRecip recip + UniqueCollabDelegRemoteGrant grant diff --git a/migrations/553_2023-11-21_collab_deleg.model b/migrations/553_2023-11-21_collab_deleg.model new file mode 100644 index 0000000..99e93fa --- /dev/null +++ b/migrations/553_2023-11-21_collab_deleg.model @@ -0,0 +1,91 @@ +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 + +CollabTopicProject + collab CollabId + project ProjectId + + UniqueCollabTopicProject collab + +Project + actor ActorId + create OutboxItemId + + UniqueProjectActor actor + UniqueProjectCreate create + +CollabTopicGroup + collab CollabId + group GroupId + + UniqueCollabTopicGroup collab + +Group + actor ActorId + create OutboxItemId + + UniqueGroupActor actor + UniqueGroupCreate create + +CollabRecipLocal + collab CollabId + person PersonId + + UniqueCollabRecipLocal collab + +CollabEnable + collab CollabId + grant OutboxItemId + + UniqueCollabEnable collab + UniqueCollabEnableGrant grant + +CollabDelegLocal + enable CollabEnableId + recip CollabRecipLocalId + grant OutboxItemId + + UniqueCollabDelegLocal enable + UniqueCollabDelegLocalRecip recip + UniqueCollabDelegLocalGrant grant diff --git a/migrations/554_2023-11-21_further_local_deleg.model b/migrations/554_2023-11-21_further_local_deleg.model new file mode 100644 index 0000000..b4710e1 --- /dev/null +++ b/migrations/554_2023-11-21_further_local_deleg.model @@ -0,0 +1,61 @@ +ComponentEnable +Actor + +Outbox + +OutboxItem + outbox OutboxId + activity PersistJSONObject + published UTCTime + +Collab + role Role + +CollabRecipLocal + collab CollabId + person PersonId + + UniqueCollabRecipLocal collab + +CollabEnable + collab CollabId + grant OutboxItemId + + UniqueCollabEnable collab + UniqueCollabEnableGrant grant + +CollabDelegLocal + enable CollabEnableId + recip CollabRecipLocalId + grant OutboxItemId + + UniqueCollabDelegLocal enable + UniqueCollabDelegLocalRecip recip + UniqueCollabDelegLocalGrant grant + +ComponentFurtherLocal + component ComponentEnableId + collab CollabRecipLocalId + collabNew CollabDelegLocalId + grant OutboxItemId + + UniqueComponentFurtherLocal component collab + UniqueComponentFurtherLocalGrant grant + +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 diff --git a/migrations/564_2023-11-22_permit.model b/migrations/564_2023-11-22_permit.model new file mode 100644 index 0000000..6851563 --- /dev/null +++ b/migrations/564_2023-11-22_permit.model @@ -0,0 +1,182 @@ +Permit + person PersonId + role Role + +-------------------------------- Permit topic -------------------------------- + +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 + +------------------------------- Permit reason -------------------------------- + +PermitFulfillsTopicCreation + permit PermitId + + UniquePermitFulfillsTopicCreation permit + +PermitFulfillsInvite + permit PermitId + + UniquePermitFulfillsInvite permit + +PermitFulfillsJoin + permit PermitId + + UniquePermitFulfillsJoin permit + +-- Person's gesture +-- +-- Join: Witnesses the initial Join that started the sequence +-- Invite: Witnesses their approval, seeing the topic's accept, and then +-- sending their own accept +-- Create: Records the Create activity that created the topic + +PermitPersonGesture + permit PermitId + activity OutboxItemId + + UniquePermitPersonGesture permit + UniquePermitPersonGestureActivity activity + +-- Topic collaborator's gesture +-- +-- Join: N/A (it happens but we don't record it) +-- Invite: Witnesses the initial Invite that started the sequence + +PermitTopicGestureLocal + fulfills PermitFulfillsInviteId + invite OutboxItemId + + UniquePermitTopicGestureLocal fulfills + UniquePermitTopicGestureLocalInvite invite + +PermitTopicGestureRemote + fulfills PermitFulfillsInviteId + actor RemoteActorId + invite RemoteActivityId + + UniquePermitTopicGestureRemote fulfills + UniquePermitTopicGestureRemoteInvite invite + +-- Topic's accept +-- +-- Join: N/A +-- Invite: Witnesses that the topic saw and approved the Invite + +PermitTopicAcceptLocal + fulfills PermitFulfillsInviteId + topic PermitTopicLocalId + accept OutboxItemId + + UniquePermitTopicAcceptLocal fulfills + UniquePermitTopicAcceptLocalTopic topic + UniquePermitTopicAcceptLocalAccept accept + +PermitTopicAcceptRemote + fulfills PermitFulfillsInviteId + topic PermitTopicRemoteId + accept RemoteActivityId + + UniquePermitTopicAcceptRemote fulfills + UniquePermitTopicAcceptRemoteTopic topic + UniquePermitTopicAcceptRemoteAccept accept + +-------------------------------- Permit enable ------------------------------- + +-- Topic's grant +-- +-- Join: Seeing the new-collaborator's Join and existing-collaborator's Accept, +-- the topic has made the link official and sent a direct-grant +-- Invite: Seeing existing-collaborator's Invite and new-collaborator's Accept, +-- the topic has made the link official and sent a direct-grant + +PermitTopicEnableLocal + permit PermitPersonGestureId + topic PermitTopicLocalId + grant OutboxItemId + + UniquePermitTopicEnableLocal permit + UniquePermitTopicEnableLocalTopic topic + UniquePermitTopicEnableLocalGrant grant + +PermitTopicEnableRemote + permit PermitPersonGestureId + topic PermitTopicRemoteId + grant RemoteActivityId + + UniquePermitTopicEnableRemote permit + UniquePermitTopicEnableRemoteTopic topic + UniquePermitTopicEnableRemoteGrant grant + +----------------------- Permit delegator+extension --------------------------- + +-- This section is only for Project or Team topics +-- Person sends delegator-Grant, topic starts sending extension-Grants + +-- Witnesses that the person used the direct-Grant to send a delegator-Grant to +-- the topic +PermitPersonSendDelegator + permit PermitPersonGestureId + grant OutboxItemId + + UniquePermitPersonSendDelegator permit + UniquePermitPersonSendDelegatorGrant grant + +-- Witnesses extension-Grants that the topic has sent, extending chains from +-- its components/subprojects or projects/superteams + +PermitTopicExtendLocal + permit PermitPersonSendDelegatorId + topic PermitTopicEnableLocalId + grant OutboxItemId + + UniquePermitTopicExtendLocal permit + UniquePermitTopicExtendLocalTopic topic + UniquePermitTopicExtendLocalGrant grant + +PermitTopicExtendRemote + permit PermitPersonSendDelegatorId + topic PermitTopicEnableRemoteId + grant RemoteActivityId + + UniquePermitTopicExtendRemote permit + UniquePermitTopicExtendRemoteTopic topic + UniquePermitTopicExtendRemoteGrant grant diff --git a/src/Data/Maybe/Local.hs b/src/Data/Maybe/Local.hs index 72bdc6e..43bb250 100644 --- a/src/Data/Maybe/Local.hs +++ b/src/Data/Maybe/Local.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2019 by fr33domlover . + - Written in 2016, 2019, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -16,9 +16,12 @@ module Data.Maybe.Local ( partitionMaybes , partitionMaybePairs + , exactlyOneJust ) where +import Data.Maybe + partitionMaybes :: [(Maybe a, b)] -> ([(a, b)], [b]) partitionMaybes = foldr f ([], []) where @@ -32,3 +35,10 @@ partitionMaybePairs = foldr f ([], [], []) f (Just x, Nothing) (xs, ys, ps) = (x : xs, ys, ps) f (Nothing, Just y) (xs, ys, ps) = (xs, y : ys, ps) f (Just x, Just y) (xs, ys, ps) = (xs, ys, (x, y) : ps) + +exactlyOneJust :: Monad m => [Maybe a] -> String -> String -> m a +exactlyOneJust l none multiple = + case catMaybes l of + [] -> error none + [x] -> pure x + _ -> error multiple diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index b28e90f..895c169 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -34,6 +34,7 @@ import Control.Applicative import Control.Exception hiding (Handler, try) import Control.Monad import Control.Monad.IO.Class +import Control.Monad.Logger.CallStack import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader @@ -158,23 +159,8 @@ handleViaActor personID maybeCap localRecips remoteRecips fwdHosts action = do verifyResourceAddressed :: (MonadSite m, YesodHashids (SiteEnv m)) - => RecipientRoutes -> GrantResourceBy Key -> ExceptT Text m () -verifyResourceAddressed localRecips resource = do - resourceHash <- hashGrantResource resource - fromMaybeE (verify resourceHash) "Local resource not addressed" - where - verify (GrantResourceRepo r) = do - routes <- lookup r $ recipRepos localRecips - guard $ routeRepo routes - verify (GrantResourceDeck d) = do - routes <- lookup d $ recipDecks localRecips - guard $ routeDeck $ familyDeck routes - verify (GrantResourceLoom l) = do - routes <- lookup l $ recipLooms localRecips - guard $ routeLoom $ familyLoom routes - verify (GrantResourceProject r) = do - routes <- lookup r $ recipProjects localRecips - guard $ routeProject routes + => RecipientRoutes -> LocalActorBy Key -> ExceptT Text m () +verifyResourceAddressed localRecips resource = logWarn "Vervis.API verifyResourceAddressed" verifyRemoteAddressed :: Monad m => [(Host, NonEmpty LocalURI)] -> FedURI -> ExceptT Text m () diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs index a803485..04c4921 100644 --- a/src/Vervis/Actor.hs +++ b/src/Vervis/Actor.hs @@ -78,10 +78,13 @@ module Vervis.Actor , RemoteRecipient (..) , sendToLocalActors + + , actorIsAddressed ) where import Control.Concurrent.STM.TVar +import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe @@ -689,3 +692,25 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do E.on $ f E.^. FollowActor E.==. p E.^. actorField E.where_ $ f E.^. FollowTarget `E.in_` E.valList followerSetIDs return $ p E.^. persistIdField + +actorIsAddressed :: RecipientRoutes -> LocalActor -> Bool +actorIsAddressed recips = isJust . verify + where + verify (LocalActorPerson p) = do + routes <- lookup p $ recipPeople recips + guard $ routePerson routes + verify (LocalActorGroup g) = do + routes <- lookup g $ recipGroups recips + guard $ routeGroup routes + verify (LocalActorRepo r) = do + routes <- lookup r $ recipRepos recips + guard $ routeRepo routes + verify (LocalActorDeck d) = do + routes <- lookup d $ recipDecks recips + guard $ routeDeck $ familyDeck routes + verify (LocalActorLoom l) = do + routes <- lookup l $ recipLooms recips + guard $ routeLoom $ familyLoom routes + verify (LocalActorProject j) = do + routes <- lookup j $ recipProjects recips + guard $ routeProject routes diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index 864c146..145727a 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -14,6 +14,7 @@ -} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} module Vervis.Actor.Common ( actorFollow @@ -227,16 +228,16 @@ actorFollow parseFollowee grabActor unread getFollowee getSieve makeLocalActor m -- * Otherwise, just ignore the Accept -- * Otherwise respond with error topicAccept - :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) + :: forall topic. + (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) => (topic -> ActorId) - -> (forall f. f topic -> GrantResourceBy f) -> (forall f. f topic -> ComponentBy f) -> UTCTime -> Key topic -> Verse -> AP.Accept URIMode -> ActE (Text, Act (), Next) -topicAccept topicActor topicResource topicComponent now recipKey (Verse authorIdMsig body) accept = do +topicAccept topicActor topicComponent now recipKey (Verse authorIdMsig body) accept = do -- Check input acceptee <- parseAccept accept @@ -282,6 +283,9 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId where + topicResource :: forall f. f topic -> LocalActorBy f + topicResource = componentActor . topicComponent + tryInviteCollab (Left (actorByKey, _actorEntity, itemID)) = (,Left actorByKey) . collabInviterLocalCollab <$> MaybeT (getValBy $ UniqueCollabInviterLocalInvite itemID) @@ -341,7 +345,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId audAccepter <- makeAudSenderWithFollowers authorIdMsig audApprover <- lift $ makeAudSenderOnly authorIdMsig recipHash <- encodeKeyHashid recipKey - let topicByHash = grantResourceLocalActor $ topicResource recipHash + let topicByHash = topicResource recipHash senderHash <- bitraverse hashLocalActor pure sender @@ -475,7 +479,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId _ -> error "topicAccept impossible" -- Prepare forwarding of Accept to my followers - let recipByID = grantResourceLocalActor $ topicResource recipKey + let recipByID = topicResource recipKey recipByHash <- hashLocalActor recipByID let sieve = makeRecipientSet [] [localActorFollowers recipByHash] @@ -491,7 +495,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId grant@(actionGrant, _, _, _) <- do Collab role <- lift $ getJust collabID lift $ prepareGrant isInvite inviterOrJoiner role - let recipByKey = grantResourceLocalActor $ topicResource recipKey + let recipByKey = topicResource recipKey _luGrant <- lift $ updateOutboxItem' recipByKey grantID actionGrant return (grantID, grant) @@ -500,7 +504,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId case maybeNew of Nothing -> done "I already have this activity in my inbox" Just (recipActorID, sieve, (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant))) -> do - let recipByID = grantResourceLocalActor $ topicResource recipKey + let recipByID = topicResource recipKey forwardActivity authorIdMsig body recipByID recipActorID sieve lift $ sendActivity recipByID recipActorID localRecipsGrant @@ -539,7 +543,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId audAccepter <- lift $ makeAudSenderOnly authorIdMsig audMe <- AudLocal [] . pure . localActorFollowers . - grantResourceLocalActor . topicResource <$> + topicResource <$> encodeKeyHashid recipKey let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = @@ -655,7 +659,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId insert_ $ StemComponentGestureRemote stemID (remoteAuthorId author) acceptID -- Prepare forwarding of Accept to my followers - let recipByID = grantResourceLocalActor $ topicResource recipKey + let recipByID = topicResource recipKey recipByHash <- hashLocalActor recipByID let sieve = makeRecipientSet [] [localActorFollowers recipByHash] @@ -667,7 +671,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId -- Prepare an Accept activity and insert to my outbox react@(actionReact, _, _, _) <- lift $ prepareReact project inviter - let recipByKey = grantResourceLocalActor $ topicResource recipKey + let recipByKey = topicResource recipKey _luReact <- lift $ updateOutboxItem' recipByKey reactID actionReact return (reactID, react) @@ -679,7 +683,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId Nothing -> done "I already have this activity in my inbox" Just Nothing -> done "Done" Just (Just (sieve, (reactID, (actionReact, localRecipsReact, remoteRecipsReact, fwdHostsReact)))) -> do - let recipByID = grantResourceLocalActor $ topicResource recipKey + let recipByID = topicResource recipKey forwardActivity authorIdMsig body recipByID recipActorID sieve lift $ sendActivity recipByID recipActorID localRecipsReact @@ -689,7 +693,7 @@ topicAccept topicActor topicResource topicComponent now recipKey (Verse authorId topicReject :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) => (topic -> ActorId) - -> (forall f. f topic -> GrantResourceBy f) + -> (forall f. f topic -> LocalActorBy f) -> UTCTime -> Key topic -> Verse @@ -815,7 +819,7 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje lift $ delete collabID -- Prepare forwarding of Reject to my followers - let recipByID = grantResourceLocalActor $ topicResource recipKey + let recipByID = topicResource recipKey recipByHash <- hashLocalActor recipByID let sieve = makeRecipientSet [] [localActorFollowers recipByHash] @@ -827,7 +831,7 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje isInvite = isLeft collab newReject@(actionReject, _, _, _) <- lift $ prepareReject isInvite inviterOrJoiner - let recipByKey = grantResourceLocalActor $ topicResource recipKey + let recipByKey = topicResource recipKey _luNewReject <- lift $ updateOutboxItem' recipByKey newRejectID actionReject return (newRejectID, newReject) @@ -836,7 +840,7 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje case maybeNew of Nothing -> done "I already have this activity in my inbox" Just (recipActorID, sieve, (newRejectID, (action, localRecips, remoteRecips, fwdHosts))) -> do - let recipByID = grantResourceLocalActor $ topicResource recipKey + let recipByID = topicResource recipKey forwardActivity authorIdMsig body recipByID recipActorID sieve lift $ sendActivity recipByID recipActorID localRecips @@ -879,7 +883,7 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje audRejecter <- makeAudSenderWithFollowers authorIdMsig audForbidder <- lift $ makeAudSenderOnly authorIdMsig recipHash <- encodeKeyHashid recipKey - let topicByHash = grantResourceLocalActor $ topicResource recipHash + let topicByHash = topicResource recipHash senderHash <- bitraverse hashLocalActor pure sender @@ -942,12 +946,12 @@ topicReject topicActor topicResource now recipKey (Verse authorIdMsig body) reje -- * Insert the Invite to my inbox -- * Forward the Invite to my followers topicInvite - :: ( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic + :: forall topic ct si. + ( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic , PersistRecordBackend ct SqlBackend , PersistRecordBackend si SqlBackend ) => (topic -> ActorId) - -> (forall f. f topic -> GrantResourceBy f) -> (forall f. f topic -> ComponentBy f) -> EntityField ct (Key topic) -> EntityField ct CollabId @@ -958,7 +962,7 @@ topicInvite -> Verse -> AP.Invite URIMode -> ActE (Text, Act (), Next) -topicInvite grabActor topicResource topicComponent topicField topicCollabField collabTopicCtor stemIdentCtor now topicKey (Verse authorIdMsig body) invite = do +topicInvite grabActor topicComponent topicField topicCollabField collabTopicCtor stemIdentCtor now topicKey (Verse authorIdMsig body) invite = do -- Check invite recipOrProject <- do @@ -1141,7 +1145,7 @@ topicInvite grabActor topicResource topicComponent topicField topicCollabField c sieve <- do topicHash <- encodeKeyHashid topicKey let topicByHash = - grantResourceLocalActor $ topicResource topicHash + topicResource topicHash return $ makeRecipientSet [] [localActorFollowers topicByHash] -- Insert Collab or Stem record to DB @@ -1152,7 +1156,7 @@ topicInvite grabActor topicResource topicComponent topicField topicCollabField c acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now insertCollab role targetDB inviteDB acceptID accept@(actionAccept, _, _, _) <- lift $ prepareAccept targetByKey - let topicByKey = grantResourceLocalActor $ topicResource topicKey + let topicByKey = topicResource topicKey _luAccept <- updateOutboxItem' topicByKey acceptID actionAccept return (acceptID, accept) Right projectDB -> do @@ -1164,7 +1168,7 @@ topicInvite grabActor topicResource topicComponent topicField topicCollabField c case maybeNew of Nothing -> done "I already have this activity in my inbox" Just (topicActorID, sieve, maybeAccept) -> do - let topicByID = grantResourceLocalActor $ topicResource topicKey + let topicByID = topicResource topicKey forwardActivity authorIdMsig body topicByID topicActorID sieve lift $ for_ maybeAccept $ \ (acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> sendActivity @@ -1174,6 +1178,9 @@ topicInvite grabActor topicResource topicComponent topicField topicCollabField c where + topicResource :: forall f. f topic -> LocalActorBy f + topicResource = componentActor . topicComponent + insertCollab role recipient inviteDB acceptID = do collabID <- insert $ Collab role fulfillsID <- insert $ CollabFulfillsInvite collabID acceptID @@ -1217,7 +1224,7 @@ topicInvite grabActor topicResource topicComponent topicField topicCollabField c Right (ObjURI h lu) -> return $ AudRemote h [lu] [] audTopic <- AudLocal [] . pure . localActorFollowers . - grantResourceLocalActor . topicResource <$> + topicResource <$> encodeKeyHashid topicKey uInvite <- getActivityURI authorIdMsig @@ -1243,7 +1250,7 @@ topicRemove , PersistRecordBackend ct SqlBackend ) => (topic -> ActorId) - -> (forall f. f topic -> GrantResourceBy f) + -> (forall f. f topic -> LocalActorBy f) -> EntityField ct (Key topic) -> EntityField ct CollabId -> UTCTime @@ -1406,13 +1413,13 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve sieve <- lift $ do topicHash <- encodeKeyHashid topicKey let topicByHash = - grantResourceLocalActor $ topicResource topicHash + topicResource topicHash return $ makeRecipientSet [] [localActorFollowers topicByHash] -- Prepare a Revoke activity and insert to my outbox revoke@(actionRevoke, _, _, _) <- lift $ prepareRevoke memberDB grantID - let recipByKey = grantResourceLocalActor $ topicResource topicKey + let recipByKey = topicResource topicKey revokeID <- insertEmptyOutboxItem' (actorOutbox topicActor) now _luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke @@ -1421,7 +1428,7 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve case maybeNew of Nothing -> done "I already have this activity in my inbox" Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke)) -> do - let topicByID = grantResourceLocalActor $ topicResource topicKey + let topicByID = topicResource topicKey forwardActivity authorIdMsig body topicByID topicActorID sieve lift $ sendActivity topicByID topicActorID localRecipsRevoke @@ -1435,7 +1442,7 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve encodeRouteLocal <- getEncodeRouteLocal recipHash <- encodeKeyHashid topicKey - let topicByHash = grantResourceLocalActor $ topicResource recipHash + let topicByHash = topicResource recipHash memberHash <- bitraverse (hashGrantRecip . bmap entityKey) pure member @@ -1475,7 +1482,7 @@ topicJoin , PersistRecordBackend ct SqlBackend ) => (topic -> ActorId) - -> (forall f. f topic -> GrantResourceBy f) + -> (forall f. f topic -> LocalActorBy f) -> EntityField ct (Key topic) -> EntityField ct CollabId -> (CollabId -> Key topic -> ct) @@ -1546,14 +1553,14 @@ topicJoin grabActor topicResource topicField topicCollabField collabTopicCtor no sieve <- lift $ do topicHash <- encodeKeyHashid topicKey let topicByHash = - grantResourceLocalActor $ topicResource topicHash + topicResource topicHash return $ makeRecipientSet [] [localActorFollowers topicByHash] return (topicActorID, sieve) case maybeNew of Nothing -> done "I already have this activity in my inbox" Just (topicActorID, sieve) -> do - let topicByID = grantResourceLocalActor $ topicResource topicKey + let topicByID = topicResource topicKey forwardActivity authorIdMsig body topicByID topicActorID sieve done "Recorded and forwarded the Join" @@ -1577,7 +1584,7 @@ topicCreateMe , PersistRecordBackend ct SqlBackend ) => (topic -> ActorId) - -> (forall f. f topic -> GrantResourceBy f) + -> (forall f. f topic -> LocalActorBy f) -> EntityField ct (Key topic) -> (CollabId -> Key topic -> ct) -> UTCTime @@ -1622,7 +1629,7 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now -- Prepare a Grant activity and insert to my outbox grant@(actionGrant, _, _, _) <- lift prepareGrant - let recipByKey = grantResourceLocalActor $ topicResource recipKey + let recipByKey = topicResource recipKey _luGrant <- updateOutboxItem' recipByKey grantID actionGrant return (recipActorID, grantID, grant) @@ -1630,7 +1637,7 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now case maybeNew of Nothing -> done "I already have this activity in my inbox" Just (recipActorID, grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) -> do - let recipByID = grantResourceLocalActor $ topicResource recipKey + let recipByID = topicResource recipKey lift $ sendActivity recipByID recipActorID localRecipsGrant remoteRecipsGrant fwdHostsGrant grantID actionGrant @@ -1653,7 +1660,7 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now recipHash <- encodeKeyHashid recipKey uCreator <- getActorURI authorIdMsig uCreate <- getActivityURI authorIdMsig - let topicByHash = grantResourceLocalActor $ topicResource recipHash + let topicByHash = topicResource recipHash audience = let audTopic = AudLocal [] [localActorFollowers topicByHash] in [audCreator, audTopic] @@ -1707,16 +1714,16 @@ topicCreateMe topicActor topicResource collabTopicFieldTopic collabTopicCtor now -- * Otherwise, if I've already seen this Grant or it's simply not related -- to me, ignore it componentGrant - :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) + :: forall topic. + (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) => (topic -> ActorId) - -> (forall f. f topic -> GrantResourceBy f) -> (forall f. f topic -> ComponentBy f) -> UTCTime -> Key topic -> Verse -> AP.Grant URIMode -> ActE (Text, Act (), Next) -componentGrant grabActor topicResource topicComponent now recipKey (Verse authorIdMsig body) grant = do +componentGrant grabActor topicComponent now recipKey (Verse authorIdMsig body) grant = do -- Check grant project <- checkDelegatorGrant grant @@ -1791,7 +1798,7 @@ componentGrant grabActor topicResource topicComponent now recipKey (Verse author sieve <- do recipHash <- encodeKeyHashid recipKey let recipByHash = - grantResourceLocalActor $ topicResource recipHash + topicResource recipHash return $ makeRecipientSet [] [localActorFollowers recipByHash] -- Update the Stem record in DB @@ -1806,7 +1813,7 @@ componentGrant grabActor topicResource topicComponent now recipKey (Verse author chain <- do Stem role <- getJust stemID chain@(actionChain, _, _, _) <- prepareChain role - let recipByKey = grantResourceLocalActor $ topicResource recipKey + let recipByKey = topicResource recipKey _luChain <- updateOutboxItem' recipByKey chainID actionChain return chain @@ -1815,7 +1822,7 @@ componentGrant grabActor topicResource topicComponent now recipKey (Verse author case maybeNew of Nothing -> done "I already have this activity in my inbox" Just (recipActorID, sieve, chainID, (actionChain, localRecipsChain, remoteRecipsChain, fwdHostsChain)) -> do - let recipByID = grantResourceLocalActor $ topicResource recipKey + let recipByID = topicResource recipKey forwardActivity authorIdMsig body recipByID recipActorID sieve lift $ sendActivity recipByID recipActorID localRecipsChain remoteRecipsChain @@ -1824,6 +1831,9 @@ componentGrant grabActor topicResource topicComponent now recipKey (Verse author where + topicResource :: forall f. f topic -> LocalActorBy f + topicResource = componentActor . topicComponent + checkDelegatorGrant g = do (role, resource, recipient, _mresult, mstart, mend, usage, mdeleg) <- parseGrant' g @@ -1833,7 +1843,7 @@ componentGrant grabActor topicResource topicComponent now recipKey (Verse author project <- bitraverse (\case - GrantResourceProject j -> return j + LocalActorProject j -> return j _ -> throwE "Resource isn't a project" ) pure @@ -1885,12 +1895,12 @@ componentGrant grabActor topicResource topicComponent now recipKey (Verse author audProject <- makeAudSenderWithFollowers authorIdMsig audMe <- AudLocal [] . pure . localActorFollowers . - grantResourceLocalActor . topicResource <$> + topicResource <$> encodeKeyHashid recipKey uProject <- lift $ getActorURI authorIdMsig uGrant <- lift $ getActivityURI authorIdMsig recipHash <- encodeKeyHashid recipKey - let topicByHash = grantResourceLocalActor $ topicResource recipHash + let topicByHash = topicResource recipHash (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = collectAudience [audProject, audMe] diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index ecb1ab4..cd90ee9 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/src/Vervis/Actor/Deck.hs @@ -191,7 +191,7 @@ deckAdd now deckID (Verse authorIdMsig body) add = do -- Verify the specified capability gives relevant access verifyCapability' - capability authorIdMsig (GrantResourceDeck deckID) AP.RoleAdmin + capability authorIdMsig (LocalActorDeck deckID) AP.RoleAdmin -- Insert the Add to my inbox mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actor) False @@ -292,7 +292,7 @@ deckCreateMe -> ActE (Text, Act (), Next) deckCreateMe = topicCreateMe - deckActor GrantResourceDeck CollabTopicDeckDeck CollabTopicDeck + deckActor LocalActorDeck CollabTopicDeckDeck CollabTopicDeck deckCreate :: UTCTime @@ -391,11 +391,11 @@ deckOffer now deckID (Verse authorIdMsig body) (AP.Offer object uTarget) = do verifyCapability' lcap authorIdMsig - (GrantResourceDeck deckID) + (LocalActorDeck deckID) AP.RoleReport -- Prepare forwarding the Offer to my followers - let recipByID = grantResourceLocalActor $ GrantResourceDeck deckID + let recipByID = LocalActorDeck deckID recipByHash <- hashLocalActor recipByID let sieve = makeRecipientSet [] [localActorFollowers recipByHash] @@ -528,7 +528,7 @@ deckResolve now deckID (Verse authorIdMsig body) (AP.Resolve uObject) = do verifyCapability'' uCap authorIdMsig - (GrantResourceDeck deckID) + (LocalActorDeck deckID) AP.RoleTriage {- @@ -744,7 +744,7 @@ deckAccept -> Verse -> AP.Accept URIMode -> ActE (Text, Act (), Next) -deckAccept = topicAccept deckActor GrantResourceDeck ComponentDeck +deckAccept = topicAccept deckActor ComponentDeck -- Meaning: An actor rejected something -- Behavior: @@ -769,7 +769,7 @@ deckReject -> Verse -> AP.Reject URIMode -> ActE (Text, Act (), Next) -deckReject = topicReject deckActor GrantResourceDeck +deckReject = topicReject deckActor LocalActorDeck -- Meaning: An actor A invited actor B to a resource -- Behavior: @@ -800,7 +800,7 @@ deckInvite -> ActE (Text, Act (), Next) deckInvite = topicInvite - deckActor GrantResourceDeck ComponentDeck + deckActor ComponentDeck CollabTopicDeckDeck CollabTopicDeckCollab CollabTopicDeck StemIdentDeck @@ -823,7 +823,7 @@ deckRemove -> ActE (Text, Act (), Next) deckRemove = topicRemove - deckActor GrantResourceDeck + deckActor LocalActorDeck CollabTopicDeckDeck CollabTopicDeckCollab -- Meaning: An actor A asked to join a resource @@ -840,7 +840,7 @@ deckJoin -> ActE (Text, Act (), Next) deckJoin = topicJoin - deckActor GrantResourceDeck + deckActor LocalActorDeck CollabTopicDeckDeck CollabTopicDeckCollab CollabTopicDeck -- Meaning: An actor is granting access-to-some-resource to another actor @@ -873,7 +873,7 @@ deckGrant -> Verse -> AP.Grant URIMode -> ActE (Text, Act (), Next) -deckGrant = componentGrant deckActor GrantResourceDeck ComponentDeck +deckGrant = componentGrant deckActor ComponentDeck ------------------------------------------------------------------------------ -- Ambiguous: Following/Resolving @@ -1014,7 +1014,7 @@ deckUndo now recipDeckID (Verse authorIdMsig body) (AP.Undo uObject) = do verifyCapability' capability authorIdMsig - (GrantResourceDeck recipDeckID) + (LocalActorDeck recipDeckID) AP.RoleTriage lift $ lift deleteFromDB diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index 61e40f2..931d35e 100644 --- a/src/Vervis/Actor/Group.hs +++ b/src/Vervis/Actor/Group.hs @@ -18,43 +18,260 @@ module Vervis.Actor.Group ) where +import Control.Applicative +import Control.Exception.Base import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger.CallStack 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.Bifoldable +import Data.Bifunctor +import Data.Bitraversable import Data.ByteString (ByteString) +import Data.Either import Data.Foldable +import Data.Maybe import Data.Text (Text) import Data.Time.Clock +import Data.Traversable import Database.Persist +import Database.Persist.Sql +import Optics.Core import Yesod.Persist.Core import qualified Data.Text as T +import qualified Database.Esqueleto as E import Control.Concurrent.Actor import Network.FedURI +import Web.Actor +import Web.Actor.Persist import Yesod.MonadSite import qualified Web.ActivityPub as AP import Control.Monad.Trans.Except.Local +import Data.Either.Local import Database.Persist.Local +import Vervis.Access +import Vervis.ActivityPub import Vervis.Actor +import Vervis.Actor.Common +import Vervis.Actor2 import Vervis.Cloth +import Vervis.Data.Actor +import Vervis.Data.Collab import Vervis.Data.Discussion import Vervis.FedURI import Vervis.Federation.Util import Vervis.Foundation -import Vervis.Model +import Vervis.Model hiding (groupCreate) +import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor) +import Vervis.RemoteActorStore +import Vervis.Persist.Actor +import Vervis.Persist.Collab import Vervis.Persist.Discussion import Vervis.Ticket +-- Meaning: Someone has created a group with my ID URI +-- Behavior: +-- * Verify I'm in a just-been-created state +-- * Verify my creator and the Create sender are the same actor +-- * Create an admin Collab record in DB +-- * Send an admin Grant to the creator +-- * Get out of the just-been-created state +groupCreateMe + :: UTCTime + -> GroupId + -> Verse + -> ActE (Text, Act (), Next) +groupCreateMe = + topicCreateMe + groupActor LocalActorGroup + CollabTopicGroupGroup CollabTopicGroup + +groupCreate + :: UTCTime + -> GroupId + -> Verse + -> AP.Create URIMode + -> ActE (Text, Act (), Next) +groupCreate now groupID verse (AP.Create obj _muTarget) = + case obj of + + AP.CreateTeam _ mlocal -> do + (h, local) <- fromMaybeE mlocal "No group id provided" + let luGroup = AP.actorId local + uMe <- do + groupHash <- encodeKeyHashid groupID + encodeRouteHome <- getEncodeRouteHome + return $ encodeRouteHome $ GroupR groupHash + unless (uMe == ObjURI h luGroup) $ + throwE "The created group id isn't me" + groupCreateMe now groupID verse + + _ -> throwE "Unsupported Create object for Group" + +-- Meaning: An actor is following someone/something +-- Behavior: +-- * Verify the target is me +-- * Record the follow in DB +-- * Publish and send an Accept to the sender and its followers +groupFollow + :: UTCTime + -> GroupId + -> Verse + -> AP.Follow URIMode + -> ActE (Text, Act (), Next) +groupFollow now recipGroupID verse follow = do + recipGroupHash <- encodeKeyHashid recipGroupID + actorFollow + (\case + GroupR d | d == recipGroupHash -> pure () + _ -> throwE "Asking to follow someone else" + ) + groupActor + False + (\ recipGroupActor () -> pure $ actorFollowers recipGroupActor) + (\ _ -> pure $ makeRecipientSet [] []) + LocalActorGroup + (\ _ -> pure []) + now recipGroupID verse follow + +-- Meaning: An actor is undoing some previous action +-- Behavior: +-- * If they're undoing their Following of me: +-- * Record it in my DB +-- * Publish and send an Accept only to the sender +-- * Otherwise respond with an error +groupUndo + :: UTCTime + -> GroupId + -> Verse + -> AP.Undo URIMode + -> ActE (Text, Act (), Next) +groupUndo now recipGroupID (Verse authorIdMsig body) (AP.Undo uObject) = do + + -- Check input + undone <- + first (\ (actor, _, item) -> (actor, item)) <$> + parseActivityURI' uObject + + -- Verify the capability URI, if provided, is one of: + -- * Outbox item URI of a local actor, i.e. a local activity + -- * A remote URI + maybeCapability <- + for (AP.activityCapability $ actbActivity body) $ \ uCap -> + nameExceptT "Undo capability" $ + first (\ (actor, _, item) -> (actor, item)) <$> + parseActivityURI' uCap + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (groupRecip, actorRecip) <- lift $ do + p <- getJust recipGroupID + (p,) <$> getJust (groupActor p) + + -- Insert the Undo to my inbox + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + for mractid $ \ _undoDB -> do + + maybeUndo <- runMaybeT $ do + + -- Find the undone activity in our DB + undoneDB <- MaybeT $ getActivity undone + + let followers = actorFollowers actorRecip + asum + [ tryUnfollow followers undoneDB authorIdMsig + ] + + (sieve, audience) <- + fromMaybeE + maybeUndo + "Undone activity isn't a Follow related to me" + + -- Prepare an Accept activity and insert to group's outbox + acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorRecip) now + accept@(actionAccept, _, _, _) <- lift $ lift $ prepareAccept audience + _luAccept <- lift $ updateOutboxItem' (LocalActorGroup recipGroupID) acceptID actionAccept + + return (groupActor groupRecip, sieve, acceptID, accept) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (actorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do + forwardActivity + authorIdMsig body (LocalActorGroup recipGroupID) actorID sieve + lift $ sendActivity + (LocalActorGroup recipGroupID) actorID localRecipsAccept + remoteRecipsAccept fwdHostsAccept acceptID actionAccept + done + "Undid the Follow, forwarded the Undo and published Accept" + + where + + tryUnfollow groupFollowersID (Left (_actorByKey, _actorE, outboxItemID)) (Left (_, actorID, _)) = do + Entity followID follow <- + MaybeT $ lift $ getBy $ UniqueFollowFollow outboxItemID + let followerID = followActor follow + followerSetID = followTarget follow + verifyTargetMe followerSetID + unless (followerID == actorID) $ + lift $ throwE "You're trying to Undo someone else's Follow" + lift $ lift $ delete followID + audSenderOnly <- lift $ lift $ lift $ makeAudSenderOnly authorIdMsig + return (makeRecipientSet [] [], [audSenderOnly]) + where + verifyTargetMe followerSetID = guard $ followerSetID == groupFollowersID + tryUnfollow groupFollowersID (Right remoteActivityID) (Right (author, _, _)) = do + Entity remoteFollowID remoteFollow <- + MaybeT $ lift $ getBy $ UniqueRemoteFollowFollow remoteActivityID + let followerID = remoteFollowActor remoteFollow + followerSetID = remoteFollowTarget remoteFollow + verifyTargetMe followerSetID + unless (followerID == remoteAuthorId author) $ + lift $ throwE "You're trying to Undo someone else's Follow" + lift $ lift $ delete remoteFollowID + audSenderOnly <- lift $ lift $ lift $ makeAudSenderOnly authorIdMsig + return (makeRecipientSet [] [], [audSenderOnly]) + where + verifyTargetMe followerSetID = guard $ followerSetID == groupFollowersID + tryUnfollow _ _ _ = mzero + + prepareAccept audience = do + encodeRouteHome <- getEncodeRouteHome + + uUndo <- getActivityURI authorIdMsig + let (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.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = uUndo + , AP.acceptResult = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + groupBehavior :: UTCTime -> GroupId -> VerseExt -> ActE (Text, Act (), Next) -groupBehavior now groupID (Left _verse@(Verse _authorIdMsig body)) = +groupBehavior now groupID (Left verse@(Verse _authorIdMsig body)) = case AP.activitySpecific $ actbActivity body of + AP.CreateActivity create -> groupCreate now groupID verse create + AP.FollowActivity follow -> groupFollow now groupID verse follow + 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/Loom.hs b/src/Vervis/Actor/Loom.hs index 5f65c57..ace96f4 100644 --- a/src/Vervis/Actor/Loom.hs +++ b/src/Vervis/Actor/Loom.hs @@ -279,11 +279,11 @@ loomOffer now loomID (Verse authorIdMsig body) (AP.Offer object uTarget) = do verifyCapability' lcap authorIdMsig - (GrantResourceLoom loomID) + (LocalActorLoom loomID) AP.RoleReport -- Prepare forwarding the Offer to my followers - let recipByID = grantResourceLocalActor $ GrantResourceLoom loomID + let recipByID = LocalActorLoom loomID recipByHash <- hashLocalActor recipByID let sieve = makeRecipientSet [] [localActorFollowers recipByHash] @@ -485,7 +485,7 @@ loomResolve now loomID (Verse authorIdMsig body) (AP.Resolve uObject) = do verifyCapability' capability authorIdMsig - (GrantResourceLoom loomID) + (LocalActorLoom loomID) AP.RoleTriage -- Prepare forwarding the Resolve to my followers & ticket diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index b815b41..db8c47e 100644 --- a/src/Vervis/Actor/Person.hs +++ b/src/Vervis/Actor/Person.hs @@ -19,6 +19,7 @@ module Vervis.Actor.Person ) where +import Control.Applicative import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger.CallStack @@ -26,6 +27,7 @@ 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) @@ -273,7 +275,13 @@ personUndo now recipPersonID (Verse authorIdMsig body) (AP.Undo uObject) = do -- Meaning: An actor accepted something -- Behavior: -- * Insert to my inbox --- * If it's a Follow I sent to them, add to my following list in DB +-- * If it's on a Follow I sent to them: +-- * Add to my following list in DB +-- * If it's on an Invite-for-me to collaborate on a resource: +-- * Verify I haven't yet seen the resource's accept +-- * Verify the Accept author is the resource +-- * Store it in the Permit record in DB +-- * Forward to my followers personAccept :: UTCTime -> PersonId @@ -298,13 +306,22 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do -- Find the accepted activity in our DB accepteeDB <- MaybeT $ getActivity acceptee - tryFollow (personActor personRecip) accepteeDB acceptDB + let recipActorID = personActor personRecip + Left <$> tryFollow recipActorID accepteeDB acceptDB <|> + Right <$> tryInvite recipActorID accepteeDB acceptDB case maybeNew of Nothing -> done "I already have this activity in my inbox" - Just Nothing -> done "Not my Follow; Just inserted to my inbox" - Just (Just ()) -> + Just Nothing -> done "Not my Follow/Invite; Just inserted to my inbox" + Just (Just (Left ())) -> done "Recorded this Accept on the Follow request I sent" + Just (Just (Right (actorID, sieve))) -> do + forwardActivity + authorIdMsig body (LocalActorPerson recipPersonID) + actorID sieve + done + "Recorded this Accept on the Invite I've had & \ + \forwarded to my followers" where @@ -359,6 +376,56 @@ personAccept now recipPersonID (Verse authorIdMsig body) accept = do -} tryFollow _ (Right _) _ = mzero + tryInvite recipActorID accepteeDB acceptDB = do + + -- Find a PermitFulfillsInvite + (permitID, fulfillsID) <- + case accepteeDB of + Left (actorByKey, _actorEntity, itemID) -> do + PermitTopicGestureLocal fulfillsID _ <- + MaybeT $ lift $ getValBy $ UniquePermitTopicGestureLocalInvite itemID + PermitFulfillsInvite permitID <- lift . lift $ getJust fulfillsID + return (permitID, fulfillsID) + Right remoteActivityID -> do + PermitTopicGestureRemote fulfillsID _ _ <- + MaybeT $ lift $ getValBy $ UniquePermitTopicGestureRemoteInvite remoteActivityID + PermitFulfillsInvite permitID <- lift . lift $ getJust fulfillsID + return (permitID, fulfillsID) + + -- Find the local person and verify it's me + Permit p _role <- lift . lift $ getJust permitID + guard $ p == recipPersonID + + lift $ do + -- Find the topic + topic <- lift $ getPermitTopic permitID + + -- Verify I haven't seen the topic's accept yet + maybeTopicAccept <- + lift $ case bimap fst fst topic of + Left localID -> void <$> getBy (UniquePermitTopicAcceptLocalTopic localID) + Right remoteID -> void <$> getBy (UniquePermitTopicAcceptRemoteTopic remoteID) + unless (isNothing maybeTopicAccept) $ + throwE "I've already seen the topic's Accept" + + -- Verify topic is the Accept sender + case (bimap snd snd topic, bimap (view _1) (view _1) acceptDB) of + (Left la, Left la') | la == la' -> pure () + (Right raID, Right ra) | raID == remoteAuthorId ra -> pure () + _ -> throwE "Accept sender isn't the Invite topic" + + -- Update the Permit record + lift $ case (bimap fst fst topic, bimap (view _3) (view _3) acceptDB) of + (Left localID, Left acceptID) -> insert_ $ PermitTopicAcceptLocal fulfillsID localID acceptID + (Right remoteID, Right acceptID) -> insert_ $ PermitTopicAcceptRemote fulfillsID remoteID acceptID + _ -> error "personAccept impossible" + + -- Prepare forwarding Accept to my followers + recipPersonHash <- encodeKeyHashid recipPersonID + let sieve = makeRecipientSet [] [LocalStagePersonFollowers recipPersonHash] + + return (recipActorID, sieve) + -- Meaning: An actor rejected something -- Behavior: -- * Insert to my inbox @@ -535,7 +602,17 @@ personAdd now recipPersonID (Verse authorIdMsig body) add = do -- Meaning: Someone invited someone to a resource -- Behavior: -- * Insert to my inbox --- * If I'm the target, forward the Invite to my followers +-- * If I'm being invited to the resource's collaborators/members +-- collection: +-- * For each Permit record I have for this resource: +-- * Verify it's not enabled yet, i.e. I'm not already a +-- collaborator, haven't received a direct-Grant +-- * Verify it's not in Invite-Accept state, already got the +-- resource's Accept and waiting for my approval or for the +-- topic's Grant +-- * Verify it's not a Join +-- * Create a Permit record in DB +-- * Forward the Invite to my followers personInvite :: UTCTime -> PersonId @@ -545,10 +622,42 @@ personInvite personInvite now recipPersonID (Verse authorIdMsig body) invite = do -- Check input - recipientOrComp <- do + maybeRoleAndResourceDB <- do let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig - (_role, _resource, target) <- parseInvite author invite - return target + (role, resource, recip) <- parseInvite author invite + let recipIsMe = + case recip of + Left (Left (GrantRecipPerson p)) | p == recipPersonID -> True + _ -> False + if not recipIsMe + then pure Nothing + else + -- If resource collabs URI is remote, HTTP GET it and its resource and its + -- managing actor, and insert to our DB. If resource is local, find it in + -- our DB. + case resource of + Left r -> + case r of + Left la -> withDBExcept $ Just . (role,) . Left <$> getLocalActorEntityE la "Invite resource not found in DB" + Right _j -> pure Nothing + Right u@(ObjURI h luColl) -> do + manager <- asksEnv envHttpManager + coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl + lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'" + AP.ResourceWithCollections _ mluCollabs _mluComps mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu + if mluCollabs == Just luColl || mluMembers == Just luColl + then Just . (role,) . Right <$> do + instanceID <- + lift $ withDB $ either entityKey id <$> insertBy' (Instance h) + result <- + ExceptT $ first (T.pack . show) <$> + fetchRemoteResource instanceID h lu + case result of + Left (Entity actorID actor) -> + return (remoteActorIdent actor, actorID, u) + Right (objectID, luManager, (Entity actorID _)) -> + return (objectID, actorID, ObjURI h luManager) + else pure Nothing maybeNew <- withDBExcept $ do @@ -558,31 +667,64 @@ personInvite now recipPersonID (Verse authorIdMsig body) invite = do (p,) <$> getJust (personActor p) maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True - for maybeInviteDB $ \ _inviteDB -> - return $ personActor personRecip + for maybeInviteDB $ \ inviteDB -> do + + maybePermit <- for maybeRoleAndResourceDB $ \ (role, resourceDB) -> do + + -- Find existing Permit records I have for this topic + -- Make sure none are enabled / in Join mode / in Invite-Accept + -- mode + checkExistingPermits + recipPersonID + (bimap (bmap entityKey) (view _2) resourceDB) + + -- Prepare forwarding Invite to my followers + recipPersonHash <- encodeKeyHashid recipPersonID + let sieve = makeRecipientSet [] [LocalStagePersonFollowers recipPersonHash] + + -- Insert Permit record to DB + insertPermit resourceDB inviteDB role + + return sieve + + return (personActor personRecip, maybePermit) case maybeNew of Nothing -> done "I already have this activity in my inbox" - Just actorID -> do - let targetIsRecip = - case recipientOrComp of - Left (Left (GrantRecipPerson p)) -> p == recipPersonID - _ -> False - if not targetIsRecip - then done "I'm not the target; Inserted to inbox" - else do - recipHash <- encodeKeyHashid recipPersonID - let sieve = - makeRecipientSet - [] - [LocalStagePersonFollowers recipHash] + Just (actorID, maybePermit) -> + case maybePermit of + Nothing -> done "I'm not the target; Inserted to inbox" + Just sieve -> do forwardActivity authorIdMsig body (LocalActorPerson recipPersonID) actorID sieve done - "I'm the target; Inserted to inbox; \ + "I'm the target; Inserted to inbox; Inserted Permit; \ \Forwarded to followers if addressed" + where + + insertPermit resourceDB inviteDB role = do + permitID <- lift $ insert $ Permit recipPersonID role + case resourceDB of + Left la -> do + localID <- lift $ insert $ PermitTopicLocal permitID + case bmap entityKey la of + LocalActorPerson _ -> throwE "insertPermit: Person not supported as a PermitTopicLocal type (you can't become a \"collaborator in a person\"" + LocalActorRepo r -> lift $ insert_ $ PermitTopicRepo localID r + LocalActorDeck d -> lift $ insert_ $ PermitTopicDeck localID d + LocalActorLoom l -> lift $ insert_ $ PermitTopicLoom localID l + LocalActorProject j -> lift $ insert_ $ PermitTopicProject localID j + LocalActorGroup g -> lift $ insert_ $ PermitTopicGroup localID g + Right (_, actorID, _) -> lift $ insert_ $ PermitTopicRemote permitID actorID + lift $ do + fulfillsID <- insert $ PermitFulfillsInvite permitID + case inviteDB of + Left (_, _, inviteID) -> + insert_ $ PermitTopicGestureLocal fulfillsID inviteID + Right (author, _, inviteID) -> + insert_ $ PermitTopicGestureRemote fulfillsID (remoteAuthorId author) inviteID + -- Meaning: Someone removed someone from a resource -- Behavior: -- * Insert to my inbox @@ -663,6 +805,21 @@ personJoin now recipPersonID (Verse authorIdMsig body) join = do -- Meaning: An actor published a Grant -- Behavior: -- * Insert to my inbox +-- +-- * If it's a direct-Grant that fulfills a Permit I have: +-- * Verify the Permit isn't already enabled +-- * Verify the sender is the Permit topic +-- * Verify the role is identical to what was requested +-- * Update the Permit record, storing the direct-Grant +-- * Forward the direct-Grant to my followers +-- * If topic is a Project or a Team: +-- * Send a delegator-Grant to the topic +-- * Update the Permit record, storing the delegator-Grant +-- +-- * If it's a extension-Grant whose capability is a delegator-Grant from +-- a Permit I have: +-- * Verify the sender is the Permit topic +-- * Update the Permit record, storing the extension-Grant personGrant :: UTCTime -> PersonId @@ -672,9 +829,18 @@ personGrant personGrant now recipPersonID (Verse authorIdMsig body) grant = do -- Check input - target <- do - --h <- lift $ objUriAuthority <$> getActorURI authorIdMsig - (_role, resource, recip, _mresult, _mstart, _mend, _usage, _mdeleg) <- + maybeMine <- do + -- Verify the capability URI, if provided, is one of: + -- * Outbox item URI of a local actor, i.e. a local activity + -- * A remote URI + maybeCapability <- + for (AP.activityCapability $ actbActivity body) $ \ uCap -> + nameExceptT "Grant.capability" $ + first (\ (actor, _, item) -> (actor, item)) <$> + parseActivityURI' uCap + + -- Basic sanity checks + (role, resource, recip, _mresult, mstart, mend, usage, mdeleg) <- parseGrant' grant case (recip, authorIdMsig) of (Left (GrantRecipPerson' p), Left (LocalActorPerson p', _, _)) @@ -684,28 +850,259 @@ personGrant now recipPersonID (Verse authorIdMsig body) grant = do | uRecip == remoteAuthorURI author -> throwE "Grant sender and target are the same remote actor" _ -> pure () - return recip + let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig + case mdeleg of + Nothing -> + unless (author == resource) $ + throwE "Not an extension but resource and actor differ" + Just _ -> + when (author == resource) $ + throwE "Extension but resource and actor are identical" - maybeGrant <- withDBExcept $ do + -- For a direct-Grant, use 'fulfills' to identify the Permit + -- For an extension-Grant, use 'capability' for that + runMaybeT $ do + guard $ usage == AP.Invoke + guard $ recip == Left (GrantRecipPerson' recipPersonID) + lift $ do + for_ mstart $ \ start -> + unless (start <= now) $ + throwE "Got a Grant that hasn't started" + for_ mend $ \ _ -> throwE "Got a Grant with expiration" + if isNothing mdeleg + then do + uFulfills <- + case AP.activityFulfills $ actbActivity body of + [] -> mzero + [u] -> pure u + _ -> lift $ throwE "Multiple fulfills" + fulfills <- + lift $ + first (\ (actor, _, item) -> (actor, item)) <$> + parseActivityURI' uFulfills + return $ Left (role, fulfills) + else do + cap <- lift $ fromMaybeE maybeCapability "Extension-Grant doesn't specify a delegator-Grant capability" + delegatorID <- + case cap of + Left (LocalActorPerson p, itemID) | p == recipPersonID -> pure itemID + _ -> lift $ throwE "Extending access to me using a delegator-Grant capability that isn't mine" + return $ Right delegatorID + + maybeNew <- withDBExcept $ do -- Grab me from DB (personRecip, actorRecip) <- lift $ do p <- getJust recipPersonID (p,) <$> getJust (personActor p) - mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True - for mractid $ \ _grantDB -> return $ personActor personRecip + maybePermit <- + for maybeMine $ + bitraverse + (\ (role, fulfills) -> do - case maybeGrant of + -- Find my Permit record, verify the roles match + fulfillsDB <- do + a <- getActivity fulfills + fromMaybeE a "Can't find fulfills in DB" + (permitID, maybeGestureID) <- do + mp <- runMaybeT $ do + x@(pt, mg) <- + tryInvite fulfillsDB <|> + tryJoin fulfillsDB <|> + tryCreate fulfillsDB + Permit p role' <- lift . lift $ getJust pt + guard $ p == recipPersonID + lift $ unless (role == AP.RXRole role') $ + throwE "Requested and granted roles differ" + return x + fromMaybeE mp "Can't find a PermitFulfills*" + + -- If Permit fulfills an Invite, verify I've approved + -- it + gestureID <- fromMaybeE maybeGestureID "I'm getting this Grant but I haven't yet approved the Invite" + + -- Verify the Permit isn't already enabled + topic <- lift $ getPermitTopic permitID + maybeTopicEnable <- + lift $ case bimap fst fst topic of + Left localID -> void <$> getBy (UniquePermitTopicEnableLocalTopic localID) + Right remoteID -> void <$> getBy (UniquePermitTopicEnableRemoteTopic remoteID) + unless (isNothing maybeTopicEnable) $ + throwE "I've already received the direct-Grant" + + -- Verify the Grant sender is the Permit topic + case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of + (Left la, Left la') | la == la' -> pure () + (Right raID, Right ra) | raID == remoteAuthorId ra -> pure () + _ -> throwE "Grant sender isn't the Permit topic" + + return (gestureID, bimap fst fst topic) + ) + (\ delegatorID -> do + Entity sendID (PermitPersonSendDelegator gestureID _) <- do + mp <- lift $ getBy $ UniquePermitPersonSendDelegatorGrant delegatorID + fromMaybeE mp "Extension-Grant.capability: I don't have such a delegator-Grant, can't find a PermitPersonSendDelegator record" + PermitPersonGesture permitID _ <- lift $ getJust gestureID + + -- Verify the Grant sender is the Permit topic + topic <- lift $ getPermitTopic permitID + case (bimap snd snd topic, bimap (view _1) (view _1) authorIdMsig) of + (Left la, Left la') | la == la' -> pure () + (Right raID, Right ra) | raID == remoteAuthorId ra -> pure () + _ -> throwE "Grant sender isn't the Permit topic" + + return (sendID, bimap fst fst topic) + ) + + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True + for mractid $ \ grantDB -> do + + for maybePermit $ + bitraverse + (\ (gestureID, topic) -> lift $ do + + -- Update the Permit record, storing the direct-Grant + case (topic, grantDB) of + (Left localID, Left (_, _, grantID)) -> + insert_ $ PermitTopicEnableLocal gestureID localID grantID + (Right remoteID, Right (_, _, grantID)) -> + insert_ $ PermitTopicEnableRemote gestureID remoteID grantID + _ -> error "personGrant impossible" + + -- Prepare forwarding direct-Grant to my followers + recipPersonHash <- encodeKeyHashid recipPersonID + let sieve = makeRecipientSet [] [LocalStagePersonFollowers recipPersonHash] + + -- Prepapre delegator-Grant and update Permit + needDeleg <- + case grantDB of + Left (la, _, _) -> + pure $ case la of + LocalActorProject _ -> True + LocalActorGroup _ -> True + _ -> False + Right (author, _, _) -> do + ra <- getJust $ remoteAuthorId author + pure $ case remoteActorType ra of + AP.ActorTypeProject -> True + AP.ActorTypeTeam -> True + _ -> False + maybeDeleg <- + if needDeleg + then Just <$> do + delegID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now + deleg@(actionDeleg, _, _, _) <- prepareDelegGrant + let recipByKey = LocalActorPerson recipPersonID + _luDeleg <- updateOutboxItem' recipByKey delegID actionDeleg + + insert_ $ PermitPersonSendDelegator gestureID delegID + + return (delegID, deleg) + else + pure Nothing + + return (personActor personRecip, sieve, maybeDeleg) + ) + (\ (sendID, topic) -> + case (topic, grantDB) of + (Left localID, Left (_, _, extID)) -> lift $ do + enableID <- do + me <- getKeyBy $ UniquePermitTopicEnableLocalTopic localID + case me of + Just e -> pure e + Nothing -> error "Impossible, Permit has the delegator-Grant but no (local) Enable" + insert_ $ PermitTopicExtendLocal sendID enableID extID + (Right remoteID, Right (_, _, extID)) -> lift $ do + enableID <- do + me <- getKeyBy $ UniquePermitTopicEnableRemoteTopic remoteID + case me of + Just e -> pure e + Nothing -> error "Impossible, Permit has the delegator-Grant but no (remote) Enable" + insert_ $ PermitTopicExtendRemote sendID enableID extID + _ -> error "personGrant impossible 2" + ) + + case maybeNew of Nothing -> done "I already have this activity in my inbox" - Just _actorID -> do - let targetIsRecip = - case target of - Left (GrantRecipPerson' p) -> p == recipPersonID - _ -> False - if not targetIsRecip - then done "I'm not the target; Inserted to inbox" - else done "I'm the target; Inserted to inbox" + Just Nothing -> done "Inserted Grant to my inbox" + Just (Just (Left (recipActorID, sieve, maybeDeleg))) -> do + let recipByID = LocalActorPerson recipPersonID + forwardActivity authorIdMsig body recipByID recipActorID sieve + lift $ for_ maybeDeleg $ \ (delegID, (actionDeleg, localRecipsDeleg, remoteRecipsDeleg, fwdHostsDeleg)) -> + sendActivity + recipByID recipActorID localRecipsDeleg + remoteRecipsDeleg fwdHostsDeleg delegID actionDeleg + done "Forwarded the direct-Grant, updated Permit, maybe published delegator-Grant" + Just (Just (Right ())) -> + done "Got an extension-Grant, updated Permit" + + where + + tryInvite fulfillsDB = do + fulfillsID <- + case fulfillsDB of + Left (_actorByKey, _actorEntity, itemID) -> do + PermitTopicGestureLocal fulfillsID _ <- + MaybeT $ lift $ getValBy $ UniquePermitTopicGestureLocalInvite itemID + return fulfillsID + Right remoteActivityID -> do + PermitTopicGestureRemote fulfillsID _ _ <- + MaybeT $ lift $ getValBy $ UniquePermitTopicGestureRemoteInvite remoteActivityID + return fulfillsID + PermitFulfillsInvite permitID <- lift . lift $ getJust fulfillsID + maybeGestureID <- lift . lift $ getKeyBy $ UniquePermitPersonGesture permitID + return (permitID, maybeGestureID) + + tryJoin fulfillsDB = do + Entity gestureID (PermitPersonGesture permitID _) <- + case fulfillsDB of + Left (_actorByKey, _actorEntity, itemID) -> + MaybeT $ lift $ getBy $ UniquePermitPersonGestureActivity itemID + Right _remoteActivityID -> mzero + _ <- MaybeT $ lift $ getBy $ UniquePermitFulfillsJoin permitID + return (permitID, Just gestureID) + + tryCreate fulfillsDB = do + Entity gestureID (PermitPersonGesture permitID _) <- + case fulfillsDB of + Left (_actorByKey, _actorEntity, itemID) -> + MaybeT $ lift $ getBy $ UniquePermitPersonGestureActivity itemID + Right _remoteActivityID -> mzero + _ <- MaybeT $ lift $ getBy $ UniquePermitFulfillsTopicCreation permitID + return (permitID, Just gestureID) + + prepareDelegGrant = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + personHash <- encodeKeyHashid recipPersonID + audTopic <- lift $ makeAudSenderOnly authorIdMsig + uTopic <- lift $ getActorURI authorIdMsig + uDirectGrant <- lift $ getActivityURI authorIdMsig + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audTopic] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Just uDirectGrant + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uDirectGrant] + , AP.actionSpecific = AP.GrantActivity AP.Grant + { AP.grantObject = AP.RXDelegator + , AP.grantContext = encodeRouteHome $ PersonR personHash + , AP.grantTarget = uTopic + , AP.grantResult = Nothing + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.Invoke + , AP.grantDelegates = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) -- Meaning: An actor has revoked some previously published Grants -- Behavior: Insert to my inbox diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index 0d3977b..a0adfc4 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/src/Vervis/Actor/Person/Client.hs @@ -54,6 +54,7 @@ import Yesod.MonadSite import qualified Web.ActivityPub as AP import Control.Monad.Trans.Except.Local +import Data.Either.Local import Database.Persist.Local import Vervis.Access @@ -61,6 +62,7 @@ import Vervis.ActivityPub import Vervis.Actor import Vervis.Actor2 import Vervis.Actor.Deck +import Vervis.Actor.Group import Vervis.Actor.Project import Vervis.Cloth import Vervis.Data.Actor @@ -80,23 +82,11 @@ import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectA import Vervis.RemoteActorStore import Vervis.Ticket -verifyResourceAddressed :: RecipientRoutes -> GrantResourceBy Key -> ActE () -verifyResourceAddressed localRecips resource = do - resourceHash <- hashGrantResource' resource - fromMaybeE (verify resourceHash) "Local resource not addressed" - where - verify (GrantResourceRepo r) = do - routes <- lookup r $ recipRepos localRecips - guard $ routeRepo routes - verify (GrantResourceDeck d) = do - routes <- lookup d $ recipDecks localRecips - guard $ routeDeck $ familyDeck routes - verify (GrantResourceLoom l) = do - routes <- lookup l $ recipLooms localRecips - guard $ routeLoom $ familyLoom routes - verify (GrantResourceProject r) = do - routes <- lookup r $ recipProjects localRecips - guard $ routeProject routes +verifyActorAddressed :: RecipientRoutes -> LocalActorBy Key -> ActE () +verifyActorAddressed localRecips resource = do + resourceHash <- hashLocalActor resource + unless (actorIsAddressed localRecips resourceHash) $ + throwE "Local resource not addressed" verifyProjectAddressed localRecips projectID = do projectHash <- encodeKeyHashid projectID @@ -141,6 +131,13 @@ verifyRemoteAddressed remoteRecips u = -- Behavior: -- * Insert to my inbox -- * Deliver without filtering +-- * If it's an Invite (that I know about) where I'm invited to a project/team/component: +-- * If I haven't yet seen the topic's approval: +-- * Respond with error, we want to wait for the approval +-- * If I saw topic's approval, but not its direct-Grant: +-- * If I already accepted, raise error +-- * Otherwise, record the approval in the Permit record in DB +-- * If I already saw both, respond with error, as Permit is already enabled clientAccept :: UTCTime -> PersonId @@ -149,6 +146,9 @@ clientAccept -> ActE OutboxItemId clientAccept now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) accept = do + -- Check input + acceptee <- parseAccept accept + (actorMeID, localRecipsFinal, acceptID) <- withDBExcept $ do -- Grab me from DB @@ -156,10 +156,56 @@ clientAccept now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost p <- getJust personMeID (p,) <$> getJust (personActor p) + -- Find the accepted activity in our DB + accepteeDB <- do + a <- getActivity acceptee + fromMaybeE a "Can't find acceptee in DB" + -- Insert the Accept activity to my outbox acceptID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now _luAccept <- lift $ updateOutboxItem' (LocalActorPerson personMeID) acceptID action + -- See if the accepted activity is an Invite to a resource, grabbing + -- the Permit record from our DB + maybePermit <- lift $ runMaybeT $ tryInvite accepteeDB + + for_ maybePermit $ \ (permitID, _fulfillsID) -> do + + -- Find the local person and verify it's me + Permit p _role <- lift $ getJust permitID + when (p == personMeID) $ do + + -- Find the topic + topic <- + lift $ + requireEitherAlt + (getKeyBy $ UniquePermitTopicLocal permitID) + (getKeyBy $ UniquePermitTopicRemote permitID) + "Permit without topic" + "Permit with both local and remote topic" + + -- If I haven't seen topic's Accept, raise error + maybeTopicAccept <- + lift $ case topic of + Left localID -> void <$> getBy (UniquePermitTopicAcceptLocalTopic localID) + Right remoteID -> void <$> getBy (UniquePermitTopicAcceptRemoteTopic remoteID) + when (isNothing maybeTopicAccept) $ + throwE "Haven't seen topic's Accept yet, please wait for it" + + -- If I haven't seen the direct-Grant, and haven't already + -- accepted, record my accept + -- If I've already accepted or seen the direct-Grant, raise an error + maybeTopicEnable <- + lift $ case topic of + Left localID -> void <$> getBy (UniquePermitTopicEnableLocalTopic localID) + Right remoteID -> void <$> getBy (UniquePermitTopicEnableRemoteTopic remoteID) + if isNothing maybeTopicEnable + then do + maybeInserted <- lift $ insertUnique $ PermitPersonGesture permitID acceptID + when (isNothing maybeInserted) $ + throwE "I already Accepted this Invite" + else throwE "I already have a direct-Grant for this Invite" + return ( personActor personMe , localRecips @@ -171,6 +217,19 @@ clientAccept now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost fwdHosts acceptID action return acceptID + where + + tryInvite (Left (actorByKey, _actorEntity, itemID)) = do + PermitTopicGestureLocal fulfillsID _ <- + MaybeT $ getValBy $ UniquePermitTopicGestureLocalInvite itemID + PermitFulfillsInvite permitID <- lift $ getJust fulfillsID + return (permitID, fulfillsID) + tryInvite (Right remoteActivityID) = do + PermitTopicGestureRemote fulfillsID _ _ <- + MaybeT $ getValBy $ UniquePermitTopicGestureRemoteInvite remoteActivityID + PermitFulfillsInvite permitID <- lift $ getJust fulfillsID + return (permitID, fulfillsID) + -- Meaning: The human wants to add component C to project P -- Behavior: -- * Some basic sanity checks @@ -207,7 +266,7 @@ clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts a manager <- asksEnv envHttpManager coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luComps lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'" - AP.ResourceWithCollections _ _ mluComps <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu + AP.ResourceWithCollections _ _ mluComps _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu unless (mluComps == Just luComps) $ throwE "Add target isn't a components list" @@ -620,6 +679,163 @@ clientCreateProject now personMeID (ClientMsg maybeCap localRecips remoteRecips } return (action, recipientSet, remoteActors, fwdHosts) +-- Meaning: The human wants to create a team +-- Behavior: +-- * Create a team on DB +-- * Launch a team actor +-- * Record a FollowRequest in DB +-- * Create and send Create and Follow to it +clientCreateTeam + :: UTCTime + -> PersonId + -> ClientMsg + -> AP.ActorDetail + -> ActE OutboxItemId +clientCreateTeam now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) tracker = do + + -- Check input + verifyNothingE maybeCap "Capability not needed" + (name, msummary) <- parseTracker tracker + + (actorMeID, localRecipsFinal, createID, actionCreate, followID, follow, groupID) <- lift $ withDB $ do + + -- Grab me from DB + (personMe, actorMe) <- do + p <- getJust personMeID + (p,) <$> getJust (personActor p) + let actorMeID = personActor personMe + + -- Insert new team to DB + createID <- insertEmptyOutboxItem' (actorOutbox actorMe) now + (groupID, projectFollowerSetID) <- + insertTeam now name msummary createID actorMeID + + -- Insert the Create activity to my outbox + groupHash <- lift $ encodeKeyHashid groupID + actionCreate <- lift $ prepareCreate name msummary groupHash + luCreate <- updateOutboxItem' (LocalActorPerson personMeID) createID actionCreate + + -- Prepare recipient sieve for sending the Create + personMeHash <- lift $ encodeKeyHashid personMeID + let sieve = + makeRecipientSet + [LocalActorGroup groupHash] + [LocalStagePersonFollowers personMeHash] + onlyGroup = GroupRoutes True False + addMe' groups = (groupHash, onlyGroup) : groups + addMe rs = rs { recipGroups = addMe' $ recipGroups rs } + + -- Insert a follow request, since I'm about to send a Follow + followID <- insertEmptyOutboxItem' (actorOutbox actorMe) now + insert_ $ FollowRequest actorMeID projectFollowerSetID True followID + + -- Insert a Follow to my outbox + follow@(actionFollow, _, _, _) <- lift $ prepareFollow groupID luCreate + _luFollow <- updateOutboxItem' (LocalActorPerson personMeID) followID actionFollow + + return + ( personActor personMe + , localRecipSieve sieve False $ addMe localRecips + , createID + , actionCreate + , followID + , follow + , groupID + ) + + -- Spawn new Group actor + success <- lift $ launchActor LocalActorGroup groupID + unless success $ + error "Failed to spawn new Group, somehow ID already in Theater" + + -- Send the Create + lift $ sendActivity + (LocalActorPerson personMeID) actorMeID localRecipsFinal remoteRecips + fwdHosts createID actionCreate + + -- Send the Follow + let (actionFollow, localRecipsFollow, remoteRecipsFollow, fwdHostsFollow) = follow + lift $ sendActivity + (LocalActorPerson personMeID) actorMeID localRecipsFollow + remoteRecipsFollow fwdHostsFollow followID actionFollow + + return createID + + where + + parseTracker (AP.ActorDetail typ muser mname msummary) = do + unless (typ == AP.ActorTypeTeam) $ + error "clientCreateTeam: Create object isn't a Team" + verifyNothingE muser "Team can't have a username" + name <- fromMaybeE mname "Team doesn't specify name" + return (name, msummary) + + insertTeam now name msummary obiidCreate actorMeID = do + ibid <- insert Inbox + obid <- insert Outbox + fsid <- insert FollowerSet + aid <- insert Actor + { actorName = name + , actorDesc = fromMaybe "" msummary + , actorCreatedAt = now + , actorInbox = ibid + , actorOutbox = obid + , actorFollowers = fsid + , actorJustCreatedBy = Just actorMeID + } + gid <- insert Group + { groupActor = aid + , groupCreate = obiidCreate + } + return (gid, fsid) + + prepareCreate name msummary groupHash = do + encodeRouteLocal <- getEncodeRouteLocal + hLocal <- asksEnv stageInstanceHost + let ttdetail = AP.ActorDetail + { AP.actorType = AP.ActorTypeTeam + , AP.actorUsername = Nothing + , AP.actorName = Just name + , AP.actorSummary = msummary + } + ttlocal = AP.ActorLocal + { AP.actorId = encodeRouteLocal $ GroupR groupHash + , AP.actorInbox = encodeRouteLocal $ GroupInboxR groupHash + , AP.actorOutbox = Nothing + , AP.actorFollowers = Nothing + , AP.actorFollowing = Nothing + , AP.actorPublicKeys = [] + , AP.actorSshKeys = [] + } + specific = AP.CreateActivity AP.Create + { AP.createObject = AP.CreateTeam ttdetail (Just (hLocal, ttlocal)) + , AP.createTarget = Nothing + } + return action { AP.actionSpecific = specific } + + prepareFollow groupID luCreate = do + encodeRouteHome <- getEncodeRouteHome + h <- asksEnv stageInstanceHost + groupHash <- encodeKeyHashid groupID + + let audTopic = AudLocal [LocalActorGroup groupHash] [] + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audTopic] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [ObjURI h luCreate] + , AP.actionSpecific = AP.FollowActivity AP.Follow + { AP.followObject = encodeRouteHome $ GroupR groupHash + , AP.followContext = Nothing + , AP.followHide = False + } + } + return (action, recipientSet, remoteActors, fwdHosts) + clientCreate :: UTCTime -> PersonId @@ -639,6 +855,11 @@ clientCreate now personMeID msg (AP.Create object muTarget) = verifyNothingE muTarget "'target' not supported in Create Project" clientCreateProject now personMeID msg detail + AP.CreateTeam detail mlocal -> do + verifyNothingE mlocal "Team id must not be provided" + verifyNothingE muTarget "'target' not supported in Create Team" + clientCreateTeam now personMeID msg detail + _ -> throwE "Unsupported Create object for C2S" -- Meaning: The human wants to invite someone A to a resource R @@ -672,15 +893,15 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost resourceDB <- bitraverse (bitraverse - (withDBExcept . flip getGrantResource "Grant resource not found in DB") + (withDBExcept . flip getLocalActorEntityE "Grant resource not found in DB") (withDBExcept . flip getEntityE "Grant context project not found in DB") ) (\ u@(ObjURI h luColl) -> do manager <- asksEnv envHttpManager coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'" - AP.ResourceWithCollections _ mluCollabs mluComps <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu - unless (mluCollabs == Just luColl || mluComps == Just luColl) $ + AP.ResourceWithCollections _ mluCollabs mluComps mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu + unless (mluCollabs == Just luColl || mluComps == Just luColl || mluMembers == Just luColl) $ throwE "Invite target isn't a collabs/components list" instanceID <- @@ -721,7 +942,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost -- Verify that resource and recipient are addressed by the Invite bitraverse_ (bitraverse_ - (verifyResourceAddressed localRecips . bmap entityKey) + (verifyActorAddressed localRecips . bmap entityKey) (verifyProjectAddressed localRecips . entityKey) ) (\ (_, _, u) -> verifyRemoteAddressed remoteRecips u) @@ -747,12 +968,12 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost -- Prepare local recipients for Invite delivery sieve <- lift $ do - resourceHash <- bitraverse (bitraverse hashGrantResource' encodeKeyHashid) pure resource + resourceHash <- bitraverse (bitraverse hashLocalActor encodeKeyHashid) pure resource recipientHash <- bitraverse (bitraverse hashGrantRecip hashComponent) pure recipient senderHash <- encodeKeyHashid personMeID let sieveActors = catMaybes [ case resourceHash of - Left (Left r) -> Just $ grantResourceLocalActor r + Left (Left a) -> Just a Left (Right j) -> Just $ LocalActorProject j Right _ -> Nothing , case recipientHash of @@ -763,7 +984,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost sieveStages = catMaybes [ Just $ LocalStagePersonFollowers senderHash , case resourceHash of - Left (Left r) -> Just $ localActorFollowers $ grantResourceLocalActor r + Left (Left a) -> Just $ localActorFollowers a Left (Right j) -> Just $ LocalStageProjectFollowers j Right _ -> Nothing , case recipientHash of @@ -783,6 +1004,150 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost fwdHosts inviteID action return inviteID +-- Meaning: The human wants to join a resource R +-- Behavior: +-- * Some basic sanity checks +-- * Parse the Join +-- * Make sure not joining myself +-- * Verify that a capability isn't specified +-- * If resource is local, verify it exists in DB +-- * Verify the resource R is addressed in the Join +-- * Insert Join to my outbox +-- +-- * If R is referred by a collabs/members collection URI: +-- * For each Permit record I have for this resource: +-- * Verify it's not enabled yet, i.e. I'm not already a +-- collaborator, haven't received a direct-Grant +-- * Verify it's not in Invite-Accept state, already got the +-- resource's Accept and waiting for my approval or for the +-- topic's Grant +-- * Verify it's not a Join +-- * Create a Permit record in DB +-- +-- * Asynchrnously deliver to: +-- * Resource+followers +-- * My followers +clientJoin + :: UTCTime + -> PersonId + -> ClientMsg + -> AP.Join URIMode + -> ActE OutboxItemId +clientJoin now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) join = do + + -- Check input + (role, resource) <- parseJoin join + verifyNothingE maybeCap "Capability provided" + + -- If resource collabs URI is remote, HTTP GET it and its resource and its + -- managing actor, and insert to our DB. If resource is local, find it in + -- our DB. + resourceDB <- + bitraverse + (withDBExcept . flip getLocalActorEntityE "Join resource not found in DB") + (\ u@(ObjURI h luColl) -> do + manager <- asksEnv envHttpManager + coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl + lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'" + AP.ResourceWithCollections _ mluCollabs mluComps mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu + let isCollabs = mluCollabs == Just luColl || mluMembers == Just luColl + unless (isCollabs || mluComps == Just luColl) $ + throwE "Join resource isn't a collabs/components list" + + instanceID <- + lift $ withDB $ either entityKey id <$> insertBy' (Instance h) + result <- + ExceptT $ first (T.pack . show) <$> + fetchRemoteResource instanceID h lu + case result of + Left (Entity actorID actor) -> + return (remoteActorIdent actor, actorID, u, isCollabs) + Right (objectID, luManager, (Entity actorID _)) -> + return (objectID, actorID, ObjURI h luManager, isCollabs) + ) + resource + + -- Verify that resource is addressed by the Join + bitraverse_ + (verifyActorAddressed localRecips . bmap entityKey) + (\ (_, _, u, _) -> verifyRemoteAddressed remoteRecips u) + resourceDB + + let maybePermit = + case resourceDB of + Left la -> Just $ Left la + Right (_, _, _, False) -> Nothing + Right (objectID, actorID, uActor, True) -> Just $ Right (objectID, actorID, uActor) + + (actorMeID, localRecipsFinal, joinID) <- withDBExcept $ do + + -- Grab me from DB + (personMe, actorMe) <- lift $ do + p <- getJust personMeID + (p,) <$> getJust (personActor p) + + -- Insert the Join activity to my outbox + joinID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now + _luJoin <- lift $ updateOutboxItem' (LocalActorPerson personMeID) joinID action + + for_ maybePermit $ \ topicDB -> do + + -- Find existing Permit records I have for this topic + -- Make sure none are enabled / in Join mode / in Invite-Accept + -- mode + checkExistingPermits + personMeID + (bimap (bmap entityKey) (view _2) topicDB) + + -- Insert Permit record to DB + insertPermit topicDB joinID role + + -- Prepare local recipients for Join delivery + sieve <- lift $ do + resourceHash <- bitraverse hashLocalActor pure resource + senderHash <- encodeKeyHashid personMeID + let sieveActors = catMaybes + [ case resourceHash of + Left a -> Just a + Right _ -> Nothing + ] + sieveStages = catMaybes + [ Just $ LocalStagePersonFollowers senderHash + , case resourceHash of + Left a -> Just $ localActorFollowers a + Right _ -> Nothing + ] + return $ makeRecipientSet sieveActors sieveStages + return + ( personActor personMe + , localRecipSieve sieve False localRecips + , joinID + ) + + lift $ sendActivity + (LocalActorPerson personMeID) actorMeID localRecipsFinal remoteRecips + fwdHosts joinID action + return joinID + + where + + insertPermit resourceDB joinID role = do + permitID <- lift $ insert $ Permit personMeID role + case resourceDB of + Left la -> do + localID <- lift $ insert $ PermitTopicLocal permitID + case bmap entityKey la of + LocalActorPerson _ -> throwE "insertPermit: Person not supported as a PermitTopicLocal type (you can't become a \"collaborator in a person\"" + LocalActorRepo r -> lift $ insert_ $ PermitTopicRepo localID r + LocalActorDeck d -> lift $ insert_ $ PermitTopicDeck localID d + LocalActorLoom l -> lift $ insert_ $ PermitTopicLoom localID l + LocalActorProject j -> lift $ insert_ $ PermitTopicProject localID j + LocalActorGroup g -> lift $ insert_ $ PermitTopicGroup localID g + Right (_, actorID, _) -> lift $ insert_ $ PermitTopicRemote permitID actorID + lift $ do + insert_ $ PermitFulfillsJoin permitID + insert_ $ PermitPersonGesture permitID joinID + -- Meaning: The human wants to open a ticket/MR/dependency -- Behavior: -- * Basics checks on the provided ticket/MR (dependency not allowed) @@ -913,8 +1278,8 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost manager <- asksEnv envHttpManager coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'" - AP.ResourceWithCollections _ mluCollabs _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu - unless (mluCollabs == Just luColl) $ + AP.ResourceWithCollections _ mluCollabs _ mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu + unless (mluCollabs == Just luColl || mluMembers == Just luColl) $ throwE "Remove origin isn't a collabs list" return $ ObjURI h lu ) @@ -922,7 +1287,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost -- Verify that resource is addressed by the Remove bitraverse_ - (verifyResourceAddressed localRecips) + (verifyActorAddressed localRecips) (verifyRemoteAddressed remoteRecips) resource' @@ -937,7 +1302,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost -- If resource is local, find it in our DB _resourceDB <- bitraverse - (flip getGrantResource "Resource not found in DB") + (flip getLocalActorEntityE "Resource not found in DB") pure resource' @@ -959,15 +1324,12 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost -- Prepare local recipients for Remove delivery sieve <- lift $ do - resourceHash <- bitraverse hashGrantResource' pure resource' + resourceHash <- bitraverse hashLocalActor pure resource' recipientHash <- bitraverse hashGrantRecip pure member senderHash <- encodeKeyHashid personMeID let sieveActors = catMaybes [ case resourceHash of - Left (GrantResourceRepo r) -> Just $ LocalActorRepo r - Left (GrantResourceDeck d) -> Just $ LocalActorDeck d - Left (GrantResourceLoom l) -> Just $ LocalActorLoom l - Left (GrantResourceProject l) -> Just $ LocalActorProject l + Left a -> Just a Right _ -> Nothing , case recipientHash of Left (GrantRecipPerson p) -> Just $ LocalActorPerson p @@ -976,10 +1338,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost sieveStages = catMaybes [ Just $ LocalStagePersonFollowers senderHash , case resourceHash of - Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r - Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d - Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l - Left (GrantResourceProject l) -> Just $ LocalStageProjectFollowers l + Left a -> Just $ localActorFollowers a Right _ -> Nothing , case recipientHash of Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p @@ -1073,6 +1432,7 @@ clientBehavior now personID msg = AP.AddActivity add -> clientAdd now personID msg add AP.CreateActivity create -> clientCreate now personID msg create AP.InviteActivity invite -> clientInvite now personID msg invite + AP.JoinActivity join -> clientJoin now personID msg join AP.OfferActivity offer -> clientOffer now personID msg offer AP.RemoveActivity remove -> clientRemove now personID msg remove AP.ResolveActivity resolve -> clientResolve now personID msg resolve diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index 59219c0..8248c3f 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -137,10 +137,6 @@ import Vervis.Ticket -- - Component's followers -- - My followers -- - The Accept's sender --- --- * In collab mode, if we just sent the collaborator-Grant, also send to --- my new collaborator a delegation-extension Grant for each component I --- have projectAccept :: UTCTime -> ProjectId @@ -223,7 +219,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do verifyCapability' capability authorIdMsig - (GrantResourceProject projectID) + (LocalActorProject projectID) AP.RoleAdmin return fulfillsID ) @@ -267,7 +263,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do verifyCapability' capability authorIdMsig - (GrantResourceProject projectID) + (LocalActorProject projectID) AP.RoleAdmin ) @@ -358,15 +354,14 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do return (componentID, ident, grantID, enableID, True) -- Prepare forwarding of Accept to my followers - let recipByID = grantResourceLocalActor $ GrantResourceProject projectID + let recipByID = LocalActorProject projectID recipByHash <- hashLocalActor recipByID let sieve = makeRecipientSet [] [localActorFollowers recipByHash] maybeGrant <- case idsForGrant of - -- In collab mode, prepare a regular Grant and extension - -- Grants + -- In collab mode, prepare a regular Grant Left (collabID, inviterOrJoiner, collab, grantID, collabEnableID) -> lift $ do let isInvite = isLeft collab grant@(actionGrant, _, _, _) <- do @@ -374,81 +369,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do prepareCollabGrant isInvite inviterOrJoiner role let recipByKey = LocalActorProject projectID _luGrant <- updateOutboxItem' recipByKey grantID actionGrant - - recip <- - requireEitherAlt - (getBy $ UniqueCollabRecipLocal collabID) - (getBy $ UniqueCollabRecipRemote collabID) - "Found Collab with no recip" - "Found Collab with multiple recips" - let insertExt = - case bimap entityKey entityKey recip of - Left localID -> - \ enableID furtherID -> insert_ $ ComponentFurtherLocal enableID localID furtherID - Right remoteID -> - \ enableID furtherID -> insert_ $ ComponentFurtherRemote enableID remoteID furtherID - locals <- - fmap (map $ over _1 Left) $ - E.select $ E.from $ \ (deleg `E.InnerJoin` local `E.InnerJoin` comp `E.InnerJoin` enable) -> do - E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent - E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId - E.on $ deleg E.^. ComponentDelegateLocalComponent E.==.local E.^. ComponentLocalId - E.where_ $ comp E.^. ComponentProject E.==. E.val projectID - return (deleg E.^. ComponentDelegateLocalGrant, comp, enable) - remotes <- - fmap (map $ over _1 Right) $ - E.select $ E.from $ \ (deleg `E.InnerJoin` remote `E.InnerJoin` comp `E.InnerJoin` enable) -> do - E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent - E.on $ remote E.^. ComponentRemoteComponent E.==. comp E.^. ComponentId - E.on $ deleg E.^. ComponentDelegateRemoteComponent E.==.remote E.^. ComponentRemoteId - E.where_ $ comp E.^. ComponentProject E.==. E.val projectID - return (deleg E.^. ComponentDelegateRemoteGrant, comp, enable) - (uCollab, audCollab) <- - case recip of - Left (Entity _ (CollabRecipLocal _ personID)) -> do - personHash <- encodeKeyHashid personID - encodeRouteHome <- getEncodeRouteHome - return - ( encodeRouteHome $ PersonR personHash - , AudLocal [LocalActorPerson personHash] [] - ) - Right (Entity _ (CollabRecipRemote _ raID)) -> do - ra <- getJust raID - u@(ObjURI h lu) <- getRemoteActorURI ra - return (u, AudRemote h [lu] []) - Collab role <- getJust collabID - exts <- for (locals ++ remotes) $ \ (start, Entity componentID component, Entity enableID _) -> do - extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now - insertExt enableID extID - componentIdent <- do - i <- getComponentIdent componentID - bitraverse - (pure . snd) - (\ (_, raID) -> getRemoteActorURI =<< getJust raID) - i - uStart <- - case start of - Left (E.Value startID) -> do - encodeRouteHome <- getEncodeRouteHome - c <- - case componentIdent of - Left ci -> hashComponent ci - Right _ -> error "Delegation-start Grant URI is local, but component found to be remote, impossible" - s <- encodeKeyHashid startID - return $ encodeRouteHome $ activityRoute (componentActor c) s - Right (E.Value remoteActivityID) -> do - objectID <- remoteActivityIdent <$> getJust remoteActivityID - o <- getJust objectID - let luAct = remoteObjectIdent o - h <- instanceHost <$> getJust (remoteObjectInstance o) - return $ ObjURI h luAct - ext@(actionExt, _, _, _) <- - prepareExtensionGrant uCollab audCollab componentIdent uStart (min role (componentRole component)) collabEnableID - let recipByKey = LocalActorProject projectID - _luExt <- updateOutboxItem' recipByKey extID actionExt - return (extID, ext) - - return $ Just (grantID, grant, exts) + return $ Just (grantID, grant) -- In Invite-component mode, only if the Accept author is -- the component, prepare a delegator-Grant @@ -460,7 +381,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do prepareDelegGrant (bimap snd snd ident) enableID includeAuthor let recipByKey = LocalActorProject projectID _luGrant <- updateOutboxItem' recipByKey grantID actionGrant - return (grantID, grant, []) + return (grantID, grant) return (recipActorID, sieve, maybeGrant) @@ -469,21 +390,17 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do Just (recipActorID, sieve, maybeGrant) -> do let recipByID = LocalActorProject projectID forwardActivity authorIdMsig body recipByID recipActorID sieve - lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant), exts) -> do + lift $ for_ maybeGrant $ \ (grantID, (actionGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant)) -> sendActivity recipByID recipActorID localRecipsGrant remoteRecipsGrant fwdHostsGrant grantID actionGrant - for_ exts $ \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) -> - sendActivity - recipByID recipActorID localRecipsExt - remoteRecipsExt fwdHostsExt extID actionExt done "Forwarded the Accept and maybe published a Grant" where verifyCollabTopic collabID = do topic <- lift $ getCollabTopic collabID - unless (GrantResourceProject projectID == topic) $ + unless (LocalActorProject projectID == topic) $ throwE "Accept object is an Invite/Join for some other resource" verifyInviteCollabTopic fulfillsID = do @@ -583,7 +500,7 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do audAccepter <- makeAudSenderWithFollowers authorIdMsig audApprover <- lift $ makeAudSenderOnly authorIdMsig recipHash <- encodeKeyHashid projectID - let topicByHash = grantResourceLocalActor $ GrantResourceProject recipHash + let topicByHash = LocalActorProject recipHash senderHash <- bitraverse hashLocalActor pure sender @@ -689,49 +606,6 @@ projectAccept now projectID (Verse authorIdMsig body) accept = do return (action, recipientSet, remoteActors, fwdHosts) - prepareExtensionGrant uCollab audCollab component uStart role enableID = do - encodeRouteHome <- getEncodeRouteHome - encodeRouteLocal <- getEncodeRouteLocal - - projectHash <- encodeKeyHashid projectID - - uComponent <- - case component of - Left c -> do - a <- componentActor <$> hashComponent c - return $ encodeRouteHome $ renderLocalActor a - Right u -> pure u - - enableHash <- encodeKeyHashid enableID - - let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = - collectAudience [audCollab] - - recips = map encodeRouteHome audLocal ++ audRemote - action = AP.Action - { AP.actionCapability = Nothing - , AP.actionSummary = Nothing - , AP.actionAudience = AP.Audience recips [] [] [] [] [] - , AP.actionFulfills = [uStart] - , AP.actionSpecific = AP.GrantActivity AP.Grant - { AP.grantObject = AP.RXRole role - , AP.grantContext = uComponent - , AP.grantTarget = uCollab - , AP.grantResult = - Just - (encodeRouteLocal $ - ProjectCollabLiveR projectHash enableHash - , Nothing - ) - , AP.grantStart = Just now - , AP.grantEnd = Nothing - , AP.grantAllows = AP.Invoke - , AP.grantDelegates = Just uStart - } - } - - return (action, recipientSet, remoteActors, fwdHosts) - checkExistingComponents :: ProjectId -> Either (ComponentBy Entity) RemoteActorId -> ActDBE () checkExistingComponents projectID componentDB = do @@ -952,7 +826,7 @@ projectCreateMe -> ActE (Text, Act (), Next) projectCreateMe = topicCreateMe - projectActor GrantResourceProject + projectActor LocalActorProject CollabTopicProjectProject CollabTopicProject projectCreate @@ -1005,7 +879,7 @@ projectFollow now recipProjectID verse follow = do -- Meaning: An actor is granting access-to-some-resource to another actor -- Behavior: --- * Verify that: +-- * Option 1 - Component sending me a delegation-start - Verify that: -- * The sender is a component of mine, C -- * The Grant's context is C -- * The Grant's target is me @@ -1019,14 +893,37 @@ projectFollow now recipProjectID verse follow = do -- * Insert the Grant to my inbox -- * Record the delegation in the Component record in DB -- * Forward the Grant to my followers --- * For each person (non-team) collaborator of mine, prepare and send a --- Grant, and store it in the Componet record in DB: +-- * For each person (non-team) collaborator of mine, prepare and send an +-- extension-Grant, and store it in the Componet record in DB: -- * Role: The lower among (1) admin (2) the collaborator's role in me -- * Resource: C -- * Target: The collaborator -- * Delegates: The Grant I just got from C -- * Result: ProjectCollabLiveR for this collaborator -- * Usage: invoke +-- +-- * Option 2 - 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 +-- * For each component of mine C, prepare and send an +-- extension-Grant to A, and store it in the Componet record in DB: +-- * Role: The lower among (1) admin (2) the collaborator's role in me +-- * Resource: C +-- * Target: A +-- * Delegates: The start-Grant I have from C +-- * Result: ProjectCollabLiveR for this collaborator, A +-- * Usage: invoke +-- +-- * If neither 1 nor 2, raise an error projectGrant :: UTCTime -> ProjectId @@ -1055,115 +952,13 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do _ -> throwE "Capability is remote i.e. definitely not by me" -- Check grant - (role, component) <- checkDelegationStart grant + grant' <- + Left <$> checkDelegationStart grant <|> + Right <$> checkDelegator grant - maybeNew <- withDBExcept $ do - - -- Grab me from DB - (recipActorID, recipActor) <- lift $ do - recip <- getJust projectID - let actorID = projectActor recip - (actorID,) <$> getJust actorID - - -- Find the Component record from the capability - Entity enableID (ComponentEnable componentID _) <- do - unless (fst capability == LocalActorProject projectID) $ - throwE "Capability isn't mine" - m <- lift $ getBy $ UniqueComponentEnableGrant $ snd capability - fromMaybeE m "I don't have a Component with this capability" - Component j role' <- lift $ getJust componentID - unless (j == projectID) $ - throwE "Found a Component for this delegator-Grant but it's not mine" - unless (role' == role) $ - throwE "Grant role isn't the same as in the Invite/Add" - ident <- lift $ getComponentIdent componentID - identForCheck <- - lift $ - bitraverse - (pure . snd) - (\ (_, raID) -> getRemoteActorURI =<< getJust raID) - ident - unless (identForCheck == component) $ - throwE "Capability's component and Grant author aren't the same actor" - - -- Verify I don't yet have a delegation from the component - maybeDeleg <- - lift $ case bimap fst fst ident of - Left localID -> (() <$) <$> getBy (UniqueComponentDelegateLocal localID) - Right remoteID -> (() <$) <$> getBy (UniqueComponentDelegateRemote remoteID) - verifyNothingE maybeDeleg "I already have a delegation-start Grant from this component" - - maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False - for maybeGrantDB $ \ grantDB -> do - - -- Record the delegation in DB - lift $ case (grantDB, bimap fst fst ident) of - (Left (_, _, grantID), Left localID) -> insert_ $ ComponentDelegateLocal localID grantID - (Right (_, _, grantID), Right remoteID) -> insert_ $ ComponentDelegateRemote remoteID grantID - _ -> error "projectGrant impossible" - - -- Prepare forwarding of Accept to my followers - projectHash <- encodeKeyHashid projectID - let sieve = makeRecipientSet [] [LocalStageProjectFollowers projectHash] - - -- For each Collab in me, prepare a delegation-extension Grant - localCollabs <- - lift $ - E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` recipL) -> do - E.on $ enable E.^. CollabEnableCollab E.==. recipL E.^. CollabRecipLocalCollab - E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab - E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId - E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID - return - ( collab E.^. CollabRole - , recipL E.^. CollabRecipLocalId - , recipL E.^. CollabRecipLocalPerson - , enable E.^. CollabEnableId - ) - localExtensions <- lift $ for localCollabs $ \ (E.Value role', E.Value recipID, E.Value personID, E.Value enableID') -> do - extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now - insert_ $ ComponentFurtherLocal enableID recipID extID - ext@(actionExt, _, _, _) <- - prepareExtensionGrant identForCheck (Left personID) (min role role') enableID' - let recipByKey = LocalActorProject projectID - _luExt <- updateOutboxItem' recipByKey extID actionExt - return (extID, ext) - - remoteCollabs <- - lift $ - E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` recipR) -> do - E.on $ enable E.^. CollabEnableCollab E.==. recipR E.^. CollabRecipRemoteCollab - E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab - E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId - E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID - return - ( collab E.^. CollabRole - , recipR E.^. CollabRecipRemoteId - , recipR E.^. CollabRecipRemoteActor - , enable E.^. CollabEnableId - ) - remoteExtensions <- lift $ for remoteCollabs $ \ (E.Value role', E.Value recipID, E.Value raID, E.Value enableID') -> do - extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now - insert_ $ ComponentFurtherRemote enableID recipID extID - ext@(actionExt, _, _, _) <- - prepareExtensionGrant identForCheck (Right raID) (min role role') enableID' - let recipByKey = LocalActorProject projectID - _luExt <- updateOutboxItem' recipByKey extID actionExt - return (extID, ext) - - return (recipActorID, sieve, localExtensions, remoteExtensions) - - case maybeNew of - Nothing -> done "I already have this activity in my inbox" - Just (recipActorID, sieve, localExts, remoteExts) -> do - let recipByID = LocalActorProject projectID - forwardActivity authorIdMsig body recipByID recipActorID sieve - lift $ for_ (localExts ++ remoteExts) $ - \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) -> - sendActivity - recipByID recipActorID localRecipsExt - remoteRecipsExt fwdHostsExt extID actionExt - done "Forwarded the Grant and published delegation extensions" + case grant' of + Left (role, component) -> handleComp capability role component + Right collab -> handleCollab capability collab where @@ -1176,7 +971,7 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do AP.RXDelegator -> throwE "Role is delegator" component <- fromMaybeE - (bitraverse resourceToComponent Just resource) + (bitraverse actorToComponent Just resource) "Resource is a local project, therefore not a component of mine" case (component, authorIdMsig) of (Left c, Left (a, _, _)) | componentActor c == a -> pure () @@ -1195,64 +990,401 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do throwE "'delegates' is specified" return (role', component) - prepareExtensionGrant component collab role enableID = do - encodeRouteHome <- getEncodeRouteHome - encodeRouteLocal <- getEncodeRouteLocal + 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 (GrantRecipProject' j) | j == projectID -> 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 - projectHash <- encodeKeyHashid projectID - uStart <- lift $ getActivityURI authorIdMsig + handleComp capability role component = do - (uCollab, audCollab) <- - case collab of - Left personID -> do - personHash <- encodeKeyHashid personID - return - ( encodeRouteHome $ PersonR personHash - , AudLocal [LocalActorPerson personHash] [] - ) - Right raID -> do - ra <- getJust raID - u@(ObjURI h lu) <- getRemoteActorURI ra - return (u, AudRemote h [lu] []) + maybeNew <- withDBExcept $ do - uComponent <- - case component of - Left c -> do - a <- componentActor <$> hashComponent c - return $ encodeRouteHome $ renderLocalActor a - Right u -> pure u + -- Grab me from DB + (recipActorID, recipActor) <- lift $ do + recip <- getJust projectID + let actorID = projectActor recip + (actorID,) <$> getJust actorID - enableHash <- encodeKeyHashid enableID + -- Find the Component record from the capability + Entity enableID (ComponentEnable componentID _) <- do + unless (fst capability == LocalActorProject projectID) $ + throwE "Capability isn't mine" + m <- lift $ getBy $ UniqueComponentEnableGrant $ snd capability + fromMaybeE m "I don't have a Component with this capability" + Component j role' <- lift $ getJust componentID + unless (j == projectID) $ + throwE "Found a Component for this delegator-Grant but it's not mine" + unless (role' == role) $ + throwE "Grant role isn't the same as in the Invite/Add" + ident <- lift $ getComponentIdent componentID + identForCheck <- + lift $ + bitraverse + (pure . snd) + (\ (_, raID) -> getRemoteActorURI =<< getJust raID) + ident + unless (identForCheck == component) $ + throwE "Capability's component and Grant author aren't the same actor" - let audience = [audCollab] + -- Verify I don't yet have a delegation from the component + maybeDeleg <- + lift $ case bimap fst fst ident of + Left localID -> (() <$) <$> getBy (UniqueComponentDelegateLocal localID) + Right remoteID -> (() <$) <$> getBy (UniqueComponentDelegateRemote remoteID) + verifyNothingE maybeDeleg "I already have a delegation-start Grant from this component" - (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = - collectAudience audience + maybeGrantDB <- lift $ insertToInbox now authorIdMsig body (actorInbox recipActor) False + for maybeGrantDB $ \ grantDB -> do - recips = map encodeRouteHome audLocal ++ audRemote - action = AP.Action - { AP.actionCapability = Nothing - , AP.actionSummary = Nothing - , AP.actionAudience = AP.Audience recips [] [] [] [] [] - , AP.actionFulfills = [uStart] - , AP.actionSpecific = AP.GrantActivity AP.Grant - { AP.grantObject = AP.RXRole role - , AP.grantContext = uComponent - , AP.grantTarget = uCollab - , AP.grantResult = - Just - (encodeRouteLocal $ - ProjectCollabLiveR projectHash enableHash - , Nothing + -- Record the delegation in DB + lift $ case (grantDB, bimap fst fst ident) of + (Left (_, _, grantID), Left localID) -> insert_ $ ComponentDelegateLocal localID grantID + (Right (_, _, grantID), Right remoteID) -> insert_ $ ComponentDelegateRemote remoteID grantID + _ -> error "projectGrant impossible" + + -- Prepare forwarding of Accept to my followers + projectHash <- encodeKeyHashid projectID + let sieve = makeRecipientSet [] [LocalStageProjectFollowers projectHash] + + -- For each Collab in me, prepare a delegation-extension Grant + localCollabs <- + lift $ + E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` recipL `E.InnerJoin` deleg) -> do + E.on $ enable E.^. CollabEnableId E.==. deleg E.^. CollabDelegLocalEnable + E.on $ enable E.^. CollabEnableCollab E.==. recipL E.^. CollabRecipLocalCollab + E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab + E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId + E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID + return + ( collab E.^. CollabRole + , recipL E.^. CollabRecipLocalPerson + , deleg ) - , AP.grantStart = Just now - , AP.grantEnd = Nothing - , AP.grantAllows = AP.Invoke - , AP.grantDelegates = Just uStart - } - } + localExtensions <- lift $ for localCollabs $ \ (E.Value role', E.Value personID, Entity delegID (CollabDelegLocal enableID' recipID grantID)) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + insert_ $ ComponentFurtherLocal enableID delegID extID + ext@(actionExt, _, _, _) <- + prepareExtensionGrant identForCheck (Left (personID, grantID)) (min role role') enableID' + let recipByKey = LocalActorProject projectID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) - return (action, recipientSet, remoteActors, fwdHosts) + remoteCollabs <- + lift $ + E.select $ E.from $ \ (topic `E.InnerJoin` collab `E.InnerJoin` enable `E.InnerJoin` recipR `E.InnerJoin` deleg) -> do + E.on $ enable E.^. CollabEnableId E.==. deleg E.^. CollabDelegRemoteEnable + E.on $ enable E.^. CollabEnableCollab E.==. recipR E.^. CollabRecipRemoteCollab + E.on $ topic E.^. CollabTopicProjectCollab E.==. enable E.^. CollabEnableCollab + E.on $ topic E.^. CollabTopicProjectCollab E.==. collab E.^. CollabId + E.where_ $ topic E.^. CollabTopicProjectProject E.==. E.val projectID + return + ( collab E.^. CollabRole + , recipR E.^. CollabRecipRemoteActor + , deleg + ) + remoteExtensions <- lift $ for remoteCollabs $ \ (E.Value role', E.Value raID, Entity delegID (CollabDelegRemote enableID' recipID grantID)) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + insert_ $ ComponentFurtherRemote enableID delegID extID + ext@(actionExt, _, _, _) <- + prepareExtensionGrant identForCheck (Right (raID, grantID)) (min role role') enableID' + let recipByKey = LocalActorProject projectID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + return (recipActorID, sieve, localExtensions, remoteExtensions) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, sieve, localExts, remoteExts) -> do + let recipByID = LocalActorProject projectID + forwardActivity authorIdMsig body recipByID recipActorID sieve + lift $ for_ (localExts ++ remoteExts) $ + \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) -> + sendActivity + recipByID recipActorID localRecipsExt + remoteRecipsExt fwdHostsExt extID actionExt + done "Forwarded the start-Grant and published delegation extensions" + + where + + prepareExtensionGrant component collab role enableID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + projectHash <- encodeKeyHashid projectID + uStart <- lift $ getActivityURI authorIdMsig + + (uCollab, audCollab, uDeleg) <- + case collab of + Left (personID, itemID) -> do + personHash <- encodeKeyHashid personID + itemHash <- encodeKeyHashid itemID + return + ( encodeRouteHome $ PersonR personHash + , AudLocal [LocalActorPerson personHash] [] + , encodeRouteHome $ + PersonOutboxItemR personHash itemHash + ) + Right (raID, ractID) -> do + ra <- getJust raID + u@(ObjURI h lu) <- getRemoteActorURI ra + uAct <- do + ract <- getJust ractID + getRemoteActivityURI ract + return (u, AudRemote h [lu] [], uAct) + + uComponent <- + case component of + Left c -> do + a <- componentActor <$> hashComponent c + return $ encodeRouteHome $ renderLocalActor a + Right u -> pure u + + enableHash <- encodeKeyHashid enableID + + let audience = [audCollab] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience audience + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Just uDeleg + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uStart] + , AP.actionSpecific = AP.GrantActivity AP.Grant + { AP.grantObject = AP.RXRole role + , AP.grantContext = uComponent + , AP.grantTarget = uCollab + , AP.grantResult = + Just + (encodeRouteLocal $ + ProjectCollabLiveR projectHash enableHash + , Nothing + ) + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.Invoke + , AP.grantDelegates = Just uStart + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + + handleCollab capability collab = do + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (recipActorID, recipActor) <- lift $ do + recip <- getJust projectID + let actorID = projectActor recip + (actorID,) <$> getJust actorID + + -- Find the Collab record from the capability + Entity enableID (CollabEnable collabID _) <- do + unless (fst capability == LocalActorProject projectID) $ + 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 == LocalActorProject projectID) $ + 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 + (insertExt, uDeleg) <- + lift $ case (grantDB, bimap entityKey entityKey recip) of + (Left (grantActor, _, grantID), Left localID) -> do + delegID <- insert $ CollabDelegLocal enableID localID grantID + encodeRouteHome <- getEncodeRouteHome + delegR <- + activityRoute + <$> hashLocalActor grantActor + <*> encodeKeyHashid grantID + return + (\ enableID furtherID -> + insert_ $ ComponentFurtherLocal enableID delegID furtherID + , encodeRouteHome delegR + ) + (Right (_, _, grantID), Right remoteID) -> do + delegID <- insert $ CollabDelegRemote enableID remoteID grantID + u <- getRemoteActivityURI =<< getJust grantID + return + (\ enableID furtherID -> + insert_ $ ComponentFurtherRemote enableID delegID furtherID + , u + ) + _ -> error "projectGrant impossible 2" + + -- Prepare forwarding of Accept to my followers + projectHash <- encodeKeyHashid projectID + let sieve = makeRecipientSet [] [LocalStageProjectFollowers projectHash] + + -- For each Component of mine, prepare a delegation-extension + -- Grant + extensions <- lift $ do + locals <- + fmap (map $ over _1 Left) $ + E.select $ E.from $ \ (deleg `E.InnerJoin` local `E.InnerJoin` comp `E.InnerJoin` enable) -> do + E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent + E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId + E.on $ deleg E.^. ComponentDelegateLocalComponent E.==.local E.^. ComponentLocalId + E.where_ $ comp E.^. ComponentProject E.==. E.val projectID + return (deleg E.^. ComponentDelegateLocalGrant, comp, enable) + remotes <- + fmap (map $ over _1 Right) $ + E.select $ E.from $ \ (deleg `E.InnerJoin` remote `E.InnerJoin` comp `E.InnerJoin` enable) -> do + E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent + E.on $ remote E.^. ComponentRemoteComponent E.==. comp E.^. ComponentId + E.on $ deleg E.^. ComponentDelegateRemoteComponent E.==.remote E.^. ComponentRemoteId + E.where_ $ comp E.^. ComponentProject E.==. E.val projectID + return (deleg E.^. ComponentDelegateRemoteGrant, comp, enable) + (uCollab, audCollab) <- + case recip of + Left (Entity _ (CollabRecipLocal _ personID)) -> do + personHash <- encodeKeyHashid personID + encodeRouteHome <- getEncodeRouteHome + return + ( encodeRouteHome $ PersonR personHash + , AudLocal [LocalActorPerson personHash] [] + ) + Right (Entity _ (CollabRecipRemote _ raID)) -> do + ra <- getJust raID + u@(ObjURI h lu) <- getRemoteActorURI ra + return (u, AudRemote h [lu] []) + for (locals ++ remotes) $ \ (start, Entity componentID component, Entity enableID' _) -> do + extID <- insertEmptyOutboxItem' (actorOutbox recipActor) now + insertExt enableID' extID + componentIdent <- do + i <- getComponentIdent componentID + bitraverse + (pure . snd) + (\ (_, raID) -> getRemoteActorURI =<< getJust raID) + i + uStart <- + case start of + Left (E.Value startID) -> do + encodeRouteHome <- getEncodeRouteHome + c <- + case componentIdent of + Left ci -> hashComponent ci + Right _ -> error "Delegation-start Grant URI is local, but component found to be remote, impossible" + s <- encodeKeyHashid startID + return $ encodeRouteHome $ activityRoute (componentActor c) s + Right (E.Value remoteActivityID) -> do + ra <- getJust remoteActivityID + getRemoteActivityURI ra + ext@(actionExt, _, _, _) <- + prepareExtensionGrant uCollab audCollab uDeleg componentIdent uStart (min role (componentRole component)) enableID + let recipByKey = LocalActorProject projectID + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + return (recipActorID, sieve, extensions) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (recipActorID, sieve, extensions) -> do + let recipByID = LocalActorProject projectID + 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 and published delegation extensions" + + where + + prepareExtensionGrant uCollab audCollab uDeleg component uStart role enableID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + projectHash <- encodeKeyHashid projectID + + uComponent <- + case component of + Left c -> do + a <- componentActor <$> hashComponent c + return $ encodeRouteHome $ renderLocalActor a + Right u -> pure u + + enableHash <- encodeKeyHashid enableID + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audCollab] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Just uDeleg + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uStart] + , AP.actionSpecific = AP.GrantActivity AP.Grant + { AP.grantObject = AP.RXRole role + , AP.grantContext = uComponent + , AP.grantTarget = uCollab + , AP.grantResult = + Just + (encodeRouteLocal $ + ProjectCollabLiveR projectHash enableHash + , Nothing + ) + , AP.grantStart = Just now + , AP.grantEnd = Nothing + , AP.grantAllows = AP.Invoke + , AP.grantDelegates = Just uStart + } + } + + return (action, recipientSet, remoteActors, fwdHosts) -- Meaning: An actor A invited actor B to a resource -- Behavior: @@ -1311,7 +1443,7 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do (role, resourceOrComps, recipientOrComp) <- parseInvite author invite mode <- case resourceOrComps of - Left (Left (GrantResourceProject j)) | j == projectID -> + Left (Left (LocalActorProject j)) | j == projectID -> Left <$> bitraverse (\case @@ -1363,7 +1495,7 @@ projectInvite now projectID (Verse authorIdMsig body) invite = do -- Verify the specified capability gives relevant access verifyCapability' - capability authorIdMsig (GrantResourceProject projectID) AP.RoleAdmin + capability authorIdMsig (LocalActorProject projectID) AP.RoleAdmin case invitedDB of @@ -1538,7 +1670,7 @@ projectJoin -> ActE (Text, Act (), Next) projectJoin = topicJoin - projectActor GrantResourceProject + projectActor LocalActorProject CollabTopicProjectProject CollabTopicProjectCollab CollabTopicProject -- Meaning: An actor rejected something @@ -1564,7 +1696,7 @@ projectReject -> Verse -> AP.Reject URIMode -> ActE (Text, Act (), Next) -projectReject = topicReject projectActor GrantResourceProject +projectReject = topicReject projectActor LocalActorProject -- Meaning: An actor A is removing actor B from a resource -- Behavior: @@ -1585,7 +1717,7 @@ projectRemove -> ActE (Text, Act (), Next) projectRemove = topicRemove - projectActor GrantResourceProject + projectActor LocalActorProject CollabTopicProjectProject CollabTopicProjectCollab -- Meaning: An actor is undoing some previous action diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index d8a4130..d1afb26 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -38,6 +38,7 @@ module Vervis.Client , createLoom , createRepo , createProject + , createGroup , invite , remove , inviteComponent @@ -1050,6 +1051,27 @@ createProject senderHash name desc = do return (Nothing, audience, detail) +createGroup + :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) + => KeyHashid Person + -> Text + -> Text + -> m (Maybe HTML, [Aud URIMode], AP.ActorDetail) +createGroup senderHash name desc = do + let audAuthor = + AudLocal [] [LocalStagePersonFollowers senderHash] + + audience = [audAuthor] + + detail = AP.ActorDetail + { AP.actorType = AP.ActorTypeTeam + , AP.actorUsername = Nothing + , AP.actorName = Just name + , AP.actorSummary = Just desc + } + + return (Nothing, audience, detail) + invite :: PersonId -> FedURI @@ -1090,15 +1112,15 @@ invite personID uRecipient uResourceCollabs role = do manager <- asksSite appHttpManager coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'" - AP.ResourceWithCollections _ mluCollabs _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu - unless (mluCollabs == Just luColl) $ + AP.ResourceWithCollections _ mluCollabs _ mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu + unless (mluCollabs == Just luColl || mluMembers == Just luColl) $ throwE "Invite target isn't a collabs list" return $ ObjURI h lu ) resource resourceDB <- bitraverse - hashGrantResource + VR.hashLocalActor (\ u@(ObjURI h lu) -> do instanceID <- lift $ runDB $ either entityKey id <$> insertBy' (Instance h) @@ -1136,14 +1158,7 @@ invite personID uRecipient uResourceCollabs role = do let audResource = case resourceDB of - Left (GrantResourceRepo r) -> - AudLocal [LocalActorRepo r] [LocalStageRepoFollowers r] - Left (GrantResourceDeck d) -> - AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d] - Left (GrantResourceLoom l) -> - AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l] - Left (GrantResourceProject l) -> - AudLocal [LocalActorProject l] [LocalStageProjectFollowers l] + Left la -> AudLocal [la] [localActorFollowers la] Right (remoteActor, ObjURI h lu) -> AudRemote h [lu] @@ -1202,8 +1217,8 @@ remove personID uRecipient uResourceCollabs = do manager <- asksSite appHttpManager coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'" - AP.ResourceWithCollections _ mluCollabs _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu - unless (mluCollabs == Just luColl) $ + AP.ResourceWithCollections _ mluCollabs _ mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu + unless (mluCollabs == Just luColl || mluMembers == Just luColl) $ throwE "Remove origin isn't a collabs list" return $ ObjURI h lu ) @@ -1213,7 +1228,7 @@ remove personID uRecipient uResourceCollabs = do -- managing actor & followers collection resourceDB <- bitraverse - hashGrantResource + VR.hashLocalActor (\ u@(ObjURI h lu) -> do instanceID <- lift $ runDB $ either entityKey id <$> insertBy' (Instance h) @@ -1251,14 +1266,7 @@ remove personID uRecipient uResourceCollabs = do let audResource = case resourceDB of - Left (GrantResourceRepo r) -> - AudLocal [LocalActorRepo r] [LocalStageRepoFollowers r] - Left (GrantResourceDeck d) -> - AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d] - Left (GrantResourceLoom l) -> - AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l] - Left (GrantResourceProject l) -> - AudLocal [LocalActorProject l] [LocalStageProjectFollowers l] + Left la -> AudLocal [la] [localActorFollowers la] Right (remoteActor, ObjURI h lu) -> AudRemote h [lu] diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index 995a65f..ed315b6 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -33,26 +33,12 @@ module Vervis.Data.Collab , grantResourceActorID - , GrantResourceBy (..) - , unhashGrantResourcePure - , unhashGrantResource - , unhashGrantResourceE - , unhashGrantResource' - , unhashGrantResourceE' - , unhashGrantResource404 - , hashGrantResource - , hashGrantResource' - , getGrantResource - , getGrantResource404 - - , grantResourceLocalActor - , ComponentBy (..) , parseComponent , hashComponent , unhashComponentE , componentActor - , resourceToComponent + , actorToComponent , GrantRecipBy' (..) , hashGrantRecip' @@ -96,16 +82,11 @@ import Vervis.FedURI import Vervis.Foundation import Vervis.Model -parseGrantResource (RepoR r) = Just $ GrantResourceRepo r -parseGrantResource (DeckR d) = Just $ GrantResourceDeck d -parseGrantResource (LoomR l) = Just $ GrantResourceLoom l -parseGrantResource (ProjectR l) = Just $ GrantResourceProject l -parseGrantResource _ = Nothing - -parseGrantResourceCollabs (RepoCollabsR r) = Just $ GrantResourceRepo r -parseGrantResourceCollabs (DeckCollabsR d) = Just $ GrantResourceDeck d -parseGrantResourceCollabs (LoomCollabsR l) = Just $ GrantResourceLoom l -parseGrantResourceCollabs (ProjectCollabsR l) = Just $ GrantResourceProject l +parseGrantResourceCollabs (RepoCollabsR r) = Just $ LocalActorRepo r +parseGrantResourceCollabs (DeckCollabsR d) = Just $ LocalActorDeck d +parseGrantResourceCollabs (LoomCollabsR l) = Just $ LocalActorLoom l +parseGrantResourceCollabs (ProjectCollabsR l) = Just $ LocalActorProject l +parseGrantResourceCollabs (GroupMembersR l) = Just $ LocalActorGroup l parseGrantResourceCollabs _ = Nothing data GrantRecipBy f = GrantRecipPerson (f Person) @@ -142,7 +123,7 @@ verifyRole = pure parseTopic :: StageRoute Env ~ Route App - => FedURI -> ActE (Either (GrantResourceBy Key) FedURI) + => FedURI -> ActE (Either (LocalActorBy Key) FedURI) parseTopic u = do t <- parseTopic' u bitraverse @@ -156,7 +137,7 @@ parseTopic u = do parseTopic' :: StageRoute Env ~ Route App => FedURI - -> ActE (Either (Either (GrantResourceBy Key) ProjectId) FedURI) + -> ActE (Either (Either (LocalActorBy Key) ProjectId) FedURI) parseTopic' u = do routeOrRemote <- parseFedURI u bitraverse @@ -168,7 +149,7 @@ parseTopic' u = do fromMaybeE (parseGrantResourceCollabs route) "Not a shared resource collabs route" - unhashGrantResourceE' + unhashLocalActorE resourceHash "Contains invalid hashid" ) @@ -240,7 +221,7 @@ parseInvite -> AP.Invite URIMode -> ActE ( AP.Role - , Either (Either (GrantResourceBy Key) ProjectId) FedURI + , Either (Either (LocalActorBy Key) ProjectId) FedURI , Either (Either (GrantRecipBy Key) (ComponentBy Key)) FedURI ) parseInvite sender (AP.Invite instrument object target) = @@ -252,7 +233,7 @@ parseInvite sender (AP.Invite instrument object target) = parseJoin :: StageRoute Env ~ Route App => AP.Join URIMode - -> ActE (AP.Role, Either (GrantResourceBy Key) FedURI) + -> ActE (AP.Role, Either (LocalActorBy Key) FedURI) parseJoin (AP.Join instrument object) = (,) <$> verifyRole instrument <*> nameExceptT "Join object" (parseTopic object) @@ -262,7 +243,7 @@ parseGrant -> AP.Grant URIMode -> ActE ( AP.RoleExt - , Either (GrantResourceBy Key) LocalURI + , Either (LocalActorBy Key) LocalURI , Either (GrantRecipBy Key) FedURI , Maybe (LocalURI, Maybe Int) , Maybe UTCTime @@ -296,13 +277,7 @@ parseGrant h (AP.Grant object context target mresult mstart mend allows deleg) = fromMaybeE (decodeRouteLocal lu) "Grant context isn't a valid route" - resourceHash <- - fromMaybeE - (parseGrantResource route) - "Grant context isn't a shared resource route" - unhashGrantResourceE' - resourceHash - "Grant resource contains invalid hashid" + parseLocalActorE' route else pure $ Right lu parseTarget u@(ObjURI h lu) = do hl <- hostIsLocal h @@ -325,7 +300,7 @@ parseGrant' :: AP.Grant URIMode -> ActE ( AP.RoleExt - , Either (GrantResourceBy Key) FedURI + , Either (LocalActorBy Key) FedURI , Either (GrantRecipBy' Key) FedURI , Maybe (LocalURI, Maybe Int) , Maybe UTCTime @@ -356,13 +331,7 @@ parseGrant' (AP.Grant object context target mresult mstart mend allows deleg) = fromMaybeE (decodeRouteLocal lu) "Grant context isn't a valid route" - resourceHash <- - fromMaybeE - (parseGrantResource route) - "Grant context isn't a shared resource route" - unhashGrantResourceE' - resourceHash - "Grant resource contains invalid hashid" + parseLocalActorE' route else pure $ Right u parseTarget u@(ObjURI h lu) = do hl <- hostIsLocal h @@ -395,7 +364,7 @@ parseRemove => Either (LocalActorBy Key) FedURI -> AP.Remove URIMode -> ActE - ( Either (Either (GrantResourceBy Key) ProjectId) FedURI + ( Either (Either (LocalActorBy Key) ProjectId) FedURI , Either (Either (GrantRecipBy Key) (ComponentBy Key)) FedURI ) parseRemove sender (AP.Remove object origin) = @@ -451,91 +420,13 @@ parseAdd sender (AP.Add object target role) = do pure routeOrRemote -grantResourceActorID :: GrantResourceBy Identity -> ActorId -grantResourceActorID (GrantResourceRepo (Identity r)) = repoActor r -grantResourceActorID (GrantResourceDeck (Identity d)) = deckActor d -grantResourceActorID (GrantResourceLoom (Identity l)) = loomActor l -grantResourceActorID (GrantResourceProject (Identity l)) = projectActor l - -data GrantResourceBy f - = GrantResourceRepo (f Repo) - | GrantResourceDeck (f Deck) - | GrantResourceLoom (f Loom) - | GrantResourceProject (f Project) - deriving (Generic, FunctorB, TraversableB, ConstraintsB) - -deriving instance AllBF Eq f GrantResourceBy => Eq (GrantResourceBy f) - -unhashGrantResourcePure ctx = f - where - f (GrantResourceRepo r) = - GrantResourceRepo <$> decodeKeyHashidPure ctx r - f (GrantResourceDeck d) = - GrantResourceDeck <$> decodeKeyHashidPure ctx d - f (GrantResourceLoom l) = - GrantResourceLoom <$> decodeKeyHashidPure ctx l - f (GrantResourceProject l) = - GrantResourceProject <$> decodeKeyHashidPure ctx l - -unhashGrantResource resource = do - ctx <- asksSite siteHashidsContext - return $ unhashGrantResourcePure ctx resource - -unhashGrantResourceE resource e = - ExceptT $ maybe (Left e) Right <$> unhashGrantResource resource - -unhashGrantResource' resource = do - ctx <- asksEnv WAP.stageHashidsContext - return $ unhashGrantResourcePure ctx resource - -unhashGrantResourceE' resource e = - ExceptT $ maybe (Left e) Right <$> unhashGrantResource' resource - -unhashGrantResource404 = maybe notFound return <=< unhashGrantResource - -hashGrantResource (GrantResourceRepo k) = - GrantResourceRepo <$> encodeKeyHashid k -hashGrantResource (GrantResourceDeck k) = - GrantResourceDeck <$> encodeKeyHashid k -hashGrantResource (GrantResourceLoom k) = - GrantResourceLoom <$> encodeKeyHashid k -hashGrantResource (GrantResourceProject k) = - GrantResourceProject <$> encodeKeyHashid k - -hashGrantResource' (GrantResourceRepo k) = - GrantResourceRepo <$> WAP.encodeKeyHashid k -hashGrantResource' (GrantResourceDeck k) = - GrantResourceDeck <$> WAP.encodeKeyHashid k -hashGrantResource' (GrantResourceLoom k) = - GrantResourceLoom <$> WAP.encodeKeyHashid k -hashGrantResource' (GrantResourceProject k) = - GrantResourceProject <$> WAP.encodeKeyHashid k - -getGrantResource (GrantResourceRepo k) e = - GrantResourceRepo <$> getEntityE k e -getGrantResource (GrantResourceDeck k) e = - GrantResourceDeck <$> getEntityE k e -getGrantResource (GrantResourceLoom k) e = - GrantResourceLoom <$> getEntityE k e -getGrantResource (GrantResourceProject k) e = - GrantResourceProject <$> getEntityE k e - -getGrantResource404 = maybe notFound return <=< getGrantResourceEntity - where - getGrantResourceEntity (GrantResourceRepo k) = - fmap GrantResourceRepo <$> getEntity k - getGrantResourceEntity (GrantResourceDeck k) = - fmap GrantResourceDeck <$> getEntity k - getGrantResourceEntity (GrantResourceLoom k) = - fmap GrantResourceLoom <$> getEntity k - getGrantResourceEntity (GrantResourceProject k) = - fmap GrantResourceProject <$> getEntity k - -grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f -grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r -grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d -grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l -grantResourceLocalActor (GrantResourceProject l) = LocalActorProject l +grantResourceActorID :: LocalActorBy Identity -> ActorId +grantResourceActorID (LocalActorPerson (Identity p)) = personActor p +grantResourceActorID (LocalActorRepo (Identity r)) = repoActor r +grantResourceActorID (LocalActorDeck (Identity d)) = deckActor d +grantResourceActorID (LocalActorLoom (Identity l)) = loomActor l +grantResourceActorID (LocalActorProject (Identity j)) = projectActor j +grantResourceActorID (LocalActorGroup (Identity g)) = groupActor g data ComponentBy f = ComponentRepo (f Repo) @@ -573,11 +464,13 @@ componentActor (ComponentRepo r) = LocalActorRepo r componentActor (ComponentDeck d) = LocalActorDeck d componentActor (ComponentLoom l) = LocalActorLoom l -resourceToComponent = \case - GrantResourceRepo k -> Just $ ComponentRepo k - GrantResourceDeck k -> Just $ ComponentDeck k - GrantResourceLoom k -> Just $ ComponentLoom k - GrantResourceProject _ -> Nothing +actorToComponent = \case + LocalActorPerson _ -> Nothing + LocalActorRepo k -> Just $ ComponentRepo k + LocalActorDeck k -> Just $ ComponentDeck k + LocalActorLoom k -> Just $ ComponentLoom k + LocalActorProject _ -> Nothing + LocalActorGroup _ -> Nothing data GrantRecipBy' f = GrantRecipPerson' (f Person) diff --git a/src/Vervis/Data/Ticket.hs b/src/Vervis/Data/Ticket.hs index 99eca6d..7fd82bb 100644 --- a/src/Vervis/Data/Ticket.hs +++ b/src/Vervis/Data/Ticket.hs @@ -37,7 +37,6 @@ module Vervis.Data.Ticket , unhashWorkItemE , unhashWorkItem404 - , workItemResource , workItemActor , workItemFollowers , workItemRoute @@ -351,9 +350,6 @@ unhashWorkItem404 actor = maybe notFound return =<< unhashWorkItem actor ctx <- asksSite siteHashidsContext return $ unhashWorkItemPure ctx byHash -workItemResource (WorkItemTicket deck _) = GrantResourceDeck deck -workItemResource (WorkItemCloth loom _) = GrantResourceLoom loom - workItemActor (WorkItemTicket deck _) = LocalActorDeck deck workItemActor (WorkItemCloth loom _) = LocalActorLoom loom diff --git a/src/Vervis/Form/Tracker.hs b/src/Vervis/Form/Tracker.hs index 66c5cf4..98c2c68 100644 --- a/src/Vervis/Form/Tracker.hs +++ b/src/Vervis/Form/Tracker.hs @@ -18,6 +18,8 @@ module Vervis.Form.Tracker , newDeckForm , NewProject (..) , newProjectForm + , NewGroup (..) + , newGroupForm , NewLoom (..) , newLoomForm , DeckInvite (..) @@ -73,6 +75,16 @@ newProjectForm = renderDivs $ NewProject <$> areq textField "Name*" Nothing <*> areq textField "Description" Nothing +data NewGroup = NewGroup + { ngName :: Text + , ngDesc :: Text + } + +newGroupForm :: Form NewGroup +newGroupForm = renderDivs $ NewGroup + <$> areq textField "Name*" Nothing + <*> areq textField "Description" Nothing + data NewLoom = NewLoom { nlName :: Text , nlDesc :: Text diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 4963e87..ebb12e3 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -872,6 +872,7 @@ instance YesodBreadcrumbs App where PersonStampR p k -> ("Stamp #" <> keyHashidText k, Just $ PersonR p) + GroupNewR -> ("New Team", Just HomeR) GroupR g -> ("Team &" <> keyHashidText g, Just HomeR) GroupInboxR g -> ("Inbox", Just $ GroupR g) GroupOutboxR g -> ("Outbox", Just $ GroupR g) @@ -882,6 +883,8 @@ instance YesodBreadcrumbs App where GroupStampR g k -> ("Stamp #" <> keyHashidText k, Just $ GroupR g) + GroupMembersR g -> ("Members", Just $ GroupR g) + RepoR r -> ("Repo ^" <> keyHashidText r, Just HomeR) RepoInboxR r -> ("Inbox", Just $ RepoR r) RepoOutboxR r -> ("Outbox", Just $ RepoR r) diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 02070a0..4bf69bd 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -51,6 +51,8 @@ import Control.Applicative import Control.Concurrent.STM.TVar import Control.Monad import Control.Monad.Trans.Except +import Data.Bifunctor +import Data.Bitraversable import Data.List import Data.Text (Text) import Data.Time.Clock @@ -90,14 +92,17 @@ import Yesod.Form.Local import Vervis.API import Vervis.Client import Vervis.Data.Actor +import Vervis.Data.Collab import Vervis.FedURI import Vervis.Form.Ticket import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident +import Vervis.Persist.Collab import Vervis.Recipient import Vervis.Settings import Vervis.Web.Actor +import Vervis.Widget.Tracker -- | Account verification email resend form getResendVerifyEmailR :: Handler Html @@ -125,7 +130,7 @@ getHomeR = do where personalOverview :: Entity Person -> Handler Html personalOverview (Entity pid _person) = do - (repos, decks, looms, projects) <- runDB $ (,,,) + (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 @@ -166,10 +171,21 @@ getHomeR = do 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 defaultLayout $(widgetFile "personal-overview") getBrowseR :: Handler Html @@ -201,10 +217,37 @@ getBrowseR = do E.orderBy [E.asc $ loom E.^. LoomId] return (loom, actor) ) - <*> (E.select $ E.from $ \ (project `E.InnerJoin` actor) -> do - E.on $ project E.^. ProjectActor E.==. actor E.^. ActorId - E.orderBy [E.asc $ project E.^. ProjectId] - return (project, actor) + <*> (do js <- + E.select $ E.from $ \ (project `E.InnerJoin` actor) -> do + E.on $ project E.^. ProjectActor E.==. actor E.^. ActorId + E.orderBy [E.asc $ project E.^. ProjectId] + return (project, actor) + for js $ \ (j@(Entity projectID _), jactor) -> do + cs <- + E.select $ E.from $ \ (comp `E.InnerJoin` enable) -> do + E.on $ comp E.^. ComponentId E.==. enable E.^. ComponentEnableComponent + E.where_ $ comp E.^. ComponentProject E.==. E.val projectID + return comp + cs' <- for cs $ \ (Entity cid _) -> do + byKeyOrRaid <- bimap snd snd <$> getComponentIdent cid + bitraverse + (\ byKey -> do + actorID <- + case byKey of + ComponentRepo k -> repoActor <$> getJust k + ComponentDeck k -> deckActor <$> getJust k + ComponentLoom k -> loomActor <$> getJust k + actor <- getJust actorID + return (byKey, actor) + ) + (\ remoteActorID -> do + remoteActor <- getJust remoteActorID + remoteObject <- getJust $ remoteActorIdent remoteActor + inztance <- getJust $ remoteObjectInstance remoteObject + return (inztance, remoteObject, remoteActor) + ) + byKeyOrRaid + return (j, jactor, cs') ) {- now <- liftIO getCurrentTime diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs index 2d2570c..691f18b 100644 --- a/src/Vervis/Handler/Group.hs +++ b/src/Vervis/Handler/Group.hs @@ -14,7 +14,10 @@ -} module Vervis.Handler.Group - ( getGroupR + ( getGroupNewR + , postGroupNewR + + , getGroupR , getGroupInboxR , postGroupInboxR , getGroupOutboxR @@ -24,7 +27,7 @@ module Vervis.Handler.Group , getGroupStampR - + , getGroupMembersR @@ -33,9 +36,6 @@ module Vervis.Handler.Group {- , getGroupsR - , postGroupsR - , getGroupNewR - , getGroupMembersR , postGroupMembersR , getGroupMemberNewR , getGroupMemberR @@ -45,16 +45,37 @@ module Vervis.Handler.Group ) where +import Control.Applicative +import Control.Monad import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe +import Data.Aeson +import Data.Bifunctor +import Data.Bitraversable +import Data.ByteString (ByteString) +import Data.Default.Class +import Data.Foldable +import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Time.Clock +import Data.Traversable import Database.Persist -import Data.ByteString (ByteString) +import Network.HTTP.Types.Method +import Text.Blaze.Html (Html) +import Yesod.Auth (requireAuth) import Yesod.Core -import Yesod.Core.Content (TypedContent) -import Yesod.Persist.Core +import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound) +import Yesod.Form.Functions (runFormPost, runFormGet) +import Yesod.Form.Types (FormResult (..)) +import Yesod.Persist.Core (runDB, get404, getBy404) +import qualified Data.ByteString.Lazy as BL +import qualified Database.Esqueleto as E + +import Database.Persist.JSON +import Development.PatchMediaType import Network.FedURI +import Web.ActivityPub hiding (Project (..), Repo (..), Actor (..), ActorDetail (..), ActorLocal (..)) import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids @@ -62,13 +83,72 @@ import Yesod.MonadSite import qualified Web.ActivityPub as AP +import Control.Monad.Trans.Except.Local +import Data.Either.Local +import Data.Paginate.Local +import Database.Persist.Local +import Yesod.Form.Local +import Yesod.Persist.Local + +import Vervis.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 import Vervis.FedURI +import Vervis.Form.Ticket +import Vervis.Form.Tracker import Vervis.Foundation import Vervis.Model +import Vervis.Paginate +import Vervis.Persist.Actor +import Vervis.Persist.Collab import Vervis.Recipient import Vervis.Settings +import Vervis.Ticket +import Vervis.TicketFilter +import Vervis.Time import Vervis.Web.Actor +import Vervis.Widget +import Vervis.Widget.Person +import Vervis.Widget.Ticket +import Vervis.Widget.Tracker + +import qualified Vervis.Client as C + +getGroupNewR :: Handler Html +getGroupNewR = do + ((_result, widget), enctype) <- runFormPost newGroupForm + defaultLayout $(widgetFile "group/new") + +postGroupNewR :: Handler Html +postGroupNewR = do + NewGroup name desc <- runFormPostRedirect GroupNewR newGroupForm + + personEntity@(Entity personID person) <- requireAuth + personHash <- encodeKeyHashid personID + (maybeSummary, audience, detail) <- C.createGroup personHash name desc + (localRecips, remoteRecips, fwdHosts, action) <- + C.makeServerInput Nothing maybeSummary audience $ AP.CreateActivity $ AP.Create (AP.CreateTeam detail Nothing) Nothing + result <- + runExceptT $ + handleViaActor personID Nothing localRecips remoteRecips fwdHosts action + + case result of + Left e -> do + setMessage $ toHtml e + redirect GroupNewR + Right createID -> do + maybeGroupID <- runDB $ getKeyBy $ UniqueGroupCreate createID + case maybeGroupID of + Nothing -> error "Can't find the newly created group" + Just groupID -> do + groupHash <- encodeKeyHashid groupID + setMessage "New group created" + redirect $ GroupR groupHash getGroupR :: KeyHashid Group -> Handler TypedContent getGroupR groupHash = do @@ -85,7 +165,7 @@ getGroupR groupHash = do perActor <- asksSite $ appPerActorKeys . appSettings let route mk = encodeRouteLocal $ mk groupHash - groupAP = AP.Actor + actorAP = AP.Actor { AP.actorLocal = AP.ActorLocal { AP.actorId = route GroupR , AP.actorInbox = route GroupInboxR @@ -100,16 +180,20 @@ getGroupR groupHash = do , AP.actorSshKeys = [] } , AP.actorDetail = AP.ActorDetail - { AP.actorType = AP.ActorTypeOther "Group" + { AP.actorType = AP.ActorTypeTeam , AP.actorUsername = Nothing , AP.actorName = Just $ actorName actor , AP.actorSummary = Just $ actorDesc actor } } + groupAP = AP.Team + { AP.teamActor = actorAP + , AP.teamChildren = [] + , AP.teamParents = [] + , AP.teamMembers = encodeRouteLocal $ GroupMembersR groupHash + } - provideHtmlAndAP groupAP $ redirectToPrettyJSON here - where - here = GroupR groupHash + provideHtmlAndAP groupAP $(widgetFile "group/one") getGroupInboxR :: KeyHashid Group -> Handler TypedContent getGroupInboxR = getInbox GroupInboxR groupActor @@ -136,7 +220,76 @@ getGroupMessageR _ _ = notFound getGroupStampR :: KeyHashid Group -> KeyHashid SigKey -> Handler TypedContent getGroupStampR = servePerActorKey groupActor LocalActorGroup - +getGroupMembersR :: KeyHashid Group -> Handler TypedContent +getGroupMembersR groupHash = do + groupID <- decodeKeyHashid404 groupHash + members <- runDB $ do + _group <- get404 groupID + grants <- + getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID + for grants $ \ (role, actor, _ct, time) -> + (role,time,) <$> bitraverse pure (getRemoteActorURI <=< getJust) actor + h <- asksSite siteInstanceHost + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + hashPerson <- getEncodeKeyHashid + let makeItem (role, time, i) = AP.Relationship + { AP.relationshipId = Nothing + , AP.relationshipExtraTypes = [] + , AP.relationshipSubject = encodeRouteHome $ GroupR groupHash + , AP.relationshipProperty = Left AP.RelHasMember + , AP.relationshipObject = + case i of + Left personID -> encodeRouteHome $ PersonR $ hashPerson personID + Right u -> u + , AP.relationshipAttributedTo = encodeRouteLocal $ GroupR groupHash + , AP.relationshipPublished = Just time + , AP.relationshipUpdated = Nothing + , AP.relationshipInstrument = Just role + } + membersAP = AP.Collection + { AP.collectionId = encodeRouteLocal $ GroupMembersR groupHash + , AP.collectionType = CollectionTypeUnordered + , AP.collectionTotalItems = Just $ length members + , AP.collectionCurrent = Nothing + , AP.collectionFirst = Nothing + , AP.collectionLast = Nothing + , AP.collectionItems = map (Doc h . makeItem) members + , AP.collectionContext = + Just $ encodeRouteLocal $ GroupR groupHash + } + provideHtmlAndAP membersAP $ getHtml groupID + where + getHtml groupID = do + (group, actor, members, invites, joins) <- handlerToWidget $ runDB $ do + group <- get404 groupID + actor <- getJust $ groupActor group + members <- do + grants <- + getTopicGrants CollabTopicGroupCollab CollabTopicGroupGroup groupID + for grants $ \ (role, actor, ct, time) -> + (,role,ct,time) <$> getPersonWidgetInfo actor + invites <- do + invites' <- + getTopicInvites CollabTopicGroupCollab CollabTopicGroupGroup groupID + for invites' $ \ (inviter, recip, time, role) -> (,,,) + <$> (getPersonWidgetInfo =<< bitraverse grabPerson pure inviter) + <*> getPersonWidgetInfo recip + <*> pure time + <*> pure role + joins <- do + joins' <- + getTopicJoins CollabTopicGroupCollab CollabTopicGroupGroup groupID + for joins' $ \ (recip, time, role) -> + (,time,role) <$> getPersonWidgetInfo recip + return (group, actor, members, invites, joins) + $(widgetFile "group/members") + where + grabPerson actorID = do + actorByKey <- getLocalActor actorID + case actorByKey of + LocalActorPerson personID -> return personID + _ -> error "Surprise, local inviter actor isn't a Person" @@ -165,62 +318,6 @@ getGroupsR = do return sharer defaultLayout $(widgetFile "group/list") -postGroupsR :: Handler Html -postGroupsR = do - ((result, widget), enctype) <- runFormPost newGroupForm - case result of - FormSuccess ng -> do - now <- liftIO getCurrentTime - pid <- requireAuthId - runDB $ do - let sharer = Sharer - { sharerIdent = ngIdent ng - , sharerName = ngName ng - , sharerCreated = now - } - sid <- insert sharer - let group = Group - { groupIdent = sid - } - gid <- insert group - let member = GroupMember - { groupMemberPerson = pid - , groupMemberGroup = gid - , groupMemberRole = GRAdmin - , groupMemberJoined = now - } - insert_ member - redirect $ SharerR $ ngIdent ng - FormMissing -> do - setMessage "Field(s) missing" - defaultLayout $(widgetFile "group/new") - FormFailure _l -> do - setMessage "Group creation failed, see errors below" - defaultLayout $(widgetFile "group/new") - -getGroupNewR :: Handler Html -getGroupNewR = do - ((_result, widget), enctype) <- runFormPost newGroupForm - defaultLayout $(widgetFile "group/new") - -getGroupMembersR :: ShrIdent -> Handler Html -getGroupMembersR shar = do - (group, members) <- runDB $ do - Entity sid s <- getBy404 $ UniqueSharer shar - Entity gid _g <- getBy404 $ UniqueGroup sid - ms <- select $ from $ \ (member, person, sharer) -> do - where_ $ - member ^. GroupMemberGroup E.==. val gid &&. - member ^. GroupMemberPerson E.==. person ^. PersonId &&. - person ^. PersonIdent E.==. sharer ^. SharerId - orderBy - [ asc $ member ^. GroupMemberRole - , asc $ sharer ^. SharerIdent - ] - return sharer - return (s, ms) - defaultLayout $(widgetFile "group/member/list") - getgid :: ShrIdent -> AppDB GroupId getgid shar = do Entity s _ <- getBy404 $ UniqueSharer shar diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index d524e87..97dd4ce 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -3021,6 +3021,106 @@ changes hLocal ctx = "OutboxItem" -- 548 , addUnique' "CollabFulfillsInvite" "Accept" ["accept"] + -- 549 + , addFieldRefRequired'' + "Group" + (do obid <- insert Outbox549 + let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity + insertEntity $ OutboxItem549 obid doc defaultTime + ) + (Just $ \ (Entity obiidTemp obiTemp) -> do + let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity + gs <- selectKeysList ([] :: [Filter Group549]) [] + for_ gs $ \ gid -> do + obid <- do + mp <- selectFirst [] [Asc Person549Id] + p <- entityVal <$> maybe (error "No people") return mp + a <- getJust $ person549Actor p + return $ actor549Outbox a + obiid <- insert $ OutboxItem549 obid doc defaultTime + update gid [Group549Create =. obiid] + + delete obiidTemp + delete $ outboxItem549Outbox obiTemp + ) + "create" + "OutboxItem" + -- 550 + , addUnique' "Group" "Create" ["create"] + -- 551 + , addEntities model_551_group_collab + -- 552 + , addEntities model_552_collab_deleg + -- 553 + , unchecked $ lift $ do + collabIDs <- + liftA2 (++) + (map (collabTopicProject553Collab . entityVal) <$> selectList [] []) + (map (collabTopicGroup553Collab . entityVal) <$> selectList [] []) + let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity + for_ collabIDs $ \ collabID -> do + e <- getKeyBy $ UniqueCollabEnable553 collabID + r <- getBy $ UniqueCollabRecipLocal553 collabID + for_ e $ \ enableID -> for_ r $ \ (Entity recipID (CollabRecipLocal553 _ personID)) -> do + actorID <- person553Actor <$> getJust personID + outboxID <- actor553Outbox <$> getJust actorID + itemID <- insert $ OutboxItem553 outboxID doc defaultTime + insert_ $ CollabDelegLocal553 enableID recipID itemID + -- 554 + , addFieldRefRequired'' + "ComponentFurtherLocal" + (do collabID <- insert $ Collab554 RoleVisit + outboxID <- insert Outbox554 + let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity + itemID <- insert $ OutboxItem554 outboxID doc defaultTime + enableID <- insert $ CollabEnable554 collabID itemID + personID <- do + mp <- selectFirst [] [Asc Person554Id] + entityKey <$> maybe (error "No people") return mp + recipID <- insert $ CollabRecipLocal554 collabID personID + insertEntity $ CollabDelegLocal554 enableID recipID itemID + ) + (Just $ \ (Entity cdlidTemp cdlTemp) -> do + l <- selectList [] [] + for_ l $ \ (Entity cflid (ComponentFurtherLocal554 _ recipID _ _)) -> do + mk <- getKeyBy $ UniqueCollabDelegLocalRecip554 recipID + case mk of + Nothing -> error "Found ComponentFurtherLocal whose CollabRecipLocal doesn't have a CollabDelegLocal, previous migration should have created it" + Just k -> update cflid [ComponentFurtherLocal554CollabNew =. k] + + delete cdlidTemp + let CollabDelegLocal554 enableID recipID itemID = cdlTemp + delete recipID + collabID <- collabEnable554Collab <$> getJust enableID + delete enableID + outboxID <- outboxItem554Outbox <$> getJust itemID + delete itemID + delete outboxID + delete collabID + ) + "collabNew" + "CollabDelegLocal" + -- 555 + , addFieldRefRequiredEmpty + "ComponentFurtherRemote" "collabNew" "CollabDelegRemote" + -- 556 + , removeUnique' "ComponentFurtherLocal" "" + -- 557 + , removeField "ComponentFurtherLocal" "collab" + -- 558 + , renameField "ComponentFurtherLocal" "collabNew" "collab" + -- 559 + , addUnique' "ComponentFurtherLocal" "" ["component", "collab"] + -- 560 + , removeUnique' "ComponentFurtherRemote" "" + -- 561 + , removeField "ComponentFurtherRemote" "collab" + -- 562 + , renameField "ComponentFurtherRemote" "collabNew" "collab" + -- 563 + , addUnique' "ComponentFurtherRemote" "" ["component", "collab"] + -- 564 + , addEntities model_564_permit ] migrateDB diff --git a/src/Vervis/Migration/Entities.hs b/src/Vervis/Migration/Entities.hs index 1a5dcac..c84d222 100644 --- a/src/Vervis/Migration/Entities.hs +++ b/src/Vervis/Migration/Entities.hs @@ -64,6 +64,9 @@ module Vervis.Migration.Entities , model_531_follow_request , model_541_project , model_542_component + , model_551_group_collab + , model_552_collab_deleg + , model_564_permit ) where @@ -248,3 +251,12 @@ model_541_project = $(schema "541_2023-06-26_project") model_542_component :: [Entity SqlBackend] model_542_component = $(schema "542_2023-06-26_component") + +model_551_group_collab :: [Entity SqlBackend] +model_551_group_collab = $(schema "551_2023-11-21_group_collab") + +model_552_collab_deleg :: [Entity SqlBackend] +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") diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 61369c3..e713717 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -528,3 +528,12 @@ makeEntitiesMigration "527" makeEntitiesMigration "547" $(modelFile "migrations/547_2023-06-28_invite_accept.model") + +makeEntitiesMigration "549" + $(modelFile "migrations/549_2023-11-21_group_create.model") + +makeEntitiesMigration "553" + $(modelFile "migrations/553_2023-11-21_collab_deleg.model") + +makeEntitiesMigration "554" + $(modelFile "migrations/554_2023-11-21_further_local_deleg.model") diff --git a/src/Vervis/Persist/Actor.hs b/src/Vervis/Persist/Actor.hs index 4f51d96..6cb052d 100644 --- a/src/Vervis/Persist/Actor.hs +++ b/src/Vervis/Persist/Actor.hs @@ -17,8 +17,12 @@ module Vervis.Persist.Actor ( getLocalActor , getLocalActorEnt , getLocalActorEntity + , getLocalActorEntityE + , getLocalActorEntity404 , verifyLocalActivityExistsInDB + , getRemoteObjectURI , getRemoteActorURI + , getRemoteActivityURI , insertActor , updateOutboxItem , updateOutboxItem' @@ -39,6 +43,7 @@ import Data.Text (Text) import Data.Traversable import Database.Persist import Database.Persist.Sql +import Yesod.Core.Handler import qualified Data.Text as T import qualified Database.Esqueleto as E @@ -110,6 +115,14 @@ getLocalActorEntity (LocalActorLoom l) = getLocalActorEntity (LocalActorProject r) = fmap (LocalActorProject . Entity r) <$> get r +getLocalActorEntityE a e = do + m <- lift $ getLocalActorEntity a + case m of + Nothing -> throwE e + Just a' -> return a' + +getLocalActorEntity404 = maybe notFound return <=< getLocalActorEntity + verifyLocalActivityExistsInDB :: MonadIO m => LocalActorBy Key @@ -125,14 +138,21 @@ verifyLocalActivityExistsInDB actorByKey outboxItemID = do unless (itemActorByKey == actorByKey) $ throwE "Actor-in-URI and Actor-owning-the-outbox-item-in-DB mismatch" -getRemoteActorURI actor = do - object <- getJust $ remoteActorIdent actor +getRemoteObjectURI object = do inztance <- getJust $ remoteObjectInstance object return $ ObjURI (instanceHost inztance) (remoteObjectIdent object) +getRemoteActorURI actor = do + object <- getJust $ remoteActorIdent actor + getRemoteObjectURI object + +getRemoteActivityURI act = do + object <- getJust $ remoteActivityIdent act + getRemoteObjectURI object + insertActor now name desc mby = do ibid <- insert Inbox obid <- insert Outbox diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index 5506727..4caaef5 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -16,6 +16,8 @@ module Vervis.Persist.Collab ( getCollabTopic , getCollabTopic' + , getCollabRecip + , getPermitTopic , getStemIdent , getStemProject , getGrantRecip @@ -32,6 +34,7 @@ module Vervis.Persist.Collab , getComponentIdent , checkExistingStems + , checkExistingPermits ) where @@ -62,6 +65,7 @@ import qualified Web.ActivityPub as AP import Control.Monad.Trans.Except.Local import Data.Either.Local +import Data.Maybe.Local import Database.Persist.Local import Vervis.Actor @@ -70,45 +74,84 @@ import Vervis.Model import Vervis.Persist.Actor getCollabTopic - :: MonadIO m => CollabId -> ReaderT SqlBackend m (GrantResourceBy Key) -getCollabTopic collabID = do - maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID - maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID - maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID - maybeProject <- getValBy $ UniqueCollabTopicProject collabID - return $ - case (maybeRepo, maybeDeck, maybeLoom, maybeProject) of - (Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic" - (Just r, Nothing, Nothing, Nothing) -> - GrantResourceRepo $ collabTopicRepoRepo r - (Nothing, Just d, Nothing, Nothing) -> - GrantResourceDeck $ collabTopicDeckDeck d - (Nothing, Nothing, Just l, Nothing) -> - GrantResourceLoom $ collabTopicLoomLoom l - (Nothing, Nothing, Nothing, Just l) -> - GrantResourceProject $ collabTopicProjectProject l - _ -> error "Found Collab with multiple topics" + :: MonadIO m => CollabId -> ReaderT SqlBackend m (LocalActorBy Key) +getCollabTopic = fmap snd . getCollabTopic' getCollabTopic' - :: MonadIO m => CollabId -> ReaderT SqlBackend m (ReaderT SqlBackend m (), GrantResourceBy Key) + :: MonadIO m => CollabId -> ReaderT SqlBackend m (ReaderT SqlBackend m (), LocalActorBy Key) getCollabTopic' collabID = do maybeRepo <- getBy $ UniqueCollabTopicRepo collabID maybeDeck <- getBy $ UniqueCollabTopicDeck collabID maybeLoom <- getBy $ UniqueCollabTopicLoom collabID maybeProject <- getBy $ UniqueCollabTopicProject collabID + maybeGroup <- getBy $ UniqueCollabTopicGroup collabID return $ - case (maybeRepo, maybeDeck, maybeLoom, maybeProject) of - (Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic" - (Just (Entity k r), Nothing, Nothing, Nothing) -> - (delete k, GrantResourceRepo $ collabTopicRepoRepo r) - (Nothing, Just (Entity k d), Nothing, Nothing) -> - (delete k, GrantResourceDeck $ collabTopicDeckDeck d) - (Nothing, Nothing, Just (Entity k l), Nothing) -> - (delete k, GrantResourceLoom $ collabTopicLoomLoom l) - (Nothing, Nothing, Nothing, Just (Entity k l)) -> - (delete k, GrantResourceProject $ collabTopicProjectProject l) + case (maybeRepo, maybeDeck, maybeLoom, maybeProject, maybeGroup) of + (Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Found Collab without topic" + (Just (Entity k r), Nothing, Nothing, Nothing, Nothing) -> + (delete k, LocalActorRepo $ collabTopicRepoRepo r) + (Nothing, Just (Entity k d), Nothing, Nothing, Nothing) -> + (delete k, LocalActorDeck $ collabTopicDeckDeck d) + (Nothing, Nothing, Just (Entity k l), Nothing, Nothing) -> + (delete k, LocalActorLoom $ collabTopicLoomLoom l) + (Nothing, Nothing, Nothing, Just (Entity k l), Nothing) -> + (delete k, LocalActorProject $ collabTopicProjectProject l) + (Nothing, Nothing, Nothing, Nothing, Just (Entity k l)) -> + (delete k, LocalActorGroup $ collabTopicGroupGroup l) _ -> error "Found Collab with multiple topics" +getCollabRecip + :: MonadIO m + => CollabId + -> ReaderT SqlBackend m + (Either (Entity CollabRecipLocal) (Entity CollabRecipRemote)) +getCollabRecip collabID = + requireEitherAlt + (getBy $ UniqueCollabRecipLocal collabID) + (getBy $ UniqueCollabRecipRemote collabID) + "Collab without recip" + "Collab with both local and remote recip" + +getPermitTopic + :: MonadIO m + => PermitId + -> ReaderT SqlBackend m + (Either + (PermitTopicLocalId, LocalActorBy Key) + (PermitTopicRemoteId, RemoteActorId) + ) +getPermitTopic permitID = do + topic <- + requireEitherAlt + (getKeyBy $ UniquePermitTopicLocal permitID) + (getBy $ UniquePermitTopicRemote permitID) + "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" + ) + (\ (Entity topicID (PermitTopicRemote _ actorID)) -> + return (topicID, actorID) + ) + topic + getStemIdent :: MonadIO m => StemId -> ReaderT SqlBackend m (ComponentBy Key) getStemIdent stemID = do maybeRepo <- getValBy $ UniqueStemIdentRepo stemID @@ -301,7 +344,7 @@ verifyCapability :: MonadIO m => (LocalActorBy Key, OutboxItemId) -> Either PersonId RemoteActorId - -> GrantResourceBy Key + -> LocalActorBy Key -> AP.Role -> ExceptT Text (ReaderT SqlBackend m) () verifyCapability (capActor, capItem) actor resource requiredRole = do @@ -333,7 +376,7 @@ verifyCapability (capActor, capItem) actor resource requiredRole = do topic <- lift $ getCollabTopic collabID -- Verify that topic is indeed the sender of the Grant - unless (grantResourceLocalActor topic == capActor) $ + unless (topic == capActor) $ error "Grant sender isn't the topic" -- Verify the topic matches the resource specified @@ -351,7 +394,7 @@ verifyCapability' -> Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI, Maybe ByteString) - -> GrantResourceBy Key + -> LocalActorBy Key -> AP.Role -> ExceptT Text (ReaderT SqlBackend m) () verifyCapability' cap actor resource role = do @@ -508,3 +551,127 @@ checkExistingStems componentByID projectDB = do const () <$> MaybeT (getBy $ UniqueStemProjectAcceptLocalProject localID) Right remoteID -> const () <$> MaybeT (getBy $ UniqueStemProjectAcceptRemoteProject remoteID) + +checkExistingPermits + :: PersonId -> Either (LocalActorBy Key) RemoteActorId -> ActDBE () +checkExistingPermits personID topicDB = do + + -- Find existing Permit records I have for this topic + permitIDs <- lift $ getExistingPermits topicDB + + -- Grab all the enabled ones, make sure none are enabled, and even if + -- any are enabled, make sure there's at most one (otherwise it's a + -- bug) + byEnabled <- + lift $ for permitIDs $ \ (_, permit) -> + isJust <$> runMaybeT (tryPermitEnabled permit) + case length $ filter id byEnabled of + 0 -> return () + 1 -> throwE "I already have a PermitTopicEnable* for this topic" + _ -> error "Multiple PermitTopicEnable* for a topic" + + -- Verify none of the Permit records are already in Join or + -- Invite-and-Accept state + anyStarted <- + lift $ runMaybeT $ asum $ + map (\ (permitID, topic) -> + tryPermitJoin permitID <|> + tryPermitInviteAccept permitID topic + ) + permitIDs + unless (isNothing anyStarted) $ + throwE + "One of the Permit records is already in Join or Invite-Accept \ + \state" + + where + + getExistingPermits (Left (LocalActorPerson _)) = pure [] + getExistingPermits (Left (LocalActorRepo repoID)) = + fmap (map $ bimap E.unValue (Left . E.unValue)) $ + E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do + E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicRepoPermit + E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit + E.where_ $ + permit E.^. PermitPerson E.==. E.val personID E.&&. + topic E.^. PermitTopicRepoRepo E.==. E.val repoID + return + ( permit E.^. PermitId + , local E.^. PermitTopicLocalId + ) + getExistingPermits (Left (LocalActorDeck deckID)) = + fmap (map $ bimap E.unValue (Left . E.unValue)) $ + E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do + E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicDeckPermit + E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit + E.where_ $ + permit E.^. PermitPerson E.==. E.val personID E.&&. + topic E.^. PermitTopicDeckDeck E.==. E.val deckID + return + ( permit E.^. PermitId + , local E.^. PermitTopicLocalId + ) + getExistingPermits (Left (LocalActorLoom loomID)) = + fmap (map $ bimap E.unValue (Left . E.unValue)) $ + E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do + E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicLoomPermit + E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit + E.where_ $ + permit E.^. PermitPerson E.==. E.val personID E.&&. + topic E.^. PermitTopicLoomLoom E.==. E.val loomID + return + ( permit E.^. PermitId + , local E.^. PermitTopicLocalId + ) + getExistingPermits (Left (LocalActorProject projectID)) = + fmap (map $ bimap E.unValue (Left . E.unValue)) $ + E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do + E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicProjectPermit + E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit + E.where_ $ + permit E.^. PermitPerson E.==. E.val personID E.&&. + topic E.^. PermitTopicProjectProject E.==. E.val projectID + return + ( permit E.^. PermitId + , local E.^. PermitTopicLocalId + ) + getExistingPermits (Left (LocalActorGroup groupID)) = + fmap (map $ bimap E.unValue (Left . E.unValue)) $ + E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do + E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicGroupPermit + E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit + E.where_ $ + permit E.^. PermitPerson E.==. E.val personID E.&&. + topic E.^. PermitTopicGroupGroup E.==. E.val groupID + return + ( permit E.^. PermitId + , local E.^. PermitTopicLocalId + ) + getExistingPermits (Right remoteActorID) = + fmap (map $ bimap E.unValue (Right . E.unValue)) $ + E.select $ E.from $ \ (permit `E.InnerJoin` remote) -> do + E.on $ permit E.^. PermitId E.==. remote E.^. PermitTopicRemotePermit + E.where_ $ + permit E.^. PermitPerson E.==. E.val personID E.&&. + remote E.^. PermitTopicRemoteActor E.==. E.val remoteActorID + return + ( permit E.^. PermitId + , remote E.^. PermitTopicRemoteId + ) + + tryPermitEnabled (Left localID) = + const () <$> MaybeT (getBy $ UniquePermitTopicEnableLocalTopic localID) + tryPermitEnabled (Right remoteID) = + const () <$> MaybeT (getBy $ UniquePermitTopicEnableRemoteTopic remoteID) + + tryPermitJoin permitID = do + _ <- MaybeT $ getBy $ UniquePermitFulfillsJoin permitID + pure () + + tryPermitInviteAccept permitID topic = do + _fulfillsID <- MaybeT $ getKeyBy $ UniquePermitFulfillsInvite permitID + case topic of + Left localID -> + const () <$> MaybeT (getBy $ UniquePermitTopicAcceptLocalTopic localID) + Right remoteID -> + const () <$> MaybeT (getBy $ UniquePermitTopicAcceptRemoteTopic remoteID) diff --git a/src/Vervis/Persist/Ticket.hs b/src/Vervis/Persist/Ticket.hs index d912faf..f8615a7 100644 --- a/src/Vervis/Persist/Ticket.hs +++ b/src/Vervis/Persist/Ticket.hs @@ -179,7 +179,7 @@ checkApplyDB actor capID (repoID, maybeBranch) (loomID, clothID, bundleID) = do case capID of Left (capActor, _, capItem) -> return (capActor, capItem) Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local loom" - verifyCapability capability actor (GrantResourceLoom loomID) AP.RoleWrite + verifyCapability capability actor (LocalActorLoom loomID) AP.RoleWrite -- Get the patches from DB, verify VCS match just in case diffs <- do diff --git a/src/Vervis/Recipient.hs b/src/Vervis/Recipient.hs index e779417..fa88bc5 100644 --- a/src/Vervis/Recipient.hs +++ b/src/Vervis/Recipient.hs @@ -770,28 +770,6 @@ localRecipSieve' sieve allowPeople allowOthers routes = RecipientRoutes then Nothing else Just (rkhid, merged) -actorIsAddressed :: RecipientRoutes -> LocalActor -> Bool -actorIsAddressed recips = isJust . verify - where - verify (LocalActorPerson p) = do - routes <- lookup p $ recipPeople recips - guard $ routePerson routes - verify (LocalActorGroup g) = do - routes <- lookup g $ recipGroups recips - guard $ routeGroup routes - verify (LocalActorRepo r) = do - routes <- lookup r $ recipRepos recips - guard $ routeRepo routes - verify (LocalActorDeck d) = do - routes <- lookup d $ recipDecks recips - guard $ routeDeck $ familyDeck routes - verify (LocalActorLoom l) = do - routes <- lookup l $ recipLooms recips - guard $ routeLoom $ familyLoom routes - verify (LocalActorProject j) = do - routes <- lookup j $ recipProjects recips - guard $ routeProject routes - data ParsedAudience u = ParsedAudience { paudLocalRecips :: RecipientRoutes , paudRemoteActors :: [(Authority u, NonEmpty LocalURI)] diff --git a/src/Vervis/Web/Collab.hs b/src/Vervis/Web/Collab.hs index 8ccf3b1..f83db53 100644 --- a/src/Vervis/Web/Collab.hs +++ b/src/Vervis/Web/Collab.hs @@ -91,15 +91,14 @@ verifyCapability'' -> Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI, Maybe ByteString) - -> GrantResourceBy Key + -> LocalActorBy Key -> AP.Role -> ActE () verifyCapability'' uCap recipientActor resource requiredRole = do manager <- asksEnv envHttpManager encodeRouteHome <- getEncodeRouteHome uResource <- - encodeRouteHome . VR.renderLocalActor <$> - hashLocalActor (grantResourceLocalActor resource) + encodeRouteHome . VR.renderLocalActor <$> hashLocalActor resource now <- liftIO getCurrentTime grants <- traverseGrants manager uResource now unless (checkRole grants) $ @@ -220,7 +219,7 @@ verifyCapability'' uCap recipientActor resource requiredRole = do -- Find the local topic, on which this Collab gives access topic <- lift $ getCollabTopic collabID -- Verify that topic is indeed the sender of the Grant - unless (grantResourceLocalActor topic == capActor) $ + unless (topic == capActor) $ error "Grant sender isn't the topic" -- Verify the topic matches the resource specified unless (topic == resource) $ @@ -242,7 +241,7 @@ verifyCapability'' uCap recipientActor resource requiredRole = do unless (componentActor topic == capActor) $ error "Grant sender isn't the Stem ident" -- Verify the topic matches the resource specified - unless (componentActor topic == grantResourceLocalActor resource) $ + unless (componentActor topic == resource) $ throwE "Capability topic is some other local resource" return $ (u, activity, grant, role, targetIsProject, targetIsTeam) : l @@ -250,7 +249,7 @@ verifyCapability'' uCap recipientActor resource requiredRole = do Just uParent -> nameExceptT "Extension-Grant" $ do case cap of Left (actor, _, _) - | grantResourceLocalActor resource == actor -> + | resource == actor -> throwE "Grant.delegates specified but Grant's actor is me" _ -> return () (luResult, _) <- fromMaybeE (AP.grantResult grant) "Grant.result not specified" diff --git a/src/Vervis/Widget.hs b/src/Vervis/Widget.hs index 5c07ded..3a624e5 100644 --- a/src/Vervis/Widget.hs +++ b/src/Vervis/Widget.hs @@ -46,6 +46,7 @@ breadcrumbsW = do revisionW :: WidgetFor site () revisionW = let rev = $gitDescribe :: Text + hash = $gitHash :: Text address = "^rjQ3E@vervis.peers.community" :: Text link = "https://vervis.peers.community/repos/rjQ3E" :: Text changes = $gitCommitCount :: Text diff --git a/src/Vervis/Widget/Tracker.hs b/src/Vervis/Widget/Tracker.hs index 7acf220..17edc8e 100644 --- a/src/Vervis/Widget/Tracker.hs +++ b/src/Vervis/Widget/Tracker.hs @@ -19,6 +19,7 @@ module Vervis.Widget.Tracker , projectNavW , componentLinkFedW , projectLinkFedW + , groupNavW ) where @@ -50,6 +51,11 @@ projectNavW (Entity projectID project) actor = do projectHash <- encodeKeyHashid projectID $(widgetFile "project/widget/nav") +groupNavW :: Entity Group -> Actor -> Widget +groupNavW (Entity groupID group) actor = do + groupHash <- encodeKeyHashid groupID + $(widgetFile "group/nav") + componentLinkW :: ComponentBy Key -> Actor -> Widget componentLinkW (ComponentRepo k) actor = do h <- encodeKeyHashid k diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index b78bcd2..db3e34c 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -51,6 +51,7 @@ module Web.ActivityPub , Resource (..) , ResourceWithCollections (..) , Project (..) + , Team (..) -- * Content objects , Note (..) @@ -859,6 +860,7 @@ data ResourceWithCollections u = ResourceWithCollections { rwcResource :: Resource u , rwcCollabs :: Maybe LocalURI , rwcComponents :: Maybe LocalURI + , rwcMembers :: Maybe LocalURI } instance ActivityPub ResourceWithCollections where @@ -868,10 +870,12 @@ instance ActivityPub ResourceWithCollections where fmap (h,) $ ResourceWithCollections r <$> withAuthorityMaybeO h (o .:? "collaborators") <*> withAuthorityMaybeO h (o .:? "components") - toSeries h (ResourceWithCollections r collabs comps) + <*> withAuthorityMaybeO h (o .:? "members") + toSeries h (ResourceWithCollections r collabs comps members) = toSeries h r <> "collaborators" .=? (ObjURI h <$> collabs) <> "components" .=? (ObjURI h <$> comps) + <> "members" .=? (ObjURI h <$> members) data Project u = Project { projectActor :: Actor u @@ -917,6 +921,44 @@ instance ActivityPub Project where <> "components" .= ObjURI h components <> "collaborators" .= ObjURI h collabs +data Team u = Team + { teamActor :: Actor u + , teamChildren :: [ObjURI u] + , teamParents :: [ObjURI u] + , teamMembers :: LocalURI + } + +instance ActivityPub Team where + jsonldContext _ = [as2Context, secContext, forgeContext] + parseObject o = do + (h, a) <- parseObject o + unless (actorType (actorDetail a) == ActorTypeTeam) $ + 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 .: "members") + toSeries h (Team actor children parents members) + = toSeries h actor + <> "subteams" `pair` pairs + ( "type" .= ("Collection" :: Text) + <> "items" .= children + <> "totalItems" .= length children + ) + <> "context" .= parents + <> "members" .= ObjURI h members + data Audience u = Audience { audienceTo :: [ObjURI u] , audienceBto :: [ObjURI u] @@ -1077,7 +1119,9 @@ instance ActivityPub Note where <> "content" .= content <> "mediaType" .= ("text/html" :: Text) -data RelationshipProperty = RelDependsOn | RelHasCollab deriving Eq +data RelationshipProperty = + RelDependsOn | RelHasCollab | RelHasMember + deriving Eq instance FromJSON RelationshipProperty where parseJSON = withText "RelationshipProperty" parse @@ -1085,6 +1129,7 @@ instance FromJSON RelationshipProperty where parse t | t == "dependsOn" = pure RelDependsOn | t == "hasCollaborator" = pure RelHasCollab + | t == "hasMember" = pure RelHasMember | otherwise = fail $ "Unrecognized relationship: " ++ T.unpack t instance ToJSON RelationshipProperty where @@ -1093,6 +1138,7 @@ instance ToJSON RelationshipProperty where toEncoding $ case at of RelDependsOn -> "dependsOn" :: Text RelHasCollab -> "hasCollaborator" + RelHasMember -> "hasMember" data Relationship u = Relationship { relationshipId :: Maybe (ObjURI u) @@ -1788,6 +1834,7 @@ data CreateObject u | CreateRepository ActorDetail VersionControlSystem (Maybe (Authority u, ActorLocal u)) | CreatePatchTracker ActorDetail (NonEmpty (ObjURI u)) (Maybe (Authority u, ActorLocal u)) | CreateProject ActorDetail (Maybe (Authority u, ActorLocal u)) + | CreateTeam ActorDetail (Maybe (Authority u, ActorLocal u)) parseCreateObject :: UriMode u => Object -> Parser (CreateObject u) parseCreateObject o @@ -1815,6 +1862,11 @@ parseCreateObject o fail "type isn't Project" ml <- parseActorLocal o return $ CreateProject d ml + <|> do d <- parseActorDetail o + unless (actorType d == ActorTypeTeam) $ + fail "type isn't Team" + ml <- parseActorLocal o + return $ CreateTeam d ml encodeCreateObject :: UriMode u => CreateObject u -> Series encodeCreateObject (CreateNote h note) = toSeries h note @@ -1831,6 +1883,8 @@ encodeCreateObject (CreatePatchTracker d repos ml) <> maybe mempty (uncurry encodeActorLocal) ml encodeCreateObject (CreateProject d ml) = encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml +encodeCreateObject (CreateTeam d ml) = + encodeActorDetail d <> maybe mempty (uncurry encodeActorLocal) ml data Create u = Create { createObject :: CreateObject u @@ -1851,6 +1905,7 @@ parseCreate o a luActor = do CreateRepository _ _ _ -> return () CreatePatchTracker _ _ _ -> return () CreateProject _ _ -> return () + CreateTeam _ _ -> return () Create obj <$> o .:? "target" encodeCreate :: UriMode u => Create u -> Series diff --git a/templates/browse.hamlet b/templates/browse.hamlet index 49e4579..3fac905 100644 --- a/templates/browse.hamlet +++ b/templates/browse.hamlet @@ -56,7 +56,11 @@ $# .

Projects