S2S: Project Add handler

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

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

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

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

th/models

@@ -830,7 +830,6 @@ ComponentLocalLoom
 ComponentRemote
     component ComponentId
     actor     RemoteActorId
-    object    RemoteObjectId
 
     UniqueComponentRemote component