From a41356c2613a41b07427cd5a188dd824a69713eb Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sat, 10 Jun 2023 10:51:01 +0300 Subject: [PATCH] Upon account verification, launch the Person actor --- src/Vervis/Actor.hs | 15 ++++++++++++++ src/Vervis/Actor/Deck.hs | 5 ++++- src/Vervis/Actor/Group.hs | 5 ++++- src/Vervis/Actor/Loom.hs | 5 ++++- src/Vervis/Actor/Person.hs | 5 ++++- src/Vervis/Actor/Repo.hs | 5 ++++- src/Vervis/Application.hs | 41 +++++++++++++++++++++++++++----------- src/Vervis/Foundation.hs | 14 ++++++++++++- 8 files changed, 77 insertions(+), 18 deletions(-) diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs index e308629..87f1b86 100644 --- a/src/Vervis/Actor.hs +++ b/src/Vervis/Actor.hs @@ -71,6 +71,9 @@ module Vervis.Actor , withDB , withDBExcept , behave + , VervisActor (..) + , launchActorIO + , launchActor , RemoteRecipient (..) , sendToLocalActors @@ -439,6 +442,18 @@ behave handler key msg = do Left e -> done $ Left e Right (t, after, next) -> return (Right t, after, next) +class VervisActor a where + actorBehavior :: UTCTime -> Key a -> Verse -> ActE (Text, Act (), Next) + +launchActorIO :: VervisActor a => Theater -> Env -> (Key a -> LocalActorBy Key) -> Key a -> IO Bool +launchActorIO theater env mk key = + spawnIO theater (mk key) (pure env) $ behave actorBehavior key + +launchActor :: forall a. VervisActor a => (Key a -> LocalActorBy Key) -> Key a -> Act Bool +launchActor mk key = do + e <- askEnv + spawn (mk key) (pure e) $ behave actorBehavior key + data RemoteRecipient = RemoteRecipient { remoteRecipientActor :: RemoteActorId , remoteRecipientId :: LocalURI diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index 27a2731..1643acf 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/src/Vervis/Actor/Deck.hs @@ -14,7 +14,7 @@ -} module Vervis.Actor.Deck - ( deckBehavior + ( ) where @@ -443,3 +443,6 @@ deckBehavior now deckID (Right (VerseRemote author body mfwd luActivity)) = AP.UndoActivity undo -> deckUndo now deckID author body mfwd luActivity undo _ -> throwE "Unsupported activity type for Deck" + +instance VervisActor Deck where + actorBehavior = deckBehavior diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index 29506ba..475b8ea 100644 --- a/src/Vervis/Actor/Group.hs +++ b/src/Vervis/Actor/Group.hs @@ -14,7 +14,7 @@ -} module Vervis.Actor.Group - ( groupBehavior + ( ) where @@ -62,3 +62,6 @@ groupBehavior now groupID (Left event) = groupBehavior now groupID (Right (VerseRemote author body mfwd luActivity)) = case AP.activitySpecific $ actbActivity body of _ -> throwE "Unsupported activity type for Group" + +instance VervisActor Group where + actorBehavior = groupBehavior diff --git a/src/Vervis/Actor/Loom.hs b/src/Vervis/Actor/Loom.hs index 3d478d9..cb8decc 100644 --- a/src/Vervis/Actor/Loom.hs +++ b/src/Vervis/Actor/Loom.hs @@ -14,7 +14,7 @@ -} module Vervis.Actor.Loom - ( loomBehavior + ( ) where @@ -62,3 +62,6 @@ loomBehavior now loomID (Left event) = loomBehavior now loomID (Right (VerseRemote author body mfwd luActivity)) = case AP.activitySpecific $ actbActivity body of _ -> throwE "Unsupported activity type for Loom" + +instance VervisActor Loom where + actorBehavior = loomBehavior diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index 0240a0c..c162ff2 100644 --- a/src/Vervis/Actor/Person.hs +++ b/src/Vervis/Actor/Person.hs @@ -15,7 +15,7 @@ -} module Vervis.Actor.Person - ( personBehavior + ( ) where @@ -748,3 +748,6 @@ personBehavior now personID (Right (VerseRemote author body mfwd luActivity)) = AP.UndoActivity undo -> personUndo now personID author body mfwd luActivity undo _ -> throwE "Unsupported activity type for Person" + +instance VervisActor Person where + actorBehavior = personBehavior diff --git a/src/Vervis/Actor/Repo.hs b/src/Vervis/Actor/Repo.hs index 74194ff..313ec9c 100644 --- a/src/Vervis/Actor/Repo.hs +++ b/src/Vervis/Actor/Repo.hs @@ -14,7 +14,7 @@ -} module Vervis.Actor.Repo - ( repoBehavior + ( ) where @@ -62,3 +62,6 @@ repoBehavior now repoID (Left event) = repoBehavior now repoID (Right (VerseRemote author body mfwd luActivity)) = case AP.activitySpecific $ actbActivity body of _ -> throwE "Unsupported activity type for Repo" + +instance VervisActor Repo where + actorBehavior = repoBehavior diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index dd6cb49..86072d9 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -33,7 +33,9 @@ module Vervis.Application ) where +import Control.Concurrent import Control.Concurrent.Chan +import Control.Concurrent.MVar import Control.Concurrent.STM import Control.Concurrent.STM.TVar import Control.Exception hiding (Handler) @@ -206,7 +208,9 @@ makeFoundation appSettings = do appConnPool appCapSignKey appHashidsContext - appTheater = + appTheater + appEnv + appPersonLauncher = App {..} -- The App {..} syntax is an example of record wild cards. For more -- information, see: @@ -217,6 +221,8 @@ makeFoundation appSettings = do (error "capSignKey forced in tempFoundation") (error "hashidsContext forced in tempFoundation") (error "theater forced in tempFoundation") + (error "env forced in tempFoundation") + (error "launcher forced in tempFoundation") logFunc = loggingFunction tempFoundation -- Create the database connection pool @@ -231,7 +237,7 @@ makeFoundation appSettings = do hashidsSalt <- loadKeyFile loadMode $ appHashidsSaltFile appSettings let hashidsCtx = hashidsContext hashidsSalt - app = mkFoundation pool capSignKey hashidsCtx (error "theater") + app = mkFoundation pool capSignKey hashidsCtx (error "theater") (error "env") (error "launcher") -- Perform database migration using our application's logging settings. --runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc @@ -259,6 +265,7 @@ makeFoundation appSettings = do env = Env appSettings pool hashidsCtx appActorKeys delivery render appHttpManager appActorFetchShare actors <- flip runWorker app $ runSiteDB $ loadTheater env theater <- startTheater logFunc actors + launcher <- startPersonLauncher theater env let hostString = T.unpack $ renderAuthority hLocal writeHookConfig hostString Config @@ -268,7 +275,7 @@ makeFoundation appSettings = do } -- Return the foundation - return app { appTheater = theater } + return app { appTheater = theater, appEnv = env, appPersonLauncher = launcher } where verifyRepoDir = do repos <- lift reposFromDir @@ -337,22 +344,32 @@ makeFoundation appSettings = do loadTheater :: Env -> WorkerDB [(LocalActorBy Key, Env, Verse -> Act (Either Text Text, Act (), Next))] loadTheater env = concat <$> sequenceA - [ selectAll LocalActorPerson personBehavior - , selectAll LocalActorGroup groupBehavior - , selectAll LocalActorRepo repoBehavior - , selectAll LocalActorDeck deckBehavior - , selectAll LocalActorLoom loomBehavior + [ selectAll LocalActorPerson + , selectAll LocalActorGroup + , selectAll LocalActorRepo + , selectAll LocalActorDeck + , selectAll LocalActorLoom ] where selectAll - :: PersistRecordBackend a SqlBackend + :: (PersistRecordBackend a SqlBackend, VervisActor a) => (Key a -> LocalActorBy Key) - -> (UTCTime -> Key a -> Verse -> ActE (Text, Act (), Next)) -> WorkerDB [(LocalActorBy Key, Env, Verse -> Act (Either Text Text, Act (), Next))] - selectAll makeLocalActor behavior = - map (\ xid -> (makeLocalActor xid, env, behave behavior xid)) <$> + selectAll makeLocalActor = + map (\ xid -> (makeLocalActor xid, env, behave actorBehavior xid)) <$> selectKeysList [] [] + startPersonLauncher :: Theater -> Env -> IO (MVar (PersonId, MVar Bool)) + startPersonLauncher theater env = do + mvar <- newEmptyMVar + _ <- forkIO $ forever $ handle mvar + return mvar + where + handle mvar = do + (personID, sendResult) <- takeMVar mvar + success <- launchActorIO theater env LocalActorPerson personID + putMVar sendResult success + -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and -- applying some additional middlewares. makeApplication :: App -> IO Application diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index c210e3d..bc73202 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -18,6 +18,7 @@ module Vervis.Foundation where import Control.Applicative import Control.Concurrent.Chan +import Control.Concurrent.MVar import Control.Concurrent.STM.TVar import Control.Monad import Control.Monad.Logger.CallStack (logWarn) @@ -133,6 +134,8 @@ data App = App , appHookSecret :: HookSecret , appActorFetchShare :: ActorFetchShare , appTheater :: Theater + , appEnv :: Env + , appPersonLauncher :: MVar (PersonId, MVar Bool) , appActivities :: Maybe (Int, TVar (Vector ActivityReport)) } @@ -690,7 +693,16 @@ instance AccountDB AccountPersistDB' where return $ Left $ mr $ MsgUsernameExists name Right pid -> return $ Right $ Entity pid person - verifyAccount = morphAPDB . verifyAccount + verifyAccount eperson@(Entity personID _) = do + morphAPDB $ verifyAccount eperson + success <- AccountPersistDB' $ do + mvarSend <- asksSite appPersonLauncher + liftIO $ do + mvarResult <- newEmptyMVar + putMVar mvarSend (personID, mvarResult) + takeMVar mvarResult + unless success $ + error "Failed to spawn new Person, somehow ID already in Theater" setVerifyKey = (morphAPDB .) . setVerifyKey setNewPasswordKey = (morphAPDB .) . setNewPasswordKey setNewPassword = (morphAPDB .) . setNewPassword