From 6786e2e0e112a4f38bfd936bc35c57cf0b90b77f Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Wed, 24 May 2023 22:17:14 +0000 Subject: [PATCH] Implement theater-based remote delivery and port personGrant --- INSTALL.md | 6 + config/settings-default.yaml | 12 +- src/Control/Concurrent/Actor.hs | 114 +++--- src/Control/Concurrent/Local.hs | 25 +- src/Data/Slab.hs | 51 +++ src/Data/Slab/Backend.hs | 195 ++++++++++ src/Data/Slab/Simple.hs | 127 +++++++ src/Database/Persist/Box.hs | 82 +++++ src/Database/Persist/Box/Internal.hs | 424 +++++++++++++++++++++ src/Database/Persist/Box/Via.hs | 34 ++ src/Database/Persist/Sqlite/Local.hs | 47 +++ src/Network/FedURI.hs | 6 +- src/Vervis/Access.hs | 13 +- src/Vervis/ActivityPub.hs | 8 +- src/Vervis/Actor.hs | 385 ++++++++++++++++++- src/Vervis/Actor/Person.hs | 131 ++++++- src/Vervis/Actor2.hs | 294 +++++++++++++++ src/Vervis/Application.hs | 41 ++- src/Vervis/Data/Actor.hs | 1 + src/Vervis/Data/Collab.hs | 25 +- src/Vervis/Data/Discussion.hs | 2 + src/Vervis/Federation/Auth.hs | 2 +- src/Vervis/Federation/Collab.hs | 168 +-------- src/Vervis/Foundation.hs | 3 - src/Vervis/Recipient.hs | 39 +- src/Vervis/Settings.hs | 11 +- src/Vervis/Web/Actor.hs | 2 +- src/Vervis/Web/Delivery.hs | 531 +++------------------------ src/Web/Actor.hs | 149 +++++++- src/Web/Actor/Deliver.hs | 208 +++++++++++ src/Web/Actor/Persist.hs | 2 +- src/Yesod/ActivityPub.hs | 6 +- src/Yesod/Actor.hs | 27 +- src/Yesod/FedURI.hs | 3 + stack.yaml | 1 + vervis.cabal | 13 + 36 files changed, 2370 insertions(+), 818 deletions(-) create mode 100644 src/Data/Slab.hs create mode 100644 src/Data/Slab/Backend.hs create mode 100644 src/Data/Slab/Simple.hs create mode 100644 src/Database/Persist/Box.hs create mode 100644 src/Database/Persist/Box/Internal.hs create mode 100644 src/Database/Persist/Box/Via.hs create mode 100644 src/Database/Persist/Sqlite/Local.hs create mode 100644 src/Vervis/Actor2.hs create mode 100644 src/Web/Actor/Deliver.hs diff --git a/INSTALL.md b/INSTALL.md index 58dd714..5753c67 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -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: diff --git a/config/settings-default.yaml b/config/settings-default.yaml index ecf30a8..ae627f7 100644 --- a/config/settings-default.yaml +++ b/config/settings-default.yaml @@ -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 diff --git a/src/Control/Concurrent/Actor.hs b/src/Control/Concurrent/Actor.hs index 82ff789..0c28e37 100644 --- a/src/Control/Concurrent/Actor.hs +++ b/src/Control/Concurrent/Actor.hs @@ -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) diff --git a/src/Control/Concurrent/Local.hs b/src/Control/Concurrent/Local.hs index e9998b6..a1ed33e 100644 --- a/src/Control/Concurrent/Local.hs +++ b/src/Control/Concurrent/Local.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019 by fr33domlover . + - Written in 2019, 2023 by fr33domlover . - - ♡ 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 diff --git a/src/Data/Slab.hs b/src/Data/Slab.hs new file mode 100644 index 0000000..5c118d8 --- /dev/null +++ b/src/Data/Slab.hs @@ -0,0 +1,51 @@ +{- This file is part of Vervis. + - + - Written in 2023 by fr33domlover . + - + - ♡ 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 + - . + -} + +-- | 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 diff --git a/src/Data/Slab/Backend.hs b/src/Data/Slab/Backend.hs new file mode 100644 index 0000000..4a36165 --- /dev/null +++ b/src/Data/Slab/Backend.hs @@ -0,0 +1,195 @@ +{- This file is part of Vervis. + - + - Written in 2023 by fr33domlover . + - + - ♡ 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 + - . + -} + +-- 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 () diff --git a/src/Data/Slab/Simple.hs b/src/Data/Slab/Simple.hs new file mode 100644 index 0000000..5f04d3a --- /dev/null +++ b/src/Data/Slab/Simple.hs @@ -0,0 +1,127 @@ +{- This file is part of Vervis. + - + - Written in 2023 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/Database/Persist/Box.hs b/src/Database/Persist/Box.hs new file mode 100644 index 0000000..6c77073 --- /dev/null +++ b/src/Database/Persist/Box.hs @@ -0,0 +1,82 @@ +{- This file is part of Vervis. + - + - Written in 2023 by fr33domlover . + - + - ♡ 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 + - . + -} + +-- | 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 diff --git a/src/Database/Persist/Box/Internal.hs b/src/Database/Persist/Box/Internal.hs new file mode 100644 index 0000000..f7b37cd --- /dev/null +++ b/src/Database/Persist/Box/Internal.hs @@ -0,0 +1,424 @@ +{- This file is part of Vervis. + - + - Written in 2023 by fr33domlover . + - + - ♡ 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 + - . + -} + +{-# 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 diff --git a/src/Database/Persist/Box/Via.hs b/src/Database/Persist/Box/Via.hs new file mode 100644 index 0000000..04f6128 --- /dev/null +++ b/src/Database/Persist/Box/Via.hs @@ -0,0 +1,34 @@ +{- This file is part of Vervis. + - + - Written in 2023 by fr33domlover . + - + - ♡ 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 + - . + -} + +{-# 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 +-} diff --git a/src/Database/Persist/Sqlite/Local.hs b/src/Database/Persist/Sqlite/Local.hs new file mode 100644 index 0000000..e73bc33 --- /dev/null +++ b/src/Database/Persist/Sqlite/Local.hs @@ -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 diff --git a/src/Network/FedURI.hs b/src/Network/FedURI.hs index 52b6a0d..8d7a5cd 100644 --- a/src/Network/FedURI.hs +++ b/src/Network/FedURI.hs @@ -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) diff --git a/src/Vervis/Access.hs b/src/Vervis/Access.hs index 3ef2777..b04183c 100644 --- a/src/Vervis/Access.hs +++ b/src/Vervis/Access.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2022 by fr33domlover . + - Written in 2019, 2022, 2023 by fr33domlover . - - ♡ 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) = diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index 5afb8cf..62c6f56 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -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 diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs index 74757c9..ad7a1ec 100644 --- a/src/Vervis/Actor.hs +++ b/src/Vervis/Actor.hs @@ -13,6 +13,8 @@ - . -} +{-# 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 diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index a50e91c..fc63521 100644 --- a/src/Vervis/Actor/Person.hs +++ b/src/Vervis/Actor/Person.hs @@ -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 -> diff --git a/src/Vervis/Actor2.hs b/src/Vervis/Actor2.hs new file mode 100644 index 0000000..d7922e9 --- /dev/null +++ b/src/Vervis/Actor2.hs @@ -0,0 +1,294 @@ +{- This file is part of Vervis. + - + - Written in 2019, 2020, 2022, 2023 by fr33domlover . + - + - ♡ 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 + - . + -} + +-- 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 diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index edd9277..d87f5f0 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -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 diff --git a/src/Vervis/Data/Actor.hs b/src/Vervis/Data/Actor.hs index 29883a7..75a2f24 100644 --- a/src/Vervis/Data/Actor.hs +++ b/src/Vervis/Data/Actor.hs @@ -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 diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index c35868f..ec877f7 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -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 <- diff --git a/src/Vervis/Data/Discussion.hs b/src/Vervis/Data/Discussion.hs index 1e5a89d..55282a8 100644 --- a/src/Vervis/Data/Discussion.hs +++ b/src/Vervis/Data/Discussion.hs @@ -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 diff --git a/src/Vervis/Federation/Auth.hs b/src/Vervis/Federation/Auth.hs index a2bcfb8..de26208 100644 --- a/src/Vervis/Federation/Auth.hs +++ b/src/Vervis/Federation/Auth.hs @@ -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 diff --git a/src/Vervis/Federation/Collab.hs b/src/Vervis/Federation/Collab.hs index dfeb307..fea9c6b 100644 --- a/src/Vervis/Federation/Collab.hs +++ b/src/Vervis/Federation/Collab.hs @@ -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" diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 93c2238..0c74a50 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -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 diff --git a/src/Vervis/Recipient.hs b/src/Vervis/Recipient.hs index d58977c..0d3b58e 100644 --- a/src/Vervis/Recipient.hs +++ b/src/Vervis/Recipient.hs @@ -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 diff --git a/src/Vervis/Settings.hs b/src/Vervis/Settings.hs index 82f7a6c..a7f298d 100644 --- a/src/Vervis/Settings.hs +++ b/src/Vervis/Settings.hs @@ -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" .!= [] diff --git a/src/Vervis/Web/Actor.hs b/src/Vervis/Web/Actor.hs index 8ce60a4..531f2ab 100644 --- a/src/Vervis/Web/Actor.hs +++ b/src/Vervis/Web/Actor.hs @@ -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 diff --git a/src/Vervis/Web/Delivery.hs b/src/Vervis/Web/Delivery.hs index 3eab78c..8eaef88 100644 --- a/src/Vervis/Web/Delivery.hs +++ b/src/Vervis/Web/Delivery.hs @@ -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 +-} diff --git a/src/Web/Actor.hs b/src/Web/Actor.hs index f66654a..72b4f24 100644 --- a/src/Web/Actor.hs +++ b/src/Web/Actor.hs @@ -13,6 +13,9 @@ - . -} +{-# 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 diff --git a/src/Web/Actor/Deliver.hs b/src/Web/Actor/Deliver.hs new file mode 100644 index 0000000..570dc81 --- /dev/null +++ b/src/Web/Actor/Deliver.hs @@ -0,0 +1,208 @@ +{- This file is part of Vervis. + - + - Written in 2023 by fr33domlover . + - + - ♡ 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 + - . + -} + +{-# 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 diff --git a/src/Web/Actor/Persist.hs b/src/Web/Actor/Persist.hs index e3b4184..a21aff7 100644 --- a/src/Web/Actor/Persist.hs +++ b/src/Web/Actor/Persist.hs @@ -20,7 +20,7 @@ module Web.Actor.Persist , encodeKeyHashidPure --, getEncodeKeyHashid - --, encodeKeyHashid + , encodeKeyHashid , decodeKeyHashidPure --, decodeKeyHashid diff --git a/src/Yesod/ActivityPub.hs b/src/Yesod/ActivityPub.hs index 9238a3b..1d58a83 100644 --- a/src/Yesod/ActivityPub.hs +++ b/src/Yesod/ActivityPub.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2022 by fr33domlover . + - Written in 2019, 2022, 2023 by fr33domlover . - - ♡ 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 diff --git a/src/Yesod/Actor.hs b/src/Yesod/Actor.hs index 7a1b1d3..3e81d73 100644 --- a/src/Yesod/Actor.hs +++ b/src/Yesod/Actor.hs @@ -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 diff --git a/src/Yesod/FedURI.hs b/src/Yesod/FedURI.hs index 007f025..e8f7102 100644 --- a/src/Yesod/FedURI.hs +++ b/src/Yesod/FedURI.hs @@ -13,6 +13,9 @@ - . -} +-- 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 diff --git a/stack.yaml b/stack.yaml index 3fe636e..11b2ca3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -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: diff --git a/vervis.cabal b/vervis.cabal index 3b80e5e..dd435bf 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -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