From 224c290b04de5b3101322216ef27241f51dc9d21 Mon Sep 17 00:00:00 2001
From: Pere Lev <pere@towards.vision>
Date: Mon, 26 Jun 2023 23:12:40 +0300
Subject: [PATCH] S2S: Project creation and following

---
 src/Vervis/Actor/Project.hs | 89 ++++++++++++++++++++++++++++++++++++-
 1 file changed, 87 insertions(+), 2 deletions(-)

diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs
index ee5d7f2..197c827 100644
--- a/src/Vervis/Actor/Project.hs
+++ b/src/Vervis/Actor/Project.hs
@@ -18,23 +18,32 @@ module Vervis.Actor.Project
     )
 where
 
+import Control.Applicative
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Logger.CallStack
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Reader
+import Data.Bifunctor
+import Data.Bitraversable
 import Data.ByteString (ByteString)
 import Data.Foldable
+import Data.Maybe
 import Data.Text (Text)
 import Data.Time.Clock
+import Data.Traversable
 import Database.Persist
+import Database.Persist.Sql
 import Yesod.Persist.Core
 
 import qualified Data.Text as T
 
 import Control.Concurrent.Actor
 import Network.FedURI
+import Web.Actor
+import Web.Actor.Persist
 import Yesod.MonadSite
 
 import qualified Web.ActivityPub as AP
@@ -42,19 +51,95 @@ import qualified Web.ActivityPub as AP
 import Control.Monad.Trans.Except.Local
 import Database.Persist.Local
 
+import Vervis.Access
+import Vervis.ActivityPub
 import Vervis.Actor
+import Vervis.Actor.Common
+import Vervis.Actor2
 import Vervis.Cloth
+import Vervis.Data.Actor
+import Vervis.Data.Collab
 import Vervis.Data.Discussion
 import Vervis.FedURI
 import Vervis.Federation.Util
 import Vervis.Foundation
-import Vervis.Model
+import Vervis.Model hiding (projectCreate)
+import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience)
+import Vervis.Persist.Actor
+import Vervis.Persist.Collab
 import Vervis.Persist.Discussion
 import Vervis.Ticket
 
+-- Meaning: Someone has created a project with my ID URI
+-- Behavior:
+--     * Verify I'm in a just-been-created state
+--     * Verify my creator and the Create sender are the same actor
+--     * Create an admin Collab record in DB
+--     * Send an admin Grant to the creator
+--     * Get out of the just-been-created state
+projectCreateMe
+    :: UTCTime
+    -> ProjectId
+    -> Verse
+    -> ActE (Text, Act (), Next)
+projectCreateMe =
+    topicCreateMe
+        projectActor GrantResourceProject
+        CollabTopicProjectProject CollabTopicProject
+
+projectCreate
+    :: UTCTime
+    -> ProjectId
+    -> Verse
+    -> AP.Create URIMode
+    -> ActE (Text, Act (), Next)
+projectCreate now projectID verse (AP.Create obj _muTarget) =
+    case obj of
+
+        AP.CreateProject _ mlocal -> do
+            (h, local) <- fromMaybeE mlocal "No project id provided"
+            let luProject = AP.actorId local
+            uMe <- do
+                projectHash <- encodeKeyHashid projectID
+                encodeRouteHome <- getEncodeRouteHome
+                return $ encodeRouteHome $ ProjectR projectHash
+            unless (uMe == ObjURI h luProject) $
+                throwE "The created project id isn't me"
+            projectCreateMe now projectID verse
+
+        _ -> throwE "Unsupported Create object for Project"
+
+-- Meaning: An actor is following someone/something
+-- Behavior:
+--      * Verify the target is me
+--      * Record the follow in DB
+--      * Publish and send an Accept to the sender and its followers
+projectFollow
+    :: UTCTime
+    -> ProjectId
+    -> Verse
+    -> AP.Follow URIMode
+    -> ActE (Text, Act (), Next)
+projectFollow now recipProjectID verse follow = do
+    recipProjectHash <- encodeKeyHashid recipProjectID
+    actorFollow
+        (\case
+            ProjectR d | d == recipProjectHash -> pure ()
+            _ -> throwE "Asking to follow someone else"
+        )
+        projectActor
+        False
+        (\ recipProjectActor () -> pure $ actorFollowers recipProjectActor)
+        (\ _ -> pure $ makeRecipientSet [] [])
+        LocalActorProject
+        (\ _ -> pure [])
+        now recipProjectID verse follow
+
 projectBehavior :: UTCTime -> ProjectId -> VerseExt -> ActE (Text, Act (), Next)
-projectBehavior now projectID (Left _verse@(Verse _authorIdMsig body)) =
+projectBehavior now projectID (Left verse@(Verse _authorIdMsig body)) =
     case AP.activitySpecific $ actbActivity body of
+        AP.CreateActivity create -> projectCreate now projectID verse create
+        AP.FollowActivity follow -> projectFollow now projectID verse follow
         _ -> throwE "Unsupported activity type for Project"
 projectBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Project"