From cdc97dcb8b806dc6fb2f1971c7a3045fa7f66bfd Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Thu, 22 Aug 2024 20:54:31 +0300 Subject: [PATCH] Actor system: Implement internal auto-increasing actor IDs --- .gitignore | 2 + src/Control/Concurrent/Actor.hs | 504 ++++++++++++++++++++++-------- src/Vervis/API.hs | 15 +- src/Vervis/Actor.hs | 286 +++++++++++------ src/Vervis/Actor/Factory.hs | 27 +- src/Vervis/Actor/Person/Client.hs | 2 +- src/Vervis/Application.hs | 46 ++- src/Vervis/Foundation.hs | 22 +- src/Vervis/Recipient.hs | 2 +- src/Vervis/RemoteActorStore.hs | 5 +- src/Vervis/Ssh.hs | 50 +-- src/Vervis/Web/Actor.hs | 75 +++-- src/Web/Actor/Deliver.hs | 37 ++- 13 files changed, 767 insertions(+), 306 deletions(-) diff --git a/.gitignore b/.gitignore index cae71c3..1a8670b 100644 --- a/.gitignore +++ b/.gitignore @@ -22,3 +22,5 @@ config/ssh-host-key.pub lib/ repos/ delivery-states/ +actor-counter.sqlite3 +delivery-counter.sqlite3 diff --git a/src/Control/Concurrent/Actor.hs b/src/Control/Concurrent/Actor.hs index 6516400..0522bb2 100644 --- a/src/Control/Concurrent/Actor.hs +++ b/src/Control/Concurrent/Actor.hs @@ -50,6 +50,7 @@ module Control.Concurrent.Actor , MethodHandler (..) -- * Implementing an actor + , SpawnMode (AllowSpawn) , Stage (..) , Actor (..) , Next () @@ -67,6 +68,7 @@ module Control.Concurrent.Actor -- * Calling actor methods , ActorHasMethod + , Ref () , callIO' , sendIO' , call' @@ -93,6 +95,8 @@ module Control.Concurrent.Actor , HAdaptHandler , Handler_ , Handle' + , ActorRefMap + , ActorRefMapTVar_ -- * Exported to allow some Yesod Handlers to reuse some actor actions , runActor @@ -124,9 +128,12 @@ import Control.Monad.Trans.Reader import Data.Foldable import Data.Hashable import Data.HashMap.Strict (HashMap) +import Data.Int +import Data.Maybe import Data.Proxy import Data.Text (Text) import Data.Traversable +import Database.Persist.Sql (PersistField (..), PersistFieldSql (..)) import GHC.TypeLits import UnliftIO.Exception @@ -137,6 +144,7 @@ import qualified Data.Text as T import qualified Vary as V import Control.Concurrent.Return +import Database.Persist.Box --------------------------- Defining method types ---------------------------- @@ -243,17 +251,20 @@ handleMethod = Proxy -- done True -- @ data MethodHandler (actor :: Type) (sym :: Symbol) (sig :: Signature) = - Proxy sym := (ActorKey actor -> HandlerSig (ActorStage actor) sig) + Proxy sym := (ActorIdentity actor -> HandlerSig (ActorStage actor) sig) --------------------------- Implementing an actor ---------------------------- -class Stage (a :: Type) where +data SpawnMode = NoSpawn | AllowSpawn + +class KnownSpawnMode (StageSpawn a) => Stage (a :: Type) where data StageEnv a :: Type type StageActors a :: [Type] + type StageSpawn a :: SpawnMode class Actor (a :: Type) where type ActorStage a :: Type - type ActorKey a = (k :: Type) | k -> a + type ActorIdentity a :: Type type ActorInterface a :: [Method] data Next = Stop | Proceed @@ -266,15 +277,23 @@ class Actor a => ActorLaunch a where type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () -type ActorRefMap a = HashMap (ActorKey a) (ActorRef a) +type ActorRefMap a = HashMap (Ref a) (ActorRef a) data ActorRefMapTVar_ :: Type -> Exp Type type instance Eval (ActorRefMapTVar_ a) = TVar (ActorRefMap a) +type ActorInt = Int64 + +type TheaterCounter :: SpawnMode -> Type +type family TheaterCounter mode = t | t -> mode where + TheaterCounter NoSpawn = () + TheaterCounter AllowSpawn = (TheaterFor (ACounterStage ActorInt), Ref (ACounter ActorInt)) + -- | A set of live actors responding to messages data TheaterFor s = TheaterFor - { theaterMap :: HList (Eval (Map ActorRefMapTVar_ (StageActors s))) - , theaterLog :: LogFunc + { theaterMap :: HList (Eval (Map ActorRefMapTVar_ (StageActors s))) + , theaterLog :: LogFunc + , theaterCounter :: TheaterCounter (StageSpawn s) } -- | Actor monad in which message reponse actions are executed. Supports @@ -541,15 +560,14 @@ askTheater :: ActFor s (TheaterFor s) askTheater = ActFor $ lift $ asks snd lookupActor - :: ( Eq (ActorKey a), Hashable (ActorKey a) - , H.HOccurs + :: ( H.HOccurs (TVar (ActorRefMap a)) (HList (Eval (Map ActorRefMapTVar_ (StageActors s)))) ) => TheaterFor s - -> ActorKey a + -> Ref a -> IO (Maybe (ActorRef a)) -lookupActor (TheaterFor hlist _) key = +lookupActor (TheaterFor hlist _ _) key = HM.lookup key <$> readTVarIO (H.hOccurs hlist) {- @@ -582,7 +600,6 @@ callIO' (sig::Signature) (stage::Type) . ( Actor a - , Eq (ActorKey a), Hashable (ActorKey a) , m ~ (sym ::: sig) --, Eval (LookupSig sym (ActorInterface a)) ~ Just sig --, Eval (Parcel_ m) V.:| Eval (Map Parcel_ (ActorInterface a)) @@ -593,7 +610,7 @@ callIO' ) => TheaterFor stage -> Proxy m - -> ActorKey a + -> Ref a -> HList (SignatureParams sig) -> IO (Maybe (SignatureReturn sig)) callIO' theater proxy key args = do @@ -617,7 +634,6 @@ sendIO' (sig::Signature) (stage::Type) . ( Actor a - , Eq (ActorKey a), Hashable (ActorKey a) , m ~ (sym ::: sig) , Eval (LookupSig sym (ActorInterface a)) ~ Just sig , Eval (Parcel_ m) V.:| Eval (Map Parcel_ (ActorInterface a)) @@ -627,7 +643,7 @@ sendIO' ) => TheaterFor stage -> Proxy m - -> ActorKey a + -> Ref a -> HList (SignatureParams sig) -> IO Bool sendIO' theater proxy key args = do @@ -654,7 +670,6 @@ call' (stage::Type) (monad :: Type -> Type) . ( Actor a - , Eq (ActorKey a), Hashable (ActorKey a) , m ~ (sym ::: sig) , Eval (LookupSig sym (ActorInterface a)) ~ Just sig , Eval (Parcel_ m) V.:| Eval (Map Parcel_ (ActorInterface a)) @@ -666,12 +681,12 @@ call' , MonadActorStage monad ~ stage ) => Proxy m - -> ActorKey a + -> Ref a -> HList (SignatureParams sig) -> monad (Maybe (SignatureReturn sig)) -call' proxy key args = liftActor $ do +call' proxy ref args = liftActor $ do theater <- askTheater - liftIO $ callIO' theater proxy key args + liftIO $ callIO' theater proxy ref args -- | Like 'send', except a Proxy is passed to specify the method's name, and -- arguments are passed as a 'HList'. @@ -684,7 +699,6 @@ send' (stage::Type) (monad :: Type -> Type) . ( Actor a - , Eq (ActorKey a), Hashable (ActorKey a) , m ~ (sym ::: sig) , Eval (LookupSig sym (ActorInterface a)) ~ Just sig , Eval (Parcel_ m) V.:| Eval (Map Parcel_ (ActorInterface a)) @@ -696,7 +710,7 @@ send' , MonadActorStage monad ~ stage ) => Proxy m - -> ActorKey a + -> Ref a -> HList (SignatureParams sig) -> monad Bool send' proxy key args = liftActor $ do @@ -730,7 +744,7 @@ type family CallSig (stage :: Type) (signature :: Signature) = (a :: Type) | a - CallSig s (t :-> sig) = t -> CallSig s sig class ActorMethodCall (sym :: Symbol) (actor :: Type) (params :: [Type]) (result :: Type) where - actorMethodCall :: ActorKey actor -> HList params -> result + actorMethodCall :: Ref actor -> HList params -> result instance forall @@ -744,7 +758,6 @@ instance (params :: [Type]) (paramsRev :: [Type]) . ( Actor a - , Eq (ActorKey a), Hashable (ActorKey a) , Eval (LookupSig sym (ActorInterface a)) ~ Just sig , m ~ (sym ::: sig) , ret ~ SignatureReturn sig @@ -781,7 +794,7 @@ call , Eval (LookupSig sym (ActorInterface actor)) ~ Just sig , r ~ CallSig (ActorStage actor) sig ) - => ActorKey actor + => Ref actor -> r call key = actorMethodCall @sym key HNil @@ -790,7 +803,7 @@ type family SendSig (stage :: Type) (signature :: Signature) = (a :: Type) | a - SendSig s (t :-> sig) = t -> SendSig s sig class ActorMethodSend (sym :: Symbol) (actor :: Type) (params :: [Type]) (result :: Type) where - actorMethodSend :: ActorKey actor -> HList params -> result + actorMethodSend :: Ref actor -> HList params -> result instance forall @@ -803,7 +816,6 @@ instance (params :: [Type]) (paramsRev :: [Type]) . ( Actor a - , Eq (ActorKey a), Hashable (ActorKey a) , Eval (LookupSig sym (ActorInterface a)) ~ Just sig , m ~ (sym ::: sig) , Eval (Parcel_ m) V.:| Eval (Map Parcel_ (ActorInterface a)) @@ -839,7 +851,7 @@ send , Eval (LookupSig sym (ActorInterface actor)) ~ Just sig , r ~ SendSig (ActorStage actor) sig ) - => ActorKey actor + => Ref actor -> r send key = actorMethodSend @sym key HNil @@ -912,24 +924,24 @@ uncurryHandler = uncurryH adaptHandler :: ( ActorStage actor ~ stage - , Show (ActorKey actor) , KnownSymbol sym , UncurryH (SignatureParams sig) (HandlerSig stage sig) (HandlerAction stage (SignatureReturn sig)) ) - => ActorKey actor + => Ref actor + -> ActorIdentity actor -> MethodHandler actor sym sig -> (Proxy sym, Parcel sig) -> (AdaptedAction (ActorStage actor), Text) -adaptHandler key (Proxy := handler) (p@Proxy, Parcel args respond) = +adaptHandler ref ident (Proxy := handler) (p@Proxy, Parcel args respond) = (go, prefixOn) where - prefix = T.concat ["[Actor '", T.pack $ show key, "']"] + prefix = T.concat ["[Actor '", T.pack $ show ref, "']"] prefixOn = T.concat [prefix, " on ", T.pack $ symbolVal p] go = do - result <- try $ uncurryHandler (handler key) args + result <- try $ uncurryHandler (handler ident) args case result of Left e -> do logError $ T.concat [prefix, " exception: ", T.pack $ displayException (e :: SomeException)] @@ -942,11 +954,10 @@ adaptHandler key (Proxy := handler) (p@Proxy, Parcel args respond) = -- This is for adaptHandler to work with hMapL -data HAdaptHandler a = HAdaptHandler (ActorKey a) +data HAdaptHandler a = HAdaptHandler (Ref a) (ActorIdentity a) instance ( ActorStage actor ~ stage - , Show (ActorKey actor) , KnownSymbol sym , UncurryH (SignatureParams sig) @@ -956,12 +967,11 @@ instance , o ~ ( (Proxy sym, Parcel sig) -> (AdaptedAction stage, Text) ) ) => H.ApplyAB (HAdaptHandler actor) i o where - applyAB (HAdaptHandler key) = adaptHandler key + applyAB (HAdaptHandler ref ident) = adaptHandler ref ident data AdaptHandlerConstraint :: Type -> Method -> Exp Constraint type instance Eval (AdaptHandlerConstraint actor (sym ::: sig)) = - ( Show (ActorKey actor) - , KnownSymbol sym + ( KnownSymbol sym , UncurryH (SignatureParams sig) (HandlerSig (ActorStage actor) sig) @@ -976,12 +986,10 @@ type instance Eval (AdaptedHandler stage (sym ::: sig)) = (Proxy sym, Parcel sig) -> (AdaptedAction stage, Text) launchActorThread - :: forall (a::Type) (k::Type) (s::Type) (ms::[Method]) . + :: forall (a::Type) (s::Type) (ms::[Method]) . ( ActorLaunch a , ActorStage a ~ s - , ActorKey a ~ k , ActorInterface a ~ ms - , Eq k, Hashable k, Show k , H.HOccurs (TVar (ActorRefMap a)) (HList (Eval (Map ActorRefMapTVar_ (StageActors s)))) @@ -1011,14 +1019,15 @@ launchActorThread ) ) ) - => Chan (Invocation ms) + => Ref a + -> Chan (Invocation ms) -> TheaterFor s - -> k + -> ActorIdentity a -> StageEnv s -> IO () -launchActorThread chan theater actor env = +launchActorThread ref chan theater actor env = void $ forkIO $ runActor theater env $ do - let handlers' = H.hMapL (HAdaptHandler actor) handlers :: HList (Eval (Map (AdaptedHandler s) ms)) + let handlers' = H.hMapL (HAdaptHandler ref actor) handlers :: HList (Eval (Map (AdaptedHandler s) ms)) logInfo $ prefix <> " starting" loop handlers' logInfo $ prefix <> " bye" @@ -1026,7 +1035,7 @@ launchActorThread chan theater actor env = handlers :: HList (Eval (Map (Handler_ a) ms)) handlers = actorBehavior (Proxy @a) - prefix = T.concat ["[Actor '", T.pack $ show actor, "']"] + prefix = T.concat ["[Actor '", T.pack $ show ref, "']"] loop :: HList (Eval (Map (AdaptedHandler s) ms)) -> ActFor s () loop handlers' = do @@ -1044,7 +1053,7 @@ launchActorThread chan theater actor env = logInfo $ T.concat [prefixOn, " stopping"] let tvar = H.hOccurs (theaterMap theater) :: TVar (ActorRefMap a) - liftIO $ atomically $ modifyTVar' tvar $ HM.delete actor + liftIO $ atomically $ modifyTVar' tvar $ HM.delete ref return False Proceed -> do @@ -1054,12 +1063,12 @@ launchActorThread chan theater actor env = -- | Same as 'spawn', except it takes the theater as a parameter. spawnIO - :: forall (a::Type) (k::Type) (s::Type) (ms::[Method]) . + :: forall (a::Type) (s::Type) (ms::[Method]) . ( ActorLaunch a , ActorStage a ~ s - , ActorKey a ~ k + , Stage s + , StageSpawn s ~ AllowSpawn , ActorInterface a ~ ms - , Eq k, Hashable k, Show k , H.HOccurs (TVar (ActorRefMap a)) (HList (Eval (Map ActorRefMapTVar_ (StageActors s)))) @@ -1090,36 +1099,30 @@ spawnIO ) ) => TheaterFor s - -> ActorKey a + -> ActorIdentity a -> IO (StageEnv s) - -> IO Bool -spawnIO theater@(TheaterFor hlist _) key mkEnv = do + -> IO (Ref a) +spawnIO theater@(TheaterFor hlist _ (acounterTheater, acounterRef)) ident mkEnv = do let tvar = H.hOccurs hlist :: TVar (ActorRefMap a) chan <- newChan - added <- atomically $ stateTVar tvar $ \ hm -> - let hm' = HM.alter (create $ ActorRef $ ActorRef' chan) key hm - in ( not (HM.member key hm) && HM.member key hm' - , hm' - ) - when added $ do - env <- mkEnv - launchActorThread chan theater key env - return added - where - create actor Nothing = Just actor - create _ j@(Just _) = j + next <- fromJust <$> callIO' @"next" acounterTheater Proxy acounterRef HNil + let ref = Ref next + atomically $ modifyTVar' tvar $ HM.insert ref (ActorRef $ ActorRef' chan) + env <- mkEnv + launchActorThread ref chan theater ident env + return ref -- | Launch a new actor with the given ID and behavior. Return 'True' if the ID -- was unused and the actor has been launched. Return 'False' if the ID is -- already in use, thus a new actor hasn't been launched. spawn - :: forall (m::Type->Type) (a::Type) (k::Type) (s::Type) (ms::[Method]) . + :: forall (a::Type) (m::Type->Type) (s::Type) (ms::[Method]) . ( MonadActor m, MonadActorStage m ~ s , ActorLaunch a , ActorStage a ~ s - , ActorKey a ~ k + , Stage s + , StageSpawn s ~ AllowSpawn , ActorInterface a ~ ms - , Eq k, Hashable k, Show k , H.HOccurs (TVar (ActorRefMap a)) (HList (Eval (Map ActorRefMapTVar_ (StageActors s)))) @@ -1149,22 +1152,20 @@ spawn ) ) ) - => ActorKey a + => ActorIdentity a -> IO (StageEnv s) - -> m Bool -spawn key mkEnv = liftActor $ do + -> m (Ref a) +spawn ident mkEnv = liftActor $ do theater <- askTheater - liftIO $ spawnIO theater key mkEnv + liftIO $ spawnIO theater ident mkEnv --------------------------- Launching the actor system ----------------------- prepareActorType - :: forall (a::Type) (k::Type) (s::Type) (ms::[Method]) . + :: forall (a::Type) (s::Type) (ms::[Method]) . ( ActorLaunch a , ActorStage a ~ s - , ActorKey a ~ k , ActorInterface a ~ ms - , Eq k, Hashable k, Show k , H.HOccurs (TVar (ActorRefMap a)) (HList (Eval (Map ActorRefMapTVar_ (StageActors s)))) @@ -1195,34 +1196,40 @@ prepareActorType ) , Stage s ) - => [(k, StageEnv s)] + => TheaterCounter (StageSpawn s) + -> [(ActorIdentity a, StageEnv s)] -> IO - ( TVar (ActorRefMap a) - , TheaterFor s -> IO () + ( ( TVar (ActorRefMap a) + , TheaterFor s -> IO () + ) + , [(ActorIdentity a, Ref a)] ) -prepareActorType actors = do - actorsWithChans <- for actors $ \ (key, env) -> do +prepareActorType counter actors = do + refs <- produceRefs counter $ length actors + let actorsWithRefs = zip actors refs + actorsWithChans <- for actorsWithRefs $ \ ((ident, env), ref) -> do chan <- newChan - return (key, env, chan) + return (ref, ident, env, chan) tvar <- newTVarIO $ HM.fromList $ map - (\ (key, _, chan) -> (key, ActorRef $ ActorRef' chan)) + (\ (ref, _, _, chan) -> (ref, ActorRef $ ActorRef' chan)) actorsWithChans return - ( tvar - , \ theater -> for_ actorsWithChans $ \ (key, env, chan) -> - launchActorThread chan theater key env + ( ( tvar + , \ theater -> for_ actorsWithChans $ \ (ref, ident, env, chan) -> + launchActorThread ref chan theater ident env + ) + , map (\ (ref, ident, _, _) -> (ident, ref)) actorsWithChans ) -data HPrepareActorType = HPrepareActorType +data HPrepareActorType (sm::SpawnMode) = HPrepareActorType (TheaterCounter sm) instance - forall (a::Type) (k::Type) (s::Type) (ms::[Method]) (i::Type) (o::Type). + forall (a::Type) (s::Type) (sm::SpawnMode) (ms::[Method]) (i::Type) (o::Type). ( ActorLaunch a , ActorStage a ~ s - , ActorKey a ~ k + , StageSpawn s ~ sm , ActorInterface a ~ ms - , Eq k, Hashable k, Show k , H.HOccurs (TVar (ActorRefMap a)) (HList (Eval (Map ActorRefMapTVar_ (StageActors s)))) @@ -1252,16 +1259,15 @@ instance ) ) , Stage s - , i ~ [(k, StageEnv s)] - , o ~ IO (TVar (ActorRefMap a), TheaterFor s -> IO ()) + , i ~ [(ActorIdentity a, StageEnv s)] + , o ~ IO ((TVar (ActorRefMap a), TheaterFor s -> IO ()), [(ActorIdentity a, Ref a)]) ) => - H.ApplyAB HPrepareActorType i o where - applyAB _ a = prepareActorType a + H.ApplyAB (HPrepareActorType sm) i o where + applyAB (HPrepareActorType counter) a = prepareActorType counter a data A_ :: Type -> Exp Constraint type instance Eval (A_ a) = ( ActorLaunch a - , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a) , H.HOccurs (TVar (ActorRefMap a)) (HList (Eval (Map ActorRefMapTVar_ (StageActors (ActorStage a))))) @@ -1293,19 +1299,42 @@ type instance Eval (A_ a) = ) data Starter :: Type -> Exp Type -type instance Eval (Starter a) = [(ActorKey a, StageEnv (ActorStage a))] +type instance Eval (Starter a) = [(ActorIdentity a, StageEnv (ActorStage a))] data Prepare_ :: Type -> Type -> Exp Type -type instance Eval (Prepare_ s a) = IO (TVar (ActorRefMap a), TheaterFor s -> IO ()) +type instance Eval (Prepare_ s a) = IO ((TVar (ActorRefMap a), TheaterFor s -> IO ()), [(ActorIdentity a, Ref a)]) data Pair_ :: Type -> Type -> Exp Type type instance Eval (Pair_ s a) = (TVar (ActorRefMap a), TheaterFor s -> IO ()) +data Triplet_ :: Type -> Type -> Exp Type +type instance Eval (Triplet_ s a) = ((TVar (ActorRefMap a), TheaterFor s -> IO ()), [(ActorIdentity a, Ref a)]) + data Launch_ :: Type -> Type -> Exp Type type instance Eval (Launch_ s _) = TheaterFor s -> IO () --- | Launch the actor system -startTheater +data Finisher :: Type -> Exp Type +type instance Eval (Finisher a) = [(ActorIdentity a, Ref a)] + +class KnownSpawnMode (sm :: SpawnMode) where + type SpawnModeInput sm = (i :: Type) | i -> sm + loadCounter :: SpawnModeInput sm -> IO (TheaterCounter sm) + produceRefs :: TheaterCounter sm -> Int -> IO [Ref a] + +instance KnownSpawnMode NoSpawn where + type SpawnModeInput NoSpawn = () + loadCounter () = pure () + produceRefs () count = pure $ map Ref [0 .. toEnum count - 1] + +instance KnownSpawnMode AllowSpawn where + type SpawnModeInput AllowSpawn = (LogFunc, FilePath) + loadCounter (logFunc, pathA) = loadSingleACounterTheater logFunc pathA 0 + produceRefs (acounterTheater, acounterRef) count = + replicateM count $ + Ref . fromJust <$> + callIO' @"next" acounterTheater Proxy acounterRef HNil + +startTheater' :: forall (s :: Type) (as :: [Type]) . ( Stage s , StageActors s ~ as @@ -1313,54 +1342,107 @@ startTheater , H.HMapAux HList - HPrepareActorType + (HPrepareActorType (StageSpawn s)) (Eval (Map Starter as)) (Eval (Map (Prepare_ s) as)) - , H.SameLength' - (Eval (Map Starter as)) - (Eval (Map (Prepare_ s) as)) - , H.SameLength' - (Eval (Map (Prepare_ s) as)) - (Eval (Map Starter as)) - , H.HSequence - IO - (Eval (Map (Prepare_ s) as)) + IO (Eval (Map (Prepare_ s) as)) (Eval (Map (Triplet_ s) as)) + , H.HZipList (Eval (Map (Pair_ s) as)) - - , H.SameLength' - (Eval (Map ActorRefMapTVar_ as)) - (Eval (Map (Launch_ s) as)) - , H.SameLength' - (Eval (Map (Launch_ s) as)) - (Eval (Map ActorRefMapTVar_ as)) - - , H.SameLength' - (Eval (Map (Launch_ s) as)) - (Eval (Map (Pair_ s) as)) - , H.SameLength' - (Eval (Map (Pair_ s) as)) - (Eval (Map (Launch_ s) as)) - + (Eval (Map Finisher as)) + (Eval (Map (Triplet_ s) as)) , H.HZipList (Eval (Map ActorRefMapTVar_ as)) (Eval (Map (Launch_ s) as)) (Eval (Map (Pair_ s) as)) - , H.HList2List - (Eval (Map (Launch_ s) as)) - (TheaterFor s -> IO ()) + (Eval (Map (Launch_ s) as)) (TheaterFor s -> IO ()) + , H.SameLength' + (Eval (Map (Prepare_ s) as)) (Eval (Map Starter as)) + , H.SameLength' + (Eval (Map (Triplet_ s) as)) (Eval (Map Finisher as)) + , H.SameLength' + (Eval (Map (Launch_ s) as)) (Eval (Map (Pair_ s) as)) + , H.SameLength' + (Eval (Map Starter as)) (Eval (Map (Prepare_ s) as)) + , H.SameLength' + (Eval (Map (Pair_ s) as)) (Eval (Map Finisher as)) + , H.SameLength' + (Eval (Map (Launch_ s) as)) (Eval (Map ActorRefMapTVar_ as)) + , H.SameLength' + (Eval (Map Finisher as)) (Eval (Map (Pair_ s) as)) + , H.SameLength' + (Eval (Map (Pair_ s) as)) (Eval (Map (Launch_ s) as)) + , H.SameLength' + (Eval (Map Finisher as)) (Eval (Map (Triplet_ s) as)) + , H.SameLength' + (Eval (Map ActorRefMapTVar_ as)) (Eval (Map (Launch_ s) as)) ) - => LogFunc + => SpawnModeInput (StageSpawn s) + -> LogFunc -> HList (Eval (Map Starter as)) - -> IO (TheaterFor s) -startTheater logFunc actors = do - let actions = H.hMapL HPrepareActorType actors :: HList (Eval (Map (Prepare_ s) as)) - mapsAndLaunches <- H.hSequence actions :: IO (HList (Eval (Map (Pair_ s) as))) - let (maps :: HList (Eval (Map ActorRefMapTVar_ as)), launches :: HList (Eval (Map (Launch_ s) as))) = H.hUnzip mapsAndLaunches - theater = TheaterFor maps logFunc + -> IO (TheaterFor s, HList (Eval (Map Finisher as))) +startTheater' input logFunc actors = do + counter <- loadCounter input + let actions = H.hMapL (HPrepareActorType counter) actors :: HList (Eval (Map (Prepare_ s) as)) + mapsAndLaunchesAndResults <- H.hSequence actions :: IO (HList (Eval (Map (Triplet_ s) as))) + let (mapsAndLaunches :: HList (Eval (Map (Pair_ s) as)), results :: HList (Eval (Map Finisher as))) = H.hUnzip mapsAndLaunchesAndResults + (maps :: HList (Eval (Map ActorRefMapTVar_ as)), launches :: HList (Eval (Map (Launch_ s) as))) = H.hUnzip mapsAndLaunches + theater = TheaterFor maps logFunc counter for_ (H.hList2List launches) $ \ launch -> launch theater - return theater + return (theater, results) + +-- | Launch the actor system +startTheater + :: forall (s :: Type) (as :: [Type]) . + ( Stage s + , StageSpawn s ~ AllowSpawn + , StageActors s ~ as + , Eval (Constraints (Eval (Map A_ as))) + + , H.HMapAux + HList + (HPrepareActorType (StageSpawn s)) + (Eval (Map Starter as)) + (Eval (Map (Prepare_ s) as)) + , H.HSequence + IO (Eval (Map (Prepare_ s) as)) (Eval (Map (Triplet_ s) as)) + , H.HZipList + (Eval (Map (Pair_ s) as)) + (Eval (Map Finisher as)) + (Eval (Map (Triplet_ s) as)) + , H.HZipList + (Eval (Map ActorRefMapTVar_ as)) + (Eval (Map (Launch_ s) as)) + (Eval (Map (Pair_ s) as)) + , H.HList2List + (Eval (Map (Launch_ s) as)) (TheaterFor s -> IO ()) + , H.SameLength' + (Eval (Map (Prepare_ s) as)) (Eval (Map Starter as)) + , H.SameLength' + (Eval (Map (Triplet_ s) as)) (Eval (Map Finisher as)) + , H.SameLength' + (Eval (Map (Launch_ s) as)) (Eval (Map (Pair_ s) as)) + , H.SameLength' + (Eval (Map Starter as)) (Eval (Map (Prepare_ s) as)) + , H.SameLength' + (Eval (Map (Pair_ s) as)) (Eval (Map Finisher as)) + , H.SameLength' + (Eval (Map (Launch_ s) as)) (Eval (Map ActorRefMapTVar_ as)) + , H.SameLength' + (Eval (Map Finisher as)) (Eval (Map (Pair_ s) as)) + , H.SameLength' + (Eval (Map (Pair_ s) as)) (Eval (Map (Launch_ s) as)) + , H.SameLength' + (Eval (Map Finisher as)) (Eval (Map (Triplet_ s) as)) + , H.SameLength' + (Eval (Map ActorRefMapTVar_ as)) (Eval (Map (Launch_ s) as)) + ) + => FilePath + -> LogFunc + -> HList (Eval (Map Starter as)) + -> IO (TheaterFor s, HList (Eval (Map Finisher as))) +startTheater avarBoxPath logFunc = startTheater' (logFunc, avarBoxPath) logFunc @@ -1482,7 +1564,7 @@ sendManyIO => TheaterFor s -> HList (Eval (Map Set_ (StageActors s))) -> IO () -sendManyIO (TheaterFor hlist _) recips = +sendManyIO (TheaterFor hlist _ _) recips = let zipped = H.hZip hlist recips :: HList (Eval (Map Pair__ (StageActors s))) actions = H.hMapL HSendTo zipped @@ -1620,3 +1702,159 @@ data Parcel (s :: Signature') = Parcel } -} + +-- We're going to define a "simple value holder" actor, which is both a good +-- simple example for using the actor system itself, and will serve us for +-- holding vat and actor auto-increasing numbering. +-- +-- Let's start with the Box. + +newtype Cell a = Cell a +instance PersistField a => PersistField (Cell a) where + toPersistValue (Cell v) = toPersistValue v + fromPersistValue = fmap Cell . fromPersistValue + +instance PersistFieldSql a => PersistFieldSql (Cell a) where + sqlType = sqlType . fmap uncell + where + uncell (Cell v) = v + +instance PersistFieldSql a => BoxableVia (Cell a) where + type BV (Cell a) = BoxableField + +-- Let's use this Box in a new actor type, the value holder + +data AVarStage (a :: Type) + +instance Stage (AVarStage a) where + data StageEnv (AVarStage a) = AVarStageEnv (Box (Cell a)) + type StageActors (AVarStage a) = '[AVar a] + type StageSpawn (AVarStage a) = NoSpawn + +data AVar (a :: Type) + +instance Actor (AVar a) where + type ActorStage (AVar a) = AVarStage a + type ActorInterface (AVar a) = + [ "get" ::: Return a + , "put" ::: a :-> Return () + ] + type ActorIdentity (AVar a) = () + +instance PersistFieldSql a => ActorLaunch (AVar a) where + actorBehavior _ = + (handleMethod @"get" := \ () -> do + AVarStageEnv box <- askEnv + Cell val <- withBox box obtain + done val + ) + `HCons` + (handleMethod @"put" := \ () val -> do + AVarStageEnv box <- askEnv + withBox box $ bestow $ Cell val + done () + ) + `HCons` + HNil + +-- So, we want to load a theater with exactly one AVar + +loadSingleAVarTheater + :: PersistFieldSql a + => LogFunc + -> FilePath + -> a + -> IO (TheaterFor (AVarStage a), Ref (AVar a)) +loadSingleAVarTheater logFunc path initial = do + box <- flip runLoggingT logFunc $ loadBox path $ Cell initial + startStar () logFunc () (AVarStageEnv box) + +-- Now, we have an infinite loop problem: +-- +-- * Every theater needs an AVar, in order to auto-increase the key counter +-- * The AVar comes inside a Theater +-- +-- Solution: Instead of using a Theater, we're going to write a different +-- version specialized for our purpose here. A single-actor theater, that +-- doesn't need to count. But since ActFor uses a Theater, we're going to use +-- Theater as well, except we just rely on avoiding any spawning. + +startStar counter logFunc ident env = do + (theater, actors `HCons` HNil) <- startTheater' counter logFunc $ [(ident, env)] `HCons` HNil + ref <- + case actors of + [((), r)] -> pure r + _ -> error "startStar: Expected exactly one actor" + return (theater, ref) + +-- Now, we can't really use AVar here because we need increase to be atomic, +-- and AVar has only 'get' and 'put'. We could write a whole new actor type for +-- this, or just wrap AVar (shows what wrapping looks like with current API), +-- or add a new method to AVar (which wouldn't work in a network setting, +-- unless there's a way to send a function (a->a) remotely). +-- +-- Let's go for the wrapping. + +data ACounterStage (a :: Type) + +instance Stage (ACounterStage a) where + data StageEnv (ACounterStage a) = ACounterStageEnv (TheaterFor (AVarStage a)) (Ref (AVar a)) + type StageActors (ACounterStage a) = '[ACounter a] + type StageSpawn (ACounterStage a) = NoSpawn + +data ACounter (a :: Type) + +instance Actor (ACounter a) where + type ActorStage (ACounter a) = ACounterStage a + type ActorInterface (ACounter a) = + '[ "next" ::: Return a + ] + type ActorIdentity (ACounter a) = () + +instance (Integral a, PersistFieldSql a) => ActorLaunch (ACounter a) where + actorBehavior _ = + (handleMethod @"next" := \ () -> do + ACounterStageEnv avarTheater avarRef <- askEnv + val <- liftIO $ fromJust <$> callIO' @"get" avarTheater Proxy avarRef HNil + void $ liftIO $ sendIO' @"put" avarTheater Proxy avarRef $ (val+1) `HCons` HNil + done val + ) + `HCons` + HNil + +-- So, we want to load a theater with exactly one ACounter + +loadSingleACounterTheater + :: (Integral a, PersistFieldSql a) + => LogFunc + -> FilePath + -> a + -> IO (TheaterFor (ACounterStage a), Ref (ACounter a)) +loadSingleACounterTheater logFunc pathA initial = do + (theaterA, avarRef) <- loadSingleAVarTheater logFunc pathA initial + startStar () logFunc () (ACounterStageEnv theaterA avarRef) + +-- We now modify TheaterFor, to have 2 types of theaters: Ones that allow +-- spawning, and ones that don't. +-- +-- And we're going to do it type-based. +-- +-- Done. Now, how will we track the bidirectional mapping between DB key and +-- internal actor number? Let's see why we need both directions: +-- +-- * In actor handlers, we need the DB key avalable somehow, i.e. startTheater +-- and spawn/IO must take this per-actor "env" +-- * Inbox POST handlers need to determine the internal ID in order to insert +-- the incoming activity + +-- First let's define a type to use for the ID + +newtype Ref a = Ref ActorInt deriving newtype (Eq, Show, Read, Hashable) + +-- Now, for each actor type, specify an env type, and have spawn & startTheater +-- take these values + +-- Done. Now, we need to keep the map updated: +-- +-- [ ] Whenever an actor is deleted, remove from appActors as well (preferrably +-- even before the removal from Theater) diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 4b09f15..2e20808 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -32,6 +32,7 @@ module Vervis.API where import Control.Applicative +import Control.Concurrent.STM.TVar import Control.Exception hiding (Handler, try) import Control.Monad import Control.Monad.IO.Class @@ -69,6 +70,8 @@ import Yesod.Persist.Core import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as HM +import qualified Data.HList as H import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -145,10 +148,16 @@ handleViaActor -> AP.Action URIMode -> ExceptT Text Handler OutboxItemId handleViaActor personID maybeCap localRecips remoteRecips fwdHosts action = do + personRef <- do + peopleVar <- H.hOccurs <$> asksSite appActors + people <- liftIO $ readTVarIO peopleVar + case HM.lookup personID people of + Nothing -> error "Person not found in appActors" + Just ref -> pure ref theater <- asksSite appTheater let maybeCap' = first (\ (byKey, _, i) -> (byKey, i)) <$> maybeCap msg = ClientMsg maybeCap' localRecips remoteRecips fwdHosts action - maybeResult <- liftIO $ callIO' @"client" theater Proxy personID $ msg `HCons` HNil + maybeResult <- liftIO $ callIO' @"client" @Person theater Proxy personRef $ msg `HCons` HNil outboxItemID <- case maybeResult of Nothing -> error "Person not found in theater" @@ -1123,7 +1132,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips success <- do theater <- asksSite appTheater env <- asksSite appEnv - liftIO $ launchActorIO theater env loomID + liftIO $ launchActorIO @Loom theater env loomID unless success $ error "Failed to spawn new Loom, somehow ID already in Theater" @@ -1377,7 +1386,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r success <- do theater <- asksSite appTheater env <- asksSite appEnv - liftIO $ launchActorIO theater env repoID + liftIO $ launchActorIO @Repo theater env repoID unless success $ error "Failed to spawn new Repo, somehow ID already in Theater" diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs index d671c1e..a13c04b 100644 --- a/src/Vervis/Actor.hs +++ b/src/Vervis/Actor.hs @@ -22,6 +22,9 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} +-- For launchActor not to need to take a Proxy +{-# LANGUAGE AllowAmbiguousTypes #-} + module Vervis.Actor ( -- * Local actors LocalActorBy (..) @@ -79,6 +82,7 @@ module Vervis.Actor , ClientMsg (..) -- * Behavior utility types + , KeyAndRef_ , StageEnv (..) , Staje , Act @@ -106,6 +110,7 @@ module Vervis.Actor ) where +import Control.Concurrent.STM import Control.Concurrent.STM.TVar import Control.Monad import Control.Monad.IO.Class @@ -121,6 +126,8 @@ import Data.Function import Data.Hashable import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) +import Data.HList (HList (..)) +import Data.Kind import Data.List.NonEmpty (NonEmpty) import Data.Maybe import Data.Text (Text) @@ -139,6 +146,7 @@ import qualified Control.Monad.Fail as F import qualified Data.Aeson as A import qualified Data.ByteString.Lazy as BL import qualified Data.HashSet as HS +import qualified Data.HashMap.Strict as HM import qualified Data.HList as H import qualified Data.List.NonEmpty as NE import qualified Data.List.Ordered as LO @@ -491,7 +499,7 @@ type Ret = Return (Either Text Text) instance Actor Person where type ActorStage Person = Staje - type ActorKey Person = PersonId + type ActorIdentity Person = PersonId type ActorInterface Person = [ "verse" ::: Verse :-> Ret , "client" ::: ClientMsg :-> Return (Either Text OutboxItemId) @@ -499,41 +507,41 @@ instance Actor Person where ] instance Actor Deck where type ActorStage Deck = Staje - type ActorKey Deck = DeckId + type ActorIdentity Deck = DeckId type ActorInterface Deck = [ "verse" ::: Verse :-> Ret , "init" ::: (Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI)) :-> Ret ] instance Actor Loom where type ActorStage Loom = Staje - type ActorKey Loom = LoomId + type ActorIdentity Loom = LoomId type ActorInterface Loom = '[ "verse" ::: Verse :-> Ret ] instance Actor Repo where type ActorStage Repo = Staje - type ActorKey Repo = RepoId + type ActorIdentity Repo = RepoId type ActorInterface Repo = [ "verse" ::: Verse :-> Ret , "wait-during-push" ::: IO () :-> Ret ] instance Actor Project where type ActorStage Project = Staje - type ActorKey Project = ProjectId + type ActorIdentity Project = ProjectId type ActorInterface Project = [ "verse" ::: Verse :-> Ret , "init" ::: (Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI)) :-> Ret ] instance Actor Group where type ActorStage Group = Staje - type ActorKey Group = GroupId + type ActorIdentity Group = GroupId type ActorInterface Group = [ "verse" ::: Verse :-> Ret , "init" ::: (Either (LocalActorBy Key, ActorId, OutboxItemId) (RemoteAuthor, LocalURI)) :-> Ret ] instance Actor Factory where type ActorStage Factory = Staje - type ActorKey Factory = FactoryId + type ActorIdentity Factory = FactoryId type ActorInterface Factory = [ "verse" ::: Verse :-> Ret , "verified" ::: PersonId :-> Ret @@ -571,6 +579,9 @@ instance VervisActor Factory where toVerse _ = Nothing -} +data KeyAndRef_ :: Type -> Exp Type +type instance Eval (KeyAndRef_ a) = TVar (HashMap (Key a) (Ref a)) + instance Stage Staje where data StageEnv Staje = forall y. (Typeable y, Yesod y) => Env -- | Data to which every actor has access. Since such data can be passed to the @@ -594,9 +605,11 @@ instance Stage Staje where , envYesodRender :: YesodRender y , envHttpManager :: Manager , envFetch :: ActorFetchShare + , envActors :: HList (Eval (Map KeyAndRef_ (StageActors Staje))) } deriving Typeable type StageActors Staje = [Person, Project, Group, Deck, Loom, Repo, Factory] + type StageSpawn Staje = AllowSpawn type YesodRender y = Route y -> [(Text, Text)] -> Text @@ -664,130 +677,149 @@ instance (Actor a, VervisActorLaunch a, ActorReturn a ~ Either Text Text, ActorS -} launchActorIO - :: ( ActorLaunch a, ActorStage a ~ Staje - , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a) - , H.HEq - (TVar (HashMap (ActorKey a) (ActorRef a))) - (TVar (HashMap PersonId (ActorRef Person))) - b1 - , H.HOccurrence' - b1 - (TVar (HashMap (ActorKey a) (ActorRef a))) - '[TVar (HashMap PersonId (ActorRef Person)), - TVar (HashMap ProjectId (ActorRef Project)), - TVar (HashMap GroupId (ActorRef Group)), - TVar (HashMap DeckId (ActorRef Deck)), - TVar (HashMap LoomId (ActorRef Loom)), - TVar (HashMap RepoId (ActorRef Repo)), - TVar (HashMap FactoryId (ActorRef Factory))] - l'1 - , H.HOccurs' - (TVar (HashMap (ActorKey a) (ActorRef a))) - l'1 - '[TVar (HashMap PersonId (ActorRef Person)), - TVar (HashMap ProjectId (ActorRef Project)), - TVar (HashMap GroupId (ActorRef Group)), - TVar (HashMap DeckId (ActorRef Deck)), - TVar (HashMap LoomId (ActorRef Loom)), - TVar (HashMap RepoId (ActorRef Repo)), - TVar (HashMap FactoryId (ActorRef Factory))] - - , ActorStage a ~ s + :: forall a ms b l . + ( ActorLaunch a, ActorStage a ~ Staje + , Hashable (ActorIdentity a) , ActorInterface a ~ ms - , Eval (Map (AdaptedHandler s) ms) + , H.HOccurs + (TVar (ActorRefMap a)) + (HList (Eval (Map ActorRefMapTVar_ (StageActors Staje)))) + , Eval (Map (AdaptedHandler Staje) ms) ~ Eval (Map - (Func (AdaptedAction s, Text)) + (Func (AdaptedAction Staje, Text)) (Eval (Map Parcel_ ms)) ) , H.SameLength' - (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms)))) + (Eval (Map (Func (AdaptedAction Staje, Text)) (Eval (Map Parcel_ ms)))) (Eval (Map (Handler_ a) ms)) , H.SameLength' (Eval (Map (Handler_ a) ms)) - (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms)))) + (Eval (Map (Func (AdaptedAction Staje, Text)) (Eval (Map Parcel_ ms)))) , Eval (Constraints (Eval (Map (AdaptHandlerConstraint a) ms))) - , Handle' (Eval (Map Parcel_ ms)) (AdaptedAction s, Text) + , Handle' (Eval (Map Parcel_ ms)) (AdaptedAction Staje, Text) , H.HMapAux - H.HList + HList (HAdaptHandler a) (Eval (Map (Handler_ a) ms)) (Eval (Map - (Func (AdaptedAction s, Text)) + (Func (AdaptedAction Staje, Text)) (Eval (Map Parcel_ ms)) ) ) + , H.HEq + (TVar (HashMap (ActorIdentity a) (Ref a))) + (TVar (HashMap (Key Person) (Ref Person))) + b + , H.HOccurrence' + b + (TVar (HashMap (ActorIdentity a) (Ref a))) + [TVar (HashMap (Key Person) (Ref Person)), + TVar (HashMap (Key Project) (Ref Project)), + TVar (HashMap (Key Group) (Ref Group)), + TVar (HashMap (Key Deck) (Ref Deck)), + TVar (HashMap (Key Loom) (Ref Loom)), + TVar (HashMap (Key Repo) (Ref Repo)), + TVar (HashMap (Key Factory) (Ref Factory))] + l + , H.HOccurs' + (TVar (HashMap (ActorIdentity a) (Ref a))) + l + [TVar (HashMap (Key Person) (Ref Person)), + TVar (HashMap (Key Project) (Ref Project)), + TVar (HashMap (Key Group) (Ref Group)), + TVar (HashMap (Key Deck) (Ref Deck)), + TVar (HashMap (Key Loom) (Ref Loom)), + TVar (HashMap (Key Repo) (Ref Repo)), + TVar (HashMap (Key Factory) (Ref Factory))] ) => Theater -> StageEnv Staje - -> ActorKey a + -> ActorIdentity a -> IO Bool -launchActorIO theater env key = spawnIO theater key (pure env) +launchActorIO theater env ident = do + let tvar = H.hOccurs (envActors env) + maybeRef <- HM.lookup ident <$> readTVarIO tvar + case maybeRef of + Just _ -> pure False + Nothing -> do + ref <- spawnIO @a theater ident (pure env) + atomically $ modifyTVar' tvar $ HM.insert ident ref + return True launchActor - :: ( ActorLaunch a, ActorStage a ~ Staje - , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a) - , H.HEq - (TVar (HashMap (ActorKey a) (ActorRef a))) - (TVar (HashMap PersonId (ActorRef Person))) - b0 - , H.HOccurrence' - b0 - (TVar (HashMap (ActorKey a) (ActorRef a))) - '[TVar (HashMap PersonId (ActorRef Person)), - TVar (HashMap ProjectId (ActorRef Project)), - TVar (HashMap GroupId (ActorRef Group)), - TVar (HashMap DeckId (ActorRef Deck)), - TVar (HashMap LoomId (ActorRef Loom)), - TVar (HashMap RepoId (ActorRef Repo)), - TVar (HashMap FactoryId (ActorRef Factory))] - l'0 - , H.HOccurs' - (TVar (HashMap (ActorKey a) (ActorRef a))) - l'0 - '[TVar (HashMap PersonId (ActorRef Person)), - TVar (HashMap ProjectId (ActorRef Project)), - TVar (HashMap GroupId (ActorRef Group)), - TVar (HashMap DeckId (ActorRef Deck)), - TVar (HashMap LoomId (ActorRef Loom)), - TVar (HashMap RepoId (ActorRef Repo)), - TVar (HashMap FactoryId (ActorRef Factory))] - - , ActorStage a ~ s + :: forall a ms b l . + ( ActorLaunch a, ActorStage a ~ Staje + , Hashable (ActorIdentity a) , ActorInterface a ~ ms - , Eval (Map (AdaptedHandler s) ms) + , H.HOccurs + (TVar (ActorRefMap a)) + (HList (Eval (Map ActorRefMapTVar_ (StageActors Staje)))) + , Eval (Map (AdaptedHandler Staje) ms) ~ Eval (Map - (Func (AdaptedAction s, Text)) + (Func (AdaptedAction Staje, Text)) (Eval (Map Parcel_ ms)) ) , H.SameLength' - (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms)))) + (Eval (Map (Func (AdaptedAction Staje, Text)) (Eval (Map Parcel_ ms)))) (Eval (Map (Handler_ a) ms)) , H.SameLength' (Eval (Map (Handler_ a) ms)) - (Eval (Map (Func (AdaptedAction s, Text)) (Eval (Map Parcel_ ms)))) + (Eval (Map (Func (AdaptedAction Staje, Text)) (Eval (Map Parcel_ ms)))) , Eval (Constraints (Eval (Map (AdaptHandlerConstraint a) ms))) - , Handle' (Eval (Map Parcel_ ms)) (AdaptedAction s, Text) + , Handle' (Eval (Map Parcel_ ms)) (AdaptedAction Staje, Text) , H.HMapAux - H.HList + HList (HAdaptHandler a) (Eval (Map (Handler_ a) ms)) (Eval (Map - (Func (AdaptedAction s, Text)) + (Func (AdaptedAction Staje, Text)) (Eval (Map Parcel_ ms)) ) ) + , H.HEq + (TVar (HashMap (ActorIdentity a) (Ref a))) + (TVar (HashMap (Key Person) (Ref Person))) + b + , H.HOccurrence' + b + (TVar (HashMap (ActorIdentity a) (Ref a))) + [TVar (HashMap (Key Person) (Ref Person)), + TVar (HashMap (Key Project) (Ref Project)), + TVar (HashMap (Key Group) (Ref Group)), + TVar (HashMap (Key Deck) (Ref Deck)), + TVar (HashMap (Key Loom) (Ref Loom)), + TVar (HashMap (Key Repo) (Ref Repo)), + TVar (HashMap (Key Factory) (Ref Factory))] + l + , H.HOccurs' + (TVar (HashMap (ActorIdentity a) (Ref a))) + l + [TVar (HashMap (Key Person) (Ref Person)), + TVar (HashMap (Key Project) (Ref Project)), + TVar (HashMap (Key Group) (Ref Group)), + TVar (HashMap (Key Deck) (Ref Deck)), + TVar (HashMap (Key Loom) (Ref Loom)), + TVar (HashMap (Key Repo) (Ref Repo)), + TVar (HashMap (Key Factory) (Ref Factory))] ) - => ActorKey a + => ActorIdentity a -> Act Bool -launchActor key = do - e <- askEnv - spawn key (pure e) +launchActor ident = do + env <- askEnv + let tvar = H.hOccurs (envActors env) + maybeRef <- liftIO $ HM.lookup ident <$> readTVarIO tvar + case maybeRef of + Just _ -> pure False + Nothing -> do + ref <- spawn @a ident (pure env) + liftIO $ atomically $ modifyTVar' tvar $ HM.insert ident ref + return True data RemoteRecipient = RemoteRecipient { remoteRecipientActor :: RemoteActorId @@ -796,6 +828,68 @@ data RemoteRecipient = RemoteRecipient , remoteRecipientErrorSince :: Maybe UTCTime } +--data MapAndSet_ :: Type -> Exp Type +--type instance Eval (MapAndSet_ a) = (Eval (KeyAndRef_ a), HashSet (ActorIdentity a)) + +sendVerses + :: ( Actor a + , ActorStage a ~ Staje + , ActorHasMethod a "verse" (Verse :-> Return (Either Text Text)) + , Eq (ActorIdentity a) + , H.HEq + (TVar (ActorRefMap a)) (TVar (ActorRefMap Person)) b + , H.HOccurrence' + b + (TVar (ActorRefMap a)) + [TVar (ActorRefMap Person), TVar (ActorRefMap Project), + TVar (ActorRefMap Group), TVar (ActorRefMap Deck), + TVar (ActorRefMap Loom), TVar (ActorRefMap Repo), + TVar (ActorRefMap Factory)] + l + , H.HOccurs' + (TVar (ActorRefMap a)) + l + [TVar (ActorRefMap Person), TVar (ActorRefMap Project), + TVar (ActorRefMap Group), TVar (ActorRefMap Deck), + TVar (ActorRefMap Loom), TVar (ActorRefMap Repo), + TVar (ActorRefMap Factory)] + ) + => Verse + -> (TVar (HashMap (ActorIdentity a) (Ref a)), HashSet (ActorIdentity a)) + -> Act () +sendVerses verse (tvar, s) = do + actorMap <- liftIO $ readTVarIO tvar + let refs = HM.elems $ actorMap `HM.intersection` HS.toMap s + for_ refs $ \ ref -> void $ send @"verse" ref verse + +data HSendVerses = HSendVerses Verse +instance + ( Actor a + , ActorStage a ~ Staje + , ActorHasMethod a "verse" (Verse :-> Return (Either Text Text)) + , Eq (ActorIdentity a) + , i ~ (TVar (HashMap (ActorIdentity a) (Ref a)), HashSet (ActorIdentity a)) + , H.HEq + (TVar (ActorRefMap a)) (TVar (ActorRefMap Person)) b + , H.HOccurrence' + b + (TVar (ActorRefMap a)) + [TVar (ActorRefMap Person), TVar (ActorRefMap Project), + TVar (ActorRefMap Group), TVar (ActorRefMap Deck), + TVar (ActorRefMap Loom), TVar (ActorRefMap Repo), + TVar (ActorRefMap Factory)] + l + , H.HOccurs' + (TVar (ActorRefMap a)) + l + [TVar (ActorRefMap Person), TVar (ActorRefMap Project), + TVar (ActorRefMap Group), TVar (ActorRefMap Deck), + TVar (ActorRefMap Loom), TVar (ActorRefMap Repo), + TVar (ActorRefMap Factory)] + ) => + H.ApplyAB HSendVerses i (Act ()) where + applyAB (HSendVerses verse) = sendVerses verse + -- Given a list of local recipients, which may include actors and collections, -- -- * Insert activity to message queues of live actors @@ -978,13 +1072,21 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do (Just (liveRecipsR, actorVerse verse)) `H.HCons` (Just (liveRecipsF, actorVerse verse)) `H.HCons` H.HNil -} - for_ liveRecipsP $ \ k -> void $ send @"verse" k verse - for_ liveRecipsJ $ \ k -> void $ send @"verse" k verse - for_ liveRecipsG $ \ k -> void $ send @"verse" k verse - for_ liveRecipsD $ \ k -> void $ send @"verse" k verse - for_ liveRecipsL $ \ k -> void $ send @"verse" k verse - for_ liveRecipsR $ \ k -> void $ send @"verse" k verse - for_ liveRecipsF $ \ k -> void $ send @"verse" k verse + let actorSets = + liveRecipsP `HCons` liveRecipsJ `HCons` liveRecipsG `HCons` + liveRecipsD `HCons` liveRecipsL `HCons` liveRecipsR `HCons` + liveRecipsF `HCons` HNil + actorMaps <- envActors <$> askEnv + {- + let sendVerses' + :: ( ActorStage a ~ Staje + , ActorHasMethod a "verse" (Verse :-> Return (Either Text Text)) + ) + => (TVar (HashMap (ActorIdentity a) (Ref a)), HashSet (ActorIdentity a)) + -> Act () + sendVerses' = sendVerses verse + -} + H.hMapM_ (HSendVerses verse) (H.hZip actorMaps actorSets) -- :: HList (Eval (Map MapAndSet_ (StageActors Staje)))) -- Return remote followers, to whom we need to deliver via HTTP return remoteFollowers diff --git a/src/Vervis/Actor/Factory.hs b/src/Vervis/Actor/Factory.hs index 73980cf..5f71227 100644 --- a/src/Vervis/Actor/Factory.hs +++ b/src/Vervis/Actor/Factory.hs @@ -19,6 +19,7 @@ module Vervis.Actor.Factory where import Control.Applicative +import Control.Concurrent.STM.TVar import Control.Exception.Base hiding (handle) import Control.Monad import Control.Monad.IO.Class @@ -45,6 +46,8 @@ import Database.Persist.Sql import Optics.Core import Yesod.Persist.Core +import qualified Data.HashMap.Strict as HM +import qualified Data.HList as H import qualified Data.Text as T import qualified Database.Esqueleto as E @@ -1060,8 +1063,12 @@ factoryCreateNew new now factoryMeID (Verse authorIdMsig body) detail = do } return ( LocalResourceDeck did - , launchActor did - , send @"init" did authorId + , launchActor @Deck did + , do tvar <- H.hOccurs <$> asksEnv envActors + actors <- liftIO $ readTVarIO tvar + case HM.lookup did actors of + Nothing -> pure False + Just ref -> send @"init" @Deck ref authorId ) NAProject -> do jid <- insert Project @@ -1070,8 +1077,12 @@ factoryCreateNew new now factoryMeID (Verse authorIdMsig body) detail = do } return ( LocalResourceProject jid - , launchActor jid - , send @"init" jid authorId + , launchActor @Project jid + , do tvar <- H.hOccurs <$> asksEnv envActors + actors <- liftIO $ readTVarIO tvar + case HM.lookup jid actors of + Nothing -> pure False + Just ref -> send @"init" @Project ref authorId ) NATeam -> do gid <- insert Group @@ -1080,8 +1091,12 @@ factoryCreateNew new now factoryMeID (Verse authorIdMsig body) detail = do } return ( LocalResourceGroup gid - , launchActor gid - , send @"init" gid authorId + , launchActor @Group gid + , do tvar <- H.hOccurs <$> asksEnv envActors + actors <- liftIO $ readTVarIO tvar + case HM.lookup gid actors of + Nothing -> pure False + Just ref -> send @"init" @Group ref authorId ) return (lr, launch, sendInit, rid) diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index 49b90ee..6a27028 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/src/Vervis/Actor/Person/Client.hs @@ -502,7 +502,7 @@ clientCreateFactory now personMeID (ClientMsg maybeCap localRecips remoteRecips ) -- Spawn new Factory actor - success <- lift $ launchActor factoryID + success <- lift $ launchActor @Factory factoryID unless success $ error "Failed to spawn new Factory, somehow ID already in Theater" diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 28c281b..487a0f3 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -16,6 +16,9 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +-- For HWriteTVar to work +{-# LANGUAGE UndecidableInstances #-} + {- LANGUAGE RankNTypes #-} module Vervis.Application @@ -46,6 +49,8 @@ import Control.Monad.Trans.Reader import Data.Bifunctor import Data.Default.Class import Data.Foldable +import Data.Hashable +import Data.HList (HList (..)) import Data.List import Data.List.NonEmpty (nonEmpty) import Data.Maybe @@ -99,6 +104,8 @@ import Yesod.ActivityPub import Yesod.Hashids import Yesod.MonadSite +import qualified Control.Concurrent.Actor as CCA + import Control.Concurrent.Local import Development.Git (isGitRepo) import Data.List.NonEmpty.Local @@ -162,6 +169,17 @@ mkYesodDispatch "App" resourcesApp loggingFunction :: App -> LogFunc loggingFunction app = messageLoggerSource app (appLogger app) +data HWriteTVar = HWriteTVar +instance + ( CCA.Actor a + , Eq (ActorIdentity a) + , Hashable (ActorIdentity a) + , i ~ (TVar (HM.HashMap (ActorIdentity a) (Ref a)), [(ActorIdentity a, Ref a)]) + ) => + H.ApplyAB HWriteTVar i (IO ()) where + applyAB HWriteTVar (tvar, l) = + atomically $ writeTVar tvar $ HM.fromList l + -- | This function allocates resources (such as a database connection pool), -- performs initialization and returns a foundation datatype value. This is also -- the place to put your migrate statements to have automatic database @@ -208,7 +226,8 @@ makeFoundation appSettings = do appHashidsContext appTheater appEnv - appPersonLauncher = + appPersonLauncher + appActors = App {..} -- The App {..} syntax is an example of record wild cards. For more -- information, see: @@ -221,6 +240,7 @@ makeFoundation appSettings = do (error "theater forced in tempFoundation") (error "env forced in tempFoundation") (error "launcher forced in tempFoundation") + (error "actors forced in tempFoundation") logFunc = loggingFunction tempFoundation -- Create the database connection pool @@ -235,7 +255,7 @@ makeFoundation appSettings = do hashidsSalt <- loadKeyFile loadMode $ appHashidsSaltFile appSettings let hashidsCtx = hashidsContext hashidsSalt - app = mkFoundation pool capSignKey hashidsCtx (error "theater") (error "env") (error "launcher") + app = mkFoundation pool capSignKey hashidsCtx (error "theater") (error "env") (error "launcher") (error "actors") -- Perform database migration using our application's logging settings. --runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc @@ -256,13 +276,22 @@ makeFoundation appSettings = do delivery <- do micros <- intervalMicros $ appDeliveryRetryBase appSettings startDeliveryTheater - (sitePostSignedHeaders app) micros appHttpManager logFunc delieryStateDir + "delivery-counter.sqlite3" (sitePostSignedHeaders app) micros appHttpManager logFunc delieryStateDir + actorTVars <- do + p <- newTVarIO HM.empty + j <- newTVarIO HM.empty + g <- newTVarIO HM.empty + d <- newTVarIO HM.empty + l <- newTVarIO HM.empty + r <- newTVarIO HM.empty + f <- newTVarIO HM.empty + return $ p `HCons` j `HCons` g `HCons` d `HCons` l `HCons` r `HCons` f `HCons` HNil let root = renderObjURI $ flip ObjURI topLocalURI $ appInstanceHost appSettings --render :: Yesod y => y -> Route y -> [(Text, Text)] -> Text render = yesodRender app root - env = Env appSettings pool hashidsCtx appActorKeys delivery render appHttpManager appActorFetchShare + env = Env appSettings pool hashidsCtx appActorKeys delivery render appHttpManager appActorFetchShare actorTVars actors <- flip runWorker app $ runSiteDB $ loadTheater env - theater <- startTheater logFunc actors + (theater, actorMap) <- startTheater "actor-counter.sqlite3" logFunc actors launcher <- startPersonLauncher theater env let hostString = T.unpack $ renderAuthority hLocal @@ -272,8 +301,10 @@ makeFoundation appSettings = do , configMaxCommits = 20 } + H.hMapM_ HWriteTVar (H.hZip actorTVars actorMap) + -- Return the foundation - return app { appTheater = theater, appEnv = env, appPersonLauncher = launcher } + return app { appTheater = theater, appEnv = env, appPersonLauncher = launcher, appActors = actorTVars } where verifyRepoDir = do repos <- lift reposFromDir @@ -371,7 +402,7 @@ makeFoundation appSettings = do where handle mvar = do (personID, sendResult) <- takeMVar mvar - success <- launchActorIO theater env personID + success <- launchActorIO @Person theater env personID putMVar sendResult success -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and @@ -446,6 +477,7 @@ sshServer foundation = (appConnPool foundation) (loggingFunction foundation) (appTheater foundation) + (H.hOccurs $ appActors foundation) mailer :: App -> IO () mailer foundation = diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index f483609..d9fded6 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -38,6 +38,7 @@ import Data.Traversable import Data.Vector (Vector) import Database.Persist.Postgresql import Database.Persist.Sql (ConnectionPool) +import Fcf (Eval, Map) import Network.HTTP.Client (Manager, HasHttpManager (..)) import Network.HTTP.Types.Header import Text.Shakespeare.Text (textFile) @@ -60,6 +61,7 @@ import Yesod.Static import qualified Data.Aeson as A import qualified Data.ByteString.Lazy as BL (ByteString) +import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS import qualified Data.HList as H import qualified Data.Time.Units as U @@ -141,6 +143,7 @@ data App = App , appTheater :: Theater , appEnv :: StageEnv Staje , appPersonLauncher :: MVar (PersonId, MVar Bool) + , appActors :: HList (Eval (Map KeyAndRef_ (StageActors Staje))) } -- Aliases for the routes file, because it doesn't like spaces in path piece @@ -725,9 +728,14 @@ instance AccountDB AccountPersistDB' where error "Failed to spawn new Person, somehow ID already in Theater" AccountPersistDB' $ do theater <- asksSite appTheater - there <- liftIO $ sendIO' @"init" theater Proxy personID HNil - unless there $ - error "Failed to find new Person, somehow ID not in Theater" + peopleVar `HCons` _ `HCons` _ `HCons` _ `HCons` _ `HCons` _ `HCons` factoriesVar `HCons` HNil <- asksSite appActors + people <- liftIO $ readTVarIO peopleVar + case HM.lookup personID people of + Nothing -> error "Failed to find new Person, somehow ID not in appActors" + Just personRef -> do + there <- liftIO $ sendIO' @"init" theater Proxy personRef HNil + unless there $ + error "Failed to find new Person, somehow Ref not in Theater" factoryIDs <- runDB $ selectKeysList [] [] {- let package = (HS.fromList factoryIDs, FactoryMsgVerified personID) @@ -740,8 +748,12 @@ instance AccountDB AccountPersistDB' where Nothing `H.HCons` Just package `H.HCons` H.HNil -} - liftIO $ for_ factoryIDs $ \ (factoryID :: FactoryId) -> - void $ sendIO' @"verified" theater Proxy factoryID (personID `HCons` HNil) + factories <- liftIO $ readTVarIO factoriesVar + let factoryRefs = + HM.elems $ + factories `HM.intersection` HS.toMap (HS.fromList factoryIDs) + liftIO $ for_ factoryRefs $ \ (ref :: Ref Factory) -> + void $ sendIO' @"verified" theater Proxy ref (personID `HCons` HNil) setVerifyKey = (morphAPDB .) . setVerifyKey setNewPasswordKey = (morphAPDB .) . setNewPasswordKey setNewPassword = (morphAPDB .) . setNewPassword diff --git a/src/Vervis/Recipient.hs b/src/Vervis/Recipient.hs index c58445c..f84c8e2 100644 --- a/src/Vervis/Recipient.hs +++ b/src/Vervis/Recipient.hs @@ -172,7 +172,7 @@ import Vervis.Model instance WA.StageWebRoute Staje where type StageRoute Staje = Route App askUrlRenderParams = do - Env _ _ _ _ _ render _ _ <- askEnv + Env _ _ _ _ _ render _ _ _ <- askEnv case cast render of Nothing -> error "Env site isn't App" Just r -> pure r diff --git a/src/Vervis/RemoteActorStore.hs b/src/Vervis/RemoteActorStore.hs index c6cc79e..dcf6969 100644 --- a/src/Vervis/RemoteActorStore.hs +++ b/src/Vervis/RemoteActorStore.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2022, 2023 by fr33domlover . + - Written in 2019, 2020, 2022, 2023, 2024 + - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -565,7 +566,7 @@ fetchRemoteActor' iid host luActor = do Left ers -> Just ers Right _ -> Nothing Nothing -> do - Env _ pool _ _ _ _ manager fetch <- askEnv + Env _ pool _ _ _ _ manager fetch _ <- askEnv liftIO $ runShared fetch (ObjURI host luActor) (pool, manager, iid) deleteUnusedURAs :: (MonadIO m, MonadLogger m) => ReaderT SqlBackend m () diff --git a/src/Vervis/Ssh.hs b/src/Vervis/Ssh.hs index ed7f3b0..ddd8033 100644 --- a/src/Vervis/Ssh.hs +++ b/src/Vervis/Ssh.hs @@ -19,6 +19,7 @@ module Vervis.Ssh where import Control.Applicative ((<|>), optional) +import Control.Concurrent.STM.TVar import Control.Monad (when) import Control.Monad.IO.Class (liftIO) import Control.Monad.Logger @@ -29,6 +30,7 @@ import Data.Attoparsec.Text import Data.ByteString (ByteString) import Data.ByteString.Lazy (fromStrict) import Data.Foldable (find) +import Data.HashMap.Strict (HashMap) import Data.HList (HList (..)) import Data.Maybe (isJust) import Data.Monoid ((<>)) @@ -49,6 +51,7 @@ import System.Process (CreateProcess (..), StdStream (..), createProcess, proc) import Web.Hashids import Yesod.Core.Dispatch +import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import qualified Formatting as F @@ -70,7 +73,7 @@ import Vervis.Settings -- Types ------------------------------------------------------------------------------- -type ChannelBase = LoggingT (ReaderT (ConnectionPool, Theater) IO) +type ChannelBase = LoggingT (ReaderT (ConnectionPool, Theater, TVar (HashMap RepoId (Ref Repo))) IO) type SessionBase = LoggingT (ReaderT ConnectionPool IO) type UserAuthId = PersonId @@ -102,7 +105,7 @@ src = "SSH" runChanDB :: SshChanDB a -> Channel a runChanDB action = do - pool <- lift . lift $ asks fst + (pool, _, _) <- lift . lift $ ask runSqlPool action pool runSessDB :: SshSessDB a -> Session a @@ -267,12 +270,16 @@ runAction decodeRepoHash root _wantReply action = Just repoID -> whenDarcsRepoExists True repoPath $ do pid <- authId <$> askAuthDetails liftIO $ setEnv "VERVIS_SSH_USER" (show $ fromSqlKey pid) - theater <- lift . lift $ asks snd - (sendValue, waitValue) <- liftIO newReturn - _ <- liftIO $ sendIO' @"wait-during-push" theater Proxy repoID $ waitValue `HCons` HNil - executeWait "darcs" ["apply", "--all", "--repodir", repoPath] - liftIO $ sendValue () - return ARProcess + (_, theater, reposVar) <- lift . lift $ ask + repos <- liftIO $ readTVarIO reposVar + case HM.lookup repoID repos of + Nothing -> return $ ARFail "RepoId not found in map" + Just ref -> do + (sendValue, waitValue) <- liftIO newReturn + _ <- liftIO $ sendIO' @"wait-during-push" theater Proxy ref $ waitValue `HCons` HNil + executeWait "darcs" ["apply", "--all", "--repodir", repoPath] + liftIO $ sendValue () + return ARProcess Nothing -> return $ ARFail "You can't push to this repository" GitUploadPack repoHash -> do let repoPath = repoDir root repoHash @@ -294,12 +301,16 @@ runAction decodeRepoHash root _wantReply action = Just repoID -> whenGitRepoExists True repoPath $ do pid <- authId <$> askAuthDetails liftIO $ setEnv "VERVIS_SSH_USER" (show $ fromSqlKey pid) - theater <- lift . lift $ asks snd - (sendValue, waitValue) <- liftIO newReturn - _ <- liftIO $ sendIO' @"wait-during-push" theater Proxy repoID $ waitValue `HCons` HNil - executeWait "git-receive-pack" [repoPath] - liftIO $ sendValue () - return ARProcess + (_, theater, reposVar) <- lift . lift $ ask + repos <- liftIO $ readTVarIO reposVar + case HM.lookup repoID repos of + Nothing -> return $ ARFail "RepoId not found in map" + Just ref -> do + (sendValue, waitValue) <- liftIO newReturn + _ <- liftIO $ sendIO' @"wait-during-push" theater Proxy ref $ waitValue `HCons` HNil + executeWait "git-receive-pack" [repoPath] + liftIO $ sendValue () + return ARProcess Nothing -> return $ ARFail "You can't push to this repository" handle @@ -346,8 +357,9 @@ mkConfig -> ConnectionPool -> LogFunc -> Theater + -> TVar (HashMap RepoId (Ref Repo)) -> IO (Config SessionBase ChannelBase UserAuthId) -mkConfig settings ctx pool logFunc theater = do +mkConfig settings ctx pool logFunc theater reposVar = do keyPair <- keyPairFromFile $ appSshKeyFile settings return $ Config { cSession = SessionConfig @@ -360,13 +372,13 @@ mkConfig settings ctx pool logFunc theater = do , cChannel = ChannelConfig { ccRequestHandler = handle (decodeKeyHashidPure ctx) (appRepoDir settings) , ccRunBaseMonad = - flip runReaderT (pool, theater) . flip runLoggingT logFunc + flip runReaderT (pool, theater, reposVar) . flip runLoggingT logFunc } , cPort = fromIntegral $ appSshPort settings , cReadyAction = ready logFunc } -runSsh :: AppSettings -> HashidsContext -> ConnectionPool -> LogFunc -> Theater -> IO () -runSsh settings ctx pool logFunc theater = do - config <- mkConfig settings ctx pool logFunc theater +runSsh :: AppSettings -> HashidsContext -> ConnectionPool -> LogFunc -> Theater -> TVar (HashMap RepoId (Ref Repo)) -> IO () +runSsh settings ctx pool logFunc theater reposVar = do + config <- mkConfig settings ctx pool logFunc theater reposVar startConfig config diff --git a/src/Vervis/Web/Actor.hs b/src/Vervis/Web/Actor.hs index 0a9e712..2c1e8fe 100644 --- a/src/Vervis/Web/Actor.hs +++ b/src/Vervis/Web/Actor.hs @@ -256,40 +256,55 @@ getInbox'' grabInbox here getActorID hash = do ibiidString = "InboxItem #" ++ show (fromSqlKey ibid) postInbox - :: ( CCA.Actor a + :: forall a b l b0 l0 . + ( CCA.Actor a , ActorLaunch a , ActorHasMethod a "verse" (Verse :-> Return (Either Text Text)) - --, Eval (LookupSig "verse" (ActorInterface a)) - -- ~ - -- Just (Verse :-> Return (Either Text Text)) - , ActorKey a ~ Key a + , ActorIdentity a ~ Key a , Eq (Key a) , Hashable (Key a) , H.HEq - (TVar (M.HashMap (Key a) (ActorRef a))) - (TVar (M.HashMap PersonId (ActorRef Person))) - b0 + (TVar (M.HashMap (Key a) (Ref a))) + (TVar (M.HashMap (Key Person) (Ref Person))) + b + , H.HOccurrence' + b + (TVar (M.HashMap (Key a) (Ref a))) + [TVar (M.HashMap (Key Person) (Ref Person)), + TVar (M.HashMap (Key Project) (Ref Project)), + TVar (M.HashMap (Key Group) (Ref Group)), + TVar (M.HashMap (Key Deck) (Ref Deck)), + TVar (M.HashMap (Key Loom) (Ref Loom)), + TVar (M.HashMap (Key Repo) (Ref Repo)), + TVar (M.HashMap (Key Factory) (Ref Factory))] + l + , H.HOccurs' + (TVar (M.HashMap (Key a) (Ref a))) + l + [TVar (M.HashMap (Key Person) (Ref Person)), + TVar (M.HashMap (Key Project) (Ref Project)), + TVar (M.HashMap (Key Group) (Ref Group)), + TVar (M.HashMap (Key Deck) (Ref Deck)), + TVar (M.HashMap (Key Loom) (Ref Loom)), + TVar (M.HashMap (Key Repo) (Ref Repo)), + TVar (M.HashMap (Key Factory) (Ref Factory))] + , H.HEq + (TVar (ActorRefMap a)) (TVar (ActorRefMap Person)) b0 , H.HOccurrence' b0 - (TVar (M.HashMap (Key a) (ActorRef a))) - '[TVar (M.HashMap PersonId (ActorRef Person)), - TVar (M.HashMap ProjectId (ActorRef Project)), - TVar (M.HashMap GroupId (ActorRef Group)), - TVar (M.HashMap DeckId (ActorRef Deck)), - TVar (M.HashMap LoomId (ActorRef Loom)), - TVar (M.HashMap RepoId (ActorRef Vervis.Model.Repo)), - TVar (M.HashMap FactoryId (ActorRef Factory))] - l'0 + (TVar (ActorRefMap a)) + [TVar (ActorRefMap Person), TVar (ActorRefMap Project), + TVar (ActorRefMap Group), TVar (ActorRefMap Deck), + TVar (ActorRefMap Loom), TVar (ActorRefMap Repo), + TVar (ActorRefMap Factory)] + l0 , H.HOccurs' - (TVar (M.HashMap (Key a) (ActorRef a))) - l'0 - '[TVar (M.HashMap PersonId (ActorRef Person)), - TVar (M.HashMap ProjectId (ActorRef Project)), - TVar (M.HashMap GroupId (ActorRef Group)), - TVar (M.HashMap DeckId (ActorRef Deck)), - TVar (M.HashMap LoomId (ActorRef Loom)), - TVar (M.HashMap RepoId (ActorRef Vervis.Model.Repo)), - TVar (M.HashMap FactoryId (ActorRef Factory))] + (TVar (ActorRefMap a)) + l0 + [TVar (ActorRefMap Person), TVar (ActorRefMap Project), + TVar (ActorRefMap Group), TVar (ActorRefMap Deck), + TVar (ActorRefMap Loom), TVar (ActorRefMap Repo), + TVar (ActorRefMap Factory)] ) => (Key a -> LocalActorBy Key) -> Key a -> Handler () postInbox toLA recipID = do @@ -319,8 +334,14 @@ postInbox toLA recipID = do recipByHash <- hashLocalActor recipByKey msig <- checkForwarding recipByHash return (author, luActivity, msig) + ref <- lift $ do + tvar <- H.hOccurs <$> getsYesod appActors + actors <- liftIO $ readTVarIO tvar + case M.lookup recipID actors of + Nothing -> notFound + Just (ref :: Ref a) -> pure ref theater <- getsYesod appTheater - r <- liftIO $ callIO' @"verse" theater Proxy recipID $ Verse authorIdMsig body `HCons` HNil + r <- liftIO $ callIO' @"verse" @a theater Proxy ref $ Verse authorIdMsig body `HCons` HNil case r of Nothing -> notFound Just (Left e) -> throwE e diff --git a/src/Web/Actor/Deliver.hs b/src/Web/Actor/Deliver.hs index 7251dcc..1b7b1a0 100644 --- a/src/Web/Actor/Deliver.hs +++ b/src/Web/Actor/Deliver.hs @@ -31,6 +31,8 @@ module Web.Actor.Deliver ) where +import Control.Concurrent.STM +import Control.Concurrent.STM.TVar import Control.Exception.Base hiding (handle) import Control.Monad import Control.Monad.IO.Class @@ -41,6 +43,7 @@ import Control.Retry import Data.ByteString (ByteString) import Data.Foldable import Data.Hashable +import Data.HashMap.Strict (HashMap) import Data.HList (HList (..)) import Data.List import Data.List.NonEmpty (NonEmpty) @@ -61,6 +64,7 @@ import Web.Hashids import qualified Data.Aeson as A import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS import qualified Data.HList as H import qualified Data.Text as T @@ -87,8 +91,8 @@ data DeliveryActor u data DeliveryStage u instance UriMode u => Actor (DeliveryActor u) where - type ActorStage (DeliveryActor u) = DeliveryStage u - type ActorKey (DeliveryActor u) = ObjURI u + type ActorStage (DeliveryActor u) = DeliveryStage u + type ActorIdentity (DeliveryActor u) = ObjURI u type ActorInterface (DeliveryActor u) = [ "deliver-local" ::: AP.Envelope u :-> Bool :-> Return () , "forward-remote" ::: AP.Errand u :-> Return () @@ -114,6 +118,7 @@ instance UriMode u => Stage (DeliveryStage u) where , envInit :: (Manager, NonEmpty HeaderName, Int) } type StageActors (DeliveryStage u) = '[DeliveryActor u] + type StageSpawn (DeliveryStage u) = AllowSpawn {- migrations :: [Migration SqlBackend IO] @@ -138,6 +143,7 @@ data DeliveryTheater u = DeliveryTheater , _dtLog :: LogFunc , _dtDir :: OsPath , _dtTheater :: TheaterFor (DeliveryStage u) + , _dtMap :: TVar (HashMap (ObjURI u) (Ref (DeliveryActor u))) } data IdMismatch = IdMismatch deriving Show @@ -219,13 +225,14 @@ decodeUtf = pure startDeliveryTheater :: UriMode u - => NonEmpty HeaderName + => FilePath + -> NonEmpty HeaderName -> Int -> Manager -> LogFunc -> OsPath -> IO (DeliveryTheater u) -startDeliveryTheater headers micros manager logFunc dbRootDir = do +startDeliveryTheater avarBoxPath headers micros manager logFunc dbRootDir = do -- We first add the sqlite3 extension as needed entries <- listDirectory dbRootDir @@ -249,7 +256,9 @@ startDeliveryTheater headers micros manager logFunc dbRootDir = do Right uri -> return uri env <- mkEnv (manager, headers, micros) logFunc (dbRootDir path) return (u, env) - DeliveryTheater manager headers micros logFunc dbRootDir <$> startTheater logFunc (actors `H.HCons` H.HNil) + (theater, actorMap `HCons` HNil) <- startTheater avarBoxPath logFunc (actors `H.HCons` H.HNil) + actorMapVar <- newTVarIO $ HM.fromList actorMap + return $ DeliveryTheater manager headers micros logFunc dbRootDir theater actorMapVar data DeliveryMethod u = MethodDeliverLocal (AP.Envelope u) Bool @@ -257,18 +266,26 @@ data DeliveryMethod u -- Since sendManyIO isn't available right now, we're using many sendIO sendHttp :: UriMode u => DeliveryTheater u -> DeliveryMethod u -> [ObjURI u] -> IO () -sendHttp (DeliveryTheater manager headers micros logFunc root theater) method recips = +sendHttp (DeliveryTheater manager headers micros logFunc root theater actorMapVar) method recips = case method of MethodDeliverLocal envelope fwd -> for_ recips $ \ u -> do - void $ spawnIO theater u (makeEnv u) - void $ sendIO' @"deliver-local" theater Proxy u $ envelope `HCons` fwd `HCons` HNil + ref <- getRef u + void $ sendIO' @"deliver-local" theater Proxy ref $ envelope `HCons` fwd `HCons` HNil MethodForwardRemote errand -> for_ recips $ \ u -> do - void $ spawnIO theater u (makeEnv u) - void $ sendIO' @"forward-remote" theater Proxy u $ errand `HCons` HNil + ref <- getRef u + void $ sendIO' @"forward-remote" theater Proxy ref $ errand `HCons` HNil where makeEnv u = either throwIO pure (TE.decodeUtf8' $ urlEncode False $ TE.encodeUtf8 $ renderObjURI u) >>= encodeUtf . (<.> "sqlite3") . (root ) . T.unpack >>= mkEnv (manager, headers, micros) logFunc + getRef u = do + mref <- HM.lookup u <$> readTVarIO actorMapVar + case mref of + Just r -> pure r + Nothing -> do + r <- spawnIO theater u (makeEnv u) + atomically $ modifyTVar' actorMapVar $ HM.insert u r + return r