mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-27 16:24:52 +09:00
C2S: Implement Add handler, for adding a component to a project
This commit is contained in:
Pere Lev
parent
477793688f
commit
14ef892032
1 changed files with 128 additions and 0 deletions
|
|
@ -136,6 +136,133 @@ verifyRemoteAddressed remoteRecips u =
|
|||
lus <- lookup h remoteRecips
|
||||
guard $ lu `elem` lus
|
||||
|
||||
-- Meaning: The human wants to add component C to project P
|
||||
-- Behavior:
|
||||
-- * Some basic sanity checks
|
||||
-- * Parse the Add
|
||||
-- * Make sure not inviting myself
|
||||
-- * Verify that a capability is specified
|
||||
-- * If component is local, verify it exists in DB
|
||||
-- * If project is local, verify it exists in DB
|
||||
-- * Verify C and P are addressed in the Invite
|
||||
-- * Insert Add to my inbox
|
||||
-- * Asynchrnously deliver to:
|
||||
-- * C+followers
|
||||
-- * P+followers
|
||||
-- * My followers
|
||||
clientAdd
|
||||
:: UTCTime
|
||||
-> PersonId
|
||||
-> ClientMsg
|
||||
-> AP.Add URIMode
|
||||
-> ActE OutboxItemId
|
||||
clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) add = do
|
||||
|
||||
-- Check input
|
||||
(component, project, _role) <- parseAdd (Left $ LocalActorPerson personMeID) add
|
||||
_capID <- fromMaybeE maybeCap "No capability provided"
|
||||
|
||||
-- If project components URI is remote, HTTP GET it and its resource and its
|
||||
-- managing actor, and insert to our DB. If project is local, find it in
|
||||
-- our DB.
|
||||
projectDB <-
|
||||
bitraverse
|
||||
(withDBExcept . flip getEntityE "Project not found in DB")
|
||||
(\ u@(ObjURI h luComps) -> do
|
||||
manager <- asksEnv envHttpManager
|
||||
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luComps
|
||||
lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
|
||||
AP.ResourceWithCollections _ _ mluComps <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
|
||||
unless (mluComps == Just luComps) $
|
||||
throwE "Add target isn't a components list"
|
||||
|
||||
instanceID <-
|
||||
lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
|
||||
result <-
|
||||
ExceptT $ first (T.pack . show) <$>
|
||||
fetchRemoteResource instanceID h lu
|
||||
case result of
|
||||
Left (Entity actorID actor) ->
|
||||
return (remoteActorIdent actor, actorID, u)
|
||||
Right (objectID, luManager, (Entity actorID _)) ->
|
||||
return (objectID, actorID, ObjURI h luManager)
|
||||
)
|
||||
project
|
||||
|
||||
-- If component is remote, HTTP GET it, make sure it's an actor, and insert
|
||||
-- it to our DB. If recipient is local, find it in our DB.
|
||||
componentDB <-
|
||||
bitraverse
|
||||
(withDBExcept . flip getComponentE "Component not found in DB")
|
||||
(\ 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 "Recipient @id mismatch"
|
||||
Left (Just err) -> throwE $ T.pack $ displayException err
|
||||
Right Nothing -> throwE "Recipient isn't an actor"
|
||||
Right (Just actor) -> return (entityKey actor, u)
|
||||
)
|
||||
component
|
||||
|
||||
-- Verify that project and component are addressed by the Add
|
||||
bitraverse_
|
||||
(verifyProjectAddressed localRecips . entityKey)
|
||||
(\ (_, _, u) -> verifyRemoteAddressed remoteRecips u)
|
||||
projectDB
|
||||
bitraverse_
|
||||
(verifyComponentAddressed localRecips . bmap entityKey)
|
||||
(verifyRemoteAddressed remoteRecips . snd)
|
||||
componentDB
|
||||
|
||||
(actorMeID, localRecipsFinal, addID) <- withDBExcept $ do
|
||||
|
||||
-- Grab me from DB
|
||||
(personMe, actorMe) <- lift $ do
|
||||
p <- getJust personMeID
|
||||
(p,) <$> getJust (personActor p)
|
||||
|
||||
-- Insert the Add activity to my outbox
|
||||
addID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now
|
||||
_luAdd <- lift $ updateOutboxItem' (LocalActorPerson personMeID) addID action
|
||||
|
||||
-- Prepare local recipients for Add delivery
|
||||
sieve <- lift $ do
|
||||
projectHash <- bitraverse encodeKeyHashid pure project
|
||||
componentHash <- bitraverse hashComponent pure component
|
||||
senderHash <- encodeKeyHashid personMeID
|
||||
let sieveActors = catMaybes
|
||||
[ case projectHash of
|
||||
Left j -> Just $ LocalActorProject j
|
||||
Right _ -> Nothing
|
||||
, case componentHash of
|
||||
Left c -> Just $ componentActor c
|
||||
Right _ -> Nothing
|
||||
]
|
||||
sieveStages = catMaybes
|
||||
[ Just $ LocalStagePersonFollowers senderHash
|
||||
, case projectHash of
|
||||
Left j -> Just $ LocalStageProjectFollowers j
|
||||
Right _ -> Nothing
|
||||
, case componentHash of
|
||||
Left c -> Just $ localActorFollowers $ componentActor c
|
||||
Right _ -> Nothing
|
||||
]
|
||||
return $ makeRecipientSet sieveActors sieveStages
|
||||
return
|
||||
( personActor personMe
|
||||
, localRecipSieve sieve False localRecips
|
||||
, addID
|
||||
)
|
||||
|
||||
lift $ sendActivity
|
||||
(LocalActorPerson personMeID) actorMeID localRecipsFinal remoteRecips
|
||||
fwdHosts addID action
|
||||
return addID
|
||||
|
||||
-- Meaning: The human wants to create a ticket tracker
|
||||
-- Behavior:
|
||||
-- * Create a deck on DB
|
||||
|
|
@ -758,6 +885,7 @@ clientBehavior :: UTCTime -> PersonId -> ClientMsg -> ActE (Text, Act (), Next)
|
|||
clientBehavior now personID msg =
|
||||
done . T.pack . show =<<
|
||||
case AP.actionSpecific $ cmAction msg of
|
||||
AP.AddActivity add -> clientAdd now personID msg add
|
||||
AP.CreateActivity create -> clientCreate now personID msg create
|
||||
AP.InviteActivity invite -> clientInvite now personID msg invite
|
||||
AP.RemoveActivity remove -> clientRemove now personID msg remove
|
||||
|
|
|
|||
Loading…
Reference in a new issue