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.
-
- 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.
-
@ -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

322
src/Vervis/API.hs
View file

@ -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,30 +181,34 @@ 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"
lift $ getValBy $ UniqueCollabFulfillsInviteRemoteInvite remoteActivityID
for maybeSender $ \ (CollabFulfillsInviteRemote collab actorID _) -> do
actor <- lift $ getJust actorID
lift $
(collab,) . Right . (,remoteActorFollowers actor) <$>
getRemoteActorURI' actor
getRemoteActorURI actor
maybeCollabMore <- for maybeCollab $ \ (collabID, collabSender) -> do
-- Verify that Accept sender is the Collab recipient
recip <-
@ -216,31 +221,26 @@ acceptC (Entity pidUser personUser) senderActor summary audience accept = do
recipID <-
case recip of
Left (Entity crlid crl)
| collabRecipLocalPerson crl == pidUser -> return crlid
_ -> throwE "Accepting a Collab whose recipient is someone else"
| collabRecipLocalPerson crl == senderPersonID -> return crlid
_ -> throwE "Accepting an Invite whose recipient is someone else"
-- 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"
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_
(verifyResourceAddressed localRecips . snd)
(verifyRemoteAddressed remoteRecips . snd)
topicActor
bitraverse_
(verifySenderAddressed localRecips)
(verifySenderAddressed localRecips . fst)
(verifyRemoteAddressed remoteRecips . fst)
collabSender
return (collabID, recipID, topic, collabSender)
-- Record the Accept on the Collab
acceptID <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now
for_ maybeCollabMore $ \ (_, recipID, _, _) -> do
maybeAccept <- lift $ insertUnique $ CollabRecipLocalAccept recipID acceptID
unless (isNothing maybeAccept) $ do
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
-- 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, approve the Collab and deliver a Grant
deliverHttpGrant <- for maybeCollabMore $ \ (collabID, _, resource, sender) -> do
-- 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
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"
case sender of
Left (_, (Entity actorID _)) ->
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
-- 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
maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
return $
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) ->
GrantResourceRepo $ collabTopicLocalRepoRepo r
GrantResourceRepo $ collabTopicRepoRepo r
(Nothing, Just d, Nothing) ->
GrantResourceDeck $ collabTopicLocalDeckDeck d
GrantResourceDeck $ collabTopicDeckDeck 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"
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
insert_ $ CollabTopicRepo collabID repoID
GrantResourceDeck (Entity deckID _) ->
insert_ $ CollabTopicLocalDeck topicID deckID
insert_ $ CollabTopicDeck collabID deckID
GrantResourceLoom (Entity loomID _) ->
insert_ $ CollabTopicLocalLoom topicID loomID
Right (remoteID, actorID, _) ->
insert_ $ CollabTopicRemote collabID remoteID actorID Nothing
insert_ $ CollabSenderLocal collabID grantID
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

173
src/Vervis/Access.hs
View file

@ -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) <$>
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 local topic"
(Nothing, Nothing, Nothing) -> error "Collab without topic"
(Just r, Nothing, Nothing) ->
return $ GrantResourceRepo $ collabTopicLocalRepoRepo r
return $ GrantResourceRepo $ collabTopicRepoRepo r
(Nothing, Just d, Nothing) ->
return $ GrantResourceDeck $ collabTopicLocalDeckDeck d
return $ GrantResourceDeck $ collabTopicDeckDeck d
(Nothing, Nothing, Just l) ->
return $ GrantResourceLoom $ collabTopicLocalLoomLoom 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 ()

110
src/Vervis/ActivityPub.hs
View file

@ -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

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

@ -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

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

@ -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

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

@ -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

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

@ -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

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

@ -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

130
src/Vervis/Migration.hs
View file

@ -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

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 = $(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 (..)
, 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

104
th/models
View file

@ -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
------------------------------------------------------------------------------
------------------------------------------------------------------------------

5
vervis.cabal
View file

@ -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