Port deckAdd to be a reusable componentAdd
This commit is contained in:
Pere Lev
parent
4b6e95b2e8
commit
38ce72996c
2 changed files with 216 additions and 176 deletions
|
|
@ -26,6 +26,7 @@ module Vervis.Actor.Common
|
|||
, topicJoin
|
||||
, topicCreateMe
|
||||
, componentGrant
|
||||
, componentAdd
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -1887,3 +1888,217 @@ componentGrant grabResource topicComponent now recipKey (Verse authorIdMsig body
|
|||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
-- Meaning: An actor is adding some object to some target
|
||||
-- Behavior:
|
||||
-- * If the object is me:
|
||||
-- * Verify that the object is me
|
||||
-- * Verify the target is some project's components collection URI
|
||||
-- * Verify the Add is authorized
|
||||
-- * For all the Stem records I have for this project:
|
||||
-- * Verify I'm not yet a member of the project
|
||||
-- * Verify I haven't already Accepted an our-Add to this project
|
||||
-- * Verify I haven't already seen an them-Invite-and-Project-accept for
|
||||
-- this project
|
||||
-- * Insert the Add to my inbox
|
||||
-- * Create a Stem record in DB
|
||||
-- * Forward the Add activity to my followers
|
||||
-- * Send an Accept on the Add:
|
||||
-- * To:
|
||||
-- * The author of the Add
|
||||
-- * The project
|
||||
-- * CC:
|
||||
-- * Author's followers
|
||||
-- * Project's followers
|
||||
-- * My followers
|
||||
componentAdd
|
||||
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
||||
=> (topic -> KomponentId)
|
||||
-> (forall f. f topic -> ComponentBy f)
|
||||
-> UTCTime
|
||||
-> Key topic
|
||||
-> Verse
|
||||
-> AP.Add URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
componentAdd grabKomponent toComponent now meID (Verse authorIdMsig body) add = do
|
||||
|
||||
let meComponent = toComponent meID
|
||||
meResource = componentResource meComponent
|
||||
meActor = resourceToActor meResource
|
||||
|
||||
-- Check capability
|
||||
capability <- do
|
||||
|
||||
-- Verify that a capability is provided
|
||||
uCap <- do
|
||||
let muCap = AP.activityCapability $ actbActivity body
|
||||
fromMaybeE muCap "No capability provided"
|
||||
|
||||
-- Verify the capability URI is one of:
|
||||
-- * Outbox item URI of a local actor, i.e. a local activity
|
||||
-- * A remote URI
|
||||
cap <- nameExceptT "Add capability" $ parseActivityURI' uCap
|
||||
|
||||
-- Verify the capability is local
|
||||
case cap of
|
||||
Left (actorByKey, _, outboxItemID) ->
|
||||
return (actorByKey, outboxItemID)
|
||||
_ -> throwE "Capability is remote i.e. definitely not by me"
|
||||
|
||||
-- Check input
|
||||
projectComps <- do
|
||||
let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
|
||||
(component, projectComps, role) <- parseAdd author add
|
||||
unless (component == Left meActor) $
|
||||
throwE "Add object isn't me"
|
||||
unless (role == AP.RoleAdmin) $
|
||||
throwE "Add role isn't admin"
|
||||
case projectComps of
|
||||
Left (ATProjectComponents j) -> return $ Left j
|
||||
Right u -> return $ Right u
|
||||
_ -> throwE "I'm being added somewhere invalid"
|
||||
|
||||
-- If project is local, find it in our DB
|
||||
-- If project is remote, HTTP GET it and store in our DB (if it's already
|
||||
-- there, no need for HTTP)
|
||||
--
|
||||
-- NOTE: This is a blocking HTTP GET done right here in the handler,
|
||||
-- which is NOT a good idea. Ideally, it would be done async, and the
|
||||
-- handler result would be sent later in a separate (e.g. Accept) activity.
|
||||
-- But for the PoC level, the current situation will hopefully do.
|
||||
projectDB <-
|
||||
bitraverse
|
||||
(withDBExcept . flip getEntityE "Project not found in DB")
|
||||
(\ u@(ObjURI h luComps) -> do
|
||||
manager <- asksEnv envHttpManager
|
||||
collection <-
|
||||
ExceptT $ first T.pack <$>
|
||||
AP.fetchAPID
|
||||
manager
|
||||
(AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI)
|
||||
h
|
||||
luComps
|
||||
luProject <- fromMaybeE (AP.collectionContext collection) "Collection has no context"
|
||||
project <-
|
||||
ExceptT $ first T.pack <$>
|
||||
AP.fetchAPID manager (AP.actorId . AP.actorLocal . AP.projectActor) h luProject
|
||||
unless (AP.projectComponents project == luComps) $
|
||||
throwE "The collection isn't the project's components collection"
|
||||
|
||||
instanceID <-
|
||||
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
|
||||
result <-
|
||||
ExceptT $ first (T.pack . displayException) <$>
|
||||
fetchRemoteActor' instanceID h luProject
|
||||
case result of
|
||||
Left Nothing -> throwE "Target @id mismatch"
|
||||
Left (Just err) -> throwE $ T.pack $ displayException err
|
||||
Right Nothing -> throwE "Target isn't an actor"
|
||||
Right (Just actor) -> do
|
||||
unless (remoteActorType (entityVal actor) == AP.ActorTypeProject) $
|
||||
throwE "Remote project type isn't Project"
|
||||
return $ entityKey actor
|
||||
)
|
||||
projectComps
|
||||
|
||||
meHash <- encodeKeyHashid meID
|
||||
let meComponentHash = toComponent meHash
|
||||
meResourceHash = componentResource meComponentHash
|
||||
meActorHash = resourceToActor meResourceHash
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
komponentID <- lift $ grabKomponent <$> getJust meID
|
||||
Komponent resourceID <- lift $ getJust komponentID
|
||||
Resource meActorID <- lift $ getJust resourceID
|
||||
actor <- lift $ getJust meActorID
|
||||
|
||||
-- Find existing Stem records I have for this project
|
||||
-- Make sure none are enabled / in Add-Accept mode / in Invite-Accept
|
||||
-- mode
|
||||
checkExistingStems komponentID projectDB
|
||||
|
||||
-- Verify the specified capability gives relevant access
|
||||
verifyCapability' capability authorIdMsig meResource AP.RoleAdmin
|
||||
|
||||
-- Insert the Add to my inbox
|
||||
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actor) False
|
||||
lift $ for mractid $ \ (inboxItemID, addDB) -> do
|
||||
|
||||
-- Create a Stem record in DB
|
||||
acceptID <- insertEmptyOutboxItem' (actorOutbox actor) now
|
||||
insertStem komponentID projectDB addDB acceptID
|
||||
|
||||
-- Prepare forwarding Add to my followers
|
||||
let sieve = makeRecipientSet [] [localActorFollowers meActorHash]
|
||||
|
||||
-- Prepare an Accept activity and insert to my outbox
|
||||
accept@(actionAccept, _, _, _) <- prepareAccept projectDB
|
||||
_luAccept <- updateOutboxItem' meActor acceptID actionAccept
|
||||
|
||||
return (meActorID, sieve, acceptID, accept, inboxItemID)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (actorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do
|
||||
forwardActivity authorIdMsig body meActor actorID sieve
|
||||
lift $ sendActivity
|
||||
meActor actorID localRecipsAccept
|
||||
remoteRecipsAccept fwdHostsAccept acceptID actionAccept
|
||||
doneDB inboxItemID "Recorded and forwarded the Add, sent an Accept"
|
||||
|
||||
where
|
||||
|
||||
insertStem komponentID projectDB addDB acceptID = do
|
||||
stemID <- insert $ Stem AP.RoleAdmin komponentID
|
||||
case projectDB of
|
||||
Left (Entity projectID _) ->
|
||||
insert_ $ StemProjectLocal stemID projectID
|
||||
Right remoteActorID ->
|
||||
insert_ $ StemProjectRemote stemID remoteActorID
|
||||
insert_ $ StemOriginAdd stemID
|
||||
case addDB of
|
||||
Left (_, _, addID) ->
|
||||
insert_ $ StemComponentGestureLocal stemID addID
|
||||
Right (author, _, addID) ->
|
||||
insert_ $ StemComponentGestureRemote stemID (remoteAuthorId author) addID
|
||||
insert_ $ StemComponentAccept stemID acceptID
|
||||
|
||||
prepareAccept projectDB = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
audAdder <- makeAudSenderWithFollowers authorIdMsig
|
||||
audProject <-
|
||||
case projectDB of
|
||||
Left (Entity j _) -> do
|
||||
jh <- encodeKeyHashid j
|
||||
return $
|
||||
AudLocal
|
||||
[LocalActorProject jh]
|
||||
[LocalStageProjectFollowers jh]
|
||||
Right remoteActorID -> do
|
||||
ra <- getJust remoteActorID
|
||||
ObjURI h lu <- getRemoteActorURI ra
|
||||
return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
|
||||
audComponent <-
|
||||
AudLocal [] . pure . localActorFollowers <$>
|
||||
hashLocalActor (resourceToActor $ componentResource $ toComponent meID)
|
||||
uAdd <- lift $ getActivityURI authorIdMsig
|
||||
|
||||
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audAdder, audProject, audComponent]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
action = AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = [uAdd]
|
||||
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||
{ AP.acceptObject = uAdd
|
||||
, AP.acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
|
|
|||
|
|
@ -105,182 +105,7 @@ deckAdd
|
|||
-> Verse
|
||||
-> AP.Add URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
deckAdd now deckID (Verse authorIdMsig body) add = do
|
||||
|
||||
-- Check capability
|
||||
capability <- do
|
||||
|
||||
-- Verify that a capability is provided
|
||||
uCap <- do
|
||||
let muCap = AP.activityCapability $ actbActivity body
|
||||
fromMaybeE muCap "No capability provided"
|
||||
|
||||
-- Verify the capability URI is one of:
|
||||
-- * Outbox item URI of a local actor, i.e. a local activity
|
||||
-- * A remote URI
|
||||
cap <- nameExceptT "Invite capability" $ parseActivityURI' uCap
|
||||
|
||||
-- Verify the capability is local
|
||||
case cap of
|
||||
Left (actorByKey, _, outboxItemID) ->
|
||||
return (actorByKey, outboxItemID)
|
||||
_ -> throwE "Capability is remote i.e. definitely not by me"
|
||||
|
||||
-- Check input
|
||||
projectComps <- do
|
||||
let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
|
||||
(component, projectComps, role) <- parseAdd author add
|
||||
unless (component == Left (LocalActorDeck deckID)) $
|
||||
throwE "Add object isn't me"
|
||||
unless (role == AP.RoleAdmin) $
|
||||
throwE "Add role isn't admin"
|
||||
case projectComps of
|
||||
Left (ATProjectComponents j) -> return $ Left j
|
||||
Right u -> return $ Right u
|
||||
_ -> throwE "I'm being added somewhere invalid"
|
||||
|
||||
-- If project is local, find it in our DB
|
||||
-- If project is remote, HTTP GET it and store in our DB (if it's already
|
||||
-- there, no need for HTTP)
|
||||
--
|
||||
-- NOTE: This is a blocking HTTP GET done right here in the handler,
|
||||
-- which is NOT a good idea. Ideally, it would be done async, and the
|
||||
-- handler result would be sent later in a separate (e.g. Accept) activity.
|
||||
-- But for the PoC level, the current situation will hopefully do.
|
||||
projectDB <-
|
||||
bitraverse
|
||||
(withDBExcept . flip getEntityE "Project not found in DB")
|
||||
(\ u@(ObjURI h luComps) -> do
|
||||
manager <- asksEnv envHttpManager
|
||||
collection <-
|
||||
ExceptT $ first T.pack <$>
|
||||
AP.fetchAPID
|
||||
manager
|
||||
(AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI)
|
||||
h
|
||||
luComps
|
||||
luProject <- fromMaybeE (AP.collectionContext collection) "Collection has no context"
|
||||
project <-
|
||||
ExceptT $ first T.pack <$>
|
||||
AP.fetchAPID manager (AP.actorId . AP.actorLocal . AP.projectActor) h luProject
|
||||
unless (AP.projectComponents project == luComps) $
|
||||
throwE "The collection isn't the project's components collection"
|
||||
|
||||
instanceID <-
|
||||
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
|
||||
result <-
|
||||
ExceptT $ first (T.pack . displayException) <$>
|
||||
fetchRemoteActor' instanceID h luProject
|
||||
case result of
|
||||
Left Nothing -> throwE "Target @id mismatch"
|
||||
Left (Just err) -> throwE $ T.pack $ displayException err
|
||||
Right Nothing -> throwE "Target isn't an actor"
|
||||
Right (Just actor) -> do
|
||||
unless (remoteActorType (entityVal actor) == AP.ActorTypeProject) $
|
||||
throwE "Remote project type isn't Project"
|
||||
return $ entityKey actor
|
||||
)
|
||||
projectComps
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(deck, actor) <- lift $ do
|
||||
d <- getJust deckID
|
||||
(d,) <$> getJust (deckActor d)
|
||||
|
||||
-- Find existing Stem records I have for this project
|
||||
-- Make sure none are enabled / in Add-Accept mode / in Invite-Accept
|
||||
-- mode
|
||||
checkExistingStems (deckKomponent deck) projectDB
|
||||
|
||||
-- Verify the specified capability gives relevant access
|
||||
verifyCapability'
|
||||
capability authorIdMsig (LocalResourceDeck deckID) AP.RoleAdmin
|
||||
|
||||
-- Insert the Add to my inbox
|
||||
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actor) False
|
||||
lift $ for mractid $ \ (inboxItemID, addDB) -> do
|
||||
|
||||
-- Create a Stem record in DB
|
||||
acceptID <- insertEmptyOutboxItem' (actorOutbox actor) now
|
||||
insertStem (deckKomponent deck) projectDB addDB acceptID
|
||||
|
||||
-- Prepare forwarding Add to my followers
|
||||
sieve <- do
|
||||
deckHash <- encodeKeyHashid deckID
|
||||
return $ makeRecipientSet [] [LocalStageDeckFollowers deckHash]
|
||||
|
||||
-- Prepare an Accept activity and insert to my outbox
|
||||
accept@(actionAccept, _, _, _) <- prepareAccept projectDB
|
||||
_luAccept <- updateOutboxItem' (LocalActorDeck deckID) acceptID actionAccept
|
||||
|
||||
return (deckActor deck, sieve, acceptID, accept, inboxItemID)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (actorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do
|
||||
forwardActivity
|
||||
authorIdMsig body (LocalActorDeck deckID) actorID sieve
|
||||
lift $ sendActivity
|
||||
(LocalActorDeck deckID) actorID localRecipsAccept
|
||||
remoteRecipsAccept fwdHostsAccept acceptID actionAccept
|
||||
doneDB inboxItemID "Recorded and forwarded the Add, sent an Accept"
|
||||
|
||||
where
|
||||
|
||||
insertStem komponentID projectDB addDB acceptID = do
|
||||
stemID <- insert $ Stem AP.RoleAdmin komponentID
|
||||
case projectDB of
|
||||
Left (Entity projectID _) ->
|
||||
insert_ $ StemProjectLocal stemID projectID
|
||||
Right remoteActorID ->
|
||||
insert_ $ StemProjectRemote stemID remoteActorID
|
||||
insert_ $ StemOriginAdd stemID
|
||||
case addDB of
|
||||
Left (_, _, addID) ->
|
||||
insert_ $ StemComponentGestureLocal stemID addID
|
||||
Right (author, _, addID) ->
|
||||
insert_ $ StemComponentGestureRemote stemID (remoteAuthorId author) addID
|
||||
insert_ $ StemComponentAccept stemID acceptID
|
||||
|
||||
prepareAccept projectDB = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
audAdder <- makeAudSenderWithFollowers authorIdMsig
|
||||
audProject <-
|
||||
case projectDB of
|
||||
Left (Entity j _) -> do
|
||||
jh <- encodeKeyHashid j
|
||||
return $
|
||||
AudLocal
|
||||
[LocalActorProject jh]
|
||||
[LocalStageProjectFollowers jh]
|
||||
Right remoteActorID -> do
|
||||
ra <- getJust remoteActorID
|
||||
ObjURI h lu <- getRemoteActorURI ra
|
||||
return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
|
||||
audComponent <-
|
||||
AudLocal [] . pure . LocalStageDeckFollowers <$>
|
||||
encodeKeyHashid deckID
|
||||
uAdd <- lift $ getActivityURI authorIdMsig
|
||||
|
||||
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audAdder, audProject, audComponent]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
action = AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = [uAdd]
|
||||
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||
{ AP.acceptObject = uAdd
|
||||
, AP.acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
deckAdd = componentAdd deckKomponent ComponentDeck
|
||||
|
||||
-- Meaning: Someone has created a ticket tracker with my ID URI
|
||||
-- Behavior:
|
||||
|
|
|
|||
Loading…
Reference in a new issue