Upon account verification, launch the Person actor

This commit is contained in:
Pere Lev 2023-06-10 10:51:01 +03:00
parent 59e99f405a
commit a41356c261
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
8 changed files with 77 additions and 18 deletions

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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