From 6ae079a3108757c22914e18461778a5b605ff308 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Tue, 27 Jun 2023 17:55:59 +0300 Subject: [PATCH] S2S: Project Add handler --- src/Vervis/Actor/Project.hs | 197 +++++++++++++++++++++++++++++++++++ src/Vervis/Data/Collab.hs | 80 ++++++++++++++ src/Vervis/Migration.hs | 2 + src/Vervis/Persist/Collab.hs | 5 + th/models | 1 - 5 files changed, 284 insertions(+), 1 deletion(-) diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index ad01a8b..b7dd182 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -19,6 +19,7 @@ module Vervis.Actor.Project where import Control.Applicative +import Control.Exception.Base import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger.CallStack @@ -36,9 +37,11 @@ import Data.Time.Clock import Data.Traversable import Database.Persist import Database.Persist.Sql +import Optics.Core import Yesod.Persist.Core import qualified Data.Text as T +import qualified Database.Esqueleto as E import Control.Concurrent.Actor import Network.FedURI @@ -65,6 +68,7 @@ import Vervis.Federation.Util import Vervis.Foundation import Vervis.Model hiding (projectCreate) import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience) +import Vervis.RemoteActorStore import Vervis.Persist.Actor import Vervis.Persist.Collab import Vervis.Persist.Discussion @@ -93,6 +97,198 @@ projectAccept -> ActE (Text, Act (), Next) projectAccept = topicAccept projectActor GrantResourceProject +-- Meaning: An actor is adding some object to some target +-- Behavior: +-- * Verify I'm the target +-- * Verify the object is a component, find in DB if local +-- * Verify it's not already an active component of mine +-- * Verify it's not already in a Add-Accept process waiting for project +-- collab to accept too +-- * Verify it's not already in an Invite-Accept process waiting for +-- component (or its collaborator) to accept too +-- * Insert the Add to my inbox +-- * Create a Component record in DB +-- * Forward the Add to my followers +projectAdd + :: UTCTime + -> ProjectId + -> Verse + -> AP.Add URIMode + -> ActE (Text, Act (), Next) +projectAdd now projectID (Verse authorIdMsig body) add = do + + -- Check input + component <- do + let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig + (component, project) <- parseAdd author add + unless (project == Left projectID) $ throwE "Add target isn't me" + return component + + -- If component is local, find it in our DB + -- If component is remote, HTTP GET it, verify it's an actor of a component + -- 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. + 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 "Target @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Target isn't an actor" + Right (Just actor) -> do + case remoteActorType $ entityVal actor of + AP.ActorTypeRepo -> pure () + AP.ActorTypeTicketTracker -> pure () + AP.ActorTypePatchTracker -> pure () + _ -> throwE "Remote component type isn't repo/tt/pt" + return $ entityKey actor + ) + component + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (project, actorRecip) <- lift $ do + p <- getJust projectID + (p,) <$> getJust (projectActor p) + + -- Find existing Component records I have for this component + componentIDs <- lift $ getExistingComponents componentDB + + -- 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) + byEnabled <- + lift $ for componentIDs $ \ (componentID, _) -> + isJust <$> runMaybeT (tryComponentEnabled componentID) + case length $ filter id byEnabled of + 0 -> return () + 1 -> throwE "I already have a ComponentEnable for this component" + _ -> error "Multiple ComponentEnable for a component" + + -- Verify none of the Component records are already in + -- Add-waiting-for-project or Invite-waiting-for-component state + anyStarted <- + lift $ runMaybeT $ asum $ + map (\ (componentID, identID) -> + tryComponentAddAccept componentID identID <|> + tryComponentInviteAccept componentID + ) + componentIDs + unless (isNothing anyStarted) $ + throwE + "One of the Component records is already in Add-Accept or \ + \Invite-Accept state" + + -- Insert the Add to my inbox + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + lift $ for mractid $ \ addDB -> do + + -- Create a Component record in DB + insertComponent componentDB addDB + + return $ projectActor project + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just actorID -> do + projectHash <- encodeKeyHashid projectID + let sieve = + makeRecipientSet + [] + [LocalStageProjectFollowers projectHash] + forwardActivity + authorIdMsig body (LocalActorProject projectID) actorID sieve + done + "Recorded a Component record; Inserted the Add to inbox; \ + \Forwarded to followers if addressed" + + where + + getExistingComponents (Left (ComponentRepo (Entity repoID _))) = + fmap (map $ bimap E.unValue (Left . E.unValue)) $ + E.select $ E.from $ \ (ident `E.InnerJoin` local `E.InnerJoin` comp) -> do + E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId + E.on $ ident E.^. ComponentLocalRepoComponent E.==. local E.^. ComponentLocalId + E.where_ $ + ident E.^. ComponentLocalRepoRepo E.==. E.val repoID E.&&. + comp E.^. ComponentProject E.==. E.val projectID + return (comp E.^. ComponentId, local E.^. ComponentLocalId) + getExistingComponents (Left (ComponentDeck (Entity deckID _))) = + fmap (map $ bimap E.unValue (Left . E.unValue)) $ + E.select $ E.from $ \ (ident `E.InnerJoin` local `E.InnerJoin` comp) -> do + E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId + E.on $ ident E.^. ComponentLocalDeckComponent E.==. local E.^. ComponentLocalId + E.where_ $ + ident E.^. ComponentLocalDeckDeck E.==. E.val deckID E.&&. + comp E.^. ComponentProject E.==. E.val projectID + return (comp E.^. ComponentId, local E.^. ComponentLocalId) + getExistingComponents (Left (ComponentLoom (Entity loomID _))) = + fmap (map $ bimap E.unValue (Left . E.unValue)) $ + E.select $ E.from $ \ (ident `E.InnerJoin` local `E.InnerJoin` comp) -> do + E.on $ local E.^. ComponentLocalComponent E.==. comp E.^. ComponentId + E.on $ ident E.^. ComponentLocalLoomComponent E.==. local E.^. ComponentLocalId + E.where_ $ + ident E.^. ComponentLocalLoomLoom E.==. E.val loomID E.&&. + comp E.^. ComponentProject E.==. E.val projectID + return (comp E.^. ComponentId, local E.^. ComponentLocalId) + getExistingComponents (Right remoteActorID) = + fmap (map $ bimap E.unValue (Right . E.unValue)) $ + E.select $ E.from $ \ (ident `E.InnerJoin` comp) -> do + E.on $ ident E.^. ComponentRemoteComponent E.==. comp E.^. ComponentId + E.where_ $ + ident E.^. ComponentRemoteActor E.==. E.val remoteActorID E.&&. + comp E.^. ComponentProject E.==. E.val projectID + return (comp E.^. ComponentId, ident E.^. ComponentRemoteId) + + tryComponentEnabled componentID = + const () <$> MaybeT (getBy $ UniqueComponentEnable componentID) + + tryComponentAddAccept componentID identID = do + _ <- MaybeT $ getBy $ UniqueComponentOriginAdd componentID + case identID of + Left localID -> + const () <$> + MaybeT (getBy $ UniqueComponentAcceptLocal localID) + Right remoteID -> + const () <$> + MaybeT (getBy $ UniqueComponentAcceptRemote remoteID) + + tryComponentInviteAccept componentID = do + originID <- MaybeT $ getKeyBy $ UniqueComponentOriginInvite componentID + const () <$> MaybeT (getBy $ UniqueComponentProjectAccept originID) + + insertComponent componentDB addDB = do + componentID <- insert $ Component projectID + originID <- insert $ ComponentOriginAdd componentID + case addDB of + Left (_, _, addID) -> + insert_ $ ComponentGestureLocal originID addID + Right (author, _, addID) -> + insert_ $ ComponentGestureRemote originID (remoteAuthorId author) addID + case componentDB of + Left l -> do + identID <- insert $ ComponentLocal componentID + case l of + ComponentRepo (Entity repoID _) -> + insert_ $ ComponentLocalRepo identID repoID + ComponentDeck (Entity deckID _) -> + insert_ $ ComponentLocalDeck identID deckID + ComponentLoom (Entity loomID _) -> + insert_ $ ComponentLocalLoom identID loomID + Right remoteActorID -> + insert_ $ ComponentRemote componentID remoteActorID + -- Meaning: Someone has created a project with my ID URI -- Behavior: -- * Verify I'm in a just-been-created state @@ -368,6 +564,7 @@ projectBehavior :: UTCTime -> ProjectId -> VerseExt -> ActE (Text, Act (), Next) projectBehavior now projectID (Left verse@(Verse _authorIdMsig body)) = case AP.activitySpecific $ actbActivity body of AP.AcceptActivity accept -> projectAccept now projectID verse accept + AP.AddActivity add -> projectAdd now projectID verse add AP.CreateActivity create -> projectCreate now projectID verse create AP.FollowActivity follow -> projectFollow now projectID verse follow AP.InviteActivity invite -> projectInvite now projectID verse invite diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index 5b5384e..f7d60d6 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -28,6 +28,7 @@ module Vervis.Data.Collab , parseAccept , parseReject , parseRemove + , parseAdd , grantResourceActorID @@ -44,6 +45,8 @@ module Vervis.Data.Collab , getGrantResource404 , grantResourceLocalActor + + , ComponentBy (..) ) where @@ -269,6 +272,60 @@ parseRemove sender (AP.Remove object origin) = (,) <$> nameExceptT "Remove origin" (parseTopic origin) <*> nameExceptT "Remove object" (parseRecipient sender object) +parseAdd + :: StageRoute Env ~ Route App + => Either (LocalActorBy Key) FedURI + -> AP.Add URIMode + -> ActE + ( Either (ComponentBy Key) FedURI + , Either ProjectId FedURI + ) +parseAdd sender (AP.Add object target) = do + result@(component, project) <- + (,) <$> nameExceptT "Add.object" (parseComponent' object) + <*> nameExceptT "Add.target" (parseProject target) + case result of + (Right u, Right v) | u == v -> throwE "Object and target are the same" + _ -> pure () + when (sender == first componentActor component) $ + throwE "Sender and component are the same" + when (sender == first LocalActorProject project) $ + throwE "Sender and project are the same" + return result + where + componentActor (ComponentRepo r) = LocalActorRepo r + componentActor (ComponentDeck d) = LocalActorDeck d + componentActor (ComponentLoom l) = LocalActorLoom l + parseComponent' (Right _) = throwE "Not a component URI" + parseComponent' (Left u) = do + routeOrRemote <- parseFedURI u + bitraverse + (\ route -> do + componentHash <- + fromMaybeE + (parseComponent route) + "Not a component route" + unhashComponentE + componentHash + "Contains invalid hashid" + ) + pure + routeOrRemote + where + parseComponent (RepoR r) = Just $ ComponentRepo r + parseComponent (DeckR d) = Just $ ComponentDeck d + parseComponent (LoomR l) = Just $ ComponentLoom l + parseComponent _ = Nothing + parseProject u = do + routeOrRemote <- parseFedURI u + bitraverse + (\case + ProjectR j -> WAP.decodeKeyHashidE j "Inavlid hashid" + _ -> throwE "Not a project route" + ) + pure + routeOrRemote + grantResourceActorID :: GrantResourceBy Identity -> ActorId grantResourceActorID (GrantResourceRepo (Identity r)) = repoActor r grantResourceActorID (GrantResourceDeck (Identity d)) = deckActor d @@ -354,3 +411,26 @@ grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l grantResourceLocalActor (GrantResourceProject l) = LocalActorProject l + +data ComponentBy f + = ComponentRepo (f Repo) + | ComponentDeck (f Deck) + | ComponentLoom (f Loom) + deriving (Generic, FunctorB, TraversableB, ConstraintsB) + +deriving instance AllBF Eq f ComponentBy => Eq (ComponentBy f) + +unhashComponentPure ctx = f + where + f (ComponentRepo r) = + ComponentRepo <$> decodeKeyHashidPure ctx r + f (ComponentDeck d) = + ComponentDeck <$> decodeKeyHashidPure ctx d + f (ComponentLoom l) = + ComponentLoom <$> decodeKeyHashidPure ctx l + +unhashComponent c = do + ctx <- asksEnv WAP.stageHashidsContext + return $ unhashComponentPure ctx c + +unhashComponentE c e = ExceptT $ maybe (Left e) Right <$> unhashComponent c diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 3585da6..f014b29 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -2962,6 +2962,8 @@ changes hLocal ctx = , addEntities model_542_component -- 543 , addFieldPrimRequired "RemoteActor" ("" :: Text) "type" + -- 544 + , removeField "ComponentRemote" "object" ] migrateDB diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index c255c64..2c1d7bf 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -17,6 +17,7 @@ module Vervis.Persist.Collab ( getCollabTopic , getCollabTopic' , getGrantRecip + , getComponentE , getTopicGrants , getTopicInvites , getTopicJoins @@ -99,6 +100,10 @@ getCollabTopic' collabID = do getGrantRecip (GrantRecipPerson k) e = GrantRecipPerson <$> getEntityE k e +getComponentE (ComponentRepo k) e = ComponentRepo <$> getEntityE k e +getComponentE (ComponentDeck k) e = ComponentDeck <$> getEntityE k e +getComponentE (ComponentLoom k) e = ComponentLoom <$> getEntityE k e + getTopicGrants :: ( MonadIO m , PersistRecordBackend topic SqlBackend diff --git a/th/models b/th/models index e8dacc0..6f25a39 100644 --- a/th/models +++ b/th/models @@ -830,7 +830,6 @@ ComponentLocalLoom ComponentRemote component ComponentId actor RemoteActorId - object RemoteObjectId UniqueComponentRemote component