Implement actor-model system and start moving Person actor to it
This patch makes Vervis temporarily unusable, because all actors' inbox POST handlers use the new system, but the actual federation handler code hasn't been ported. The next patches will port all the S2S activities supported so far, as well as C2S.
This commit is contained in:
fr33domlover
parent
36c7ae0190
commit
c9db823c8c
47 changed files with 2005 additions and 429 deletions
|
|
@ -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
|
||||
|
||||
|
|
|
|||
332
src/Control/Concurrent/Actor.hs
Normal file
332
src/Control/Concurrent/Actor.hs
Normal file
|
|
@ -0,0 +1,332 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019, 2020, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
- The author(s) have dedicated all copyright and related and neighboring
|
||||
- rights to this software to the public domain worldwide. This software is
|
||||
- distributed without any warranty.
|
||||
-
|
||||
- You should have received a copy of the CC0 Public Domain Dedication along
|
||||
- with this software. If not, see
|
||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
module 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)
|
||||
37
src/Control/Concurrent/Return.hs
Normal file
37
src/Control/Concurrent/Return.hs
Normal file
|
|
@ -0,0 +1,37 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
- The author(s) have dedicated all copyright and related and neighboring
|
||||
- rights to this software to the public domain worldwide. This software is
|
||||
- distributed without any warranty.
|
||||
-
|
||||
- You should have received a copy of the CC0 Public Domain Dedication along
|
||||
- with this software. If not, see
|
||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
-- | 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"
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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 <-
|
||||
|
|
|
|||
271
src/Vervis/Actor.hs
Normal file
271
src/Vervis/Actor.hs
Normal file
|
|
@ -0,0 +1,271 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
- The author(s) have dedicated all copyright and related and neighboring
|
||||
- rights to this software to the public domain worldwide. This software is
|
||||
- distributed without any warranty.
|
||||
-
|
||||
- You should have received a copy of the CC0 Public Domain Dedication along
|
||||
- with this software. If not, see
|
||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
-- 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)
|
||||
64
src/Vervis/Actor/Deck.hs
Normal file
64
src/Vervis/Actor/Deck.hs
Normal file
|
|
@ -0,0 +1,64 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
- The author(s) have dedicated all copyright and related and neighboring
|
||||
- rights to this software to the public domain worldwide. This software is
|
||||
- distributed without any warranty.
|
||||
-
|
||||
- You should have received a copy of the CC0 Public Domain Dedication along
|
||||
- with this software. If not, see
|
||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
module 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"
|
||||
64
src/Vervis/Actor/Group.hs
Normal file
64
src/Vervis/Actor/Group.hs
Normal file
|
|
@ -0,0 +1,64 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
- The author(s) have dedicated all copyright and related and neighboring
|
||||
- rights to this software to the public domain worldwide. This software is
|
||||
- distributed without any warranty.
|
||||
-
|
||||
- You should have received a copy of the CC0 Public Domain Dedication along
|
||||
- with this software. If not, see
|
||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
module 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"
|
||||
64
src/Vervis/Actor/Loom.hs
Normal file
64
src/Vervis/Actor/Loom.hs
Normal file
|
|
@ -0,0 +1,64 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
- The author(s) have dedicated all copyright and related and neighboring
|
||||
- rights to this software to the public domain worldwide. This software is
|
||||
- distributed without any warranty.
|
||||
-
|
||||
- You should have received a copy of the CC0 Public Domain Dedication along
|
||||
- with this software. If not, see
|
||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
module 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"
|
||||
189
src/Vervis/Actor/Person.hs
Normal file
189
src/Vervis/Actor/Person.hs
Normal file
|
|
@ -0,0 +1,189 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2016, 2018, 2019, 2020, 2022, 2023
|
||||
- by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
- The author(s) have dedicated all copyright and related and neighboring
|
||||
- rights to this software to the public domain worldwide. This software is
|
||||
- distributed without any warranty.
|
||||
-
|
||||
- You should have received a copy of the CC0 Public Domain Dedication along
|
||||
- with this software. If not, see
|
||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
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"
|
||||
64
src/Vervis/Actor/Repo.hs
Normal file
64
src/Vervis/Actor/Repo.hs
Normal file
|
|
@ -0,0 +1,64 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
- The author(s) have dedicated all copyright and related and neighboring
|
||||
- rights to this software to the public domain worldwide. This software is
|
||||
- distributed without any warranty.
|
||||
-
|
||||
- You should have received a copy of the CC0 Public Domain Dedication along
|
||||
- with this software. If not, see
|
||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
module 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"
|
||||
|
|
@ -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 <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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 <-
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2016, 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2016, 2019, 2020, 2022, 2023
|
||||
- by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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 <-
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019, 2020, 2021, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2019, 2020, 2021, 2022, 2023
|
||||
- by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2019, 2020, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2016, 2018, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2016, 2018, 2019, 2022, 2023
|
||||
- by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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
|
||||
|
|
|
|||
|
|
@ -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 <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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|
|
||||
<h1>Comment on a ticket or a merge request
|
||||
<form method=POST action=@{PublishCommentR} enctype=#{enctype}>
|
||||
^{widget}
|
||||
<input type=submit>
|
||||
|]
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2016, 2018, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2016, 2018, 2019, 2022, 2023
|
||||
- by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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
|
||||
|
|
|
|||
|
|
@ -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 <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
-}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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 ()
|
||||
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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019, 2020, 2021, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2019, 2020, 2021, 2022, 2023
|
||||
- by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019, 2020, 2021, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2019, 2020, 2021, 2022, 2023
|
||||
- by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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
|
||||
|
|
|
|||
51
src/Web/Actor.hs
Normal file
51
src/Web/Actor.hs
Normal file
|
|
@ -0,0 +1,51 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
- The author(s) have dedicated all copyright and related and neighboring
|
||||
- rights to this software to the public domain worldwide. This software is
|
||||
- distributed without any warranty.
|
||||
-
|
||||
- You should have received a copy of the CC0 Public Domain Dedication along
|
||||
- with this software. If not, see
|
||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
-- | 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
|
||||
137
src/Web/Actor/Persist.hs
Normal file
137
src/Web/Actor/Persist.hs
Normal file
|
|
@ -0,0 +1,137 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
- The author(s) have dedicated all copyright and related and neighboring
|
||||
- rights to this software to the public domain worldwide. This software is
|
||||
- distributed without any warranty.
|
||||
-
|
||||
- You should have received a copy of the CC0 Public Domain Dedication along
|
||||
- with this software. If not, see
|
||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
56
src/Yesod/Actor.hs
Normal file
56
src/Yesod/Actor.hs
Normal file
|
|
@ -0,0 +1,56 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written 2019, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ Copying is an act of love. Please copy, reuse and share.
|
||||
-
|
||||
- The author(s) have dedicated all copyright and related and neighboring
|
||||
- rights to this software to the public domain worldwide. This software is
|
||||
- distributed without any warranty.
|
||||
-
|
||||
- You should have received a copy of the CC0 Public Domain Dedication along
|
||||
- with this software. If not, see
|
||||
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||
-}
|
||||
|
||||
-- | 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
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written 2019 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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)
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -35,6 +35,9 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|||
<li>
|
||||
<a href=@{PublishOfferMergeR}>
|
||||
Open a merge request
|
||||
$# <li>
|
||||
$# <a href=@{PublishCommentR}>
|
||||
$# Comment on a ticket or merge request
|
||||
<li>
|
||||
<a href=@{PublishMergeR}>
|
||||
Merge a merge request
|
||||
|
|
|
|||
|
|
@ -25,6 +25,11 @@ Instance
|
|||
RemoteObject
|
||||
instance InstanceId
|
||||
ident LocalURI
|
||||
-- fetched UTCTime Maybe
|
||||
|
||||
-- type Text Maybe
|
||||
-- followers LocalURI Maybe
|
||||
-- team LocalURI Maybe
|
||||
|
||||
UniqueRemoteObject instance ident
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
13
vervis.cabal
13
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue