diff --git a/migrations/466_2022-09-04_collab_topic_repo.model b/migrations/466_2022-09-04_collab_topic_repo.model new file mode 100644 index 0000000..241aadc --- /dev/null +++ b/migrations/466_2022-09-04_collab_topic_repo.model @@ -0,0 +1,15 @@ +Repo + +Collab + +CollabTopicLocal + collab CollabId + + UniqueCollabTopicLocal collab + +CollabTopicLocalRepo + collab CollabTopicLocalId + collabNew CollabId + repo RepoId + + UniqueCollabTopicLocalRepo collab diff --git a/migrations/467_2022-09-04_collab_topic_deck.model b/migrations/467_2022-09-04_collab_topic_deck.model new file mode 100644 index 0000000..cf04197 --- /dev/null +++ b/migrations/467_2022-09-04_collab_topic_deck.model @@ -0,0 +1,15 @@ +Deck + +Collab + +CollabTopicLocal + collab CollabId + + UniqueCollabTopicLocal collab + +CollabTopicLocalDeck + collab CollabTopicLocalId + collabNew CollabId + deck DeckId + + UniqueCollabTopicLocalDeck collab diff --git a/migrations/468_2022-09-04_collab_topic_loom.model b/migrations/468_2022-09-04_collab_topic_loom.model new file mode 100644 index 0000000..2fe78cc --- /dev/null +++ b/migrations/468_2022-09-04_collab_topic_loom.model @@ -0,0 +1,15 @@ +Loom + +Collab + +CollabTopicLocal + collab CollabId + + UniqueCollabTopicLocal collab + +CollabTopicLocalLoom + collab CollabTopicLocalId + collabNew CollabId + loom LoomId + + UniqueCollabTopicLocalLoom collab diff --git a/migrations/486_2022-09-04_collab_enable.model b/migrations/486_2022-09-04_collab_enable.model new file mode 100644 index 0000000..6957da1 --- /dev/null +++ b/migrations/486_2022-09-04_collab_enable.model @@ -0,0 +1,16 @@ +OutboxItem + +Collab + +CollabTopicLocal + collab CollabId + + UniqueCollabTopicLocal collab + +CollabEnable + collab CollabTopicLocalId + collabNew CollabId + grant OutboxItemId + + UniqueCollabTopicLocalAcceptCollab collab + UniqueCollabTopicLocalAcceptAccept grant diff --git a/src/Control/Monad/Trans/Except/Local.hs b/src/Control/Monad/Trans/Except/Local.hs index 62a8931..47bf0a4 100644 --- a/src/Control/Monad/Trans/Except/Local.hs +++ b/src/Control/Monad/Trans/Except/Local.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019 by fr33domlover . + - Written in 2019, 2022 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -16,10 +16,12 @@ module Control.Monad.Trans.Except.Local ( fromMaybeE , verifyNothingE + , nameExceptT ) where import Control.Monad.Trans.Except +import Data.Text (Text) fromMaybeE :: Monad m => Maybe a -> e -> ExceptT e m a fromMaybeE Nothing t = throwE t @@ -28,3 +30,6 @@ fromMaybeE (Just x) _ = return x verifyNothingE :: Monad m => Maybe a -> e -> ExceptT e m () verifyNothingE Nothing _ = return () verifyNothingE (Just _) e = throwE e + +nameExceptT :: Functor m => Text -> ExceptT Text m a -> ExceptT Text m a +nameExceptT title = withExceptT $ \ e -> title <> ": " <> e diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index c169981..c2b54ce 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -24,7 +24,7 @@ module Vervis.API , createNoteC , createTicketTrackerC , followC - , grantC + , inviteC , offerTicketC , offerDepC , resolveC @@ -118,6 +118,7 @@ import Vervis.ActivityPub import Vervis.ActorKey import Vervis.Cloth import Vervis.Darcs +import Vervis.Data.Actor import Vervis.Data.Collab import Vervis.Delivery import Vervis.Discussion @@ -169,7 +170,7 @@ acceptC -> Audience URIMode -> Accept URIMode -> ExceptT Text Handler OutboxItemId -acceptC (Entity pidUser personUser) senderActor summary audience accept = do +acceptC (Entity senderPersonID senderPerson) senderActor summary audience accept = do -- Check input acceptee <- parseAccept accept @@ -180,71 +181,70 @@ acceptC (Entity pidUser personUser) senderActor summary audience accept = do return recips now <- liftIO getCurrentTime - senderHash <- encodeKeyHashid pidUser + senderHash <- encodeKeyHashid senderPersonID - (obiidAccept, deliverHttpAccept, deliverHttpTopicAccept) <- runDBExcept $ do + (obiidAccept, deliverHttpAccept, deliverHttpGrant) <- runDBExcept $ do - -- Find a Collab record for the accepted activity + -- Find the accepted activity in our DB accepteeDB <- do a <- getActivity acceptee fromMaybeE a "Can't find acceptee in DB" - (collabID, collabSender) <- + + -- See if the accepted activity is an Invite to a local resource + maybeCollab <- + --(collabID, collabSender) <- case accepteeDB of - Left (actor, itemID) -> do + Left (actorByKey, actorEntity, itemID) -> do maybeSender <- - lift $ getValBy $ UniqueCollabSenderLocalActivity itemID - (,Left actor) . collabSenderLocalCollab <$> - fromMaybeE maybeSender "No Collab for this local activity" + lift $ getValBy $ UniqueCollabFulfillsInviteLocalInvite itemID + return $ + (,Left (actorByKey, actorEntity)) . collabFulfillsInviteLocalCollab <$> maybeSender Right remoteActivityID -> do maybeSender <- - lift $ getValBy $ UniqueCollabSenderRemoteActivity remoteActivityID - CollabSenderRemote collab actorID _ <- - fromMaybeE maybeSender "No Collab for this remote activity" - actor <- lift $ getJust actorID - lift $ - (collab,) . Right . (,remoteActorFollowers actor) <$> - getRemoteActorURI' actor + lift $ getValBy $ UniqueCollabFulfillsInviteRemoteInvite remoteActivityID + for maybeSender $ \ (CollabFulfillsInviteRemote collab actorID _) -> do + actor <- lift $ getJust actorID + lift $ + (collab,) . Right . (,remoteActorFollowers actor) <$> + getRemoteActorURI actor - -- Verify that Accept sender is the Collab recipient - recip <- - lift $ - requireEitherAlt - (getBy $ UniqueCollabRecipLocal collabID) - (getBy $ UniqueCollabRecipRemote collabID) - "Found Collab with no recip" - "Found Collab with multiple recips" - recipID <- - case recip of - Left (Entity crlid crl) - | collabRecipLocalPerson crl == pidUser -> return crlid - _ -> throwE "Accepting a Collab whose recipient is someone else" + maybeCollabMore <- for maybeCollab $ \ (collabID, collabSender) -> do - -- Verify the Collab isn't already validated - topicActor <- lift $ getCollabTopic collabID - case topicActor of - Left (localID, _) -> do - maybeValid <- lift $ getBy $ UniqueCollabTopicLocalAcceptCollab localID - verifyNothingE maybeValid "Collab already Accepted by the local topic" - Right (remoteID, _) -> do - maybeValid <- lift $ getBy $ UniqueCollabTopicRemoteAcceptCollab remoteID - verifyNothingE maybeValid "Collab already Accepted by the remote topic" + -- Verify that Accept sender is the Collab recipient + recip <- + lift $ + requireEitherAlt + (getBy $ UniqueCollabRecipLocal collabID) + (getBy $ UniqueCollabRecipRemote collabID) + "Found Collab with no recip" + "Found Collab with multiple recips" + recipID <- + case recip of + Left (Entity crlid crl) + | collabRecipLocalPerson crl == senderPersonID -> return crlid + _ -> throwE "Accepting an Invite whose recipient is someone else" - -- Verify that Grant sender and resource are addressed by the Accept - bitraverse_ - (verifyResourceAddressed localRecips . snd) - (verifyRemoteAddressed remoteRecips . snd) - topicActor - bitraverse_ - (verifySenderAddressed localRecips) - (verifyRemoteAddressed remoteRecips . fst) - collabSender + -- Verify the Collab isn't already validated + maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID + verifyNothingE maybeEnabled "Collab already enabled by the local topic" + + -- Verify that Grant sender and resource are addressed by the Accept + topic <- lift $ getCollabTopic collabID + verifyResourceAddressed localRecips topic + bitraverse_ + (verifySenderAddressed localRecips . fst) + (verifyRemoteAddressed remoteRecips . fst) + collabSender + + return (collabID, recipID, topic, collabSender) -- Record the Accept on the Collab acceptID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now - maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID acceptID - unless (isNothing maybeAccept) $ do - lift $ delete acceptID - throwE "This Collab already has an Accept by recip" + for_ maybeCollabMore $ \ (_, recipID, _, _) -> do + maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID acceptID + unless (isNothing maybeAccept) $ do + lift $ delete acceptID + throwE "This Collab already has an Accept by recip" -- Insert the Accept activity to author's outbox docAccept <- lift $ insertAcceptToOutbox senderHash now blinded acceptID @@ -252,93 +252,77 @@ acceptC (Entity pidUser personUser) senderActor summary audience accept = do -- Deliver the Accept activity to local recipients, and schedule -- delivery for unavailable remote recipients remoteRecipsHttpAccept <- do - topicHash <- bitraverse (hashGrantResource . snd) (pure . snd) topicActor + let maybeTopicActor = (\ (_, _, t, _) -> t) <$> maybeCollabMore + maybeCollabSender = (\ (_, _, _, s) -> s) <$> maybeCollabMore + maybeTopicHash <- traverse hashGrantResource maybeTopicActor + maybeSenderHash <- + case maybeCollabSender of + Just (Left (actor, _)) -> Just <$> hashLocalActor actor + _ -> pure Nothing let sieveActors = catMaybes - [ case topicHash of - Left (GrantResourceRepo r) -> Just $ LocalActorRepo r - Left (GrantResourceDeck d) -> Just $ LocalActorDeck d - Left (GrantResourceLoom l) -> Just $ LocalActorLoom l - Right _ -> Nothing - , case collabSender of - Left actor -> Just actor - Right _ -> Nothing + [ grantResourceLocalActor <$> maybeTopicHash + , maybeSenderHash ] sieveStages = catMaybes [ Just $ LocalStagePersonFollowers senderHash - , case topicHash of - Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r - Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d - Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l - Right _ -> Nothing - , case collabSender of - Left actor -> Just $ localActorFollowers actor - Right _ -> Nothing + , localActorFollowers . grantResourceLocalActor <$> maybeTopicHash + , localActorFollowers <$> maybeSenderHash ] sieve = makeRecipientSet sieveActors sieveStages moreRemoteRecips <- - lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor personUser) acceptID $ + lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor senderPerson) acceptID $ localRecipSieve sieve False localRecips checkFederation moreRemoteRecips lift $ deliverRemoteDB'' fwdHosts acceptID remoteRecips moreRemoteRecips - -- If resource is local, verify it has received the Accept - topicActorLocal <- - case topicActor of - Left (localID, resource) -> - Just . (localID,) <$> getGrantResource resource "getGrantResource" - Right _ -> pure Nothing - for_ topicActorLocal $ \ (_, resource) -> do - let resourceActorID = grantResourceActor resource + -- If resource is local, approve the Collab and deliver a Grant + deliverHttpGrant <- for maybeCollabMore $ \ (collabID, _, resource, sender) -> do + + -- If resource is local, verify it has received the Accept + resourceByEntity <- getGrantResource resource "getGrantResource" + let resourceActorID = grantResourceActor resourceByEntity verifyActorHasItem resourceActorID acceptID "Local topic didn't receive the Accept" - -- If Collab sender is local, verify it has received the Accept - case collabSender of - Left actorHash -> do - actor <- unhashLocalActorE actorHash "Can't unhash collab sender" - actorID <- do - maybeID <- lift $ getLocalActorID actor - fromMaybeE maybeID "Suddenly can't find collab sender in DB" - verifyActorHasItem actorID acceptID "Local Collab sender didn't receive the Accept" - Right _ -> pure () - - -- If resource is local, approve the Collab and deliver an Accept - -- We'll refer to the resource's Accept as the "Enable" activity - deliverHttpEnable <- for topicActorLocal $ \ (topicLocalID, resource) -> do + -- If Collab sender is local, verify it has received the Accept + case sender of + Left (_, (Entity actorID _)) -> + verifyActorHasItem actorID acceptID "Local Collab sender didn't receive the Accept" + Right _ -> pure () -- Approve the Collab in the DB resourceOutbox <- - lift $ actorOutbox <$> getJust (grantResourceActor resource) - enableID <- lift $ insertEmptyOutboxItem resourceOutbox now - lift $ insert_ $ CollabTopicLocalAccept topicLocalID enableID + lift $ actorOutbox <$> getJust resourceActorID + grantID <- lift $ insertEmptyOutboxItem resourceOutbox now + lift $ insert_ $ CollabEnable collabID grantID - -- Insert the Enable to resource's outbox - (docEnable, localRecipsEnable, remoteRecipsEnable, fwdHostsEnable) <- - lift $ insertEnableToOutbox senderHash collabSender resource enableID + -- Insert the Grant to resource's outbox + (docGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant) <- + lift $ insertGrantToOutbox senderHash sender resource grantID - -- Deliver the Enable to local recipients, and schedule delivery + -- Deliver the Grant to local recipients, and schedule delivery -- for unavailable remote recipients - remoteRecipsHttpEnable <- do + remoteRecipsHttpGrant <- do moreRemoteRecips <- do - resourceHash <- hashGrantResource $ bmap entityKey resource - lift $ deliverLocal' True (grantResourceLocalActor resourceHash) (grantResourceActor resource) enableID localRecipsEnable + resourceHash <- hashGrantResource resource + lift $ deliverLocal' True (grantResourceLocalActor resourceHash) resourceActorID grantID localRecipsGrant checkFederation moreRemoteRecips - lift $ deliverRemoteDB'' fwdHostsEnable enableID remoteRecipsEnable moreRemoteRecips + lift $ deliverRemoteDB'' fwdHostsGrant grantID remoteRecipsGrant moreRemoteRecips -- Return instructions for HTTP delivery to remote recipients - return $ deliverRemoteHttp' fwdHostsEnable enableID docEnable remoteRecipsHttpEnable + return $ deliverRemoteHttp' fwdHostsGrant grantID docGrant remoteRecipsHttpGrant -- Return instructions for HTTP delivery to remote recipients return ( acceptID , deliverRemoteHttp' fwdHosts acceptID docAccept remoteRecipsHttpAccept - , deliverHttpEnable + , deliverHttpGrant ) - -- Launch asynchronous HTTP delivery of the Grant activity + -- Launch asynchronous HTTP delivery of Accept and Grant lift $ do forkWorker "acceptC: async HTTP Accept delivery" deliverHttpAccept - for_ deliverHttpTopicAccept $ - forkWorker "acceptC: async HTTP Topic Accept delivery" + for_ deliverHttpGrant $ + forkWorker "acceptC: async HTTP Grant delivery" return obiidAccept @@ -346,11 +330,10 @@ acceptC (Entity pidUser personUser) senderActor summary audience accept = do parseAccept (Accept object mresult) = do verifyNothingE mresult "Accept must not contain 'result'" - parseActivityURI "Accept object" object + first (\ (actor, _, item) -> (actor, item)) <$> + nameExceptT "Accept object" (parseActivityURI object) - getRemoteActorURI = getRemoteActorURI' <=< getJust - - getRemoteActorURI' actor = do + getRemoteActorURI actor = do object <- getJust $ remoteActorIdent actor inztance <- getJust $ remoteObjectInstance object return $ @@ -359,37 +342,23 @@ acceptC (Entity pidUser personUser) senderActor summary audience accept = do (remoteObjectIdent object) getCollabTopic collabID = do - maybeLocal <- do - maybeLocalID <- getKeyBy $ UniqueCollabTopicLocal collabID - for maybeLocalID $ \ localID -> do - resourceID <- do - maybeRepo <- getValBy $ UniqueCollabTopicLocalRepo localID - maybeDeck <- getValBy $ UniqueCollabTopicLocalDeck localID - maybeLoom <- getValBy $ UniqueCollabTopicLocalLoom localID - return $ - case (maybeRepo, maybeDeck, maybeLoom) of - (Nothing, Nothing, Nothing) -> error "Found Collab with no specific local topic" - (Just r, Nothing, Nothing) -> - GrantResourceRepo $ collabTopicLocalRepoRepo r - (Nothing, Just d, Nothing) -> - GrantResourceDeck $ collabTopicLocalDeckDeck d - (Nothing, Nothing, Just l) -> - GrantResourceLoom $ collabTopicLocalLoomLoom l - _ -> error "Found Collab with multiple local topics" - return (localID, resourceID) - maybeRemote <- do - mr <- getBy $ UniqueCollabTopicRemote collabID - for mr $ \ (Entity remoteID remote) -> do - u <- getRemoteActorURI $ collabTopicRemoteActor remote - return (remoteID, u) - requireEitherM - maybeLocal - maybeRemote - "Found Collab without topic" - "Found Collab with both local and remote topics" + maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID + maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID + maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID + return $ + case (maybeRepo, maybeDeck, maybeLoom) of + (Nothing, Nothing, Nothing) -> error "Found Collab without topic" + (Just r, Nothing, Nothing) -> + GrantResourceRepo $ collabTopicRepoRepo r + (Nothing, Just d, Nothing) -> + GrantResourceDeck $ collabTopicDeckDeck d + (Nothing, Nothing, Just l) -> + GrantResourceLoom $ collabTopicLoomLoom l + _ -> error "Found Collab with multiple topics" verifySenderAddressed localRecips actor = do - unless (actorIsAddressed localRecips actor) $ + actorByHash <- hashLocalActor actor + unless (actorIsAddressed localRecips actorByHash) $ throwE "Collab sender not addressed" insertAcceptToOutbox senderHash now blinded acceptID = do @@ -415,22 +384,29 @@ acceptC (Entity pidUser personUser) senderActor summary audience accept = do grantResourceActor (GrantResourceDeck (Entity _ d)) = deckActor d grantResourceActor (GrantResourceLoom (Entity _ l)) = loomActor l - grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f - grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r - grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d - grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l - - insertEnableToOutbox recipHash sender topic enableID = do + insertGrantToOutbox + :: KeyHashid Person + -> Either (LocalActorBy Key, Entity Actor) (FedURI, Maybe LocalURI) + -> GrantResourceBy Key + -> OutboxItemId + -> ReaderT SqlBackend Handler + ( Doc Activity URIMode + , RecipientRoutes + , [(Host, NonEmpty LocalURI)] + , [Host] + ) + insertGrantToOutbox recipHash sender topic grantID = do encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome hLocal <- asksSite siteInstanceHost topicHash <- - grantResourceLocalActor <$> hashGrantResource (bmap entityKey topic) - enableHash <- encodeKeyHashid enableID + grantResourceLocalActor <$> hashGrantResource topic + grantHash <- encodeKeyHashid grantID + senderHash <- bitraverse (hashLocalActor . fst) pure sender let audSender = - case sender of + case senderHash of Left actor -> AudLocal [actor] [localActorFollowers actor] Right (ObjURI h lu, followers) -> AudRemote h [lu] (maybeToList followers) @@ -444,19 +420,20 @@ acceptC (Entity pidUser personUser) senderActor summary audience accept = do recips = map encodeRouteHome audLocal ++ audRemote doc = Doc hLocal Activity - { activityId = Just $ encodeRouteLocal $ outboxItemRoute topicHash enableHash + { activityId = Just $ encodeRouteLocal $ activityRoute topicHash grantHash , activityActor = encodeRouteLocal $ renderLocalActor topicHash , activityCapability = Nothing , activitySummary = Nothing , activityAudience = Audience recips [] [] [] [] [] , activityFulfills = [] - , activitySpecific = AcceptActivity Accept - { acceptObject = acceptObject accept - , acceptResult = Nothing + , activitySpecific = GrantActivity Grant + { grantObject = Left RoleAdmin + , grantContext = encodeRouteHome $ renderLocalActor topicHash + , grantTarget = encodeRouteHome $ PersonR recipHash } } - update enableID [OutboxItemActivity =. persistJSONObjectFromDoc doc] + update grantID [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (doc, recipientSet, remoteActors, fwdHosts) addBundleC @@ -1530,10 +1507,8 @@ createTicketTrackerC (Entity pidUser personUser) senderActor summary audience tr insertCollab did obiidGrant = do cid <- insert Collab - ctlid <- insert $ CollabTopicLocal cid - insert_ $ CollabTopicLocalDeck ctlid did - insert_ $ CollabTopicLocalAccept ctlid obiidGrant - insert_ $ CollabSenderLocal cid obiidGrant + insert_ $ CollabTopicDeck cid did + insert_ $ CollabEnable cid obiidGrant insert_ $ CollabRecipLocal cid pidUser insert_ $ CollabFulfillsLocalTopicCreation cid @@ -1808,21 +1783,21 @@ data Result | ResultNotActor deriving Show -grantC +inviteC :: Entity Person -> Actor -> Maybe FedURI -> Maybe TextHtml -> Audience URIMode - -> Grant URIMode + -> Invite URIMode -> ExceptT Text Handler OutboxItemId -grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do +inviteC (Entity senderPersonID senderPerson) senderActor muCap summary audience invite = do -- Check input - (resource, recipient) <- parseGrant (Just pidUser) grant + (resource, recipient) <- parseInvite (Just senderPersonID) invite ParsedAudience localRecips remoteRecips blinded fwdHosts <- do mrecips <- parseAudience audience - recips <- fromMaybeE mrecips "Grant with no recipients" + recips <- fromMaybeE mrecips "Invite with no recipients" checkFederation $ paudRemoteActors recips return recips @@ -1830,7 +1805,7 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do -- * Outbox item URI of a local actor, i.e. a local activity -- * A remote URI uCap <- fromMaybeE muCap "No capability provided" - capID <- parseActivityURI "Grant capability" uCap + capID <- nameExceptT "Invite capability" $ parseActivityURI uCap -- If resource is remote, HTTP GET it and its managing actor, and insert to -- our DB. If resource is local, find it in our DB. @@ -1870,7 +1845,7 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do ) recipient - -- Verify that resource and recipient are addressed by the Grant + -- Verify that resource and recipient are addressed by the Invite bitraverse_ (verifyResourceAddressed localRecips . bmap entityKey) (\ (_, _, u) -> verifyRemoteAddressed remoteRecips u) @@ -1881,28 +1856,34 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do recipientDB now <- liftIO getCurrentTime - senderHash <- encodeKeyHashid pidUser + senderHash <- encodeKeyHashid senderPersonID - (obiidGrant, deliverHttpGrant) <- runDBExcept $ do + (obiidInvite, deliverHttpInvite) <- runDBExcept $ do -- If resource is local, verify the specified capability gives relevant - -- access. If resource is remote, check the specified capability as - -- much as we can, letting the remote resource say the final word. - bitraverse_ - (verifyCapability capID pidUser . bmap entityKey) - (verifyCapabilityRemote capID pidUser . (\ (o, _, _) -> o)) - resourceDB + -- access to it. + case resourceDB of + Left r -> do + capability <- + case capID of + Left (actor, _, item) -> return (actor, item) + Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local topic" + verifyCapability capability senderPersonID $ bmap entityKey r + Right _ -> pure () -- Insert new Collab to DB - grantID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now - lift $ insertCollab resourceDB recipientDB grantID + inviteID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now + case resourceDB of + Left localResource -> + lift $ insertCollab localResource recipientDB inviteID + Right _ -> pure () -- Insert the Grant activity to author's outbox - docGrant <- lift $ insertGrantToOutbox senderHash now uCap blinded grantID + docInvite <- lift $ insertInviteToOutbox senderHash now uCap blinded inviteID - -- Deliver the Grant activity to local recipients, and schedule + -- Deliver the Invite activity to local recipients, and schedule -- delivery for unavailable remote recipients - remoteRecipsHttpGrant <- do + remoteRecipsHttpInvite <- do resourceHash <- bitraverse hashGrantResource pure resource recipientHash <- bitraverse hashGrantRecip pure recipient let sieveActors = catMaybes @@ -1928,10 +1909,10 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do ] sieve = makeRecipientSet sieveActors sieveStages moreRemoteRecips <- - lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor personUser) grantID $ + lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor senderPerson) inviteID $ localRecipSieve sieve False localRecips checkFederation moreRemoteRecips - lift $ deliverRemoteDB'' fwdHosts grantID remoteRecips moreRemoteRecips + lift $ deliverRemoteDB'' fwdHosts inviteID remoteRecips moreRemoteRecips -- If resource is local, verify it has received the Grant case resourceDB of @@ -1941,26 +1922,26 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do GrantResourceRepo (Entity _ r) -> repoActor r GrantResourceDeck (Entity _ d) -> deckActor d GrantResourceLoom (Entity _ l) -> loomActor l - verifyActorHasItem resourceActorID grantID "Local topic didn't receive the Grant" + verifyActorHasItem resourceActorID inviteID "Local topic didn't receive the Invite" Right _ -> pure () - -- If recipient is local, verify it has received the grant + -- If recipient is local, verify it has received the invite case recipientDB of Left (GrantRecipPerson (Entity _ p)) -> - verifyActorHasItem (personActor p) grantID "Local recipient didn't receive the Grant" + verifyActorHasItem (personActor p) inviteID "Local recipient didn't receive the Invite" Right _ -> pure () -- Return instructions for HTTP delivery to remote recipients return - ( grantID - , deliverRemoteHttp' fwdHosts grantID docGrant remoteRecipsHttpGrant + ( inviteID + , deliverRemoteHttp' fwdHosts inviteID docInvite remoteRecipsHttpInvite ) -- Launch asynchronous HTTP delivery of the Grant activity lift $ do - forkWorker "grantC: async HTTP Grant delivery" deliverHttpGrant + forkWorker "inviteC: async HTTP Grant delivery" deliverHttpInvite - return obiidGrant + return obiidInvite where @@ -2017,48 +1998,43 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do lus <- lookup h remoteRecips guard $ lu `elem` lus - insertCollab resource recipient grantID = do + insertCollab resource recipient inviteID = do collabID <- insert Collab case resource of - Left local -> do - topicID <- insert $ CollabTopicLocal collabID - case local of - GrantResourceRepo (Entity repoID _) -> - insert_ $ CollabTopicLocalRepo topicID repoID - GrantResourceDeck (Entity deckID _) -> - insert_ $ CollabTopicLocalDeck topicID deckID - GrantResourceLoom (Entity loomID _) -> - insert_ $ CollabTopicLocalLoom topicID loomID - Right (remoteID, actorID, _) -> - insert_ $ CollabTopicRemote collabID remoteID actorID Nothing - insert_ $ CollabSenderLocal collabID grantID + GrantResourceRepo (Entity repoID _) -> + insert_ $ CollabTopicRepo collabID repoID + GrantResourceDeck (Entity deckID _) -> + insert_ $ CollabTopicDeck collabID deckID + GrantResourceLoom (Entity loomID _) -> + insert_ $ CollabTopicLoom collabID loomID + insert_ $ CollabFulfillsInviteLocal collabID inviteID case recipient of Left (GrantRecipPerson (Entity personID _)) -> insert_ $ CollabRecipLocal collabID personID Right (remoteActorID, _) -> insert_ $ CollabRecipRemote collabID remoteActorID - hashGrantRecip (GrantRecipPerson k) = - GrantRecipPerson <$> encodeKeyHashid k - - insertGrantToOutbox senderHash now uCap blinded grantID = do + insertInviteToOutbox senderHash now uCap blinded inviteID = do encodeRouteLocal <- getEncodeRouteLocal hLocal <- asksSite siteInstanceHost - grantHash <- encodeKeyHashid grantID + inviteHash <- encodeKeyHashid inviteID let doc = Doc hLocal Activity { activityId = Just $ encodeRouteLocal $ - PersonOutboxItemR senderHash grantHash + PersonOutboxItemR senderHash inviteHash , activityActor = encodeRouteLocal $ PersonR senderHash , activityCapability = Just uCap , activitySummary = summary , activityAudience = blinded , activityFulfills = [] - , activitySpecific = GrantActivity grant + , activitySpecific = InviteActivity invite } - update grantID [OutboxItemActivity =. persistJSONObjectFromDoc doc] + update inviteID [OutboxItemActivity =. persistJSONObjectFromDoc doc] return doc + hashGrantRecip (GrantRecipPerson k) = + GrantRecipPerson <$> encodeKeyHashid k + offerTicketC :: Entity Person -> Maybe TextHtml diff --git a/src/Vervis/Access.hs b/src/Vervis/Access.hs index a5dd682..f7da060 100644 --- a/src/Vervis/Access.hs +++ b/src/Vervis/Access.hs @@ -70,8 +70,9 @@ module Vervis.Access , hashGrantResource , getGrantResource + , grantResourceLocalActor + , verifyCapability - , verifyCapabilityRemote ) where @@ -103,6 +104,7 @@ import Vervis.FedURI import Vervis.Foundation import Vervis.Model import Vervis.Model.Role +import Vervis.Persist.Actor import Vervis.Query import Vervis.Recipient @@ -112,6 +114,16 @@ data ObjectAccessStatus = data PersonRole = Developer | User | Guest | RoleID RoleId +{- +data RepoAuthorization + = RepoAuthorizationLocal PersonId + | RepoAuthorizationRemote RepoRemoteCollabId + +data ProjectAuthorization + = ProjectAuthorizationLocal PersonId + | ProjectAuthorizationRemote ProjectRemoteCollabId +-} + roleHasAccess :: MonadIO m => PersonRole @@ -167,15 +179,14 @@ checkRepoAccess' mpid op repoID = do where asCollab rid pid = do fmap (const Developer) . listToMaybe <$> do - E.select $ E.from $ \ (repo `E.InnerJoin` topic `E.InnerJoin` recip `E.InnerJoin` accept) -> do - E.on $ topic E.^. CollabTopicLocalId E.==. accept E.^. CollabTopicLocalAcceptCollab - E.on $ topic E.^. CollabTopicLocalCollab E.==. recip E.^. CollabRecipLocalCollab - E.on $ repo E.^. CollabTopicLocalRepoCollab E.==. topic E.^. CollabTopicLocalId + E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` enable) -> do + E.on $ topic E.^. CollabTopicRepoCollab E.==. enable E.^. CollabEnableCollab + E.on $ topic E.^. CollabTopicRepoCollab E.==. recip E.^. CollabRecipLocalCollab E.where_ $ - repo E.^. CollabTopicLocalRepoRepo E.==. E.val rid E.&&. + topic E.^. CollabTopicRepoRepo E.==. E.val rid E.&&. recip E.^. CollabRecipLocalPerson E.==. E.val pid E.limit 1 - return $ topic E.^. CollabTopicLocalCollab + return $ topic E.^. CollabTopicRepoCollab asUser = fmap RoleID . repoCollabUser asAnon = fmap RoleID . repoCollabAnon @@ -202,15 +213,14 @@ checkRepoAccess mpid op repoHash = do where asCollab rid pid = do fmap (const Developer) . listToMaybe <$> do - E.select $ E.from $ \ (repo `E.InnerJoin` topic `E.InnerJoin` recip `E.InnerJoin` accept) -> do - E.on $ topic E.^. CollabTopicLocalId E.==. accept E.^. CollabTopicLocalAcceptCollab - E.on $ topic E.^. CollabTopicLocalCollab E.==. recip E.^. CollabRecipLocalCollab - E.on $ repo E.^. CollabTopicLocalRepoCollab E.==. topic E.^. CollabTopicLocalId + E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` enable) -> do + E.on $ topic E.^. CollabTopicRepoCollab E.==. enable E.^. CollabEnableCollab + E.on $ topic E.^. CollabTopicRepoCollab E.==. recip E.^. CollabRecipLocalCollab E.where_ $ - repo E.^. CollabTopicLocalRepoRepo E.==. E.val rid E.&&. + topic E.^. CollabTopicRepoRepo E.==. E.val rid E.&&. recip E.^. CollabRecipLocalPerson E.==. E.val pid E.limit 1 - return $ topic E.^. CollabTopicLocalCollab + return $ topic E.^. CollabTopicRepoCollab asUser = fmap RoleID . repoCollabUser asAnon = fmap RoleID . repoCollabAnon @@ -238,15 +248,14 @@ checkProjectAccess mpid op deckHash = do where asCollab jid pid = do fmap (const Developer) . listToMaybe <$> do - E.select $ E.from $ \ (deck `E.InnerJoin` topic `E.InnerJoin` recip `E.InnerJoin` accept) -> do - E.on $ topic E.^. CollabTopicLocalId E.==. accept E.^. CollabTopicLocalAcceptCollab - E.on $ topic E.^. CollabTopicLocalCollab E.==. recip E.^. CollabRecipLocalCollab - E.on $ deck E.^. CollabTopicLocalDeckCollab E.==. topic E.^. CollabTopicLocalId + E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` enable) -> do + E.on $ topic E.^. CollabTopicDeckCollab E.==. enable E.^. CollabEnableCollab + E.on $ topic E.^. CollabTopicDeckCollab E.==. recip E.^. CollabRecipLocalCollab E.where_ $ - deck E.^. CollabTopicLocalDeckDeck E.==. E.val jid E.&&. + topic E.^. CollabTopicDeckDeck E.==. E.val jid E.&&. recip E.^. CollabRecipLocalPerson E.==. E.val pid E.limit 1 - return $ topic E.^. CollabTopicLocalCollab + return $ topic E.^. CollabTopicDeckCollab asUser = fmap RoleID . deckCollabUser asAnon = fmap RoleID . deckCollabAnon @@ -288,34 +297,33 @@ getGrantResource (GrantResourceDeck k) e = getGrantResource (GrantResourceLoom k) e = GrantResourceLoom <$> getEntityE k e +grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f +grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r +grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d +grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l + verifyCapability - :: Either (LocalActorBy KeyHashid, OutboxItemId) FedURI + :: (LocalActorBy Key, OutboxItemId) -> PersonId -> GrantResourceBy Key -> ExceptT Text (ReaderT SqlBackend Handler) () -verifyCapability capability personID resource = do +verifyCapability (capActor, capItem) personID resource = do + -- Find the activity itself by URI in the DB - grant <- do - mact <- getActivity capability - fromMaybeE mact "Capability activity not known to me" + nameExceptT "Capability activity not found" $ + verifyLocalActivityExistsInDB capActor capItem -- Find the Collab record for that activity - cid <- - case grant of - Left (_actor, obiid) -> do - mcsl <- lift $ getValBy $ UniqueCollabSenderLocalActivity obiid - collabSenderLocalCollab <$> - fromMaybeE mcsl "Capability is a local activity but no matching capability" - Right ractid -> do - mcsr <- lift $ getValBy $ UniqueCollabSenderRemoteActivity ractid - collabSenderRemoteCollab <$> - fromMaybeE mcsr "Capability is a known remote activity but no matching capability" + collabID <- do + maybeEnable <- lift $ getValBy $ UniqueCollabEnableGrant capItem + collabEnableCollab <$> + fromMaybeE maybeEnable "No CollabEnable for this activity" -- Find the recipient of that Collab recipID <- do - mcrl <- lift $ getValBy $ UniqueCollabRecipLocal cid + mcrl <- lift $ getValBy $ UniqueCollabRecipLocal collabID crl <- fromMaybeE mcrl "No local recip for capability" - mcrr <- lift $ getBy $ UniqueCollabRecipRemote cid + mcrr <- lift $ getBy $ UniqueCollabRecipRemote collabID for_ mcrr $ \ _ -> error "Both local & remote recip for capability!" return $ collabRecipLocalPerson crl @@ -323,98 +331,29 @@ verifyCapability capability personID resource = do unless (recipID == personID) $ throwE "Collab recipient is some other Person" - -- Verify the topic isn't remote - maybeRemote <- lift $ getBy $ UniqueCollabTopicRemote cid - verifyNothingE maybeRemote "Collab is for some other, remote topic" - -- Find the local topic, on which this Collab gives access - (topic, topicLocalID) <- lift $ do - localID <- do - maybeLocal <- getKeyBy $ UniqueCollabTopicLocal cid - case maybeLocal of - Nothing -> error "Collab without topic" - Just l -> return l - maybeRepo <- getValBy $ UniqueCollabTopicLocalRepo localID - maybeDeck <- getValBy $ UniqueCollabTopicLocalDeck localID - maybeLoom <- getValBy $ UniqueCollabTopicLocalLoom localID - (,localID) <$> - case (maybeRepo, maybeDeck, maybeLoom) of - (Nothing, Nothing, Nothing) -> error "Collab without local topic" - (Just r, Nothing, Nothing) -> - return $ GrantResourceRepo $ collabTopicLocalRepoRepo r - (Nothing, Just d, Nothing) -> - return $ GrantResourceDeck $ collabTopicLocalDeckDeck d - (Nothing, Nothing, Just l) -> - return $ GrantResourceLoom $ collabTopicLocalLoomLoom l - _ -> error "Collab with multiple topics" + topic <- lift $ do + maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID + maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID + maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID + case (maybeRepo, maybeDeck, maybeLoom) of + (Nothing, Nothing, Nothing) -> error "Collab without topic" + (Just r, Nothing, Nothing) -> + return $ GrantResourceRepo $ collabTopicRepoRepo r + (Nothing, Just d, Nothing) -> + return $ GrantResourceDeck $ collabTopicDeckDeck d + (Nothing, Nothing, Just l) -> + return $ GrantResourceLoom $ collabTopicLoomLoom l + _ -> error "Collab with multiple topics" + + -- Verify that topic is indeed the sender of the Grant + unless (grantResourceLocalActor topic == capActor) $ + error "Grant sender isn't the topic" -- Verify the topic matches the resource specified unless (topic == resource) $ throwE "Capability topic is some other local resource" - -- Verify that the resource has accepted the grant, making it valid - maybeAccept <- lift $ getBy $ UniqueCollabTopicLocalAcceptCollab topicLocalID - _ <- fromMaybeE maybeAccept "Collab not approved by the resource" - - -- Since there are currently no roles, and grants allow only the "Admin" - -- role that supports every operation, we don't need to check role access - return () - -verifyCapabilityRemote - :: Either (LocalActorBy KeyHashid, OutboxItemId) FedURI - -> PersonId - -> RemoteObjectId - -> ExceptT Text (ReaderT SqlBackend Handler) () -verifyCapabilityRemote capability personID resourceID = do - -- Find the activity itself by URI in the DB - grant <- do - mact <- getActivity capability - fromMaybeE mact "Capability activity not known to me" - - -- Find the Collab record for that activity - cid <- - case grant of - Left (_actor, obiid) -> do - mcsl <- lift $ getValBy $ UniqueCollabSenderLocalActivity obiid - collabSenderLocalCollab <$> - fromMaybeE mcsl "Capability is a local activity but no matching capability" - Right ractid -> do - mcsr <- lift $ getValBy $ UniqueCollabSenderRemoteActivity ractid - collabSenderRemoteCollab <$> - fromMaybeE mcsr "Capability is a known remote activity but no matching capability" - - -- Find the recipient of that Collab - recipID <- do - mcrl <- lift $ getValBy $ UniqueCollabRecipLocal cid - crl <- fromMaybeE mcrl "No local recip for capability" - mcrr <- lift $ getBy $ UniqueCollabRecipRemote cid - for_ mcrr $ \ _ -> error "Both local & remote recip for capability!" - return $ collabRecipLocalPerson crl - - -- Verify the recipient is the expected one - unless (recipID == personID) $ - throwE "Collab recipient is some other Person" - - -- Verify the topic isn't local - maybeLocalTopic <- lift $ getBy $ UniqueCollabTopicLocal cid - verifyNothingE maybeLocalTopic "Collab is for some other, local topic" - - -- Find the remote topic, on which this Collab gives access - (topicRemoteID, topicObjectID) <- do - maybeRemote <- lift $ getBy $ UniqueCollabTopicRemote cid - case maybeRemote of - Nothing -> error "Collab without topic" - Just (Entity remoteID remote) -> - return (remoteID, collabTopicRemoteTopic remote) - - -- Verify the topic matches the resource specified - unless (topicObjectID == resourceID) $ - throwE "Capability topic is some other remote resource" - - -- Verify that the resource has accepted the grant, making it valid - maybeAccept <- lift $ getBy $ UniqueCollabTopicRemoteAcceptCollab topicRemoteID - _ <- fromMaybeE maybeAccept "Collab not approved by the resource" - -- Since there are currently no roles, and grants allow only the "Admin" -- role that supports every operation, we don't need to check role access return () diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index dcf29d8..5afb8cf 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -28,15 +28,10 @@ module Vervis.ActivityPub , insertEmptyOutboxItem , verifyContentTypeAP , verifyContentTypeAP_E - , parseActivity - , parseActivityURI , getActivity --, ActorEntity (..) - , getLocalActor' - , getLocalActor --, getOutboxActorEntity --, actorEntityPath - , outboxItemRoute , verifyActorHasItem ) @@ -272,54 +267,18 @@ verifyContentTypeAP_E = do "application/ld+json; \ \profile=\"https://www.w3.org/ns/activitystreams\"" --- | If the given URI is remote, return as is. If the URI is local, verify that --- it parses as an activity URI, i.e. an outbox item route, and return the --- parsed route. -parseActivityURI name u@(ObjURI h lu) = do - hl <- hostIsLocal h - if hl - then Left <$> do - route <- - fromMaybeE - (decodeRouteLocal lu) - (name <> " is local but isn't a valid route") - (actor, outboxItemHash) <- - fromMaybeE - (parseOutboxItemRoute route) - (name <> " is a valid local route, but isn't an outbox item route") - outboxItemID <- - decodeKeyHashidE outboxItemHash (name <> ": Invalid obikhid") - return (actor, outboxItemID) - else return $ Right u - where - parseOutboxItemRoute (PersonOutboxItemR p i) = Just (LocalActorPerson p, i) - parseOutboxItemRoute (GroupOutboxItemR g i) = Just (LocalActorGroup g, i) - parseOutboxItemRoute (RepoOutboxItemR r i) = Just (LocalActorRepo r, i) - parseOutboxItemRoute (DeckOutboxItemR d i) = Just (LocalActorDeck d, i) - parseOutboxItemRoute (LoomOutboxItemR l i) = Just (LocalActorLoom l, i) - parseOutboxItemRoute _ = Nothing - -parseActivity = parseActivityURI "Activity URI" - getActivity (Left (actor, obiid)) = Just . Left <$> do - obid <- actorOutbox <$> getActor' actor + actorID <- do + maybeActorID <- lift $ getLocalActorID actor + fromMaybeE maybeActorID "No such actor entity in DB" + actorDB <- lift $ getJust actorID + let obid = actorOutbox actorDB obi <- do mobi <- lift $ get obiid fromMaybeE mobi "No such obiid" unless (outboxItemOutbox obi == obid) $ throwE "Actor/obiid mismatch" - return (actor, obiid) - where - getActor grabActor hash = do - key <- decodeKeyHashidE hash "No such hashid" - actorID <- grabActor <$> getE key "No such actor entity in DB" - lift $ getJust actorID - - getActor' (LocalActorPerson hash) = getActor personActor hash - getActor' (LocalActorGroup hash) = getActor groupActor hash - getActor' (LocalActorRepo hash) = getActor repoActor hash - getActor' (LocalActorDeck hash) = getActor deckActor hash - getActor' (LocalActorLoom hash) = getActor loomActor hash + return (actor, Entity actorID actorDB, obiid) getActivity (Right u@(ObjURI h lu)) = lift $ runMaybeT $ Right <$> do iid <- MaybeT $ getKeyBy $ UniqueInstance h @@ -333,57 +292,6 @@ data ActorEntity | ActorRepo (Entity Repo) -} -getLocalActor' - :: ( BaseBackend b ~ SqlBackend - , PersistUniqueRead b - , MonadIO m - ) - => ActorId - -> ReaderT b m (LocalActorBy Key) -getLocalActor' actorID = do - mp <- getKeyBy $ UniquePersonActor actorID - mg <- getKeyBy $ UniqueGroupActor actorID - mr <- getKeyBy $ UniqueRepoActor actorID - md <- getKeyBy $ UniqueDeckActor actorID - ml <- getKeyBy $ UniqueLoomActor actorID - return $ - case (mp, mg, mr, md, ml) of - (Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId" - (Just p, Nothing, Nothing, Nothing, Nothing) -> LocalActorPerson p - (Nothing, Just g, Nothing, Nothing, Nothing) -> LocalActorGroup g - (Nothing, Nothing, Just r, Nothing, Nothing) -> LocalActorRepo r - (Nothing, Nothing, Nothing, Just d, Nothing) -> LocalActorDeck d - (Nothing, Nothing, Nothing, Nothing, Just l) -> LocalActorLoom l - _ -> error "Multi-usage of an ActorId" - -getLocalActor - :: ( BaseBackend b ~ SqlBackend - , PersistUniqueRead b - , MonadSite m - , YesodHashids (SiteEnv m) - ) - => ActorId - -> ReaderT b m LocalActor -getLocalActor actorID = do - mp <- getKeyBy $ UniquePersonActor actorID - mg <- getKeyBy $ UniqueGroupActor actorID - mr <- getKeyBy $ UniqueRepoActor actorID - md <- getKeyBy $ UniqueDeckActor actorID - ml <- getKeyBy $ UniqueLoomActor actorID - case (mp, mg, mr, md, ml) of - (Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId" - (Just p, Nothing, Nothing, Nothing, Nothing) -> - LocalActorPerson <$> encodeKeyHashid p - (Nothing, Just g, Nothing, Nothing, Nothing) -> - LocalActorGroup <$> encodeKeyHashid g - (Nothing, Nothing, Just r, Nothing, Nothing) -> - LocalActorRepo <$> encodeKeyHashid r - (Nothing, Nothing, Nothing, Just d, Nothing) -> - LocalActorDeck <$> encodeKeyHashid d - (Nothing, Nothing, Nothing, Nothing, Just l) -> - LocalActorLoom <$> encodeKeyHashid l - _ -> error "Multi-usage of an ActorId" - {- getOutboxActorEntity obid = do mp <- getBy $ UniquePersonOutbox obid @@ -410,12 +318,6 @@ actorEntityPath (ActorRepo (Entity _ r)) = getJust (repoSharer r) -} -outboxItemRoute (LocalActorPerson p) = PersonOutboxItemR p -outboxItemRoute (LocalActorGroup g) = GroupOutboxItemR g -outboxItemRoute (LocalActorRepo r) = RepoOutboxItemR r -outboxItemRoute (LocalActorDeck d) = DeckOutboxItemR d -outboxItemRoute (LocalActorLoom l) = LoomOutboxItemR l - verifyActorHasItem actorID itemID errorMessage = do inboxID <- lift $ actorInbox <$> getJust actorID maybeItem <- lift $ getBy $ UniqueInboxItemLocal inboxID itemID diff --git a/src/Vervis/Data/Actor.hs b/src/Vervis/Data/Actor.hs index f32126f..d8039e7 100644 --- a/src/Vervis/Data/Actor.hs +++ b/src/Vervis/Data/Actor.hs @@ -15,6 +15,8 @@ module Vervis.Data.Actor ( parseLocalActivityURI + , parseActivityURI + , activityRoute ) where @@ -22,12 +24,14 @@ import Control.Monad.Trans.Except import Data.Text (Text) import Network.FedURI +import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids import Yesod.MonadSite import Control.Monad.Trans.Except.Local +import Vervis.FedURI import Vervis.Foundation import Vervis.Model import Vervis.Recipient @@ -37,15 +41,13 @@ parseLocalActivityURI => LocalURI -> ExceptT Text m (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId) parseLocalActivityURI luAct = do - route <- - fromMaybeE (decodeRouteLocal luAct) "Local activity: Not a valid route" + route <- fromMaybeE (decodeRouteLocal luAct) "Not a valid route" (actorHash, outboxItemHash) <- fromMaybeE (parseOutboxItemRoute route) - "Local activity: Valid local route, but not an outbox item route" - outboxItemID <- - decodeKeyHashidE outboxItemHash "Local activity: Invalid outbox item hash" - actorKey <- unhashLocalActorE actorHash "Local activity: Invalid actor hash" + "Valid local route, but not an outbox item route" + outboxItemID <- decodeKeyHashidE outboxItemHash "Invalid outbox item hash" + actorKey <- unhashLocalActorE actorHash "Invalid actor hash" return (actorKey, actorHash, outboxItemID) where parseOutboxItemRoute (PersonOutboxItemR p i) = Just (LocalActorPerson p, i) @@ -54,3 +56,27 @@ parseLocalActivityURI luAct = do parseOutboxItemRoute (DeckOutboxItemR d i) = Just (LocalActorDeck d, i) parseOutboxItemRoute (LoomOutboxItemR l i) = Just (LocalActorLoom l, i) parseOutboxItemRoute _ = Nothing + +-- | If the given URI is remote, return as is. If the URI is local, verify that +-- it parses as an activity URI, i.e. an outbox item route, and return the +-- parsed route. +parseActivityURI + :: (MonadSite m, SiteEnv m ~ App) + => FedURI + -> ExceptT Text m + (Either + (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId) + FedURI + ) +parseActivityURI u@(ObjURI h lu) = do + hl <- hostIsLocal h + if hl + then Left <$> parseLocalActivityURI lu + else pure $ Right u + +activityRoute :: LocalActorBy KeyHashid -> KeyHashid OutboxItem -> Route App +activityRoute (LocalActorPerson p) = PersonOutboxItemR p +activityRoute (LocalActorGroup g) = GroupOutboxItemR g +activityRoute (LocalActorRepo r) = RepoOutboxItemR r +activityRoute (LocalActorDeck d) = DeckOutboxItemR d +activityRoute (LocalActorLoom l) = LoomOutboxItemR l diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index 99ce30c..9a4ef1b 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -18,6 +18,7 @@ module Vervis.Data.Collab ( GrantRecipBy (..) + , parseInvite , parseGrant ) where @@ -60,6 +61,64 @@ unhashGrantRecip resource = do unhashGrantRecipE resource e = ExceptT $ maybe (Left e) Right <$> unhashGrantRecip resource +parseInvite + :: Maybe PersonId + -> Invite URIMode + -> ExceptT Text Handler + ( Either (GrantResourceBy Key) FedURI + , Either (GrantRecipBy Key) FedURI + ) +parseInvite maybeSenderID (Invite instrument object target) = do + verifyRole instrument + (,) <$> parseTopic target + <*> parseRecipient object + where + verifyRole (Left RoleAdmin) = pure () + verifyRole (Right _) = + throwE "ForgeFed Admin is the only role allowed currently" + parseTopic u@(ObjURI h lu) = do + hl <- hostIsLocal h + if hl + then Left <$> do + route <- + fromMaybeE + (decodeRouteLocal lu) + "Invite target isn't a valid route" + resourceHash <- + fromMaybeE + (parseGrantResource route) + "Invite target isn't a shared resource route" + unhashGrantResourceE + resourceHash + "Invite target contains invalid hashid" + else pure $ Right u + where + parseGrantResource (RepoR r) = Just $ GrantResourceRepo r + parseGrantResource (DeckR d) = Just $ GrantResourceDeck d + parseGrantResource (LoomR l) = Just $ GrantResourceLoom l + parseGrantResource _ = Nothing + parseRecipient u@(ObjURI h lu) = do + hl <- hostIsLocal h + if hl + then Left <$> do + route <- + fromMaybeE + (decodeRouteLocal lu) + "Invite object isn't a valid route" + recipHash <- + fromMaybeE + (parseGrantRecip route) + "Invite object isn't a grant recipient route" + recipKey <- + unhashGrantRecipE + recipHash + "Invite object contains invalid hashid" + case recipKey of + GrantRecipPerson p | Just p == maybeSenderID -> + throwE "Invite sender and recipient are the same Person" + _ -> return recipKey + else pure $ Right u + parseGrant :: Maybe PersonId -> Grant URIMode diff --git a/src/Vervis/Handler/Cloth.hs b/src/Vervis/Handler/Cloth.hs index 263dcb1..15e5a16 100644 --- a/src/Vervis/Handler/Cloth.hs +++ b/src/Vervis/Handler/Cloth.hs @@ -89,6 +89,7 @@ import Vervis.ActivityPub import Vervis.Actor import Vervis.API import Vervis.Cloth +import Vervis.Data.Actor import Vervis.Discussion import Vervis.FedURI import Vervis.Foundation @@ -96,6 +97,8 @@ import Vervis.Model import Vervis.Model.Ident import Vervis.Model.Ticket import Vervis.Paginate +import Vervis.Persist.Actor +import Vervis.Recipient import Vervis.Ticket getClothR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler TypedContent @@ -145,6 +148,7 @@ getClothR loomHash clothHash = do encodeRouteHome <- getEncodeRouteHome hashPerson <- getEncodeKeyHashid hashItem <- getEncodeKeyHashid + hashActor <- getHashLocalActor hLocal <- getsYesod siteInstanceHost repoHash <- encodeKeyHashid repoID bundleHash <- encodeKeyHashid bundleID @@ -194,7 +198,7 @@ getClothR loomHash clothHash = do , AP.ticketResolved = let u (Left (actor, obiid)) = encodeRouteHome $ - outboxItemRoute actor $ hashItem obiid + activityRoute (hashActor actor) (hashItem obiid) u (Right (i, ro)) = ObjURI (instanceHost i) (remoteObjectIdent ro) in (,Nothing) . Just . u <$> resolve diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 4a76221..d251226 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -73,6 +73,7 @@ import Vervis.Federation.Auth import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident +import Vervis.Persist.Actor import Vervis.Recipient import Vervis.Secure import Vervis.Settings @@ -135,21 +136,6 @@ parseAuthenticatedLocalActivityURI author maybeActivityURI = do throwE "'actor' actor and 'id' actor mismatch" return outboxItemID -verifyLocalActivityExistsInDB - :: MonadIO m - => LocalActorBy Key - -> OutboxItemId - -> ExceptT Text (ReaderT SqlBackend m) () -verifyLocalActivityExistsInDB actorByKey outboxItemID = do - outboxID <- outboxItemOutbox <$> getE outboxItemID "No such OutboxItemId in DB" - itemActorID <- do - maybeActorID <- - lift $ getKeyBy $ UniqueActorOutbox outboxID - fromMaybeE maybeActorID "Outbox item's outbox doesn't belong to any Actor" - itemActorByKey <- lift $ getLocalActor' itemActorID - unless (itemActorByKey == actorByKey) $ - throwE "Actor-in-URI and Actor-owning-the-outbox-item-in-DB mismatch" - insertActivityToInbox :: MonadIO m => UTCTime -> ActorId -> OutboxItemId -> ReaderT SqlBackend m Bool @@ -292,8 +278,8 @@ postPersonOutboxR personHash = do AP.CreateTicketTracker detail mlocal -> createTicketTrackerC eperson actorDB summary audience detail mlocal mtarget _ -> throwE "Unsupported Create 'object' type" - AP.GrantActivity grant -> - grantC eperson actorDB mcap summary audience grant + AP.InviteActivity invite -> + inviteC eperson actorDB mcap summary audience invite {- AddActivity (AP.Add obj target) -> case obj of diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 90766b2..bb58212 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -133,6 +133,7 @@ import Yesod.Persist.Local import Vervis.ActivityPub import Vervis.Actor import Vervis.API +import Vervis.Data.Actor import Vervis.Discussion import Vervis.Federation import Vervis.FedURI @@ -144,6 +145,8 @@ import Vervis.Model.Ident import Vervis.Model.Ticket import Vervis.Model.Workflow import Vervis.Paginate +import Vervis.Persist.Actor +import Vervis.Recipient import Vervis.Settings import Vervis.Style import Vervis.Ticket @@ -193,6 +196,7 @@ getTicketR deckHash ticketHash = do encodeRouteHome <- getEncodeRouteHome hashPerson <- getEncodeKeyHashid hashItem <- getEncodeKeyHashid + hashActor <- getHashLocalActor hLocal <- getsYesod siteInstanceHost let route mk = encodeRouteLocal $ mk deckHash ticketHash authorHost = @@ -227,7 +231,7 @@ getTicketR deckHash ticketHash = do , AP.ticketResolved = let u (Left (actor, obiid)) = encodeRouteHome $ - outboxItemRoute actor $ hashItem obiid + activityRoute (hashActor actor) (hashItem obiid) u (Right (i, ro)) = ObjURI (instanceHost i) (remoteObjectIdent ro) in (,Nothing) . Just . u <$> resolve diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 1915d2a..337c8fa 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -2556,6 +2556,136 @@ changes hLocal ctx = , addFieldPrimRequired "InboxItem" defaultTime "received" -- 453 , addEntities model_453_collab_receive + -- 454 + , renameUnique "CollabSenderLocal" "UniqueCollabSenderLocal" "UniqueCollabFulfillsInviteLocal" + -- 455 + , renameUnique "CollabSenderLocal" "UniqueCollabSenderLocalActivity" "UniqueCollabFulfillsInviteLocalInvite" + -- 456 + , renameField "CollabSenderLocal" "activity" "invite" + -- 457 + , renameUnique "CollabSenderRemote" "UniqueCollabSenderRemote" "UniqueCollabFulfillsInviteRemote" + -- 458 + , renameUnique "CollabSenderRemote" "UniqueCollabSenderRemoteActivity" "UniqueCollabFulfillsInviteRemoteInvite" + -- 459 + , renameField "CollabSenderRemote" "activity" "invite" + -- 460 + , renameEntity "CollabSenderLocal" "CollabFulfillsInviteLocal" + -- 461 + , renameEntity "CollabSenderRemote" "CollabFulfillsInviteRemote" + -- 462 + , removeEntity "CollabRecipLocalReceive" + -- 463 + , removeEntity "CollabTopicRemoteAccept" + -- 464 + , removeEntity "CollabTopicRemote" + -- 465 + , removeEntity "CollabTopicLocalReceive" + -- 466 + , addFieldRefRequired'' + "CollabTopicLocalRepo" + (insertEntity Collab466) + (Just $ \ (Entity collabTemp _) -> do + collabs <- selectList [] [] + for_ collabs $ \ (Entity topicID topic) -> do + CollabTopicLocal466 collabID <- + getJust $ collabTopicLocalRepo466Collab topic + update topicID [CollabTopicLocalRepo466CollabNew =. collabID] + + delete collabTemp + ) + "collabNew" + "Collab" + -- 467 + , addFieldRefRequired'' + "CollabTopicLocalDeck" + (insertEntity Collab467) + (Just $ \ (Entity collabTemp _) -> do + collabs <- selectList [] [] + for_ collabs $ \ (Entity topicID topic) -> do + CollabTopicLocal467 collabID <- + getJust $ collabTopicLocalDeck467Collab topic + update topicID [CollabTopicLocalDeck467CollabNew =. collabID] + + delete collabTemp + ) + "collabNew" + "Collab" + -- 468 + , addFieldRefRequired'' + "CollabTopicLocalLoom" + (insertEntity Collab468) + (Just $ \ (Entity collabTemp _) -> do + collabs <- selectList [] [] + for_ collabs $ \ (Entity topicID topic) -> do + CollabTopicLocal468 collabID <- + getJust $ collabTopicLocalLoom468Collab topic + update topicID [CollabTopicLocalLoom468CollabNew =. collabID] + + delete collabTemp + ) + "collabNew" + "Collab" + -- 469 + , removeUnique' "CollabTopicLocalRepo" "" + -- 470 + , renameEntity "CollabTopicLocalRepo" "CollabTopicRepo" + -- 471 + , removeUnique' "CollabTopicLocalDeck" "" + -- 472 + , renameEntity "CollabTopicLocalDeck" "CollabTopicDeck" + -- 473 + , removeUnique' "CollabTopicLocalLoom" "" + -- 474 + , renameEntity "CollabTopicLocalLoom" "CollabTopicLoom" + -- 475 + , addUnique' "CollabTopicRepo" "" ["collabNew"] + -- 476 + , addUnique' "CollabTopicDeck" "" ["collabNew"] + -- 477 + , addUnique' "CollabTopicLoom" "" ["collabNew"] + -- 478 + , removeField "CollabTopicRepo" "collab" + -- 479 + , renameField "CollabTopicRepo" "collabNew" "collab" + -- 480 + , removeField "CollabTopicDeck" "collab" + -- 481 + , renameField "CollabTopicDeck" "collabNew" "collab" + -- 482 + , removeField "CollabTopicLoom" "collab" + -- 483 + , renameField "CollabTopicLoom" "collabNew" "collab" + -- 484 + , renameEntity "CollabTopicLocalAccept" "CollabEnable" + -- 485 + , renameField "CollabEnable" "accept" "grant" + -- 486 + , addFieldRefRequired'' + "CollabEnable" + (insertEntity Collab486) + (Just $ \ (Entity collabTemp _) -> do + collabs <- selectList [] [] + for_ collabs $ \ (Entity topicID topic) -> do + CollabTopicLocal486 collabID <- + getJust $ collabEnable486Collab topic + update topicID [CollabEnable486CollabNew =. collabID] + + delete collabTemp + ) + "collabNew" + "Collab" + -- 487 + , removeUnique "CollabEnable" "UniqueCollabTopicLocalAcceptCollab" + -- 488 + , addUnique' "CollabEnable" "" ["collabNew"] + -- 489 + , removeField "CollabEnable" "collab" + -- 490 + , renameField "CollabEnable" "collabNew" "collab" + -- 491 + , renameUnique "CollabEnable" "UniqueCollabTopicLocalAcceptAccept" "UniqueCollabEnableGrant" + -- 492 + , removeEntity "CollabTopicLocal" ] migrateDB diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 328b24a..47074b6 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -650,3 +650,15 @@ model_451_collab_remote_accept = $(schema "451_2022-08-30_collab_remote_accept") model_453_collab_receive :: [Entity SqlBackend] model_453_collab_receive = $(schema "453_2022-09-01_collab_receive") + +makeEntitiesMigration "466" + $(modelFile "migrations/466_2022-09-04_collab_topic_repo.model") + +makeEntitiesMigration "467" + $(modelFile "migrations/467_2022-09-04_collab_topic_deck.model") + +makeEntitiesMigration "468" + $(modelFile "migrations/468_2022-09-04_collab_topic_loom.model") + +makeEntitiesMigration "486" + $(modelFile "migrations/486_2022-09-04_collab_enable.model") diff --git a/src/Vervis/Persist/Actor.hs b/src/Vervis/Persist/Actor.hs new file mode 100644 index 0000000..0e77a3e --- /dev/null +++ b/src/Vervis/Persist/Actor.hs @@ -0,0 +1,68 @@ +{- This file is part of Vervis. + - + - Written in 2022 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Vervis.Persist.Actor + ( getLocalActor + , verifyLocalActivityExistsInDB + ) +where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import Control.Monad.Trans.Reader +import Data.Text (Text) +import Database.Persist +import Database.Persist.Sql + +import Control.Monad.Trans.Except.Local +import Database.Persist.Local + +import Vervis.Model +import Vervis.Recipient + +getLocalActor + :: MonadIO m => ActorId -> ReaderT SqlBackend m (LocalActorBy Key) +getLocalActor actorID = do + mp <- getKeyBy $ UniquePersonActor actorID + mg <- getKeyBy $ UniqueGroupActor actorID + mr <- getKeyBy $ UniqueRepoActor actorID + md <- getKeyBy $ UniqueDeckActor actorID + ml <- getKeyBy $ UniqueLoomActor actorID + return $ + case (mp, mg, mr, md, ml) of + (Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId" + (Just p, Nothing, Nothing, Nothing, Nothing) -> LocalActorPerson p + (Nothing, Just g, Nothing, Nothing, Nothing) -> LocalActorGroup g + (Nothing, Nothing, Just r, Nothing, Nothing) -> LocalActorRepo r + (Nothing, Nothing, Nothing, Just d, Nothing) -> LocalActorDeck d + (Nothing, Nothing, Nothing, Nothing, Just l) -> LocalActorLoom l + _ -> error "Multi-usage of an ActorId" + +verifyLocalActivityExistsInDB + :: MonadIO m + => LocalActorBy Key + -> OutboxItemId + -> ExceptT Text (ReaderT SqlBackend m) () +verifyLocalActivityExistsInDB actorByKey outboxItemID = do + outboxID <- outboxItemOutbox <$> getE outboxItemID "No such OutboxItemId in DB" + itemActorID <- do + maybeActorID <- + lift $ getKeyBy $ UniqueActorOutbox outboxID + fromMaybeE maybeActorID "Outbox item's outbox doesn't belong to any Actor" + itemActorByKey <- lift $ getLocalActor itemActorID + unless (itemActorByKey == actorByKey) $ + throwE "Actor-in-URI and Actor-owning-the-outbox-item-in-DB mismatch" diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 2f3a649..79e8eb7 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -71,6 +71,7 @@ module Web.ActivityPub , Create (..) , Follow (..) , Grant (..) + , Invite (..) , OfferObject (..) , Offer (..) , Push (..) @@ -1507,13 +1508,32 @@ data Grant u = Grant parseGrant :: UriMode u => Object -> Parser (Grant u) parseGrant o = Grant - <$> o .: "object" + <$> o .:+ "object" <*> o .: "context" <*> o .: "target" encodeGrant :: UriMode u => Grant u -> Series encodeGrant (Grant obj context target) - = "object" .= obj + = "object" .=+ obj + <> "context" .= context + <> "target" .= target + +data Invite u = Invite + { inviteInstrument :: Either Role (ObjURI u) + , inviteObject :: ObjURI u + , inviteTarget :: ObjURI u + } + +parseInvite :: UriMode u => Object -> Parser (Invite u) +parseInvite o = + Invite + <$> o .:+ "instrument" + <*> o .: "object" + <*> o .: "target" + +encodeInvite :: UriMode u => Invite u -> Series +encodeInvite (Invite obj context target) + = "object" .=+ obj <> "context" .= context <> "target" .= target @@ -1629,6 +1649,7 @@ data SpecificActivity u | CreateActivity (Create u) | FollowActivity (Follow u) | GrantActivity (Grant u) + | InviteActivity (Invite u) | OfferActivity (Offer u) | PushActivity (Push u) | RejectActivity (Reject u) @@ -1666,6 +1687,7 @@ instance ActivityPub Activity where "Create" -> CreateActivity <$> parseCreate o a actor "Follow" -> FollowActivity <$> parseFollow o "Grant" -> GrantActivity <$> parseGrant o + "Invite" -> InviteActivity <$> parseInvite o "Offer" -> OfferActivity <$> parseOffer o a actor "Push" -> PushActivity <$> parsePush a o "Reject" -> RejectActivity <$> parseReject o @@ -1691,6 +1713,7 @@ instance ActivityPub Activity where activityType (CreateActivity _) = "Create" activityType (FollowActivity _) = "Follow" activityType (GrantActivity _) = "Grant" + activityType (InviteActivity _) = "Invite" activityType (OfferActivity _) = "Offer" activityType (PushActivity _) = "Push" activityType (RejectActivity _) = "Reject" @@ -1702,6 +1725,7 @@ instance ActivityPub Activity where encodeSpecific _ _ (CreateActivity a) = encodeCreate a encodeSpecific _ _ (FollowActivity a) = encodeFollow a encodeSpecific _ _ (GrantActivity a) = encodeGrant a + encodeSpecific _ _ (InviteActivity a) = encodeInvite a encodeSpecific h u (OfferActivity a) = encodeOffer h u a encodeSpecific h _ (PushActivity a) = encodePush h a encodeSpecific _ _ (RejectActivity a) = encodeReject a diff --git a/th/models b/th/models index 876b733..1f70b6f 100644 --- a/th/models +++ b/th/models @@ -587,6 +587,28 @@ RemoteMessage Collab +-------------------------------- Collab reason ------------------------------- + +CollabFulfillsLocalTopicCreation + collab CollabId + + UniqueCollabFulfillsLocalTopicCreation collab + +CollabFulfillsInviteLocal + collab CollabId + invite OutboxItemId + + UniqueCollabFulfillsInviteLocal collab + UniqueCollabFulfillsInviteLocalInvite invite + +CollabFulfillsInviteRemote + collab CollabId + actor RemoteActorId + invite RemoteActivityId + + UniqueCollabFulfillsInviteRemote collab + UniqueCollabFulfillsInviteRemoteInvite invite + -------------------------------- Collab topic -------------------------------- -- Removed for now, until I figure out whether/how to federate custom roles @@ -596,74 +618,30 @@ Collab -- -- UniqueCollabRoleLocal collab -CollabTopicLocal +CollabTopicRepo collab CollabId - - UniqueCollabTopicLocal collab - -CollabTopicLocalRepo - collab CollabTopicLocalId repo RepoId - UniqueCollabTopicLocalRepo collab + UniqueCollabTopicRepo collab -CollabTopicLocalDeck - collab CollabTopicLocalId +CollabTopicDeck + collab CollabId deck DeckId - UniqueCollabTopicLocalDeck collab + UniqueCollabTopicDeck collab -CollabTopicLocalLoom - collab CollabTopicLocalId +CollabTopicLoom + collab CollabId loom LoomId - UniqueCollabTopicLocalLoom collab + UniqueCollabTopicLoom collab -CollabTopicLocalReceive - collab CollabTopicLocalId - item InboxItemId - - UniqueCollabTopicLocalReceiveCollab collab - UniqueCollabTopicLocalReceiveItem item - -CollabTopicLocalAccept - collab CollabTopicLocalId - accept OutboxItemId - - UniqueCollabTopicLocalAcceptCollab collab - UniqueCollabTopicLocalAcceptAccept accept - -CollabTopicRemote +CollabEnable collab CollabId - topic RemoteObjectId - actor RemoteActorId - role LocalURI Maybe + grant OutboxItemId - UniqueCollabTopicRemote collab - -CollabTopicRemoteAccept - collab CollabTopicRemoteId - accept RemoteActivityId - - UniqueCollabTopicRemoteAcceptCollab collab - UniqueCollabTopicRemoteAcceptAccept accept - --------------------------------- Collab sender ------------------------------- - -CollabSenderLocal - collab CollabId - activity OutboxItemId - - UniqueCollabSenderLocal collab - UniqueCollabSenderLocalActivity activity - -CollabSenderRemote - collab CollabId - actor RemoteActorId - activity RemoteActivityId - - UniqueCollabSenderRemote collab - UniqueCollabSenderRemoteActivity activity + UniqueCollabEnable collab + UniqueCollabEnableGrant grant -------------------------------- Collab recipient ---------------------------- @@ -673,13 +651,6 @@ CollabRecipLocal UniqueCollabRecipLocal collab -CollabRecipLocalReceive - collab CollabRecipLocalId - item InboxItemId - - UniqueCollabRecipLocalReceiveCollab collab - UniqueCollabRecipLocalReceiveItem item - CollabRecipLocalAccept collab CollabRecipLocalId accept OutboxItemId @@ -700,13 +671,6 @@ CollabRecipRemoteAccept UniqueCollabRecipRemoteAcceptCollab collab UniqueCollabRecipRemoteAcceptAccept accept --------------------------------- Collab reason ------------------------------- - -CollabFulfillsLocalTopicCreation - collab CollabId - - UniqueCollabFulfillsLocalTopicCreation collab - ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ diff --git a/vervis.cabal b/vervis.cabal index fd40a62..e7b4e72 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -137,8 +137,10 @@ library Vervis.Colour Vervis.Content Vervis.Darcs + Vervis.Data.Actor Vervis.Data.Collab + Vervis.Delivery Vervis.Discussion Vervis.Federation @@ -203,6 +205,9 @@ library Vervis.Paginate Vervis.Palette Vervis.Path + + Vervis.Persist.Actor + Vervis.Query Vervis.Readme Vervis.Recipient