S2S: Group: Add: Implement resource-active mode
This commit is contained in:
Pere Lev
parent
fe7ae763db
commit
f7d3d6d957
4 changed files with 271 additions and 0 deletions
|
|
@ -26,9 +26,12 @@ module Vervis.Actor
|
|||
( -- * Local actors
|
||||
LocalActorBy (..)
|
||||
, LocalResourceBy (..)
|
||||
, LocalResourceNonGroupBy (..)
|
||||
, LocalActor
|
||||
, actorToResource
|
||||
, resourceToActor
|
||||
, resourceToNG
|
||||
, resourceFromNG
|
||||
|
||||
-- * Converting between KeyHashid, Key, Identity and Entity
|
||||
--
|
||||
|
|
@ -177,6 +180,15 @@ data LocalResourceBy f
|
|||
|
||||
deriving instance AllBF Eq f LocalResourceBy => Eq (LocalResourceBy f)
|
||||
|
||||
data LocalResourceNonGroupBy f
|
||||
= LocalResourceRepo' (f Repo)
|
||||
| LocalResourceDeck' (f Deck)
|
||||
| LocalResourceLoom' (f Loom)
|
||||
| LocalResourceProject' (f Project)
|
||||
deriving (Generic, FunctorB, ConstraintsB)
|
||||
|
||||
deriving instance AllBF Eq f LocalResourceNonGroupBy => Eq (LocalResourceNonGroupBy f)
|
||||
|
||||
type LocalActor = LocalActorBy KeyHashid
|
||||
|
||||
actorToResource = \case
|
||||
|
|
@ -194,6 +206,19 @@ resourceToActor = \case
|
|||
LocalResourceLoom l -> LocalActorLoom l
|
||||
LocalResourceProject j -> LocalActorProject j
|
||||
|
||||
resourceToNG = \case
|
||||
LocalResourceGroup _ -> Nothing
|
||||
LocalResourceRepo r -> Just $ LocalResourceRepo' r
|
||||
LocalResourceDeck d -> Just $ LocalResourceDeck' d
|
||||
LocalResourceLoom l -> Just $ LocalResourceLoom' l
|
||||
LocalResourceProject j -> Just $ LocalResourceProject' j
|
||||
|
||||
resourceFromNG = \case
|
||||
LocalResourceRepo' r -> LocalResourceRepo r
|
||||
LocalResourceDeck' d -> LocalResourceDeck d
|
||||
LocalResourceLoom' l -> LocalResourceLoom l
|
||||
LocalResourceProject' j -> LocalResourceProject j
|
||||
|
||||
hashLocalActorPure
|
||||
:: HashidsContext -> LocalActorBy Key -> LocalActorBy KeyHashid
|
||||
hashLocalActorPure ctx = f
|
||||
|
|
|
|||
|
|
@ -118,6 +118,23 @@ import Vervis.Web.Collab
|
|||
-- * My followers
|
||||
-- * Record my Accept in the Source record
|
||||
--
|
||||
-- * If the target is my resources list:
|
||||
-- * Verify the object is a resource (i.e. project or component), find in DB/HTTP
|
||||
-- * Verify the Add is authorized
|
||||
-- * Verify it's not already an active resource of mine
|
||||
-- * Verify it's not already in an Origin-Us process where I saw the Add
|
||||
-- and sent my Accept
|
||||
-- * Verify it's not already in an Origin-Them process, where I saw the
|
||||
-- Add and the resource's Accept
|
||||
-- * Insert the Add to my inbox
|
||||
-- * Create a Effort record in DB
|
||||
-- * Forward the Add to my followers
|
||||
-- * Publish an Accept to:
|
||||
-- * The object resource + followers
|
||||
-- * Add sender + followers
|
||||
-- * My followers
|
||||
-- * Record my Accept in the Effort record
|
||||
--
|
||||
-- * If I'm the object, being added to someone's parents/children list:
|
||||
-- * Verify the target is a project, find in DB/HTTP
|
||||
-- * Verify it's not already an active parent of mine
|
||||
|
|
@ -148,6 +165,8 @@ groupAdd now groupID (Verse authorIdMsig body) add = do
|
|||
addChildActive object
|
||||
(Left (ATGroupParents j), _) | j == groupID ->
|
||||
addParentActive object
|
||||
(Left (ATGroupEfforts j), _) | j == groupID ->
|
||||
addResourceActive object
|
||||
(_, Left (LocalActorGroup j)) | j == groupID ->
|
||||
case target of
|
||||
Left (ATGroupParents j) | j /= groupID ->
|
||||
|
|
@ -599,6 +618,143 @@ groupAdd now groupID (Verse authorIdMsig body) add = do
|
|||
Right (author, _, addID) ->
|
||||
insert_ $ DestThemGestureRemote themID (remoteAuthorId author) addID
|
||||
|
||||
addResourceActive resource = do
|
||||
|
||||
-- If resource is local, find it in our DB
|
||||
-- If resource is remote, HTTP GET it, verify it's an actor of Group
|
||||
-- type, 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.
|
||||
resourceDB <-
|
||||
bitraverse
|
||||
(\ la ->
|
||||
case resourceToNG =<< actorToResource la of
|
||||
Just ng -> withDBExcept $ getLocalResourceEntityE (resourceFromNG ng) "Resource not found in DB"
|
||||
Nothing -> throwE "Local proposed resource of non-resource type"
|
||||
)
|
||||
(\ u@(ObjURI h lu) -> do
|
||||
instanceID <-
|
||||
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
|
||||
result <-
|
||||
ExceptT $ first (T.pack . displayException) <$>
|
||||
fetchRemoteActor' instanceID h lu
|
||||
case result of
|
||||
Left Nothing -> throwE "Resource @id mismatch"
|
||||
Left (Just err) -> throwE $ T.pack $ displayException err
|
||||
Right Nothing -> throwE "Resource isn't an actor"
|
||||
Right (Just actor) -> do
|
||||
if AP.actorTypeIsResourceNT $ remoteActorType $ entityVal actor
|
||||
then pure ()
|
||||
else throwE "Remote resource type isn't a resource"
|
||||
return (u, actor)
|
||||
)
|
||||
resource
|
||||
let resourceDB' = bimap localResourceID (entityKey . snd) resourceDB
|
||||
|
||||
-- Verify that a capability is provided
|
||||
uCap <- do
|
||||
let muCap = AP.activityCapability $ actbActivity body
|
||||
fromMaybeE muCap "No capability provided"
|
||||
|
||||
-- Verify the sender is authorized by me to add a resource
|
||||
verifyCapability''
|
||||
uCap
|
||||
authorIdMsig
|
||||
(LocalResourceGroup groupID)
|
||||
AP.RoleAdmin
|
||||
|
||||
maybeNew <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(group, actorRecip) <- lift $ do
|
||||
p <- getJust groupID
|
||||
(p,) <$> getJust (groupActor p)
|
||||
|
||||
-- Verify the object isn't already a resource of mine, and that no
|
||||
-- Effort record is already in Add-Accept state
|
||||
verifyNoStartedGroupResources groupID resourceDB'
|
||||
|
||||
-- Insert the Add to my inbox
|
||||
mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False
|
||||
lift $ for mractid $ \ (inboxItemID, addDB) -> do
|
||||
|
||||
-- Create an Effort record in DB
|
||||
acceptID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now
|
||||
insertEffort resourceDB' addDB acceptID
|
||||
|
||||
-- Prepare forwarding the Add to my followers
|
||||
sieve <- do
|
||||
groupHash <- encodeKeyHashid groupID
|
||||
return $ makeRecipientSet [] [LocalStageGroupFollowers groupHash]
|
||||
|
||||
-- Prepare an Accept activity and insert to my outbox
|
||||
accept@(actionAccept, _, _, _) <- prepareAccept resourceDB
|
||||
_luAccept <- updateOutboxItem' (LocalActorGroup groupID) acceptID actionAccept
|
||||
|
||||
return (groupActor group, sieve, acceptID, accept, inboxItemID)
|
||||
|
||||
case maybeNew of
|
||||
Nothing -> done "I already have this activity in my inbox"
|
||||
Just (groupActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do
|
||||
forwardActivity
|
||||
authorIdMsig body (LocalActorGroup groupID) groupActorID sieve
|
||||
lift $ sendActivity
|
||||
(LocalActorGroup groupID) groupActorID localRecipsAccept
|
||||
remoteRecipsAccept fwdHostsAccept acceptID actionAccept
|
||||
doneDB inboxItemID "[Resource-active] Recorded a resource-in-progress, forwarded the Add, sent an Accept"
|
||||
|
||||
where
|
||||
|
||||
insertEffort topicDB addDB acceptID = do
|
||||
effortID <- insert $ Effort AP.RoleAdmin groupID
|
||||
case topicDB of
|
||||
Left r -> insert_ $ EffortTopicLocal effortID r
|
||||
Right a -> insert_ $ EffortTopicRemote effortID a
|
||||
usID <- insert $ EffortOriginUs effortID
|
||||
case addDB of
|
||||
Left (_, _, addID) ->
|
||||
insert_ $ EffortUsGestureLocal usID addID
|
||||
Right (author, _, addID) ->
|
||||
insert_ $ EffortUsGestureRemote usID (remoteAuthorId author) addID
|
||||
|
||||
insert_ $ EffortUsAccept usID acceptID
|
||||
|
||||
prepareAccept resourceDB = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
audAdder <- makeAudSenderWithFollowers authorIdMsig
|
||||
audResource <-
|
||||
case resourceDB of
|
||||
Left r -> do
|
||||
a <- hashLocalActor $ resourceToActor $ bmap entityKey r
|
||||
return $ AudLocal [a] [localActorFollowers a]
|
||||
Right (ObjURI h lu, Entity _ ra) ->
|
||||
return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
|
||||
audMe <-
|
||||
AudLocal [] . pure . LocalStageGroupFollowers <$>
|
||||
encodeKeyHashid groupID
|
||||
uAdd <- lift $ getActivityURI authorIdMsig
|
||||
|
||||
let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audAdder, audResource, audMe]
|
||||
|
||||
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)
|
||||
|
||||
-- Meaning: An actor accepted something
|
||||
-- Behavior:
|
||||
-- * Check if I know the activity that's being Accepted:
|
||||
|
|
|
|||
|
|
@ -72,6 +72,8 @@ module Vervis.Persist.Collab
|
|||
|
||||
, getEffortAdd
|
||||
, getEffortTopic
|
||||
|
||||
, verifyNoStartedGroupResources
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -1882,3 +1884,79 @@ getEffortTopic effortID =
|
|||
(getBy $ UniqueEffortTopicRemote effortID)
|
||||
"Found Effort without topic"
|
||||
"Found Effort with both local and remote topic"
|
||||
|
||||
getExistingGroupEfforts groupID (Left resourceID) =
|
||||
fmap (map $ bimap E.unValue (Left . E.unValue)) $
|
||||
E.select $ E.from $ \ (effort `E.InnerJoin` topic) -> do
|
||||
E.on $ effort E.^. EffortId E.==. topic E.^. EffortTopicLocalEffort
|
||||
E.where_ $
|
||||
effort E.^. EffortHolder E.==. E.val groupID E.&&.
|
||||
topic E.^. EffortTopicLocalTopic E.==. E.val resourceID
|
||||
return
|
||||
( effort E.^. EffortId
|
||||
, topic E.^. EffortTopicLocalId
|
||||
)
|
||||
getExistingGroupEfforts groupID (Right actorID) =
|
||||
fmap (map $ bimap E.unValue (Right . E.unValue)) $
|
||||
E.select $ E.from $ \ (effort `E.InnerJoin` topic) -> do
|
||||
E.on $ effort E.^. EffortId E.==. topic E.^. EffortTopicRemoteEffort
|
||||
E.where_ $
|
||||
effort E.^. EffortHolder E.==. E.val groupID E.&&.
|
||||
topic E.^. EffortTopicRemoteTopic E.==. E.val actorID
|
||||
return
|
||||
( effort E.^. EffortId
|
||||
, topic E.^. EffortTopicRemoteId
|
||||
)
|
||||
|
||||
verifyEffortsNotEnabled effortIDs = do
|
||||
byEnabled <-
|
||||
lift $ for effortIDs $ \ (effortID, _) ->
|
||||
isJust <$> runMaybeT (tryEffortEnabled effortID)
|
||||
case length $ filter id byEnabled of
|
||||
0 -> return ()
|
||||
1 -> throwE "I already have a EffortUsSendDelegator for this effort"
|
||||
_ -> error "Multiple EffortUsSendDelegator for a effort"
|
||||
where
|
||||
tryEffortEnabled effortID =
|
||||
const () <$> MaybeT (getBy $ UniqueEffortUsSendDelegator effortID)
|
||||
|
||||
verifyEffortsNotStarted effortIDs = do
|
||||
anyStarted <-
|
||||
lift $ runMaybeT $ asum $
|
||||
map (\ (effortID, topic) ->
|
||||
tryEffortUs effortID <|>
|
||||
tryEffortThem effortID topic
|
||||
)
|
||||
effortIDs
|
||||
unless (isNothing anyStarted) $
|
||||
throwE "One of the Effort records is already in Add-Accept state"
|
||||
where
|
||||
tryEffortUs effortID = do
|
||||
usID <- MaybeT $ getKeyBy $ UniqueEffortOriginUs effortID
|
||||
const () <$> MaybeT (getBy $ UniqueEffortUsAccept usID)
|
||||
|
||||
tryEffortThem effortID topic = do
|
||||
_ <- MaybeT $ getBy $ UniqueEffortOriginThem effortID
|
||||
case topic of
|
||||
Left localID ->
|
||||
const () <$>
|
||||
MaybeT (getBy $ UniqueEffortThemAcceptLocal localID)
|
||||
Right remoteID ->
|
||||
const () <$>
|
||||
MaybeT (getBy $ UniqueEffortThemAcceptRemote remoteID)
|
||||
|
||||
verifyNoStartedGroupResources
|
||||
:: GroupId -> Either ResourceId RemoteActorId -> ActDBE ()
|
||||
verifyNoStartedGroupResources groupID resource = do
|
||||
|
||||
-- Find existing Effort records I have for this resource
|
||||
effortIDs <- lift $ getExistingGroupEfforts groupID resource
|
||||
|
||||
-- Grab all the enabled ones, make sure none are enabled, and even if
|
||||
-- any are enabled, make sure there's at most one (otherwise it's a
|
||||
-- bug)
|
||||
verifyEffortsNotEnabled effortIDs
|
||||
|
||||
-- Verify none of the Effort records are already in
|
||||
-- Our-Add+Accept-waiting-for-them or Their-Add+Accept-waiting-for-us state
|
||||
verifyEffortsNotStarted effortIDs
|
||||
|
|
|
|||
|
|
@ -31,6 +31,8 @@ module Web.ActivityPub
|
|||
-- instance for fetching and a 'ToJSON' instance for publishing.
|
||||
, ActorType (..)
|
||||
, actorTypeIsComponent
|
||||
, actorTypeIsResource
|
||||
, actorTypeIsResourceNT
|
||||
, parseActorType
|
||||
, renderActorType
|
||||
--, Algorithm (..)
|
||||
|
|
@ -398,6 +400,16 @@ actorTypeIsComponent = \case
|
|||
ActorTypePatchTracker -> True
|
||||
_ -> False
|
||||
|
||||
actorTypeIsResource = \case
|
||||
ActorTypeRepo -> True
|
||||
ActorTypeTicketTracker -> True
|
||||
ActorTypePatchTracker -> True
|
||||
ActorTypeProject -> True
|
||||
ActorTypeTeam -> True
|
||||
_ -> False
|
||||
|
||||
actorTypeIsResourceNT t = actorTypeIsResource t && t /= ActorTypeTeam
|
||||
|
||||
parseActorType :: Text -> ActorType
|
||||
parseActorType t
|
||||
| t == "Person" = ActorTypePerson
|
||||
|
|
|
|||
Loading…
Reference in a new issue