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