Upon account verification, launch the Person actor

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

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

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

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

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

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

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 LocalActorPerson
-        , selectAll LocalActorGroup  groupBehavior
+        , selectAll LocalActorGroup
-        , selectAll LocalActorRepo   repoBehavior
+        , selectAll LocalActorRepo
-        , selectAll LocalActorDeck   deckBehavior
+        , selectAll LocalActorDeck
-        , selectAll LocalActorLoom   loomBehavior
+        , 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 =
+        selectAll makeLocalActor =
-            map (\ xid -> (makeLocalActor xid, env, behave behavior xid)) <$>
+            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

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