forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Implement theater-based remote delivery and port personGrant

Browse source
This commit is contained in:
fr33domlover 2023-05-24 22:17:14 +00:00
parent bb01538dfa
commit 6786e2e0e1
36 changed files with 2370 additions and 818 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
INSTALL.md
View file

@ -118,6 +118,12 @@ example, if you're keeping the default name:
$ mkdir repos
Create a directory that will keep remote delivery state. Its name should match
the `delivery-state-dir` setting in `config/settings.yml`. For example, if
you're keeping the default name:
$ mkdir delivery-states
# (8) Development and deployment
To update your local clone of Vervis, run:

12
config/settings-default.yaml
View file

@ -58,7 +58,7 @@ per-actor-keys: false
# load-font-from-lib-data: false
###############################################################################
# SQL database
# Database
###############################################################################
# If you need a numeric value (e.g. 123) to parse as a String, wrap it in
@ -76,6 +76,8 @@ database:
max-instance-keys: 2
max-actor-keys: 2
delivery-state-dir: delivery-states
###############################################################################
# Version control repositories
###############################################################################
@ -149,12 +151,16 @@ reject-on-max-keys: true
# periodically retry to deliver them activities. After that period of time, we
# stop trying to deliver and we remove them from follower lists of local
# actors.
#
# TODO this probably isn't working anymore since the switch to DeliveryTheater
drop-delivery-after:
amount: 25
unit: weeks
# How often to retry failed deliveries
retry-delivery-every:
# Base of the exponential backoff for inbox POST delivery to remote actors,
# i.e. how much time to wait before the first retry. Afterwards this time
# interval will be doubled with each retry.
retry-delivery-base:
amount: 1
unit: hours

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

@ -28,7 +28,7 @@ module Control.Concurrent.Actor
, send
, sendManyIO
, sendMany
--, spawnIO
, spawnIO
, spawn
, done
, doneAnd
@ -65,22 +65,48 @@ import Control.Concurrent.Return
type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
-- PROBLEM: I'm stuck with how App can hold the (TheaterFor Env) while Env
-- needs to somehow hold the route rendering function (Route App -> Text) so
-- there's a cyclic reference
--
-- And right now the classes below are weird:
--
-- * Stage and Env terms used interchangeably, it's cnfusing, Stage is weird
-- * The main type everything's keyed on is the Env, which is merely parameters
-- for the actor, perhaps we can key on an abstact type where Env is just one
-- of the things keyed on it?
--
-- And that change into abstract type can also help with the cyclic reference?
class Stage a where
type StageKey a
type StageMessage a
type StageReturn a
newtype Actor m r = Actor (Chan (m, Either SomeException r -> IO ()))
callIO' :: Actor m r -> m -> IO r
callIO' (Actor chan) msg = do
(returx, wait) <- newReturn
writeChan chan (msg, returx)
result <- wait
case result of
Left e -> AE.checkpointCallStack $ throwIO e
Right r -> return r
sendIO' :: Actor m r -> m -> IO ()
sendIO' (Actor chan) msg = writeChan chan (msg, const $ pure ())
-- | A set of live actors responding to messages
data TheaterFor s = TheaterFor
{ theaterMap :: TVar (HashMap (StageKey s) (Chan (StageMessage s, Either SomeException (StageReturn s) -> IO ())))
{ theaterMap :: TVar (HashMap (StageKey s) (Actor (StageMessage s) (StageReturn s)))
, theaterLog :: LogFunc
, theaterEnv :: s
}
-- | Actor monad in which message reponse actions are executed. Supports
-- logging, a read-only environment, and IO.
newtype ActFor s a = ActFor
{ unActFor :: LoggingT (ReaderT (TheaterFor s) IO) a
{ unActFor :: LoggingT (ReaderT (s, TheaterFor s) IO) a
}
deriving
( Functor, Applicative, Monad, MonadFail, MonadIO, MonadLogger
@ -94,9 +120,9 @@ instance MonadUnliftIO (ActFor s) where
withRunInIO inner =
ActFor $ withRunInIO $ \ run -> inner (run . unActFor)
runActor :: TheaterFor s -> ActFor s a -> IO a
runActor theater (ActFor action) =
runReaderT (runLoggingT action $ theaterLog theater) theater
runActor :: TheaterFor s -> s -> ActFor s a -> IO a
runActor theater env (ActFor action) =
runReaderT (runLoggingT action $ theaterLog theater) (env, theater)
class Monad m => MonadActor m where
type ActorEnv m
@ -105,7 +131,7 @@ class Monad m => MonadActor m where
instance MonadActor (ActFor s) where
type ActorEnv (ActFor s) = s
askEnv = theaterEnv <$> askTheater
askEnv = ActFor $ lift $ asks fst
liftActor = id
instance MonadActor m => MonadActor (ReaderT r m) where
@ -144,10 +170,11 @@ launchActorThread
=> Chan (m, Either SomeException r -> IO ())
-> TheaterFor s
-> k
-> s
-> (m -> ActFor s (r, ActFor s (), Next))
-> IO ()
launchActorThread chan theater actor behavior =
void $ forkIO $ runActor theater $ do
launchActorThread chan theater actor env behavior =
void $ forkIO $ runActor theater env $ do
logInfo $ prefix <> "starting"
loop
logInfo $ prefix <> "bye"
@ -184,21 +211,20 @@ startTheater
, Hashable k, Eq k, Show k, Message m, Show r
)
=> LogFunc
-> s
-> [(k, m -> ActFor s (r, ActFor s (), Next))]
-> [(k, s, m -> ActFor s (r, ActFor s (), Next))]
-> IO (TheaterFor s)
startTheater logFunc env actors = do
actorsWithChans <- for actors $ \ (key, behavior) -> do
startTheater logFunc actors = do
actorsWithChans <- for actors $ \ (key, env, behavior) -> do
chan <- newChan
return ((key, chan), behavior)
return ((key, Actor chan), (env, behavior))
tvar <- newTVarIO $ HM.fromList $ map fst actorsWithChans
let theater = TheaterFor tvar logFunc env
for_ actorsWithChans $ \ ((key, chan), behavior) ->
launchActorThread chan theater key behavior
let theater = TheaterFor tvar logFunc
for_ actorsWithChans $ \ ((key, Actor chan), (env, behavior)) ->
launchActorThread chan theater key env behavior
return theater
askTheater :: ActFor s (TheaterFor s)
askTheater = ActFor $ lift ask
askTheater = ActFor $ lift $ asks snd
lookupActor
:: ( StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r
@ -206,8 +232,8 @@ lookupActor
)
=> TheaterFor s
-> k
-> IO (Maybe (Chan (m, Either SomeException r -> IO ())))
lookupActor (TheaterFor tvar _ _) actor = HM.lookup actor <$> readTVarIO tvar
-> IO (Maybe (Actor m r))
lookupActor (TheaterFor tvar _) actor = HM.lookup actor <$> readTVarIO tvar
-- | Same as 'call', except it takes the theater as a parameter.
callIO
@ -215,15 +241,9 @@ callIO
, Eq k, Hashable k
)
=> TheaterFor s -> k -> m -> IO (Maybe r)
callIO theater actor msg = do
maybeChan <- lookupActor theater actor
for maybeChan $ \ chan -> do
(returx, wait) <- newReturn
writeChan chan (msg, returx)
result <- wait
case result of
Left e -> AE.checkpointCallStack $ throwIO e
Right r -> return r
callIO theater key msg = do
maybeActor <- lookupActor theater key
for maybeActor $ \ actor -> callIO' actor msg
-- | Send a message to an actor, and wait for the result to arrive. Return
-- 'Nothing' if actor doesn't exist, otherwise 'Just' the result.
@ -244,12 +264,12 @@ call key msg = liftActor $ do
sendIO
:: (StageKey s ~ k, StageMessage s ~ m, Eq k, Hashable k)
=> TheaterFor s -> k -> m -> IO Bool
sendIO theater actor msg = do
maybeChan <- lookupActor theater actor
case maybeChan of
sendIO theater key msg = do
maybeActor <- lookupActor theater key
case maybeActor of
Nothing -> return False
Just chan -> do
writeChan chan (msg, const $ pure ())
Just actor -> do
sendIO' actor msg
return True
-- | Send a message to an actor, without waiting for a result. Return 'True' if
@ -268,10 +288,10 @@ send key msg = liftActor $ do
sendManyIO
:: (StageKey s ~ k, StageMessage s ~ m, Eq k, Hashable k)
=> TheaterFor s -> HashSet k -> m -> IO ()
sendManyIO (TheaterFor tvar _ _) recips msg = do
sendManyIO (TheaterFor tvar _) recips msg = do
allActors <- readTVarIO tvar
for_ (HM.intersection allActors (HS.toMap recips)) $
\ chan -> writeChan chan (msg, const $ pure ())
\ actor -> sendIO' actor msg
-- | Send a message to each actor in the set that exists in the system,
-- without waiting for results.
@ -292,20 +312,23 @@ spawnIO
)
=> TheaterFor s
-> k
-> IO s
-> (m -> ActFor s (r, ActFor s (), Next))
-> IO Bool
spawnIO theater@(TheaterFor tvar _ _) actor behavior = do
spawnIO theater@(TheaterFor tvar _) key mkEnv behavior = do
chan <- newChan
added <- atomically $ stateTVar tvar $ \ hm ->
let hm' = HM.alter (create chan) actor hm
in ( not (HM.member actor hm) && HM.member actor hm'
let hm' = HM.alter (create $ Actor chan) key hm
in ( not (HM.member key hm) && HM.member key hm'
, hm'
)
when added $ launchActorThread chan theater actor behavior
when added $ do
env <- mkEnv
launchActorThread chan theater key env behavior
return added
where
create chan Nothing = Just chan
create _ j@(Just _) = j
create actor Nothing = Just actor
create _ j@(Just _) = j
-- | Launch a new actor with the given ID and behavior. Return 'True' if the ID
-- was unused and the actor has been launched. Return 'False' if the ID is
@ -316,11 +339,12 @@ spawn
, Eq k, Hashable k, Show k, Message m, Show r
)
=> k
-> IO s
-> (m -> ActFor s (r, ActFor s (), Next))
-> n Bool
spawn key behavior = liftActor $ do
spawn key mkEnv behavior = liftActor $ do
theater <- askTheater
liftIO $ spawnIO theater key behavior
liftIO $ spawnIO theater key mkEnv behavior
done :: Monad n => a -> n (a, ActFor s (), Next)
done msg = return (msg, return (), Proceed)

25
src/Control/Concurrent/Local.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2019, 2023 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -15,11 +15,13 @@
module Control.Concurrent.Local
( forkCheck
, intervalMicros
, periodically
)
where
import Control.Concurrent
import Control.Exception.Base
import Control.Monad
import Control.Monad.IO.Class
import Data.Functor (void)
@ -32,11 +34,18 @@ forkCheck run = do
tid <- myThreadId
void $ forkFinally run $ either (throwTo tid) (const $ return ())
periodically :: MonadIO m => TimeInterval -> m () -> m ()
periodically interval action =
data MicrosBeyondIntRange = MicrosBeyondIntRange Integer deriving Show
instance Exception MicrosBeyondIntRange
intervalMicros :: TimeInterval -> IO Int
intervalMicros interval = do
let micros = microseconds interval
in if 0 < micros && micros <= toInteger (maxBound :: Int)
then
let micros' = fromInteger micros
in forever $ liftIO (threadDelay micros') >> action
else error $ "periodically: interval out of range: " ++ show micros
if 0 < micros && micros <= toInteger (maxBound :: Int)
then return $ fromInteger micros
else throwIO $ MicrosBeyondIntRange micros
periodically :: MonadIO m => TimeInterval -> m () -> m ()
periodically interval action = do
micros <- liftIO $ intervalMicros interval
forever $ liftIO (threadDelay micros) >> action

51
src/Data/Slab.hs Normal file
View file

@ -0,0 +1,51 @@
{- This file is part of Vervis.
-
- Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
-- | Save and load the read-only environment of application components.
--
-- Meh, that's the best title I can come up with right now. I'm tempted not to
-- make it actor-specific, hence also no "Actor" in the module name. But here's
-- an attempt with actors:
--
-- Disk-persistent actor read-only identity/environments
--
-- Or:
--
-- Store and load the read-only environments that identity/define/accompany
-- your actor/microservice threads throughout their lifetimes.
--
-- I'm thinking of 3 basic ways that the slab system can be implemented:
--
-- * Using one file per actor, naming the file using either UUID or a hash of
-- some unique property of the actor if it already has one
-- * Same but using an SQLite database for each slab, for atomicity
-- * A single database, say SQLite, for all the slabs
--
-- This module provides just the slab system, without a specific backend. I'll
-- write a file backend in another module, which can live in the same package.
-- The SQLite ones need their own package(s) because they depend on a DB.
--
-- Let's see what comes up.
module Data.Slab
( Engrave ()
, EngraveShow ()
, EngraveJSON ()
, EngraveSerialize ()
, Slab (..)
, Workshop (..)
)
where
import Data.Slab.Backend

195
src/Data/Slab/Backend.hs Normal file
View file

@ -0,0 +1,195 @@
{- This file is part of Vervis.
-
- Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
-- For the fundep in FaceType - is that fundep needed? haven't verified yet
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE DataKinds #-}
-- | This module is only for use when implementing new backends, i.e.
-- 'Workshop' instances. It exports everything 'Data.Slab' does, in addition to
-- types needed for implementing a backend.
module Data.Slab.Backend
( SlabValue (..)
, Hard (..)
, Face (..)
, FaceType ()
, Engrave (..)
, EngraveShow ()
, EngraveJSON ()
, EngraveSerialize ()
, Slab (..)
, Workshop (..)
)
where
import Data.Bifunctor
import Data.ByteString (ByteString)
import Data.Kind
import Data.Proxy
import Data.Text (Text)
import Data.Typeable
import Text.Read (readEither)
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as BL
import qualified Data.Serialize as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding.Error as TEE
data SlabValue = SlabText Text | SlabByteString ByteString deriving Show
{-
data SlabValue (a :: Type) :: Type where
SlabText :: Text -> SlabValue Text
SlabByteString :: ByteString -> SlabValue ByteString
-}
class Hard (f :: Face) where
toSlabValue :: FaceType f -> SlabValue
fromSlabValue :: SlabValue -> Either Text (FaceType f)
data Face = FaceText | FaceByteString
type family FaceType (a :: Face) {-:: Type-} = t | t -> a where
FaceType 'FaceText = Text
FaceType 'FaceByteString = ByteString
instance Hard 'FaceText where
toSlabValue = SlabText
fromSlabValue (SlabText t) = Right t
fromSlabValue s =
Left $ "fromSlabValue FaceText: Got " <> T.pack (show s)
instance Hard 'FaceByteString where
toSlabValue = SlabByteString
fromSlabValue (SlabByteString b) = Right b
fromSlabValue s =
Left $ "fromSlabValue FaceByteString: Got " <> T.pack (show s)
class Hard (EngraveFace a) => Engrave a where
type EngraveFace a :: Face
engrave :: a -> FaceType (EngraveFace a)
see :: FaceType (EngraveFace a) -> Either Text a
{-
engrave :: Engrave a => a -> SlabValue
engrave = toSlabValue . engrave
see :: Engrave a => SlabValue -> Either Text a
see = see <=< fromSlabValue
-}
instance Engrave Text where
type EngraveFace Text = 'FaceText
engrave = id
see = Right
instance Engrave ByteString where
type EngraveFace ByteString = 'FaceByteString
engrave = id
see = Right
showError :: Typeable a => Either (Proxy a, Text -> Text) a -> Either Text a
showError = bimap (uncurry errorText) id
where
errorText :: Typeable b => Proxy b -> (Text -> Text) -> Text
errorText p mk = mk $ T.pack $ show $ typeRep p
newtype EngraveShow a = EngraveShow { unEngraveShow :: a }
instance (Typeable a, Show a, Read a) => Engrave (EngraveShow a) where
type EngraveFace (EngraveShow a) = EngraveFace Text
engrave = engrave . T.pack . show . unEngraveShow
see v = do
t <- see v
showError $
case readEither $ T.unpack t of
Left e ->
Left $ (Proxy,) $ \ typ ->
T.concat [ "Invalid ", typ, ": ", T.pack e, ": ", t]
Right x -> Right $ EngraveShow x
newtype EngraveJSON a = EngraveJSON { unEngraveJSON :: a }
instance (Typeable a, A.FromJSON a, A.ToJSON a) => Engrave (EngraveJSON a) where
type EngraveFace (EngraveJSON a) = EngraveFace ByteString
engrave = BL.toStrict . A.encode . unEngraveJSON
see v = do
bs <- see v
let input = TE.decodeUtf8With TEE.lenientDecode bs -- TE.decodeUtf8Lenient bs
showError $
case A.eitherDecodeStrict' bs of
Left e ->
Left $ (Proxy,) $ \ typ ->
T.concat
[ "JSON decoding error for ", typ, ": "
, T.pack e, " on input: ", input
]
Right x -> Right $ EngraveJSON x
newtype EngraveSerialize a = EngraveSerialize { unEngraveSerialize :: a }
instance (Typeable a, S.Serialize a) => Engrave (EngraveSerialize a) where
type EngraveFace (EngraveSerialize a) = EngraveFace ByteString
engrave = engrave . S.encode . unEngraveSerialize
see v = do
b <- see v
showError $
case S.decode b of
Left e ->
Left $ (Proxy,) $
\ typ -> T.concat ["Invalid ", typ, ": ", T.pack e]
Right x -> Right $ EngraveSerialize x
class Slab (s :: Type -> Type) where
-- | Once the slab has been created, it's meant to be used from a single
-- thread. As long as this thread hasn't obliterated the slab, it can
-- 'retrieve' it as many times as it wants.
--
-- Most likely you want to retrieve once when the thread starts, and
-- retrieve again whenever the thread crashes/restarts and loses access to
-- the slab.
--
-- If you want multiple threads to have access to the slab's value,
-- 'retrieve' the slab once and then pass the value to those threads.
retrieve :: Engrave a => s a -> IO a
-- | Permanently deletes the slab from the workshop. Meant to be used only
-- from a single thread. Meant to be used only once. After that one use,
-- retrieving or obliterating again will raise an exception.
obliterate :: Engrave a => s a -> IO ()
class Slab (WorkshopSlab w) => Workshop w where
data WorkshopSlab w :: Type -> Type
data WorkshopConfig w :: Type
-- | Unless a specific 'Workshop' instance says otherwise, it's safe to
-- 'load' a workshop only when nothing else is holding access to it: Not
-- your program, not another thread, not another process.
--
-- You probably want to load your workshop once when your application
-- starts, and reload when the component of your program that uses the
-- workshop is restarted.
load :: Engrave a => WorkshopConfig w -> IO (w a, [WorkshopSlab w a])
-- | Create a new slab with the given value. This must be thread-safe, i.e.
-- different threads can concurrently create new slabs. However, once the
-- slab is obtained, only one thread should use it.
--
-- If you want multiple threads to have access to the slab's value,
-- 'retrieve' the slab once and then pass the value to those threads.
conceive :: Engrave a => w a -> a -> IO (WorkshopSlab w a)
-- | Clear the workshop. Like 'load', this is safe only if nothing else
-- holds access to the workshop.
vacate :: Engrave a => w a -> IO ()

127
src/Data/Slab/Simple.hs Normal file
View file

@ -0,0 +1,127 @@
{- This file is part of Vervis.
-
- Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
module Data.Slab.Simple
( SimpleWorkshop ()
, makeSimpleWorkshopConfig
)
where
import Control.Concurrent
import Control.Monad
import Data.Foldable
import System.Directory
--import System.Directory.OsPath
import System.FilePath
--import System.OsPath
import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Slab.Backend
data SimpleWorkshop a = SimpleWorkshop
{ _swPath :: OsPath
, _swMVar :: MVar (a, MVar OsPath)
}
isSlab :: OsPath -> Bool
isSlab path = takeExtension path == ".slab" -- [osp|.slab|]
type OsPath = FilePath
decodeUtf = pure
encodeUtf = pure
unpack = id
toChar = id
instance Workshop SimpleWorkshop where
data WorkshopSlab SimpleWorkshop a = SimpleSlab OsPath
data WorkshopConfig SimpleWorkshop = SimpleConfig OsPath
load (SimpleConfig dir) = do
entries <- listDirectory dir
let slabPaths = filter isSlab $ map (dir </>) entries
mvar <- newEmptyMVar
let next = dir </> "next" --[osp|next|]
nextExists <- doesPathExist next
next' <- decodeUtf next
unless nextExists $ writeFile next' $ show (0 :: Integer)
_ <- forkIO $ forever $ handleRequests mvar
return
( SimpleWorkshop dir mvar
, map SimpleSlab slabPaths
)
where
handleRequests mvar = do
(val, sendPath) <- takeMVar mvar
slabPath <- do
next <- decodeUtf $ dir </> "next" -- [osp|next|]
n <- read <$> readFile next
writeFile next $ show $ succ (n :: Integer)
let wrap name = dir </> name <.> "slab" -- [osp|slab|]
(new, bs) <-
case toSlabValue $ engrave val of
SlabText t ->
(, TE.encodeUtf8 t) <$>
encodeUtf (wrap $ show n ++ "t")
SlabByteString b ->
(, b) <$> encodeUtf (wrap $ show n ++ "b")
new' <- decodeUtf new
B.writeFile new' bs
return new
putMVar sendPath slabPath
conceive (SimpleWorkshop _ mvar) val = do
sendPath <- newEmptyMVar
putMVar mvar (val, sendPath)
new <- takeMVar sendPath
return $ SimpleSlab new
vacate (SimpleWorkshop dir _) = do
entries <- listDirectory dir
let slabPaths = filter isSlab $ map (dir </>) entries
next = dir </> "next" -- [osp|next|]
traverse_ removeFile slabPaths
removeFile next
instance Slab (WorkshopSlab SimpleWorkshop) where
retrieve (SimpleSlab path) = do
b <- B.readFile path
let sv =
case reverse $ unpack $ takeBaseName path of
't':_ -> SlabText $ TE.decodeUtf8 b
'b':_ -> SlabByteString b
_ -> error $ "no b/t suffix in " ++ show path
case see =<< fromSlabValue sv of
Left e -> error $ "retrieve " ++ show path ++ " : " ++ T.unpack e
Right val -> return val
obliterate (SimpleSlab path) = removeFile path
{-
TODO CONTINUE
then, the atomic-durable one
perhaps that's enough, no need for SQLite-based one?
I thought it avoids file overload but if every actor has its own SQLite
db anyway for the Box, then no harm
Just need to make sure that slab file deletion is atomic
finally, move on to creating a module that offers a system with slabs
and boxes, it doesn't need to be perfect e.g. no need to support
persistence of private sub-actors and no need for pretty types, just a
function that wraps startTheater,spawnIO,spawn
then use that to launch the DeliveryTheater in Vervis.Application
And evolve the DeliveryTheater behavior to cache+retry
-}
makeSimpleWorkshopConfig :: OsPath -> WorkshopConfig SimpleWorkshop
makeSimpleWorkshopConfig = SimpleConfig

82
src/Database/Persist/Box.hs Normal file
View file

@ -0,0 +1,82 @@
{- This file is part of Vervis.
-
- Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
-- | Example:
--
-- @
-- import Database.Persist.Box
-- import System.OsPath
--
-- data Person = Person
-- { personName :: Text
-- , personAge :: Int
-- }
-- deriving Show
-- deriving 'Boxable' via ('BoxableShow' Person)
--
-- main :: IO ()
-- main = do
-- path <- decodeUtf "mydb.box"
-- alice <- 'loadBox' path $ Person "Alice" 50
-- 'withBox' alice $ do
-- Person _name age <- 'obtain'
-- 'bestow' $ Person "Alicia" (age + 1)
-- @
--
-- Notes:
--
-- * A 'Box' is meant to be used from a single thread! However, you can have
-- multiple threads with read-only access, see 'createBoxView'
-- * Instead of passing around the 'Box' and using 'withBox' to access it, you
-- can implement a 'MonadBox' instance for your monad and use 'runBox' to
-- access the box
-- * 'BoxableShow' is just one of several serialization methods
-- * Migrations not supported yet
module Database.Persist.Box
( -- * TH
model
, modelFile
, makeBox
-- * Making types boxable
, BoxPersistT ()
, Boxable ()
, BoxableFormat ()
, BoxableVia (..)
, BoxableRecord ()
, BoxableField ()
, BoxableShow ()
, BoxableJSON ()
, BoxableSerialize ()
-- * Box access
, Box ()
--, MigrationRecipes
, loadBox
, withBox
, MonadBox (..)
, runBox
, bestow
, obtain
-- * Box viewer pool
, BoxView ()
, createBoxView
, viewBox
)
where
import Database.Persist.Box.Internal
import Database.Persist.Box.Via

424
src/Database/Persist/Box/Internal.hs Normal file
View file

@ -0,0 +1,424 @@
{- This file is part of Vervis.
-
- Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeApplications #-}
module Database.Persist.Box.Internal
( -- * TH
model
, modelFile
, makeBox
-- * Making types boxable
, BoxPersistT ()
, Boxable (..)
, BoxableFormat (..)
, BoxableVia (..)
, BoxableRecord ()
, BoxableField ()
, BoxableShow ()
, BoxableJSON ()
, BoxableSerialize ()
-- MIGRATIONS
--
-- Use the SQLite user version pragma to track the version
--
-- Record: Adapt persistent-migration to single-field case
-- The rest: Provide 3 types of migrations:
-- 1. Create the table
-- 2. Adapt the value
-- 3. Change the value's type
--
-- This should allow migrating *between* serialization types as well. Since
-- SQLite column types are just a recommendation (AFAIK so far), switching type
-- simply involves an in-place update, and an update to the schema for the
-- formality.
--
-- This can be automated by either having a typeclass for each switch between
-- serialization types, or have each serialization type specify its sqlType,
-- and then whenever a migration switches between serialization types with a
-- different SqlType, run a SQL command to change the column type.
--
-- And switching to/from record to simple field would be done by creating a new
-- table, migrating the row, and deleting the old table.
--
-- Actually, this can be done for the between-simples as well, it means there's
-- no need to define migration SQL for column type change, just reuse the SQL
-- for table creation. OTOH does it waste anything? Likely not, serialization
-- type changes would likely be rare, never something that would generate 1000s
-- of table create-deletes or anything like that.
--
-- Switching between different record types is same idea: Make new table,
-- migrate the row, delete old table.
--
-- NOTE: Old and new table names might clash, especially since all the "simple"
-- types use the same schema of table "cell" with column "value". Solution
-- would be to create the new table with some very unlikely name, do the
-- migration, delete old table, then finally rename new table. It's now the
-- only table, so, the remaming will just work.
--
-- Proposal: Somehow use types to force writing migration numbers in the
-- migration list, not just as comments? And then verify the numbers at *build*
-- time, i.e. compile successfully only if they're sequential and starting from
-- the earliest-supported number specified. And perhaps force having the
-- migration number at the end of the type name for "simple" ones, and have it
-- auto-prepended to type name and field accessor names using
-- persistent-migration's existing mechanism that does that?
--
-- Proposal: To have better type safety, rather than a plain list of possibly
-- inconsistent migrations, make sure that a migration a->b is followed by a
-- migration b->c etc. etc. and finally the last migration leads to the current
-- version of the boxable type.
--
-- Proposal: The "record" option might be most useful for debugging,
-- inspecting, accessing via non-haskell, etc. etc. but also migrations are
-- more involved, having to manually specify each column
-- change/removal/addition. So, idea: Add a migration that allows to specify
-- function PersonOld->PersonNew and simply creates a new table, writes the row
-- and deletes old table. Idk if it exhausts anything, but it allows to write a
-- migration in terms of Haskell types rather than columns. It's also safer,
-- more checked, unless I add support for column remove/add that verifies the
-- removed column actually existed and added one truly exists in the new
-- version of the type etc.
-- * Box access
, Box ()
--, MigrationRecipes
, loadBox
, withBox
, MonadBox (..)
, runBox
, bestow
, obtain
-- * Box viewer pool
, BoxView ()
, createBoxView
, viewBox
)
where
import Control.Exception.Base
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Class
import Data.ByteString (ByteString)
import Data.Int
import Data.Kind
import Data.Proxy
import Data.Text (Text)
import Database.Persist
import Database.Persist.Sql
import Database.Persist.Sqlite
import Language.Haskell.TH.Quote (QuasiQuoter)
import Language.Haskell.TH.Syntax (Q, Exp, Dec)
import Text.Read (readEither)
import Type.Reflection (Typeable, typeRep)
import qualified Data.Aeson as A
import qualified Data.Serialize as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Database.Persist.Types as PT
import qualified Database.Persist.Schema.TH as PS
import Database.Persist.Sqlite.Local
{-
getVersion :: MonadIO m => SqlPersistT m Int
getVersion = do
r <- rawSql "PRAGMA user_version" []
case r of
[] -> error "No user_version"
[Single n] -> return n
_ -> error "Multiple user_version"
setVersion :: MonadIO m => Int -> SqlPersistT m ()
setVersion n = rawExecute "PRAGMA user_version = ?" [toPersistValue n]
-}
createEntityIfNeeded
:: (Monad proxy, MonadIO m, PersistRecordBackend record SqlBackend)
=> proxy record -> SqlPersistT m ()
createEntityIfNeeded p = runMigration $ migrate [] (entityDef p)
createCellIfNeeded
:: forall m a. (MonadIO m, PersistFieldSql a)
=> Proxy a -> SqlPersistT m ()
createCellIfNeeded p = do
r <-
rawSql
"SELECT name FROM sqlite_schema WHERE type='table' AND name=?"
[PersistText "cell"]
case r of
[] ->
let query = T.concat
["CREATE TABLE cell(id INTEGER PRIMARY KEY, value "
, showSqlType $ sqlType p
, " NOT NULL)"
]
in rawExecute query []
[Single (_ :: a)] -> pure ()
_ -> error "Multiple cell tables in sqlite_schema"
model :: QuasiQuoter
model = PS.model ""
modelFile :: FilePath -> Q Exp
modelFile = PS.modelFile ""
-- | Declare datatypes and a 'PeristEntity' instance, from the entity
-- definition produced by 'model' or 'modelFile'
makeBox :: [PT.EntityDef] -> Q [Dec]
makeBox [e] = PS.makeEntities [e]
makeBox _ = fail "makeBox requires exactly 1 entity"
newtype BoxPersistT r m a = BoxPersistT (SqlPersistT m a)
deriving (Functor, Applicative, Monad, MonadIO, MonadTrans)
class Boxable a where
--type MonadMigrateBox :: (* -> *) -> Constraint
--type MigrationRecipes a :: * -> *
--migrateBox :: (MonadIO m, MonadLogger m, MonadMigrateBox m) => MigrationRecipe a m -> SqlPersistT m (Either Text (Int, Int))
createBoxStorageIfNeeded :: MonadIO m => Proxy a -> SqlPersistT m ()
bestowB :: MonadIO m => a -> SqlPersistT m ()
obtainB :: MonadIO m => SqlPersistT m a
class BoxableFormat (f :: Type -> Type) where
wrapBF :: a -> f a
unwrapBF :: f a -> a
class (BoxableFormat (BV a), Boxable (BV a a)) => BoxableVia a where
type BV a :: Type -> Type
bestow' :: (MonadIO m, Boxable a) => a -> BoxPersistT a m ()
bestow' = BoxPersistT . bestowB
obtain' :: (MonadIO m, Boxable a) => BoxPersistT a m a
obtain' = BoxPersistT obtainB
bestow :: forall m a. (MonadIO m, BoxableVia a) => a -> BoxPersistT a m ()
bestow = BoxPersistT . bestowB . wrapBF @(BV a) @a
obtain :: forall m a. (MonadIO m, BoxableVia a) => BoxPersistT a m a
obtain = BoxPersistT $ unwrapBF @(BV a) @a <$> obtainB
newtype BoxableRecord a = BoxableRecord { unBoxableRecord :: a }
instance BoxableFormat BoxableRecord where
wrapBF = BoxableRecord
unwrapBF = unBoxableRecord
keyN :: Int64
keyN = 1
key :: ToBackendKey SqlBackend record => Key record
key = toSqlKey keyN
instance (PersistRecordBackend a SqlBackend, ToBackendKey SqlBackend a) => Boxable (BoxableRecord a) where
--type MigrationRecipe (BoxablePersist a) m = [Migration SqlBackend m]
--migrateBox ms = second (,length ms) <$> runMigrations schemaBackend? "" 1 ms
createBoxStorageIfNeeded = createEntityIfNeeded . fmap unBoxableRecord
bestowB (BoxableRecord r) = repsert key r
obtainB = BoxableRecord <$> getJust key
newtype BoxableField a = BoxableField { unBoxableField :: a }
instance BoxableFormat BoxableField where
wrapBF = BoxableField
unwrapBF = unBoxableField
newtype BoxException = BoxException Text deriving Show
instance Exception BoxException
instance PersistFieldSql a => Boxable (BoxableField a) where
--type MigrationRecipe (BoxablePersist a) = ???
--migrateBox ms = ???
createBoxStorageIfNeeded = createCellIfNeeded . fmap unBoxableField
bestowB (BoxableField v) =
rawExecute query [toPersistValue keyN, toPersistValue v]
where
query =
"INSERT INTO cell(id,value) VALUES (?,?)\
\ ON CONFLICT (id) DO UPDATE SET value=EXCLUDED.value"
obtainB = do
r <- rawSql query [toPersistValue keyN]
case r of
[] -> liftIO $ throwIO $ BoxException "obtainB: row not found"
[Single v] -> return $ BoxableField v
_ -> liftIO $ throwIO $ BoxException "obtainB: multiple rows found"
where
query = "SELECT value FROM cell WHERE id=?"
{-
adapt :: BoxPersistT x m a -> BoxPersistT y m a
adapt (BoxPersistT action) = BoxPersistT action
-}
newtype WrapShow a = WrapShow { unWrapShow :: a }
instance (Typeable a, Show a, Read a) => PersistField (WrapShow a) where
toPersistValue = toPersistValue . show . unWrapShow
fromPersistValue v = do
s <- fromPersistValue v
case readEither s of
Left e' ->
Left $ T.pack $
"Invalid " ++ show (typeRep @a) ++ ": " ++
e' ++ ": " ++ s
Right x -> Right $ WrapShow x
instance PersistField (WrapShow a) => PersistFieldSql (WrapShow a) where
sqlType _ = sqlType (Proxy :: Proxy String)
newtype BoxableShow a = BoxableShow { unBoxableShow :: a }
instance BoxableFormat BoxableShow where
wrapBF = BoxableShow
unwrapBF = unBoxableShow
instance (Typeable a, Show a, Read a) => Boxable (BoxableShow a) where
--type MigrationRecipe (BoxablePersist a) = ???
--migrateBox ms = ???
createBoxStorageIfNeeded =
createCellIfNeeded . fmap (WrapShow . unBoxableShow)
bestowB = bestowB . BoxableField . WrapShow . unBoxableShow
obtainB = BoxableShow . unWrapShow . unBoxableField <$> obtainB
newtype WrapJSON a = WrapJSON { unWrapJSON :: a }
instance (Typeable a, A.FromJSON a, A.ToJSON a) => PersistField (WrapJSON a) where
toPersistValue = PersistText . toJsonText . unWrapJSON
fromPersistValue v = do
text <- fromPersistValue v
let bs = TE.encodeUtf8 text
case A.eitherDecodeStrict' bs of
Left e ->
Left $
T.concat
[ "JSON decoding error for "
, T.pack $ show $ typeRep @a
, ": ", T.pack e, " on input: ", text
]
Right x -> Right $ WrapJSON x
instance PersistField (WrapJSON a) => PersistFieldSql (WrapJSON a) where
sqlType _ = SqlString
newtype BoxableJSON a = BoxableJSON { unBoxableJSON :: a }
instance BoxableFormat BoxableJSON where
wrapBF = BoxableJSON
unwrapBF = unBoxableJSON
instance (Typeable a, A.FromJSON a, A.ToJSON a) => Boxable (BoxableJSON a) where
--type MigrationRecipe (BoxablePersist a) = ???
--migrateBox ms = ???
createBoxStorageIfNeeded =
createCellIfNeeded . fmap (WrapJSON . unBoxableJSON)
bestowB = bestowB . BoxableField . WrapJSON . unBoxableJSON
obtainB = BoxableJSON . unWrapJSON . unBoxableField <$> obtainB
newtype WrapSerialize a = WrapSerialize { unWrapSerialize :: a }
instance (Typeable a, S.Serialize a) => PersistField (WrapSerialize a) where
toPersistValue = toPersistValue . S.encode . unWrapSerialize
fromPersistValue v = do
b <- fromPersistValue v
case S.decode b of
Left e ->
Left $ T.pack $ "Invalid " ++ show (typeRep @a) ++ ": " ++ e
Right x -> Right $ WrapSerialize x
instance PersistField (WrapSerialize a) => PersistFieldSql (WrapSerialize a) where
sqlType _ = sqlType (Proxy :: Proxy ByteString)
newtype BoxableSerialize a = BoxableSerialize { unBoxableSerialize :: a }
instance BoxableFormat BoxableSerialize where
wrapBF = BoxableSerialize
unwrapBF = unBoxableSerialize
instance (Typeable a, S.Serialize a) => Boxable (BoxableSerialize a) where
--type MigrationRecipe (BoxablSerialize a) = ???
--migrateBox ms = ???
createBoxStorageIfNeeded =
createCellIfNeeded . fmap (WrapSerialize . unBoxableSerialize)
bestowB = bestowB . BoxableField . WrapSerialize . unBoxableSerialize
obtainB = BoxableSerialize . unWrapSerialize . unBoxableField <$> obtainB
data Box a = Box SqliteConnectionInfo ConnectionPool
type OsPath = FilePath
decodeUtf = pure
loadBox
:: (MonadLoggerIO m, MonadUnliftIO m, BoxableVia a)
=> OsPath -> a -> m (Box a)
loadBox path val = do
path' <- liftIO $ T.pack <$> decodeUtf path
let info = mkSqliteConnectionInfo path'
pool <- createSqlitePoolFromInfo info 1
let box = Box info pool
withBox box $ do
let proxy :: a -> Proxy (BV a a)
proxy _ = Proxy
BoxPersistT $ createBoxStorageIfNeeded $ proxy val
{-
r <- migrateBox migrations
Left err -> do
let msg = "DB migration failed: " <> path' <> ": " <> err
logError msg
error $ T.unpack msg
Right (from, to) -> do
logInfo $ T.concat
[ "DB migration success: ", path', ": "
, T.pack $ show from, " ==> ", T.pack $ show to
]
mval <- get key
when (isNothing val) $ insertKey key val
-}
return box
withBox :: MonadUnliftIO m => Box record -> BoxPersistT record m a -> m a
withBox (Box info pool) (BoxPersistT action) = runPool conf action pool
where
conf = SqliteConfInfo info 1
class (Monad m, BoxableVia (BoxType m)) => MonadBox m where
type BoxType m
askBox :: m (Box (BoxType m))
runBox :: (MonadUnliftIO m, MonadBox m) => BoxPersistT (BoxType m) m a -> m a
runBox action = do
box <- askBox
withBox box action
data BoxView a = BoxView SqliteConf ConnectionPool
createBoxView :: (MonadLoggerIO m, MonadUnliftIO m) => Box record -> Int -> m (BoxView record)
createBoxView (Box info _) size = do
pool <- createSqlitePoolFromInfo info size
let conf = SqliteConfInfo info size
return $ BoxView conf pool
viewBox :: (MonadUnliftIO m, Boxable a) => BoxView a -> m a
viewBox (BoxView conf pool) = runPool conf obtainB pool

34
src/Database/Persist/Box/Via.hs Normal file
View file

@ -0,0 +1,34 @@
{- This file is part of Vervis.
-
- Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
module Database.Persist.Box.Via
(
)
where
import Data.Kind
import Database.Persist.Box.Internal
{-
instance BoxableVia a => Boxable a where
createBoxStorageIfNeeded = createBoxStorageIfNeeded . fmap (wrapBF @(BV a) @a)
bestowB = bestowB . wrapBF @(BV a) @a
obtainB = unwrapBF @(BV a) @a <$> obtainB
-}

47
src/Database/Persist/Sqlite/Local.hs Normal file
View file

@ -0,0 +1,47 @@
{-
Copied from persistent-sqlite 2.13.1.1 which is under MIT license
Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/
Permission is hereby granted, free of charge, to any person obtaining
a copy of this software and associated documentation files (the
"Software"), to deal in the Software without restriction, including
without limitation the rights to use, copy, modify, merge, publish,
distribute, sublicense, and/or sell copies of the Software, and to
permit persons to whom the Software is furnished to do so, subject to
the following conditions:
The above copyright notice and this permission notice shall be
included in all copies or substantial portions of the Software.
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-}
module Database.Persist.Sqlite.Local
( showSqlType
)
where
import Data.Text (Text)
import Database.Persist.Sql
import qualified Data.Text as T
showSqlType :: SqlType -> Text
showSqlType SqlString = "VARCHAR"
showSqlType SqlInt32 = "INTEGER"
showSqlType SqlInt64 = "INTEGER"
showSqlType SqlReal = "REAL"
showSqlType (SqlNumeric precision scale) = T.concat [ "NUMERIC(", T.pack (show precision), ",", T.pack (show scale), ")" ]
showSqlType SqlDay = "DATE"
showSqlType SqlTime = "TIME"
showSqlType SqlDayTime = "TIMESTAMP"
showSqlType SqlBlob = "BLOB"
showSqlType SqlBool = "BOOLEAN"
showSqlType (SqlOther t) = t

6
src/Network/FedURI.hs
View file

@ -65,7 +65,7 @@ data Authority t = Authority
{ authorityHost :: Text
, authorityPort :: Maybe Word16
}
deriving (Eq, Ord, Generic)
deriving (Eq, Ord, Show, Generic)
instance UriMode t => Hashable (Authority t)
@ -185,7 +185,7 @@ instance PersistFieldSql FullURI where
data LocalURI = LocalURI
{ localUriPath :: Text
}
deriving (Eq, Ord, Generic)
deriving (Eq, Ord, Show, Read, Generic)
instance Hashable LocalURI
@ -459,7 +459,7 @@ data ObjURI t = ObjURI
{ objUriAuthority :: Authority t
, objUriLocal :: LocalURI
}
deriving (Eq, Generic)
deriving (Eq, Show, Generic)
instance UriMode t => Hashable (ObjURI t)

13
src/Vervis/Access.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -67,6 +67,8 @@ module Vervis.Access
, unhashGrantResourcePure
, unhashGrantResource
, unhashGrantResourceE
, unhashGrantResource'
, unhashGrantResourceE'
, unhashGrantResource404
, hashGrantResource
, getGrantResource
@ -96,6 +98,8 @@ import Yesod.Core.Handler
import qualified Database.Esqueleto as E
import Control.Concurrent.Actor
import Web.Actor.Persist (stageHashidsContext)
import Yesod.Hashids
import Yesod.MonadSite
@ -285,6 +289,13 @@ unhashGrantResource resource = do
unhashGrantResourceE resource e =
ExceptT $ maybe (Left e) Right <$> unhashGrantResource resource
unhashGrantResource' resource = do
ctx <- asksEnv stageHashidsContext
return $ unhashGrantResourcePure ctx resource
unhashGrantResourceE' resource e =
ExceptT $ maybe (Left e) Right <$> unhashGrantResource' resource
unhashGrantResource404 = maybe notFound return <=< unhashGrantResource
hashGrantResource (GrantResourceRepo k) =

8
src/Vervis/ActivityPub.hs
View file

@ -101,6 +101,7 @@ import Database.Persist.Local
import qualified Data.Patch.Local as P
import Vervis.Actor
import Vervis.FedURI
import Vervis.Foundation
import Vervis.Model
@ -109,13 +110,6 @@ import Vervis.RemoteActorStore
import Vervis.Settings
import Vervis.Time
data RemoteRecipient = RemoteRecipient
{ remoteRecipientActor :: RemoteActorId
, remoteRecipientId :: LocalURI
, remoteRecipientInbox :: LocalURI
, remoteRecipientErrorSince :: Maybe UTCTime
}
{-
getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty RemoteRecipient)])
getFollowers fsid = do

385
src/Vervis/Actor.hs
View file

@ -13,6 +13,8 @@
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
{-# LANGUAGE RankNTypes #-}
-- These are for the Barbie-based generated instances
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
@ -24,6 +26,20 @@ module Vervis.Actor
LocalActorBy (..)
, LocalActor
-- * Converting between KeyHashid, Key, Identity and Entity
--
-- Adapted from 'Vervis.Recipient'
, hashLocalActorPure
, getHashLocalActor
, hashLocalActor
, unhashLocalActorPure
, unhashLocalActor
, unhashLocalActorF
, unhashLocalActorM
, unhashLocalActorE
, unhashLocalActor404
-- * Local recipient set
, TicketRoutes (..)
, ClothRoutes (..)
@ -55,33 +71,57 @@ module Vervis.Actor
, withDB
, withDBExcept
, behave
, RemoteRecipient (..)
, sendToLocalActors
)
where
import Control.Concurrent.STM.TVar
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import Data.Barbie
import Data.ByteString (ByteString)
import Data.Foldable
import Data.Function
import Data.Hashable
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe
import Data.Text (Text)
import Data.Time.Clock
import Data.Traversable
import Data.Typeable
import Database.Persist.Sql
import GHC.Generics
import UnliftIO.Exception
import Web.Hashids
import Yesod.Core
import qualified Control.Monad.Fail as F
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as BL
import qualified Data.HashSet as HS
import qualified Data.List.NonEmpty as NE
import qualified Data.List.Ordered as LO
import qualified Data.Text as T
import qualified Database.Esqueleto as E
import Control.Concurrent.Actor
import Crypto.ActorKey
import Network.FedURI
import Web.Actor
import Web.Actor.Deliver
import Web.Actor.Persist
import Yesod.Hashids
import Yesod.MonadSite
import qualified Web.ActivityPub as AP
import Data.List.NonEmpty.Local
import Vervis.FedURI
import Vervis.Model hiding (Actor, Message)
import Vervis.Settings
@ -101,6 +141,77 @@ deriving instance AllBF Show f LocalActorBy => Show (LocalActorBy f)
type LocalActor = LocalActorBy KeyHashid
hashLocalActorPure
:: HashidsContext -> LocalActorBy Key -> LocalActorBy KeyHashid
hashLocalActorPure ctx = f
where
f (LocalActorPerson p) = LocalActorPerson $ encodeKeyHashidPure ctx p
f (LocalActorGroup g) = LocalActorGroup $ encodeKeyHashidPure ctx g
f (LocalActorRepo r) = LocalActorRepo $ encodeKeyHashidPure ctx r
f (LocalActorDeck d) = LocalActorDeck $ encodeKeyHashidPure ctx d
f (LocalActorLoom l) = LocalActorLoom $ encodeKeyHashidPure ctx l
getHashLocalActor
:: (MonadActor m, StageHashids (ActorEnv m))
=> m (LocalActorBy Key -> LocalActorBy KeyHashid)
getHashLocalActor = do
ctx <- asksEnv stageHashidsContext
return $ hashLocalActorPure ctx
hashLocalActor
:: (MonadActor m, StageHashids (ActorEnv m))
=> LocalActorBy Key -> m (LocalActorBy KeyHashid)
hashLocalActor actor = do
hash <- getHashLocalActor
return $ hash actor
unhashLocalActorPure
:: HashidsContext -> LocalActorBy KeyHashid -> Maybe (LocalActorBy Key)
unhashLocalActorPure ctx = f
where
f (LocalActorPerson p) = LocalActorPerson <$> decodeKeyHashidPure ctx p
f (LocalActorGroup g) = LocalActorGroup <$> decodeKeyHashidPure ctx g
f (LocalActorRepo r) = LocalActorRepo <$> decodeKeyHashidPure ctx r
f (LocalActorDeck d) = LocalActorDeck <$> decodeKeyHashidPure ctx d
f (LocalActorLoom l) = LocalActorLoom <$> decodeKeyHashidPure ctx l
unhashLocalActor
:: (MonadActor m, StageHashids (ActorEnv m))
=> LocalActorBy KeyHashid -> m (Maybe (LocalActorBy Key))
unhashLocalActor actor = do
ctx <- asksEnv stageHashidsContext
return $ unhashLocalActorPure ctx actor
unhashLocalActorF
:: (F.MonadFail m, MonadActor m, StageHashids (ActorEnv m))
=> LocalActorBy KeyHashid -> String -> m (LocalActorBy Key)
unhashLocalActorF actor e = maybe (F.fail e) return =<< unhashLocalActor actor
unhashLocalActorM
:: (MonadActor m, StageHashids (ActorEnv m))
=> LocalActorBy KeyHashid -> MaybeT m (LocalActorBy Key)
unhashLocalActorM = MaybeT . unhashLocalActor
unhashLocalActorE
:: (MonadActor m, StageHashids (ActorEnv m))
=> LocalActorBy KeyHashid -> e -> ExceptT e m (LocalActorBy Key)
unhashLocalActorE actor e =
ExceptT $ maybe (Left e) Right <$> unhashLocalActor actor
unhashLocalActor404
:: ( MonadSite m
, MonadHandler m
, HandlerSite m ~ SiteEnv m
, YesodHashids (HandlerSite m)
)
=> LocalActorBy KeyHashid
-> m (LocalActorBy Key)
unhashLocalActor404 actor = maybe notFound return =<< unhashLocalActor actor
where
unhashLocalActor byHash = do
ctx <- asksSite siteHashidsContext
return $ unhashLocalActorPure ctx byHash
data TicketRoutes = TicketRoutes
{ routeTicketFollowers :: Bool
}
@ -182,8 +293,13 @@ data VerseRemote = VerseRemote
}
data Event
= EventFwdRemoteGrantToSomeoneElse RemoteActivityId
= EventRemoteGrantLocalRecipFwdToFollower RemoteActivityId
-- ^ A local actor has received a Grant (they're being granted some access)
-- and forwarding it to me because I'm following this local actor
| EventRemoteFwdLocalActivity (LocalActorBy Key) OutboxItemId
-- EventLocalFwdRemoteActivity (LocalActorBy Key) RemoteActivityId
-- ^ A local actor is forwarding me a remote activity to add to my inbox.
-- The data is (1) who's forwarding to me (2) the remote activity
| EventUnknown
deriving Show
@ -200,6 +316,8 @@ instance Message Verse where
let ObjURI h _ = remoteAuthorURI author
in renderObjURI $ ObjURI h uri
type YesodRender y = Route y -> [(Text, Text)] -> Text
-- | Data to which every actor has access. Since such data can be passed to the
-- behavior function when launching the actor, having a dedicated datatype is
-- just convenience. The main reason is to allow 'runDB' not to take a
@ -207,13 +325,22 @@ instance Message Verse where
-- reason is to avoid the clutter of passing the same arguments manually
-- everywhere.
--
-- The purpose of Env is to hold the system stuff: DB connection pool,
-- settings, HTTP manager, etc. etc. while the data stuff (actual info of the
-- actor) is meant to be passed as parameters of the behavior function.
--
-- Maybe in the future there won't be data shared by all actors, and then this
-- type can be removed.
data Env = Env
{ envSettings :: AppSettings
, envDbPool :: ConnectionPool
, envHashidsContext :: HashidsContext
data Env = forall y. (Typeable y, Yesod y) => Env
{ envSettings :: AppSettings
, envDbPool :: ConnectionPool
, envHashidsContext :: HashidsContext
, envActorKeys :: Maybe (TVar (ActorKey, ActorKey, Bool))
, envDeliveryTheater :: DeliveryTheater URIMode
--, envYesodSite :: y
, envYesodRender :: YesodRender y
}
deriving Typeable
instance Stage Env where
type StageKey Env = LocalActorBy Key
@ -222,7 +349,9 @@ instance Stage Env where
instance StageWeb Env where
type StageURIMode Env = URIMode
--type StageRoute Env = Route Site
stageInstanceHost = appInstanceHost . envSettings
stageDeliveryTheater = envDeliveryTheater
instance StageHashids Env where
stageHashidsContext = envHashidsContext
@ -269,3 +398,249 @@ behave handler key msg = do
case result of
Left e -> done $ Left e
Right (t, after, next) -> return (Right t, after, next)
data RemoteRecipient = RemoteRecipient
{ remoteRecipientActor :: RemoteActorId
, remoteRecipientId :: LocalURI
, remoteRecipientInbox :: LocalURI
, remoteRecipientErrorSince :: Maybe UTCTime
}
-- Given a list of local recipients, which may include actors and collections,
--
-- * Insert activity to message queues of live actors
-- * If collections are listed, insert activity to message queues of local
-- members and return the remote members
--
-- This function reads the follower sets and remote recipient data from the
-- PostgreSQL database. Don't use it inside a database transaction.
sendToLocalActors
:: Event
-- ^ Event to send to local live actors
-> Bool
-- ^ Whether to deliver to collection only if owner actor is addressed
-> Maybe (LocalActorBy Key)
-- ^ An actor whose collections are excluded from requiring an owner, i.e.
-- even if owner is required, this actor's collections will be delivered
-- to, even if this actor isn't addressed. This is meant to be the
-- activity's author.
-> Maybe (LocalActorBy Key)
-- ^ An actor whose inbox to exclude from delivery, even if this actor is
-- listed in the recipient set. This is meant to be the activity's
-- author.
-> RecipientRoutes
-> Act [((InstanceId, Host), NonEmpty RemoteRecipient)]
sendToLocalActors event requireOwner mauthor maidAuthor recips = do
-- Unhash actor and work item hashids
people <- unhashKeys $ recipPeople recips
groups <- unhashKeys $ recipGroups recips
repos <- unhashKeys $ recipRepos recips
decksAndTickets <- do
decks <- unhashKeys $ recipDecks recips
for decks $ \ (deckID, (DeckFamilyRoutes deck tickets)) ->
(deckID,) . (deck,) <$> unhashKeys tickets
loomsAndCloths <- do
looms <- unhashKeys $ recipLooms recips
for looms $ \ (loomID, (LoomFamilyRoutes loom cloths)) ->
(loomID,) . (loom,) <$> unhashKeys cloths
-- Grab local actor sets whose stages are allowed for delivery
let allowStages'
:: (famili -> routes)
-> (routes -> Bool)
-> (Key record -> LocalActorBy Key)
-> (Key record, famili)
-> Bool
allowStages' = allowStages isAuthor
peopleForStages =
filter (allowStages' id routePerson LocalActorPerson) people
groupsForStages =
filter (allowStages' id routeGroup LocalActorGroup) groups
reposForStages =
filter (allowStages' id routeRepo LocalActorRepo) repos
decksAndTicketsForStages =
filter (allowStages' fst routeDeck LocalActorDeck) decksAndTickets
loomsAndClothsForStages =
filter (allowStages' fst routeLoom LocalActorLoom) loomsAndCloths
-- Grab local actors being addressed
let localActorsForSelf = concat
[ [ LocalActorPerson key | (key, routes) <- people, routePerson routes ]
, [ LocalActorGroup key | (key, routes) <- groups, routeGroup routes ]
, [ LocalActorRepo key | (key, routes) <- repos, routeRepo routes ]
, [ LocalActorDeck key | (key, (routes, _)) <- decksAndTickets, routeDeck routes ]
, [ LocalActorLoom key | (key, (routes, _)) <- loomsAndCloths, routeLoom routes ]
]
-- Grab local actors whose followers are going to be delivered to
let personIDsForFollowers =
[ key | (key, routes) <- peopleForStages, routePersonFollowers routes ]
groupIDsForFollowers =
[ key | (key, routes) <- groupsForStages, routeGroupFollowers routes ]
repoIDsForFollowers =
[ key | (key, routes) <- reposForStages, routeRepoFollowers routes ]
deckIDsForFollowers =
[ key | (key, (routes, _)) <- decksAndTicketsForStages, routeDeckFollowers routes ]
loomIDsForFollowers =
[ key | (key, (routes, _)) <- loomsAndClothsForStages, routeLoomFollowers routes ]
-- Grab tickets and cloths whose followers are going to be delivered to
let ticketSetsForFollowers =
mapMaybe
(\ (deckID, (_, tickets)) -> (deckID,) <$>
NE.nonEmpty
[ ticketDeckID | (ticketDeckID, routes) <- tickets
, routeTicketFollowers routes
]
)
decksAndTicketsForStages
clothSetsForFollowers =
mapMaybe
(\ (loomID, (_, cloths)) -> (loomID,) <$>
NE.nonEmpty
[ ticketLoomID | (ticketLoomID, routes) <- cloths
, routeClothFollowers routes
]
)
loomsAndClothsForStages
(localFollowers, remoteFollowers) <- withDB $ do
-- Get actor and work item FollowerSet IDs from DB
followerSetIDs <- do
actorIDs <- concat <$> sequenceA
[ selectActorIDs personActor personIDsForFollowers
, selectActorIDs groupActor groupIDsForFollowers
, selectActorIDs repoActor repoIDsForFollowers
, selectActorIDs deckActor deckIDsForFollowers
, selectActorIDs loomActor loomIDsForFollowers
]
ticketIDs <-
concat <$>
((++)
<$> traverse
(selectTicketIDs ticketDeckTicket TicketDeckDeck)
ticketSetsForFollowers
<*> traverse
(selectTicketIDs ticketLoomTicket TicketLoomLoom)
clothSetsForFollowers
)
(++)
<$> (map (actorFollowers . entityVal) <$>
selectList [ActorId <-. actorIDs] []
)
<*> (map (ticketFollowers . entityVal) <$>
selectList [TicketId <-. ticketIDs] []
)
-- Get the local and remote followers of the follower sets from DB
locals <- concat <$> sequenceA
[ selectFollowers LocalActorPerson PersonActor followerSetIDs
, selectFollowers LocalActorGroup GroupActor followerSetIDs
, selectFollowers LocalActorRepo RepoActor followerSetIDs
, selectFollowers LocalActorDeck DeckActor followerSetIDs
, selectFollowers LocalActorLoom LoomActor followerSetIDs
]
remotes <- getRemoteFollowers followerSetIDs
return (locals, remotes)
-- Insert activity to message queues of all local live actors who are
-- recipients, i.e. either directly addressed or listed in a local stage
-- addressed
let liveRecips =
let s = HS.fromList $ localFollowers ++ localActorsForSelf
in case maidAuthor of
Nothing -> s
Just a -> HS.delete a s
sendMany liveRecips $ Left event
-- Return remote followers, to whom we need to deliver via HTTP
return remoteFollowers
where
orderedUnion = foldl' LO.union []
unhashKeys
:: ToBackendKey SqlBackend record
=> [(KeyHashid record, routes)]
-> Act [(Key record, routes)]
unhashKeys actorSets = do
unhash <- decodeKeyHashidPure <$> asksEnv stageHashidsContext
return $ mapMaybe (unhashKey unhash) actorSets
where
unhashKey unhash (hash, famili) = (,famili) <$> unhash hash
isAuthor =
case mauthor of
Nothing -> const False
Just author -> (== author)
allowStages
:: (LocalActorBy Key -> Bool)
-> (famili -> routes)
-> (routes -> Bool)
-> (Key record -> LocalActorBy Key)
-> (Key record, famili)
-> Bool
allowStages isAuthor familyActor routeActor makeActor (actorID, famili)
= routeActor (familyActor famili)
|| not requireOwner
|| isAuthor (makeActor actorID)
selectActorIDs
:: (MonadIO m, PersistRecordBackend record SqlBackend)
=> (record -> ActorId)
-> [Key record]
-> ReaderT SqlBackend m [ActorId]
selectActorIDs grabActor ids =
map (grabActor . entityVal) <$> selectList [persistIdField <-. ids] []
selectTicketIDs
:: ( MonadIO m
, PersistRecordBackend tracker SqlBackend
, PersistRecordBackend item SqlBackend
)
=> (item -> TicketId)
-> EntityField item (Key tracker)
-> (Key tracker, NonEmpty (Key item))
-> ReaderT SqlBackend m [TicketId]
selectTicketIDs grabTicket trackerField (trackerID, workItemIDs) = do
maybeTracker <- get trackerID
case maybeTracker of
Nothing -> pure []
Just _ ->
map (grabTicket . entityVal) <$>
selectList [persistIdField <-. NE.toList workItemIDs, trackerField ==. trackerID] []
getRemoteFollowers
:: MonadIO m
=> [FollowerSetId]
-> ReaderT SqlBackend m
[((InstanceId, Host), NonEmpty RemoteRecipient)]
getRemoteFollowers fsids =
fmap groupRemotes $
E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId
E.where_ $ rf E.^. RemoteFollowTarget `E.in_` E.valList fsids
E.orderBy [E.asc $ i E.^. InstanceId, E.asc $ ra E.^. RemoteActorId]
return
( i E.^. InstanceId
, i E.^. InstanceHost
, ra E.^. RemoteActorId
, ro E.^. RemoteObjectIdent
, ra E.^. RemoteActorInbox
, ra E.^. RemoteActorErrorSince
)
where
groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples
where
toTuples (E.Value iid, E.Value h, E.Value raid, E.Value luA, E.Value luI, E.Value ms) = ((iid, h), RemoteRecipient raid luA luI ms)
selectFollowers makeLocalActor actorField followerSetIDs =
fmap (map (makeLocalActor . E.unValue)) $
E.select $ E.from $ \ (f `E.InnerJoin` p) -> do
E.on $ f E.^. FollowActor E.==. p E.^. actorField
E.where_ $ f E.^. FollowTarget `E.in_` E.valList followerSetIDs
return $ p E.^. persistIdField

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

@ -26,10 +26,12 @@ import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Data.Bitraversable
import Data.ByteString (ByteString)
import Data.Foldable
import Data.Text (Text)
import Data.Time.Clock
import Data.Traversable
import Database.Persist
import Database.Persist.Sql
import Yesod.Persist.Core
@ -38,6 +40,7 @@ import qualified Data.Text as T
import Control.Concurrent.Actor
import Network.FedURI
import Web.Actor.Persist
import Yesod.MonadSite
import qualified Web.ActivityPub as AP
@ -46,28 +49,23 @@ import Control.Monad.Trans.Except.Local
import Database.Persist.Local
import Vervis.Actor
import Vervis.Actor2
import Vervis.Cloth
import Vervis.Data.Collab
import Vervis.Data.Discussion
import Vervis.FedURI
import Vervis.Federation.Util
import Vervis.Foundation
import Vervis.Model
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..))
import Vervis.Persist.Actor
import Vervis.Persist.Collab
import Vervis.Persist.Discussion
import Vervis.Ticket
insertActivityToInbox
:: MonadIO m
=> UTCTime -> ActorId -> OutboxItemId -> ReaderT SqlBackend m Bool
insertActivityToInbox now recipActorID outboxItemID = do
inboxID <- actorInbox <$> getJust recipActorID
inboxItemID <- insert $ InboxItem True now
maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID
case maybeItem of
Nothing -> do
delete inboxItemID
return False
Just _ -> return True
------------------------------------------------------------------------------
-- Commenting
------------------------------------------------------------------------------
-- Meaning: Someone commented on an issue/PR
-- Behavior: Insert to inbox
@ -79,7 +77,7 @@ personCreateNote
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Note URIMode
-> ExceptT Text Act (Text, Act (), Next)
-> ActE (Text, Act (), Next)
personCreateNote now recipPersonID author body mfwd luCreate note = do
-- Check input
@ -145,10 +143,109 @@ personCreateNote now recipPersonID author body mfwd luCreate note = do
unless (messageRoot m == did) $
throwE "Remote parent belongs to a different discussion"
------------------------------------------------------------------------------
-- Access
------------------------------------------------------------------------------
-- Meaning: A remote actor published a Grant
-- Behavior:
-- * Insert to my inbox
-- * If I'm the target, forward the Grant to my followers
personGrant
:: UTCTime
-> PersonId
-> RemoteAuthor
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Grant URIMode
-> ActE (Text, Act (), Next)
personGrant now recipPersonID author body mfwd luGrant grant = do
-- Check input
(_remoteResource, recipient) <- do
(resource, recip) <- parseGrant grant
let u@(ObjURI h _) = remoteAuthorURI author
resourceURI <-
case resource of
Right (ObjURI h' r) | h == h' -> return (u, r)
_ -> throwE "Grant resource and Grant author are from different instances"
when (recip == Right u) $
throwE "Grant sender and target are the same remote actor"
return (resourceURI, recip)
maybeGrant <- withDBExcept $ do
-- Grab recipient person from DB
(personRecip, actorRecip) <- lift $ do
p <- getJust recipPersonID
(p,) <$> getJust (personActor p)
mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luGrant True
for mractid $ \ grantID -> do
-- If recipient is local, find it in our DB
_recipientDB <-
bitraverse
(flip getGrantRecip "Grant local target not found in DB")
pure
recipient
return (personActor personRecip, grantID)
case maybeGrant of
Nothing -> done "I already have this activity in my inbox"
Just (actorID, grantID) -> do
let targetIsRecip =
case recipient of
Left (GrantRecipPerson p) -> p == recipPersonID
_ -> False
if not targetIsRecip
then done "I'm not the target; Inserted to inbox"
else case mfwd of
Nothing ->
done
"I'm the target; Inserted to inbox; \
\Forwarding not approved"
Just (localRecips, sig) -> do
recipHash <- encodeKeyHashid recipPersonID
let sieve =
makeRecipientSet
[]
[LocalStagePersonFollowers recipHash]
lift $ forwardActivity
(actbBL body) localRecips sig
actorID
(LocalActorPerson recipPersonID) sieve
(EventRemoteGrantLocalRecipFwdToFollower grantID)
done
"I'm the target; Inserted to inbox; \
\Forwarded to followers if addressed"
------------------------------------------------------------------------------
-- Main behavior function
------------------------------------------------------------------------------
insertActivityToInbox
:: MonadIO m
=> UTCTime -> ActorId -> OutboxItemId -> ReaderT SqlBackend m Bool
insertActivityToInbox now recipActorID outboxItemID = do
inboxID <- actorInbox <$> getJust recipActorID
inboxItemID <- insert $ InboxItem True now
maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID
case maybeItem of
Nothing -> do
delete inboxItemID
return False
Just _ -> return True
personBehavior :: UTCTime -> PersonId -> Verse -> ActE (Text, Act (), Next)
personBehavior now personID (Left event) =
case event of
EventFwdRemoteGrantToSomeoneElse grantID -> do
-- Meaning: Someone X received a Grant and forwarded it to me because
-- I'm a follower of X
-- Behavior: Insert to my inbox
EventRemoteGrantLocalRecipFwdToFollower grantID -> do
lift $ withDB $ do
(_personRecip, actorRecip) <- do
p <- getJust personID
@ -157,6 +254,8 @@ personBehavior now personID (Left event) =
itemID <- insert $ InboxItem True now
insert_ $ InboxItemRemote inboxID grantID itemID
done "Inserted Grant to inbox"
-- Meaning: A remote actor has forwarded to me a remote activity
-- Behavior: Insert it to my inbox
EventRemoteFwdLocalActivity authorByKey outboxItemID -> withDBExcept $ do
recipPerson <- lift $ getJust personID
verifyLocalActivityExistsInDB authorByKey outboxItemID
@ -179,8 +278,10 @@ personBehavior now personID (Right (VerseRemote author body mfwd luActivity)) =
{-
AP.FollowActivity follow ->
personFollowA now personID author body mfwd luActivity follow
-}
AP.GrantActivity grant ->
personGrantA now personID author body mfwd luActivity grant
personGrant now personID author body mfwd luActivity grant
{-
AP.InviteActivity invite ->
personInviteA now personID author body mfwd luActivity invite
AP.UndoActivity undo ->

294
src/Vervis/Actor2.hs Normal file
View file

@ -0,0 +1,294 @@
{- This file is part of Vervis.
-
- Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
-- For the ugly existential-type trick that avoids Env depending on App
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
-- | Everything I'd put in 'Vervis.Actor' but currently depends on
-- 'Vervis.Foundation', and therefore needs a separate module.
module Vervis.Actor2
( -- * Sending messages to actors
sendActivity
, forwardActivity
)
where
import Control.Concurrent.STM.TVar
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Data.Barbie
import Data.ByteString (ByteString)
import Data.Either
import Data.Hashable
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
import Data.Time.Clock
import Data.Traversable
import Data.Typeable
import Database.Persist.Sql
import GHC.Generics
import UnliftIO.Exception
import Web.Hashids
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as BL
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
import Control.Concurrent.Actor
import Crypto.ActorKey
import Network.FedURI
import Web.Actor
import Web.Actor.Deliver
import Web.Actor.Persist
import qualified Web.ActivityPub as AP
import Vervis.Actor
import Vervis.Data.Actor
import Vervis.FedURI
import Vervis.Foundation
import Vervis.Model hiding (Actor, Message)
import Vervis.Recipient (renderLocalActor, localRecipSieve')
import Vervis.Settings
instance StageWebRoute Env where
type StageRoute Env = Route App
askUrlRenderParams = do
Env _ _ _ _ _ render <- askEnv
case cast render of
Nothing -> error "Env site isn't App"
Just r -> pure r
pageParamName _ = "page"
askLatestInstanceKey :: Act (Maybe (Route App, ActorKey))
askLatestInstanceKey = do
maybeTVar <- asksEnv envActorKeys
for maybeTVar $ \ tvar -> do
(akey1, akey2, new1) <- liftIO $ readTVarIO tvar
return $
if new1
then (ActorKey1R, akey1)
else (ActorKey2R, akey2)
prepareSendIK
:: (Route App, ActorKey)
-> LocalActorBy KeyHashid
-> OutboxItemId
-> AP.Action URIMode
-> Act (AP.Envelope URIMode)
prepareSendIK (keyR, akey) actorByHash itemID action = do
itemHash <- encodeKeyHashid itemID
let sign = actorKeySign akey
actorR = renderLocalActor actorByHash
idR = activityRoute actorByHash itemHash
prepareToSend keyR sign True actorR idR action
prepareSendAK
:: ActorId
-> LocalActorBy KeyHashid
-> OutboxItemId
-> AP.Action URIMode
-> ActDB (AP.Envelope URIMode)
prepareSendAK actorID actorByHash itemID action = do
Entity keyID key <- do
mk <- getBy $ UniqueSigKey actorID
case mk of
Nothing -> error "Actor has no keys!"
Just k -> return k
itemHash <- encodeKeyHashid itemID
keyHash <- encodeKeyHashid keyID
let keyR = stampRoute actorByHash keyHash
sign = actorKeySign $ sigKeyMaterial key
actorR = renderLocalActor actorByHash
idR = activityRoute actorByHash itemHash
prepareToSend keyR sign False actorR idR action
prepareSendP
:: ActorId
-> LocalActorBy KeyHashid
-> OutboxItemId
-> AP.Action URIMode
-> ActDB (AP.Envelope URIMode)
prepareSendP actorID actorByHash itemID action = do
maybeKey <- lift askLatestInstanceKey
case maybeKey of
Nothing -> prepareSendAK actorID actorByHash itemID action
Just key -> lift $ prepareSendIK key actorByHash itemID action
prepareSendH
:: ActorId
-> LocalActorBy KeyHashid
-> OutboxItemId
-> AP.Action URIMode
-> Act (AP.Envelope URIMode)
prepareSendH actorID actorByHash itemID action = do
maybeKey <- askLatestInstanceKey
case maybeKey of
Nothing -> withDB $ prepareSendAK actorID actorByHash itemID action
Just key -> prepareSendIK key actorByHash itemID action
-- | Given a list of local and remote recipients, which may include actors and
-- collections,
--
-- * Insert event to message queues of local actors listed
-- * Insert event to message queues of local members of local collections
-- listed
-- * Launch asynchronously sending activity to remote recipients and remote
-- member of local collections listed
--
-- This function reads the follower sets, remote recipient data and the
-- sender's signing key from the PostgreSQL database. Don't use it inside a
-- database transaction.
sendActivity
:: LocalActorBy Key
-- ^ Activity author and sender
--
-- * Its collections are excluded from requiring an owner, i.e.
-- even if owner is required, this actor's collections will be delivered
-- to, even if this actor isn't addressed
-- * Its inbox is excluded from delivery, even if this actor is listed in
-- the recipient set
-> ActorId
-- ^ Actor key for the sender, for fetching its signing key from the DB
-> RecipientRoutes
-- ^ Local recipients
-> [(Host, NonEmpty LocalURI)]
-- ^ Remote recipients
-> [Host]
-- ^ Instances for which the sender is approving to forward this activity
-> OutboxItemId
-- ^ DB ID of the item in the author's outbox
-> Event
-- ^ Event to send to local live actors
-> AP.Action URIMode
-- ^ Activity to send to remote actors
-> Act ()
sendActivity senderByKey senderActorID localRecips remoteRecips fwdHosts itemID event action = do
moreRemoteRecips <-
let justSender = Just senderByKey
in sendToLocalActors event True justSender justSender localRecips
envelope <- do
senderByHash <- hashLocalActor senderByKey
prepareSendH senderActorID senderByHash itemID action
let (yesFwd, noFwd) =
let remoteRecipsList =
concatMap
(\ ((_, h), rrs) -> NE.toList $ NE.map (decideFwd h . remoteRecipientId) rrs)
moreRemoteRecips
moreList =
concatMap
(\ (h, lus) -> NE.toList $ NE.map (decideFwd h) lus)
remoteRecips
allRemotes = remoteRecipsList ++ moreList
in partitionEithers allRemotes
dt <- asksEnv stageDeliveryTheater
liftIO $ do
sendHttp dt (MethodDeliverLocal envelope True) yesFwd
sendHttp dt (MethodDeliverLocal envelope False) noFwd
where
decideFwd h =
if h `elem` fwdHosts
then Left . ObjURI h
else Right . ObjURI h
prepareForwardIK
:: (Route App, ActorKey)
-> LocalActorBy KeyHashid
-> BL.ByteString
-> ByteString
-> Act (AP.Errand URIMode)
prepareForwardIK (keyR, akey) fwderByHash body proof = do
let sign = actorKeySign akey
fwderR = renderLocalActor fwderByHash
prepareToForward keyR sign True fwderR body proof
prepareForwardAK
:: ActorId
-> LocalActorBy KeyHashid
-> BL.ByteString
-> ByteString
-> ActDB (AP.Errand URIMode)
prepareForwardAK actorID fwderByHash body proof = do
Entity keyID key <- do
mk <- getBy $ UniqueSigKey actorID
case mk of
Nothing -> error "Actor has no keys!"
Just k -> return k
keyHash <- encodeKeyHashid keyID
let keyR = stampRoute fwderByHash keyHash
sign = actorKeySign $ sigKeyMaterial key
fwderR = renderLocalActor fwderByHash
prepareToForward keyR sign False fwderR body proof
prepareForwardP
:: ActorId
-> LocalActorBy KeyHashid
-> BL.ByteString
-> ByteString
-> ActDB (AP.Errand URIMode)
prepareForwardP actorID fwderByHash body proof = do
maybeKey <- lift askLatestInstanceKey
case maybeKey of
Nothing -> prepareForwardAK actorID fwderByHash body proof
Just key -> lift $ prepareForwardIK key fwderByHash body proof
prepareForwardH
:: ActorId
-> LocalActorBy KeyHashid
-> BL.ByteString
-> ByteString
-> Act (AP.Errand URIMode)
prepareForwardH actorID fwderByHash body proof = do
maybeKey <- askLatestInstanceKey
case maybeKey of
Nothing -> withDB $ prepareForwardAK actorID fwderByHash body proof
Just key -> prepareForwardIK key fwderByHash body proof
-- | Given a list of local recipients, which may include actors and
-- collections,
--
-- * Insert event to message queues of actors listed
-- * Insert event to message queues of local members of collections listed
-- * Launch asynchronously sending activity, with a forwarded signature, to
-- remote member of collections listed
--
-- This function reads remote recipient data and the sender's signing key from
-- the PostgreSQL database. Don't use it inside a database transaction.
forwardActivity
:: BL.ByteString
-> RecipientRoutes
-> ByteString
-> ActorId
-> LocalActorBy Key
-> RecipientRoutes
-> Event
-> Act ()
forwardActivity body localRecips sig fwderActorID fwderByKey sieve event = do
remoteRecips <-
let localRecipsFinal = localRecipSieve' sieve False False localRecips
justSender = Just fwderByKey
in sendToLocalActors event False justSender justSender localRecipsFinal
errand <- do
fwderByHash <- hashLocalActor fwderByKey
prepareForwardH fwderActorID fwderByHash body sig
let remoteRecipsList =
concatMap
(\ ((_, h), rrs) -> NE.toList $ NE.map (ObjURI h . remoteRecipientId) rrs)
remoteRecips
dt <- asksEnv stageDeliveryTheater
liftIO $ sendHttp dt (MethodForwardRemote errand) remoteRecipsList

41
src/Vervis/Application.hs
View file

@ -16,6 +16,8 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{- LANGUAGE RankNTypes #-}
module Vervis.Application
( getApplicationDev
, appMain
@ -92,6 +94,8 @@ import Crypto.ActorKey
import Data.KeyFile
import Development.PatchMediaType
import Network.FedURI
import Web.Actor.Deliver
import Yesod.ActivityPub
import Yesod.Hashids
import Yesod.MonadSite
@ -188,9 +192,6 @@ makeFoundation appSettings = do
appActorFetchShare <- newResultShare actorFetchShareAction
-- Temporarily blank actor map, we'll replace it in a moment
--appTheatre <- startTheater (error "logFunc") (error "env") []
appActivities <-
case appInboxDebugReportLength appSettings of
Nothing -> return Nothing
@ -239,15 +240,25 @@ makeFoundation appSettings = do
migrate "Vervis" $ migrateDB hLocal hashidsCtx
migrate "Dvara" $ migrateDvara (Proxy :: Proxy App) schemaBackend
verifyRepoDir
fixRunningDeliveries
--fixRunningDeliveries
deleteUnusedURAs
writePostReceiveHooks
writePostApplyHooks
-- Launch actor threads and fill the actor map
actors <- flip runWorker app $ runSiteDB loadTheatre
let env = Env appSettings pool hashidsCtx
theater <- startTheater logFunc env actors
let delieryStateDir = appDeliveryStateDir appSettings
exists <- doesDirectoryExist delieryStateDir
unless exists $ error $ "delivery-state-dir not found: " ++ delieryStateDir
delivery <- do
micros <- intervalMicros $ appDeliveryRetryBase appSettings
startDeliveryTheater
(sitePostSignedHeaders app) micros appHttpManager logFunc delieryStateDir
let root = renderObjURI $ flip ObjURI topLocalURI $ appInstanceHost appSettings
--render :: Yesod y => y -> Route y -> [(Text, Text)] -> Text
render = yesodRender app root
env = Env appSettings pool hashidsCtx appActorKeys delivery render
actors <- flip runWorker app $ runSiteDB $ loadTheater env
theater <- startTheater logFunc actors
let hostString = T.unpack $ renderAuthority hLocal
writeHookConfig hostString Config
@ -276,6 +287,8 @@ makeFoundation appSettings = do
" [" ++ T.unpack (versionControlSystemName vcs) ++ "]"
reposFromDir = do
dir <- askRepoRootDir
exists <- liftIO $ doesDirectoryExist dir
unless exists $ error $ "repo-dir not found: " ++ dir
subdirs <- liftIO $ sort <$> listDirectory dir
for subdirs $ \ subdir -> do
checkDir $ dir </> subdir
@ -322,7 +335,8 @@ makeFoundation appSettings = do
, T.pack $ show from, " ==> ", T.pack $ show to
]
loadTheatre = concat <$> sequenceA
loadTheater :: Env -> WorkerDB [(LocalActorBy Key, Env, Verse -> Act (Either Text Text, Act (), Next))]
loadTheater env = concat <$> sequenceA
[ selectAll LocalActorPerson personBehavior
, selectAll LocalActorGroup groupBehavior
, selectAll LocalActorRepo repoBehavior
@ -333,10 +347,10 @@ makeFoundation appSettings = do
selectAll
:: PersistRecordBackend a SqlBackend
=> (Key a -> LocalActorBy Key)
-> (UTCTime -> Key a -> Verse -> ExceptT Text Act (Text, Act (), Next))
-> WorkerDB [(LocalActorBy Key, Verse -> Act (Either Text Text, Act (), Next))]
-> (UTCTime -> Key a -> Verse -> ActE (Text, Act (), Next))
-> WorkerDB [(LocalActorBy Key, Env, Verse -> Act (Either Text Text, Act (), Next))]
selectAll makeLocalActor behavior =
map (\ xid -> (makeLocalActor xid, behave behavior xid)) <$>
map (\ xid -> (makeLocalActor xid, env, behave behavior xid)) <$>
selectKeysList [] []
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
@ -396,10 +410,12 @@ actorKeyPeriodicRotator :: App -> Maybe (IO ())
actorKeyPeriodicRotator app =
actorKeyRotator (appActorKeyRotation $ appSettings app) <$> appActorKeys app
{-
deliveryRunner :: App -> IO ()
deliveryRunner app =
let interval = appDeliveryRetryFreq $ appSettings app
in runWorker (periodically interval retryOutboxDelivery) app
-}
sshServer :: App -> IO ()
sshServer foundation =
@ -452,8 +468,11 @@ appMain = do
runWorker fillPerActorKeys foundation
-- Run periodic activity delivery retry runner
-- Disabled because we're using the DeliveryTheater now
{-
when (appFederation $ appSettings foundation) $
forkCheck $ deliveryRunner foundation
-}
-- Run SSH server
forkCheck $ sshServer foundation

1
src/Vervis/Data/Actor.hs
View file

@ -40,6 +40,7 @@ import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import Network.FedURI
import Web.Actor
import Yesod.ActivityPub
import Yesod.Actor
import Yesod.FedURI

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

@ -40,18 +40,22 @@ import Data.Text (Text)
import Database.Persist.Types
import GHC.Generics
import Control.Concurrent.Actor
import Network.FedURI
import Web.Actor
import Web.Actor.Persist
import Yesod.ActivityPub
import Yesod.Actor
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite
import Yesod.MonadSite (asksSite)
import qualified Web.ActivityPub as AP
import Control.Monad.Trans.Except.Local
import Vervis.Access
import Vervis.Actor
import Vervis.Data.Actor
import Vervis.FedURI
import Vervis.Foundation
@ -75,10 +79,17 @@ unhashGrantRecipPure ctx = f
f (GrantRecipPerson p) =
GrantRecipPerson <$> decodeKeyHashidPure ctx p
unhashGrantRecip resource = do
unhashGrantRecipOld resource = do
ctx <- asksSite siteHashidsContext
return $ unhashGrantRecipPure ctx resource
unhashGrantRecip resource = do
ctx <- asksEnv stageHashidsContext
return $ unhashGrantRecipPure ctx resource
unhashGrantRecipEOld resource e =
ExceptT $ maybe (Left e) Right <$> unhashGrantRecipOld resource
unhashGrantRecipE resource e =
ExceptT $ maybe (Left e) Right <$> unhashGrantRecip resource
@ -122,7 +133,7 @@ parseInvite sender (AP.Invite instrument object target) = do
(parseGrantRecip route)
"Not a grant recipient route"
recipKey <-
unhashGrantRecipE
unhashGrantRecipEOld
recipHash
"Contains invalid hashid"
case recipKey of
@ -146,7 +157,7 @@ parseJoin (AP.Join instrument object) = do
parseGrant
:: AP.Grant URIMode
-> ExceptT Text Handler
-> ActE
( Either (GrantResourceBy Key) FedURI
, Either (GrantRecipBy Key) FedURI
)
@ -159,7 +170,7 @@ parseGrant (AP.Grant object context target) = do
verifyRole (Right _) =
throwE "ForgeFed Admin is the only role allowed currently"
parseContext u@(ObjURI h lu) = do
hl <- hostIsLocalOld h
hl <- hostIsLocal h
if hl
then Left <$> do
route <-
@ -170,7 +181,7 @@ parseGrant (AP.Grant object context target) = do
fromMaybeE
(parseGrantResource route)
"Grant context isn't a shared resource route"
unhashGrantResourceE
unhashGrantResourceE'
resourceHash
"Grant resource contains invalid hashid"
else pure $ Right u
@ -180,7 +191,7 @@ parseGrant (AP.Grant object context target) = do
parseGrantResource (LoomR l) = Just $ GrantResourceLoom l
parseGrantResource _ = Nothing
parseTarget u@(ObjURI h lu) = do
hl <- hostIsLocalOld h
hl <- hostIsLocal h
if hl
then Left <$> do
route <-

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

@ -33,6 +33,7 @@ import Data.Time.Clock
import Control.Concurrent.Actor
import Network.FedURI
import Web.Actor
import Web.Actor.Persist
import Web.Text
import Yesod.ActivityPub
@ -46,6 +47,7 @@ import qualified Yesod.Hashids as YH
import Control.Monad.Trans.Except.Local
import Vervis.Actor
import Vervis.Actor2
import Vervis.Data.Actor
import Vervis.FedURI
import Vervis.Foundation

2
src/Vervis/Federation/Auth.hs
View file

@ -95,7 +95,7 @@ import Data.Tuple.Local
import Database.Persist.Local
import Yesod.Persist.Local
import Vervis.Actor
import Vervis.Actor (RemoteAuthor (..), ActivityBody (..))
import Vervis.ActivityPub
import Vervis.Data.Actor
import Vervis.FedURI

168
src/Vervis/Federation/Collab.hs
View file

@ -16,8 +16,8 @@
{-# LANGUAGE RankNTypes #-}
module Vervis.Federation.Collab
( personInviteF
, topicInviteF
( --personInviteF
topicInviteF
, repoJoinF
, deckJoinF
@ -27,7 +27,7 @@ module Vervis.Federation.Collab
, deckAcceptF
, loomAcceptF
, personGrantF
--, personGrantF
)
where
@ -76,7 +76,7 @@ import Yesod.Persist.Local
import Vervis.Access
import Vervis.ActivityPub
import Vervis.Actor
import Vervis.Actor (RemoteAuthor (..), ActivityBody (..))
import Vervis.Data.Actor
import Vervis.Data.Collab
import Vervis.Web.Delivery
@ -90,100 +90,6 @@ import Vervis.Persist.Collab
import Vervis.Recipient
import Vervis.RemoteActorStore
personInviteF
:: UTCTime
-> KeyHashid Person
-> RemoteAuthor
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Invite URIMode
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
personInviteF now recipHash author body mfwd luInvite invite = (,Nothing) <$> do
-- Check input
(resourceAndCap, recipient) <- do
-- Check the invite-specific data
(resource, recip) <-
parseInvite (Right $ remoteAuthorURI author) invite
-- Verify the capability URI is one of:
-- * Outbox item URI of a local actor, i.e. a local activity
-- * A remote URI
capability <- do
let muCap = AP.activityCapability $ actbActivity body
uCap <- fromMaybeE muCap "No capability provided"
nameExceptT "Invite capability" $ parseActivityURI uCap
-- Verify that capability is either a local activity of a local
-- resource, or both resource and capability are of the same remote
-- instance
(,recip) <$> case (resource, capability) of
(Left r, Left (actor, _, item)) -> do
unless (grantResourceLocalActor r == actor) $
throwE "Local capability belongs to actor that isn't the resource"
return $ Left (r, item)
(Left _, Right _) ->
throwE "Remote capability obviously doesn't belong to local resource"
(Right _, Left _) ->
throwE "Local capability obviously doesn't belong to remote resource"
(Right (ObjURI h r), Right (ObjURI h' c)) -> do
unless (h == h') $
throwE "Capability and resource are on different remote instances"
return $ Right (ObjURI h r, c)
-- Find recipient person in DB, returning 404 if doesn't exist because
-- we're in the person's inbox post handler
personRecipID <- decodeKeyHashid404 recipHash
mhttp <- runDBExcept $ do
(personRecip, actorRecip) <- lift $ do
p <- get404 personRecipID
(p,) <$> getJust (personActor p)
mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luInvite True
for mractid $ \ inviteID -> do
-- If resource is local, find it in our DB
_resourceDB <-
bitraverse
(flip getGrantResource "Invite local target not found in DB" . fst)
pure
resourceAndCap
-- If recipient is local, find it in our DB
_recipientDB <-
bitraverse
(flip getGrantRecip "Invite local object not found in DB")
pure
recipient
-- Forward the Invite activity to relevant local stages, and
-- schedule delivery for unavailable remote members of them
lift $ for mfwd $ \ (localRecips, sig) -> do
let inviteeIsRecip =
case recipient of
Left (GrantRecipPerson p) -> p == personRecipID
_ -> False
sieve =
if inviteeIsRecip
then makeRecipientSet [] [LocalStagePersonFollowers recipHash]
else makeRecipientSet [] []
forwardActivityDB
(actbBL body) localRecips sig (personActor personRecip)
(LocalActorPerson recipHash) sieve inviteID
-- Launch asynchronous HTTP forwarding of the Invite activity
case mhttp of
Nothing -> return "I already have this activity in my inbox, doing nothing"
Just maybeForwardHttpInvite -> do
for_ maybeForwardHttpInvite $
forkWorker "personInviteF inbox-forwarding"
return $
case maybeForwardHttpInvite of
Nothing -> "Inserted to inbox, no inbox-forwarding to do"
Just _ -> "Inserted to inbox and ran inbox-forwarding of the Invite"
topicInviteF
:: UTCTime
-> GrantResourceBy KeyHashid
@ -681,69 +587,3 @@ loomAcceptF
-> AP.Accept URIMode
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
loomAcceptF = topicAcceptF loomActor GrantResourceLoom
personGrantF
:: UTCTime
-> KeyHashid Person
-> RemoteAuthor
-> ActivityBody
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Grant URIMode
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
personGrantF now recipHash author body mfwd luGrant grant = (,Nothing) <$> do
-- Check input
(_remoteResource, recipient) <- do
(resource, recip) <- parseGrant grant
let u@(ObjURI h _) = remoteAuthorURI author
resourceURI <-
case resource of
Right (ObjURI h' r) | h == h' -> return (u, r)
_ -> throwE "Grant resource and Grant author are from different instances"
when (recip == Right u) $
throwE "Grant sender and target are the same remote actor"
return (resourceURI, recip)
-- Find recipient person in DB, returning 404 if doesn't exist because
-- we're in the person's inbox post handler
personRecipID <- decodeKeyHashid404 recipHash
mhttp <- runDBExcept $ do
(personRecip, actorRecip) <- lift $ do
p <- get404 personRecipID
(p,) <$> getJust (personActor p)
mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luGrant True
for mractid $ \ grantID -> do
-- If recipient is local, find it in our DB
_recipientDB <-
bitraverse
(flip getGrantRecip "Grant local target not found in DB")
pure
recipient
-- Forward the Grant activity to relevant local stages, and
-- schedule delivery for unavailable remote members of them
lift $ for mfwd $ \ (localRecips, sig) -> do
let targetIsRecip =
case recipient of
Left (GrantRecipPerson p) -> p == personRecipID
_ -> False
sieve =
if targetIsRecip
then makeRecipientSet [] [LocalStagePersonFollowers recipHash]
else makeRecipientSet [] []
forwardActivityDB
(actbBL body) localRecips sig (personActor personRecip)
(LocalActorPerson recipHash) sieve grantID
-- Launch asynchronous HTTP forwarding of the Grant activity
case mhttp of
Nothing -> return "I already have this activity in my inbox, doing nothing"
Just mhttpFwd -> do
for_ mhttpFwd $ forkWorker "personGrantF inbox-forwarding"
return $
case mhttpFwd of
Nothing -> "Inserted to inbox, no inbox-forwarding to do"
Just _ -> "Inserted to inbox and ran inbox-forwarding of the Grant"

3
src/Vervis/Foundation.hs
View file

@ -155,9 +155,6 @@ type TicketDeckKeyHashid = KeyHashid TicketDeck
type TicketLoomKeyHashid = KeyHashid TicketLoom
type SigKeyKeyHashid = KeyHashid SigKey
instance StageYesod Env where
type StageSite Env = App
-- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see:
-- http://www.yesodweb.com/book/routing-and-handlers

39
src/Vervis/Recipient.hs
View file

@ -131,7 +131,14 @@ import qualified Web.ActivityPub as AP
import Data.List.Local
import Data.List.NonEmpty.Local
import Vervis.Actor
import Vervis.Actor hiding
( getHashLocalActor
, hashLocalActor
, unhashLocalActor
, unhashLocalActorF
, unhashLocalActorM
, unhashLocalActorE
)
import Vervis.FedURI
import Vervis.Foundation
import Vervis.Model
@ -248,16 +255,6 @@ localActorFollowers (LocalActorLoom l) = LocalStageLoomFollowers l
-- Converting between KeyHashid, Key, Identity and Entity
-------------------------------------------------------------------------------
hashLocalActorPure
:: HashidsContext -> LocalActorBy Key -> LocalActorBy KeyHashid
hashLocalActorPure ctx = f
where
f (LocalActorPerson p) = LocalActorPerson $ encodeKeyHashidPure ctx p
f (LocalActorGroup g) = LocalActorGroup $ encodeKeyHashidPure ctx g
f (LocalActorRepo r) = LocalActorRepo $ encodeKeyHashidPure ctx r
f (LocalActorDeck d) = LocalActorDeck $ encodeKeyHashidPure ctx d
f (LocalActorLoom l) = LocalActorLoom $ encodeKeyHashidPure ctx l
getHashLocalActor
:: (MonadSite m, YesodHashids (SiteEnv m))
=> m (LocalActorBy Key -> LocalActorBy KeyHashid)
@ -272,16 +269,6 @@ hashLocalActor actor = do
hash <- getHashLocalActor
return $ hash actor
unhashLocalActorPure
:: HashidsContext -> LocalActorBy KeyHashid -> Maybe (LocalActorBy Key)
unhashLocalActorPure ctx = f
where
f (LocalActorPerson p) = LocalActorPerson <$> decodeKeyHashidPure ctx p
f (LocalActorGroup g) = LocalActorGroup <$> decodeKeyHashidPure ctx g
f (LocalActorRepo r) = LocalActorRepo <$> decodeKeyHashidPure ctx r
f (LocalActorDeck d) = LocalActorDeck <$> decodeKeyHashidPure ctx d
f (LocalActorLoom l) = LocalActorLoom <$> decodeKeyHashidPure ctx l
unhashLocalActor
:: (MonadSite m, YesodHashids (SiteEnv m))
=> LocalActorBy KeyHashid -> m (Maybe (LocalActorBy Key))
@ -305,16 +292,6 @@ unhashLocalActorE
unhashLocalActorE actor e =
ExceptT $ maybe (Left e) Right <$> unhashLocalActor actor
unhashLocalActor404
:: ( MonadSite m
, MonadHandler m
, HandlerSite m ~ SiteEnv m
, YesodHashids (HandlerSite m)
)
=> LocalActorBy KeyHashid
-> m (LocalActorBy Key)
unhashLocalActor404 actor = maybe notFound return =<< unhashLocalActor actor
hashLocalStagePure
:: HashidsContext -> LocalStageBy Key -> LocalStageBy KeyHashid
hashLocalStagePure ctx = f

11
src/Vervis/Settings.hs
View file

@ -90,6 +90,8 @@ data AppSettings = AppSettings
-- | Maximal number of keys (personal keys or usage of shared keys) to
-- remember cached in our database per remote actor.
, appMaxActorKeys :: Maybe Int
-- | Path of the directory in which DeliveryTheater actor state is stored
, appDeliveryStateDir :: FilePath
-- | The instance's host (e.g. \"dev.angeley.es\"). Used for determining
-- which requests are remote and which are for this instance, and for
-- generating URLs. The database relies on this value, and you shouldn't
@ -183,9 +185,11 @@ data AppSettings = AppSettings
-- we periodically retry to deliver them activities. After that period of
-- time, we stop trying to deliver and we remove them from follower lists
-- of local actors.
--
-- TODO this probably isn't working anymore since the switch to DeliveryTheater
, appDropDeliveryAfter :: NominalDiffTime
-- | How much time to wait between retries of failed deliveries.
, appDeliveryRetryFreq :: TimeInterval
-- | Base time to wait before first retry of a failed delivery.
, appDeliveryRetryBase :: TimeInterval
-- | How many activities to remember in the debug report list, showing
-- latest activities received in local inboxes and the result of their
-- processing. 'Nothing' means disable the report page entirely.
@ -210,6 +214,7 @@ instance FromJSON AppSettings where
appDatabaseConf <- o .: "database"
appMaxInstanceKeys <- o .:? "max-instance-keys"
appMaxActorKeys <- o .:? "max-actor-keys"
appDeliveryStateDir <- o .: "delivery-state-dir"
port <- o .: "http-port"
appInstanceHost <- do
h <- o .: "instance-host"
@ -252,7 +257,7 @@ instance FromJSON AppSettings where
appHashidsSaltFile <- o .: "hashids-salt-file"
appRejectOnMaxKeys <- o .: "reject-on-max-keys"
appDropDeliveryAfter <- ndt <$> o .: "drop-delivery-after"
appDeliveryRetryFreq <- interval <$> o .: "retry-delivery-every"
appDeliveryRetryBase <- interval <$> o .: "retry-delivery-base"
appInboxDebugReportLength <- o .:? "activity-debug-reports"
appInstances <- o .:? "instances" .!= []

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

@ -95,7 +95,7 @@ import Yesod.Persist.Local
import qualified Data.Aeson.Encode.Pretty.ToEncoding as P
import qualified Web.ActivityPub as AP
import Vervis.Actor
import Vervis.Actor (RemoteAuthor (..), ActivityBody (..), VerseRemote (..), Event (..))
import Vervis.ActivityPub
import Vervis.API
import Vervis.Data.Actor

531
src/Vervis/Web/Delivery.hs
View file

@ -15,12 +15,8 @@
-}
module Vervis.Web.Delivery
( --prepareSendP
--, prepareSendH
--, prepareResendP
( -- prepareResendP
--, prepareResendH
--, prepareForwardP
--, prepareForwardH
--, forwardRemoteDB
--, forwardRemoteHttp
@ -29,12 +25,10 @@ module Vervis.Web.Delivery
--, deliverLocal'
--, deliverLocal
--, insertRemoteActivityToLocalInboxes
fixRunningDeliveries
, retryOutboxDelivery
--fixRunningDeliveries
--, retryOutboxDelivery
, deliverActivityDB_Live
, deliverActivityDB
, forwardActivityDB_Live
deliverActivityDB
, forwardActivityDB
)
where
@ -89,7 +83,7 @@ import Data.Maybe.Local
import Data.Tuple.Local
import Database.Persist.Local
import Vervis.Actor
import Vervis.Actor (Event)
import Vervis.ActivityPub
import Vervis.Data.Actor
import Vervis.FedURI
@ -100,80 +94,6 @@ import Vervis.Recipient
import Vervis.RemoteActorStore
import Vervis.Settings
askLatestInstanceKey
:: (MonadSite m, SiteEnv m ~ App) => m (Maybe (Route App, ActorKey))
askLatestInstanceKey = do
maybeTVar <- asksSite appActorKeys
for maybeTVar $ \ tvar -> do
(akey1, akey2, new1) <- liftIO $ readTVarIO tvar
return $
if new1
then (ActorKey1R, akey1)
else (ActorKey2R, akey2)
prepareSendIK
:: (MonadSite m, SiteEnv m ~ App)
=> (Route App, ActorKey)
-> LocalActorBy KeyHashid
-> OutboxItemId
-> AP.Action URIMode
-> m (AP.Envelope URIMode)
prepareSendIK (keyR, akey) actorByHash itemID action = do
itemHash <- encodeKeyHashid itemID
let sign = actorKeySign akey
actorR = renderLocalActor actorByHash
idR = activityRoute actorByHash itemHash
prepareToSend keyR sign True actorR idR action
prepareSendAK
:: (MonadSite m, SiteEnv m ~ App)
=> ActorId
-> LocalActorBy KeyHashid
-> OutboxItemId
-> AP.Action URIMode
-> ReaderT SqlBackend m (AP.Envelope URIMode)
prepareSendAK actorID actorByHash itemID action = do
Entity keyID key <- do
mk <- getBy $ UniqueSigKey actorID
case mk of
Nothing -> error "Actor has no keys!"
Just k -> return k
itemHash <- encodeKeyHashid itemID
keyHash <- encodeKeyHashid keyID
let keyR = stampRoute actorByHash keyHash
sign = actorKeySign $ sigKeyMaterial key
actorR = renderLocalActor actorByHash
idR = activityRoute actorByHash itemHash
prepareToSend keyR sign False actorR idR action
prepareSendP
:: (MonadSite m, SiteEnv m ~ App)
=> ActorId
-> LocalActorBy KeyHashid
-> OutboxItemId
-> AP.Action URIMode
-> ReaderT SqlBackend m (AP.Envelope URIMode)
prepareSendP actorID actorByHash itemID action = do
maybeKey <- lift askLatestInstanceKey
case maybeKey of
Nothing -> prepareSendAK actorID actorByHash itemID action
Just key -> lift $ prepareSendIK key actorByHash itemID action
{-
prepareSendH
:: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App)
=> ActorId
-> LocalActorBy KeyHashid
-> OutboxItemId
-> AP.Action URIMode
-> m (AP.Envelope URIMode)
prepareSendH actorID actorByHash itemID action = do
maybeKey <- askLatestInstanceKey
case maybeKey of
Nothing -> runSiteDB $ prepareSendAK actorID actorByHash itemID action
Just key -> prepareSendIK key actorByHash itemID action
-}
prepareResendIK
:: (MonadSite m, SiteEnv m ~ App)
=> (Route App, ActorKey)
@ -216,6 +136,7 @@ prepareResendP actorID holderByHash body = do
Just key -> lift $ prepareResendIK key holderByHash body
-}
{-
prepareResendH
:: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App)
=> ActorId
@ -228,63 +149,6 @@ prepareResendH actorID holderByHash body = do
Nothing -> runSiteDB $ prepareResendAK actorID holderByHash body
Just key -> prepareResendIK key holderByHash body
prepareForwardIK
:: (MonadSite m, SiteEnv m ~ App)
=> (Route App, ActorKey)
-> LocalActorBy KeyHashid
-> BL.ByteString
-> ByteString
-> m (AP.Errand URIMode)
prepareForwardIK (keyR, akey) fwderByHash body proof = do
let sign = actorKeySign akey
fwderR = renderLocalActor fwderByHash
prepareToForward keyR sign True fwderR body proof
prepareForwardAK
:: (MonadSite m, SiteEnv m ~ App)
=> ActorId
-> LocalActorBy KeyHashid
-> BL.ByteString
-> ByteString
-> ReaderT SqlBackend m (AP.Errand URIMode)
prepareForwardAK actorID fwderByHash body proof = do
Entity keyID key <- do
mk <- getBy $ UniqueSigKey actorID
case mk of
Nothing -> error "Actor has no keys!"
Just k -> return k
keyHash <- encodeKeyHashid keyID
let keyR = stampRoute fwderByHash keyHash
sign = actorKeySign $ sigKeyMaterial key
fwderR = renderLocalActor fwderByHash
prepareToForward keyR sign False fwderR body proof
prepareForwardP
:: (MonadSite m, SiteEnv m ~ App)
=> ActorId
-> LocalActorBy KeyHashid
-> BL.ByteString
-> ByteString
-> ReaderT SqlBackend m (AP.Errand URIMode)
prepareForwardP actorID fwderByHash body proof = do
maybeKey <- askLatestInstanceKey
case maybeKey of
Nothing -> prepareForwardAK actorID fwderByHash body proof
Just key -> lift $ prepareForwardIK key fwderByHash body proof
prepareForwardH
:: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App)
=> ActorId
-> LocalActorBy KeyHashid
-> BL.ByteString
-> ByteString
-> m (AP.Errand URIMode)
prepareForwardH actorID fwderByHash body proof = do
maybeKey <- askLatestInstanceKey
case maybeKey of
Nothing -> runSiteDB $ prepareForwardAK actorID fwderByHash body proof
Just key -> prepareForwardIK key fwderByHash body proof
forwardRemoteDB
:: MonadIO m
=> BL.ByteString
@ -562,325 +426,29 @@ deliverRemoteHttp hContexts obid envelope (fetched, unfetched, unknown) = do
-- | Given a list of local recipients, which may include actors and
-- collections,
--
-- * Insert activity to inboxes of actors
-- * If collections are listed, insert activity to the local members and return
-- the remote members
--
-- NOTE: This functions is in a transition process! Instead of adding items to
-- local inboxes, it will send the items to live actors. At the moment, the
-- transition status is:
--
-- * For person actors, send to live actors
-- * For all other types, insert to inboxes
insertActivityToLocalInboxes
:: ( MonadSite m
, YesodHashids (SiteEnv m)
, SiteEnv m ~ App
, PersistRecordBackend record SqlBackend
)
=> Event
-- ^ Event to send to local live actors
-> (InboxId -> InboxItemId -> record)
-- ^ Database record to insert as a new inbox item to each inbox
-> Bool
-- ^ Whether to deliver to collection only if owner actor is addressed
-> Maybe LocalActor
-- ^ An actor whose collections are excluded from requiring an owner, i.e.
-- even if owner is required, this actor's collections will be delivered
-- to, even if this actor isn't addressed. This is meant to be the
-- activity's author.
-> Maybe ActorId
-- ^ A un actor whose inbox to exclude from delivery, even if this actor is
-- listed in the recipient set. This is meant to be the activity's
-- author.
-> RecipientRoutes
-> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)]
insertActivityToLocalInboxes event makeInboxItem requireOwner mauthor maidAuthor recips = do
-- Unhash actor and work item hashids
people <- unhashKeys $ recipPeople recips
groups <- unhashKeys $ recipGroups recips
repos <- unhashKeys $ recipRepos recips
decksAndTickets <- do
decks <- unhashKeys $ recipDecks recips
for decks $ \ (deckID, (DeckFamilyRoutes deck tickets)) ->
(deckID,) . (deck,) <$> unhashKeys tickets
loomsAndCloths <- do
looms <- unhashKeys $ recipLooms recips
for looms $ \ (loomID, (LoomFamilyRoutes loom cloths)) ->
(loomID,) . (loom,) <$> unhashKeys cloths
-- Grab local actor sets whose stages are allowed for delivery
isAuthor <- getIsAuthor
let allowStages'
:: (famili -> routes)
-> (routes -> Bool)
-> (Key record -> LocalActorBy Key)
-> (Key record, famili)
-> Bool
allowStages' = allowStages isAuthor
peopleForStages =
filter (allowStages' id routePerson LocalActorPerson) people
groupsForStages =
filter (allowStages' id routeGroup LocalActorGroup) groups
reposForStages =
filter (allowStages' id routeRepo LocalActorRepo) repos
decksAndTicketsForStages =
filter (allowStages' fst routeDeck LocalActorDeck) decksAndTickets
loomsAndClothsForStages =
filter (allowStages' fst routeLoom LocalActorLoom) loomsAndCloths
-- Grab local actors being addressed
let personIDsForSelf =
[ key | (key, routes) <- people, routePerson routes ]
groupIDsForSelf =
[ key | (key, routes) <- groups, routeGroup routes ]
repoIDsForSelf =
[ key | (key, routes) <- repos, routeRepo routes ]
deckIDsForSelf =
[ key | (key, (routes, _)) <- decksAndTickets, routeDeck routes ]
loomIDsForSelf =
[ key | (key, (routes, _)) <- loomsAndCloths, routeLoom routes ]
-- Grab local actors whose followers are going to be delivered to
let personIDsForFollowers =
[ key | (key, routes) <- peopleForStages, routePersonFollowers routes ]
groupIDsForFollowers =
[ key | (key, routes) <- groupsForStages, routeGroupFollowers routes ]
repoIDsForFollowers =
[ key | (key, routes) <- reposForStages, routeRepoFollowers routes ]
deckIDsForFollowers =
[ key | (key, (routes, _)) <- decksAndTicketsForStages, routeDeckFollowers routes ]
loomIDsForFollowers =
[ key | (key, (routes, _)) <- loomsAndClothsForStages, routeLoomFollowers routes ]
-- Grab tickets and cloths whose followers are going to be delivered to
let ticketSetsForFollowers =
mapMaybe
(\ (deckID, (_, tickets)) -> (deckID,) <$>
NE.nonEmpty
[ ticketDeckID | (ticketDeckID, routes) <- tickets
, routeTicketFollowers routes
]
)
decksAndTicketsForStages
clothSetsForFollowers =
mapMaybe
(\ (loomID, (_, cloths)) -> (loomID,) <$>
NE.nonEmpty
[ ticketLoomID | (ticketLoomID, routes) <- cloths
, routeClothFollowers routes
]
)
loomsAndClothsForStages
-- Get addressed Actor IDs from DB
-- Except for Person actors, we'll send to them via actor system
actorIDsForSelf <- orderedUnion <$> sequenceA
[ selectActorIDsOrdered groupActor GroupActor groupIDsForSelf
, selectActorIDsOrdered repoActor RepoActor repoIDsForSelf
, selectActorIDsOrdered deckActor DeckActor deckIDsForSelf
, selectActorIDsOrdered loomActor LoomActor loomIDsForSelf
]
-- Get actor and work item FollowerSet IDs from DB
followerSetIDs <- do
actorIDs <- concat <$> sequenceA
[ selectActorIDs personActor personIDsForFollowers
, selectActorIDs groupActor groupIDsForFollowers
, selectActorIDs repoActor repoIDsForFollowers
, selectActorIDs deckActor deckIDsForFollowers
, selectActorIDs loomActor loomIDsForFollowers
]
ticketIDs <-
concat <$>
((++)
<$> traverse
(selectTicketIDs ticketDeckTicket TicketDeckDeck)
ticketSetsForFollowers
<*> traverse
(selectTicketIDs ticketLoomTicket TicketLoomLoom)
clothSetsForFollowers
)
(++)
<$> (map (actorFollowers . entityVal) <$>
selectList [ActorId <-. actorIDs] []
)
<*> (map (ticketFollowers . entityVal) <$>
selectList [TicketId <-. ticketIDs] []
)
-- Get the local and remote followers of the follower sets from DB
localFollowersDB <-
fmap (map E.unValue) $
E.select $ E.from $ \ (f `E.LeftOuterJoin` p) -> do
E.on $ E.just (f E.^. FollowActor) E.==. p E.?. PersonActor
E.where_ $
f E.^. FollowTarget `E.in_` E.valList followerSetIDs E.&&.
E.isNothing (p E.?. PersonId)
E.orderBy [E.asc $ f E.^. FollowActor]
return $ f E.^. FollowActor
localFollowersLivePersonIDs <-
fmap (map E.unValue) $
E.select $ E.from $ \ (f `E.InnerJoin` p) -> do
E.on $ f E.^. FollowActor E.==. p E.^. PersonActor
E.where_ $ f E.^. FollowTarget `E.in_` E.valList followerSetIDs
return $ p E.^. PersonId
remoteFollowers <- getRemoteFollowers followerSetIDs
-- Insert inbox items to all local recipients, i.e. the local actors
-- directly addressed or listed in a local stage addressed
let localRecipients =
let allLocal = LO.union localFollowersDB actorIDsForSelf
in case maidAuthor of
Nothing -> allLocal
Just actorID -> LO.minus' allLocal [actorID]
inboxIDs <-
map (actorInbox . entityVal) <$>
selectList [ActorId <-. localRecipients] []
now <- liftIO getCurrentTime
inboxItemIDs <- insertMany $ replicate (length inboxIDs) $ InboxItem True now
insertMany_ $ zipWith makeInboxItem inboxIDs inboxItemIDs
-- Insert activity to message queues of live actors
let liveRecips =
HS.fromList $ map LocalActorPerson $
localFollowersLivePersonIDs ++ personIDsForSelf
lift $ do
theater <- asksSite appTheater
liftIO $ sendManyIO theater liveRecips $ Left event
-- Return remote followers, to whom we need to deliver via HTTP
return remoteFollowers
where
orderedUnion = foldl' LO.union []
unhashKeys
:: ( MonadSite m
, YesodHashids (SiteEnv m)
, ToBackendKey SqlBackend record
)
=> [(KeyHashid record, routes)]
-> m [(Key record, routes)]
unhashKeys actorSets = do
unhash <- decodeKeyHashidPure <$> asksSite siteHashidsContext
return $ mapMaybe (unhashKey unhash) actorSets
where
unhashKey unhash (hash, famili) = (,famili) <$> unhash hash
getIsAuthor =
case mauthor of
Nothing -> pure $ const False
Just author -> maybe (const False) (==) <$> unhashLocalActor author
allowStages
:: (LocalActorBy Key -> Bool)
-> (famili -> routes)
-> (routes -> Bool)
-> (Key record -> LocalActorBy Key)
-> (Key record, famili)
-> Bool
allowStages isAuthor familyActor routeActor makeActor (actorID, famili)
= routeActor (familyActor famili)
|| not requireOwner
|| isAuthor (makeActor actorID)
selectActorIDs
:: (MonadIO m, PersistRecordBackend record SqlBackend)
=> (record -> ActorId)
-> [Key record]
-> ReaderT SqlBackend m [ActorId]
selectActorIDs grabActor ids =
map (grabActor . entityVal) <$> selectList [persistIdField <-. ids] []
selectActorIDsOrdered
:: (MonadIO m, PersistRecordBackend record SqlBackend)
=> (record -> ActorId)
-> EntityField record ActorId
-> [Key record]
-> ReaderT SqlBackend m [ActorId]
selectActorIDsOrdered grabActor actorField ids =
map (grabActor . entityVal) <$> selectList [persistIdField <-. ids] [Asc actorField]
selectTicketIDs
:: ( MonadIO m
, PersistRecordBackend tracker SqlBackend
, PersistRecordBackend item SqlBackend
)
=> (item -> TicketId)
-> EntityField item (Key tracker)
-> (Key tracker, NonEmpty (Key item))
-> ReaderT SqlBackend m [TicketId]
selectTicketIDs grabTicket trackerField (trackerID, workItemIDs) = do
maybeTracker <- get trackerID
case maybeTracker of
Nothing -> pure []
Just _ ->
map (grabTicket . entityVal) <$>
selectList [persistIdField <-. NE.toList workItemIDs, trackerField ==. trackerID] []
getRemoteFollowers
:: MonadIO m
=> [FollowerSetId]
-> ReaderT SqlBackend m
[((InstanceId, Host), NonEmpty RemoteRecipient)]
getRemoteFollowers fsids =
fmap groupRemotes $
E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId
E.where_ $ rf E.^. RemoteFollowTarget `E.in_` E.valList fsids
E.orderBy [E.asc $ i E.^. InstanceId, E.asc $ ra E.^. RemoteActorId]
return
( i E.^. InstanceId
, i E.^. InstanceHost
, ra E.^. RemoteActorId
, ro E.^. RemoteObjectIdent
, ra E.^. RemoteActorInbox
, ra E.^. RemoteActorErrorSince
)
where
groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples
where
toTuples (E.Value iid, E.Value h, E.Value raid, E.Value luA, E.Value luI, E.Value ms) = ((iid, h), RemoteRecipient raid luA luI ms)
-- | Given a list of local recipients, which may include actors and
-- collections,
--
-- * Insert activity to inboxes of actors
-- * If collections are listed, insert activity to the local members and return
-- the remote members
--
-- NOTE transition to live actors
-- * Insert activity to message queues of live local actors
-- * If collections are listed, insert activity to message queues of local
-- members and return the remote members
deliverLocal'
:: (MonadSite m, YesodHashids (SiteEnv m), SiteEnv m ~ App)
=> Bool -- ^ Whether to deliver to collection only if owner actor is addressed
-> LocalActor
-> ActorId
-> OutboxItemId
-> LocalActorBy Key
-> LocalActorBy Key
-> Event
-> RecipientRoutes
-> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)]
deliverLocal' requireOwner author aidAuthor obiid event =
insertActivityToLocalInboxes event makeItem requireOwner (Just author) (Just aidAuthor)
where
makeItem ibid ibiid = InboxItemLocal ibid obiid ibiid
deliverLocal' requireOwner author aidAuthor event =
insertActivityToLocalInboxes event requireOwner (Just author) (Just aidAuthor)
-- | Given a list of local recipients, which may include actors and
-- collections,
--
-- * Insert activity to inboxes of actors
-- * If the author's follower collection is listed, insert activity to the
-- local members and return the remote members
-- * Insert activity to queues of actors
-- * If the author's follower collection is listed, insert activity to queues
-- of the local members and return the remote members
-- * Ignore other collections
--
-- NOTE transition to live actors
deliverLocal
:: KeyHashid Person
-> ActorId
-> OutboxItemId
:: PersonId
-> Event
-> RecipientRoutes
-> AppDB
@ -888,25 +456,24 @@ deliverLocal
, NonEmpty RemoteRecipient
)
]
deliverLocal authorHash aidAuthor obiid event
= deliverLocal' True (LocalActorPerson authorHash) aidAuthor obiid event
. localRecipSieve sieve True
where
sieve = RecipientRoutes [(authorHash, PersonRoutes False True)] [] [] [] []
deliverLocal authorID event recips = do
authorHash <- encodeKeyHashid authorID
let sieve =
RecipientRoutes [(authorHash, PersonRoutes False True)] [] [] [] []
author = LocalActorPerson authorID
deliverLocal' True author author event $ localRecipSieve sieve True recips
-- NOTE transition to live actors
insertRemoteActivityToLocalInboxes
:: (MonadSite m, YesodHashids (SiteEnv m), SiteEnv m ~ App)
=> Bool
-> RemoteActivityId
-> Event
-> RecipientRoutes
-> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)]
insertRemoteActivityToLocalInboxes requireOwner ractid event =
insertActivityToLocalInboxes event makeItem requireOwner Nothing Nothing
where
makeItem ibid ibiid = InboxItemRemote ibid ractid ibiid
insertRemoteActivityToLocalInboxes requireOwner event =
insertActivityToLocalInboxes event requireOwner Nothing Nothing
-}
{-
fixRunningDeliveries :: (MonadIO m, MonadLogger m, IsSqlBackend backend) => ReaderT backend m ()
fixRunningDeliveries = do
c <- updateWhereCount [UnlinkedDeliveryRunning ==. True] [UnlinkedDeliveryRunning =. False]
@ -927,7 +494,9 @@ fixRunningDeliveries = do
, T.pack (show c'')
, " forwarding deliveries"
]
-}
{-
relevant dropAfter now since = addUTCTime dropAfter since > now
fork action = do
@ -977,7 +546,7 @@ retryUnlinkedDelivery = do
unlinked <- traverse adaptUnlinked unlinked'
-- Split into found (recipient has been reached) and lonely (recipient
-- hasn't been reached
-- hasn't been reached)
let (found, lonely) = partitionMaybes unlinked
-- Turn the found ones into linked deliveries
@ -1307,9 +876,9 @@ retryOutboxDelivery = do
retryForwarding
logInfo "Periodic delivery done"
-}
-- NOTE transition to live actors
deliverActivityDB_Live
deliverActivityDB
:: (MonadSite m, SiteEnv m ~ App)
=> LocalActorBy KeyHashid
-> ActorId
@ -1317,27 +886,26 @@ deliverActivityDB_Live
-> [(Host, NonEmpty LocalURI)]
-> [Host]
-> OutboxItemId
-> Event
-> AP.Action URIMode
-> ExceptT Text (ReaderT SqlBackend m) (Worker ())
deliverActivityDB_Live senderByHash senderActorID localRecips remoteRecips fwdHosts itemID event action = do
moreRemoteRecips <- lift $ deliverLocal' True senderByHash senderActorID itemID event localRecips
deliverActivityDB senderByHash senderActorID localRecips remoteRecips fwdHosts itemID action = do
pure $ pure ()
{-
moreRemoteRecips <- lift $ deliverLocal' True senderByKey senderByKey event localRecips
checkFederation moreRemoteRecips
remoteRecipsHttp <- lift $ deliverRemoteDB fwdHosts itemID remoteRecips moreRemoteRecips
envelope <- lift $ prepareSendP senderActorID senderByHash itemID action
envelope <- lift $ do
senderByHash <- hashLocalActor senderByKey
prepareSendP senderActorID senderByHash itemID action
return $ deliverRemoteHttp fwdHosts itemID envelope remoteRecipsHttp
where
checkFederation remoteRecips = do
federation <- asksSite $ appFederation . appSettings
unless (federation || null remoteRecips) $
throwE "Federation disabled, but remote recipients found"
-}
-- NOTE transition to live actors
deliverActivityDB senderByHash senderActorID localRecips remoteRecips fwdHosts itemID =
deliverActivityDB_Live senderByHash senderActorID localRecips remoteRecips fwdHosts itemID EventUnknown
-- NOTE transition to live actors
forwardActivityDB_Live
forwardActivityDB
:: (MonadSite m, SiteEnv m ~ App)
=> BL.ByteString
-> RecipientRoutes
@ -1346,18 +914,19 @@ forwardActivityDB_Live
-> LocalActorBy KeyHashid
-> RecipientRoutes
-> RemoteActivityId
-> Event
-> ReaderT SqlBackend m (Worker ())
forwardActivityDB_Live body localRecips sig fwderActorID fwderByHash sieve activityID event = do
forwardActivityDB body localRecips sig fwderActorID fwderByHash sieve activityID = do
pure $ pure ()
{-
let localRecipsFinal = localRecipSieve' sieve False False localRecips
event = EventLocalFwdRemoteActivity fwderByKey activityID
remoteRecips <-
insertRemoteActivityToLocalInboxes False activityID event localRecipsFinal
insertRemoteActivityToLocalInboxes False event localRecipsFinal
remoteRecipsHttp <-
forwardRemoteDB body activityID fwderActorID sig remoteRecips
errand <- prepareForwardP fwderActorID fwderByHash body sig
errand <- do
fwderByHash <- hashLocalActor fwderByKey
prepareForwardP fwderActorID fwderByHash body sig
now <- liftIO getCurrentTime
return $ forwardRemoteHttp now errand remoteRecipsHttp
-- NOTE transition to live actors
forwardActivityDB body localRecips sig fwderActorID fwderByHash sieve activityID =
forwardActivityDB_Live body localRecips sig fwderActorID fwderByHash sieve activityID EventUnknown
-}

149
src/Web/Actor.hs
View file

@ -13,6 +13,9 @@
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
-- | Reusable library for building decentralized actor-model-based web apps,
-- with 'Control.Concurrent.Actor' for the local actor system, and ActivityPub
-- as the network protocol.
@ -28,24 +31,168 @@
-- steps of refactoring.
module Web.Actor
( StageWeb (..)
, DecodeRouteLocal (..)
, StageWebRoute (..)
, askUrlRender
, ActForE
, hostIsLocal
, parseLocalURI
, parseFedURI
-- Adapted from Yesod.FedURI
, getEncodeRouteLocal
, getEncodeRouteHome
, getEncodeRouteFed
, getEncodeRoutePageLocal
, getEncodeRoutePageHome
, getEncodeRoutePageFed
-- Adapted from Yesod.ActivityPub
, prepareToSend
, prepareToForward
)
where
import Control.Monad.Trans.Except
import Data.ByteString (ByteString)
import Data.Proxy
import Data.Text (Text)
import qualified Data.ByteString.Lazy as BL
import qualified Network.HTTP.Signature as S
import Control.Concurrent.Actor
import Network.FedURI
import Web.Actor.Deliver
import qualified Web.ActivityPub as AP
import Control.Monad.Trans.Except.Local
type ActForE s = ExceptT Text (ActFor s)
class (Stage s, UriMode (StageURIMode s)) => StageWeb s where
type StageURIMode s
stageInstanceHost :: s -> Authority (StageURIMode s)
stageDeliveryTheater :: s -> DeliveryTheater (StageURIMode s)
type ActForE s = ExceptT Text (ActFor s)
class DecodeRouteLocal r where
decodeRouteLocal :: LocalURI -> Maybe r
class (DecodeRouteLocal (StageRoute s), StageWeb s) => StageWebRoute s where
type StageRoute s
askUrlRenderParams
:: (MonadActor m, ActorEnv m ~ s)
=> m (StageRoute s -> [(Text, Text)] -> Text)
-- | Name of parameter to use in generated URIs' query part to indicate the
-- page number in a paginated collection
pageParamName :: Proxy s -> Text
askUrlRender
:: (MonadActor m, ActorEnv m ~ s, StageWebRoute s)
=> m (StageRoute s -> Text)
askUrlRender = do
render <- askUrlRenderParams
return $ \ route -> render route []
hostIsLocal
:: (MonadActor m, ActorEnv m ~ s, StageWeb s)
=> Authority (StageURIMode s) -> m Bool
hostIsLocal h = asksEnv $ (== h) . stageInstanceHost
parseLocalURI :: (Monad m, DecodeRouteLocal r) => LocalURI -> ExceptT Text m r
parseLocalURI lu = fromMaybeE (decodeRouteLocal lu) "Not a valid route"
parseFedURI
:: StageWebRoute s
=> ObjURI (StageURIMode s)
-> ActForE s (Either (StageRoute s) (ObjURI (StageURIMode s)))
parseFedURI u@(ObjURI h lu) = do
hl <- hostIsLocal h
if hl
then Left <$> parseLocalURI lu
else pure $ Right u
getEncodeRouteHome
:: (MonadActor m, ActorEnv m ~ s, StageWebRoute s)
=> m (StageRoute s -> ObjURI (StageURIMode s))
getEncodeRouteHome = toFed <$> askUrlRender
where
toFed renderUrl route =
case parseObjURI $ renderUrl route of
Left e -> error $ "askUrlRender produced invalid ObjURI: " ++ e
Right u -> u
getEncodeRouteLocal
:: (MonadActor m, ActorEnv m ~ s, StageWebRoute s)
=> m (StageRoute s -> LocalURI)
getEncodeRouteLocal = (objUriLocal .) <$> getEncodeRouteHome
getEncodeRouteFed
:: ( MonadActor m
, ActorEnv m ~ s
, StageWebRoute s
, StageURIMode s ~ u
)
=> m (Authority u -> StageRoute s -> ObjURI u)
getEncodeRouteFed = (\ f a -> ObjURI a . f) <$> getEncodeRouteLocal
getEncodeRoutePageLocal
:: (MonadActor m, ActorEnv m ~ s, StageWebRoute s)
=> m (StageRoute s -> Int -> LocalPageURI)
getEncodeRoutePageLocal =
(\ f r n -> pageUriLocal $ f r n) <$> getEncodeRoutePageHome
getEncodeRoutePageHome
:: forall m s. (MonadActor m, ActorEnv m ~ s, StageWebRoute s)
=> m (StageRoute s -> Int -> PageURI (StageURIMode s))
getEncodeRoutePageHome = do
encodeRouteHome <- getEncodeRouteHome
let param = pageParamName (Proxy @s)
return $ \ route page ->
let ObjURI a l = encodeRouteHome route
in PageURI a $ LocalPageURI l param page
getEncodeRoutePageFed
:: ( MonadActor m
, ActorEnv m ~ s
, StageWebRoute s
, StageURIMode s ~ u
)
=> m (Authority u -> StageRoute s -> Int -> PageURI u)
getEncodeRoutePageFed =
(\ f a r n -> PageURI a $ f r n) <$> getEncodeRoutePageLocal
prepareToSend
:: (MonadActor m, ActorEnv m ~ s, StageWebRoute s, StageURIMode s ~ u)
=> StageRoute s
-> (ByteString -> S.Signature)
-> Bool
-> StageRoute s
-> StageRoute s
-> AP.Action u
-> m (AP.Envelope u)
prepareToSend keyR sign holder actorR idR action = do
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
uActor = encodeRouteHome actorR
luId = encodeRouteLocal idR
return $ AP.sending lruKey sign holder uActor luId action
prepareToForward
:: (MonadActor m, ActorEnv m ~ s, StageWebRoute s, StageURIMode s ~ u)
=> StageRoute s
-> (ByteString -> S.Signature)
-> Bool
-> StageRoute s
-> BL.ByteString
-> ByteString
-> m (AP.Errand u)
prepareToForward keyR sign holder fwderR body sig = do
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
let lruKey = LocalRefURI $ Left $ encodeRouteLocal keyR
uFwder = encodeRouteHome fwderR
return $ AP.forwarding lruKey sign holder uFwder body sig

208
src/Web/Actor/Deliver.hs Normal file
View file

@ -0,0 +1,208 @@
{- This file is part of Vervis.
-
- Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
-- | Should eventually turn into an internal module for use only by
-- 'Web.Actor'.
--
-- System of local utility-actors that do the actual HTTP POSTing of
-- activities to remote actors.
module Web.Actor.Deliver
( Method (..)
, DeliveryTheater ()
, startDeliveryTheater
, sendHttp
)
where
import Control.Exception.Base
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Retry
import Data.ByteString (ByteString)
import Data.Foldable
import Data.Hashable
import Data.List.NonEmpty (NonEmpty)
import Data.Text (Text)
import Data.Time.Clock
import Data.Time.Interval
import Data.Traversable
import Database.Persist.Sql
import Network.HTTP.Client (Manager)
import Network.HTTP.Types.Header (HeaderName)
import System.Directory
import Web.Hashids
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as BL
import qualified Data.HashSet as HS
import qualified Data.Text as T
import Control.Concurrent.Actor
import Database.Persist.Box
import Network.FedURI
import qualified Web.ActivityPub as AP
import Vervis.Settings
data Method u
= MethodDeliverLocal (AP.Envelope u) Bool
| MethodForwardRemote (AP.Errand u)
instance Message (Method u) where
summarize _ = "Method"
refer _ = "Method"
data RemoteActor = RemoteActor
{ raInbox :: Maybe LocalURI
, _raErrorSince :: Maybe UTCTime
}
deriving (Show, Read)
instance BoxableVia RemoteActor where
type BV RemoteActor = BoxableShow
{-
migrations :: [Migration SqlBackend IO]
migrations =
[ -- 1
addEntities [entities|
RemoteActor
inbox LocalURI Maybe
errorSince UTCTime Maybe
|]
]
-}
data Env u = Env
{ envBox :: Box RemoteActor
}
instance MonadBox (ActFor (Env u)) where
type BoxType (ActFor (Env u)) = RemoteActor
askBox = asksEnv envBox
instance Stage (Env u) where
type StageKey (Env u) = ObjURI u
type StageMessage (Env u) = Method u
type StageReturn (Env u) = ()
data DeliveryTheater u = DeliveryTheater
{ _dtManager :: Manager
, _dtHeaders :: NonEmpty HeaderName
, _dtDelay :: Int
, _dtLog :: LogFunc
, _dtTheater :: TheaterFor (Env u)
}
data IdMismatch = IdMismatch deriving Show
instance Exception IdMismatch
behavior
:: UriMode u
=> Manager
-> NonEmpty HeaderName
-> Int
-> ObjURI u
-> Method u
-> ActFor (Env u) ((), ActFor (Env u) (), Next)
behavior manager postSignedHeaders micros (ObjURI h lu) = \case
MethodDeliverLocal envelope fwd -> do
ra@(RemoteActor mluInbox _mError) <- runBox obtain
uInbox <- getInbox
let mluFwd = if fwd then Just lu else Nothing
_resp <-
liftIO $ retry toException $
AP.deliver manager postSignedHeaders envelope mluFwd uInbox
done ()
MethodForwardRemote errand -> do
uInbox <- getInbox
_resp <-
liftIO $ retry toException $
AP.forward manager postSignedHeaders errand uInbox
done ()
where
retry :: (e -> SomeException) -> IO (Either e a) -> IO a
retry toE action = do
errorOrResult <-
runExceptT $
retryOnError
(exponentialBackoff micros)
(\ _ _ -> pure True)
(const $ ExceptT action)
case errorOrResult of
Left e -> throwIO $ toE e
Right r -> return r
getInbox = do
ra@(RemoteActor mluInbox _mError) <- runBox obtain
luInbox <-
case mluInbox of
Just luInb -> return luInb
Nothing -> do
AP.Actor local _detail <-
liftIO $
retry
(maybe (toException IdMismatch) toException)
(AP.fetchAPID' manager (AP.actorId . AP.actorLocal) h lu)
let luInb = AP.actorInbox local
runBox $ bestow $ ra { raInbox = Just luInb }
return luInb
return $ ObjURI h luInbox
mkEnv :: LogFunc -> OsPath -> IO (Env u)
mkEnv logFunc path = flip runLoggingT logFunc $ do
box <- loadBox {-migrations-} path (RemoteActor Nothing Nothing)
return $ Env box
type OsPath = FilePath
encodeUtf = pure
decodeUtf = pure
startDeliveryTheater
:: UriMode u
=> NonEmpty HeaderName
-> Int
-> Manager
-> LogFunc
-> OsPath
-> IO (DeliveryTheater u)
startDeliveryTheater headers micros manager logFunc dbRootDir = do
entries <- listDirectory dbRootDir
actors <- for entries $ \ path -> do
path' <- T.pack <$> decodeUtf path
u <-
case parseObjURI path' of
Left e ->
error $
"Failed to parse URI-named SQLite db filename: " ++ e
Right uri -> return uri
env <- mkEnv logFunc path
return (u, env, behavior manager headers micros u)
DeliveryTheater manager headers micros logFunc <$> startTheater logFunc actors
sendHttp :: UriMode u => DeliveryTheater u -> Method u -> [ObjURI u] -> IO ()
sendHttp (DeliveryTheater manager headers micros logFunc theater) method recips = do
for_ recips $ \ u ->
let makeEnv = encodeUtf (T.unpack $ renderObjURI u) >>= mkEnv logFunc
behave = behavior manager headers micros u
in void $ spawnIO theater u makeEnv behave
sendManyIO theater (HS.fromList recips) method

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

@ -20,7 +20,7 @@ module Web.Actor.Persist
, encodeKeyHashidPure
--, getEncodeKeyHashid
--, encodeKeyHashid
, encodeKeyHashid
, decodeKeyHashidPure
--, decodeKeyHashid

6
src/Yesod/ActivityPub.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -16,13 +16,13 @@
module Yesod.ActivityPub
( YesodActivityPub (..)
, prepareToSend
--, prepareToSend
, prepareToRetry
, deliverActivity
, deliverActivityExcept
, deliverActivityThrow
, prepareToForward
--, prepareToForward
, forwardActivity
, forwardActivityExcept
, forwardActivityThrow

27
src/Yesod/Actor.hs
View file

@ -16,9 +16,6 @@
-- | Tools for integrating 'Web.Actor' with the Yesod web framework.
module Yesod.Actor
( decodeRouteLocal
, parseLocalURI
, StageYesod (..)
, parseFedURI
)
where
@ -33,24 +30,6 @@ import Web.Actor
import Control.Monad.Trans.Except.Local
decodeRouteLocal :: ParseRoute site => LocalURI -> Maybe (Route site)
decodeRouteLocal =
parseRoute . (,[]) . decodePathSegments . encodeUtf8 . localUriPath
parseLocalURI
:: (Monad m, ParseRoute site)
=> LocalURI -> ExceptT Text m (Route site)
parseLocalURI lu = fromMaybeE (decodeRouteLocal lu) "Not a valid route"
class (StageWeb s, Yesod (StageSite s)) => StageYesod s where
type StageSite s
parseFedURI
:: (StageYesod s, ParseRoute (StageSite s))
=> ObjURI (StageURIMode s)
-> ActForE s (Either (Route (StageSite s)) (ObjURI (StageURIMode s)))
parseFedURI u@(ObjURI h lu) = do
hl <- lift $ hostIsLocal h
if hl
then Left <$> parseLocalURI lu
else pure $ Right u
instance ParseRoute site => DecodeRouteLocal (Route site) where
decodeRouteLocal =
parseRoute . (,[]) . decodePathSegments . encodeUtf8 . localUriPath

3
src/Yesod/FedURI.hs
View file

@ -13,6 +13,9 @@
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
-- Switching to actor-based system in Web.Actor
-- So this module can be removed once not used anymore
-- Or kept around if can be useful to other projects?
module Yesod.FedURI
( SiteFedURI (..)
, getEncodeRouteLocal

1
stack.yaml
View file

@ -56,6 +56,7 @@ extra-deps:
- time-units-1.0.0
- url-2.1.3
- annotated-exception-0.2.0.4
- retry-0.9.3.1
# Override default flag values for local packages and extra-deps
flags:

13
vervis.cabal
View file

@ -52,6 +52,9 @@ library
Crypto.PubKey.Encoding
Crypto.PublicVerifKey
Darcs.Local.Repository
Data.Slab
Data.Slab.Backend
Data.Slab.Simple
Data.Aeson.Encode.Pretty.ToEncoding
Data.Aeson.Local
Data.Attoparsec.ByteString.Local
@ -87,9 +90,13 @@ library
Data.Tree.Local
Data.Tuple.Local
Database.Esqueleto.Local
Database.Persist.Box
Database.Persist.Box.Internal
Database.Persist.Box.Via
Database.Persist.Class.Local
Database.Persist.JSON
Database.Persist.Sql.Local
Database.Persist.Sqlite.Local
Database.Persist.Local
Database.Persist.Local.Class.PersistEntityHierarchy
Database.Persist.Local.RecursionDoc
@ -112,6 +119,7 @@ library
Web.ActivityAccess
Web.ActivityPub
Web.Actor
Web.Actor.Deliver
Web.Actor.Persist
-- Web.Capability
Web.Text
@ -134,6 +142,7 @@ library
Vervis.Access
Vervis.ActivityPub
Vervis.Actor
Vervis.Actor2
Vervis.Actor.Deck
Vervis.Actor.Group
Vervis.Actor.Loom
@ -305,6 +314,8 @@ library
-- for Darcs.Local.PatchInfo.Parser
, bytestring-lexing
, case-insensitive
-- For slab/box/citron serialization
, cereal
-- for defining colors for use with diagrams
, colour
, conduit
@ -382,12 +393,14 @@ library
, persistent-graph
, persistent-migration
, persistent-postgresql
, persistent-sqlite
, persistent-template
, process
-- for generating hashids salt
, random
-- for Database.Persist.Local
, resourcet
, retry
, safe
, shakespeare
-- for json debug highlighting in Yesod.RenderSource