forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Upgrade actor system, now using HList, to allow per-actor method type

Browse source
This commit is contained in:
Pere Lev 2024-07-29 12:29:38 +03:00
parent 3ddae07d26
commit ea463703b5
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
34 changed files with 955 additions and 377 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

516
src/Control/Concurrent/Actor.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2019, 2020, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2019, 2020, 2024 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -13,14 +13,31 @@
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
{-# 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
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
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
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
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)

42
src/Vervis/API.hs
View file

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

298
src/Vervis/Actor.hs
View file

@ -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
}
type VerseExt = Either Verse ClientMsg
instance Message VerseExt where
summarize (Left (Verse (Left (actor, _, itemID)) body)) =
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]
summarize (Left (Verse (Right (author, luAct, _)) body)) =
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]
summarize (Right _) = "ClientMsg"
refer (Left (Verse (Left (actor, _, itemID)) _body)) =
referVerse (Verse (Left (actor, _, itemID)) _body) =
T.concat [T.pack $ show actor, " ", T.pack $ show itemID]
refer (Left (Verse (Right (author, luAct, _)) _body)) =
referVerse (Verse (Right (author, luAct, _)) _body) =
let ObjURI h _ = remoteAuthorURI author
in renderObjURI $ ObjURI h luAct
refer (Right _) = "ClientMsg"
type YesodRender y = Route y -> [(Text, Text)] -> Text
type VerseExt = Either Verse ClientMsg
-- | 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
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 (ActorKey, ActorKey, Bool))
, 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 Stage Env where
type StageKey Env = LocalActorBy Key
type StageMessage Env = VerseExt
type StageReturn Env = Either Text Text
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
instance StageWeb Env where
type StageURIMode Env = URIMode
--type StageRoute Env = Route Site
type YesodRender y = Route y -> [(Text, Text)] -> Text
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

2
src/Vervis/Actor/Common.hs
View file

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

9
src/Vervis/Actor/Deck.hs
View file

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

9
src/Vervis/Actor/Group.hs
View file

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

9
src/Vervis/Actor/Loom.hs
View file

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

10
src/Vervis/Actor/Person.hs
View file

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

6
src/Vervis/Actor/Person/Client.hs
View file

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

9
src/Vervis/Actor/Project.hs
View file

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

9
src/Vervis/Actor/Repo.hs
View file

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

16
src/Vervis/Actor2.hs
View file

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

49
src/Vervis/Application.hs
View file

@ -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
loadTheater
:: StageEnv Staje
-> WorkerDB
(H.HList
[ [(PersonId , StageEnv Staje)]
, [(ProjectId, StageEnv Staje)]
, [(GroupId , StageEnv Staje)]
, [(DeckId , StageEnv Staje)]
, [(LoomId , StageEnv Staje)]
, [(RepoId , StageEnv Staje)]
]
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 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

12
src/Vervis/Data/Collab.hs
View file

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

4
src/Vervis/Data/Discussion.hs
View file

@ -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 <fr33domlover@riseup.net>.
-
- ♡ 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) =

14
src/Vervis/Data/Ticket.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2022, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ 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

1
src/Vervis/Federation/Discussion.hs
View file

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

1
src/Vervis/Federation/Offer.hs
View file

@ -94,7 +94,6 @@ import Vervis.Model.Ticket
import Vervis.Persist.Actor
import Vervis.Recipient
import Vervis.Ticket
import Vervis.Web.Delivery
{-
sharerAcceptF

1
src/Vervis/Federation/Ticket.hs
View file

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

1
src/Vervis/Fetch.hs
View file

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

6
src/Vervis/Foundation.hs
View file

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

2
src/Vervis/Handler/Deck.hs
View file

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

3
src/Vervis/Handler/Group.hs
View file

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

2
src/Vervis/Handler/Loom.hs
View file

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

3
src/Vervis/Handler/Person.hs
View file

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

3
src/Vervis/Handler/Project.hs
View file

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

6
src/Vervis/Handler/Repo.hs
View file

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

23
src/Vervis/Persist/Actor.hs
View file

@ -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,13 +420,16 @@ 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
-> (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

8
src/Vervis/Recipient.hs
View file

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

59
src/Vervis/Web/Actor.hs
View file

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

28
src/Web/Actor.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2019, 2022, 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ 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

84
src/Web/Actor/Deliver.hs
View file

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

17
src/Web/Actor/Persist.hs
View file

@ -1,6 +1,7 @@
{- This file is part of Vervis.
-
- Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2019, 2020, 2022, 2023, 2024
- by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ 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

4
vervis.cabal
View file

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