sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 16:44:52 +09:00
Code Issues Activity

Implement actor-model system and start moving Person actor to it

Browse source 
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 2023-04-29 10:40:44 +00:00
parent 36c7ae0190
commit c9db823c8c
47 changed files with 2005 additions and 429 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
INSTALL.md
View file

@ -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
View 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
View 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"

9
src/Vervis/API.hs
View file

@ -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
View 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
View 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
View 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
View 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
View 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
View 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"

49
src/Vervis/Application.hs
View file

@ -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

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

@ -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

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

@ -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 <-

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

@ -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"

4
src/Vervis/Data/Follow.hs
View file

@ -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)

11
src/Vervis/Data/Ticket.hs
View file

@ -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 <-

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

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -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)

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

@ -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

9
src/Vervis/Federation/Discussion.hs
View file

@ -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)

5
src/Vervis/Federation/Offer.hs
View file

@ -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"

6
src/Vervis/Federation/Ticket.hs
View file

@ -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"

3
src/Vervis/Federation/Util.hs
View file

@ -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

28
src/Vervis/Foundation.hs
View file

@ -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

66
src/Vervis/Handler/Client.hs
View file

@ -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

21
src/Vervis/Handler/Deck.hs
View file

@ -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

19
src/Vervis/Handler/Group.hs
View file

@ -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

21
src/Vervis/Handler/Loom.hs
View file

@ -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

105
src/Vervis/Handler/Person.hs
View file

@ -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

21
src/Vervis/Handler/Repo.hs
View file

@ -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

37
src/Vervis/Model.hs
View file

@ -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
-}

16
src/Vervis/Persist/Discussion.hs
View file

@ -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

78
src/Vervis/Recipient.hs
View file

@ -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

1
src/Vervis/RemoteActorStore.hs
View file

@ -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

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

@ -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 ()
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

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

@ -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

146
src/Web/ActivityPub.hs
View file

@ -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
View 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
View 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

8
src/Yesod/ActivityPub.hs
View file

@ -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
View 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

11
src/Yesod/FedURI.hs
View file

@ -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)

27
src/Yesod/Hashids.hs
View file

@ -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)

7
stack.yaml
View file

@ -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:

3
templates/personal-overview.hamlet
View file

@ -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

9
th/models
View file

@ -23,8 +23,13 @@ Instance
UniqueInstance host
RemoteObject
instance InstanceId
ident LocalURI
instance InstanceId
ident LocalURI
-- fetched UTCTime Maybe
-- type Text Maybe
-- followers LocalURI Maybe
-- team LocalURI Maybe
UniqueRemoteObject instance ident

1
th/routes
View file

@ -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
View file

@ -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