mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-27 15:44:51 +09:00
C2S: Implement acceptC, allowing people to accept Grants given to them
This commit is contained in:
fr33domlover
parent
e8ed2d5f24
commit
b7eb7a17d2
7 changed files with 413 additions and 57 deletions
|
|
@ -17,7 +17,8 @@
|
|||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
||||
module Vervis.API
|
||||
( addBundleC
|
||||
( acceptC
|
||||
, addBundleC
|
||||
, applyC
|
||||
, noteC
|
||||
, createNoteC
|
||||
|
|
@ -135,6 +136,318 @@ import Vervis.Query
|
|||
import Vervis.Ticket
|
||||
import Vervis.WorkItem
|
||||
|
||||
verifyResourceAddressed
|
||||
:: (MonadSite m, YesodHashids (SiteEnv m))
|
||||
=> RecipientRoutes -> GrantResourceBy Key -> ExceptT Text m ()
|
||||
verifyResourceAddressed localRecips resource = do
|
||||
resourceHash <- hashGrantResource resource
|
||||
fromMaybeE (verify resourceHash) "Local resource not addressed"
|
||||
where
|
||||
verify (GrantResourceRepo r) = do
|
||||
routes <- lookup r $ recipRepos localRecips
|
||||
guard $ routeRepo routes
|
||||
verify (GrantResourceDeck d) = do
|
||||
routes <- lookup d $ recipDecks localRecips
|
||||
guard $ routeDeck $ familyDeck routes
|
||||
verify (GrantResourceLoom l) = do
|
||||
routes <- lookup l $ recipLooms localRecips
|
||||
guard $ routeLoom $ familyLoom routes
|
||||
|
||||
verifyRemoteAddressed
|
||||
:: Monad m => [(Host, NonEmpty LocalURI)] -> FedURI -> ExceptT Text m ()
|
||||
verifyRemoteAddressed remoteRecips u =
|
||||
fromMaybeE (verify u) "Given remote entity not addressed"
|
||||
where
|
||||
verify (ObjURI h lu) = do
|
||||
lus <- lookup h remoteRecips
|
||||
guard $ lu `elem` lus
|
||||
|
||||
acceptC
|
||||
:: Entity Person
|
||||
-> Actor
|
||||
-> Maybe TextHtml
|
||||
-> Audience URIMode
|
||||
-> Accept URIMode
|
||||
-> ExceptT Text Handler OutboxItemId
|
||||
acceptC (Entity pidUser personUser) senderActor summary audience accept = do
|
||||
|
||||
-- Check input
|
||||
acceptee <- parseAccept accept
|
||||
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
|
||||
mrecips <- parseAudience audience
|
||||
recips <- fromMaybeE mrecips "Accept with no recipients"
|
||||
checkFederation $ paudRemoteActors recips
|
||||
return recips
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
senderHash <- encodeKeyHashid pidUser
|
||||
|
||||
(obiidAccept, deliverHttpAccept, deliverHttpTopicAccept) <- runDBExcept $ do
|
||||
|
||||
-- Find a Collab record for the accepted activity
|
||||
accepteeDB <- do
|
||||
a <- getActivity acceptee
|
||||
fromMaybeE a "Can't find acceptee in DB"
|
||||
(collabID, collabSender) <-
|
||||
case accepteeDB of
|
||||
Left (actor, itemID) -> do
|
||||
maybeSender <-
|
||||
lift $ getValBy $ UniqueCollabSenderLocalActivity itemID
|
||||
(,Left actor) . collabSenderLocalCollab <$>
|
||||
fromMaybeE maybeSender "No Collab for this local activity"
|
||||
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
|
||||
|
||||
-- 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"
|
||||
|
||||
-- Verify the Collab isn't already validated
|
||||
maybeValid <- lift $ getBy $ UniqueCollabTopicAcceptCollab collabID
|
||||
verifyNothingE maybeValid "Collab already Accepted by the topic"
|
||||
|
||||
-- Verify that Grant sender and resource are addressed by the Accept
|
||||
topicActor <- lift $ getCollabTopic collabID
|
||||
bitraverse_
|
||||
(verifyResourceAddressed localRecips)
|
||||
(verifyRemoteAddressed remoteRecips)
|
||||
topicActor
|
||||
bitraverse_
|
||||
(verifySenderAddressed localRecips)
|
||||
(verifyRemoteAddressed remoteRecips . fst)
|
||||
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"
|
||||
|
||||
-- Insert the Accept activity to author's outbox
|
||||
docAccept <- lift $ insertAcceptToOutbox senderHash now blinded acceptID
|
||||
|
||||
-- Deliver the Accept activity to local recipients, and schedule
|
||||
-- delivery for unavailable remote recipients
|
||||
remoteRecipsHttpAccept <- do
|
||||
topicHash <- bitraverse hashGrantResource pure topicActor
|
||||
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
|
||||
]
|
||||
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 -> localActorFollowers actor
|
||||
Right _ -> Nothing
|
||||
]
|
||||
sieve = makeRecipientSet sieveActors sieveStages
|
||||
moreRemoteRecips <-
|
||||
lift $ deliverLocal' True (LocalActorPerson senderHash) (personActor personUser) 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 resource ->
|
||||
Just <$> getGrantResource resource "getGrantResource"
|
||||
Right _ -> pure Nothing
|
||||
for_ topicActorLocal $ \ resource -> do
|
||||
let resourceActorID = grantResourceActor resource
|
||||
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 $ \ resource -> do
|
||||
|
||||
-- Approve the Collab in the DB
|
||||
resourceOutbox <-
|
||||
lift $ actorOutbox <$> getJust (grantResourceActor resource)
|
||||
enableID <- lift $ insertEmptyOutboxItem resourceOutbox now
|
||||
lift $ insert_ $ CollabTopicAccept collabID enableID
|
||||
|
||||
-- Insert the Enable to resource's outbox
|
||||
(docEnable, localRecipsEnable, remoteRecipsEnable, fwdHostsEnable) <-
|
||||
lift $ insertEnableToOutbox senderHash collabSender resource enableID
|
||||
|
||||
-- Deliver the Enable to local recipients, and schedule delivery
|
||||
-- for unavailable remote recipients
|
||||
remoteRecipsHttpEnable <- do
|
||||
moreRemoteRecips <- do
|
||||
resourceHash <- hashGrantResource $ bmap entityKey resource
|
||||
lift $ deliverLocal' True (grantResourceLocalActor resourceHash) (grantResourceActor resource) enableID localRecipsEnable
|
||||
checkFederation moreRemoteRecips
|
||||
lift $ deliverRemoteDB'' fwdHostsEnable enableID remoteRecipsEnable moreRemoteRecips
|
||||
|
||||
-- Return instructions for HTTP delivery to remote recipients
|
||||
return $ deliverRemoteHttp' fwdHostsEnable enableID docEnable remoteRecipsHttpEnable
|
||||
|
||||
-- Return instructions for HTTP delivery to remote recipients
|
||||
return
|
||||
( acceptID
|
||||
, deliverRemoteHttp' fwdHosts acceptID docAccept remoteRecipsHttpAccept
|
||||
, deliverHttpEnable
|
||||
)
|
||||
|
||||
-- Launch asynchronous HTTP delivery of the Grant activity
|
||||
lift $ do
|
||||
forkWorker "acceptC: async HTTP Accept delivery" deliverHttpAccept
|
||||
for_ deliverHttpTopicAccept $
|
||||
forkWorker "acceptC: async HTTP Topic Accept delivery"
|
||||
|
||||
return obiidAccept
|
||||
|
||||
where
|
||||
|
||||
parseAccept (Accept object mresult) = do
|
||||
verifyNothingE mresult "Accept must not contain 'result'"
|
||||
parseActivityURI "Accept object" object
|
||||
|
||||
getRemoteActorURI = getRemoteActorURI' <=< getJust
|
||||
|
||||
getRemoteActorURI' actor = do
|
||||
object <- getJust $ remoteActorIdent actor
|
||||
inztance <- getJust $ remoteObjectInstance object
|
||||
return $
|
||||
ObjURI
|
||||
(instanceHost inztance)
|
||||
(remoteObjectIdent object)
|
||||
|
||||
getCollabTopic collabID = do
|
||||
maybeLocal <- do
|
||||
maybeRepo <- getValBy $ UniqueCollabTopicLocalRepo collabID
|
||||
maybeDeck <- getValBy $ UniqueCollabTopicLocalDeck collabID
|
||||
maybeLoom <- getValBy $ UniqueCollabTopicLocalLoom collabID
|
||||
return $
|
||||
case (maybeRepo, maybeDeck, maybeLoom) of
|
||||
(Nothing, Nothing, Nothing) -> Nothing
|
||||
(Just r, Nothing, Nothing) ->
|
||||
Just $ GrantResourceRepo $ collabTopicLocalRepoRepo r
|
||||
(Nothing, Just d, Nothing) ->
|
||||
Just $ GrantResourceDeck $ collabTopicLocalDeckDeck d
|
||||
(Nothing, Nothing, Just l) ->
|
||||
Just $ GrantResourceLoom $ collabTopicLocalLoomLoom l
|
||||
_ -> error "Found Collab with multiple local topics"
|
||||
maybeRemote <- do
|
||||
mr <- getValBy $ UniqueCollabTopicRemote collabID
|
||||
traverse (getRemoteActorURI . collabTopicRemoteActor) mr
|
||||
requireEitherM
|
||||
maybeLocal
|
||||
maybeRemote
|
||||
"Found Collab without topic"
|
||||
"Found Collab with both local and remote topics"
|
||||
|
||||
verifySenderAddressed localRecips actor = do
|
||||
unless (actorIsAddressed localRecips actor) $
|
||||
throwE "Collab sender not addressed"
|
||||
|
||||
insertAcceptToOutbox senderHash now blinded acceptID = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
acceptHash <- encodeKeyHashid acceptID
|
||||
let doc = Doc hLocal Activity
|
||||
{ activityId =
|
||||
Just $ encodeRouteLocal $
|
||||
PersonOutboxItemR senderHash acceptHash
|
||||
, activityActor = encodeRouteLocal $ PersonR senderHash
|
||||
, activityCapability = Nothing
|
||||
, activitySummary = summary
|
||||
, activityAudience = blinded
|
||||
, activityFulfills = []
|
||||
, activitySpecific = AcceptActivity accept
|
||||
}
|
||||
update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return doc
|
||||
|
||||
grantResourceActor :: GrantResourceBy Entity -> ActorId
|
||||
grantResourceActor (GrantResourceRepo (Entity _ r)) = repoActor r
|
||||
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
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
|
||||
topicHash <-
|
||||
grantResourceLocalActor <$> hashGrantResource (bmap entityKey topic)
|
||||
enableHash <- encodeKeyHashid enableID
|
||||
|
||||
let audSender =
|
||||
case sender of
|
||||
Left actor -> AudLocal [actor] (maybeToList $ localActorFollowers actor)
|
||||
Right (ObjURI h lu, followers) ->
|
||||
AudRemote h [lu] (maybeToList followers)
|
||||
audRecip =
|
||||
AudLocal [LocalActorPerson recipHash] [LocalStagePersonFollowers recipHash]
|
||||
audTopic =
|
||||
AudLocal [] (maybeToList $ localActorFollowers topicHash)
|
||||
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audSender, audRecip, audTopic]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId = Just $ encodeRouteLocal $ outboxItemRoute topicHash enableHash
|
||||
, activityActor = encodeRouteLocal $ renderLocalActor topicHash
|
||||
, activityCapability = Nothing
|
||||
, activitySummary = Nothing
|
||||
, activityAudience = Audience recips [] [] [] [] []
|
||||
, activityFulfills = []
|
||||
, activitySpecific = AcceptActivity Accept
|
||||
{ acceptObject = acceptObject accept
|
||||
, acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
|
||||
update enableID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
addBundleC
|
||||
:: Entity Person
|
||||
-> Maybe TextHtml
|
||||
|
|
@ -1641,22 +1954,6 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
|
|||
parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
|
||||
parseGrantResource _ = Nothing
|
||||
|
||||
unhashGrantResourcePure ctx = f
|
||||
where
|
||||
f (GrantResourceRepo r) =
|
||||
GrantResourceRepo <$> decodeKeyHashidPure ctx r
|
||||
f (GrantResourceDeck d) =
|
||||
GrantResourceDeck <$> decodeKeyHashidPure ctx d
|
||||
f (GrantResourceLoom l) =
|
||||
GrantResourceLoom <$> decodeKeyHashidPure ctx l
|
||||
|
||||
unhashGrantResource resource = do
|
||||
ctx <- asksSite siteHashidsContext
|
||||
return $ unhashGrantResourcePure ctx resource
|
||||
|
||||
unhashGrantResourceE resource e =
|
||||
ExceptT $ maybe (Left e) Right <$> unhashGrantResource resource
|
||||
|
||||
parseGrantRecip (PersonR p) = Just $ GrantRecipPerson p
|
||||
parseGrantRecip _ = Nothing
|
||||
|
||||
|
|
@ -1760,29 +2057,8 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
|
|||
Right (Right Nothing) -> Left ResultNotActor
|
||||
Right (Right (Just actor)) -> Right $ Right (roid, luManager, actor)
|
||||
|
||||
getGrantResource (GrantResourceRepo k) e =
|
||||
GrantResourceRepo <$> getEntityE k e
|
||||
getGrantResource (GrantResourceDeck k) e =
|
||||
GrantResourceDeck <$> getEntityE k e
|
||||
getGrantResource (GrantResourceLoom k) e =
|
||||
GrantResourceLoom <$> getEntityE k e
|
||||
|
||||
getGrantRecip (GrantRecipPerson k) e = GrantRecipPerson <$> getEntityE k e
|
||||
|
||||
verifyResourceAddressed localRecips resource = do
|
||||
resourceHash <- hashGrantResource resource
|
||||
fromMaybeE (verify resourceHash) "Local resource not addressed"
|
||||
where
|
||||
verify (GrantResourceRepo r) = do
|
||||
routes <- lookup r $ recipRepos localRecips
|
||||
guard $ routeRepo routes
|
||||
verify (GrantResourceDeck d) = do
|
||||
routes <- lookup d $ recipDecks localRecips
|
||||
guard $ routeDeck $ familyDeck routes
|
||||
verify (GrantResourceLoom l) = do
|
||||
routes <- lookup l $ recipLooms localRecips
|
||||
guard $ routeLoom $ familyLoom routes
|
||||
|
||||
verifyRecipientAddressed localRecips recipient = do
|
||||
recipientHash <- hashGrantRecip recipient
|
||||
fromMaybeE (verify recipientHash) "Recipient not addressed"
|
||||
|
|
@ -1809,8 +2085,8 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
|
|||
insert_ $ CollabTopicLocalDeck collabID deckID
|
||||
GrantResourceLoom (Entity loomID _) ->
|
||||
insert_ $ CollabTopicLocalLoom collabID loomID
|
||||
Right (remoteID, _, _) ->
|
||||
insert_ $ CollabTopicRemote collabID remoteID Nothing
|
||||
Right (remoteID, actorID, _) ->
|
||||
insert_ $ CollabTopicRemote collabID remoteID actorID Nothing
|
||||
insert_ $ CollabSenderLocal collabID grantID
|
||||
case recipient of
|
||||
Left (GrantRecipPerson (Entity personID _)) ->
|
||||
|
|
@ -1818,13 +2094,6 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
|
|||
Right (remoteActorID, _) ->
|
||||
insert_ $ CollabRecipRemote collabID remoteActorID
|
||||
|
||||
hashGrantResource (GrantResourceRepo k) =
|
||||
GrantResourceRepo <$> encodeKeyHashid k
|
||||
hashGrantResource (GrantResourceDeck k) =
|
||||
GrantResourceDeck <$> encodeKeyHashid k
|
||||
hashGrantResource (GrantResourceLoom k) =
|
||||
GrantResourceLoom <$> encodeKeyHashid k
|
||||
|
||||
hashGrantRecip (GrantRecipPerson k) =
|
||||
GrantRecipPerson <$> encodeKeyHashid k
|
||||
|
||||
|
|
@ -1846,11 +2115,6 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do
|
|||
update grantID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return doc
|
||||
|
||||
verifyActorHasItem actorID itemID errorMessage = do
|
||||
inboxID <- lift $ actorInbox <$> getJust actorID
|
||||
maybeItem <- lift $ getBy $ UniqueInboxItemLocal inboxID itemID
|
||||
void $ fromMaybeE maybeItem errorMessage
|
||||
|
||||
offerTicketC
|
||||
:: Entity Person
|
||||
-> Maybe TextHtml
|
||||
|
|
|
|||
|
|
@ -62,7 +62,14 @@ module Vervis.Access
|
|||
, checkRepoAccess'
|
||||
, checkRepoAccess
|
||||
, checkProjectAccess
|
||||
|
||||
, GrantResourceBy (..)
|
||||
, unhashGrantResourcePure
|
||||
, unhashGrantResource
|
||||
, unhashGrantResourceE
|
||||
, hashGrantResource
|
||||
, getGrantResource
|
||||
|
||||
, verifyCapability
|
||||
, verifyCapabilityRemote
|
||||
)
|
||||
|
|
@ -79,9 +86,8 @@ import Data.Barbie
|
|||
import Data.Foldable
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Database.Persist.Class
|
||||
import Database.Persist.Sql (SqlBackend)
|
||||
import Database.Persist.Types (Entity (..))
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
import GHC.Generics
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
|
@ -249,6 +255,36 @@ data GrantResourceBy f
|
|||
|
||||
deriving instance AllBF Eq f GrantResourceBy => Eq (GrantResourceBy f)
|
||||
|
||||
unhashGrantResourcePure ctx = f
|
||||
where
|
||||
f (GrantResourceRepo r) =
|
||||
GrantResourceRepo <$> decodeKeyHashidPure ctx r
|
||||
f (GrantResourceDeck d) =
|
||||
GrantResourceDeck <$> decodeKeyHashidPure ctx d
|
||||
f (GrantResourceLoom l) =
|
||||
GrantResourceLoom <$> decodeKeyHashidPure ctx l
|
||||
|
||||
unhashGrantResource resource = do
|
||||
ctx <- asksSite siteHashidsContext
|
||||
return $ unhashGrantResourcePure ctx resource
|
||||
|
||||
unhashGrantResourceE resource e =
|
||||
ExceptT $ maybe (Left e) Right <$> unhashGrantResource resource
|
||||
|
||||
hashGrantResource (GrantResourceRepo k) =
|
||||
GrantResourceRepo <$> encodeKeyHashid k
|
||||
hashGrantResource (GrantResourceDeck k) =
|
||||
GrantResourceDeck <$> encodeKeyHashid k
|
||||
hashGrantResource (GrantResourceLoom k) =
|
||||
GrantResourceLoom <$> encodeKeyHashid k
|
||||
|
||||
getGrantResource (GrantResourceRepo k) e =
|
||||
GrantResourceRepo <$> getEntityE k e
|
||||
getGrantResource (GrantResourceDeck k) e =
|
||||
GrantResourceDeck <$> getEntityE k e
|
||||
getGrantResource (GrantResourceLoom k) e =
|
||||
GrantResourceLoom <$> getEntityE k e
|
||||
|
||||
verifyCapability
|
||||
:: Either (LocalActorBy KeyHashid, OutboxItemId) FedURI
|
||||
-> PersonId
|
||||
|
|
|
|||
|
|
@ -36,6 +36,8 @@ module Vervis.ActivityPub
|
|||
--, getOutboxActorEntity
|
||||
--, actorEntityPath
|
||||
, outboxItemRoute
|
||||
|
||||
, verifyActorHasItem
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -389,3 +391,8 @@ 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
|
||||
void $ fromMaybeE maybeItem errorMessage
|
||||
|
|
|
|||
|
|
@ -164,6 +164,8 @@ postPersonOutboxR personHash = do
|
|||
|
||||
handle eperson actorDB (AP.Activity _mid _actorAP mcap summary audience _fulfills specific) =
|
||||
case specific of
|
||||
AP.AcceptActivity accept ->
|
||||
acceptC eperson actorDB summary audience accept
|
||||
AP.CreateActivity (AP.Create obj mtarget) ->
|
||||
case obj of
|
||||
{-
|
||||
|
|
|
|||
|
|
@ -2432,6 +2432,8 @@ changes hLocal ctx =
|
|||
let doc = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
|
||||
insert $ OutboxItem426 (actor426Outbox actor) doc defaultTime
|
||||
insert_ $ CollabTopicAccept426 collabID itemID
|
||||
-- 427
|
||||
, addFieldRefRequiredEmpty "CollabTopicRemote" "actor" "RemoteActor"
|
||||
]
|
||||
|
||||
migrateDB
|
||||
|
|
|
|||
|
|
@ -31,6 +31,9 @@ module Vervis.Recipient
|
|||
, LocalStage
|
||||
, renderLocalStage
|
||||
|
||||
-- * Related actors and stages
|
||||
, localActorFollowers
|
||||
|
||||
-- * Converting between KeyHashid, Key, Identity and Entity
|
||||
, hashLocalActorPure
|
||||
, getHashLocalActor
|
||||
|
|
@ -54,6 +57,9 @@ module Vervis.Recipient
|
|||
, unhashLocalStageE
|
||||
, unhashLocalStage404
|
||||
|
||||
-- * Getting from DB
|
||||
, getLocalActorID
|
||||
|
||||
-- * Local recipient set
|
||||
-- ** Types
|
||||
, TicketRoutes (..)
|
||||
|
|
@ -69,9 +75,11 @@ module Vervis.Recipient
|
|||
-- ** Creating
|
||||
, makeRecipientSet
|
||||
, actorRecips
|
||||
-- * Filtering
|
||||
-- ** Filtering
|
||||
, localRecipSieve
|
||||
, localRecipSieve'
|
||||
-- ** Querying
|
||||
, actorIsAddressed
|
||||
|
||||
-- * Parsing audience from a received activity
|
||||
, ParsedAudience (..)
|
||||
|
|
@ -88,11 +96,11 @@ import Control.Applicative
|
|||
import Control.Monad
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.Reader
|
||||
import Data.Barbie
|
||||
import Data.Bifunctor
|
||||
import Data.Either
|
||||
import Data.Foldable
|
||||
import Data.Functor.Classes
|
||||
import Data.List ((\\))
|
||||
import Data.List.NonEmpty (NonEmpty, nonEmpty)
|
||||
import Data.Maybe
|
||||
|
|
@ -100,6 +108,8 @@ import Data.Semigroup
|
|||
import Data.Text (Text)
|
||||
import Data.These
|
||||
import Data.Traversable
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
import GHC.Generics
|
||||
import Web.Hashids
|
||||
import Yesod.Core
|
||||
|
|
@ -232,6 +242,13 @@ parseLocalRecipient :: Route App -> Maybe (Either LocalActor LocalStage)
|
|||
parseLocalRecipient r =
|
||||
Left <$> parseLocalActor r <|> Right <$> parseLocalStage r
|
||||
|
||||
localActorFollowers :: LocalActorBy f -> Maybe (LocalStageBy f)
|
||||
localActorFollowers (LocalActorPerson p) = Just $ LocalStagePersonFollowers p
|
||||
localActorFollowers (LocalActorGroup _) = Nothing
|
||||
localActorFollowers (LocalActorRepo r) = Just $ LocalStageRepoFollowers r
|
||||
localActorFollowers (LocalActorDeck d) = Just $ LocalStageDeckFollowers d
|
||||
localActorFollowers (LocalActorLoom l) = Just $ LocalStageLoomFollowers l
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Converting between KeyHashid, Key, Identity and Entity
|
||||
-------------------------------------------------------------------------------
|
||||
|
|
@ -392,6 +409,14 @@ unhashLocalStage404
|
|||
-> m (LocalStageBy Key)
|
||||
unhashLocalStage404 stage = maybe notFound return =<< unhashLocalStage stage
|
||||
|
||||
getLocalActorID
|
||||
:: MonadIO m => LocalActorBy Key -> ReaderT SqlBackend m (Maybe ActorId)
|
||||
getLocalActorID (LocalActorPerson p) = fmap personActor <$> get p
|
||||
getLocalActorID (LocalActorGroup g) = fmap groupActor <$> get g
|
||||
getLocalActorID (LocalActorRepo r) = fmap repoActor <$> get r
|
||||
getLocalActorID (LocalActorDeck d) = fmap deckActor <$> get d
|
||||
getLocalActorID (LocalActorLoom l) = fmap loomActor <$> get l
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Intermediate recipient types
|
||||
--
|
||||
|
|
@ -790,6 +815,25 @@ localRecipSieve' sieve allowPeople allowOthers routes = RecipientRoutes
|
|||
then Nothing
|
||||
else Just (lkhid, LoomFamilyRoutes loom cloths)
|
||||
|
||||
actorIsAddressed :: RecipientRoutes -> LocalActor -> Bool
|
||||
actorIsAddressed recips = isJust . verify
|
||||
where
|
||||
verify (LocalActorPerson p) = do
|
||||
routes <- lookup p $ recipPeople recips
|
||||
guard $ routePerson routes
|
||||
verify (LocalActorGroup g) = do
|
||||
routes <- lookup g $ recipGroups recips
|
||||
guard $ routeGroup routes
|
||||
verify (LocalActorRepo r) = do
|
||||
routes <- lookup r $ recipRepos recips
|
||||
guard $ routeRepo routes
|
||||
verify (LocalActorDeck d) = do
|
||||
routes <- lookup d $ recipDecks recips
|
||||
guard $ routeDeck $ familyDeck routes
|
||||
verify (LocalActorLoom l) = do
|
||||
routes <- lookup l $ recipLooms recips
|
||||
guard $ routeLoom $ familyLoom routes
|
||||
|
||||
data ParsedAudience u = ParsedAudience
|
||||
{ paudLocalRecips :: RecipientRoutes
|
||||
, paudRemoteActors :: [(Authority u, NonEmpty LocalURI)]
|
||||
|
|
|
|||
|
|
@ -623,6 +623,7 @@ CollabTopicAccept
|
|||
CollabTopicRemote
|
||||
collab CollabId
|
||||
topic RemoteObjectId
|
||||
actor RemoteActorId
|
||||
role LocalURI Maybe
|
||||
|
||||
UniqueCollabTopicRemote collab
|
||||
|
|
|
|||
Loading…
Reference in a new issue