diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index 95cf606..ddd7442 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/src/Vervis/Actor/Person/Client.hs @@ -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