diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index 3424ddf..b13bb0c 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/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