C2S: Implement Add handler, for adding a component to a project

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