S2S: Deck Add handler

src/Vervis/Actor/Deck.hs

@@ -19,6 +19,7 @@ module Vervis.Actor.Deck
 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
@@ -68,8 +71,286 @@ import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectA
 import Vervis.Persist.Actor
 import Vervis.Persist.Collab
 import Vervis.Persist.Discussion
+import Vervis.RemoteActorStore
 import Vervis.Ticket
 
+checkExistingStems
+    :: DeckId -> Either (Entity Project) RemoteActorId -> ActDBE ()
+checkExistingStems deckID projectDB = do
+
+    -- Find existing Stem records I have for this project
+    stemIDs <- lift $ getExistingStems projectDB
+
+    -- 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 stemIDs $ \ (_, stem) ->
+            isJust <$> runMaybeT (tryStemEnabled stem)
+    case length $ filter id byEnabled of
+        0 -> return ()
+        1 -> throwE "I already have a StemProjectGrant* for this project"
+        _ -> error "Multiple StemProjectGrant* for a project"
+
+    -- Verify none of the Stem records are already in
+    -- Add-waiting-for-project or Invite-waiting-for-my-collaborator state
+    anyStarted <-
+        lift $ runMaybeT $ asum $
+            map (\ (stemID, project) ->
+                    tryStemAddAccept stemID <|>
+                    tryStemInviteAccept stemID project
+                )
+                stemIDs
+    unless (isNothing anyStarted) $
+        throwE
+            "One of the Stem records is already in Add-Accept or \
+            \Invite-Accept state"
+
+    where
+
+    getExistingStems (Left (Entity projectID _)) =
+        fmap (map $ bimap E.unValue (Left . E.unValue)) $
+        E.select $ E.from $ \ (project `E.InnerJoin` ident) -> do
+            E.on $ project E.^. StemProjectLocalStem E.==. ident E.^. StemIdentDeckStem
+            E.where_ $
+                project E.^. StemProjectLocalProject E.==. E.val projectID E.&&.
+                ident E.^. StemIdentDeckDeck E.==. E.val deckID
+            return
+                ( project E.^. StemProjectLocalStem
+                , project E.^. StemProjectLocalId
+                )
+    getExistingStems (Right remoteActorID) =
+        fmap (map $ bimap E.unValue (Right . E.unValue)) $
+        E.select $ E.from $ \ (project `E.InnerJoin` ident) -> do
+            E.on $ project E.^. StemProjectRemoteStem E.==. ident E.^. StemIdentDeckStem
+            E.where_ $
+                project E.^. StemProjectRemoteProject E.==. E.val remoteActorID E.&&.
+                ident E.^. StemIdentDeckDeck E.==. E.val deckID
+            return
+                ( project E.^. StemProjectRemoteStem
+                , project E.^. StemProjectRemoteId
+                )
+
+    tryStemEnabled (Left localID) =
+        const () <$> MaybeT (getBy $ UniqueStemProjectGrantLocalProject localID)
+    tryStemEnabled (Right remoteID) =
+        const () <$> MaybeT (getBy $ UniqueStemProjectGrantRemoteProject remoteID)
+
+    tryStemAddAccept stemID = do
+        _ <- MaybeT $ getBy $ UniqueStemOriginAdd stemID
+        _ <- MaybeT $ getBy $ UniqueStemComponentAccept stemID
+        pure ()
+
+    tryStemInviteAccept stemID project = do
+        originID <- MaybeT $ getKeyBy $ UniqueStemOriginInvite stemID
+        case project of
+            Left localID ->
+                const () <$> MaybeT (getBy $ UniqueStemProjectAcceptLocalProject localID)
+            Right remoteID ->
+                const () <$> MaybeT (getBy $ UniqueStemProjectAcceptRemoteProject remoteID)
+
+-- Meaning: An actor is adding some object to some target
+-- Behavior:
+--     * Verify that the object is me
+--     * Verify the target is some project's components collection URI
+--     * Verify the Add is authorized
+--     * For all the Stem records I have for this project:
+--         * Verify I'm not yet a member of the project
+--         * Verify I haven't already Accepted an Add to this project
+--         * Verify I haven't already seen an Invite-and-Project-accept for
+--           this project
+--     * Insert the Add to my inbox
+--     * Create a Stem record in DB
+--     * Forward the Add activity to my followers
+--     * Send an Accept on the Add:
+--         * To:
+--             * The author of the Add
+--             * The project
+--         * CC:
+--             * Author's followers
+--             * Project's followers
+--             * My followers
+deckAdd
+    :: UTCTime
+    -> DeckId
+    -> Verse
+    -> AP.Add URIMode
+    -> ActE (Text, Act (), Next)
+deckAdd now deckID (Verse authorIdMsig body) add = do
+
+    -- Check capability
+    capability <- do
+
+        -- Verify that a capability is provided
+        uCap <- do
+            let muCap = AP.activityCapability $ actbActivity body
+            fromMaybeE muCap "No capability provided"
+
+        -- Verify the capability URI is one of:
+        --   * Outbox item URI of a local actor, i.e. a local activity
+        --   * A remote URI
+        cap <- nameExceptT "Invite capability" $ parseActivityURI' uCap
+
+        -- Verify the capability is local
+        case cap of
+            Left (actorByKey, _, outboxItemID) ->
+                return (actorByKey, outboxItemID)
+            _ -> throwE "Capability is remote i.e. definitely not by me"
+
+    -- Check input
+    projectComps <- do
+        let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
+        (component, projectComps, role) <- parseAdd author add
+        unless (component == Left (ComponentDeck deckID)) $
+            throwE "Add object isn't me"
+        unless (role == AP.RoleAdmin) $
+            throwE "Add role isn't admin"
+        return projectComps
+
+    -- If project is local, find it in our DB
+    -- If project is remote, HTTP GET it 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.
+    projectDB <-
+        bitraverse
+            (withDBExcept . flip getEntityE "Project not found in DB")
+            (\ u@(ObjURI h luComps) -> do
+                manager <- asksEnv envHttpManager
+                collection <-
+                    ExceptT $ first T.pack <$>
+                        AP.fetchAPID
+                            manager
+                            (AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI)
+                            h
+                            luComps
+                luProject <- fromMaybeE (AP.collectionContext collection) "Collection has no context"
+                project <-
+                    ExceptT $ first T.pack <$>
+                        AP.fetchAPID manager (AP.actorId . AP.actorLocal . AP.projectActor) h luProject
+                unless (AP.projectComponents project == luComps) $
+                    throwE "The collection isn't the project's components collection"
+
+                instanceID <-
+                    lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+                result <-
+                    ExceptT $ first (T.pack . displayException) <$>
+                        fetchRemoteActor' instanceID h luProject
+                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
+                        unless (remoteActorType (entityVal actor) == AP.ActorTypeProject) $
+                            throwE "Remote project type isn't Project"
+                        return $ entityKey actor
+            )
+            projectComps
+
+    maybeNew <- withDBExcept $ do
+
+        -- Grab me from DB
+        (deck, actor) <- lift $ do
+            d <- getJust deckID
+            (d,) <$> getJust (deckActor d)
+
+        -- Find existing Stem records I have for this project
+        -- Make sure none are enabled / in Add-Accept mode / in Invite-Accept
+        -- mode
+        checkExistingStems deckID projectDB
+
+        -- Verify the specified capability gives relevant access
+        verifyCapability'
+            capability authorIdMsig (GrantResourceDeck deckID) AP.RoleAdmin
+
+        -- Insert the Add to my inbox
+        mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actor) False
+        lift $ for mractid $ \ addDB -> do
+
+            -- Create a Stem record in DB
+            acceptID <- insertEmptyOutboxItem' (actorOutbox actor) now
+            insertStem projectDB addDB acceptID
+
+            -- Prepare forwarding Add to my followers
+            sieve <- do
+                deckHash <- encodeKeyHashid deckID
+                return $ makeRecipientSet [] [LocalStageDeckFollowers deckHash]
+
+            -- Prepare an Accept activity and insert to my outbox
+            accept@(actionAccept, _, _, _) <- prepareAccept projectDB
+            _luAccept <- updateOutboxItem' (LocalActorDeck deckID) acceptID actionAccept
+
+            return (deckActor deck, sieve, acceptID, accept)
+
+    case maybeNew of
+        Nothing -> done "I already have this activity in my inbox"
+        Just (actorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do
+            forwardActivity
+                authorIdMsig body (LocalActorDeck deckID) actorID sieve
+            lift $ sendActivity
+                (LocalActorDeck deckID) actorID localRecipsAccept
+                remoteRecipsAccept fwdHostsAccept acceptID actionAccept
+            done "Recorded and forwarded the Add, sent an Accept"
+
+    where
+
+    insertStem projectDB addDB acceptID = do
+        stemID <- insert $ Stem AP.RoleAdmin
+        insert_ $ StemIdentDeck stemID deckID
+        case projectDB of
+            Left (Entity projectID _) ->
+                insert_ $ StemProjectLocal stemID projectID
+            Right remoteActorID ->
+                insert_ $ StemProjectRemote stemID remoteActorID
+        insert_ $ StemOriginAdd stemID
+        case addDB of
+            Left (_, _, addID) ->
+                insert_ $ StemComponentGestureLocal stemID addID
+            Right (author, _, addID) ->
+                insert_ $ StemComponentGestureRemote stemID (remoteAuthorId author) addID
+        insert_ $ StemComponentAccept stemID acceptID
+
+    prepareAccept projectDB = do
+        encodeRouteHome <- getEncodeRouteHome
+
+        audAdder <- makeAudSenderWithFollowers authorIdMsig
+        audProject <-
+            case projectDB of
+                Left (Entity j _) -> do
+                    jh <- encodeKeyHashid j
+                    return $
+                        AudLocal
+                            [LocalActorProject jh]
+                            [LocalStageProjectFollowers jh]
+                Right remoteActorID -> do
+                    ra <- getJust remoteActorID
+                    ObjURI h lu <- getRemoteActorURI ra
+                    return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
+        audComponent <-
+            AudLocal [] . pure . LocalStageDeckFollowers <$>
+                encodeKeyHashid deckID
+        uAdd <- lift $ getActivityURI authorIdMsig
+
+        let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience [audAdder, audProject, audComponent]
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            action = AP.Action
+                { AP.actionCapability = Nothing
+                , AP.actionSummary    = Nothing
+                , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                , AP.actionFulfills   = [uAdd]
+                , AP.actionSpecific   = AP.AcceptActivity AP.Accept
+                    { AP.acceptObject   = uAdd
+                    , AP.acceptResult   = Nothing
+                    }
+                }
+
+        return (action, recipientSet, remoteActors, fwdHosts)
+
 -- Meaning: Someone has created a ticket tracker with my ID URI
 -- Behavior:
 --     * Verify I'm in a just-been-created state
@@ -472,6 +753,7 @@ deckBehavior :: UTCTime -> DeckId -> VerseExt -> ActE (Text, Act (), Next)
 deckBehavior now deckID (Left verse@(Verse _authorIdMsig body)) =
     case AP.activitySpecific $ actbActivity body of
         AP.AcceptActivity accept -> deckAccept now deckID verse accept
+        AP.AddActivity add       -> deckAdd now deckID verse add
         AP.CreateActivity create -> deckCreate now deckID verse create
         AP.FollowActivity follow -> deckFollow now deckID verse follow
         AP.InviteActivity invite -> deckInvite now deckID verse invite