diff --git a/src/Control/Concurrent/Actor.hs b/src/Control/Concurrent/Actor.hs index c68d9ee..7cb9675 100644 --- a/src/Control/Concurrent/Actor.hs +++ b/src/Control/Concurrent/Actor.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2023, 2024 by fr33domlover . + - Written in 2019, 2020, 2024 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -13,14 +13,31 @@ - . -} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilyDependencies #-} + +{-# LANGUAGE IncoherentInstances #-} + module Control.Concurrent.Actor - ( Stage (..) + ( Next () + , Actor (..) + , ActorLaunch (..) + , Stage (..) + , ActorRef () , TheaterFor () , ActFor () , runActor , MonadActor (..) , asksEnv - , Next () , Message (..) , startTheater , callIO @@ -37,6 +54,13 @@ module Control.Concurrent.Actor ) where +import Data.HList (HList) +import Data.Kind +import Fcf +import "first-class-families" Fcf.Data.Symbol + +import qualified Data.HList as H + import Control.Concurrent import Control.Concurrent.STM.TVar import Control.Monad @@ -52,6 +76,7 @@ import Data.Foldable import Data.Hashable import Data.HashMap.Strict (HashMap) import Data.HashSet (HashSet) +import Data.Proxy import Data.Text (Text) import Data.Traversable import UnliftIO.Exception @@ -64,8 +89,6 @@ import qualified Data.Text as T import Control.Concurrent.Return -type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () - -- PROBLEM: I'm stuck with how App can hold the (TheaterFor Env) while Env -- needs to somehow hold the route rendering function (Route App -> Text) so -- there's a cyclic reference @@ -79,15 +102,34 @@ type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () -- -- And that change into abstract type can also help with the cyclic reference? -class Stage a where - type StageKey a - type StageMessage a - type StageReturn a +type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () -newtype Actor m r = Actor (Chan (m, Either SomeException r -> IO ())) +data Next = Stop | Proceed -callIO' :: Actor m r -> m -> IO r -callIO' (Actor chan) msg = do +class Actor (a :: Type) where + type ActorStage a :: Type + type ActorKey a = (k :: Type) | k -> a + data ActorMessage a :: Type + type ActorReturn a :: Type + +class Actor a => ActorLaunch a where + actorBehavior + :: ActorKey a + -> ActorMessage a + -> ActFor + (ActorStage a) + (ActorReturn a, ActFor (ActorStage a) (), Next) + +class Stage (a :: Type) where + data StageEnv a :: Type + type StageActors a :: [Type] + +newtype ActorRef' m r = ActorRef' (Chan (m, Either SomeException r -> IO ())) + +newtype ActorRef a = ActorRef (ActorRef' (ActorMessage a) (ActorReturn a)) + +callIO'' :: ActorRef' m r -> m -> IO r +callIO'' (ActorRef' chan) msg = do (returx, wait) <- newReturn writeChan chan (msg, returx) result <- wait @@ -95,19 +137,31 @@ callIO' (Actor chan) msg = do Left e -> AE.checkpointCallStack $ throwIO e Right r -> return r -sendIO' :: Actor m r -> m -> IO () -sendIO' (Actor chan) msg = writeChan chan (msg, const $ pure ()) +callIO' :: Actor a => ActorRef a -> ActorMessage a -> IO (ActorReturn a) +callIO' (ActorRef ref) = callIO'' ref + +sendIO'' :: ActorRef' m r -> m -> IO () +sendIO'' (ActorRef' chan) msg = writeChan chan (msg, const $ pure ()) + +sendIO' :: Actor a => ActorRef a -> ActorMessage a -> IO () +sendIO' (ActorRef ref) = sendIO'' ref + +type ActorRefMap a = HashMap (ActorKey a) (ActorRef a) + +data Item_ :: Type -> Exp Type +type instance Eval (Item_ a) = TVar (ActorRefMap a) -- | A set of live actors responding to messages data TheaterFor s = TheaterFor - { theaterMap :: TVar (HashMap (StageKey s) (Actor (StageMessage s) (StageReturn s))) + { theaterMap :: HList (Eval (Map Item_ (StageActors s))) , theaterLog :: LogFunc } +-- theaterMap :: TVar (HashMap (StageKey s) (ActorRef (StageMessage s) (StageReturn s))) -- | Actor monad in which message reponse actions are executed. Supports -- logging, a read-only environment, and IO. newtype ActFor s a = ActFor - { unActFor :: LoggingT (ReaderT (s, TheaterFor s) IO) a + { unActFor :: LoggingT (ReaderT (StageEnv s, TheaterFor s) IO) a } deriving ( Functor, Applicative, Monad, MonadFail, MonadIO, MonadLogger @@ -118,60 +172,63 @@ instance MonadUnliftIO (ActFor s) where withRunInIO inner = ActFor $ withRunInIO $ \ run -> inner (run . unActFor) -runActor :: TheaterFor s -> s -> ActFor s a -> IO a +runActor :: TheaterFor s -> StageEnv s -> ActFor s a -> IO a runActor theater env (ActFor action) = runReaderT (runLoggingT action $ theaterLog theater) (env, theater) -class Monad m => MonadActor m where - type ActorEnv m - askEnv :: m (ActorEnv m) - liftActor :: ActFor (ActorEnv m) a -> m a +class (Monad m, Stage (MonadActorStage m)) => MonadActor m where + type MonadActorStage m + askEnv :: m (StageEnv (MonadActorStage m)) + liftActor :: ActFor (MonadActorStage m) a -> m a -instance MonadActor (ActFor s) where - type ActorEnv (ActFor s) = s +instance Stage (s :: Type) => MonadActor (ActFor s) where + type MonadActorStage (ActFor s) = s askEnv = ActFor $ lift $ asks fst liftActor = id instance MonadActor m => MonadActor (ReaderT r m) where - type ActorEnv (ReaderT r m) = ActorEnv m - askEnv = lift askEnv - liftActor = lift . liftActor + type MonadActorStage (ReaderT r m) = MonadActorStage m + askEnv = lift askEnv + liftActor = lift . liftActor instance MonadActor m => MonadActor (MaybeT m) where - type ActorEnv (MaybeT m) = ActorEnv m - askEnv = lift askEnv - liftActor = lift . liftActor + type MonadActorStage (MaybeT m) = MonadActorStage m + askEnv = lift askEnv + liftActor = lift . liftActor instance MonadActor m => MonadActor (ExceptT e m) where - type ActorEnv (ExceptT e m) = ActorEnv m - askEnv = lift askEnv - liftActor = lift . liftActor + type MonadActorStage (ExceptT e m) = MonadActorStage m + askEnv = lift askEnv + liftActor = lift . liftActor instance (Monoid w, MonadActor m) => MonadActor (RWSL.RWST r w s m) where - type ActorEnv (RWSL.RWST r w s m) = ActorEnv m - askEnv = lift askEnv - liftActor = lift . liftActor + type MonadActorStage (RWSL.RWST r w s m) = MonadActorStage m + askEnv = lift askEnv + liftActor = lift . liftActor -asksEnv :: MonadActor m => (ActorEnv m -> a) -> m a +asksEnv :: MonadActor m => (StageEnv (MonadActorStage m) -> a) -> m a asksEnv f = f <$> askEnv -data Next = Stop | Proceed - class Message a where summarize :: a -> Text refer :: a -> Text launchActorThread - :: ( StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r - , Hashable k, Eq k, Show k, Message m, Show r + :: forall (a::Type) (k::Type) (m::Type) (r::Type) (s::Type). + ( ActorLaunch a + , ActorStage a ~ s + , ActorKey a ~ k, ActorMessage a ~ m, ActorReturn a ~ r + , H.HOccurs + (TVar (ActorRefMap a)) + (HList (Eval (Map Item_ (StageActors s)))) + , Eq k, Hashable k, Show k, Message m, Show r ) => Chan (m, Either SomeException r -> IO ()) -> TheaterFor s -> k - -> s - -> (m -> ActFor s (r, ActFor s (), Next)) + -> StageEnv s -> IO () -launchActorThread chan theater actor env behavior = +launchActorThread chan theater actor env = void $ forkIO $ runActor theater env $ do logInfo $ prefix <> "starting" loop @@ -181,7 +238,7 @@ launchActorThread chan theater actor env behavior = loop = do (message, respond) <- liftIO $ readChan chan logInfo $ T.concat [prefix, "received: ", summarize message] - result <- try $ behavior message + result <- try $ behavior (actorProxy actor) actor message proceed <- case result of Left e -> do @@ -195,50 +252,182 @@ launchActorThread chan theater actor env behavior = case next of Stop -> do logInfo $ T.concat [prefix, "on ", refer message, " stopping"] - let tvar = theaterMap theater + + let tvar = H.hOccurs (theaterMap theater) :: TVar (ActorRefMap a) liftIO $ atomically $ modifyTVar' tvar $ HM.delete actor + return False Proceed -> do logInfo $ T.concat [prefix, "on ", refer message, " done"] return True when proceed loop + actorProxy :: forall a. ActorKey a -> Proxy a + actorProxy _ = Proxy + behavior + :: Proxy a + -> ActorKey a + -> ActorMessage a + -> ActFor + (ActorStage a) + (ActorReturn a, ActFor (ActorStage a) (), Next) + behavior _ = actorBehavior + +--data HFind :: Type -> [Type] -> Maybe Type +--type instance Eval (HFind a as) = Eval (Find (TyEq a) as) :: Exp (Maybe a) + +prepareActorType + :: ( ActorLaunch a + , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a) + , Message (ActorMessage a) + , Show (ActorReturn a) + , ActorStage a ~ s + , Stage s + , H.HOccurs + (TVar (ActorRefMap a)) + (HList (Eval (Map Item_ (StageActors s)))) + ) + => [(ActorKey a, StageEnv s)] + -> IO + ( TVar (ActorRefMap a) + , TheaterFor s -> IO () + ) +prepareActorType actors = do + actorsWithChans <- for actors $ \ (key, env) -> do + chan <- newChan + return (key, env, chan) + tvar <- + newTVarIO $ HM.fromList $ + map + (\ (key, _, chan) -> (key, ActorRef $ ActorRef' chan)) + actorsWithChans + return + ( tvar + , \ theater -> for_ actorsWithChans $ \ (key, env, chan) -> + launchActorThread chan theater key env + ) + +data HPrepareActorType = HPrepareActorType +instance + ( ActorLaunch a + , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a) + , Message (ActorMessage a) + , Show (ActorReturn a) + , ActorStage a ~ s + , Stage s + , H.HOccurs + (TVar (ActorRefMap a)) + (HList (Eval (Map Item_ (StageActors s)))) + , i ~ [(ActorKey a, StageEnv s)] + , o ~ IO (TVar (ActorRefMap a), TheaterFor (ActorStage a) -> IO ()) + ) => + H.ApplyAB HPrepareActorType i o where + applyAB _ a = prepareActorType a + +--Why can't the compiler prove the HOccurence? Because it can't detect the l'? + +data A_ :: Type -> Exp Constraint +type instance Eval (A_ a) = + ( ActorLaunch a + , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a) + , Message (ActorMessage a) + , Show (ActorReturn a) + ) + +data Starter :: Type -> Exp Type +type instance Eval (Starter a) = [(ActorKey a, StageEnv (ActorStage a))] + +data Prepare_ :: Type -> Type -> Exp Type +type instance Eval (Prepare_ s a) = IO (TVar (ActorRefMap a), TheaterFor s -> IO ()) + +data Pair_ :: Type -> Type -> Exp Type +type instance Eval (Pair_ s a) = (TVar (ActorRefMap a), TheaterFor s -> IO ()) + +data Launch_ :: Type -> Type -> Exp Type +type instance Eval (Launch_ s _) = TheaterFor s -> IO () -- | Launch the actor system startTheater - :: ( StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r - , Hashable k, Eq k, Show k, Message m, Show r + :: forall (s :: Type) (as :: [Type]) . + ( Stage s + , StageActors s ~ as + , Eval (Constraints (Eval (Map A_ as))) + + , H.HMapAux + HList + HPrepareActorType + (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)) + (Eval (Map (Pair_ s) as)) + + , H.SameLength' + (Eval (Map Item_ as)) + (Eval (Map (Launch_ s) as)) + , H.SameLength' + (Eval (Map (Launch_ s) as)) + (Eval (Map Item_ 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)) + + , H.HZipList + (Eval (Map Item_ as)) + (Eval (Map (Launch_ s) as)) + (Eval (Map (Pair_ s) as)) + + , H.HList2List + (Eval (Map (Launch_ s) as)) + (TheaterFor s -> IO ()) ) => LogFunc - -> [(k, s, m -> ActFor s (r, ActFor s (), Next))] + -> HList (Eval (Map Starter as)) -> IO (TheaterFor s) startTheater logFunc actors = do - actorsWithChans <- for actors $ \ (key, env, behavior) -> do - chan <- newChan - return ((key, Actor chan), (env, behavior)) - tvar <- newTVarIO $ HM.fromList $ map fst actorsWithChans - let theater = TheaterFor tvar logFunc - for_ actorsWithChans $ \ ((key, Actor chan), (env, behavior)) -> - launchActorThread chan theater key env behavior + 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 Item_ as)), launches :: HList (Eval (Map (Launch_ s) as))) = H.hUnzip mapsAndLaunches + theater = TheaterFor maps logFunc + for_ (H.hList2List launches) $ \ launch -> launch theater return theater askTheater :: ActFor s (TheaterFor s) askTheater = ActFor $ lift $ asks snd lookupActor - :: ( StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r - , Eq k, Hashable k + :: ( Eq (ActorKey a), Hashable (ActorKey a) + , H.HOccurs + (TVar (ActorRefMap a)) + (HList (Eval (Map Item_ (StageActors s)))) ) => TheaterFor s - -> k - -> IO (Maybe (Actor m r)) -lookupActor (TheaterFor tvar _) actor = HM.lookup actor <$> readTVarIO tvar + -> ActorKey a + -> IO (Maybe (ActorRef a)) +lookupActor (TheaterFor hlist _) key = + HM.lookup key <$> readTVarIO (H.hOccurs hlist) + -- | Same as 'call', except it takes the theater as a parameter. callIO - :: ( StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r - , Eq k, Hashable k + :: ( Actor a + , Eq (ActorKey a), Hashable (ActorKey a) + , H.HOccurs + (TVar (ActorRefMap a)) + (HList (Eval (Map Item_ (StageActors s)))) ) - => TheaterFor s -> k -> m -> IO (Maybe r) + => TheaterFor s -> ActorKey a -> ActorMessage a -> IO (Maybe (ActorReturn a)) callIO theater key msg = do maybeActor <- lookupActor theater key for maybeActor $ \ actor -> callIO' actor msg @@ -249,19 +438,27 @@ callIO theater key msg = do -- If the called method throws an exception, it is rethrown, wrapped with an -- annotation, in the current thread. call - :: ( MonadActor n, ActorEnv n ~ s - , StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r - , Eq k, Hashable k + :: ( MonadActor m, MonadActorStage m ~ ActorStage a + , Actor a + , Eq (ActorKey a), Hashable (ActorKey a) + , H.HOccurs + (TVar (ActorRefMap a)) + (HList (Eval (Map Item_ (StageActors (ActorStage a))))) ) - => k -> m -> n (Maybe r) + => ActorKey a -> ActorMessage a -> m (Maybe (ActorReturn a)) call key msg = liftActor $ do theater <- askTheater liftIO $ callIO theater key msg -- | Like 'send', except it takes the theater as a parameter. sendIO - :: (StageKey s ~ k, StageMessage s ~ m, Eq k, Hashable k) - => TheaterFor s -> k -> m -> IO Bool + :: ( Actor a + , Eq (ActorKey a), Hashable (ActorKey a) + , H.HOccurs + (TVar (ActorRefMap a)) + (HList (Eval (Map Item_ (StageActors s)))) + ) + => TheaterFor s -> ActorKey a -> ActorMessage a -> IO Bool sendIO theater key msg = do maybeActor <- lookupActor theater key case maybeActor of @@ -273,56 +470,173 @@ sendIO theater key msg = do -- | Send a message to an actor, without waiting for a result. Return 'True' if -- the given actor exists, 'False' otherwise. send - :: ( MonadActor n, ActorEnv n ~ s - , StageKey s ~ k, StageMessage s ~ m - , Eq k, Hashable k + :: ( MonadActor m, MonadActorStage m ~ ActorStage a + , Actor a + , Eq (ActorKey a), Hashable (ActorKey a) + , H.HOccurs + (TVar (ActorRefMap a)) + (HList (Eval (Map Item_ (StageActors (ActorStage a))))) ) - => k -> m -> n Bool + => ActorKey a -> ActorMessage a -> m Bool send key msg = liftActor $ do theater <- askTheater liftIO $ sendIO theater key msg --- | Like 'sendMany', except it takes the theater as a parameter. -sendManyIO - :: (StageKey s ~ k, StageMessage s ~ m, Eq k, Hashable k) - => TheaterFor s -> HashSet k -> m -> IO () -sendManyIO (TheaterFor tvar _) recips msg = do +hSendTo + :: ( Actor a + , Eq (ActorKey a), Hashable (ActorKey a) + ) + => (TVar (ActorRefMap a), (HashSet (ActorKey a), ActorMessage a)) + -> IO () +hSendTo (tvar, (recips, msg)) = do allActors <- readTVarIO tvar for_ (HM.intersection allActors (HS.toMap recips)) $ \ actor -> sendIO' actor msg +data HSendTo = HSendTo +instance + ( Actor a + , Eq (ActorKey a), Hashable (ActorKey a) + , i ~ (TVar (ActorRefMap a), (HashSet (ActorKey a), ActorMessage a)) + ) => + H.ApplyAB HSendTo i (IO ()) where + applyAB _ a = hSendTo a + +data B_ :: Type -> Exp Constraint +type instance Eval (B_ a) = + ( Actor a + , Eq (ActorKey a), Hashable (ActorKey a) + ) + +data Set_ :: Type -> Exp Type +type instance Eval (Set_ a) = (HashSet (ActorKey a), ActorMessage a) + +data Pair__ :: Type -> Exp Type +type instance Eval (Pair__ a) = (Eval (Item_ a), Eval (Set_ a)) + +-- | Like 'sendMany', except it takes the theater as a parameter. +sendManyIO + :: forall s. + ( Stage s + , Eval (Constraints (Eval (Map B_ (StageActors s)))) + + , H.HZipList + (Eval (Map Item_ (StageActors s))) + (Eval (Map Set_ (StageActors s))) + (Eval (Map Pair__ (StageActors s))) + , H.SameLength' + (Eval (Map Item_ (StageActors s))) + (Eval (Map Set_ (StageActors s))) + , H.SameLength' + (Eval (Map Set_ (StageActors s))) + (Eval (Map Item_ (StageActors s))) + , H.SameLength' + (Eval (Map Set_ (StageActors s))) + (Eval (Map Pair__ (StageActors s))) + , H.SameLength' + (Eval (Map Pair__ (StageActors s))) + (Eval (Map Set_ (StageActors s))) + , H.HMapAux + HList + HSendTo + (Eval (Map Pair__ (StageActors s))) + (Eval (Map (ConstFn (IO ())) (StageActors s))) + , H.SameLength' + (Eval (Map Pair__ (StageActors s))) + (Eval (Map (ConstFn (IO ())) (StageActors s))) + , H.SameLength' + (Eval (Map (ConstFn (IO ())) (StageActors s))) + (Eval (Map Pair__ (StageActors s))) + , H.HSequence + IO + (Eval (Map (ConstFn (IO ())) (StageActors s))) + (Eval (Map (ConstFn ()) (StageActors s))) + ) + => TheaterFor s + -> HList (Eval (Map Set_ (StageActors s))) + -> IO () +sendManyIO (TheaterFor hlist _) recips = + let zipped = H.hZip hlist recips + :: HList (Eval (Map Pair__ (StageActors s))) + actions = H.hMapL HSendTo zipped + :: HList (Eval (Map (ConstFn (IO ())) (StageActors s))) + action = H.hSequence actions + :: IO (HList (Eval (Map (ConstFn ()) (StageActors s)))) + in void action + -- | Send a message to each actor in the set that exists in the system, -- without waiting for results. sendMany - :: ( MonadActor n, ActorEnv n ~ s - , StageKey s ~ k, StageMessage s ~ m - , Eq k, Hashable k + :: forall m s. + ( MonadActor m, MonadActorStage m ~ s + , Stage s + , Eval (Constraints (Eval (Map B_ (StageActors s)))) + + , H.HZipList + (Eval (Map Item_ (StageActors s))) + (Eval (Map Set_ (StageActors s))) + (Eval (Map Pair__ (StageActors s))) + , H.SameLength' + (Eval (Map Item_ (StageActors s))) + (Eval (Map Set_ (StageActors s))) + , H.SameLength' + (Eval (Map Set_ (StageActors s))) + (Eval (Map Item_ (StageActors s))) + , H.SameLength' + (Eval (Map Set_ (StageActors s))) + (Eval (Map Pair__ (StageActors s))) + , H.SameLength' + (Eval (Map Pair__ (StageActors s))) + (Eval (Map Set_ (StageActors s))) + , H.HMapAux + HList + HSendTo + (Eval (Map Pair__ (StageActors s))) + (Eval (Map (ConstFn (IO ())) (StageActors s))) + , H.SameLength' + (Eval (Map Pair__ (StageActors s))) + (Eval (Map (ConstFn (IO ())) (StageActors s))) + , H.SameLength' + (Eval (Map (ConstFn (IO ())) (StageActors s))) + (Eval (Map Pair__ (StageActors s))) + , H.HSequence + IO + (Eval (Map (ConstFn (IO ())) (StageActors s))) + (Eval (Map (ConstFn ()) (StageActors s))) ) - => HashSet k -> m -> n () -sendMany keys msg = liftActor $ do + => HList (Eval (Map Set_ (StageActors s))) + -> m () +sendMany keys = liftActor $ do theater <- askTheater - liftIO $ sendManyIO theater keys msg + liftIO $ sendManyIO theater keys -- | Same as 'spawn', except it takes the theater as a parameter. spawnIO - :: ( StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r - , Eq k, Hashable k, Show k, Message m, Show r + :: forall a s. + ( ActorLaunch a, ActorStage a ~ s + , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a) + , Message (ActorMessage a) + , Show (ActorReturn a) + + , H.HOccurs + (TVar (HashMap (ActorKey a) (ActorRef a))) + (HList (Eval (Map Item_ (StageActors s)))) ) => TheaterFor s - -> k - -> IO s - -> (m -> ActFor s (r, ActFor s (), Next)) + -> ActorKey a + -> IO (StageEnv s) -> IO Bool -spawnIO theater@(TheaterFor tvar _) key mkEnv behavior = do +spawnIO theater@(TheaterFor hlist _) key mkEnv = do + let tvar = H.hOccurs hlist :: TVar (ActorRefMap a) chan <- newChan added <- atomically $ stateTVar tvar $ \ hm -> - let hm' = HM.alter (create $ Actor chan) key 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 behavior + launchActorThread chan theater key env return added where create actor Nothing = Just actor @@ -332,23 +646,29 @@ spawnIO theater@(TheaterFor tvar _) key mkEnv behavior = do -- 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 - :: ( MonadActor n, ActorEnv n ~ s - , StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r - , Eq k, Hashable k, Show k, Message m, Show r - ) - => k - -> IO s - -> (m -> ActFor s (r, ActFor s (), Next)) - -> n Bool -spawn key mkEnv behavior = liftActor $ do - theater <- askTheater - liftIO $ spawnIO theater key mkEnv behavior + :: forall m a s. + ( MonadActor m, MonadActorStage m ~ s + , ActorLaunch a, ActorStage a ~ s + , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a) + , Message (ActorMessage a) + , Show (ActorReturn a) -done :: Monad n => a -> n (a, ActFor s (), Next) + , H.HOccurs + (TVar (HashMap (ActorKey a) (ActorRef a))) + (HList (Eval (Map Item_ (StageActors s)))) + ) + => ActorKey a + -> IO (StageEnv s) + -> m Bool +spawn key mkEnv = liftActor $ do + theater <- askTheater + liftIO $ spawnIO theater key mkEnv + +done :: Monad m => a -> m (a, ActFor s (), Next) done msg = return (msg, return (), Proceed) -doneAnd :: Monad n => a -> ActFor s () -> n (a, ActFor s (), Next) +doneAnd :: Monad m => a -> ActFor s () -> m (a, ActFor s (), Next) doneAnd msg act = return (msg, act, Proceed) -stop :: Monad n => a -> n (a, ActFor s (), Next) +stop :: Monad m => a -> m (a, ActFor s (), Next) stop msg = return (msg, return (), Stop) diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 6876835..ee069ba 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -72,7 +72,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL -import Control.Concurrent.Actor +import Control.Concurrent.Actor hiding (Actor) import Database.Persist.JSON import Development.PatchMediaType import Network.FedURI @@ -126,7 +126,6 @@ import Vervis.Recipient import Vervis.RemoteActorStore import Vervis.Settings import Vervis.Ticket -import Vervis.Web.Delivery import Vervis.Web.Repo import qualified Vervis.Actor2 as VA2 @@ -148,7 +147,7 @@ handleViaActor personID maybeCap localRecips remoteRecips fwdHosts action = do let maybeCap' = first (\ (byKey, _, i) -> (byKey, i)) <$> maybeCap msg = ClientMsg maybeCap' localRecips remoteRecips fwdHosts action maybeResult <- - liftIO $ callIO theater (LocalActorPerson personID) (Right msg) + liftIO $ callIO theater personID (MsgP $ Right msg) itemText <- case maybeResult of Nothing -> error "Person not found in theater" @@ -290,9 +289,12 @@ acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re ] return $ makeRecipientSet sieveActors sieveStages let localRecipsFinal = localRecipSieve sieve False localRecips + {- deliverActivityDB (LocalActorPerson senderHash) (personActor senderPerson) localRecipsFinal remoteRecips fwdHosts acceptID action + -} + pure $ pure () -- If resource is local, approve the Collab and deliver a Grant deliverHttpGrant <- for maybeCollabMore $ \ (collabID, _, _, resource, sender) -> do @@ -324,9 +326,12 @@ acceptC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re -- for unavailable remote recipients resourceHash <- grantResourceLocalActor <$> hashGrantResource resource + {- deliverActivityDB resourceHash resourceActorID localRecipsGrant remoteRecipsGrant fwdHostsGrant grantID actionGrant + -} + pure $ pure () -- Return instructions for HTTP delivery to remote recipients return @@ -677,9 +682,12 @@ applyC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips rem ] return $ makeRecipientSet sieveActors sieveStages let localRecipsFinal = localRecipSieve sieve False localRecips + {- deliverActivityDB (LocalActorPerson senderHash) (personActor senderPerson) localRecipsFinal remoteRecips fwdHosts applyID action + -} + pure $ pure () -- Verify that the loom has received the Apply, resolve the Ticket in -- DB, and publish Accept @@ -711,9 +719,12 @@ applyC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips rem -- delivery for unavailable remote recipients let localRecipsAccept = makeRecipientSet acceptRecipActors acceptRecipStages + {- deliverActivityDB (LocalActorLoom loomHash) loomActorID localRecipsAccept [] [] acceptID actionAccept + -} + pure $ pure () -- Return instructions for HTTP delivery or Apply and Accept to remote -- recipients @@ -862,9 +873,12 @@ createNoteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecip return $ makeRecipientSet actors stages let localRecipsFinal = localRecipSieve' sieve True False localRecips + {- deliverActivityDB (LocalActorPerson senderHash) (personActor senderPerson) localRecipsFinal remoteRecips fwdHosts createID actionCreate + -} + pure $ pure () -- Return instructions for HTTP delivery to remote recipients return (createID, deliverHttpCreate) @@ -1049,9 +1063,12 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips , LocalStageRepoFollowers repoHash ] localRecipsFinal = localRecipSieve sieve False localRecips + {- deliverActivityDB (LocalActorPerson senderHash) (personActor personUser) localRecipsFinal remoteRecips fwdHosts obiidCreate actionCreate + -} + pure $ pure () -- Insert collaboration access for loom's creator let loomOutboxID = actorOutbox loomActor @@ -1070,9 +1087,12 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips deliverHttpGrant <- do let localRecipsGrant = makeRecipientSet grantRecipActors grantRecipStages + {- deliverActivityDB (LocalActorLoom loomHash) loomActorID localRecipsGrant [] [] obiidGrant actionGrant + -} + pure $ pure () -- Insert follow record obiidFollow <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now @@ -1104,7 +1124,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips success <- do theater <- asksSite appTheater env <- asksSite appEnv - liftIO $ launchActorIO theater env LocalActorLoom loomID + liftIO $ launchActorIO theater env loomID unless success $ error "Failed to spawn new Loom, somehow ID already in Theater" @@ -1295,9 +1315,12 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r let sieve = makeRecipientSet [] [LocalStagePersonFollowers senderHash] localRecipsFinal = localRecipSieve sieve False localRecips + {- deliverActivityDB (LocalActorPerson senderHash) (personActor personUser) localRecipsFinal remoteRecips fwdHosts obiidCreate actionCreate + -} + pure $ pure () -- Insert collaboration access for repo's creator let repoOutboxID = actorOutbox repoActor @@ -1315,9 +1338,12 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r deliverHttpGrant <- do let localRecipsGrant = makeRecipientSet grantRecipActors grantRecipStages + {- deliverActivityDB (LocalActorRepo repoHash) repoActorID localRecipsGrant [] [] grantID actionGrant + -} + pure $ pure () -- Insert follow record obiidFollow <- lift $ insertEmptyOutboxItem (actorOutbox senderActor) now @@ -1352,7 +1378,7 @@ createRepositoryC (Entity pidUser personUser) senderActor maybeCap localRecips r success <- do theater <- asksSite appTheater env <- asksSite appEnv - liftIO $ launchActorIO theater env LocalActorRepo repoID + liftIO $ launchActorIO theater env repoID unless success $ error "Failed to spawn new Repo, somehow ID already in Theater" @@ -1572,9 +1598,12 @@ followC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re let stages' = LocalStagePersonFollowers senderHash : stages return $ makeRecipientSet actors stages' let localRecipsFinal = localRecipSieve sieve False localRecips + {- deliverActivityDB (LocalActorPerson senderHash) (personActor senderPerson) localRecipsFinal remoteRecips fwdHosts followID action + -} + pure $ pure () maybeDeliverHttpAccept <- case followeeDB of @@ -1614,9 +1643,12 @@ followC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips re -- schedule delivery for unavailable remote recipients let localRecipsAccept = makeRecipientSet acceptActors acceptStages actorByHash <- hashLocalActor actorByKey + {- deliverActivityDB actorByHash actorID localRecipsAccept [] [] acceptID actionAccept + -} + pure $ pure () -- Return instructions for HTTP delivery to remote recipients return (followID, deliverHttpFollow, maybeDeliverHttpAccept) diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs index f3dee60..9149e8f 100644 --- a/src/Vervis/Actor.hs +++ b/src/Vervis/Actor.hs @@ -79,7 +79,8 @@ module Vervis.Actor -- * Behavior utility types , VerseExt - , Env (..) + , StageEnv (..) + , Staje , Act , ActE , ActDB @@ -91,6 +92,8 @@ module Vervis.Actor , withDBExcept , behave , VervisActor (..) + , VervisActorLaunch (..) + , ActorMessage (..) , launchActorIO , launchActor @@ -116,6 +119,8 @@ import Data.ByteString (ByteString) import Data.Foldable import Data.Function import Data.Hashable +import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) import Data.List.NonEmpty (NonEmpty) import Data.Maybe import Data.Text (Text) @@ -133,13 +138,13 @@ 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.HList as H import qualified Data.List.NonEmpty as NE import qualified Data.List.Ordered as LO import qualified Data.Text as T import qualified Database.Esqueleto as E import Control.Concurrent.Actor -import Crypto.ActorKey import Network.FedURI import Web.Actor import Web.Actor.Deliver @@ -147,6 +152,7 @@ import Web.Actor.Persist import Yesod.Hashids import Yesod.MonadSite +import qualified Crypto.ActorKey as AK import qualified Web.ActivityPub as AP import Data.List.NonEmpty.Local @@ -231,14 +237,14 @@ hashLocalActorPure ctx = f f (LocalActorProject j) = LocalActorProject $ encodeKeyHashidPure ctx j getHashLocalActor - :: (MonadActor m, StageHashids (ActorEnv m)) + :: (MonadActor m, StageHashids (MonadActorStage m)) => m (LocalActorBy Key -> LocalActorBy KeyHashid) getHashLocalActor = do ctx <- asksEnv stageHashidsContext return $ hashLocalActorPure ctx hashLocalActor - :: (MonadActor m, StageHashids (ActorEnv m)) + :: (MonadActor m, StageHashids (MonadActorStage m)) => LocalActorBy Key -> m (LocalActorBy KeyHashid) hashLocalActor actor = do hash <- getHashLocalActor @@ -256,24 +262,24 @@ unhashLocalActorPure ctx = f f (LocalActorProject j) = LocalActorProject <$> decodeKeyHashidPure ctx j unhashLocalActor - :: (MonadActor m, StageHashids (ActorEnv m)) + :: (MonadActor m, StageHashids (MonadActorStage m)) => LocalActorBy KeyHashid -> m (Maybe (LocalActorBy Key)) unhashLocalActor actor = do ctx <- asksEnv stageHashidsContext return $ unhashLocalActorPure ctx actor unhashLocalActorF - :: (F.MonadFail m, MonadActor m, StageHashids (ActorEnv m)) + :: (F.MonadFail m, MonadActor m, StageHashids (MonadActorStage m)) => LocalActorBy KeyHashid -> String -> m (LocalActorBy Key) unhashLocalActorF actor e = maybe (F.fail e) return =<< unhashLocalActor actor unhashLocalActorM - :: (MonadActor m, StageHashids (ActorEnv m)) + :: (MonadActor m, StageHashids (MonadActorStage m)) => LocalActorBy KeyHashid -> MaybeT m (LocalActorBy Key) unhashLocalActorM = MaybeT . unhashLocalActor unhashLocalActorE - :: (MonadActor m, StageHashids (ActorEnv m)) + :: (MonadActor m, StageHashids (MonadActorStage m)) => LocalActorBy KeyHashid -> e -> ExceptT e m (LocalActorBy Key) unhashLocalActorE actor e = ExceptT $ maybe (Left e) Right <$> unhashLocalActor actor @@ -303,14 +309,14 @@ hashLocalResourcePure ctx = f f (LocalResourceProject j) = LocalResourceProject $ encodeKeyHashidPure ctx j getHashLocalResource - :: (MonadActor m, StageHashids (ActorEnv m)) + :: (MonadActor m, StageHashids (MonadActorStage m)) => m (LocalResourceBy Key -> LocalResourceBy KeyHashid) getHashLocalResource = do ctx <- asksEnv stageHashidsContext return $ hashLocalResourcePure ctx hashLocalResource - :: (MonadActor m, StageHashids (ActorEnv m)) + :: (MonadActor m, StageHashids (MonadActorStage m)) => LocalResourceBy Key -> m (LocalResourceBy KeyHashid) hashLocalResource actor = do hash <- getHashLocalResource @@ -327,24 +333,24 @@ unhashLocalResourcePure ctx = f f (LocalResourceProject j) = LocalResourceProject <$> decodeKeyHashidPure ctx j unhashLocalResource - :: (MonadActor m, StageHashids (ActorEnv m)) + :: (MonadActor m, StageHashids (MonadActorStage m)) => LocalResourceBy KeyHashid -> m (Maybe (LocalResourceBy Key)) unhashLocalResource actor = do ctx <- asksEnv stageHashidsContext return $ unhashLocalResourcePure ctx actor unhashLocalResourceF - :: (F.MonadFail m, MonadActor m, StageHashids (ActorEnv m)) + :: (F.MonadFail m, MonadActor m, StageHashids (MonadActorStage m)) => LocalResourceBy KeyHashid -> String -> m (LocalResourceBy Key) unhashLocalResourceF actor e = maybe (F.fail e) return =<< unhashLocalResource actor unhashLocalResourceM - :: (MonadActor m, StageHashids (ActorEnv m)) + :: (MonadActor m, StageHashids (MonadActorStage m)) => LocalResourceBy KeyHashid -> MaybeT m (LocalResourceBy Key) unhashLocalResourceM = MaybeT . unhashLocalResource unhashLocalResourceE - :: (MonadActor m, StageHashids (ActorEnv m)) + :: (MonadActor m, StageHashids (MonadActorStage m)) => LocalResourceBy KeyHashid -> e -> ExceptT e m (LocalResourceBy Key) unhashLocalResourceE actor e = ExceptT $ maybe (Left e) Right <$> unhashLocalResource actor @@ -459,74 +465,145 @@ data ClientMsg = ClientMsg , cmAction :: AP.Action URIMode } +summarizeVerse (Verse (Left (actor, _, itemID)) body) = + let typ = AP.activityType $ AP.activitySpecific $ actbActivity body + in T.concat [typ, " ", T.pack $ show actor, " ", T.pack $ show itemID] +summarizeVerse (Verse (Right (author, luAct, _)) body) = + let ObjURI h _ = remoteAuthorURI author + typ = AP.activityType $ AP.activitySpecific $ actbActivity body + in T.concat [typ, " ", renderObjURI $ ObjURI h luAct] + +referVerse (Verse (Left (actor, _, itemID)) _body) = + T.concat [T.pack $ show actor, " ", T.pack $ show itemID] +referVerse (Verse (Right (author, luAct, _)) _body) = + let ObjURI h _ = remoteAuthorURI author + in renderObjURI $ ObjURI h luAct + type VerseExt = Either Verse ClientMsg -instance Message VerseExt where - summarize (Left (Verse (Left (actor, _, itemID)) body)) = - let typ = AP.activityType $ AP.activitySpecific $ actbActivity body - in T.concat [typ, " ", T.pack $ show actor, " ", T.pack $ show itemID] - summarize (Left (Verse (Right (author, luAct, _)) body)) = - let ObjURI h _ = remoteAuthorURI author - typ = AP.activityType $ AP.activitySpecific $ actbActivity body - in T.concat [typ, " ", renderObjURI $ ObjURI h luAct] - summarize (Right _) = "ClientMsg" - refer (Left (Verse (Left (actor, _, itemID)) _body)) = - T.concat [T.pack $ show actor, " ", T.pack $ show itemID] - refer (Left (Verse (Right (author, luAct, _)) _body)) = - let ObjURI h _ = remoteAuthorURI author - in renderObjURI $ ObjURI h luAct - refer (Right _) = "ClientMsg" +data Staje + +instance Actor Person where + type ActorStage Person = Staje + type ActorKey Person = PersonId + type ActorReturn Person = Either Text Text + data ActorMessage Person = MsgP (Either Verse ClientMsg) +instance Actor Deck where + type ActorStage Deck = Staje + type ActorKey Deck = DeckId + type ActorReturn Deck = Either Text Text + data ActorMessage Deck = MsgD Verse +instance Actor Loom where + type ActorStage Loom = Staje + type ActorKey Loom = LoomId + type ActorReturn Loom = Either Text Text + data ActorMessage Loom = MsgL Verse +instance Actor Repo where + type ActorStage Repo = Staje + type ActorKey Repo = RepoId + type ActorReturn Repo = Either Text Text + data ActorMessage Repo = MsgR Verse +instance Actor Project where + type ActorStage Project = Staje + type ActorKey Project = ProjectId + type ActorReturn Project = Either Text Text + data ActorMessage Project = MsgJ Verse +instance Actor Group where + type ActorStage Group = Staje + type ActorKey Group = GroupId + type ActorReturn Group = Either Text Text + data ActorMessage Group = MsgG Verse + +instance VervisActor Person where + actorVerse = MsgP . Left + toVerse (MsgP e) = + case e of + Left v -> Just v + Right _ -> Nothing +instance VervisActor Project where + actorVerse = MsgJ + toVerse (MsgJ v) = Just v +instance VervisActor Group where + actorVerse = MsgG + toVerse (MsgG v) = Just v +instance VervisActor Deck where + actorVerse = MsgD + toVerse (MsgD v) = Just v +instance VervisActor Loom where + actorVerse = MsgL + toVerse (MsgL v) = Just v +instance VervisActor Repo where + actorVerse = MsgR + toVerse (MsgR v) = Just v + +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 + -- behavior function when launching the actor, having a dedicated datatype is + -- just convenience. The main reason is to allow 'runDB' not to take a + -- connection pool parameter, instead grabbing it from the ReaderT. Another + -- reason is to avoid the clutter of passing the same arguments manually + -- everywhere. + -- + -- The purpose of Env is to hold the system stuff: DB connection pool, + -- settings, HTTP manager, etc. etc. while the data stuff (actual info of the + -- actor) is meant to be passed as parameters of the behavior function. + -- + -- Maybe in the future there won't be data shared by all actors, and then this + -- type can be removed. + { envSettings :: AppSettings + , envDbPool :: ConnectionPool + , envHashidsContext :: HashidsContext + , envActorKeys :: Maybe (TVar (AK.ActorKey, AK.ActorKey, Bool)) + , envDeliveryTheater :: DeliveryTheater URIMode + , envYesodRender :: YesodRender y + , envHttpManager :: Manager + , envFetch :: ActorFetchShare + } + deriving Typeable + type StageActors Staje = [Person, Project, Group, Deck, Loom, Repo] + +instance Message (ActorMessage Person) where + summarize (MsgP (Left verse)) = summarizeVerse verse + summarize (MsgP (Right _)) = "ClientMsg" + refer (MsgP (Left verse)) = referVerse verse + refer (MsgP (Right _)) = "ClientMsg" +instance Message (ActorMessage Deck) where + summarize (MsgD verse) = summarizeVerse verse + refer (MsgD verse) = referVerse verse +instance Message (ActorMessage Loom) where + summarize (MsgL verse) = summarizeVerse verse + refer (MsgL verse) = referVerse verse +instance Message (ActorMessage Repo) where + summarize (MsgR verse) = summarizeVerse verse + refer (MsgR verse) = referVerse verse +instance Message (ActorMessage Project) where + summarize (MsgJ verse) = summarizeVerse verse + refer (MsgJ verse) = referVerse verse +instance Message (ActorMessage Group) where + summarize (MsgG verse) = summarizeVerse verse + refer (MsgG verse) = referVerse verse type YesodRender y = Route y -> [(Text, Text)] -> Text --- | Data to which every actor has access. Since such data can be passed to the --- behavior function when launching the actor, having a dedicated datatype is --- just convenience. The main reason is to allow 'runDB' not to take a --- connection pool parameter, instead grabbing it from the ReaderT. Another --- reason is to avoid the clutter of passing the same arguments manually --- everywhere. --- --- The purpose of Env is to hold the system stuff: DB connection pool, --- settings, HTTP manager, etc. etc. while the data stuff (actual info of the --- actor) is meant to be passed as parameters of the behavior function. --- --- Maybe in the future there won't be data shared by all actors, and then this --- type can be removed. -data Env = forall y. (Typeable y, Yesod y) => Env - { envSettings :: AppSettings - , envDbPool :: ConnectionPool - , envHashidsContext :: HashidsContext - , envActorKeys :: Maybe (TVar (ActorKey, ActorKey, Bool)) - , envDeliveryTheater :: DeliveryTheater URIMode - , envYesodRender :: YesodRender y - , envHttpManager :: Manager - , envFetch :: ActorFetchShare - } - deriving Typeable - -instance Stage Env where - type StageKey Env = LocalActorBy Key - type StageMessage Env = VerseExt - type StageReturn Env = Either Text Text - -instance StageWeb Env where - type StageURIMode Env = URIMode - --type StageRoute Env = Route Site +instance StageWeb Staje where + type StageURIMode Staje = URIMode + --type StageRoute Staje = Route Site stageInstanceHost = appInstanceHost . envSettings stageDeliveryTheater = envDeliveryTheater -instance StageHashids Env where +instance StageHashids Staje where stageHashidsContext = envHashidsContext -type Act = ActFor Env +type Act = ActFor Staje -type ActE = ActForE Env +type ActE = ActForE Staje type ActDB = SqlPersistT Act type ActDBE = ExceptT Text ActDB -type Theater = TheaterFor Env +type Theater = TheaterFor Staje -- | Run a database transaction. If an exception is thrown, the whole -- transaction is aborted. @@ -552,8 +629,8 @@ withDBExcept action = do abort = throwIO . FedError behave - :: (UTCTime -> Key a -> VerseExt -> ExceptT Text Act (Text, Act (), Next)) - -> (Key a -> VerseExt -> Act (Either Text Text, Act (), Next)) + :: (UTCTime -> ActorKey a -> ActorMessage a -> ExceptT Text Act (Text, Act (), Next)) + -> (ActorKey a -> ActorMessage a -> Act (Either Text Text, Act (), Next)) behave handler key msg = do now <- liftIO getCurrentTime result <- runExceptT $ handler now key msg @@ -562,16 +639,84 @@ behave handler key msg = do Right (t, after, next) -> return (Right t, after, next) class VervisActor a where - actorBehavior :: UTCTime -> Key a -> VerseExt -> ActE (Text, Act (), Next) + actorVerse :: Verse -> ActorMessage a + toVerse :: ActorMessage a -> Maybe Verse -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 +class VervisActor a => VervisActorLaunch a where + actorBehavior' :: UTCTime -> ActorKey a -> ActorMessage a -> ActE (Text, Act (), Next) -launchActor :: forall a. VervisActor a => (Key a -> LocalActorBy Key) -> Key a -> Act Bool -launchActor mk key = do +instance (Actor a, VervisActorLaunch a, ActorReturn a ~ Either Text Text, ActorStage a ~ Staje) => ActorLaunch a where + actorBehavior = behave actorBehavior' + +launchActorIO + :: ( ActorLaunch a, ActorStage a ~ Staje + , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a) + , Message (ActorMessage a) + , Show (ActorReturn 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))] + 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))] + ) + => Theater + -> StageEnv Staje + -> ActorKey a + -> IO Bool +launchActorIO theater env key = spawnIO theater key (pure env) + +launchActor + :: ( ActorLaunch a, ActorStage a ~ Staje + , Eq (ActorKey a), Hashable (ActorKey a), Show (ActorKey a) + , Message (ActorMessage a) + , Show (ActorReturn 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))] + 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))] + ) + => ActorKey a + -> Act Bool +launchActor key = do e <- askEnv - spawn (mk key) (pure e) $ behave actorBehavior key + spawn key (pure e) data RemoteRecipient = RemoteRecipient { remoteRecipientActor :: RemoteActorId @@ -739,7 +884,16 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do Just a -> HS.delete a s authorAndId' = second (\ (author, luAct) -> (author, luAct, Nothing)) authorAndId - sendMany liveRecips $ Left $ Verse authorAndId' body + (liveRecipsP, liveRecipsJ, liveRecipsG, liveRecipsD, liveRecipsL, liveRecipsR) = + partitionByActor liveRecips + verse = Verse authorAndId' body + sendMany $ + (liveRecipsP, actorVerse verse) `H.HCons` + (liveRecipsJ, actorVerse verse) `H.HCons` + (liveRecipsG, actorVerse verse) `H.HCons` + (liveRecipsD, actorVerse verse) `H.HCons` + (liveRecipsL, actorVerse verse) `H.HCons` + (liveRecipsR, actorVerse verse) `H.HCons` H.HNil -- Return remote followers, to whom we need to deliver via HTTP return remoteFollowers @@ -831,6 +985,30 @@ sendToLocalActors authorAndId body requireOwner mauthor maidAuthor recips = do E.where_ $ f E.^. FollowTarget `E.in_` E.valList followerSetIDs return $ p E.^. persistIdField + partitionByActor + :: HashSet (LocalActorBy Key) + -> ( HashSet PersonId + , HashSet ProjectId + , HashSet GroupId + , HashSet DeckId + , HashSet LoomId + , HashSet RepoId + ) + partitionByActor = foldl' f (HS.empty, HS.empty, HS.empty, HS.empty, HS.empty, HS.empty) + where + f (p, j, g, d, l, r) (LocalActorPerson k) = + (HS.insert k p, j, g, d, l, r) + f (p, j, g, d, l, r) (LocalActorProject k) = + (p, HS.insert k j, g, d, l, r) + f (p, j, g, d, l, r) (LocalActorGroup k) = + (p, j, HS.insert k g, d, l, r) + f (p, j, g, d, l, r) (LocalActorDeck k) = + (p, j, g, HS.insert k d, l, r) + f (p, j, g, d, l, r) (LocalActorLoom k) = + (p, j, g, d, HS.insert k l, r) + f (p, j, g, d, l, r) (LocalActorRepo k) = + (p, j, g, d, l, HS.insert k r) + actorIsAddressed :: RecipientRoutes -> LocalActor -> Bool actorIsAddressed recips = isJust . verify where diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index 29fb5e3..10f6f11 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -60,7 +60,7 @@ import Yesod.Persist.Core import qualified Data.Text as T import qualified Database.Esqueleto as E -import Control.Concurrent.Actor +import Control.Concurrent.Actor hiding (Actor) import Network.FedURI import Web.Actor import Web.Actor.Persist diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index 3e59ba1..3249d3f 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/src/Vervis/Actor/Deck.hs @@ -821,8 +821,8 @@ deckUndo now recipDeckID (Verse authorIdMsig body) (AP.Undo uObject) = do -- Main behavior function ------------------------------------------------------------------------------ -deckBehavior :: UTCTime -> DeckId -> VerseExt -> ActE (Text, Act (), Next) -deckBehavior now deckID (Left verse@(Verse _authorIdMsig body)) = +deckBehavior :: UTCTime -> DeckId -> ActorMessage Deck -> ActE (Text, Act (), Next) +deckBehavior now deckID (MsgD verse@(Verse _authorIdMsig body)) = case AP.activitySpecific $ actbActivity body of AP.AcceptActivity accept -> deckAccept now deckID verse accept AP.AddActivity add -> deckAdd now deckID verse add @@ -838,10 +838,9 @@ deckBehavior now deckID (Left verse@(Verse _authorIdMsig body)) = AP.RevokeActivity revoke -> deckRevoke now deckID verse revoke AP.UndoActivity undo -> deckUndo now deckID verse undo _ -> throwE "Unsupported activity type for Deck" -deckBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Deck" -instance VervisActor Deck where - actorBehavior now deckID ve = do +instance VervisActorLaunch Deck where + actorBehavior' now deckID ve = do errboxID <- lift $ withDB $ do resourceID <- deckResource <$> getJust deckID Resource actorID <- getJust resourceID diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index 5b70928..229c1ee 100644 --- a/src/Vervis/Actor/Group.hs +++ b/src/Vervis/Actor/Group.hs @@ -5926,8 +5926,8 @@ groupUndo now recipGroupID (Verse authorIdMsig body) (AP.Undo uObject) = do return (action, recipientSet, remoteActors, fwdHosts) -groupBehavior :: UTCTime -> GroupId -> VerseExt -> ActE (Text, Act (), Next) -groupBehavior now groupID (Left verse@(Verse _authorIdMsig body)) = +groupBehavior :: UTCTime -> GroupId -> ActorMessage Group -> ActE (Text, Act (), Next) +groupBehavior now groupID (MsgG verse@(Verse _authorIdMsig body)) = case AP.activitySpecific $ actbActivity body of AP.AcceptActivity accept -> groupAccept now groupID verse accept AP.AddActivity add -> groupAdd now groupID verse add @@ -5941,10 +5941,9 @@ groupBehavior now groupID (Left verse@(Verse _authorIdMsig body)) = AP.RevokeActivity revoke -> groupRevoke now groupID verse revoke AP.UndoActivity undo -> groupUndo now groupID verse undo _ -> throwE "Unsupported activity type for Group" -groupBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Group" -instance VervisActor Group where - actorBehavior now groupID ve = do +instance VervisActorLaunch Group where + actorBehavior' now groupID ve = do errboxID <- lift $ withDB $ do resourceID <- groupResource <$> getJust groupID Resource actorID <- getJust resourceID diff --git a/src/Vervis/Actor/Loom.hs b/src/Vervis/Actor/Loom.hs index 28c0e04..fa7ee31 100644 --- a/src/Vervis/Actor/Loom.hs +++ b/src/Vervis/Actor/Loom.hs @@ -570,16 +570,15 @@ loomResolve now loomID (Verse authorIdMsig body) (AP.Resolve uObject) = do return (action, recipientSet, remoteActors, fwdHosts) -loomBehavior :: UTCTime -> LoomId -> VerseExt -> ActE (Text, Act (), Next) -loomBehavior now loomID (Left verse@(Verse _authorIdMsig body)) = +loomBehavior :: UTCTime -> LoomId -> ActorMessage Loom -> ActE (Text, Act (), Next) +loomBehavior now loomID (MsgL verse@(Verse _authorIdMsig body)) = case AP.activitySpecific $ actbActivity body of AP.OfferActivity offer -> loomOffer now loomID verse offer AP.ResolveActivity resolve -> loomResolve now loomID verse resolve _ -> throwE "Unsupported activity type for Loom" -loomBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Loom" -instance VervisActor Loom where - actorBehavior now loomID ve = do +instance VervisActorLaunch Loom where + actorBehavior' now loomID ve = do errboxID <- lift $ withDB $ do resourceID <- loomResource <$> getJust loomID Resource actorID <- getJust resourceID diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index 104be22..c4bab5e 100644 --- a/src/Vervis/Actor/Person.hs +++ b/src/Vervis/Actor/Person.hs @@ -1316,8 +1316,8 @@ personRevoke now recipPersonID (Verse authorIdMsig body) (AP.Revoke lus) = do -- Main behavior function ------------------------------------------------------------------------------ -personBehavior :: UTCTime -> PersonId -> VerseExt -> ActE (Text, Act (), Next) -personBehavior now personID (Left verse@(Verse _authorIdMsig body)) = +personBehavior :: UTCTime -> PersonId -> ActorMessage Person -> ActE (Text, Act (), Next) +personBehavior now personID (MsgP (Left verse@(Verse _authorIdMsig body))) = case AP.activitySpecific $ actbActivity body of AP.AcceptActivity accept -> personAccept now personID verse accept AP.AddActivity add -> personAdd now personID verse add @@ -1337,10 +1337,10 @@ personBehavior now personID (Left verse@(Verse _authorIdMsig body)) = AP.RevokeActivity revoke -> personRevoke now personID verse revoke AP.UndoActivity undo -> personUndo now personID verse undo _ -> throwE "Unsupported activity type for Person" -personBehavior now personID (Right msg) = clientBehavior now personID msg +personBehavior now personID (MsgP (Right msg)) = clientBehavior now personID msg -instance VervisActor Person where - actorBehavior now personID ve = do +instance VervisActorLaunch Person where + actorBehavior' now personID ve = do errboxID <- lift $ withDB $ do actorID <- personActor <$> getJust personID actorErrbox <$> getJust actorID diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index 3865808..a5ce2ba 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/src/Vervis/Actor/Person/Client.hs @@ -429,7 +429,7 @@ clientCreateDeck now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd ) -- Spawn new Deck actor - success <- lift $ launchActor LocalActorDeck deckID + success <- lift $ launchActor deckID unless success $ error "Failed to spawn new Deck, somehow ID already in Theater" @@ -593,7 +593,7 @@ clientCreateProject now personMeID (ClientMsg maybeCap localRecips remoteRecips ) -- Spawn new Project actor - success <- lift $ launchActor LocalActorProject projectID + success <- lift $ launchActor projectID unless success $ error "Failed to spawn new Project, somehow ID already in Theater" @@ -748,7 +748,7 @@ clientCreateTeam now personMeID (ClientMsg maybeCap localRecips remoteRecips fwd ) -- Spawn new Group actor - success <- lift $ launchActor LocalActorGroup groupID + success <- lift $ launchActor groupID unless success $ error "Failed to spawn new Group, somehow ID already in Theater" diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index b31d43b..f558e6f 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -7613,8 +7613,8 @@ projectUndo now recipProjectID (Verse authorIdMsig body) (AP.Undo uObject) = do return (action, recipientSet, remoteActors, fwdHosts) -projectBehavior :: UTCTime -> ProjectId -> VerseExt -> ActE (Text, Act (), Next) -projectBehavior now projectID (Left verse@(Verse _authorIdMsig body)) = +projectBehavior :: UTCTime -> ProjectId -> ActorMessage Project -> ActE (Text, Act (), Next) +projectBehavior now projectID (MsgJ verse@(Verse _authorIdMsig body)) = case AP.activitySpecific $ actbActivity body of AP.AcceptActivity accept -> projectAccept now projectID verse accept AP.AddActivity add -> projectAdd now projectID verse add @@ -7628,10 +7628,9 @@ projectBehavior now projectID (Left verse@(Verse _authorIdMsig body)) = AP.RevokeActivity revoke -> projectRevoke now projectID verse revoke AP.UndoActivity undo -> projectUndo now projectID verse undo _ -> throwE "Unsupported activity type for Project" -projectBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Project" -instance VervisActor Project where - actorBehavior now projectID ve = do +instance VervisActorLaunch Project where + actorBehavior' now projectID ve = do errboxID <- lift $ withDB $ do resourceID <- projectResource <$> getJust projectID Resource actorID <- getJust resourceID diff --git a/src/Vervis/Actor/Repo.hs b/src/Vervis/Actor/Repo.hs index f5de7ae..fc133fe 100644 --- a/src/Vervis/Actor/Repo.hs +++ b/src/Vervis/Actor/Repo.hs @@ -53,14 +53,13 @@ import Vervis.Persist.Actor import Vervis.Persist.Discussion import Vervis.Ticket -repoBehavior :: UTCTime -> RepoId -> VerseExt -> ActE (Text, Act (), Next) -repoBehavior now repoID (Left _verse@(Verse _authorIdMsig body)) = +repoBehavior :: UTCTime -> RepoId -> ActorMessage Repo -> ActE (Text, Act (), Next) +repoBehavior now repoID (MsgR _verse@(Verse _authorIdMsig body)) = case AP.activitySpecific $ actbActivity body of _ -> throwE "Unsupported activity type for Repo" -repoBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Repo" -instance VervisActor Repo where - actorBehavior now repoID ve = do +instance VervisActorLaunch Repo where + actorBehavior' now repoID ve = do errboxID <- lift $ withDB $ do resourceID <- repoResource <$> getJust repoID Resource actorID <- getJust resourceID diff --git a/src/Vervis/Actor2.hs b/src/Vervis/Actor2.hs index a5db385..893086f 100644 --- a/src/Vervis/Actor2.hs +++ b/src/Vervis/Actor2.hs @@ -66,12 +66,12 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import Control.Concurrent.Actor -import Crypto.ActorKey import Network.FedURI import Web.Actor import Web.Actor.Deliver import Web.Actor.Persist +import qualified Crypto.ActorKey as AK import qualified Web.ActivityPub as AP import qualified Yesod.MonadSite as YM @@ -88,7 +88,7 @@ import Vervis.Recipient (renderLocalActor, localRecipSieve', localActorFollowers import Vervis.RemoteActorStore import Vervis.Settings -askLatestInstanceKey :: Act (Maybe (Route App, ActorKey)) +askLatestInstanceKey :: Act (Maybe (Route App, AK.ActorKey)) askLatestInstanceKey = do maybeTVar <- asksEnv envActorKeys for maybeTVar $ \ tvar -> do @@ -99,14 +99,14 @@ askLatestInstanceKey = do else (ActorKey2R, akey2) prepareSendIK - :: (Route App, ActorKey) + :: (Route App, AK.ActorKey) -> LocalActorBy KeyHashid -> OutboxItemId -> AP.Action URIMode -> Act (AP.Envelope URIMode) prepareSendIK (keyR, akey) actorByHash itemID action = do itemHash <- encodeKeyHashid itemID - let sign = actorKeySign akey + let sign = AK.actorKeySign akey actorR = renderLocalActor actorByHash idR = activityRoute actorByHash itemHash prepareToSend keyR sign True actorR idR action @@ -126,7 +126,7 @@ prepareSendAK actorID actorByHash itemID action = do itemHash <- encodeKeyHashid itemID keyHash <- encodeKeyHashid keyID let keyR = stampRoute actorByHash keyHash - sign = actorKeySign $ sigKeyMaterial key + sign = AK.actorKeySign $ sigKeyMaterial key actorR = renderLocalActor actorByHash idR = activityRoute actorByHash itemHash prepareToSend keyR sign False actorR idR action @@ -232,13 +232,13 @@ sendActivity senderByKey senderActorID localRecips remoteRecips fwdHosts itemID sendHttp dt (MethodDeliverLocal envelope False) noFwd prepareForwardIK - :: (Route App, ActorKey) + :: (Route App, AK.ActorKey) -> LocalActorBy KeyHashid -> BL.ByteString -> Maybe ByteString -> Act (AP.Errand URIMode) prepareForwardIK (keyR, akey) fwderByHash body mproof = do - let sign = actorKeySign akey + let sign = AK.actorKeySign akey fwderR = renderLocalActor fwderByHash prepareToForward keyR sign True fwderR body mproof @@ -256,7 +256,7 @@ prepareForwardAK actorID fwderByHash body mproof = do Just k -> return k keyHash <- encodeKeyHashid keyID let keyR = stampRoute fwderByHash keyHash - sign = actorKeySign $ sigKeyMaterial key + sign = AK.actorKeySign $ sigKeyMaterial key fwderR = renderLocalActor fwderByHash prepareToForward keyR sign False fwderR body mproof diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 0fe803f..c377d36 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -80,6 +80,7 @@ import Yesod.Static import qualified Data.CaseInsensitive as CI 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 @@ -144,7 +145,6 @@ import Vervis.Path import Vervis.Persist.Actor import Vervis.Settings import Vervis.Ssh (runSsh) -import Vervis.Web.Delivery -- Only for fillPermitRecords, so remove soon import qualified Web.ActivityPub as AP @@ -338,33 +338,28 @@ makeFoundation appSettings = do , T.pack $ show from, " ==> ", T.pack $ show to ] - loadTheater :: Env -> WorkerDB [(LocalActorBy Key, Env, VerseExt -> Act (Either Text Text, Act (), Next))] - loadTheater env = concat <$> sequenceA - [ selectAllWhere LocalActorPerson (PersonVerified ==. True) - , selectAll LocalActorGroup - , selectAll LocalActorRepo - , selectAll LocalActorDeck - , selectAll LocalActorLoom - , selectAll LocalActorProject - ] - where - selectAll - :: (PersistRecordBackend a SqlBackend, VervisActor a) - => (Key a -> LocalActorBy Key) - -> WorkerDB [(LocalActorBy Key, Env, VerseExt -> Act (Either Text Text, Act (), Next))] - selectAll makeLocalActor = - map (\ xid -> (makeLocalActor xid, env, behave actorBehavior xid)) <$> - selectKeysList [] [] - selectAllWhere - :: (PersistRecordBackend a SqlBackend, VervisActor a) - => (Key a -> LocalActorBy Key) - -> Filter a - -> WorkerDB [(LocalActorBy Key, Env, VerseExt -> Act (Either Text Text, Act (), Next))] - selectAllWhere makeLocalActor filt = - map (\ xid -> (makeLocalActor xid, env, behave actorBehavior xid)) <$> - selectKeysList [filt] [] + loadTheater + :: StageEnv Staje + -> WorkerDB + (H.HList + [ [(PersonId , StageEnv Staje)] + , [(ProjectId, StageEnv Staje)] + , [(GroupId , StageEnv Staje)] + , [(DeckId , StageEnv Staje)] + , [(LoomId , StageEnv Staje)] + , [(RepoId , StageEnv Staje)] + ] + ) + loadTheater env = + (\ p j g d l r -> p `H.HCons`j `H.HCons` g `H.HCons` d `H.HCons` l `H.HCons` r `H.HCons` H.HNil) + <$> (map (,env) <$> selectKeysList [PersonVerified ==. True] []) + <*> (map (,env) <$> selectKeysList [] []) + <*> (map (,env) <$> selectKeysList [] []) + <*> (map (,env) <$> selectKeysList [] []) + <*> (map (,env) <$> selectKeysList [] []) + <*> (map (,env) <$> selectKeysList [] []) - startPersonLauncher :: Theater -> Env -> IO (MVar (PersonId, MVar Bool)) + startPersonLauncher :: Theater -> StageEnv Staje -> IO (MVar (PersonId, MVar Bool)) startPersonLauncher theater env = do mvar <- newEmptyMVar _ <- forkIO $ forever $ handle mvar @@ -372,7 +367,7 @@ makeFoundation appSettings = do where handle mvar = do (personID, sendResult) <- takeMVar mvar - success <- launchActorIO theater env LocalActorPerson personID + success <- launchActorIO theater env personID putMVar sendResult success -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index d41c248..58bd692 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -122,7 +122,7 @@ unhashGrantRecipE resource e = verifyRole = pure parseTopic - :: StageRoute Env ~ Route App + :: StageRoute Staje ~ Route App => FedURI -> ActE (Either (LocalResourceBy Key) FedURI) parseTopic u = do t <- parseTopic' u @@ -135,7 +135,7 @@ parseTopic u = do t parseTopic' - :: StageRoute Env ~ Route App + :: StageRoute Staje ~ Route App => FedURI -> ActE (Either (Either (LocalResourceBy Key) ProjectId) FedURI) parseTopic' u = do @@ -216,7 +216,7 @@ parseRecipient' sender u = do routeOrRemote parseInvite - :: StageRoute Env ~ Route App + :: StageRoute Staje ~ Route App => Either (LocalActorBy Key) FedURI -> AP.Invite URIMode -> ActE @@ -231,7 +231,7 @@ parseInvite sender (AP.Invite instrument object target) = <*> nameExceptT "Invite object" (parseRecipient' sender object) parseJoin - :: StageRoute Env ~ Route App + :: StageRoute Staje ~ Route App => AP.Join URIMode -> ActE (AP.Role, Either (LocalResourceBy Key) FedURI) parseJoin (AP.Join instrument object) = @@ -405,7 +405,7 @@ parseCollabs route = do "Contains invalid hashid" parseRemove - :: StageRoute Env ~ Route App + :: StageRoute Staje ~ Route App => Either (LocalActorBy Key) FedURI -> AP.Remove URIMode -> ActE @@ -487,7 +487,7 @@ addTargetResourceTeams = \case _ -> Nothing parseAdd - :: StageRoute Env ~ Route App + :: StageRoute Staje ~ Route App => Either (LocalActorBy Key) FedURI -> AP.Add URIMode -> ActE diff --git a/src/Vervis/Data/Discussion.hs b/src/Vervis/Data/Discussion.hs index 91ccfff..96f8234 100644 --- a/src/Vervis/Data/Discussion.hs +++ b/src/Vervis/Data/Discussion.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2019, 2020, 2022, 2023 + - Written in 2016, 2019, 2020, 2022, 2023, 2024 - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. @@ -125,7 +125,7 @@ parseCommentTopicOld (ClothR lkhid ltkhid) = parseCommentTopicOld _ = throwE "Not a ticket/cloth route" parseCommentTopic - :: (MonadActor m, StageHashids (ActorEnv m)) + :: (MonadActor m, StageHashids (MonadActorStage m)) => Route App -> ExceptT Text m CommentTopic parseCommentTopic (TicketR dkhid ltkhid) = diff --git a/src/Vervis/Data/Ticket.hs b/src/Vervis/Data/Ticket.hs index 7fd82bb..c8655a7 100644 --- a/src/Vervis/Data/Ticket.hs +++ b/src/Vervis/Data/Ticket.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2022, 2023 by fr33domlover . + - Written in 2022, 2023, 2024 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -287,14 +287,14 @@ hashWorkItemPure ctx = f WorkItemCloth (encodeKeyHashidPure ctx l) (encodeKeyHashidPure ctx c) getHashWorkItem - :: (MonadActor m, StageHashids (ActorEnv m)) + :: (MonadActor m, StageHashids (MonadActorStage m)) => m (WorkItemBy Key -> WorkItemBy KeyHashid) getHashWorkItem = do ctx <- asksEnv stageHashidsContext return $ hashWorkItemPure ctx hashWorkItem - :: (MonadActor m, StageHashids (ActorEnv m)) + :: (MonadActor m, StageHashids (MonadActorStage m)) => WorkItemBy Key -> m (WorkItemBy KeyHashid) hashWorkItem actor = do hash <- getHashWorkItem @@ -314,24 +314,24 @@ unhashWorkItemPure ctx = f <*> decodeKeyHashidPure ctx c unhashWorkItem - :: (MonadActor m, StageHashids (ActorEnv m)) + :: (MonadActor m, StageHashids (MonadActorStage m)) => WorkItemBy KeyHashid -> m (Maybe (WorkItemBy Key)) unhashWorkItem actor = do ctx <- asksEnv stageHashidsContext return $ unhashWorkItemPure ctx actor unhashWorkItemF - :: (F.MonadFail m, MonadActor m, StageHashids (ActorEnv m)) + :: (F.MonadFail m, MonadActor m, StageHashids (MonadActorStage m)) => WorkItemBy KeyHashid -> String -> m (WorkItemBy Key) unhashWorkItemF actor e = maybe (F.fail e) return =<< unhashWorkItem actor unhashWorkItemM - :: (MonadActor m, StageHashids (ActorEnv m)) + :: (MonadActor m, StageHashids (MonadActorStage m)) => WorkItemBy KeyHashid -> MaybeT m (WorkItemBy Key) unhashWorkItemM = MaybeT . unhashWorkItem unhashWorkItemE - :: (MonadActor m, StageHashids (ActorEnv m)) + :: (MonadActor m, StageHashids (MonadActorStage m)) => WorkItemBy KeyHashid -> e -> ExceptT e m (WorkItemBy Key) unhashWorkItemE actor e = ExceptT $ maybe (Left e) Right <$> unhashWorkItem actor diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs index dd7b4ac..fc85356 100644 --- a/src/Vervis/Federation/Discussion.hs +++ b/src/Vervis/Federation/Discussion.hs @@ -80,7 +80,6 @@ import Vervis.Persist.Discussion import Vervis.Recipient import Vervis.Settings import Vervis.Ticket -import Vervis.Web.Delivery -- | Insert the new remote comment into the discussion tree. If we didn't have -- this comment before, return the database ID of the newly created cached diff --git a/src/Vervis/Federation/Offer.hs b/src/Vervis/Federation/Offer.hs index 14d960f..0141b40 100644 --- a/src/Vervis/Federation/Offer.hs +++ b/src/Vervis/Federation/Offer.hs @@ -94,7 +94,6 @@ import Vervis.Model.Ticket import Vervis.Persist.Actor import Vervis.Recipient import Vervis.Ticket -import Vervis.Web.Delivery {- sharerAcceptF diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 8965cb2..768da93 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -96,7 +96,6 @@ import Vervis.Data.Actor import Vervis.Data.Collab import Vervis.Data.Ticket import Vervis.Darcs -import Vervis.Web.Delivery import Vervis.Federation.Auth import Vervis.FedURI diff --git a/src/Vervis/Fetch.hs b/src/Vervis/Fetch.hs index b2b1e7f..ce5a3e5 100644 --- a/src/Vervis/Fetch.hs +++ b/src/Vervis/Fetch.hs @@ -90,7 +90,6 @@ import Vervis.Cloth import Vervis.Data.Actor import Vervis.Data.Collab import Vervis.Data.Ticket -import Vervis.Web.Delivery import Vervis.FedURI import Vervis.Foundation import Vervis.Model diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 5fad606..4a428f1 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -75,7 +75,6 @@ import qualified Network.HTTP.Signature as S (Algorithm (..)) import qualified Yesod.Hashids as YH import Control.Concurrent.Actor hiding (Message) -import Crypto.ActorKey --import Crypto.PublicVerifKey import Network.FedURI import Web.ActivityAccess @@ -85,6 +84,7 @@ import Yesod.Actor import Yesod.FedURI import Yesod.MonadSite +import qualified Crypto.ActorKey as AK import qualified Web.ActivityPub as AP import qualified Yesod.Hashids as YH @@ -127,14 +127,14 @@ data App = App , appLogger :: Logger , appMailQueue :: Maybe (Chan (MailRecipe App)) --, appSvgFont :: PreparedFont Double - , appActorKeys :: Maybe (TVar (ActorKey, ActorKey, Bool)) + , appActorKeys :: Maybe (TVar (AK.ActorKey, AK.ActorKey, Bool)) , appInstanceMutex :: InstanceMutex , appCapSignKey :: AccessTokenSecretKey , appHashidsContext :: HashidsContext , appHookSecret :: HookSecret , appActorFetchShare :: ActorFetchShare , appTheater :: Theater - , appEnv :: Env + , appEnv :: StageEnv Staje , appPersonLauncher :: MVar (PersonId, MVar Bool) } diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index 2baa83f..070470a 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/src/Vervis/Handler/Deck.hs @@ -205,7 +205,7 @@ getDeckErrboxR = getInbox' actorErrbox DeckErrboxR deckActor postDeckInboxR :: KeyHashid Deck -> Handler () postDeckInboxR deckHash = do deckID <- decodeKeyHashid404 deckHash - postInbox $ LocalActorDeck deckID + postInbox LocalActorDeck deckID {- AP.AcceptActivity accept -> diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs index 3df084e..74d0616 100644 --- a/src/Vervis/Handler/Group.hs +++ b/src/Vervis/Handler/Group.hs @@ -115,6 +115,7 @@ import Yesod.Form.Local import Yesod.Persist.Local import Vervis.Access +import Vervis.Actor.Group import Vervis.API import Vervis.Data.Actor import Vervis.Data.Collab @@ -235,7 +236,7 @@ getGroupErrboxR = getInbox' actorErrbox GroupErrboxR groupActor postGroupInboxR :: KeyHashid Group -> Handler () postGroupInboxR groupHash = do groupID <- decodeKeyHashid404 groupHash - postInbox $ LocalActorGroup groupID + postInbox LocalActorGroup groupID getGroupOutboxR :: KeyHashid Group -> Handler TypedContent getGroupOutboxR = getOutbox GroupOutboxR GroupOutboxItemR groupActor diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs index d3a97c3..02931c1 100644 --- a/src/Vervis/Handler/Loom.hs +++ b/src/Vervis/Handler/Loom.hs @@ -175,7 +175,7 @@ getLoomErrboxR = getInbox' actorErrbox LoomErrboxR loomActor postLoomInboxR :: KeyHashid Loom -> Handler () postLoomInboxR loomHash = do loomID <- decodeKeyHashid404 loomHash - postInbox $ LocalActorLoom loomID + postInbox LocalActorLoom loomID {- AP.AcceptActivity accept -> diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index f7ae1ab..50dd620 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -68,6 +68,7 @@ import Data.Either.Local import Database.Persist.Local import Vervis.ActivityPub +import Vervis.Actor.Person import Vervis.API import Vervis.Data.Actor import Vervis.Federation.Auth @@ -138,7 +139,7 @@ getPersonErrboxR = getInbox' actorErrbox PersonErrboxR personActor postPersonInboxR :: KeyHashid Person -> Handler () postPersonInboxR personHash = do personID <- decodeKeyHashid404 personHash - postInbox $ LocalActorPerson personID + postInbox LocalActorPerson personID getPersonOutboxR :: KeyHashid Person -> Handler TypedContent getPersonOutboxR = getOutbox PersonOutboxR PersonOutboxItemR personActor diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 4ad9231..3abee1b 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -113,6 +113,7 @@ import Yesod.Persist.Local import Vervis.Access import Vervis.Actor (resourceToActor) +import Vervis.Actor.Project import Vervis.API import Vervis.Data.Actor import Vervis.Data.Collab @@ -207,7 +208,7 @@ getProjectErrboxR = getInbox' actorErrbox ProjectErrboxR projectActor postProjectInboxR :: KeyHashid Project -> Handler () postProjectInboxR projectHash = do projectID <- decodeKeyHashid404 projectHash - postInbox $ LocalActorProject projectID + postInbox LocalActorProject projectID getProjectOutboxR :: KeyHashid Project -> Handler TypedContent getProjectOutboxR = getOutbox ProjectOutboxR ProjectOutboxItemR projectActor diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index bbd0f5d..d87caf5 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -191,7 +191,6 @@ import Vervis.Time import Vervis.Web.Actor import Vervis.Web.Collab import Vervis.Web.Darcs -import Vervis.Web.Delivery import Vervis.Web.Git import Vervis.Widget import Vervis.Widget.Repo @@ -264,7 +263,7 @@ getRepoErrboxR = getInbox' actorErrbox RepoErrboxR repoActor postRepoInboxR :: KeyHashid Repo -> Handler () postRepoInboxR repoHash = do repoID <- decodeKeyHashid404 repoHash - postInbox $ LocalActorRepo repoID + postInbox LocalActorRepo repoID {- AP.AcceptActivity accept -> @@ -587,9 +586,12 @@ postPostReceiveR = do pushID <- lift $ insertEmptyOutboxItem (actorOutbox actor) now luPush <- lift $ updateOutboxItem (LocalActorRepo repoID) pushID action deliverHttpPush <- + {- deliverActivityDB (LocalActorRepo repoHash) actorID localRecips remoteRecips fwdHosts pushID action + -} + pure $ pure () return (luPush, deliverHttpPush) -- HTTP delivery to remote recipients diff --git a/src/Vervis/Persist/Actor.hs b/src/Vervis/Persist/Actor.hs index 4548442..d9f843e 100644 --- a/src/Vervis/Persist/Actor.hs +++ b/src/Vervis/Persist/Actor.hs @@ -72,8 +72,7 @@ import Yesod.Core.Handler import qualified Data.Text as T import qualified Database.Esqueleto as E -import Control.Concurrent.Actor -import Crypto.ActorKey +import Control.Concurrent.Actor hiding (Actor) import Database.Persist.JSON import Network.FedURI import Yesod.ActivityPub @@ -81,6 +80,7 @@ import Yesod.FedURI import Yesod.Hashids import Yesod.MonadSite +import qualified Crypto.ActorKey as AK import qualified Web.ActivityPub as AP import qualified Web.Actor as WA import qualified Web.Actor.Persist as WAP @@ -297,7 +297,7 @@ updateOutboxItem actorByKey itemID action = do return luId updateOutboxItem' - :: WA.StageRoute VA.Env ~ Route App + :: WA.StageRoute VA.Staje ~ Route App => LocalActorBy Key -> OutboxItemId -> AP.Action URIMode @@ -322,7 +322,7 @@ fillPerActorKeys = do E.where_ $ E.isNothing $ sigkey E.?. SigKeyId return $ actor E.^. ActorId keys <- for actorIDs $ \ (E.Value actorID) -> do - key <- liftIO generateActorKey + key <- liftIO AK.generateActorKey return $ SigKey actorID key runSiteDB $ insertMany_ keys logInfo $ @@ -420,21 +420,24 @@ insertToInbox now (Right (author, luAct, _)) body inboxID unread = do Just _ -> return $ Just (ibiid, Right (author, luAct, ractid)) adaptErrbox - :: InboxId + :: VA.VervisActor a + => InboxId -> Bool - -> (UTCTime -> Key a -> VA.VerseExt -> VA.ActE (Text, VA.Act (), Next)) - -> UTCTime -> Key a -> VA.VerseExt -> VA.ActE (Text, VA.Act (), Next) -adaptErrbox _ _ behavior now key ve@(Right _) = behavior now key ve -adaptErrbox inboxID unread behavior now key ve@(Left (VA.Verse authorIdMsig body)) = do - result <- lift $ runExceptT $ behavior now key ve - case result of - Right success -> return success - Left err -> do - _ <- lift $ VA.withDB $ runMaybeT $ do - _ <- MaybeT $ get inboxID - (itemID, _) <- MaybeT $ insertToInbox now authorIdMsig body inboxID unread - lift $ update itemID [InboxItemResult =. err] - throwE err + -> (UTCTime -> ActorKey a -> ActorMessage a -> VA.ActE (Text, VA.Act (), Next)) + -> UTCTime -> ActorKey a -> ActorMessage a -> VA.ActE (Text, VA.Act (), Next) +adaptErrbox inboxID unread behavior now key msg = + case VA.toVerse msg of + Nothing -> behavior now key msg + Just (VA.Verse authorIdMsig body) -> do + result <- lift $ runExceptT $ behavior now key msg + case result of + Right success -> return success + Left err -> do + _ <- lift $ VA.withDB $ runMaybeT $ do + _ <- MaybeT $ get inboxID + (itemID, _) <- MaybeT $ insertToInbox now authorIdMsig body inboxID unread + lift $ update itemID [InboxItemResult =. err] + throwE err getActivityIdent :: MonadIO m diff --git a/src/Vervis/Recipient.hs b/src/Vervis/Recipient.hs index 0372e70..f3285e3 100644 --- a/src/Vervis/Recipient.hs +++ b/src/Vervis/Recipient.hs @@ -169,8 +169,8 @@ import Vervis.FedURI import Vervis.Foundation import Vervis.Model -instance WA.StageWebRoute Env where - type StageRoute Env = Route App +instance WA.StageWebRoute Staje where + type StageRoute Staje = Route App askUrlRenderParams = do Env _ _ _ _ _ render _ _ <- askEnv case cast render of @@ -898,7 +898,7 @@ parseRecipients recips = do Just recip -> Right recip parseRecipients' - :: WA.StageRoute Env ~ Route App + :: WA.StageRoute Staje ~ Route App => NonEmpty FedURI -> ActE (RecipientRoutes, [FedURI]) parseRecipients' recips = do hLocal <- asksEnv WA.stageInstanceHost @@ -966,7 +966,7 @@ parseAudience audience = do groupByHost = groupAllExtract objUriAuthority objUriLocal parseAudience' - :: WA.StageRoute Env ~ Route App + :: WA.StageRoute Staje ~ Route App => AP.Audience URIMode -> ActE (Maybe (ParsedAudience URIMode)) parseAudience' audience = do let recips = concatRecipients audience diff --git a/src/Vervis/Web/Actor.hs b/src/Vervis/Web/Actor.hs index a5e8ed1..41e1887 100644 --- a/src/Vervis/Web/Actor.hs +++ b/src/Vervis/Web/Actor.hs @@ -30,7 +30,7 @@ module Vervis.Web.Actor where import Control.Applicative ((<|>)) -import Control.Concurrent.STM.TVar (readTVarIO, modifyTVar') +import Control.Concurrent.STM.TVar (readTVarIO, modifyTVar', TVar) import Control.Exception hiding (Handler) import Control.Monad import Control.Monad.IO.Class (liftIO) @@ -44,6 +44,7 @@ import Data.Bifunctor import Data.Bitraversable import Data.ByteString (ByteString) import Data.Foldable (for_) +import Data.Hashable import Data.List import Data.Maybe import Data.Text (Text) @@ -70,13 +71,13 @@ import Yesod.Persist.Core import qualified Data.ByteString.Char8 as BC (unpack) import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Strict as M +import qualified Data.HList as H import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Vector as V import qualified Database.Esqueleto as E -import Control.Concurrent.Actor -import Crypto.ActorKey +import Control.Concurrent.Actor hiding (Actor) import Database.Persist.JSON import Network.FedURI import Web.ActivityPub hiding (Project (..), ActorLocal (..)) @@ -87,6 +88,9 @@ import Yesod.Hashids import Yesod.MonadSite import Yesod.RenderSource +import qualified Control.Concurrent.Actor as CCA +import qualified Crypto.ActorKey as AK + import Control.Monad.Trans.Except.Local import Data.Aeson.Local import Data.Either.Local @@ -99,7 +103,7 @@ import Yesod.Persist.Local import qualified Data.Aeson.Encode.Pretty.ToEncoding as P import qualified Web.ActivityPub as AP -import Vervis.Actor (RemoteAuthor (..), ActivityBody (..), Verse (..)) +import Vervis.Actor (RemoteAuthor (..), ActivityBody (..), Verse (..), VervisActor (..), VervisActorLaunch) import Vervis.Actor2 import Vervis.ActivityPub import Vervis.API @@ -238,8 +242,41 @@ getInbox' grabInbox here actor hash = do where ibiidString = "InboxItem #" ++ show (fromSqlKey ibid) -postInbox :: LocalActorBy Key -> Handler () -postInbox recipByKey = do +postInbox + :: ( CCA.Actor a + , ActorLaunch a + , VervisActor a + , ActorKey a ~ Key a + , ActorReturn a ~ Either Text Text + , Eq (Key a) + , Hashable (Key a) + , H.HEq + (TVar (M.HashMap (Key a) (ActorRef a))) + (TVar (M.HashMap PersonId (ActorRef 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))] + l'0 + , 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))] + ) + => (Key a -> LocalActorBy Key) -> Key a -> Handler () +postInbox toLA recipID = do + let recipByKey = toLA recipID federation <- getsYesod $ appFederation . appSettings unless federation badMethod contentTypes <- lookupHeaders "Content-Type" @@ -266,7 +303,7 @@ postInbox recipByKey = do msig <- checkForwarding recipByHash return (author, luActivity, msig) theater <- getsYesod appTheater - r <- liftIO $ callIO theater recipByKey $ Left $ Verse authorIdMsig body + r <- liftIO $ callIO theater recipID $ actorVerse $ Verse authorIdMsig body case r of Nothing -> notFound Just (Left e) -> throwE e @@ -519,7 +556,7 @@ actorKeyAP :: ( MonadSite m, SiteEnv m ~ site , SiteFedURI site, SiteFedURIMode site ~ u ) - => Maybe (Route site) -> Route site -> ActorKey -> m (AP.PublicKey u) + => Maybe (Route site) -> Route site -> AK.ActorKey -> m (AP.PublicKey u) actorKeyAP maybeHolderR keyR akey = do encodeRouteLocal <- getEncodeRouteLocal return AP.PublicKey @@ -529,11 +566,11 @@ actorKeyAP maybeHolderR keyR akey = do case maybeHolderR of Nothing -> AP.OwnerInstance Just holderR -> AP.OwnerActor $ encodeRouteLocal holderR - , AP.publicKeyMaterial = actorKeyPublicBin akey + , AP.publicKeyMaterial = AK.actorKeyPublicBin akey } serveInstanceKey - :: ((ActorKey, ActorKey) -> ActorKey) + :: ((AK.ActorKey, AK.ActorKey) -> AK.ActorKey) -> Route App -> Handler TypedContent serveInstanceKey choose keyR = do @@ -550,7 +587,7 @@ serveInstanceKey choose keyR = do servePerActorKey' :: LocalActorBy KeyHashid -> KeyHashid SigKey - -> ActorKey + -> AK.ActorKey -> Handler TypedContent servePerActorKey' holderByHash keyHash akey = do let holderR = renderLocalActor holderByHash diff --git a/src/Web/Actor.hs b/src/Web/Actor.hs index 7ef3afd..4e38bbf 100644 --- a/src/Web/Actor.hs +++ b/src/Web/Actor.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2022, 2023 by fr33domlover . + - Written in 2019, 2022, 2023, 2024 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -76,8 +76,8 @@ type ActForE s = ExceptT Text (ActFor s) class (Stage s, UriMode (StageURIMode s)) => StageWeb s where type StageURIMode s - stageInstanceHost :: s -> Authority (StageURIMode s) - stageDeliveryTheater :: s -> DeliveryTheater (StageURIMode s) + stageInstanceHost :: StageEnv s -> Authority (StageURIMode s) + stageDeliveryTheater :: StageEnv s -> DeliveryTheater (StageURIMode s) class DecodeRouteLocal r where decodeRouteLocal :: LocalURI -> Maybe r @@ -85,21 +85,21 @@ class DecodeRouteLocal r where class (DecodeRouteLocal (StageRoute s), StageWeb s) => StageWebRoute s where type StageRoute s askUrlRenderParams - :: (MonadActor m, ActorEnv m ~ s) + :: (MonadActor m, MonadActorStage m ~ s) => m (StageRoute s -> [(Text, Text)] -> Text) -- | Name of parameter to use in generated URIs' query part to indicate the -- page number in a paginated collection pageParamName :: Proxy s -> Text askUrlRender - :: (MonadActor m, ActorEnv m ~ s, StageWebRoute s) + :: (MonadActor m, MonadActorStage m ~ s, StageWebRoute s) => m (StageRoute s -> Text) askUrlRender = do render <- askUrlRenderParams return $ \ route -> render route [] hostIsLocal - :: (MonadActor m, ActorEnv m ~ s, StageWeb s) + :: (MonadActor m, MonadActorStage m ~ s, StageWeb s) => Authority (StageURIMode s) -> m Bool hostIsLocal h = asksEnv $ (== h) . stageInstanceHost @@ -117,7 +117,7 @@ parseFedURI u@(ObjURI h lu) = do else pure $ Right u getEncodeRouteHome - :: (MonadActor m, ActorEnv m ~ s, StageWebRoute s) + :: (MonadActor m, MonadActorStage m ~ s, StageWebRoute s) => m (StageRoute s -> ObjURI (StageURIMode s)) getEncodeRouteHome = toFed <$> askUrlRender where @@ -127,13 +127,13 @@ getEncodeRouteHome = toFed <$> askUrlRender Right u -> u getEncodeRouteLocal - :: (MonadActor m, ActorEnv m ~ s, StageWebRoute s) + :: (MonadActor m, MonadActorStage m ~ s, StageWebRoute s) => m (StageRoute s -> LocalURI) getEncodeRouteLocal = (objUriLocal .) <$> getEncodeRouteHome getEncodeRouteFed :: ( MonadActor m - , ActorEnv m ~ s + , MonadActorStage m ~ s , StageWebRoute s , StageURIMode s ~ u ) @@ -141,13 +141,13 @@ getEncodeRouteFed getEncodeRouteFed = (\ f a -> ObjURI a . f) <$> getEncodeRouteLocal getEncodeRoutePageLocal - :: (MonadActor m, ActorEnv m ~ s, StageWebRoute s) + :: (MonadActor m, MonadActorStage m ~ s, StageWebRoute s) => m (StageRoute s -> Int -> LocalPageURI) getEncodeRoutePageLocal = (\ f r n -> pageUriLocal $ f r n) <$> getEncodeRoutePageHome getEncodeRoutePageHome - :: forall m s. (MonadActor m, ActorEnv m ~ s, StageWebRoute s) + :: forall m s. (MonadActor m, MonadActorStage m ~ s, StageWebRoute s) => m (StageRoute s -> Int -> PageURI (StageURIMode s)) getEncodeRoutePageHome = do encodeRouteHome <- getEncodeRouteHome @@ -158,7 +158,7 @@ getEncodeRoutePageHome = do getEncodeRoutePageFed :: ( MonadActor m - , ActorEnv m ~ s + , MonadActorStage m ~ s , StageWebRoute s , StageURIMode s ~ u ) @@ -167,7 +167,7 @@ getEncodeRoutePageFed = (\ f a r n -> PageURI a $ f r n) <$> getEncodeRoutePageLocal prepareToSend - :: (MonadActor m, ActorEnv m ~ s, StageWebRoute s, StageURIMode s ~ u) + :: (MonadActor m, MonadActorStage m ~ s, StageWebRoute s, StageURIMode s ~ u) => StageRoute s -> (ByteString -> S.Signature) -> Bool @@ -187,7 +187,7 @@ prepareToSend keyR sign holder actorR idR action = do return $ AP.sending lruKey sign (Just (config, signB)) holder uActor luId action prepareToForward - :: (MonadActor m, ActorEnv m ~ s, StageWebRoute s, StageURIMode s ~ u) + :: (MonadActor m, MonadActorStage m ~ s, StageWebRoute s, StageURIMode s ~ u) => StageRoute s -> (ByteString -> S.Signature) -> Bool diff --git a/src/Web/Actor/Deliver.hs b/src/Web/Actor/Deliver.hs index 7659d64..fa9355b 100644 --- a/src/Web/Actor/Deliver.hs +++ b/src/Web/Actor/Deliver.hs @@ -22,8 +22,10 @@ -- System of local utility-actors that do the actual HTTP POSTing of -- activities to remote actors. module Web.Actor.Deliver - ( Method (..) + ( DeliveryActor + , DeliveryStage , DeliveryTheater () + , ActorMessage (..) , startDeliveryTheater , sendHttp ) @@ -56,6 +58,7 @@ import Web.Hashids import qualified Data.Aeson as A import qualified Data.ByteString.Lazy as BL import qualified Data.HashSet as HS +import qualified Data.HList as H import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -67,14 +70,6 @@ import qualified Web.ActivityPub as AP import Vervis.Settings -data Method u - = MethodDeliverLocal (AP.Envelope u) Bool - | MethodForwardRemote (AP.Errand u) - -instance Message (Method u) where - summarize _ = "Method" - refer _ = "Method" - data RemoteActor = RemoteActor { raInbox :: Maybe LocalURI , _raErrorSince :: Maybe UTCTime @@ -84,6 +79,33 @@ data RemoteActor = RemoteActor instance BoxableVia RemoteActor where type BV RemoteActor = BoxableShow +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 ActorReturn (DeliveryActor _) = () + data ActorMessage (DeliveryActor u) + = MethodDeliverLocal (AP.Envelope u) Bool + | MethodForwardRemote (AP.Errand u) + +instance UriMode u => ActorLaunch (DeliveryActor u) where + actorBehavior uri msg = do + Env _ (manager, headers, micros) <- askEnv + behavior manager headers micros uri msg + +instance UriMode u => Stage (DeliveryStage u) where + data StageEnv (DeliveryStage u) = Env + { envBox :: Box RemoteActor + , envInit :: (Manager, NonEmpty HeaderName, Int) + } + type StageActors (DeliveryStage u) = '[DeliveryActor u] + +instance Message (ActorMessage (DeliveryActor u)) where + summarize _ = "Method" + refer _ = "Method" + {- migrations :: [Migration SqlBackend IO] migrations = @@ -96,26 +118,17 @@ migrations = ] -} -data Env u = Env - { envBox :: Box RemoteActor - } - -instance MonadBox (ActFor (Env u)) where - type BoxType (ActFor (Env u)) = RemoteActor +instance UriMode u => MonadBox (ActFor (DeliveryStage u)) where + type BoxType (ActFor (DeliveryStage u)) = RemoteActor askBox = asksEnv envBox -instance Stage (Env u) where - type StageKey (Env u) = ObjURI u - type StageMessage (Env u) = Method u - type StageReturn (Env u) = () - data DeliveryTheater u = DeliveryTheater { _dtManager :: Manager , _dtHeaders :: NonEmpty HeaderName , _dtDelay :: Int , _dtLog :: LogFunc , _dtDir :: OsPath - , _dtTheater :: TheaterFor (Env u) + , _dtTheater :: TheaterFor (DeliveryStage u) } data IdMismatch = IdMismatch deriving Show @@ -128,8 +141,8 @@ behavior -> NonEmpty HeaderName -> Int -> ObjURI u - -> Method u - -> ActFor (Env u) ((), ActFor (Env u) (), Next) + -> ActorMessage (DeliveryActor u) + -> ActFor (DeliveryStage u) ((), ActFor (DeliveryStage u) (), Next) behavior manager postSignedHeaders micros (ObjURI h lu) = \case MethodDeliverLocal envelope fwd -> do ra@(RemoteActor mluInbox _mError) <- runBox obtain @@ -182,10 +195,14 @@ behavior manager postSignedHeaders micros (ObjURI h lu) = \case return luInb return $ ObjURI h luInbox -mkEnv :: LogFunc -> OsPath -> IO (Env u) -mkEnv logFunc path = flip runLoggingT logFunc $ do +mkEnv + :: (Manager, NonEmpty HeaderName, Int) + -> LogFunc + -> OsPath + -> IO (StageEnv (DeliveryStage u)) +mkEnv env logFunc path = flip runLoggingT logFunc $ do box <- loadBox {-migrations-} path (RemoteActor Nothing Nothing) - return $ Env box + return $ Env box env type OsPath = FilePath encodeUtf = pure @@ -210,14 +227,13 @@ startDeliveryTheater headers micros manager logFunc dbRootDir = do error $ "Failed to parse URI-named SQLite db filename: " ++ e Right uri -> return uri - env <- mkEnv logFunc $ dbRootDir path - return (u, env, behavior manager headers micros u) - DeliveryTheater manager headers micros logFunc dbRootDir <$> startTheater logFunc actors + env <- mkEnv (manager, headers, micros) logFunc (dbRootDir path) + return (u, env) + DeliveryTheater manager headers micros logFunc dbRootDir <$> startTheater logFunc (actors `H.HCons` H.HNil) -sendHttp :: UriMode u => DeliveryTheater u -> Method u -> [ObjURI u] -> IO () +sendHttp :: UriMode u => DeliveryTheater u -> ActorMessage (DeliveryActor u) -> [ObjURI u] -> IO () sendHttp (DeliveryTheater manager headers micros logFunc root theater) method recips = do for_ recips $ \ u -> - let makeEnv = either throwIO pure (TE.decodeUtf8' $ urlEncode False $ TE.encodeUtf8 $ renderObjURI u) >>= encodeUtf . (root ) . T.unpack >>= mkEnv logFunc - behave = behavior manager headers micros u - in void $ spawnIO theater u makeEnv behave - sendManyIO theater (HS.fromList recips) method + let makeEnv = either throwIO pure (TE.decodeUtf8' $ urlEncode False $ TE.encodeUtf8 $ renderObjURI u) >>= encodeUtf . (root ) . T.unpack >>= mkEnv (manager, headers, micros) logFunc + in void $ spawnIO theater u makeEnv + sendManyIO theater $ (HS.fromList recips, method) `H.HCons` H.HNil diff --git a/src/Web/Actor/Persist.hs b/src/Web/Actor/Persist.hs index a21aff7..e0ee989 100644 --- a/src/Web/Actor/Persist.hs +++ b/src/Web/Actor/Persist.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. - @@ -49,7 +50,7 @@ import Web.Actor import Web.Hashids.Local class StageWeb s => StageHashids s where - stageHashidsContext :: s -> HashidsContext + stageHashidsContext :: StageEnv s -> HashidsContext newtype KeyHashid record = KeyHashid { keyHashidText :: Text @@ -67,7 +68,7 @@ encodeKeyHashidPure ctx = KeyHashid . decodeUtf8 . encodeInt64 ctx . fromSqlKey getEncodeKeyHashid :: ( MonadActor m - , StageHashids (ActorEnv m) + , StageHashids (MonadActorStage m) , ToBackendKey SqlBackend record ) => m (Key record -> KeyHashid record) @@ -77,7 +78,7 @@ getEncodeKeyHashid = do encodeKeyHashid :: ( MonadActor m - , StageHashids (ActorEnv m) + , StageHashids (MonadActorStage m) , ToBackendKey SqlBackend record ) => Key record @@ -96,7 +97,7 @@ decodeKeyHashidPure ctx (KeyHashid t) = decodeKeyHashid :: ( MonadActor m - , StageHashids (ActorEnv m) + , StageHashids (MonadActorStage m) , ToBackendKey SqlBackend record ) => KeyHashid record @@ -108,7 +109,7 @@ decodeKeyHashid khid = do decodeKeyHashidF :: ( MonadFail m , MonadActor m - , StageHashids (ActorEnv m) + , StageHashids (MonadActorStage m) , ToBackendKey SqlBackend record ) => KeyHashid record @@ -118,7 +119,7 @@ decodeKeyHashidF khid e = maybe (fail e) return =<< decodeKeyHashid khid decodeKeyHashidM :: ( MonadActor m - , StageHashids (ActorEnv m) + , StageHashids (MonadActorStage m) , ToBackendKey SqlBackend record ) => KeyHashid record @@ -127,7 +128,7 @@ decodeKeyHashidM = MaybeT . decodeKeyHashid decodeKeyHashidE :: ( MonadActor m - , StageHashids (ActorEnv m) + , StageHashids (MonadActorStage m) , ToBackendKey SqlBackend record ) => KeyHashid record diff --git a/vervis.cabal b/vervis.cabal index b23da6d..604cb1d 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -52,8 +52,8 @@ library Data.Binary.Put.Local Control.Applicative.Local + --Control.Concurrent.ActorOld Control.Concurrent.Actor - --Control.Concurrent.ActorNew2 Control.Concurrent.Local Control.Concurrent.ResultShare Control.Concurrent.Return @@ -277,7 +277,7 @@ library Vervis.Web.Actor Vervis.Web.Collab Vervis.Web.Darcs - Vervis.Web.Delivery + --Vervis.Web.Delivery Vervis.Web.Discussion Vervis.Web.Git Vervis.Web.Repo