From c9db823c8ccfe4642168178a202a3594c7414a19 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sat, 29 Apr 2023 10:40:44 +0000 Subject: [PATCH] Implement actor-model system and start moving Person actor to it This patch makes Vervis temporarily unusable, because all actors' inbox POST handlers use the new system, but the actual federation handler code hasn't been ported. The next patches will port all the S2S activities supported so far, as well as C2S. --- INSTALL.md | 8 +- src/Control/Concurrent/Actor.hs | 332 ++++++++++++++++++++++++++++ src/Control/Concurrent/Return.hs | 37 ++++ src/Vervis/API.hs | 9 +- src/Vervis/Actor.hs | 271 +++++++++++++++++++++++ src/Vervis/Actor/Deck.hs | 64 ++++++ src/Vervis/Actor/Group.hs | 64 ++++++ src/Vervis/Actor/Loom.hs | 64 ++++++ src/Vervis/Actor/Person.hs | 189 ++++++++++++++++ src/Vervis/Actor/Repo.hs | 64 ++++++ src/Vervis/Application.hs | 49 +++- src/Vervis/Data/Actor.hs | 35 ++- src/Vervis/Data/Collab.hs | 11 +- src/Vervis/Data/Discussion.hs | 106 ++++++++- src/Vervis/Data/Follow.hs | 4 +- src/Vervis/Data/Ticket.hs | 11 +- src/Vervis/Federation/Auth.hs | 30 +-- src/Vervis/Federation/Collab.hs | 3 +- src/Vervis/Federation/Discussion.hs | 9 +- src/Vervis/Federation/Offer.hs | 5 +- src/Vervis/Federation/Ticket.hs | 6 +- src/Vervis/Federation/Util.hs | 3 +- src/Vervis/Foundation.hs | 28 ++- src/Vervis/Handler/Client.hs | 66 +++++- src/Vervis/Handler/Deck.hs | 21 +- src/Vervis/Handler/Group.hs | 19 +- src/Vervis/Handler/Loom.hs | 21 +- src/Vervis/Handler/Person.hs | 105 +-------- src/Vervis/Handler/Repo.hs | 21 +- src/Vervis/Model.hs | 37 ++++ src/Vervis/Persist/Discussion.hs | 16 +- src/Vervis/Recipient.hs | 78 +------ src/Vervis/RemoteActorStore.hs | 1 + src/Vervis/Web/Actor.hs | 70 +++--- src/Vervis/Web/Delivery.hs | 108 ++++++--- src/Web/ActivityPub.hs | 146 ++++++++++-- src/Web/Actor.hs | 51 +++++ src/Web/Actor/Persist.hs | 137 ++++++++++++ src/Yesod/ActivityPub.hs | 8 +- src/Yesod/Actor.hs | 56 +++++ src/Yesod/FedURI.hs | 11 +- src/Yesod/Hashids.hs | 27 +-- stack.yaml | 7 + templates/personal-overview.hamlet | 3 + th/models | 9 +- th/routes | 1 + vervis.cabal | 13 ++ 47 files changed, 2005 insertions(+), 429 deletions(-) create mode 100644 src/Control/Concurrent/Actor.hs create mode 100644 src/Control/Concurrent/Return.hs create mode 100644 src/Vervis/Actor.hs create mode 100644 src/Vervis/Actor/Deck.hs create mode 100644 src/Vervis/Actor/Group.hs create mode 100644 src/Vervis/Actor/Loom.hs create mode 100644 src/Vervis/Actor/Person.hs create mode 100644 src/Vervis/Actor/Repo.hs create mode 100644 src/Web/Actor.hs create mode 100644 src/Web/Actor/Persist.hs create mode 100644 src/Yesod/Actor.hs diff --git a/INSTALL.md b/INSTALL.md index 08e6dc8..58dd714 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -32,10 +32,12 @@ On Debian based distros, installation can be done like this: $ sudo apt install libpq-dev zlib1g-dev libssl-dev libpcre3-dev -# (2) The Stack build tool +# (2) Haskell development tools -Install stack. To install stack, go to its [website](https://haskellstack.org) -and follow the instructions. +Go to the [GHCup website](https://www.haskell.org/ghcup) and follow the +instructions. + + $ curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh # (3) Version control systems Darcs and Git diff --git a/src/Control/Concurrent/Actor.hs b/src/Control/Concurrent/Actor.hs new file mode 100644 index 0000000..82ff789 --- /dev/null +++ b/src/Control/Concurrent/Actor.hs @@ -0,0 +1,332 @@ +{- This file is part of Vervis. + - + - Written in 2019, 2020, 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 Control.Concurrent.Actor + ( Stage (..) + , TheaterFor () + , ActFor () + , MonadActor (..) + , asksEnv + , Next () + , Message (..) + , startTheater + , callIO + , call + --, sendIO + , send + , sendManyIO + , sendMany + --, spawnIO + , spawn + , done + , doneAnd + , stop + ) +where + +import Control.Concurrent +import Control.Concurrent.STM.TVar +import Control.Monad +import Control.Monad.Fail +import Control.Monad.IO.Unlift +import Control.Monad.Logger.CallStack +import Control.Monad.STM +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +import Data.Foldable +import Data.Hashable +import Data.HashMap.Strict (HashMap) +import Data.HashSet (HashSet) +import Data.Text (Text) +import Data.Traversable +import UnliftIO.Exception + +import qualified Control.Exception.Annotated as AE +import qualified Control.Monad.Trans.RWS.Lazy as RWSL +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import qualified Data.Text as T + +import Control.Concurrent.Return + +type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () + +class Stage a where + type StageKey a + type StageMessage a + type StageReturn a + +-- | 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 ()))) + , 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 + } + deriving + ( Functor, Applicative, Monad, MonadFail, MonadIO, MonadLogger + , MonadLoggerIO + ) + +instance MonadUnliftIO (ActFor s) where + askUnliftIO = + ActFor $ withUnliftIO $ \ u -> + return $ UnliftIO $ unliftIO u . unActFor + 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 + +class Monad m => MonadActor m where + type ActorEnv m + askEnv :: m (ActorEnv m) + liftActor :: ActFor (ActorEnv m) a -> m a + +instance MonadActor (ActFor s) where + type ActorEnv (ActFor s) = s + askEnv = theaterEnv <$> askTheater + liftActor = id + +instance MonadActor m => MonadActor (ReaderT r m) where + type ActorEnv (ReaderT r m) = ActorEnv m + askEnv = lift askEnv + liftActor = lift . liftActor + +instance MonadActor m => MonadActor (MaybeT m) where + type ActorEnv (MaybeT m) = ActorEnv m + askEnv = lift askEnv + liftActor = lift . liftActor + +instance MonadActor m => MonadActor (ExceptT e m) where + type ActorEnv (ExceptT e m) = ActorEnv m + askEnv = lift askEnv + liftActor = lift . liftActor + +instance (Monoid w, MonadActor m) => MonadActor (RWSL.RWST r w s m) where + type ActorEnv (RWSL.RWST r w s m) = ActorEnv m + askEnv = lift askEnv + liftActor = lift . liftActor + +asksEnv :: MonadActor m => (ActorEnv m -> a) -> m a +asksEnv f = f <$> askEnv + +data Next = Stop | Proceed + +class Message a where + summarize :: a -> Text + refer :: a -> Text + +launchActorThread + :: ( StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r + , Hashable k, Eq k, Show k, Message m, Show r + ) + => Chan (m, Either SomeException r -> IO ()) + -> TheaterFor s + -> k + -> (m -> ActFor s (r, ActFor s (), Next)) + -> IO () +launchActorThread chan theater actor behavior = + void $ forkIO $ runActor theater $ do + logInfo $ prefix <> "starting" + loop + logInfo $ prefix <> "bye" + where + prefix = T.concat ["[Actor '", T.pack $ show actor, "'] "] + loop = do + (message, respond) <- liftIO $ readChan chan + logInfo $ T.concat [prefix, "received: ", summarize message] + result <- try $ behavior message + proceed <- + case result of + Left e -> do + logError $ T.concat [prefix, "on ", refer message, " exception: ", T.pack $ displayException (e :: SomeException)] + liftIO $ respond $ Left e + return True + Right (value, after, next) -> do + logInfo $ T.concat [prefix, "on ", refer message, " result: ", T.pack $ show value] + liftIO $ respond $ Right value + after + case next of + Stop -> do + logInfo $ T.concat [prefix, "on ", refer message, " stopping"] + let tvar = theaterMap theater + liftIO $ atomically $ modifyTVar' tvar $ HM.delete actor + return False + Proceed -> do + logInfo $ T.concat [prefix, "on ", refer message, " done"] + return True + when proceed loop + +-- | Launch the actor system +startTheater + :: ( StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r + , Hashable k, Eq k, Show k, Message m, Show r + ) + => LogFunc + -> s + -> [(k, m -> ActFor s (r, ActFor s (), Next))] + -> IO (TheaterFor s) +startTheater logFunc env actors = do + actorsWithChans <- for actors $ \ (key, behavior) -> do + chan <- newChan + return ((key, chan), behavior) + tvar <- newTVarIO $ HM.fromList $ map fst actorsWithChans + let theater = TheaterFor tvar logFunc env + for_ actorsWithChans $ \ ((key, chan), behavior) -> + launchActorThread chan theater key behavior + return theater + +askTheater :: ActFor s (TheaterFor s) +askTheater = ActFor $ lift ask + +lookupActor + :: ( StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r + , Eq k, Hashable k + ) + => TheaterFor s + -> k + -> IO (Maybe (Chan (m, Either SomeException r -> IO ()))) +lookupActor (TheaterFor tvar _ _) actor = HM.lookup actor <$> readTVarIO tvar + +-- | Same as 'call', except it takes the theater as a parameter. +callIO + :: ( StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r + , Eq k, Hashable k + ) + => 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 + +-- | Send a message to an actor, and wait for the result to arrive. Return +-- 'Nothing' if actor doesn't exist, otherwise 'Just' the result. +-- +-- If the called method throws an exception, it is rethrown, wrapped with an +-- annotation, in the current thread. +call + :: ( MonadActor n, ActorEnv n ~ s + , StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r + , Eq k, Hashable k + ) + => k -> m -> n (Maybe r) +call key msg = liftActor $ do + theater <- askTheater + liftIO $ callIO theater key msg + +-- | Like 'send', except it takes the theater as a parameter. +sendIO + :: (StageKey s ~ k, StageMessage s ~ m, Eq k, Hashable k) + => TheaterFor s -> k -> m -> IO Bool +sendIO theater actor msg = do + maybeChan <- lookupActor theater actor + case maybeChan of + Nothing -> return False + Just chan -> do + writeChan chan (msg, const $ pure ()) + return True + +-- | Send a message to an actor, without waiting for a result. Return 'True' if +-- the given actor exists, 'False' otherwise. +send + :: ( MonadActor n, ActorEnv n ~ s + , StageKey s ~ k, StageMessage s ~ m + , Eq k, Hashable k + ) + => k -> m -> n Bool +send key msg = liftActor $ do + theater <- askTheater + liftIO $ sendIO theater key msg + +-- | Like 'sendMany', except it takes the theater as a parameter. +sendManyIO + :: (StageKey s ~ k, StageMessage s ~ m, Eq k, Hashable k) + => TheaterFor s -> HashSet k -> m -> IO () +sendManyIO (TheaterFor tvar _ _) recips msg = do + allActors <- readTVarIO tvar + for_ (HM.intersection allActors (HS.toMap recips)) $ + \ chan -> writeChan chan (msg, const $ pure ()) + +-- | Send a message to each actor in the set that exists in the system, +-- without waiting for results. +sendMany + :: ( MonadActor n, ActorEnv n ~ s + , StageKey s ~ k, StageMessage s ~ m + , Eq k, Hashable k + ) + => HashSet k -> m -> n () +sendMany keys msg = liftActor $ do + theater <- askTheater + liftIO $ sendManyIO theater keys msg + +-- | Same as 'spawn', except it takes the theater as a parameter. +spawnIO + :: ( StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r + , Eq k, Hashable k, Show k, Message m, Show r + ) + => TheaterFor s + -> k + -> (m -> ActFor s (r, ActFor s (), Next)) + -> IO Bool +spawnIO theater@(TheaterFor tvar _ _) actor 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' + , hm' + ) + when added $ launchActorThread chan theater actor behavior + return added + where + create chan Nothing = Just chan + 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 +-- already in use, thus a new actor hasn't been launched. +spawn + :: ( MonadActor n, ActorEnv n ~ s + , StageKey s ~ k, StageMessage s ~ m, StageReturn s ~ r + , Eq k, Hashable k, Show k, Message m, Show r + ) + => k + -> (m -> ActFor s (r, ActFor s (), Next)) + -> n Bool +spawn key behavior = liftActor $ do + theater <- askTheater + liftIO $ spawnIO theater key behavior + +done :: Monad n => a -> n (a, ActFor s (), Next) +done msg = return (msg, return (), Proceed) + +doneAnd :: Monad n => a -> ActFor s () -> n (a, ActFor s (), Next) +doneAnd msg act = return (msg, act, Proceed) + +stop :: Monad n => a -> n (a, ActFor s (), Next) +stop msg = return (msg, return (), Stop) diff --git a/src/Control/Concurrent/Return.hs b/src/Control/Concurrent/Return.hs new file mode 100644 index 0000000..d09b146 --- /dev/null +++ b/src/Control/Concurrent/Return.hs @@ -0,0 +1,37 @@ +{- 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 + - . + -} + +-- | Give another thread a way to send a value back to us. +module Control.Concurrent.Return + ( newReturn + ) +where + +import Control.Concurrent.MVar +import Control.Monad + +-- | Produce a pair of IO actions: +-- +-- 1. Setter to give another thread, where it would be called at most once to +-- send us a value +-- 2. Action that waits until the value arrives +newReturn :: IO (a -> IO (), IO a) +newReturn = do + mvar <- newEmptyMVar + return (putReturn mvar, readMVar mvar) + where + putReturn mvar val = do + success <- tryPutMVar mvar val + unless success $ error "newReturn: putReturn: MVar is full" diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 523d061..5cfdc82 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2022 by fr33domlover . + - Written in 2019, 2020, 2022, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -80,6 +80,7 @@ import Network.FedURI import Web.ActivityPub hiding (Patch (..), Ticket, Follow, Repo (..), ActorLocal (..), ActorDetail (..), Actor (..)) import Web.Text import Yesod.ActivityPub +import Yesod.Actor import Yesod.FedURI import Yesod.Hashids import Yesod.MonadSite @@ -781,7 +782,7 @@ createNoteC (Entity senderPersonID senderPerson) senderActor maybeCap localRecip -- Check input verifyNothingE maybeCap "Capability not needed" Comment maybeParent topic source content <- do - (authorPersonID, comment) <- parseNewLocalComment note + (authorPersonID, comment) <- parseNewLocalCommentOld note unless (authorPersonID == senderPersonID) $ throwE "Note attributed to someone else" return comment @@ -1079,7 +1080,7 @@ createPatchTrackerC (Entity pidUser personUser) senderActor maybeCap localRecips parseRepo (ObjURI h lu :| us) = do unless (null us) $ throwE "More than one repo is specified" - hl <- hostIsLocal h + hl <- hostIsLocalOld h unless hl $ throwE "A remote repo is specified" route <- fromMaybeE (decodeRouteLocal lu) "Not a valid route" case route of @@ -2712,7 +2713,7 @@ resolveC (Entity senderPersonID senderPerson) senderActor maybeCap localRecips r -- Check input maybeLocalWorkItem <- nameExceptT "Resolve object" $ either Just (const Nothing) <$> do - routeOrRemote <- parseFedURI uObject + routeOrRemote <- parseFedURIOld uObject bitraverse (\ r -> do wiByHash <- diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs new file mode 100644 index 0000000..74757c9 --- /dev/null +++ b/src/Vervis/Actor.hs @@ -0,0 +1,271 @@ +{- 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 + - . + -} + +-- These are for the Barbie-based generated instances +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module Vervis.Actor + ( -- * Local actors + LocalActorBy (..) + , LocalActor + + -- * Local recipient set + , TicketRoutes (..) + , ClothRoutes (..) + , PersonRoutes (..) + , GroupRoutes (..) + , RepoRoutes (..) + , DeckRoutes (..) + , LoomRoutes (..) + , DeckFamilyRoutes (..) + , LoomFamilyRoutes (..) + , RecipientRoutes (..) + + -- * AP system base types + , RemoteAuthor (..) + , ActivityBody (..) + , VerseRemote (..) + + -- * Behavior utility types + , Verse + , Event (..) + , Env (..) + , Act + , ActE + , ActDB + , ActDBE + , Theater + + -- * Behavior utilities + , withDB + , withDBExcept + , behave + ) +where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import Data.Barbie +import Data.ByteString (ByteString) +import Data.Hashable +import Data.Text (Text) +import Data.Time.Clock +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.Text as T + +import Control.Concurrent.Actor +import Network.FedURI +import Web.Actor +import Web.Actor.Persist + +import qualified Web.ActivityPub as AP + +import Vervis.FedURI +import Vervis.Model hiding (Actor, Message) +import Vervis.Settings + +data LocalActorBy f + = LocalActorPerson (f Person) + | LocalActorGroup (f Group) + | LocalActorRepo (f Repo) + | LocalActorDeck (f Deck) + | LocalActorLoom (f Loom) + deriving (Generic, FunctorB, ConstraintsB) + +deriving instance AllBF Eq f LocalActorBy => Eq (LocalActorBy f) +deriving instance AllBF Ord f LocalActorBy => Ord (LocalActorBy f) +deriving instance AllBF Hashable f LocalActorBy => Hashable (LocalActorBy f) +deriving instance AllBF Show f LocalActorBy => Show (LocalActorBy f) + +type LocalActor = LocalActorBy KeyHashid + +data TicketRoutes = TicketRoutes + { routeTicketFollowers :: Bool + } + deriving Eq + +data ClothRoutes = ClothRoutes + { routeClothFollowers :: Bool + } + deriving Eq + +data PersonRoutes = PersonRoutes + { routePerson :: Bool + , routePersonFollowers :: Bool + } + deriving Eq + +data GroupRoutes = GroupRoutes + { routeGroup :: Bool + , routeGroupFollowers :: Bool + } + deriving Eq + +data RepoRoutes = RepoRoutes + { routeRepo :: Bool + , routeRepoFollowers :: Bool + } + deriving Eq + +data DeckRoutes = DeckRoutes + { routeDeck :: Bool + , routeDeckFollowers :: Bool + } + deriving Eq + +data LoomRoutes = LoomRoutes + { routeLoom :: Bool + , routeLoomFollowers :: Bool + } + deriving Eq + +data DeckFamilyRoutes = DeckFamilyRoutes + { familyDeck :: DeckRoutes + , familyTickets :: [(KeyHashid TicketDeck, TicketRoutes)] + } + deriving Eq + +data LoomFamilyRoutes = LoomFamilyRoutes + { familyLoom :: LoomRoutes + , familyCloths :: [(KeyHashid TicketLoom, ClothRoutes)] + } + deriving Eq + +data RecipientRoutes = RecipientRoutes + { recipPeople :: [(KeyHashid Person, PersonRoutes)] + , recipGroups :: [(KeyHashid Group , GroupRoutes)] + , recipRepos :: [(KeyHashid Repo , RepoRoutes)] + , recipDecks :: [(KeyHashid Deck , DeckFamilyRoutes)] + , recipLooms :: [(KeyHashid Loom , LoomFamilyRoutes)] + } + deriving Eq + +data RemoteAuthor = RemoteAuthor + { remoteAuthorURI :: FedURI + , remoteAuthorInstance :: InstanceId + , remoteAuthorId :: RemoteActorId + } + +data ActivityBody = ActivityBody + { actbBL :: BL.ByteString + , actbObject :: A.Object + , actbActivity :: AP.Activity URIMode + } + +data VerseRemote = VerseRemote + { verseAuthor :: RemoteAuthor + , verseBody :: ActivityBody + , verseForward :: Maybe (RecipientRoutes, ByteString) + , verseActivity :: LocalURI + } + +data Event + = EventFwdRemoteGrantToSomeoneElse RemoteActivityId + | EventRemoteFwdLocalActivity (LocalActorBy Key) OutboxItemId + | EventUnknown + deriving Show + +type Verse = Either Event VerseRemote + +instance Message Verse where + summarize (Left event) = T.pack $ show event + summarize (Right (VerseRemote author body _fwd uri)) = + let ObjURI h _ = remoteAuthorURI author + typ = AP.activityType $ AP.activitySpecific $ actbActivity body + in T.concat [typ, " ", renderObjURI $ ObjURI h uri] + refer (Left event) = T.pack $ show event + refer (Right (VerseRemote author _body _fwd uri)) = + let ObjURI h _ = remoteAuthorURI author + in renderObjURI $ ObjURI h uri + +-- | Data to which every actor has access. Since such data can be passed to the +-- behavior function when launching the actor, having a dedicated datatype is +-- just convenience. The main reason is to allow 'runDB' not to take a +-- connection pool parameter, instead grabbing it from the ReaderT. Another +-- reason is to avoid the clutter of passing the same arguments manually +-- everywhere. +-- +-- 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 + } + +instance Stage Env where + type StageKey Env = LocalActorBy Key + type StageMessage Env = Verse + type StageReturn Env = Either Text Text + +instance StageWeb Env where + type StageURIMode Env = URIMode + stageInstanceHost = appInstanceHost . envSettings + +instance StageHashids Env where + stageHashidsContext = envHashidsContext + +type Act = ActFor Env + +type ActE = ActForE Env + +type ActDB = SqlPersistT Act + +type ActDBE = ExceptT Text ActDB + +type Theater = TheaterFor Env + +-- | Run a database transaction. If an exception is thrown, the whole +-- transaction is aborted. +withDB :: ActDB a -> Act a +withDB action = do + env <- askEnv + runPool (appDatabaseConf $ envSettings env) action (envDbPool env) + +newtype FedError = FedError Text deriving Show + +instance Exception FedError + +-- | Like 'withDB', but supports errors via 'ExceptT. If an exception is +-- thrown, either via the 'ExceptT' or via regular throwing, the whole +-- transaction is aborted. +withDBExcept :: ExceptT Text (SqlPersistT Act) a -> ExceptT Text Act a +withDBExcept action = do + result <- lift $ try $ withDB $ either abort return =<< runExceptT action + case result of + Left (FedError t) -> throwE t + Right r -> return r + where + abort = throwIO . FedError + +behave + :: (UTCTime -> Key a -> Verse -> ExceptT Text Act (Text, Act (), Next)) + -> (Key a -> Verse -> Act (Either Text Text, Act (), Next)) +behave handler key msg = do + now <- liftIO getCurrentTime + result <- runExceptT $ handler now key msg + case result of + Left e -> done $ Left e + Right (t, after, next) -> return (Right t, after, next) diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs new file mode 100644 index 0000000..e57f473 --- /dev/null +++ b/src/Vervis/Actor/Deck.hs @@ -0,0 +1,64 @@ +{- 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 Vervis.Actor.Deck + ( deckBehavior + ) +where + +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.Monad.Trans.Maybe +import Data.ByteString (ByteString) +import Data.Foldable +import Data.Text (Text) +import Data.Time.Clock +import Database.Persist +import Yesod.Persist.Core + +import qualified Data.Text as T + +import Control.Concurrent.Actor +import Network.FedURI +import Yesod.MonadSite + +import qualified Web.ActivityPub as AP + +import Control.Monad.Trans.Except.Local +import Database.Persist.Local + +import Vervis.Actor +import Vervis.Cloth +import Vervis.Data.Discussion +import Vervis.FedURI +import Vervis.Federation.Util +import Vervis.Foundation +import Vervis.Model +import Vervis.Persist.Discussion +import Vervis.Ticket + +deckBehavior + :: UTCTime -> DeckId -> Verse -> ExceptT Text Act (Text, Act (), Next) +deckBehavior now deckID (Left event) = + case event of + EventRemoteFwdLocalActivity _ _ -> + throwE "Got a forwarded local activity, I don't need those" + _ -> throwE $ "Unsupported event for Deck: " <> T.pack (show event) +deckBehavior now deckID (Right (VerseRemote author body mfwd luActivity)) = + case AP.activitySpecific $ actbActivity body of + _ -> throwE "Unsupported activity type for Deck" diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs new file mode 100644 index 0000000..29506ba --- /dev/null +++ b/src/Vervis/Actor/Group.hs @@ -0,0 +1,64 @@ +{- 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 Vervis.Actor.Group + ( groupBehavior + ) +where + +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.Monad.Trans.Maybe +import Data.ByteString (ByteString) +import Data.Foldable +import Data.Text (Text) +import Data.Time.Clock +import Database.Persist +import Yesod.Persist.Core + +import qualified Data.Text as T + +import Control.Concurrent.Actor +import Network.FedURI +import Yesod.MonadSite + +import qualified Web.ActivityPub as AP + +import Control.Monad.Trans.Except.Local +import Database.Persist.Local + +import Vervis.Actor +import Vervis.Cloth +import Vervis.Data.Discussion +import Vervis.FedURI +import Vervis.Federation.Util +import Vervis.Foundation +import Vervis.Model +import Vervis.Persist.Discussion +import Vervis.Ticket + +groupBehavior + :: UTCTime -> GroupId -> Verse -> ExceptT Text Act (Text, Act (), Next) +groupBehavior now groupID (Left event) = + case event of + EventRemoteFwdLocalActivity _ _ -> + throwE "Got a forwarded local activity, I don't need those" + _ -> throwE $ "Unsupported event for Group: " <> T.pack (show event) +groupBehavior now groupID (Right (VerseRemote author body mfwd luActivity)) = + case AP.activitySpecific $ actbActivity body of + _ -> throwE "Unsupported activity type for Group" diff --git a/src/Vervis/Actor/Loom.hs b/src/Vervis/Actor/Loom.hs new file mode 100644 index 0000000..3d478d9 --- /dev/null +++ b/src/Vervis/Actor/Loom.hs @@ -0,0 +1,64 @@ +{- 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 Vervis.Actor.Loom + ( loomBehavior + ) +where + +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.Monad.Trans.Maybe +import Data.ByteString (ByteString) +import Data.Foldable +import Data.Text (Text) +import Data.Time.Clock +import Database.Persist +import Yesod.Persist.Core + +import qualified Data.Text as T + +import Control.Concurrent.Actor +import Network.FedURI +import Yesod.MonadSite + +import qualified Web.ActivityPub as AP + +import Control.Monad.Trans.Except.Local +import Database.Persist.Local + +import Vervis.Actor +import Vervis.Cloth +import Vervis.Data.Discussion +import Vervis.FedURI +import Vervis.Federation.Util +import Vervis.Foundation +import Vervis.Model +import Vervis.Persist.Discussion +import Vervis.Ticket + +loomBehavior + :: UTCTime -> LoomId -> Verse -> ExceptT Text Act (Text, Act (), Next) +loomBehavior now loomID (Left event) = + case event of + EventRemoteFwdLocalActivity _ _ -> + throwE "Got a forwarded local activity, I don't need those" + _ -> throwE $ "Unsupported event for Loom: " <> T.pack (show event) +loomBehavior now loomID (Right (VerseRemote author body mfwd luActivity)) = + case AP.activitySpecific $ actbActivity body of + _ -> throwE "Unsupported activity type for Loom" diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs new file mode 100644 index 0000000..a50e91c --- /dev/null +++ b/src/Vervis/Actor/Person.hs @@ -0,0 +1,189 @@ +{- This file is part of Vervis. + - + - Written in 2016, 2018, 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 + - . + -} + +module Vervis.Actor.Person + ( personBehavior + ) +where + +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.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +import Data.ByteString (ByteString) +import Data.Foldable +import Data.Text (Text) +import Data.Time.Clock +import Database.Persist +import Database.Persist.Sql +import Yesod.Persist.Core + +import qualified Data.Text as T + +import Control.Concurrent.Actor +import Network.FedURI +import Yesod.MonadSite + +import qualified Web.ActivityPub as AP + +import Control.Monad.Trans.Except.Local +import Database.Persist.Local + +import Vervis.Actor +import Vervis.Cloth +import Vervis.Data.Discussion +import Vervis.FedURI +import Vervis.Federation.Util +import Vervis.Foundation +import Vervis.Model +import Vervis.Persist.Actor +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 + +-- Meaning: Someone commented on an issue/PR +-- Behavior: Insert to inbox +personCreateNote + :: UTCTime + -> PersonId + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Note URIMode + -> ExceptT Text Act (Text, Act (), Next) +personCreateNote now recipPersonID author body mfwd luCreate note = do + + -- Check input + (luNote, published, Comment maybeParent topic source content) <- do + (luId, luAuthor, published, comment) <- parseRemoteComment note + unless (luAuthor == objUriLocal (remoteAuthorURI author)) $ + throwE "Create author != note author" + return (luId, published, comment) + + mractid <- withDBExcept $ do + Entity recipActorID recipActor <- lift $ do + person <- getJust recipPersonID + let actorID = personActor person + Entity actorID <$> getJust actorID + + case topic of + + Right uContext -> do + checkContextParent uContext maybeParent + lift $ insertToInbox now author body (actorInbox recipActor) luCreate True + + Left (CommentTopicTicket deckID taskID) -> do + (_, _, Entity _ ticket, _, _) <- do + mticket <- lift $ getTicket deckID taskID + fromMaybeE mticket "Context: No such deck-ticket" + let did = ticketDiscuss ticket + _ <- traverse (getMessageParent did) maybeParent + lift $ insertToInbox now author body (actorInbox recipActor) luCreate True + + Left (CommentTopicCloth loomID clothID) -> do + (_, _, Entity _ ticket, _, _, _) <- do + mticket <- lift $ getCloth loomID clothID + fromMaybeE mticket "Context: No such loom-cloth" + let did = ticketDiscuss ticket + _ <- traverse (getMessageParent did) maybeParent + lift $ insertToInbox now author body (actorInbox recipActor) luCreate True + + done $ + case mractid of + Nothing -> "I already have this activity in my inbox, doing nothing" + Just _ -> "Inserted Create{Note} to my inbox" + where + checkContextParent (ObjURI hContext luContext) mparent = do + mdid <- lift $ runMaybeT $ do + iid <- MaybeT $ getKeyBy $ UniqueInstance hContext + roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luContext + rd <- MaybeT $ getValBy $ UniqueRemoteDiscussionIdent roid + return $ remoteDiscussionDiscuss rd + for_ mparent $ \ parent -> + case parent of + Left msg -> do + did <- fromMaybeE mdid "Local parent inexistent, no RemoteDiscussion" + void $ getLocalParentMessageId did msg + Right (ObjURI hParent luParent) -> do + mrm <- lift $ runMaybeT $ do + iid <- MaybeT $ getKeyBy $ UniqueInstance hParent + roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent + MaybeT $ getValBy $ UniqueRemoteMessageIdent roid + for_ mrm $ \ rm -> do + let mid = remoteMessageRest rm + m <- lift $ getJust mid + did <- fromMaybeE mdid "Remote parent known, but no context RemoteDiscussion" + unless (messageRoot m == did) $ + throwE "Remote parent belongs to a different discussion" + +personBehavior :: UTCTime -> PersonId -> Verse -> ActE (Text, Act (), Next) +personBehavior now personID (Left event) = + case event of + EventFwdRemoteGrantToSomeoneElse grantID -> do + lift $ withDB $ do + (_personRecip, actorRecip) <- do + p <- getJust personID + (p,) <$> getJust (personActor p) + let inboxID = actorInbox actorRecip + itemID <- insert $ InboxItem True now + insert_ $ InboxItemRemote inboxID grantID itemID + done "Inserted Grant to inbox" + EventRemoteFwdLocalActivity authorByKey outboxItemID -> withDBExcept $ do + recipPerson <- lift $ getJust personID + verifyLocalActivityExistsInDB authorByKey outboxItemID + if LocalActorPerson personID == authorByKey + then done "Received activity authored by self, ignoring" + else do + inserted <- lift $ insertActivityToInbox now (personActor recipPerson) outboxItemID + done $ + if inserted + then "Activity inserted to my inbox" + else "Activity already exists in my inbox, ignoring" + _ -> throwE $ "Unsupported event for Person: " <> T.pack (show event) +personBehavior now personID (Right (VerseRemote author body mfwd luActivity)) = + case AP.activitySpecific $ actbActivity body of + AP.CreateActivity (AP.Create obj mtarget) -> + case obj of + AP.CreateNote _ note -> + personCreateNote now personID author body mfwd luActivity note + _ -> throwE "Unsupported create object type for people" + {- + AP.FollowActivity follow -> + personFollowA now personID author body mfwd luActivity follow + AP.GrantActivity grant -> + personGrantA now personID author body mfwd luActivity grant + AP.InviteActivity invite -> + personInviteA now personID author body mfwd luActivity invite + AP.UndoActivity undo -> + (,Nothing) <$> personUndoA now personID author body mfwd luActivity undo + -} + _ -> throwE "Unsupported activity type for Person" diff --git a/src/Vervis/Actor/Repo.hs b/src/Vervis/Actor/Repo.hs new file mode 100644 index 0000000..74194ff --- /dev/null +++ b/src/Vervis/Actor/Repo.hs @@ -0,0 +1,64 @@ +{- 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 Vervis.Actor.Repo + ( repoBehavior + ) +where + +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.Monad.Trans.Maybe +import Data.ByteString (ByteString) +import Data.Foldable +import Data.Text (Text) +import Data.Time.Clock +import Database.Persist +import Yesod.Persist.Core + +import qualified Data.Text as T + +import Control.Concurrent.Actor +import Network.FedURI +import Yesod.MonadSite + +import qualified Web.ActivityPub as AP + +import Control.Monad.Trans.Except.Local +import Database.Persist.Local + +import Vervis.Actor +import Vervis.Cloth +import Vervis.Data.Discussion +import Vervis.FedURI +import Vervis.Federation.Util +import Vervis.Foundation +import Vervis.Model +import Vervis.Persist.Discussion +import Vervis.Ticket + +repoBehavior + :: UTCTime -> RepoId -> Verse -> ExceptT Text Act (Text, Act (), Next) +repoBehavior now repoID (Left event) = + case event of + EventRemoteFwdLocalActivity _ _ -> + throwE "Got a forwarded local activity, I don't need those" + _ -> throwE $ "Unsupported event for Repo: " <> T.pack (show event) +repoBehavior now repoID (Right (VerseRemote author body mfwd luActivity)) = + case AP.activitySpecific $ actbActivity body of + _ -> throwE "Unsupported activity type for Repo" diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 0c66623..edd9277 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019, 2020, 2022 + - Written in 2016, 2018, 2019, 2020, 2022, 2023 - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. @@ -32,10 +32,12 @@ module Vervis.Application where import Control.Concurrent.Chan +import Control.Concurrent.STM import Control.Concurrent.STM.TVar import Control.Exception hiding (Handler) import Control.Monad import Control.Monad.Logger (liftLoc, runLoggingT, logInfo, logError) +import Control.Monad.Trans.Except import Control.Monad.Trans.Reader import Data.Bifunctor import Data.Default.Class @@ -47,6 +49,7 @@ import Data.Maybe import Data.Proxy import Data.String import Data.Text (Text) +import Data.Time.Clock import Data.Traversable import Database.Persist.Postgresql import Graphics.SVGFonts.Fonts (lin2) @@ -75,6 +78,7 @@ import Yesod.Persist.Core import Yesod.Static import qualified Data.CaseInsensitive as CI +import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import qualified Database.Esqueleto as E @@ -82,6 +86,7 @@ import Database.Persist.Schema.PostgreSQL (schemaBackend) import Dvara import Yesod.Mail.Send (runMailer) +import Control.Concurrent.Actor import Control.Concurrent.ResultShare import Crypto.ActorKey import Data.KeyFile @@ -94,8 +99,14 @@ import Control.Concurrent.Local import Data.List.NonEmpty.Local import Web.Hashids.Local +import Vervis.Actor +import Vervis.Actor.Deck +import Vervis.Actor.Group +import Vervis.Actor.Loom +import Vervis.Actor.Person +import Vervis.Actor.Repo import Vervis.Darcs -import Vervis.Web.Delivery +import Vervis.Data.Actor import Vervis.Foundation import Vervis.Git import Vervis.Hook @@ -127,6 +138,7 @@ import Vervis.Path import Vervis.Persist.Actor import Vervis.Settings import Vervis.Ssh (runSsh) +import Vervis.Web.Delivery -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the @@ -176,6 +188,9 @@ 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 @@ -189,7 +204,8 @@ makeFoundation appSettings = do let mkFoundation appConnPool appCapSignKey - appHashidsContext = + appHashidsContext + appTheater = App {..} -- The App {..} syntax is an example of record wild cards. For more -- information, see: @@ -199,6 +215,7 @@ makeFoundation appSettings = do (error "connPool forced in tempFoundation") (error "capSignKey forced in tempFoundation") (error "hashidsContext forced in tempFoundation") + (error "theater forced in tempFoundation") logFunc = loggingFunction tempFoundation -- Create the database connection pool @@ -213,7 +230,7 @@ makeFoundation appSettings = do hashidsSalt <- loadKeyFile loadMode $ appHashidsSaltFile appSettings let hashidsCtx = hashidsContext hashidsSalt - app = mkFoundation pool capSignKey hashidsCtx + app = mkFoundation pool capSignKey hashidsCtx (error "theater") -- Perform database migration using our application's logging settings. --runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc @@ -227,6 +244,11 @@ makeFoundation appSettings = do 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 hostString = T.unpack $ renderAuthority hLocal writeHookConfig hostString Config { configSecret = hookSecretText appHookSecret @@ -235,7 +257,7 @@ makeFoundation appSettings = do } -- Return the foundation - return app + return app { appTheater = theater } where verifyRepoDir = do repos <- lift reposFromDir @@ -300,6 +322,23 @@ makeFoundation appSettings = do , T.pack $ show from, " ==> ", T.pack $ show to ] + loadTheatre = concat <$> sequenceA + [ selectAll LocalActorPerson personBehavior + , selectAll LocalActorGroup groupBehavior + , selectAll LocalActorRepo repoBehavior + , selectAll LocalActorDeck deckBehavior + , selectAll LocalActorLoom loomBehavior + ] + where + 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))] + selectAll makeLocalActor behavior = + map (\ xid -> (makeLocalActor xid, behave behavior xid)) <$> + selectKeysList [] [] + -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and -- applying some additional middlewares. makeApplication :: App -> IO Application diff --git a/src/Vervis/Data/Actor.hs b/src/Vervis/Data/Actor.hs index 27f0af3..29883a7 100644 --- a/src/Vervis/Data/Actor.hs +++ b/src/Vervis/Data/Actor.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2022 by fr33domlover . + - Written in 2022, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -21,17 +21,27 @@ module Vervis.Data.Actor , parseStampRoute , localActorID , parseLocalURI - , parseFedURI + , parseFedURIOld , parseLocalActorE ) where +import Control.Concurrent.Chan +import Control.Concurrent.STM.TVar +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Logger.CallStack import Control.Monad.Trans.Except import Data.Text (Text) import Database.Persist.Types +import UnliftIO.Exception (try, SomeException, displayException) + +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T import Network.FedURI import Yesod.ActivityPub +import Yesod.Actor import Yesod.FedURI import Yesod.Hashids import Yesod.MonadSite @@ -76,7 +86,7 @@ parseActivityURI FedURI ) parseActivityURI u@(ObjURI h lu) = do - hl <- hostIsLocal h + hl <- hostIsLocalOld h if hl then Left <$> parseLocalActivityURI lu else pure $ Right u @@ -95,6 +105,8 @@ stampRoute (LocalActorRepo r) = RepoStampR r stampRoute (LocalActorDeck d) = DeckStampR d stampRoute (LocalActorLoom l) = LoomStampR l +parseStampRoute + :: Route App -> Maybe (LocalActorBy KeyHashid, KeyHashid SigKey) parseStampRoute (PersonStampR p i) = Just (LocalActorPerson p, i) parseStampRoute (GroupStampR g i) = Just (LocalActorGroup g, i) parseStampRoute (RepoStampR r i) = Just (LocalActorRepo r, i) @@ -102,18 +114,23 @@ parseStampRoute (DeckStampR d i) = Just (LocalActorDeck d, i) parseStampRoute (LoomStampR l i) = Just (LocalActorLoom l, i) parseStampRoute _ = Nothing +localActorID :: LocalActorBy Entity -> ActorId localActorID (LocalActorPerson (Entity _ p)) = personActor p localActorID (LocalActorGroup (Entity _ g)) = groupActor g localActorID (LocalActorRepo (Entity _ r)) = repoActor r localActorID (LocalActorDeck (Entity _ d)) = deckActor d localActorID (LocalActorLoom (Entity _ l)) = loomActor l -parseLocalURI :: LocalURI -> ExceptT Text Handler (Route App) -parseLocalURI lu = fromMaybeE (decodeRouteLocal lu) "Not a valid route" - -parseFedURI :: FedURI -> ExceptT Text Handler (Either (Route App) FedURI) -parseFedURI u@(ObjURI h lu) = do - hl <- hostIsLocal h +parseFedURIOld + :: ( MonadSite m + , SiteEnv m ~ site + , YesodActivityPub site + , SiteFedURIMode site ~ URIMode + ) + => FedURI + -> ExceptT Text m (Either (Route App) FedURI) +parseFedURIOld u@(ObjURI h lu) = do + hl <- hostIsLocalOld h if hl then Left <$> parseLocalURI lu else pure $ Right u diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index 537febb..c35868f 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2022 by fr33domlover . + - Written in 2022, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -42,6 +42,7 @@ import GHC.Generics import Network.FedURI import Yesod.ActivityPub +import Yesod.Actor import Yesod.FedURI import Yesod.Hashids import Yesod.MonadSite @@ -86,7 +87,7 @@ verifyRole (Right _) = throwE "ForgeFed Admin is the only role allowed currently" parseTopic u = do - routeOrRemote <- parseFedURI u + routeOrRemote <- parseFedURIOld u bitraverse (\ route -> do resourceHash <- @@ -113,7 +114,7 @@ parseInvite sender (AP.Invite instrument object target) = do <*> nameExceptT "Invite object" (parseRecipient object) where parseRecipient u = do - routeOrRemote <- parseFedURI u + routeOrRemote <- parseFedURIOld u bitraverse (\ route -> do recipHash <- @@ -158,7 +159,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 <- hostIsLocal h + hl <- hostIsLocalOld h if hl then Left <$> do route <- @@ -179,7 +180,7 @@ parseGrant (AP.Grant object context target) = do parseGrantResource (LoomR l) = Just $ GrantResourceLoom l parseGrantResource _ = Nothing parseTarget u@(ObjURI h lu) = do - hl <- hostIsLocal h + hl <- hostIsLocalOld h if hl then Left <$> do route <- diff --git a/src/Vervis/Data/Discussion.hs b/src/Vervis/Data/Discussion.hs index 332d0a4..1e5a89d 100644 --- a/src/Vervis/Data/Discussion.hs +++ b/src/Vervis/Data/Discussion.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2016, 2019, 2020, 2022 by fr33domlover . + - Written in 2016, 2019, 2020, 2022, 2023 + - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -18,7 +19,8 @@ module Vervis.Data.Discussion , commentTopicAudience , commentTopicManagingActor , Comment (..) - , parseNewLocalComment + , parseNewLocalCommentOld + , parseRemoteCommentOld , parseRemoteComment , messageRoute ) @@ -29,24 +31,53 @@ import Data.Bitraversable import Data.Text (Text) import Data.Time.Clock +import Control.Concurrent.Actor import Network.FedURI +import Web.Actor.Persist import Web.Text import Yesod.ActivityPub +import Yesod.Actor import Yesod.FedURI -import Yesod.Hashids +import Yesod.MonadSite import qualified Web.ActivityPub as AP +import qualified Yesod.Hashids as YH import Control.Monad.Trans.Except.Local +import Vervis.Actor import Vervis.Data.Actor import Vervis.FedURI import Vervis.Foundation import Vervis.Model import Vervis.Recipient -parseCommentId - :: Route App -> ExceptT Text Handler (LocalActorBy Key, LocalMessageId) +parseCommentIdOld + :: ( MonadSite m + , SiteEnv m ~ site + , YH.YesodHashids site + , SiteFedURIMode site ~ URIMode + ) + => Route App + -> ExceptT Text m (LocalActorBy Key, LocalMessageId) +parseCommentIdOld (PersonMessageR p m) = + (,) <$> (LocalActorPerson <$> YH.decodeKeyHashidE p "Invalid actor keyhashid") + <*> YH.decodeKeyHashidE m "Invalid LocalMessage keyhashid" +parseCommentIdOld (GroupMessageR g m) = + (,) <$> (LocalActorGroup <$> YH.decodeKeyHashidE g "Invalid actor keyhashid") + <*> YH.decodeKeyHashidE m "Invalid LocalMessage keyhashid" +parseCommentIdOld (RepoMessageR r m) = + (,) <$> (LocalActorRepo <$> YH.decodeKeyHashidE r "Invalid actor keyhashid") + <*> YH.decodeKeyHashidE m "Invalid LocalMessage keyhashid" +parseCommentIdOld (DeckMessageR d m) = + (,) <$> (LocalActorDeck <$> YH.decodeKeyHashidE d "Invalid actor keyhashid") + <*> YH.decodeKeyHashidE m "Invalid LocalMessage keyhashid" +parseCommentIdOld (LoomMessageR l m) = + (,) <$> (LocalActorLoom <$> YH.decodeKeyHashidE l "Invalid actor keyhashid") + <*> YH.decodeKeyHashidE m "Invalid LocalMessage keyhashid" +parseCommentIdOld _ = throwE "Not a message route" + +parseCommentId :: Route App -> ActE (LocalActorBy Key, LocalMessageId) parseCommentId (PersonMessageR p m) = (,) <$> (LocalActorPerson <$> decodeKeyHashidE p "Invalid actor keyhashid") <*> decodeKeyHashidE m "Invalid LocalMessage keyhashid" @@ -77,7 +108,24 @@ commentTopicAudience (CommentTopicCloth loomID clothID) = commentTopicManagingActor :: CommentTopic -> LocalActorBy Key commentTopicManagingActor = fst . commentTopicAudience -parseCommentTopic :: Route App -> ExceptT Text Handler CommentTopic +parseCommentTopicOld + :: (MonadSite m, YH.YesodHashids (SiteEnv m)) + => Route App + -> ExceptT Text m CommentTopic +parseCommentTopicOld (TicketR dkhid ltkhid) = + CommentTopicTicket + <$> YH.decodeKeyHashidE dkhid "Invalid dkhid" + <*> YH.decodeKeyHashidE ltkhid "Invalid ltkhid" +parseCommentTopicOld (ClothR lkhid ltkhid) = + CommentTopicCloth + <$> YH.decodeKeyHashidE lkhid "Invalid lkhid" + <*> YH.decodeKeyHashidE ltkhid "Invalid ltkhid" +parseCommentTopicOld _ = throwE "Not a ticket/cloth route" + +parseCommentTopic + :: (MonadActor m, StageHashids (ActorEnv m)) + => Route App + -> ExceptT Text m CommentTopic parseCommentTopic (TicketR dkhid ltkhid) = CommentTopicTicket <$> decodeKeyHashidE dkhid "Invalid dkhid" @@ -95,7 +143,28 @@ data Comment = Comment , commentContent :: HTML } -parseComment :: AP.Note URIMode -> ExceptT Text Handler (Maybe LocalURI, LocalURI, Maybe UTCTime, Comment) +parseCommentOld + :: ( MonadSite m + , SiteEnv m ~ site + , YH.YesodHashids site + , YesodActivityPub site + , SiteFedURIMode site ~ URIMode + ) + => AP.Note URIMode + -> ExceptT Text m (Maybe LocalURI, LocalURI, Maybe UTCTime, Comment) +parseCommentOld (AP.Note mluNote luAttrib _aud muParent muContext mpublished source content) = do + uContext <- fromMaybeE muContext "Note without context" + topic <- bitraverse parseCommentTopicOld pure =<< parseFedURIOld uContext + maybeParent <- do + uParent <- fromMaybeE muParent "Note doesn't specify inReplyTo" + if uParent == uContext + then pure Nothing + else fmap Just . bitraverse parseCommentIdOld pure =<< parseFedURIOld uParent + return (mluNote, luAttrib, mpublished, Comment maybeParent topic source content) + +parseComment + :: AP.Note URIMode + -> ActE (Maybe LocalURI, LocalURI, Maybe UTCTime, Comment) parseComment (AP.Note mluNote luAttrib _aud muParent muContext mpublished source content) = do uContext <- fromMaybeE muContext "Note without context" topic <- bitraverse parseCommentTopic pure =<< parseFedURI uContext @@ -106,10 +175,10 @@ parseComment (AP.Note mluNote luAttrib _aud muParent muContext mpublished source else fmap Just . bitraverse parseCommentId pure =<< parseFedURI uParent return (mluNote, luAttrib, mpublished, Comment maybeParent topic source content) -parseNewLocalComment +parseNewLocalCommentOld :: AP.Note URIMode -> ExceptT Text Handler (PersonId, Comment) -parseNewLocalComment note = do - (mluId, luAuthor, maybePublished, comment) <- parseComment note +parseNewLocalCommentOld note = do + (mluId, luAuthor, maybePublished, comment) <- parseCommentOld note verifyNothingE mluId "Note specifies an id" authorPersonID <- do authorByKey <- @@ -121,9 +190,24 @@ parseNewLocalComment note = do verifyNothingE maybePublished "Note specifies published" return (authorPersonID, comment) +parseRemoteCommentOld + :: ( MonadSite m + , SiteEnv m ~ site + , YH.YesodHashids site + , YesodActivityPub site + , SiteFedURIMode site ~ URIMode + ) + => AP.Note URIMode + -> ExceptT Text m (LocalURI, LocalURI, UTCTime, Comment) +parseRemoteCommentOld note = do + (mluId, luAuthor, maybePublished, comment) <- parseCommentOld note + luId <- fromMaybeE mluId "Note doesn't specify id" + published <- fromMaybeE maybePublished "Note doesn't specify published" + return (luId, luAuthor, published, comment) + parseRemoteComment :: AP.Note URIMode - -> ExceptT Text Handler (LocalURI, LocalURI, UTCTime, Comment) + -> ExceptT Text Act (LocalURI, LocalURI, UTCTime, Comment) parseRemoteComment note = do (mluId, luAuthor, maybePublished, comment) <- parseComment note luId <- fromMaybeE mluId "Note doesn't specify id" diff --git a/src/Vervis/Data/Follow.hs b/src/Vervis/Data/Follow.hs index 15f9985..a898182 100644 --- a/src/Vervis/Data/Follow.hs +++ b/src/Vervis/Data/Follow.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2022 by fr33domlover . + - Written in 2022, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -62,7 +62,7 @@ parseFollow -> ExceptT Text Handler (Either (FolloweeBy Key) (Host, LocalURI, LocalURI), Bool) parseFollow (AP.Follow uObject mluContext hide) = do - routeOrRemote <- parseFedURI uObject + routeOrRemote <- parseFedURIOld uObject (,hide) <$> bitraverse (parseLocal mluContext) diff --git a/src/Vervis/Data/Ticket.hs b/src/Vervis/Data/Ticket.hs index 5c546df..31d3286 100644 --- a/src/Vervis/Data/Ticket.hs +++ b/src/Vervis/Data/Ticket.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2022 by fr33domlover . + - Written in 2022, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -66,6 +66,7 @@ import Development.PatchMediaType import Network.FedURI import Web.Text import Yesod.ActivityPub +import Yesod.Actor import Yesod.FedURI import Yesod.Hashids import Yesod.MonadSite @@ -113,7 +114,7 @@ data WorkItemOffer = WorkItemOffer checkAuthor :: FedURI -> ExceptT Text Handler (Either PersonId FedURI) checkAuthor u@(ObjURI h lu) = do - hl <- hostIsLocal h + hl <- hostIsLocalOld h if hl then do route <- fromMaybeE (decodeRouteLocal lu) "Local author not a valid route" @@ -143,7 +144,7 @@ checkBundle h (AP.BundleOffer mlocal patches) = do checkTipURI :: FedURI -> ExceptT Text Handler (Either RepoId FedURI) checkTipURI u@(ObjURI h lu) = do - hl <- hostIsLocal h + hl <- hostIsLocalOld h if hl then Left <$> do route <- fromMaybeE (decodeRouteLocal lu) "URI is local but isn't a valid route" @@ -177,7 +178,7 @@ checkMR h (AP.MergeRequest muOrigin target mbundle) = checkTracker :: FedURI -> ExceptT Text Handler Tracker checkTracker u@(ObjURI h lu) = do - hl <- hostIsLocal h + hl <- hostIsLocalOld h if hl then do route <- fromMaybeE (decodeRouteLocal lu) "Local tracker not a valid route" @@ -230,7 +231,7 @@ checkOfferTicket host ticket uTarget = do return $ WorkItemOffer author title desc source tam parseBundleRoute name u@(ObjURI h lu) = do - hl <- hostIsLocal h + hl <- hostIsLocalOld h if hl then Left <$> do route <- diff --git a/src/Vervis/Federation/Auth.hs b/src/Vervis/Federation/Auth.hs index e59c7dc..a2bcfb8 100644 --- a/src/Vervis/Federation/Auth.hs +++ b/src/Vervis/Federation/Auth.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. - @@ -14,10 +14,10 @@ -} module Vervis.Federation.Auth - ( RemoteAuthor (..) - , ActivityAuthentication (..) - , ActivityBody (..) - , authenticateActivity + ( --RemoteAuthor (..) + --, ActivityAuthentication (..) + --, ActivityBody (..) + authenticateActivity , checkForwarding ) where @@ -79,6 +79,7 @@ import Network.FedURI import Network.HTTP.Digest import Web.ActivityPub hiding (Follow) import Yesod.ActivityPub +import Yesod.Actor import Yesod.Auth.Unverified import Yesod.FedURI import Yesod.Hashids @@ -94,6 +95,7 @@ import Data.Tuple.Local import Database.Persist.Local import Yesod.Persist.Local +import Vervis.Actor import Vervis.ActivityPub import Vervis.Data.Actor import Vervis.FedURI @@ -104,22 +106,6 @@ import Vervis.Recipient import Vervis.RemoteActorStore import Vervis.Settings -data RemoteAuthor = RemoteAuthor - { remoteAuthorURI :: FedURI - , remoteAuthorInstance :: InstanceId - , remoteAuthorId :: RemoteActorId - } - -data ActivityAuthentication - = ActivityAuthLocal (LocalActorBy Key) - | ActivityAuthRemote RemoteAuthor - -data ActivityBody = ActivityBody - { actbBL :: BL.ByteString - , actbObject :: Object - , actbActivity :: Activity URIMode - } - parseKeyId (KeyId k) = case parseRefURI =<< (first displayException . decodeUtf8') k of Left e -> throwE $ "keyId isn't a valid FedURI: " ++ e @@ -365,7 +351,7 @@ verifyForwardedSig hAuthor luAuthor (Verification malgo keyid input signature) = RefURI hKey luKey <- parseKeyId keyid unless (hAuthor == hKey) $ throwE "Author and forwarded sig key on different hosts" - local <- hostIsLocal hKey + local <- hostIsLocalOld hKey if local then ActivityAuthLocal <$> verifySelfSig luAuthor luKey input signature else ActivityAuthRemote <$> verifyActorSig' malgo input signature hKey luKey (Just luAuthor) diff --git a/src/Vervis/Federation/Collab.hs b/src/Vervis/Federation/Collab.hs index efc6038..dfeb307 100644 --- a/src/Vervis/Federation/Collab.hs +++ b/src/Vervis/Federation/Collab.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2022 by fr33domlover . + - Written in 2022, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -76,6 +76,7 @@ import Yesod.Persist.Local import Vervis.Access import Vervis.ActivityPub +import Vervis.Actor import Vervis.Data.Actor import Vervis.Data.Collab import Vervis.Web.Delivery diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs index 91b0b41..ce31868 100644 --- a/src/Vervis/Federation/Discussion.hs +++ b/src/Vervis/Federation/Discussion.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2022 by fr33domlover . + - Written in 2019, 2020, 2022, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -67,6 +67,7 @@ import Database.Persist.Local import Yesod.Persist.Local import Vervis.ActivityPub +import Vervis.Actor import Vervis.Cloth import Vervis.Data.Discussion import Vervis.FedURI @@ -179,7 +180,7 @@ personCreateNoteF now recipPersonHash author body mfwd luCreate note = do -- Check input recipPersonID <- decodeKeyHashid404 recipPersonHash (luNote, published, Comment maybeParent topic source content) <- do - (luId, luAuthor, published, comment) <- parseRemoteComment note + (luId, luAuthor, published, comment) <- parseRemoteCommentOld note unless (luAuthor == objUriLocal (remoteAuthorURI author)) $ throwE "Create author != note author" return (luId, published, comment) @@ -253,7 +254,7 @@ deckCreateNoteF now recipDeckHash author body mfwd luCreate note = do recipDeckID <- decodeKeyHashid404 recipDeckHash (luNote, published, Comment maybeParent topic source content) <- do - (luId, luAuthor, published, comment) <- parseRemoteComment note + (luId, luAuthor, published, comment) <- parseRemoteCommentOld note unless (luAuthor == objUriLocal (remoteAuthorURI author)) $ throwE "Create author != note author" return (luId, published, comment) @@ -322,7 +323,7 @@ loomCreateNoteF now recipLoomHash author body mfwd luCreate note = do recipLoomID <- decodeKeyHashid404 recipLoomHash (luNote, published, Comment maybeParent topic source content) <- do - (luId, luAuthor, published, comment) <- parseRemoteComment note + (luId, luAuthor, published, comment) <- parseRemoteCommentOld note unless (luAuthor == objUriLocal (remoteAuthorURI author)) $ throwE "Create author != note author" return (luId, published, comment) diff --git a/src/Vervis/Federation/Offer.hs b/src/Vervis/Federation/Offer.hs index d001ef0..0adc841 100644 --- a/src/Vervis/Federation/Offer.hs +++ b/src/Vervis/Federation/Offer.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2022 by fr33domlover . + - Written in 2019, 2020, 2022, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -82,6 +82,7 @@ import Yesod.Persist.Local import Vervis.Access import Vervis.ActivityPub +import Vervis.Actor import Vervis.Cloth import Vervis.Data.Actor import Vervis.FedURI @@ -323,7 +324,7 @@ followF parseFollowee grabActor unread getFollowee getSieve makeLocalActor makeA recipID <- decodeKeyHashid404 recipHash followee <- nameExceptT "Follow object" $ do route <- do - routeOrRemote <- parseFedURI uObject + routeOrRemote <- parseFedURIOld uObject case routeOrRemote of Left route -> pure route Right _ -> throwE "Remote, so definitely not me/mine" diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 6446d80..59a1c5b 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2021, 2022 by fr33domlover . + - Written in 2019, 2020, 2021, 2022, 2023 + - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -95,6 +96,7 @@ import Development.PatchMediaType import Vervis.Access import Vervis.ActivityPub +import Vervis.Actor import Vervis.Cloth import Vervis.Data.Actor import Vervis.Data.Ticket @@ -1902,7 +1904,7 @@ trackerResolveF maybeWorkItem grabActor getWorkItem makeResource trackerFollower recipID <- decodeKeyHashid404 recipHash wiID <- nameExceptT "Resolve object" $ do route <- do - routeOrRemote <- parseFedURI uObject + routeOrRemote <- parseFedURIOld uObject case routeOrRemote of Left route -> pure route Right _ -> throwE "Remote, so definitely not mine" diff --git a/src/Vervis/Federation/Util.hs b/src/Vervis/Federation/Util.hs index 9023831..4871f2f 100644 --- a/src/Vervis/Federation/Util.hs +++ b/src/Vervis/Federation/Util.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020 by fr33domlover . + - Written in 2019, 2020, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -31,6 +31,7 @@ import Network.FedURI import Database.Persist.Local +import Vervis.Actor import Vervis.Federation.Auth import Vervis.Foundation import Vervis.Model diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 0e354c5..93c2238 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019, 2022 by fr33domlover . + - Written in 2016, 2018, 2019, 2022, 2023 + - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -21,6 +22,8 @@ import Control.Concurrent.STM.TVar import Control.Monad import Control.Monad.Logger.CallStack (logWarn) import Control.Monad.Trans.Maybe +import Data.ByteString (ByteString) +import Data.HashMap.Strict (HashMap) import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text) import Data.Text.Encoding @@ -48,10 +51,11 @@ import Yesod.Core.Types import Yesod.Default.Util (addStaticContentExternal) import Yesod.Form.Fields import Yesod.Form.Functions -import Yesod.Form.Types +import Yesod.Form.Types hiding (Env) import Yesod.Persist.Core import Yesod.Static +import qualified Data.Aeson as A import qualified Data.ByteString.Lazy as BL (ByteString) import qualified Data.Time.Units as U import qualified Database.Esqueleto as E @@ -69,21 +73,25 @@ import Yesod.Mail.Send import qualified Network.HTTP.Signature as S (Algorithm (..)) +import Control.Concurrent.Actor hiding (Message) import Crypto.ActorKey import Crypto.PublicVerifKey import Network.FedURI import Web.ActivityAccess +import Web.Actor.Persist import Yesod.ActivityPub +import Yesod.Actor import Yesod.FedURI -import Yesod.Hashids import Yesod.MonadSite import qualified Web.ActivityPub as AP +import qualified Yesod.Hashids as YH import Text.Email.Local import Text.Jasmine.Local (discardm) import Yesod.Paginate.Local +import Vervis.Actor import Vervis.FedURI import Vervis.Hook import Vervis.Model @@ -95,6 +103,10 @@ import Vervis.Settings import Vervis.Style import Vervis.Widget (breadcrumbsW, revisionW) +data ActivityAuthentication + = ActivityAuthLocal (LocalActorBy Key) + | ActivityAuthRemote RemoteAuthor + data ActivityReport = ActivityReport { _arTime :: UTCTime , _arMessage :: Text @@ -120,6 +132,7 @@ data App = App , appHashidsContext :: HashidsContext , appHookSecret :: HookSecret , appActorFetchShare :: ActorFetchShare App + , appTheater :: Theater , appActivities :: Maybe (Int, TVar (Vector ActivityReport)) } @@ -142,6 +155,9 @@ 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 @@ -259,7 +275,7 @@ instance Yesod App where case vs :: [E.Value Int] of [E.Value i] -> return i _ -> error $ "countUnread returned " ++ show vs - hash <- encodeKeyHashid pid + hash <- YH.encodeKeyHashid pid return (p, hash, verified, unread) (title, bcs) <- breadcrumbs @@ -448,7 +464,7 @@ instance Yesod App where person :: KeyHashid Person -> Handler AuthResult person hash = personAnd $ \ (Entity pid _) -> do - hash' <- encodeKeyHashid pid + hash' <- YH.encodeKeyHashid pid return $ if hash == hash' then Authorized else Unauthorized "No access to this operation" @@ -770,7 +786,7 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger -- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain -- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding -instance YesodHashids App where +instance YH.YesodHashids App where siteHashidsContext = appHashidsContext instance YesodRemoteActorStore App where diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index a6a49a9..b04f50f 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019, 2020, 2022 + - Written in 2016, 2018, 2019, 2020, 2022, 2023 - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. @@ -30,6 +30,9 @@ module Vervis.Handler.Client , getPublishOfferMergeR , postPublishOfferMergeR + --, getPublishCommentR + --, postPublishCommentR + , getPublishMergeR , postPublishMergeR ) @@ -1025,7 +1028,7 @@ postPublishOfferMergeR = do (ep@(Entity pid _), a) <- getSender senderHash <- encodeKeyHashid pid - trackerLocal <- hostIsLocal $ objUriAuthority omgTracker + trackerLocal <- hostIsLocalOld $ objUriAuthority omgTracker edest <- runExceptT $ do (summary, audience, ticket) <- offerMerge @@ -1056,6 +1059,65 @@ postPublishOfferMergeR = do else setMessage "Offer published" redirect dest +{- +data Comment = Comment + { commentTopic :: FedURI + , commentParent :: Maybe FedURI + , commentText :: PandocMarkdown + } + +commentForm :: Form Comment +commentForm = Comment + <$> areq fedUriField "Topic" Nothing + <*> aopt fedUriField "Replying to" Nothing + <*> (pandocMarkdownFromText <$> + areq textField "Message" Nothing + ) + +getPublishCommentR :: Handler Html +getPublishCommentR = do + ((_, widget), enctype) <- runFormPost commentForm + defaultLayout + [whamlet| +

Comment on a ticket or a merge request +
+ ^{widget} + + |] + +postPublishCommentR :: Handler () +postPublishCommentR = do + federation <- getsYesod $ appFederation . appSettings + unless federation badMethod + + Comment uTopic uParent source <- + runFormPostRedirect PublishCommentR commentForm + + (ep@(Entity pid _), a) <- getSender + senderHash <- encodeKeyHashid pid + + result <- runExceptT $ do + + + + + + + + (maybeSummary, audience, apply) <- applyPatches senderHash uBundle + (localRecips, remoteRecips, fwdHosts, action) <- + makeServerInput (Just uCap) maybeSummary audience (AP.ApplyActivity apply) + applyC ep a (Just cap) localRecips remoteRecips fwdHosts action apply + + case result of + Left err -> do + setMessage $ toHtml err + redirect PublishMergeR + Right _ -> do + setMessage "Apply activity sent" + redirect HomeR +-} + mergeForm = renderDivs $ (,) <$> areq fedUriField "Patch bundle to apply" Nothing <*> areq capField "Grant activity to use for authorization" Nothing diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index c28b99d..04e65dc 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/src/Vervis/Handler/Deck.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2019, 2022 by fr33domlover . + - Written in 2016, 2019, 2022, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -177,19 +177,11 @@ getDeckInboxR :: KeyHashid Deck -> Handler TypedContent getDeckInboxR = getInbox DeckInboxR deckActor postDeckInboxR :: KeyHashid Deck -> Handler () -postDeckInboxR recipDeckHash = - postInbox $ handleRobotInbox (LocalActorDeck recipDeckHash) handle - where - handle - :: UTCTime - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI - -> SpecificActivity URIMode - -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) - handle now author body mfwd luActivity specific = - case specific of +postDeckInboxR deckHash = do + deckID <- decodeKeyHashid404 deckHash + postInbox $ LocalActorDeck deckID + +{- AP.AcceptActivity accept -> deckAcceptF now recipDeckHash author body mfwd luActivity accept AP.CreateActivity (AP.Create obj mtarget) -> @@ -217,6 +209,7 @@ postDeckInboxR recipDeckHash = AP.UndoActivity undo -> (,Nothing) <$> deckUndoF now recipDeckHash author body mfwd luActivity undo _ -> return ("Unsupported activity type for decks", Nothing) +-} getDeckOutboxR :: KeyHashid Deck -> Handler TypedContent getDeckOutboxR = getOutbox DeckOutboxR DeckOutboxItemR deckActor diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs index ebfa2ae..2d2570c 100644 --- a/src/Vervis/Handler/Group.hs +++ b/src/Vervis/Handler/Group.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2019, 2022 by fr33domlover . + - Written in 2016, 2019, 2022, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -115,20 +115,9 @@ getGroupInboxR :: KeyHashid Group -> Handler TypedContent getGroupInboxR = getInbox GroupInboxR groupActor postGroupInboxR :: KeyHashid Group -> Handler () -postGroupInboxR recipGroupHash = - postInbox $ handleRobotInbox (LocalActorGroup recipGroupHash) handle - where - handle - :: UTCTime - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI - -> AP.SpecificActivity URIMode - -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) - handle _now _author _body _mfwd _luActivity specific = - case specific of - _ -> return ("Unsupported activity type for groups", Nothing) +postGroupInboxR groupHash = do + groupID <- decodeKeyHashid404 groupHash + postInbox $ LocalActorGroup groupID getGroupOutboxR :: KeyHashid Group -> Handler TypedContent getGroupOutboxR = getOutbox GroupOutboxR GroupOutboxItemR groupActor diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs index c70acfa..d229572 100644 --- a/src/Vervis/Handler/Loom.hs +++ b/src/Vervis/Handler/Loom.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2022 by fr33domlover . + - Written in 2022, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -138,19 +138,11 @@ getLoomInboxR :: KeyHashid Loom -> Handler TypedContent getLoomInboxR = getInbox LoomInboxR loomActor postLoomInboxR :: KeyHashid Loom -> Handler () -postLoomInboxR recipLoomHash = - postInbox $ handleRobotInbox (LocalActorLoom recipLoomHash) handle - where - handle - :: UTCTime - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI - -> AP.SpecificActivity URIMode - -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) - handle now author body mfwd luActivity specific = - case specific of +postLoomInboxR loomHash = do + loomID <- decodeKeyHashid404 loomHash + postInbox $ LocalActorLoom loomID + +{- AP.AcceptActivity accept -> loomAcceptF now recipLoomHash author body mfwd luActivity accept AP.ApplyActivity apply-> @@ -176,6 +168,7 @@ postLoomInboxR recipLoomHash = AP.UndoActivity undo -> (,Nothing) <$> loomUndoF now recipLoomHash author body mfwd luActivity undo _ -> return ("Unsupported activity type for looms", Nothing) +-} getLoomOutboxR :: KeyHashid Loom -> Handler TypedContent getLoomOutboxR = getOutbox LoomOutboxR LoomOutboxItemR loomActor diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 5e1cfc9..b016ef3 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019, 2022 by fr33domlover . + - Written in 2016, 2018, 2019, 2022, 2023 + - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -57,6 +58,7 @@ import Text.Email.Local import Network.FedURI import Yesod.ActivityPub +import Yesod.Actor import Yesod.FedURI import Yesod.Hashids import Yesod.MonadSite @@ -138,103 +140,10 @@ getPersonR personHash = do getPersonInboxR :: KeyHashid Person -> Handler TypedContent getPersonInboxR = getInbox PersonInboxR personActor -parseAuthenticatedLocalActivityURI - :: (MonadSite m, YesodHashids (SiteEnv m)) - => LocalActorBy Key -> Maybe LocalURI -> ExceptT Text m OutboxItemId -parseAuthenticatedLocalActivityURI author maybeActivityURI = do - luAct <- fromMaybeE maybeActivityURI "No 'id'" - (actorByKey, _, outboxItemID) <- parseLocalActivityURI luAct - unless (actorByKey == author) $ - throwE "'actor' actor and 'id' actor mismatch" - return outboxItemID - -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 - postPersonInboxR :: KeyHashid Person -> Handler () -postPersonInboxR recipPersonHash = postInbox handle - where - handle - :: UTCTime - -> ActivityAuthentication - -> ActivityBody - -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) - - handle now (ActivityAuthLocal authorByKey) body = (,Nothing) <$> do - outboxItemID <- - parseAuthenticatedLocalActivityURI - authorByKey - (AP.activityId $ actbActivity body) - recipPersonID <- decodeKeyHashid404 recipPersonHash - runDBExcept $ do - recipPerson <- lift $ get404 recipPersonID - verifyLocalActivityExistsInDB authorByKey outboxItemID - if LocalActorPerson recipPersonID == authorByKey - then return "Received activity authored by self, ignoring" - else lift $ do - inserted <- insertActivityToInbox now (personActor recipPerson) outboxItemID - return $ - if inserted - then "Activity inserted to recipient's inbox" - else "Activity already exists in recipient's inbox" - - handle now (ActivityAuthRemote author) body = do - luActivity <- - fromMaybeE (AP.activityId $ actbActivity body) "Activity without 'id'" - localRecips <- do - mrecips <- parseAudience $ AP.activityAudience $ actbActivity body - paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients" - msig <- checkForwarding $ LocalActorPerson recipPersonHash - let mfwd = (localRecips,) <$> msig - case AP.activitySpecific $ actbActivity body of - {- - AcceptActivity accept -> - (,Nothing) <$> sharerAcceptF shrRecip now author body mfwd luActivity accept - AddActivity (AP.Add obj target) -> - case obj of - Right (AddBundle patches) -> - sharerAddBundleF now shrRecip author body mfwd luActivity patches target - _ -> return ("Unsupported add object type for sharers", Nothing) - -} - AP.CreateActivity (AP.Create obj mtarget) -> - case obj of - AP.CreateNote _ note -> - (,Nothing) <$> personCreateNoteF now recipPersonHash author body mfwd luActivity note - _ -> return ("Unsupported create object type for people", Nothing) - AP.FollowActivity follow -> - personFollowF now recipPersonHash author body mfwd luActivity follow - AP.GrantActivity grant -> - personGrantF now recipPersonHash author body mfwd luActivity grant - AP.InviteActivity invite -> - personInviteF now recipPersonHash author body mfwd luActivity invite - {- - OfferActivity (Offer obj target) -> - case obj of - OfferTicket ticket -> - (,Nothing) <$> sharerOfferTicketF now shrRecip author body mfwd luActivity ticket target - OfferDep dep -> - sharerOfferDepF now shrRecip author body mfwd luActivity dep target - _ -> return ("Unsupported offer object type for sharers", Nothing) - PushActivity push -> - (,Nothing) <$> sharerPushF shrRecip now author body mfwd luActivity push - RejectActivity reject -> - (,Nothing) <$> sharerRejectF shrRecip now author body mfwd luActivity reject - ResolveActivity resolve -> - (,Nothing) <$> sharerResolveF now shrRecip author body mfwd luActivity resolve - -} - AP.UndoActivity undo -> - (,Nothing) <$> personUndoF now recipPersonHash author body mfwd luActivity undo - _ -> return ("Unsupported activity type for Person", Nothing) +postPersonInboxR personHash = do + personID <- decodeKeyHashid404 personHash + postInbox $ LocalActorPerson personID getPersonOutboxR :: KeyHashid Person -> Handler TypedContent getPersonOutboxR = getOutbox PersonOutboxR PersonOutboxItemR personActor @@ -253,7 +162,7 @@ postPersonOutboxR personHash = do verifyContentTypeAP AP.Doc h activity <- requireInsecureJsonBody - hl <- hostIsLocal h + hl <- hostIsLocalOld h unless hl $ invalidArgs ["Activity host isn't the instance host"] result <- runExceptT $ do diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 0306a4b..ec0ac26 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019, 2020, 2022 + - Written in 2016, 2018, 2019, 2020, 2022, 2023 - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. @@ -242,19 +242,11 @@ getRepoInboxR :: KeyHashid Repo -> Handler TypedContent getRepoInboxR = getInbox RepoInboxR repoActor postRepoInboxR :: KeyHashid Repo -> Handler () -postRepoInboxR recipRepoHash = - postInbox $ handleRobotInbox (LocalActorRepo recipRepoHash) handle - where - handle - :: UTCTime - -> RemoteAuthor - -> ActivityBody - -> Maybe (RecipientRoutes, ByteString) - -> LocalURI - -> AP.SpecificActivity URIMode - -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) - handle now author body mfwd luActivity specific = - case specific of +postRepoInboxR repoHash = do + repoID <- decodeKeyHashid404 repoHash + postInbox $ LocalActorRepo repoID + +{- AP.AcceptActivity accept -> repoAcceptF now recipRepoHash author body mfwd luActivity accept {- @@ -289,6 +281,7 @@ postRepoInboxR recipRepoHash = AP.UndoActivity undo-> (,Nothing) <$> repoUndoF now recipRepoHash author body mfwd luActivity undo _ -> return ("Unsupported activity type for repos", Nothing) +-} getRepoOutboxR :: KeyHashid Repo -> Handler TypedContent getRepoOutboxR = getOutbox RepoOutboxR RepoOutboxItemR repoActor diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index 9b9dbc0..4b30af8 100644 --- a/src/Vervis/Model.hs +++ b/src/Vervis/Model.hs @@ -85,6 +85,26 @@ instance Hashable RoleId where hashWithSalt salt = hashWithSalt salt . fromSqlKey hash = hash . fromSqlKey +instance Hashable PersonId where + hashWithSalt salt = hashWithSalt salt . fromSqlKey + hash = hash . fromSqlKey + +instance Hashable GroupId where + hashWithSalt salt = hashWithSalt salt . fromSqlKey + hash = hash . fromSqlKey + +instance Hashable RepoId where + hashWithSalt salt = hashWithSalt salt . fromSqlKey + hash = hash . fromSqlKey + +instance Hashable DeckId where + hashWithSalt salt = hashWithSalt salt . fromSqlKey + hash = hash . fromSqlKey + +instance Hashable LoomId where + hashWithSalt salt = hashWithSalt salt . fromSqlKey + hash = hash . fromSqlKey + {- instance PersistEntityGraph Ticket TicketDependency where sourceParam = ticketDependencyParent @@ -106,3 +126,20 @@ instance PersistEntityGraphNumbered Ticket TicketDependency where numberField _ = TicketNumber uniqueNode _ = UniqueTicket -} + +{- +instance VervisActor Person where + type VervisActorForwarder Person = ForwarderPerson + +instance VervisActor Group where + type VervisActorForwarder Group = ForwarderGroup + +instance VervisActor Repo where + type VervisActorForwarder Repo = ForwarderRepo + +instance VervisActor Deck where + type VervisActorForwarder Deck = ForwarderDeck + +instance VervisActor Loom where + type VervisActorForwarder Loom = ForwarderLoom +-} diff --git a/src/Vervis/Persist/Discussion.hs b/src/Vervis/Persist/Discussion.hs index a12184f..b2249e6 100644 --- a/src/Vervis/Persist/Discussion.hs +++ b/src/Vervis/Persist/Discussion.hs @@ -28,6 +28,7 @@ import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader import Data.Graph.Inductive.Graph (mkGraph, lab') import Data.Graph.Inductive.PatriciaTree (Gr) import Data.Graph.Inductive.Query.DFS (dffWith) @@ -158,9 +159,10 @@ getDiscussionTree getdid = sortByTime . discussionTree <$> getAllMessages getdid getMessageFromRoute - :: LocalActorBy Key + :: MonadIO m + => LocalActorBy Key -> LocalMessageId - -> ExceptT Text AppDB + -> ExceptT Text (ReaderT SqlBackend m) ( LocalActorBy Entity , Entity Actor , Entity LocalMessage @@ -187,9 +189,10 @@ getMessageFromRoute authorByKey localMsgID = do ) getLocalParentMessageId - :: DiscussionId + :: MonadIO m + => DiscussionId -> (LocalActorBy Key, LocalMessageId) - -> ExceptT Text AppDB MessageId + -> ExceptT Text (ReaderT SqlBackend m) MessageId getLocalParentMessageId discussionID (authorByKey, localMsgID) = do (_, _, _, Entity msgID msg) <- getMessageFromRoute authorByKey localMsgID unless (messageRoot msg == discussionID) $ @@ -200,9 +203,10 @@ getLocalParentMessageId discussionID (authorByKey, localMsgID) = do -- know and have this parent note in the DB, and whether the child and parent -- belong to the same discussion root. getMessageParent - :: DiscussionId + :: MonadIO m + => DiscussionId -> Either (LocalActorBy Key, LocalMessageId) FedURI - -> ExceptT Text AppDB (Either MessageId FedURI) + -> ExceptT Text (ReaderT SqlBackend m) (Either MessageId FedURI) getMessageParent did (Left msg) = Left <$> getLocalParentMessageId did msg getMessageParent did (Right p@(ObjURI hParent luParent)) = do mrm <- lift $ runMaybeT $ do diff --git a/src/Vervis/Recipient.hs b/src/Vervis/Recipient.hs index 5e4eb83..d58977c 100644 --- a/src/Vervis/Recipient.hs +++ b/src/Vervis/Recipient.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2022 by fr33domlover . + - Written in 2019, 2020, 2022, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -121,6 +121,7 @@ import qualified Data.Text as T import Network.FedURI import Yesod.ActivityPub +import Yesod.Actor import Yesod.FedURI import Yesod.Hashids import Yesod.MonadSite @@ -130,6 +131,7 @@ import qualified Web.ActivityPub as AP import Data.List.Local import Data.List.NonEmpty.Local +import Vervis.Actor import Vervis.FedURI import Vervis.Foundation import Vervis.Model @@ -142,17 +144,6 @@ import Vervis.Model -- types, then you can do any further parsing and grouping. ------------------------------------------------------------------------------- -data LocalActorBy f - = LocalActorPerson (f Person) - | LocalActorGroup (f Group) - | LocalActorRepo (f Repo) - | LocalActorDeck (f Deck) - | LocalActorLoom (f Loom) - deriving (Generic, FunctorB, ConstraintsB) - -deriving instance AllBF Eq f LocalActorBy => Eq (LocalActorBy f) -deriving instance AllBF Ord f LocalActorBy => Ord (LocalActorBy f) - {- instance (Eq (f Person), Eq (f Group), Eq (f Repo), Eq (f Deck), Eq (f Loom)) => Eq (LocalActorBy f) where (==) (LocalActorPerson p) (LocalActorPerson p') = p == p' @@ -175,8 +166,6 @@ instance (Ord (f Person), Ord (f Group), Ord (f Repo), Ord (f Deck), Ord (f Loom (<=) (LocalActorGroup _) _ = True -} -type LocalActor = LocalActorBy KeyHashid - parseLocalActor :: Route App -> Maybe LocalActor parseLocalActor (PersonR pkhid) = Just $ LocalActorPerson pkhid parseLocalActor (GroupR gkhid) = Just $ LocalActorGroup gkhid @@ -504,67 +493,6 @@ recipientFromStage (LocalStageClothFollowers lkhid ltkhid) = -- logic rather than plain lists of routes. ------------------------------------------------------------------------------- -data TicketRoutes = TicketRoutes - { routeTicketFollowers :: Bool - } - deriving Eq - -data ClothRoutes = ClothRoutes - { routeClothFollowers :: Bool - } - deriving Eq - -data PersonRoutes = PersonRoutes - { routePerson :: Bool - , routePersonFollowers :: Bool - } - deriving Eq - -data GroupRoutes = GroupRoutes - { routeGroup :: Bool - , routeGroupFollowers :: Bool - } - deriving Eq - -data RepoRoutes = RepoRoutes - { routeRepo :: Bool - , routeRepoFollowers :: Bool - } - deriving Eq - -data DeckRoutes = DeckRoutes - { routeDeck :: Bool - , routeDeckFollowers :: Bool - } - deriving Eq - -data LoomRoutes = LoomRoutes - { routeLoom :: Bool - , routeLoomFollowers :: Bool - } - deriving Eq - -data DeckFamilyRoutes = DeckFamilyRoutes - { familyDeck :: DeckRoutes - , familyTickets :: [(KeyHashid TicketDeck, TicketRoutes)] - } - deriving Eq - -data LoomFamilyRoutes = LoomFamilyRoutes - { familyLoom :: LoomRoutes - , familyCloths :: [(KeyHashid TicketLoom, ClothRoutes)] - } - deriving Eq - -data RecipientRoutes = RecipientRoutes - { recipPeople :: [(KeyHashid Person, PersonRoutes)] - , recipGroups :: [(KeyHashid Group , GroupRoutes)] - , recipRepos :: [(KeyHashid Repo , RepoRoutes)] - , recipDecks :: [(KeyHashid Deck , DeckFamilyRoutes)] - , recipLooms :: [(KeyHashid Loom , LoomFamilyRoutes)] - } - deriving Eq - groupLocalRecipients :: [LocalRecipient] -> RecipientRoutes groupLocalRecipients = organize . partitionByActor where diff --git a/src/Vervis/RemoteActorStore.hs b/src/Vervis/RemoteActorStore.hs index 82fd42c..59505f4 100644 --- a/src/Vervis/RemoteActorStore.hs +++ b/src/Vervis/RemoteActorStore.hs @@ -511,6 +511,7 @@ actorFetchShareAction u (site, iid) = flip runWorkerT site $ do for_ mroid $ \ roid -> insertUnique_ $ RemoteCollection roid return Nothing + -- TODO see https://vervis.peers.community/decks/br6Go/tickets/r7dDo fetchRemoteActor :: ( YesodPersist site diff --git a/src/Vervis/Web/Actor.hs b/src/Vervis/Web/Actor.hs index f895905..8ce60a4 100644 --- a/src/Vervis/Web/Actor.hs +++ b/src/Vervis/Web/Actor.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2022 by fr33domlover . + - Written in 2019, 2020, 2022, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -71,6 +71,7 @@ import qualified Data.Text.Lazy as TL import qualified Data.Vector as V import qualified Database.Esqueleto as E +import Control.Concurrent.Actor import Crypto.ActorKey import Database.Persist.JSON import Network.FedURI @@ -94,6 +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.ActivityPub import Vervis.API import Vervis.Data.Actor @@ -226,47 +228,48 @@ getInbox here actor hash = do where ibiidString = "InboxItem #" ++ show (fromSqlKey ibid) -postInbox - :: ( UTCTime - -> ActivityAuthentication - -> ActivityBody - -> ExceptT Text Handler - ( Text - , Maybe (ExceptT Text Worker Text) - ) - ) - -> Handler () -postInbox handler = do +postInbox :: LocalActorBy Key -> Handler () +postInbox recipByKey = do federation <- getsYesod $ appFederation . appSettings unless federation badMethod contentTypes <- lookupHeaders "Content-Type" now <- liftIO getCurrentTime result <- runExceptT $ do (auth, body) <- authenticateActivity now - (actbObject body,) <$> handler now auth body + verse <- + case auth of + ActivityAuthLocal authorByKey -> Left <$> do + outboxItemID <- + parseAuthenticatedLocalActivityURI + authorByKey + (AP.activityId $ actbActivity body) + return $ EventRemoteFwdLocalActivity authorByKey outboxItemID + ActivityAuthRemote author -> Right <$> do + luActivity <- + fromMaybeE (AP.activityId $ actbActivity body) "Activity without 'id'" + localRecips <- do + mrecips <- parseAudience $ AP.activityAudience $ actbActivity body + paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients" + recipByHash <- hashLocalActor recipByKey + msig <- checkForwarding recipByHash + let mfwd = (localRecips,) <$> msig + return $ VerseRemote author body mfwd luActivity + theater <- getsYesod appTheater + r <- liftIO $ callIO theater recipByKey verse + case r of + Nothing -> notFound + Just (Left e) -> throwE e + Just (Right t) -> return (actbObject body, t) recordActivity now result contentTypes case result of Left err -> do logDebug err sendResponseStatus badRequest400 err - Right (obj, (_, mworker)) -> - for_ mworker $ \ worker -> forkWorker "postInbox worker" $ do - wait <- asyncWorker $ runExceptT worker - result' <- wait - let result'' = - case result' of - Left e -> Left $ T.pack $ displayException e - Right (Left e) -> Left e - Right (Right t) -> Right (obj, (t, Nothing)) - now' <- liftIO getCurrentTime - recordActivity now' result'' contentTypes - case result'' of - Left err -> logDebug err - Right _ -> return () + Right _ -> return () where recordActivity :: (MonadSite m, SiteEnv m ~ App) - => UTCTime -> Either Text (Object, (Text, w)) -> [ContentType] -> m () + => UTCTime -> Either Text (Object, Text) -> [ContentType] -> m () recordActivity now result contentTypes = do macts <- asksSite appActivities for_ macts $ \ (size, acts) -> @@ -274,12 +277,21 @@ postInbox handler = do let (msg, body) = case result of Left t -> (t, "{?}") - Right (o, (t, _)) -> (t, encodePretty o) + Right (o, t) -> (t, encodePretty o) item = ActivityReport now msg contentTypes body vec' = item `V.cons` vec in if V.length vec' > size then V.init vec' else vec' + parseAuthenticatedLocalActivityURI + :: (MonadSite m, YesodHashids (SiteEnv m)) + => LocalActorBy Key -> Maybe LocalURI -> ExceptT Text m OutboxItemId + parseAuthenticatedLocalActivityURI author maybeActivityURI = do + luAct <- fromMaybeE maybeActivityURI "No 'id'" + (actorByKey, _, outboxItemID) <- parseLocalActivityURI luAct + unless (actorByKey == author) $ + throwE "'actor' actor and 'id' actor mismatch" + return outboxItemID getOutbox here itemRoute grabActorID hash = do key <- decodeKeyHashid404 hash diff --git a/src/Vervis/Web/Delivery.hs b/src/Vervis/Web/Delivery.hs index 386cdd0..3eab78c 100644 --- a/src/Vervis/Web/Delivery.hs +++ b/src/Vervis/Web/Delivery.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2021, 2022 by fr33domlover . + - Written in 2019, 2020, 2021, 2022, 2023 + - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -31,12 +32,15 @@ module Vervis.Web.Delivery fixRunningDeliveries , retryOutboxDelivery + , deliverActivityDB_Live , deliverActivityDB + , forwardActivityDB_Live , forwardActivityDB ) where import Control.Applicative +import Control.Concurrent.Chan import Control.Concurrent.STM.TVar import Control.Exception hiding (Handler, try) import Control.Monad @@ -63,11 +67,14 @@ import Database.Persist.Sql import Yesod.Core hiding (logError, logWarn, logInfo, logDebug) import qualified Data.ByteString.Lazy as BL +import qualified Data.HashMap.Strict as HM +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 Database.Persist.JSON import Network.FedURI @@ -82,6 +89,7 @@ import Data.Maybe.Local import Data.Tuple.Local import Database.Persist.Local +import Vervis.Actor import Vervis.ActivityPub import Vervis.Data.Actor import Vervis.FedURI @@ -557,13 +565,23 @@ deliverRemoteHttp hContexts obid envelope (fetched, unfetched, unknown) = do -- * 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 ) - => (InboxId -> InboxItemId -> record) - -- ^ Database record to insert as an new inbox item to each inbox + => 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 @@ -577,7 +595,7 @@ insertActivityToLocalInboxes -- author. -> RecipientRoutes -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)] -insertActivityToLocalInboxes makeInboxItem requireOwner mauthor maidAuthor recips = do +insertActivityToLocalInboxes event makeInboxItem requireOwner mauthor maidAuthor recips = do -- Unhash actor and work item hashids people <- unhashKeys $ recipPeople recips @@ -625,7 +643,7 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor maidAuthor recip loomIDsForSelf = [ key | (key, (routes, _)) <- loomsAndCloths, routeLoom routes ] - -- Grab actor actors whose followers are going to be delivered to + -- Grab local actors whose followers are going to be delivered to let personIDsForFollowers = [ key | (key, routes) <- peopleForStages, routePersonFollowers routes ] groupIDsForFollowers = @@ -658,9 +676,9 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor maidAuthor recip loomsAndClothsForStages -- Get addressed Actor IDs from DB + -- Except for Person actors, we'll send to them via actor system actorIDsForSelf <- orderedUnion <$> sequenceA - [ selectActorIDsOrdered personActor PersonActor personIDsForSelf - , selectActorIDsOrdered groupActor GroupActor groupIDsForSelf + [ selectActorIDsOrdered groupActor GroupActor groupIDsForSelf , selectActorIDsOrdered repoActor RepoActor repoIDsForSelf , selectActorIDsOrdered deckActor DeckActor deckIDsForSelf , selectActorIDsOrdered loomActor LoomActor loomIDsForSelf @@ -694,15 +712,27 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor maidAuthor recip ) -- Get the local and remote followers of the follower sets from DB - localFollowers <- - map (followActor . entityVal) <$> - selectList [FollowTarget <-. followerSetIDs] [Asc FollowActor] + 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 localFollowers actorIDsForSelf + let allLocal = LO.union localFollowersDB actorIDsForSelf in case maidAuthor of Nothing -> allLocal Just actorID -> LO.minus' allLocal [actorID] @@ -713,6 +743,14 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor maidAuthor recip 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 @@ -814,16 +852,19 @@ insertActivityToLocalInboxes makeInboxItem requireOwner mauthor maidAuthor recip -- * 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 deliverLocal' - :: (MonadSite m, YesodHashids (SiteEnv m)) + :: (MonadSite m, YesodHashids (SiteEnv m), SiteEnv m ~ App) => Bool -- ^ Whether to deliver to collection only if owner actor is addressed -> LocalActor -> ActorId -> OutboxItemId + -> Event -> RecipientRoutes -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)] -deliverLocal' requireOwner author aidAuthor obiid = - insertActivityToLocalInboxes makeItem requireOwner (Just author) (Just aidAuthor) +deliverLocal' requireOwner author aidAuthor obiid event = + insertActivityToLocalInboxes event makeItem requireOwner (Just author) (Just aidAuthor) where makeItem ibid ibiid = InboxItemLocal ibid obiid ibiid @@ -834,30 +875,35 @@ deliverLocal' requireOwner author aidAuthor obiid = -- * If the author's follower collection is listed, insert activity to the -- local members and return the remote members -- * Ignore other collections +-- +-- NOTE transition to live actors deliverLocal :: KeyHashid Person -> ActorId -> OutboxItemId + -> Event -> RecipientRoutes -> AppDB [ ( (InstanceId, Host) , NonEmpty RemoteRecipient ) ] -deliverLocal authorHash aidAuthor obiid - = deliverLocal' True (LocalActorPerson authorHash) aidAuthor obiid +deliverLocal authorHash aidAuthor obiid event + = deliverLocal' True (LocalActorPerson authorHash) aidAuthor obiid event . localRecipSieve sieve True where sieve = RecipientRoutes [(authorHash, PersonRoutes False True)] [] [] [] [] +-- NOTE transition to live actors insertRemoteActivityToLocalInboxes - :: (MonadSite m, YesodHashids (SiteEnv m)) + :: (MonadSite m, YesodHashids (SiteEnv m), SiteEnv m ~ App) => Bool -> RemoteActivityId + -> Event -> RecipientRoutes -> ReaderT SqlBackend m [((InstanceId, Host), NonEmpty RemoteRecipient)] -insertRemoteActivityToLocalInboxes requireOwner ractid = - insertActivityToLocalInboxes makeItem requireOwner Nothing Nothing +insertRemoteActivityToLocalInboxes requireOwner ractid event = + insertActivityToLocalInboxes event makeItem requireOwner Nothing Nothing where makeItem ibid ibiid = InboxItemRemote ibid ractid ibiid @@ -1262,7 +1308,8 @@ retryOutboxDelivery = do logInfo "Periodic delivery done" -deliverActivityDB +-- NOTE transition to live actors +deliverActivityDB_Live :: (MonadSite m, SiteEnv m ~ App) => LocalActorBy KeyHashid -> ActorId @@ -1270,10 +1317,11 @@ deliverActivityDB -> [(Host, NonEmpty LocalURI)] -> [Host] -> OutboxItemId + -> Event -> AP.Action URIMode -> ExceptT Text (ReaderT SqlBackend m) (Worker ()) -deliverActivityDB senderByHash senderActorID localRecips remoteRecips fwdHosts itemID action = do - moreRemoteRecips <- lift $ deliverLocal' True senderByHash senderActorID itemID localRecips +deliverActivityDB_Live senderByHash senderActorID localRecips remoteRecips fwdHosts itemID event action = do + moreRemoteRecips <- lift $ deliverLocal' True senderByHash senderActorID itemID event localRecips checkFederation moreRemoteRecips remoteRecipsHttp <- lift $ deliverRemoteDB fwdHosts itemID remoteRecips moreRemoteRecips envelope <- lift $ prepareSendP senderActorID senderByHash itemID action @@ -1284,7 +1332,12 @@ deliverActivityDB senderByHash senderActorID localRecips remoteRecips fwdHosts i unless (federation || null remoteRecips) $ throwE "Federation disabled, but remote recipients found" -forwardActivityDB +-- 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 :: (MonadSite m, SiteEnv m ~ App) => BL.ByteString -> RecipientRoutes @@ -1293,13 +1346,18 @@ forwardActivityDB -> LocalActorBy KeyHashid -> RecipientRoutes -> RemoteActivityId + -> Event -> ReaderT SqlBackend m (Worker ()) -forwardActivityDB body localRecips sig fwderActorID fwderByHash sieve activityID = do +forwardActivityDB_Live body localRecips sig fwderActorID fwderByHash sieve activityID event = do let localRecipsFinal = localRecipSieve' sieve False False localRecips remoteRecips <- - insertRemoteActivityToLocalInboxes False activityID localRecipsFinal + insertRemoteActivityToLocalInboxes False activityID event localRecipsFinal remoteRecipsHttp <- forwardRemoteDB body activityID fwderActorID sig remoteRecips errand <- 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/ActivityPub.hs b/src/Web/ActivityPub.hs index 9db737b..e66f92a 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2021, 2022 by fr33domlover . + - Written in 2019, 2020, 2021, 2022, 2023 + - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -79,6 +80,7 @@ module Web.ActivityPub , Undo (..) , Audience (..) , SpecificActivity (..) + , activityType , Action (..) , makeActivity , Activity (..) @@ -174,6 +176,119 @@ import Web.Text import Data.Aeson.Local +{- +data Link = Link + { linkHref :: URI + , linkRel :: + , linkMediaType :: + , linkName :: + , linkHreflang :: + , linkHeight :: + , linkWidth :: + , linkPreview :: + , linkRest :: Object + } + +data X = X + { xId :: LocalURI + , x + } + +data Object' u = Object' + { objectId :: ObjURI + , objectType :: + + , objectSubject :: + , objectRelationship :: + , objectActor :: + , objectAttributedTo :: + , objectAttachment :: + , objectBcc :: + , objectBto :: + , objectCc :: + , objectContext :: + , objectCurrent :: + , objectFirst :: + , objectGenerator :: + , objectIcon :: + , objectImage :: + , objectInReplyTo :: + , objectItems :: + , objectInstrument :: + , objectOrderedItems :: + , objectLast :: + , objectLocation :: + , objectNext :: + , objectObject :: + , objectOneOf :: + , objectAnyOf :: + , objectClosed :: + , objectOrigin :: + , objectAccuracy :: + , objectPrev :: + , objectPreview :: + , objectProvider :: + , objectReplies :: + , objectResult :: + , objectAudience :: + , objectPartOf :: + , objectTag :: + , objectTags :: + , objectTarget :: + , objectTo :: + , objectUrl :: + , objectAltitude :: + , objectContent :: + , objectContentMap :: + , objectName :: + , objectNameMap :: + , objectDuration :: + , objectEndTime :: + , objectHeight :: + , objectHref :: + , objectHreflang :: + , objectLatitude :: + , objectLongitude :: + , objectMediaType :: + , objectPublished :: + , objectRadius :: + , objectRating :: + , objectRel :: + , objectStartIndex :: + , objectStartTime :: + , objectSummary :: + , objectSummaryMap :: + , objectTotalItems :: + , objectUnits :: + , objectUpdated :: + , objectWidth :: + , objectDescribes :: + , objectFormerType :: + , objectDeleted :: + + , objectEndpoints :: + , objectFollowing :: + , objectFollowers :: + , objectInbox :: + , objectLiked :: + , objectShares :: + , objectLikes :: + , objectOauthAuthorizationEndpoint :: + , objectOauthTokenEndpoint :: + , objectOutbox :: + , objectPreferredUsername :: + , objectProvideClientKey :: + , objectProxyUrl :: + , objectSharedInbox :: + , objectSignClientKey :: + , objectSource :: + , objectStreams :: + , objectUploadMedia :: + + , objectRest :: Object + } +-} + proxy :: a u -> Proxy a proxy _ = Proxy @@ -1712,6 +1827,21 @@ data SpecificActivity u | ResolveActivity (Resolve u) | UndoActivity (Undo u) +activityType :: SpecificActivity u -> Text +activityType (AcceptActivity _) = "Accept" +activityType (AddActivity _) = "Add" +activityType (ApplyActivity _) = "Apply" +activityType (CreateActivity _) = "Create" +activityType (FollowActivity _) = "Follow" +activityType (GrantActivity _) = "Grant" +activityType (InviteActivity _) = "Invite" +activityType (JoinActivity _) = "Join" +activityType (OfferActivity _) = "Offer" +activityType (PushActivity _) = "Push" +activityType (RejectActivity _) = "Reject" +activityType (ResolveActivity _) = "Resolve" +activityType (UndoActivity _) = "Undo" + data Action u = Action { actionCapability :: Maybe (ObjURI u) , actionSummary :: Maybe HTML @@ -1782,20 +1912,6 @@ instance ActivityPub Activity where <> "fulfills" .=% fulfills <> encodeSpecific authority actor specific where - activityType :: SpecificActivity u -> Text - activityType (AcceptActivity _) = "Accept" - activityType (AddActivity _) = "Add" - activityType (ApplyActivity _) = "Apply" - activityType (CreateActivity _) = "Create" - activityType (FollowActivity _) = "Follow" - activityType (GrantActivity _) = "Grant" - activityType (InviteActivity _) = "Invite" - activityType (JoinActivity _) = "Join" - activityType (OfferActivity _) = "Offer" - activityType (PushActivity _) = "Push" - activityType (RejectActivity _) = "Reject" - activityType (ResolveActivity _) = "Resolve" - activityType (UndoActivity _) = "Undo" encodeSpecific h _ (AcceptActivity a) = encodeAccept h a encodeSpecific h _ (AddActivity a) = encodeAdd h a encodeSpecific _ _ (ApplyActivity a) = encodeApply a diff --git a/src/Web/Actor.hs b/src/Web/Actor.hs new file mode 100644 index 0000000..f66654a --- /dev/null +++ b/src/Web/Actor.hs @@ -0,0 +1,51 @@ +{- This file is part of Vervis. + - + - Written in 2019, 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 + - . + -} + +-- | 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. +-- +-- At the time of writing (April 2023), this module is collecting the pieces +-- that aren't tied to a specific web framework. Yesod-specific parts are in +-- separate modules. +-- +-- Ideally, the whole application structure would be specified using +-- framework-independent tools, and framework integration (right now just +-- Yesod, might also be Servant in the future) would be an automatic or +-- auto-generated nearly-seamless part. I hope to get there, gradually, in +-- steps of refactoring. +module Web.Actor + ( StageWeb (..) + , ActForE + , hostIsLocal + ) +where + +import Control.Monad.Trans.Except +import Data.Text (Text) + +import Control.Concurrent.Actor +import Network.FedURI + +class (Stage s, UriMode (StageURIMode s)) => StageWeb s where + type StageURIMode s + stageInstanceHost :: s -> Authority (StageURIMode s) + +type ActForE s = ExceptT Text (ActFor s) + +hostIsLocal + :: (MonadActor m, ActorEnv m ~ s, StageWeb s) + => Authority (StageURIMode s) -> m Bool +hostIsLocal h = asksEnv $ (== h) . stageInstanceHost diff --git a/src/Web/Actor/Persist.hs b/src/Web/Actor/Persist.hs new file mode 100644 index 0000000..e3b4184 --- /dev/null +++ b/src/Web/Actor/Persist.hs @@ -0,0 +1,137 @@ +{- 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 + - . + -} + +module Web.Actor.Persist + ( StageHashids (..) + , KeyHashid () + , keyHashidText + + , encodeKeyHashidPure + --, getEncodeKeyHashid + --, encodeKeyHashid + + , decodeKeyHashidPure + --, decodeKeyHashid + --, decodeKeyHashidF + --, decodeKeyHashidM + , decodeKeyHashidE + ) +where + +import Prelude hiding (fail) + +import Control.Monad.Fail +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe +import Data.Text (Text) +import Data.Text.Encoding +import Database.Persist.Class +import Database.Persist.Sql +import Web.Hashids +import Web.PathPieces + +import Control.Concurrent.Actor +import Web.Actor +--import Yesod.MonadActor + +import Web.Hashids.Local + +class StageWeb s => StageHashids s where + stageHashidsContext :: s -> HashidsContext + +newtype KeyHashid record = KeyHashid + { keyHashidText :: Text + } + deriving (Eq, Ord, Read, Show) + +instance PersistEntity record => PathPiece (KeyHashid record) where + fromPathPiece t = KeyHashid <$> fromPathPiece t + toPathPiece (KeyHashid t) = toPathPiece t + +encodeKeyHashidPure + :: ToBackendKey SqlBackend record + => HashidsContext -> Key record -> KeyHashid record +encodeKeyHashidPure ctx = KeyHashid . decodeUtf8 . encodeInt64 ctx . fromSqlKey + +getEncodeKeyHashid + :: ( MonadActor m + , StageHashids (ActorEnv m) + , ToBackendKey SqlBackend record + ) + => m (Key record -> KeyHashid record) +getEncodeKeyHashid = do + ctx <- asksEnv stageHashidsContext + return $ encodeKeyHashidPure ctx + +encodeKeyHashid + :: ( MonadActor m + , StageHashids (ActorEnv m) + , ToBackendKey SqlBackend record + ) + => Key record + -> m (KeyHashid record) +encodeKeyHashid k = do + enc <- getEncodeKeyHashid + return $ enc k + +decodeKeyHashidPure + :: ToBackendKey SqlBackend record + => HashidsContext + -> KeyHashid record + -> Maybe (Key record) +decodeKeyHashidPure ctx (KeyHashid t) = + fmap toSqlKey $ decodeInt64 ctx $ encodeUtf8 t + +decodeKeyHashid + :: ( MonadActor m + , StageHashids (ActorEnv m) + , ToBackendKey SqlBackend record + ) + => KeyHashid record + -> m (Maybe (Key record)) +decodeKeyHashid khid = do + ctx <- asksEnv stageHashidsContext + return $ decodeKeyHashidPure ctx khid + +decodeKeyHashidF + :: ( MonadFail m + , MonadActor m + , StageHashids (ActorEnv m) + , ToBackendKey SqlBackend record + ) + => KeyHashid record + -> String + -> m (Key record) +decodeKeyHashidF khid e = maybe (fail e) return =<< decodeKeyHashid khid + +decodeKeyHashidM + :: ( MonadActor m + , StageHashids (ActorEnv m) + , ToBackendKey SqlBackend record + ) + => KeyHashid record + -> MaybeT m (Key record) +decodeKeyHashidM = MaybeT . decodeKeyHashid + +decodeKeyHashidE + :: ( MonadActor m + , StageHashids (ActorEnv m) + , ToBackendKey SqlBackend record + ) + => KeyHashid record + -> e + -> ExceptT e m (Key record) +decodeKeyHashidE khid e = + ExceptT $ maybe (Left e) Right <$> decodeKeyHashid khid diff --git a/src/Yesod/ActivityPub.hs b/src/Yesod/ActivityPub.hs index c346760..9238a3b 100644 --- a/src/Yesod/ActivityPub.hs +++ b/src/Yesod/ActivityPub.hs @@ -34,7 +34,7 @@ module Yesod.ActivityPub , provideHtmlAndAP'' , provideHtmlFeedAndAP - , hostIsLocal + , hostIsLocalOld , verifyHostLocal ) where @@ -576,14 +576,14 @@ provideHtmlFeedAndAP object feed widget = do widget (Just feed) -hostIsLocal +hostIsLocalOld :: (MonadSite m, SiteEnv m ~ site, YesodActivityPub site) => Authority (SiteFedURIMode site) -> m Bool -hostIsLocal h = asksSite $ (== h) . siteInstanceHost +hostIsLocalOld h = asksSite $ (== h) . siteInstanceHost verifyHostLocal :: (MonadSite m, SiteEnv m ~ site, YesodActivityPub site) => Authority (SiteFedURIMode site) -> Text -> ExceptT Text m () verifyHostLocal h t = do - local <- hostIsLocal h + local <- hostIsLocalOld h unless local $ throwE t diff --git a/src/Yesod/Actor.hs b/src/Yesod/Actor.hs new file mode 100644 index 0000000..7a1b1d3 --- /dev/null +++ b/src/Yesod/Actor.hs @@ -0,0 +1,56 @@ +{- This file is part of Vervis. + - + - Written 2019, 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 + - . + -} + +-- | Tools for integrating 'Web.Actor' with the Yesod web framework. +module Yesod.Actor + ( decodeRouteLocal + , parseLocalURI + , StageYesod (..) + , parseFedURI + ) +where + +import Control.Monad.Trans.Except +import Data.Text (Text) +import Data.Text.Encoding +import Network.HTTP.Types.URI +import Yesod.Core + +import Network.FedURI +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 diff --git a/src/Yesod/FedURI.hs b/src/Yesod/FedURI.hs index 50a8cd8..007f025 100644 --- a/src/Yesod/FedURI.hs +++ b/src/Yesod/FedURI.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written 2019 by fr33domlover . + - Written in 2019 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -18,19 +18,14 @@ module Yesod.FedURI , getEncodeRouteLocal , getEncodeRouteHome , getEncodeRouteFed - , decodeRouteLocal , getEncodeRoutePageLocal , getEncodeRoutePageHome , getEncodeRoutePageFed ) where -import Data.Text.Encoding -import Network.HTTP.Types.URI import Yesod.Core -import qualified Data.Text as T - import Network.FedURI import Yesod.MonadSite @@ -63,10 +58,6 @@ getEncodeRouteFed => m (Authority u -> Route site -> ObjURI u) getEncodeRouteFed = (\ f a -> ObjURI a . f) <$> getEncodeRouteLocal -decodeRouteLocal :: ParseRoute site => LocalURI -> Maybe (Route site) -decodeRouteLocal = - parseRoute . (,[]) . decodePathSegments . encodeUtf8 . localUriPath - getEncodeRoutePageLocal :: (MonadSite m, SiteEnv m ~ site, SiteFedURI site, YesodPaginate site) => m (Route site -> Int -> LocalPageURI) diff --git a/src/Yesod/Hashids.hs b/src/Yesod/Hashids.hs index 59cd537..0e0f269 100644 --- a/src/Yesod/Hashids.hs +++ b/src/Yesod/Hashids.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2022 by fr33domlover . + - Written in 2019, 2020, 2022, 2023 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -15,7 +15,7 @@ module Yesod.Hashids ( YesodHashids (..) - , KeyHashid () + , KeyHashid , keyHashidText , encodeKeyHashidPure @@ -44,6 +44,7 @@ import Web.Hashids import Web.PathPieces import Yesod.Core +import Web.Actor.Persist (KeyHashid, keyHashidText, encodeKeyHashidPure, decodeKeyHashidPure) import Yesod.MonadSite import Web.Hashids.Local @@ -51,20 +52,6 @@ import Web.Hashids.Local class Yesod site => YesodHashids site where siteHashidsContext :: site -> HashidsContext -newtype KeyHashid record = KeyHashid - { keyHashidText :: Text - } - deriving (Eq, Ord, Read, Show) - -instance PersistEntity record => PathPiece (KeyHashid record) where - fromPathPiece t = KeyHashid <$> fromPathPiece t - toPathPiece (KeyHashid t) = toPathPiece t - -encodeKeyHashidPure - :: ToBackendKey SqlBackend record - => HashidsContext -> Key record -> KeyHashid record -encodeKeyHashidPure ctx = KeyHashid . decodeUtf8 . encodeInt64 ctx . fromSqlKey - getEncodeKeyHashid :: ( MonadSite m , YesodHashids (SiteEnv m) @@ -86,14 +73,6 @@ encodeKeyHashid k = do enc <- getEncodeKeyHashid return $ enc k -decodeKeyHashidPure - :: ToBackendKey SqlBackend record - => HashidsContext - -> KeyHashid record - -> Maybe (Key record) -decodeKeyHashidPure ctx (KeyHashid t) = - fmap toSqlKey $ decodeInt64 ctx $ encodeUtf8 t - decodeKeyHashid :: ( MonadSite m , YesodHashids (SiteEnv m) diff --git a/stack.yaml b/stack.yaml index 4bcd8cb..3fe636e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -15,6 +15,12 @@ extra-deps: # yesod-auth-account - git: https://vervis.peers.community/repos/VE2Kr commit: 70024e76cafb95bfa50b456efcf0970d720207bd +# - git: https://notabug.org/fr33domlover/haskell-persistent +# commit: 9cc700b540a680ac1fdc9df94847a631013cb3ca +# subdirs: +# - persistent +# - persistent-postgresql + - ./lib/darcs-lights - ./lib/darcs-rev - ./lib/dvara @@ -49,6 +55,7 @@ extra-deps: - time-interval-0.1.1 - time-units-1.0.0 - url-2.1.3 + - annotated-exception-0.2.0.4 # Override default flag values for local packages and extra-deps flags: diff --git a/templates/personal-overview.hamlet b/templates/personal-overview.hamlet index 7010b39..641aa54 100644 --- a/templates/personal-overview.hamlet +++ b/templates/personal-overview.hamlet @@ -35,6 +35,9 @@ $# .
  • Open a merge request +$#
  • +$# +$# Comment on a ticket or merge request
  • Merge a merge request diff --git a/th/models b/th/models index b28f13d..a1e5e80 100644 --- a/th/models +++ b/th/models @@ -23,8 +23,13 @@ Instance UniqueInstance host RemoteObject - instance InstanceId - ident LocalURI + instance InstanceId + ident LocalURI + -- fetched UTCTime Maybe + + -- type Text Maybe + -- followers LocalURI Maybe + -- team LocalURI Maybe UniqueRemoteObject instance ident diff --git a/th/routes b/th/routes index 1c4c687..5c184a7 100644 --- a/th/routes +++ b/th/routes @@ -129,6 +129,7 @@ /ssh-keys KeysR GET POST /ssh-keys/#SshKeyKeyHashid/delete KeyDeleteR POST +--/publish/comment PublishCommentR GET POST /publish/offer-merge PublishOfferMergeR GET POST /publish/merge PublishMergeR GET POST diff --git a/vervis.cabal b/vervis.cabal index 0887c8e..3b80e5e 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -43,8 +43,10 @@ library Vervis.Hook other-modules: Control.Applicative.Local + Control.Concurrent.Actor Control.Concurrent.Local Control.Concurrent.ResultShare + Control.Concurrent.Return Control.Monad.Trans.Except.Local Crypto.ActorKey Crypto.PubKey.Encoding @@ -109,11 +111,14 @@ library Text.Jasmine.Local Web.ActivityAccess Web.ActivityPub + Web.Actor + Web.Actor.Persist -- Web.Capability Web.Text Web.Hashids.Local Web.PathPieces.Local Yesod.ActivityPub + Yesod.Actor Yesod.Auth.Unverified Yesod.Auth.Unverified.Creds Yesod.Auth.Unverified.Internal @@ -128,6 +133,12 @@ library Vervis.Access Vervis.ActivityPub + Vervis.Actor + Vervis.Actor.Deck + Vervis.Actor.Group + Vervis.Actor.Loom + Vervis.Actor.Person + Vervis.Actor.Repo Vervis.API Vervis.Avatar Vervis.BinaryBody @@ -270,6 +281,8 @@ library build-depends: aeson -- For activity JSOn display in /inbox test page , aeson-pretty + -- For rethrowing in Control.Concurrent.Actor + , annotated-exception -- for encoding and decoding of crypto public keys , asn1-encoding , asn1-types