forge/Vervis
1
0
Fork 0
Code Pull requests Activity

S2S: Switch from Grant->Accept->Enable to Invite->Accept->Grant

Browse source 
Giving access now starts with an Invite activity, followed by Accept from the
Invite's recipient. Finally, the resource sends a Grant, which is the actual
OCap.
This commit is contained in:
fr33domlover 2022-09-05 16:19:52 +00:00
parent 0d96ee0775
commit ac867e56f2
19 changed files with 697 additions and 532 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

15
migrations/466_2022-09-04_collab_topic_repo.model Normal file
View file

@ -0,0 +1,15 @@
Repo
Collab
CollabTopicLocal
collab CollabId
UniqueCollabTopicLocal collab
CollabTopicLocalRepo
collab CollabTopicLocalId
collabNew CollabId
repo RepoId
UniqueCollabTopicLocalRepo collab

15
migrations/467_2022-09-04_collab_topic_deck.model Normal file
View file

@ -0,0 +1,15 @@
Deck
Collab
CollabTopicLocal
collab CollabId
UniqueCollabTopicLocal collab
CollabTopicLocalDeck
collab CollabTopicLocalId
collabNew CollabId
deck DeckId
UniqueCollabTopicLocalDeck collab

15
migrations/468_2022-09-04_collab_topic_loom.model Normal file
View file

@ -0,0 +1,15 @@
Loom
Collab
CollabTopicLocal
collab CollabId
UniqueCollabTopicLocal collab
CollabTopicLocalLoom
collab CollabTopicLocalId
collabNew CollabId
loom LoomId
UniqueCollabTopicLocalLoom collab

16
migrations/486_2022-09-04_collab_enable.model Normal file
View file

@ -0,0 +1,16 @@
OutboxItem
Collab
CollabTopicLocal
collab CollabId
UniqueCollabTopicLocal collab
CollabEnable
collab CollabTopicLocalId
collabNew CollabId
grant OutboxItemId
UniqueCollabTopicLocalAcceptCollab collab
UniqueCollabTopicLocalAcceptAccept grant

7
src/Control/Monad/Trans/Except/Local.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -16,10 +16,12 @@
module Control.Monad.Trans.Except.Local module Control.Monad.Trans.Except.Local
( fromMaybeE ( fromMaybeE
, verifyNothingE , verifyNothingE
, nameExceptT
) )
where where
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Data.Text (Text)
fromMaybeE :: Monad m => Maybe a -> e -> ExceptT e m a fromMaybeE :: Monad m => Maybe a -> e -> ExceptT e m a
fromMaybeE Nothing t = throwE t fromMaybeE Nothing t = throwE t
@ -28,3 +30,6 @@ fromMaybeE (Just x) _ = return x
verifyNothingE :: Monad m => Maybe a -> e -> ExceptT e m () verifyNothingE :: Monad m => Maybe a -> e -> ExceptT e m ()
verifyNothingE Nothing _ = return () verifyNothingE Nothing _ = return ()
verifyNothingE (Just _) e = throwE e verifyNothingE (Just _) e = throwE e
nameExceptT :: Functor m => Text -> ExceptT Text m a -> ExceptT Text m a
nameExceptT title = withExceptT $ \ e -> title <> ": " <> e

322
src/Vervis/API.hs
View file

@ -24,7 +24,7 @@ module Vervis.API
, createNoteC , createNoteC
, createTicketTrackerC , createTicketTrackerC
, followC , followC
, grantC , inviteC
, offerTicketC , offerTicketC
, offerDepC , offerDepC
, resolveC , resolveC
@ -118,6 +118,7 @@ import Vervis.ActivityPub
import Vervis.ActorKey import Vervis.ActorKey
import Vervis.Cloth import Vervis.Cloth
import Vervis.Darcs import Vervis.Darcs
import Vervis.Data.Actor
import Vervis.Data.Collab import Vervis.Data.Collab
import Vervis.Delivery import Vervis.Delivery
import Vervis.Discussion import Vervis.Discussion
@ -169,7 +170,7 @@ acceptC
-> Audience URIMode -> Audience URIMode
-> Accept URIMode -> Accept URIMode
-> ExceptT Text Handler OutboxItemId -> ExceptT Text Handler OutboxItemId
acceptC (Entity pidUser personUser) senderActor summary audience accept = do acceptC (Entity senderPersonID senderPerson) senderActor summary audience accept = do
-- Check input -- Check input
acceptee <- parseAccept accept acceptee <- parseAccept accept
@ -180,30 +181,34 @@ acceptC (Entity pidUser personUser) senderActor summary audience accept = do
return recips return recips
now <- liftIO getCurrentTime 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 accepteeDB <- do
a <- getActivity acceptee a <- getActivity acceptee
fromMaybeE a "Can't find acceptee in DB" 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 case accepteeDB of
Left (actor, itemID) -> do Left (actorByKey, actorEntity, itemID) -> do
maybeSender <- maybeSender <-
lift $ getValBy $ UniqueCollabSenderLocalActivity itemID lift $ getValBy $ UniqueCollabFulfillsInviteLocalInvite itemID
(,Left actor) . collabSenderLocalCollab <$> return $
fromMaybeE maybeSender "No Collab for this local activity" (,Left (actorByKey, actorEntity)) . collabFulfillsInviteLocalCollab <$> maybeSender
Right remoteActivityID -> do Right remoteActivityID -> do
maybeSender <- maybeSender <-
lift $ getValBy $ UniqueCollabSenderRemoteActivity remoteActivityID lift $ getValBy $ UniqueCollabFulfillsInviteRemoteInvite remoteActivityID
CollabSenderRemote collab actorID _ <- for maybeSender $ \ (CollabFulfillsInviteRemote collab actorID _) -> do
fromMaybeE maybeSender "No Collab for this remote activity"
actor <- lift $ getJust actorID actor <- lift $ getJust actorID
lift $ lift $
(collab,) . Right . (,remoteActorFollowers actor) <$> (collab,) . Right . (,remoteActorFollowers actor) <$>
getRemoteActorURI' actor getRemoteActorURI actor
maybeCollabMore <- for maybeCollab $ \ (collabID, collabSender) -> do
-- Verify that Accept sender is the Collab recipient -- Verify that Accept sender is the Collab recipient
recip <- recip <-
@ -216,31 +221,26 @@ acceptC (Entity pidUser personUser) senderActor summary audience accept = do
recipID <- recipID <-
case recip of case recip of
Left (Entity crlid crl) Left (Entity crlid crl)
| collabRecipLocalPerson crl == pidUser -> return crlid | collabRecipLocalPerson crl == senderPersonID -> return crlid
_ -> throwE "Accepting a Collab whose recipient is someone else" _ -> throwE "Accepting an Invite whose recipient is someone else"
-- Verify the Collab isn't already validated -- Verify the Collab isn't already validated
topicActor <- lift $ getCollabTopic collabID maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID
case topicActor of verifyNothingE maybeEnabled "Collab already enabled by the local topic"
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 Grant sender and resource are addressed by the Accept -- Verify that Grant sender and resource are addressed by the Accept
topic <- lift $ getCollabTopic collabID
verifyResourceAddressed localRecips topic
bitraverse_ bitraverse_
(verifyResourceAddressed localRecips . snd) (verifySenderAddressed localRecips . fst)
(verifyRemoteAddressed remoteRecips . snd)
topicActor
bitraverse_
(verifySenderAddressed localRecips)
(verifyRemoteAddressed remoteRecips . fst) (verifyRemoteAddressed remoteRecips . fst)
collabSender collabSender
return (collabID, recipID, topic, collabSender)
-- Record the Accept on the Collab -- Record the Accept on the Collab
acceptID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now acceptID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
for_ maybeCollabMore $ \ (_, recipID, _, _) -> do
maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID acceptID maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID acceptID
unless (isNothing maybeAccept) $ do unless (isNothing maybeAccept) $ do
lift $ delete acceptID lift $ delete acceptID
@ -252,93 +252,77 @@ acceptC (Entity pidUser personUser) senderActor summary audience accept = do
-- Deliver the Accept activity to local recipients, and schedule -- Deliver the Accept activity to local recipients, and schedule
-- delivery for unavailable remote recipients -- delivery for unavailable remote recipients
remoteRecipsHttpAccept <- do 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 let sieveActors = catMaybes
[ case topicHash of [ grantResourceLocalActor <$> maybeTopicHash
Left (GrantResourceRepo r) -> Just $ LocalActorRepo r , maybeSenderHash
Left (GrantResourceDeck d) -> Just $ LocalActorDeck d
Left (GrantResourceLoom l) -> Just $ LocalActorLoom l
Right _ -> Nothing
, case collabSender of
Left actor -> Just actor
Right _ -> Nothing
] ]
sieveStages = catMaybes sieveStages = catMaybes
[ Just $ LocalStagePersonFollowers senderHash [ Just $ LocalStagePersonFollowers senderHash
, case topicHash of , localActorFollowers . grantResourceLocalActor <$> maybeTopicHash
Left (GrantResourceRepo r) -> Just $ LocalStageRepoFollowers r , localActorFollowers <$> maybeSenderHash
Left (GrantResourceDeck d) -> Just $ LocalStageDeckFollowers d
Left (GrantResourceLoom l) -> Just $ LocalStageLoomFollowers l
Right _ -> Nothing
, case collabSender of
Left actor -> Just $ localActorFollowers actor
Right _ -> Nothing
] ]
sieve = makeRecipientSet sieveActors sieveStages sieve = makeRecipientSet sieveActors sieveStages
moreRemoteRecips <- moreRemoteRecips <-
lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor personUser) acceptID $ lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor senderPerson) acceptID $
localRecipSieve sieve False localRecips localRecipSieve sieve False localRecips
checkFederation moreRemoteRecips checkFederation moreRemoteRecips
lift $ deliverRemoteDB'' fwdHosts acceptID remoteRecips moreRemoteRecips lift $ deliverRemoteDB'' fwdHosts acceptID remoteRecips moreRemoteRecips
-- 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 -- If resource is local, verify it has received the Accept
topicActorLocal <- resourceByEntity <- getGrantResource resource "getGrantResource"
case topicActor of let resourceActorID = grantResourceActor resourceByEntity
Left (localID, resource) ->
Just . (localID,) <$> getGrantResource resource "getGrantResource"
Right _ -> pure Nothing
for_ topicActorLocal $ \ (_, resource) -> do
let resourceActorID = grantResourceActor resource
verifyActorHasItem resourceActorID acceptID "Local topic didn't receive the Accept" verifyActorHasItem resourceActorID acceptID "Local topic didn't receive the Accept"
-- If Collab sender is local, verify it has received the Accept -- If Collab sender is local, verify it has received the Accept
case collabSender of case sender of
Left actorHash -> do Left (_, (Entity actorID _)) ->
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" verifyActorHasItem actorID acceptID "Local Collab sender didn't receive the Accept"
Right _ -> pure () 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
-- Approve the Collab in the DB -- Approve the Collab in the DB
resourceOutbox <- resourceOutbox <-
lift $ actorOutbox <$> getJust (grantResourceActor resource) lift $ actorOutbox <$> getJust resourceActorID
enableID <- lift $ insertEmptyOutboxItem resourceOutbox now grantID <- lift $ insertEmptyOutboxItem resourceOutbox now
lift $ insert_ $ CollabTopicLocalAccept topicLocalID enableID lift $ insert_ $ CollabEnable collabID grantID
-- Insert the Enable to resource's outbox -- Insert the Grant to resource's outbox
(docEnable, localRecipsEnable, remoteRecipsEnable, fwdHostsEnable) <- (docGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant) <-
lift $ insertEnableToOutbox senderHash collabSender resource enableID 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 -- for unavailable remote recipients
remoteRecipsHttpEnable <- do remoteRecipsHttpGrant <- do
moreRemoteRecips <- do moreRemoteRecips <- do
resourceHash <- hashGrantResource $ bmap entityKey resource resourceHash <- hashGrantResource resource
lift $ deliverLocal' True (grantResourceLocalActor resourceHash) (grantResourceActor resource) enableID localRecipsEnable lift $ deliverLocal' True (grantResourceLocalActor resourceHash) resourceActorID grantID localRecipsGrant
checkFederation moreRemoteRecips checkFederation moreRemoteRecips
lift $ deliverRemoteDB'' fwdHostsEnable enableID remoteRecipsEnable moreRemoteRecips lift $ deliverRemoteDB'' fwdHostsGrant grantID remoteRecipsGrant moreRemoteRecips
-- Return instructions for HTTP delivery to remote recipients -- 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 instructions for HTTP delivery to remote recipients
return return
( acceptID ( acceptID
, deliverRemoteHttp' fwdHosts acceptID docAccept remoteRecipsHttpAccept , 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 lift $ do
forkWorker "acceptC: async HTTP Accept delivery" deliverHttpAccept forkWorker "acceptC: async HTTP Accept delivery" deliverHttpAccept
for_ deliverHttpTopicAccept $ for_ deliverHttpGrant $
forkWorker "acceptC: async HTTP Topic Accept delivery" forkWorker "acceptC: async HTTP Grant delivery"
return obiidAccept return obiidAccept
@ -346,11 +330,10 @@ acceptC (Entity pidUser personUser) senderActor summary audience accept = do
parseAccept (Accept object mresult) = do parseAccept (Accept object mresult) = do
verifyNothingE mresult "Accept must not contain 'result'" 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 object <- getJust $ remoteActorIdent actor
inztance <- getJust $ remoteObjectInstance object inztance <- getJust $ remoteObjectInstance object
return $ return $
@ -359,37 +342,23 @@ acceptC (Entity pidUser personUser) senderActor summary audience accept = do
(remoteObjectIdent object) (remoteObjectIdent object)
getCollabTopic collabID = do getCollabTopic collabID = do
maybeLocal <- do maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
maybeLocalID <- getKeyBy $ UniqueCollabTopicLocal collabID maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
for maybeLocalID $ \ localID -> do maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
resourceID <- do
maybeRepo <- getValBy $ UniqueCollabTopicLocalRepo localID
maybeDeck <- getValBy $ UniqueCollabTopicLocalDeck localID
maybeLoom <- getValBy $ UniqueCollabTopicLocalLoom localID
return $ return $
case (maybeRepo, maybeDeck, maybeLoom) of case (maybeRepo, maybeDeck, maybeLoom) of
(Nothing, Nothing, Nothing) -> error "Found Collab with no specific local topic" (Nothing, Nothing, Nothing) -> error "Found Collab without topic"
(Just r, Nothing, Nothing) -> (Just r, Nothing, Nothing) ->
GrantResourceRepo $ collabTopicLocalRepoRepo r GrantResourceRepo $ collabTopicRepoRepo r
(Nothing, Just d, Nothing) -> (Nothing, Just d, Nothing) ->
GrantResourceDeck $ collabTopicLocalDeckDeck d GrantResourceDeck $ collabTopicDeckDeck d
(Nothing, Nothing, Just l) -> (Nothing, Nothing, Just l) ->
GrantResourceLoom $ collabTopicLocalLoomLoom l GrantResourceLoom $ collabTopicLoomLoom l
_ -> error "Found Collab with multiple local topics" _ -> error "Found Collab with multiple 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"
verifySenderAddressed localRecips actor = do verifySenderAddressed localRecips actor = do
unless (actorIsAddressed localRecips actor) $ actorByHash <- hashLocalActor actor
unless (actorIsAddressed localRecips actorByHash) $
throwE "Collab sender not addressed" throwE "Collab sender not addressed"
insertAcceptToOutbox senderHash now blinded acceptID = do 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 (GrantResourceDeck (Entity _ d)) = deckActor d
grantResourceActor (GrantResourceLoom (Entity _ l)) = loomActor l grantResourceActor (GrantResourceLoom (Entity _ l)) = loomActor l
grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f insertGrantToOutbox
grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r :: KeyHashid Person
grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d -> Either (LocalActorBy Key, Entity Actor) (FedURI, Maybe LocalURI)
grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l -> GrantResourceBy Key
-> OutboxItemId
insertEnableToOutbox recipHash sender topic enableID = do -> ReaderT SqlBackend Handler
( Doc Activity URIMode
, RecipientRoutes
, [(Host, NonEmpty LocalURI)]
, [Host]
)
insertGrantToOutbox recipHash sender topic grantID = do
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
hLocal <- asksSite siteInstanceHost hLocal <- asksSite siteInstanceHost
topicHash <- topicHash <-
grantResourceLocalActor <$> hashGrantResource (bmap entityKey topic) grantResourceLocalActor <$> hashGrantResource topic
enableHash <- encodeKeyHashid enableID grantHash <- encodeKeyHashid grantID
senderHash <- bitraverse (hashLocalActor . fst) pure sender
let audSender = let audSender =
case sender of case senderHash of
Left actor -> AudLocal [actor] [localActorFollowers actor] Left actor -> AudLocal [actor] [localActorFollowers actor]
Right (ObjURI h lu, followers) -> Right (ObjURI h lu, followers) ->
AudRemote h [lu] (maybeToList followers) AudRemote h [lu] (maybeToList followers)
@ -444,19 +420,20 @@ acceptC (Entity pidUser personUser) senderActor summary audience accept = do
recips = map encodeRouteHome audLocal ++ audRemote recips = map encodeRouteHome audLocal ++ audRemote
doc = Doc hLocal Activity doc = Doc hLocal Activity
{ activityId = Just $ encodeRouteLocal $ outboxItemRoute topicHash enableHash { activityId = Just $ encodeRouteLocal $ activityRoute topicHash grantHash
, activityActor = encodeRouteLocal $ renderLocalActor topicHash , activityActor = encodeRouteLocal $ renderLocalActor topicHash
, activityCapability = Nothing , activityCapability = Nothing
, activitySummary = Nothing , activitySummary = Nothing
, activityAudience = Audience recips [] [] [] [] [] , activityAudience = Audience recips [] [] [] [] []
, activityFulfills = [] , activityFulfills = []
, activitySpecific = AcceptActivity Accept , activitySpecific = GrantActivity Grant
{ acceptObject = acceptObject accept { grantObject = Left RoleAdmin
, acceptResult = Nothing , grantContext = encodeRouteHome $ renderLocalActor topicHash
, grantTarget = encodeRouteHome $ PersonR recipHash
} }
} }
update enableID [OutboxItemActivity =. persistJSONObjectFromDoc doc] update grantID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (doc, recipientSet, remoteActors, fwdHosts) return (doc, recipientSet, remoteActors, fwdHosts)
addBundleC addBundleC
@ -1530,10 +1507,8 @@ createTicketTrackerC (Entity pidUser personUser) senderActor summary audience tr
insertCollab did obiidGrant = do insertCollab did obiidGrant = do
cid <- insert Collab cid <- insert Collab
ctlid <- insert $ CollabTopicLocal cid insert_ $ CollabTopicDeck cid did
insert_ $ CollabTopicLocalDeck ctlid did insert_ $ CollabEnable cid obiidGrant
insert_ $ CollabTopicLocalAccept ctlid obiidGrant
insert_ $ CollabSenderLocal cid obiidGrant
insert_ $ CollabRecipLocal cid pidUser insert_ $ CollabRecipLocal cid pidUser
insert_ $ CollabFulfillsLocalTopicCreation cid insert_ $ CollabFulfillsLocalTopicCreation cid
@ -1808,21 +1783,21 @@ data Result
| ResultNotActor | ResultNotActor
deriving Show deriving Show
grantC inviteC
:: Entity Person :: Entity Person
-> Actor -> Actor
-> Maybe FedURI -> Maybe FedURI
-> Maybe TextHtml -> Maybe TextHtml
-> Audience URIMode -> Audience URIMode
-> Grant URIMode -> Invite URIMode
-> ExceptT Text Handler OutboxItemId -> 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 -- Check input
(resource, recipient) <- parseGrant (Just pidUser) grant (resource, recipient) <- parseInvite (Just senderPersonID) invite
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
mrecips <- parseAudience audience mrecips <- parseAudience audience
recips <- fromMaybeE mrecips "Grant with no recipients" recips <- fromMaybeE mrecips "Invite with no recipients"
checkFederation $ paudRemoteActors recips checkFederation $ paudRemoteActors recips
return 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 -- * Outbox item URI of a local actor, i.e. a local activity
-- * A remote URI -- * A remote URI
uCap <- fromMaybeE muCap "No capability provided" 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 -- 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. -- 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 recipient
-- Verify that resource and recipient are addressed by the Grant -- Verify that resource and recipient are addressed by the Invite
bitraverse_ bitraverse_
(verifyResourceAddressed localRecips . bmap entityKey) (verifyResourceAddressed localRecips . bmap entityKey)
(\ (_, _, u) -> verifyRemoteAddressed remoteRecips u) (\ (_, _, u) -> verifyRemoteAddressed remoteRecips u)
@ -1881,28 +1856,34 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
recipientDB recipientDB
now <- liftIO getCurrentTime 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 -- If resource is local, verify the specified capability gives relevant
-- access. If resource is remote, check the specified capability as -- access to it.
-- much as we can, letting the remote resource say the final word. case resourceDB of
bitraverse_ Left r -> do
(verifyCapability capID pidUser . bmap entityKey) capability <-
(verifyCapabilityRemote capID pidUser . (\ (o, _, _) -> o)) case capID of
resourceDB 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 -- Insert new Collab to DB
grantID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now inviteID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
lift $ insertCollab resourceDB recipientDB grantID case resourceDB of
Left localResource ->
lift $ insertCollab localResource recipientDB inviteID
Right _ -> pure ()
-- Insert the Grant activity to author's outbox -- 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 -- delivery for unavailable remote recipients
remoteRecipsHttpGrant <- do remoteRecipsHttpInvite <- do
resourceHash <- bitraverse hashGrantResource pure resource resourceHash <- bitraverse hashGrantResource pure resource
recipientHash <- bitraverse hashGrantRecip pure recipient recipientHash <- bitraverse hashGrantRecip pure recipient
let sieveActors = catMaybes let sieveActors = catMaybes
@ -1928,10 +1909,10 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
] ]
sieve = makeRecipientSet sieveActors sieveStages sieve = makeRecipientSet sieveActors sieveStages
moreRemoteRecips <- moreRemoteRecips <-
lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor personUser) grantID $ lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor senderPerson) inviteID $
localRecipSieve sieve False localRecips localRecipSieve sieve False localRecips
checkFederation moreRemoteRecips checkFederation moreRemoteRecips
lift $ deliverRemoteDB'' fwdHosts grantID remoteRecips moreRemoteRecips lift $ deliverRemoteDB'' fwdHosts inviteID remoteRecips moreRemoteRecips
-- If resource is local, verify it has received the Grant -- If resource is local, verify it has received the Grant
case resourceDB of case resourceDB of
@ -1941,26 +1922,26 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
GrantResourceRepo (Entity _ r) -> repoActor r GrantResourceRepo (Entity _ r) -> repoActor r
GrantResourceDeck (Entity _ d) -> deckActor d GrantResourceDeck (Entity _ d) -> deckActor d
GrantResourceLoom (Entity _ l) -> loomActor l 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 () 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 case recipientDB of
Left (GrantRecipPerson (Entity _ p)) -> 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 () Right _ -> pure ()
-- Return instructions for HTTP delivery to remote recipients -- Return instructions for HTTP delivery to remote recipients
return return
( grantID ( inviteID
, deliverRemoteHttp' fwdHosts grantID docGrant remoteRecipsHttpGrant , deliverRemoteHttp' fwdHosts inviteID docInvite remoteRecipsHttpInvite
) )
-- Launch asynchronous HTTP delivery of the Grant activity -- Launch asynchronous HTTP delivery of the Grant activity
lift $ do lift $ do
forkWorker "grantC: async HTTP Grant delivery" deliverHttpGrant forkWorker "inviteC: async HTTP Grant delivery" deliverHttpInvite
return obiidGrant return obiidInvite
where where
@ -2017,48 +1998,43 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
lus <- lookup h remoteRecips lus <- lookup h remoteRecips
guard $ lu `elem` lus guard $ lu `elem` lus
insertCollab resource recipient grantID = do insertCollab resource recipient inviteID = do
collabID <- insert Collab collabID <- insert Collab
case resource of case resource of
Left local -> do
topicID <- insert $ CollabTopicLocal collabID
case local of
GrantResourceRepo (Entity repoID _) -> GrantResourceRepo (Entity repoID _) ->
insert_ $ CollabTopicLocalRepo topicID repoID insert_ $ CollabTopicRepo collabID repoID
GrantResourceDeck (Entity deckID _) -> GrantResourceDeck (Entity deckID _) ->
insert_ $ CollabTopicLocalDeck topicID deckID insert_ $ CollabTopicDeck collabID deckID
GrantResourceLoom (Entity loomID _) -> GrantResourceLoom (Entity loomID _) ->
insert_ $ CollabTopicLocalLoom topicID loomID insert_ $ CollabTopicLoom collabID loomID
Right (remoteID, actorID, _) -> insert_ $ CollabFulfillsInviteLocal collabID inviteID
insert_ $ CollabTopicRemote collabID remoteID actorID Nothing
insert_ $ CollabSenderLocal collabID grantID
case recipient of case recipient of
Left (GrantRecipPerson (Entity personID _)) -> Left (GrantRecipPerson (Entity personID _)) ->
insert_ $ CollabRecipLocal collabID personID insert_ $ CollabRecipLocal collabID personID
Right (remoteActorID, _) -> Right (remoteActorID, _) ->
insert_ $ CollabRecipRemote collabID remoteActorID insert_ $ CollabRecipRemote collabID remoteActorID
hashGrantRecip (GrantRecipPerson k) = insertInviteToOutbox senderHash now uCap blinded inviteID = do
GrantRecipPerson <$> encodeKeyHashid k
insertGrantToOutbox senderHash now uCap blinded grantID = do
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
hLocal <- asksSite siteInstanceHost hLocal <- asksSite siteInstanceHost
grantHash <- encodeKeyHashid grantID inviteHash <- encodeKeyHashid inviteID
let doc = Doc hLocal Activity let doc = Doc hLocal Activity
{ activityId = { activityId =
Just $ encodeRouteLocal $ Just $ encodeRouteLocal $
PersonOutboxItemR senderHash grantHash PersonOutboxItemR senderHash inviteHash
, activityActor = encodeRouteLocal $ PersonR senderHash , activityActor = encodeRouteLocal $ PersonR senderHash
, activityCapability = Just uCap , activityCapability = Just uCap
, activitySummary = summary , activitySummary = summary
, activityAudience = blinded , activityAudience = blinded
, activityFulfills = [] , activityFulfills = []
, activitySpecific = GrantActivity grant , activitySpecific = InviteActivity invite
} }
update grantID [OutboxItemActivity =. persistJSONObjectFromDoc doc] update inviteID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return doc return doc
hashGrantRecip (GrantRecipPerson k) =
GrantRecipPerson <$> encodeKeyHashid k
offerTicketC offerTicketC
:: Entity Person :: Entity Person
-> Maybe TextHtml -> Maybe TextHtml

173
src/Vervis/Access.hs
View file

@ -70,8 +70,9 @@ module Vervis.Access
, hashGrantResource , hashGrantResource
, getGrantResource , getGrantResource
, grantResourceLocalActor
, verifyCapability , verifyCapability
, verifyCapabilityRemote
) )
where where
@ -103,6 +104,7 @@ import Vervis.FedURI
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Role import Vervis.Model.Role
import Vervis.Persist.Actor
import Vervis.Query import Vervis.Query
import Vervis.Recipient import Vervis.Recipient
@ -112,6 +114,16 @@ data ObjectAccessStatus =
data PersonRole = Developer | User | Guest | RoleID RoleId data PersonRole = Developer | User | Guest | RoleID RoleId
{-
data RepoAuthorization
= RepoAuthorizationLocal PersonId
| RepoAuthorizationRemote RepoRemoteCollabId
data ProjectAuthorization
= ProjectAuthorizationLocal PersonId
| ProjectAuthorizationRemote ProjectRemoteCollabId
-}
roleHasAccess roleHasAccess
:: MonadIO m :: MonadIO m
=> PersonRole => PersonRole
@ -167,15 +179,14 @@ checkRepoAccess' mpid op repoID = do
where where
asCollab rid pid = do asCollab rid pid = do
fmap (const Developer) . listToMaybe <$> do fmap (const Developer) . listToMaybe <$> do
E.select $ E.from $ \ (repo `E.InnerJoin` topic `E.InnerJoin` recip `E.InnerJoin` accept) -> do E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` enable) -> do
E.on $ topic E.^. CollabTopicLocalId E.==. accept E.^. CollabTopicLocalAcceptCollab E.on $ topic E.^. CollabTopicRepoCollab E.==. enable E.^. CollabEnableCollab
E.on $ topic E.^. CollabTopicLocalCollab E.==. recip E.^. CollabRecipLocalCollab E.on $ topic E.^. CollabTopicRepoCollab E.==. recip E.^. CollabRecipLocalCollab
E.on $ repo E.^. CollabTopicLocalRepoCollab E.==. topic E.^. CollabTopicLocalId
E.where_ $ 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 recip E.^. CollabRecipLocalPerson E.==. E.val pid
E.limit 1 E.limit 1
return $ topic E.^. CollabTopicLocalCollab return $ topic E.^. CollabTopicRepoCollab
asUser = fmap RoleID . repoCollabUser asUser = fmap RoleID . repoCollabUser
asAnon = fmap RoleID . repoCollabAnon asAnon = fmap RoleID . repoCollabAnon
@ -202,15 +213,14 @@ checkRepoAccess mpid op repoHash = do
where where
asCollab rid pid = do asCollab rid pid = do
fmap (const Developer) . listToMaybe <$> do fmap (const Developer) . listToMaybe <$> do
E.select $ E.from $ \ (repo `E.InnerJoin` topic `E.InnerJoin` recip `E.InnerJoin` accept) -> do E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` enable) -> do
E.on $ topic E.^. CollabTopicLocalId E.==. accept E.^. CollabTopicLocalAcceptCollab E.on $ topic E.^. CollabTopicRepoCollab E.==. enable E.^. CollabEnableCollab
E.on $ topic E.^. CollabTopicLocalCollab E.==. recip E.^. CollabRecipLocalCollab E.on $ topic E.^. CollabTopicRepoCollab E.==. recip E.^. CollabRecipLocalCollab
E.on $ repo E.^. CollabTopicLocalRepoCollab E.==. topic E.^. CollabTopicLocalId
E.where_ $ 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 recip E.^. CollabRecipLocalPerson E.==. E.val pid
E.limit 1 E.limit 1
return $ topic E.^. CollabTopicLocalCollab return $ topic E.^. CollabTopicRepoCollab
asUser = fmap RoleID . repoCollabUser asUser = fmap RoleID . repoCollabUser
asAnon = fmap RoleID . repoCollabAnon asAnon = fmap RoleID . repoCollabAnon
@ -238,15 +248,14 @@ checkProjectAccess mpid op deckHash = do
where where
asCollab jid pid = do asCollab jid pid = do
fmap (const Developer) . listToMaybe <$> do fmap (const Developer) . listToMaybe <$> do
E.select $ E.from $ \ (deck `E.InnerJoin` topic `E.InnerJoin` recip `E.InnerJoin` accept) -> do E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` enable) -> do
E.on $ topic E.^. CollabTopicLocalId E.==. accept E.^. CollabTopicLocalAcceptCollab E.on $ topic E.^. CollabTopicDeckCollab E.==. enable E.^. CollabEnableCollab
E.on $ topic E.^. CollabTopicLocalCollab E.==. recip E.^. CollabRecipLocalCollab E.on $ topic E.^. CollabTopicDeckCollab E.==. recip E.^. CollabRecipLocalCollab
E.on $ deck E.^. CollabTopicLocalDeckCollab E.==. topic E.^. CollabTopicLocalId
E.where_ $ 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 recip E.^. CollabRecipLocalPerson E.==. E.val pid
E.limit 1 E.limit 1
return $ topic E.^. CollabTopicLocalCollab return $ topic E.^. CollabTopicDeckCollab
asUser = fmap RoleID . deckCollabUser asUser = fmap RoleID . deckCollabUser
asAnon = fmap RoleID . deckCollabAnon asAnon = fmap RoleID . deckCollabAnon
@ -288,34 +297,33 @@ getGrantResource (GrantResourceDeck k) e =
getGrantResource (GrantResourceLoom k) e = getGrantResource (GrantResourceLoom k) e =
GrantResourceLoom <$> getEntityE 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 verifyCapability
:: Either (LocalActorBy KeyHashid, OutboxItemId) FedURI :: (LocalActorBy Key, OutboxItemId)
-> PersonId -> PersonId
-> GrantResourceBy Key -> GrantResourceBy Key
-> ExceptT Text (ReaderT SqlBackend Handler) () -> 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 -- Find the activity itself by URI in the DB
grant <- do nameExceptT "Capability activity not found" $
mact <- getActivity capability verifyLocalActivityExistsInDB capActor capItem
fromMaybeE mact "Capability activity not known to me"
-- Find the Collab record for that activity -- Find the Collab record for that activity
cid <- collabID <- do
case grant of maybeEnable <- lift $ getValBy $ UniqueCollabEnableGrant capItem
Left (_actor, obiid) -> do collabEnableCollab <$>
mcsl <- lift $ getValBy $ UniqueCollabSenderLocalActivity obiid fromMaybeE maybeEnable "No CollabEnable for this activity"
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 -- Find the recipient of that Collab
recipID <- do recipID <- do
mcrl <- lift $ getValBy $ UniqueCollabRecipLocal cid mcrl <- lift $ getValBy $ UniqueCollabRecipLocal collabID
crl <- fromMaybeE mcrl "No local recip for capability" 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!" for_ mcrr $ \ _ -> error "Both local & remote recip for capability!"
return $ collabRecipLocalPerson crl return $ collabRecipLocalPerson crl
@ -323,98 +331,29 @@ verifyCapability capability personID resource = do
unless (recipID == personID) $ unless (recipID == personID) $
throwE "Collab recipient is some other Person" 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 -- Find the local topic, on which this Collab gives access
(topic, topicLocalID) <- lift $ do topic <- lift $ do
localID <- do maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
maybeLocal <- getKeyBy $ UniqueCollabTopicLocal cid maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
case maybeLocal of maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
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 case (maybeRepo, maybeDeck, maybeLoom) of
(Nothing, Nothing, Nothing) -> error "Collab without local topic" (Nothing, Nothing, Nothing) -> error "Collab without topic"
(Just r, Nothing, Nothing) -> (Just r, Nothing, Nothing) ->
return $ GrantResourceRepo $ collabTopicLocalRepoRepo r return $ GrantResourceRepo $ collabTopicRepoRepo r
(Nothing, Just d, Nothing) -> (Nothing, Just d, Nothing) ->
return $ GrantResourceDeck $ collabTopicLocalDeckDeck d return $ GrantResourceDeck $ collabTopicDeckDeck d
(Nothing, Nothing, Just l) -> (Nothing, Nothing, Just l) ->
return $ GrantResourceLoom $ collabTopicLocalLoomLoom l return $ GrantResourceLoom $ collabTopicLoomLoom l
_ -> error "Collab with multiple topics" _ -> 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 -- Verify the topic matches the resource specified
unless (topic == resource) $ unless (topic == resource) $
throwE "Capability topic is some other local 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" -- 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 -- role that supports every operation, we don't need to check role access
return () return ()

110
src/Vervis/ActivityPub.hs
View file

@ -28,15 +28,10 @@ module Vervis.ActivityPub
, insertEmptyOutboxItem , insertEmptyOutboxItem
, verifyContentTypeAP , verifyContentTypeAP
, verifyContentTypeAP_E , verifyContentTypeAP_E
, parseActivity
, parseActivityURI
, getActivity , getActivity
--, ActorEntity (..) --, ActorEntity (..)
, getLocalActor'
, getLocalActor
--, getOutboxActorEntity --, getOutboxActorEntity
--, actorEntityPath --, actorEntityPath
, outboxItemRoute
, verifyActorHasItem , verifyActorHasItem
) )
@ -272,54 +267,18 @@ verifyContentTypeAP_E = do
"application/ld+json; \ "application/ld+json; \
\profile=\"https://www.w3.org/ns/activitystreams\"" \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 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 obi <- do
mobi <- lift $ get obiid mobi <- lift $ get obiid
fromMaybeE mobi "No such obiid" fromMaybeE mobi "No such obiid"
unless (outboxItemOutbox obi == obid) $ unless (outboxItemOutbox obi == obid) $
throwE "Actor/obiid mismatch" throwE "Actor/obiid mismatch"
return (actor, obiid) return (actor, Entity actorID actorDB, 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
getActivity (Right u@(ObjURI h lu)) = lift $ runMaybeT $ Right <$> do getActivity (Right u@(ObjURI h lu)) = lift $ runMaybeT $ Right <$> do
iid <- MaybeT $ getKeyBy $ UniqueInstance h iid <- MaybeT $ getKeyBy $ UniqueInstance h
@ -333,57 +292,6 @@ data ActorEntity
| ActorRepo (Entity Repo) | 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 getOutboxActorEntity obid = do
mp <- getBy $ UniquePersonOutbox obid mp <- getBy $ UniquePersonOutbox obid
@ -410,12 +318,6 @@ actorEntityPath (ActorRepo (Entity _ r)) =
getJust (repoSharer 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 verifyActorHasItem actorID itemID errorMessage = do
inboxID <- lift $ actorInbox <$> getJust actorID inboxID <- lift $ actorInbox <$> getJust actorID
maybeItem <- lift $ getBy $ UniqueInboxItemLocal inboxID itemID maybeItem <- lift $ getBy $ UniqueInboxItemLocal inboxID itemID

38
src/Vervis/Data/Actor.hs
View file

@ -15,6 +15,8 @@
module Vervis.Data.Actor module Vervis.Data.Actor
( parseLocalActivityURI ( parseLocalActivityURI
, parseActivityURI
, activityRoute
) )
where where
@ -22,12 +24,14 @@ import Control.Monad.Trans.Except
import Data.Text (Text) import Data.Text (Text)
import Network.FedURI import Network.FedURI
import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids import Yesod.Hashids
import Yesod.MonadSite import Yesod.MonadSite
import Control.Monad.Trans.Except.Local import Control.Monad.Trans.Except.Local
import Vervis.FedURI
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Recipient import Vervis.Recipient
@ -37,15 +41,13 @@ parseLocalActivityURI
=> LocalURI => LocalURI
-> ExceptT Text m (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId) -> ExceptT Text m (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId)
parseLocalActivityURI luAct = do parseLocalActivityURI luAct = do
route <- route <- fromMaybeE (decodeRouteLocal luAct) "Not a valid route"
fromMaybeE (decodeRouteLocal luAct) "Local activity: Not a valid route"
(actorHash, outboxItemHash) <- (actorHash, outboxItemHash) <-
fromMaybeE fromMaybeE
(parseOutboxItemRoute route) (parseOutboxItemRoute route)
"Local activity: Valid local route, but not an outbox item route" "Valid local route, but not an outbox item route"
outboxItemID <- outboxItemID <- decodeKeyHashidE outboxItemHash "Invalid outbox item hash"
decodeKeyHashidE outboxItemHash "Local activity: Invalid outbox item hash" actorKey <- unhashLocalActorE actorHash "Invalid actor hash"
actorKey <- unhashLocalActorE actorHash "Local activity: Invalid actor hash"
return (actorKey, actorHash, outboxItemID) return (actorKey, actorHash, outboxItemID)
where where
parseOutboxItemRoute (PersonOutboxItemR p i) = Just (LocalActorPerson p, i) parseOutboxItemRoute (PersonOutboxItemR p i) = Just (LocalActorPerson p, i)
@ -54,3 +56,27 @@ parseLocalActivityURI luAct = do
parseOutboxItemRoute (DeckOutboxItemR d i) = Just (LocalActorDeck d, i) parseOutboxItemRoute (DeckOutboxItemR d i) = Just (LocalActorDeck d, i)
parseOutboxItemRoute (LoomOutboxItemR l i) = Just (LocalActorLoom l, i) parseOutboxItemRoute (LoomOutboxItemR l i) = Just (LocalActorLoom l, i)
parseOutboxItemRoute _ = Nothing 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

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

@ -18,6 +18,7 @@
module Vervis.Data.Collab module Vervis.Data.Collab
( GrantRecipBy (..) ( GrantRecipBy (..)
, parseInvite
, parseGrant , parseGrant
) )
where where
@ -60,6 +61,64 @@ unhashGrantRecip resource = do
unhashGrantRecipE resource e = unhashGrantRecipE resource e =
ExceptT $ maybe (Left e) Right <$> unhashGrantRecip resource 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 parseGrant
:: Maybe PersonId :: Maybe PersonId
-> Grant URIMode -> Grant URIMode

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

@ -89,6 +89,7 @@ import Vervis.ActivityPub
import Vervis.Actor import Vervis.Actor
import Vervis.API import Vervis.API
import Vervis.Cloth import Vervis.Cloth
import Vervis.Data.Actor
import Vervis.Discussion import Vervis.Discussion
import Vervis.FedURI import Vervis.FedURI
import Vervis.Foundation import Vervis.Foundation
@ -96,6 +97,8 @@ import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
import Vervis.Model.Ticket import Vervis.Model.Ticket
import Vervis.Paginate import Vervis.Paginate
import Vervis.Persist.Actor
import Vervis.Recipient
import Vervis.Ticket import Vervis.Ticket
getClothR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler TypedContent getClothR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler TypedContent
@ -145,6 +148,7 @@ getClothR loomHash clothHash = do
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
hashPerson <- getEncodeKeyHashid hashPerson <- getEncodeKeyHashid
hashItem <- getEncodeKeyHashid hashItem <- getEncodeKeyHashid
hashActor <- getHashLocalActor
hLocal <- getsYesod siteInstanceHost hLocal <- getsYesod siteInstanceHost
repoHash <- encodeKeyHashid repoID repoHash <- encodeKeyHashid repoID
bundleHash <- encodeKeyHashid bundleID bundleHash <- encodeKeyHashid bundleID
@ -194,7 +198,7 @@ getClothR loomHash clothHash = do
, AP.ticketResolved = , AP.ticketResolved =
let u (Left (actor, obiid)) = let u (Left (actor, obiid)) =
encodeRouteHome $ encodeRouteHome $
outboxItemRoute actor $ hashItem obiid activityRoute (hashActor actor) (hashItem obiid)
u (Right (i, ro)) = u (Right (i, ro)) =
ObjURI (instanceHost i) (remoteObjectIdent ro) ObjURI (instanceHost i) (remoteObjectIdent ro)
in (,Nothing) . Just . u <$> resolve in (,Nothing) . Just . u <$> resolve

20
src/Vervis/Handler/Person.hs
View file

@ -73,6 +73,7 @@ import Vervis.Federation.Auth
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
import Vervis.Persist.Actor
import Vervis.Recipient import Vervis.Recipient
import Vervis.Secure import Vervis.Secure
import Vervis.Settings import Vervis.Settings
@ -135,21 +136,6 @@ parseAuthenticatedLocalActivityURI author maybeActivityURI = do
throwE "'actor' actor and 'id' actor mismatch" throwE "'actor' actor and 'id' actor mismatch"
return outboxItemID 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 insertActivityToInbox
:: MonadIO m :: MonadIO m
=> UTCTime -> ActorId -> OutboxItemId -> ReaderT SqlBackend m Bool => UTCTime -> ActorId -> OutboxItemId -> ReaderT SqlBackend m Bool
@ -292,8 +278,8 @@ postPersonOutboxR personHash = do
AP.CreateTicketTracker detail mlocal -> AP.CreateTicketTracker detail mlocal ->
createTicketTrackerC eperson actorDB summary audience detail mlocal mtarget createTicketTrackerC eperson actorDB summary audience detail mlocal mtarget
_ -> throwE "Unsupported Create 'object' type" _ -> throwE "Unsupported Create 'object' type"
AP.GrantActivity grant -> AP.InviteActivity invite ->
grantC eperson actorDB mcap summary audience grant inviteC eperson actorDB mcap summary audience invite
{- {-
AddActivity (AP.Add obj target) -> AddActivity (AP.Add obj target) ->
case obj of case obj of

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

@ -133,6 +133,7 @@ import Yesod.Persist.Local
import Vervis.ActivityPub import Vervis.ActivityPub
import Vervis.Actor import Vervis.Actor
import Vervis.API import Vervis.API
import Vervis.Data.Actor
import Vervis.Discussion import Vervis.Discussion
import Vervis.Federation import Vervis.Federation
import Vervis.FedURI import Vervis.FedURI
@ -144,6 +145,8 @@ import Vervis.Model.Ident
import Vervis.Model.Ticket import Vervis.Model.Ticket
import Vervis.Model.Workflow import Vervis.Model.Workflow
import Vervis.Paginate import Vervis.Paginate
import Vervis.Persist.Actor
import Vervis.Recipient
import Vervis.Settings import Vervis.Settings
import Vervis.Style import Vervis.Style
import Vervis.Ticket import Vervis.Ticket
@ -193,6 +196,7 @@ getTicketR deckHash ticketHash = do
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
hashPerson <- getEncodeKeyHashid hashPerson <- getEncodeKeyHashid
hashItem <- getEncodeKeyHashid hashItem <- getEncodeKeyHashid
hashActor <- getHashLocalActor
hLocal <- getsYesod siteInstanceHost hLocal <- getsYesod siteInstanceHost
let route mk = encodeRouteLocal $ mk deckHash ticketHash let route mk = encodeRouteLocal $ mk deckHash ticketHash
authorHost = authorHost =
@ -227,7 +231,7 @@ getTicketR deckHash ticketHash = do
, AP.ticketResolved = , AP.ticketResolved =
let u (Left (actor, obiid)) = let u (Left (actor, obiid)) =
encodeRouteHome $ encodeRouteHome $
outboxItemRoute actor $ hashItem obiid activityRoute (hashActor actor) (hashItem obiid)
u (Right (i, ro)) = u (Right (i, ro)) =
ObjURI (instanceHost i) (remoteObjectIdent ro) ObjURI (instanceHost i) (remoteObjectIdent ro)
in (,Nothing) . Just . u <$> resolve in (,Nothing) . Just . u <$> resolve

130
src/Vervis/Migration.hs
View file

@ -2556,6 +2556,136 @@ changes hLocal ctx =
, addFieldPrimRequired "InboxItem" defaultTime "received" , addFieldPrimRequired "InboxItem" defaultTime "received"
-- 453 -- 453
, addEntities model_453_collab_receive , 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 migrateDB

12
src/Vervis/Migration/Model.hs
View file

@ -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 :: [Entity SqlBackend]
model_453_collab_receive = $(schema "453_2022-09-01_collab_receive") 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")

68
src/Vervis/Persist/Actor.hs Normal file
View file

@ -0,0 +1,68 @@
{- This file is part of Vervis.
-
- Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
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"

28
src/Web/ActivityPub.hs
View file

@ -71,6 +71,7 @@ module Web.ActivityPub
, Create (..) , Create (..)
, Follow (..) , Follow (..)
, Grant (..) , Grant (..)
, Invite (..)
, OfferObject (..) , OfferObject (..)
, Offer (..) , Offer (..)
, Push (..) , Push (..)
@ -1507,13 +1508,32 @@ data Grant u = Grant
parseGrant :: UriMode u => Object -> Parser (Grant u) parseGrant :: UriMode u => Object -> Parser (Grant u)
parseGrant o = parseGrant o =
Grant Grant
<$> o .: "object" <$> o .:+ "object"
<*> o .: "context" <*> o .: "context"
<*> o .: "target" <*> o .: "target"
encodeGrant :: UriMode u => Grant u -> Series encodeGrant :: UriMode u => Grant u -> Series
encodeGrant (Grant obj context target) 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 <> "context" .= context
<> "target" .= target <> "target" .= target
@ -1629,6 +1649,7 @@ data SpecificActivity u
| CreateActivity (Create u) | CreateActivity (Create u)
| FollowActivity (Follow u) | FollowActivity (Follow u)
| GrantActivity (Grant u) | GrantActivity (Grant u)
| InviteActivity (Invite u)
| OfferActivity (Offer u) | OfferActivity (Offer u)
| PushActivity (Push u) | PushActivity (Push u)
| RejectActivity (Reject u) | RejectActivity (Reject u)
@ -1666,6 +1687,7 @@ instance ActivityPub Activity where
"Create" -> CreateActivity <$> parseCreate o a actor "Create" -> CreateActivity <$> parseCreate o a actor
"Follow" -> FollowActivity <$> parseFollow o "Follow" -> FollowActivity <$> parseFollow o
"Grant" -> GrantActivity <$> parseGrant o "Grant" -> GrantActivity <$> parseGrant o
"Invite" -> InviteActivity <$> parseInvite o
"Offer" -> OfferActivity <$> parseOffer o a actor "Offer" -> OfferActivity <$> parseOffer o a actor
"Push" -> PushActivity <$> parsePush a o "Push" -> PushActivity <$> parsePush a o
"Reject" -> RejectActivity <$> parseReject o "Reject" -> RejectActivity <$> parseReject o
@ -1691,6 +1713,7 @@ instance ActivityPub Activity where
activityType (CreateActivity _) = "Create" activityType (CreateActivity _) = "Create"
activityType (FollowActivity _) = "Follow" activityType (FollowActivity _) = "Follow"
activityType (GrantActivity _) = "Grant" activityType (GrantActivity _) = "Grant"
activityType (InviteActivity _) = "Invite"
activityType (OfferActivity _) = "Offer" activityType (OfferActivity _) = "Offer"
activityType (PushActivity _) = "Push" activityType (PushActivity _) = "Push"
activityType (RejectActivity _) = "Reject" activityType (RejectActivity _) = "Reject"
@ -1702,6 +1725,7 @@ instance ActivityPub Activity where
encodeSpecific _ _ (CreateActivity a) = encodeCreate a encodeSpecific _ _ (CreateActivity a) = encodeCreate a
encodeSpecific _ _ (FollowActivity a) = encodeFollow a encodeSpecific _ _ (FollowActivity a) = encodeFollow a
encodeSpecific _ _ (GrantActivity a) = encodeGrant a encodeSpecific _ _ (GrantActivity a) = encodeGrant a
encodeSpecific _ _ (InviteActivity a) = encodeInvite a
encodeSpecific h u (OfferActivity a) = encodeOffer h u a encodeSpecific h u (OfferActivity a) = encodeOffer h u a
encodeSpecific h _ (PushActivity a) = encodePush h a encodeSpecific h _ (PushActivity a) = encodePush h a
encodeSpecific _ _ (RejectActivity a) = encodeReject a encodeSpecific _ _ (RejectActivity a) = encodeReject a

104
th/models
View file

@ -587,6 +587,28 @@ RemoteMessage
Collab 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 -------------------------------- -------------------------------- Collab topic --------------------------------
-- Removed for now, until I figure out whether/how to federate custom roles -- Removed for now, until I figure out whether/how to federate custom roles
@ -596,74 +618,30 @@ Collab
-- --
-- UniqueCollabRoleLocal collab -- UniqueCollabRoleLocal collab
CollabTopicLocal CollabTopicRepo
collab CollabId collab CollabId
UniqueCollabTopicLocal collab
CollabTopicLocalRepo
collab CollabTopicLocalId
repo RepoId repo RepoId
UniqueCollabTopicLocalRepo collab UniqueCollabTopicRepo collab
CollabTopicLocalDeck CollabTopicDeck
collab CollabTopicLocalId collab CollabId
deck DeckId deck DeckId
UniqueCollabTopicLocalDeck collab UniqueCollabTopicDeck collab
CollabTopicLocalLoom CollabTopicLoom
collab CollabTopicLocalId collab CollabId
loom LoomId loom LoomId
UniqueCollabTopicLocalLoom collab UniqueCollabTopicLoom collab
CollabTopicLocalReceive CollabEnable
collab CollabTopicLocalId
item InboxItemId
UniqueCollabTopicLocalReceiveCollab collab
UniqueCollabTopicLocalReceiveItem item
CollabTopicLocalAccept
collab CollabTopicLocalId
accept OutboxItemId
UniqueCollabTopicLocalAcceptCollab collab
UniqueCollabTopicLocalAcceptAccept accept
CollabTopicRemote
collab CollabId collab CollabId
topic RemoteObjectId grant OutboxItemId
actor RemoteActorId
role LocalURI Maybe
UniqueCollabTopicRemote collab UniqueCollabEnable collab
UniqueCollabEnableGrant grant
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
-------------------------------- Collab recipient ---------------------------- -------------------------------- Collab recipient ----------------------------
@ -673,13 +651,6 @@ CollabRecipLocal
UniqueCollabRecipLocal collab UniqueCollabRecipLocal collab
CollabRecipLocalReceive
collab CollabRecipLocalId
item InboxItemId
UniqueCollabRecipLocalReceiveCollab collab
UniqueCollabRecipLocalReceiveItem item
CollabRecipLocalAccept CollabRecipLocalAccept
collab CollabRecipLocalId collab CollabRecipLocalId
accept OutboxItemId accept OutboxItemId
@ -700,13 +671,6 @@ CollabRecipRemoteAccept
UniqueCollabRecipRemoteAcceptCollab collab UniqueCollabRecipRemoteAcceptCollab collab
UniqueCollabRecipRemoteAcceptAccept accept UniqueCollabRecipRemoteAcceptAccept accept
-------------------------------- Collab reason -------------------------------
CollabFulfillsLocalTopicCreation
collab CollabId
UniqueCollabFulfillsLocalTopicCreation collab
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
------------------------------------------------------------------------------ ------------------------------------------------------------------------------

5
vervis.cabal
View file

@ -137,8 +137,10 @@ library
Vervis.Colour Vervis.Colour
Vervis.Content Vervis.Content
Vervis.Darcs Vervis.Darcs
Vervis.Data.Actor Vervis.Data.Actor
Vervis.Data.Collab Vervis.Data.Collab
Vervis.Delivery Vervis.Delivery
Vervis.Discussion Vervis.Discussion
Vervis.Federation Vervis.Federation
@ -203,6 +205,9 @@ library
Vervis.Paginate Vervis.Paginate
Vervis.Palette Vervis.Palette
Vervis.Path Vervis.Path
Vervis.Persist.Actor
Vervis.Query Vervis.Query
Vervis.Readme Vervis.Readme
Vervis.Recipient Vervis.Recipient