naskya/vervis
1
0
Fork 0
mirror of https://code.naskya.net/repos/ndqEd synced 2025-03-20 15:14:54 +09:00
Code 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

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

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

183
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) <$>
case (maybeRepo, maybeDeck, maybeLoom) of
(Nothing, Nothing, Nothing) -> error "Collab without local topic"
(Just r, Nothing, Nothing) ->
return $ GrantResourceRepo $ collabTopicLocalRepoRepo r
(Nothing, Just d, Nothing) ->
return $ GrantResourceDeck $ collabTopicLocalDeckDeck d
(Nothing, Nothing, Just l) ->
return $ GrantResourceLoom $ collabTopicLocalLoomLoom l
_ -> error "Collab with multiple topics"
topic <- lift $ do
maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID
maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID
maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID
case (maybeRepo, maybeDeck, maybeLoom) of
(Nothing, Nothing, Nothing) -> error "Collab without topic"
(Just r, Nothing, Nothing) ->
return $ GrantResourceRepo $ collabTopicRepoRepo r
(Nothing, Just d, Nothing) ->
return $ GrantResourceDeck $ collabTopicDeckDeck d
(Nothing, Nothing, Just l) ->
return $ GrantResourceLoom $ collabTopicLoomLoom l
_ -> error "Collab with multiple topics"
-- Verify that topic is indeed the sender of the Grant
unless (grantResourceLocalActor topic == capActor) $
error "Grant sender isn't the topic"
-- Verify the topic matches the resource specified
unless (topic == resource) $
throwE "Capability topic is some other local resource"
-- Verify that the resource has accepted the grant, making it valid
maybeAccept <- lift $ getBy $ UniqueCollabTopicLocalAcceptCollab topicLocalID
_ <- fromMaybeE maybeAccept "Collab not approved by the resource"
-- Since there are currently no roles, and grants allow only the "Admin"
-- role that supports every operation, we don't need to check role access
return ()
verifyCapabilityRemote
:: Either (LocalActorBy KeyHashid, OutboxItemId) FedURI
-> PersonId
-> RemoteObjectId
-> ExceptT Text (ReaderT SqlBackend Handler) ()
verifyCapabilityRemote capability personID resourceID = do
-- Find the activity itself by URI in the DB
grant <- do
mact <- getActivity capability
fromMaybeE mact "Capability activity not known to me"
-- Find the Collab record for that activity
cid <-
case grant of
Left (_actor, obiid) -> do
mcsl <- lift $ getValBy $ UniqueCollabSenderLocalActivity obiid
collabSenderLocalCollab <$>
fromMaybeE mcsl "Capability is a local activity but no matching capability"
Right ractid -> do
mcsr <- lift $ getValBy $ UniqueCollabSenderRemoteActivity ractid
collabSenderRemoteCollab <$>
fromMaybeE mcsr "Capability is a known remote activity but no matching capability"
-- Find the recipient of that Collab
recipID <- do
mcrl <- lift $ getValBy $ UniqueCollabRecipLocal cid
crl <- fromMaybeE mcrl "No local recip for capability"
mcrr <- lift $ getBy $ UniqueCollabRecipRemote cid
for_ mcrr $ \ _ -> error "Both local & remote recip for capability!"
return $ collabRecipLocalPerson crl
-- Verify the recipient is the expected one
unless (recipID == personID) $
throwE "Collab recipient is some other Person"
-- Verify the topic isn't local
maybeLocalTopic <- lift $ getBy $ UniqueCollabTopicLocal cid
verifyNothingE maybeLocalTopic "Collab is for some other, local topic"
-- Find the remote topic, on which this Collab gives access
(topicRemoteID, topicObjectID) <- do
maybeRemote <- lift $ getBy $ UniqueCollabTopicRemote cid
case maybeRemote of
Nothing -> error "Collab without topic"
Just (Entity remoteID remote) ->
return (remoteID, collabTopicRemoteTopic remote)
-- Verify the topic matches the resource specified
unless (topicObjectID == resourceID) $
throwE "Capability topic is some other remote resource"
-- Verify that the resource has accepted the grant, making it valid
maybeAccept <- lift $ getBy $ UniqueCollabTopicRemoteAcceptCollab topicRemoteID
_ <- fromMaybeE maybeAccept "Collab not approved by the resource"
-- Since there are currently no roles, and grants allow only the "Admin"
-- role that supports every operation, we don't need to check role access
return ()

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