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