From 7686f3777ed4c578f2226f007881eac1648aeca3 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Sat, 15 Jun 2019 04:39:13 +0000
Subject: [PATCH] New module structure for ActivityPub C2S and S2S code
---
src/Control/Monad/Trans/Except/Local.hs | 27 +
src/Data/Either/Local.hs | 10 +
src/Data/Tuple/Local.hs | 36 +
src/Vervis/API.hs | 809 +++++++++++++++
src/Vervis/ActivityPub.hs | 251 +++++
src/Vervis/Federation.hs | 1261 +----------------------
src/Vervis/Federation/Discussion.hs | 448 ++++++++
src/Vervis/Handler/Discussion.hs | 5 +-
src/Vervis/Handler/Inbox.hs | 3 +-
src/Vervis/Handler/Project.hs | 1 +
src/Vervis/Handler/Ticket.hs | 1 +
vervis.cabal | 5 +
12 files changed, 1599 insertions(+), 1258 deletions(-)
create mode 100644 src/Control/Monad/Trans/Except/Local.hs
create mode 100644 src/Data/Tuple/Local.hs
create mode 100644 src/Vervis/API.hs
create mode 100644 src/Vervis/ActivityPub.hs
create mode 100644 src/Vervis/Federation/Discussion.hs
diff --git a/src/Control/Monad/Trans/Except/Local.hs b/src/Control/Monad/Trans/Except/Local.hs
new file mode 100644
index 0000000..2d98aab
--- /dev/null
+++ b/src/Control/Monad/Trans/Except/Local.hs
@@ -0,0 +1,27 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 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.Monad.Trans.Except.Local
+ ( fromMaybeE
+ )
+where
+
+import Prelude
+
+import Control.Monad.Trans.Except
+
+fromMaybeE :: Monad m => Maybe a -> e -> ExceptT e m a
+fromMaybeE Nothing t = throwE t
+fromMaybeE (Just x) _ = return x
diff --git a/src/Data/Either/Local.hs b/src/Data/Either/Local.hs
index ec6c932..631d2f0 100644
--- a/src/Data/Either/Local.hs
+++ b/src/Data/Either/Local.hs
@@ -17,6 +17,7 @@ module Data.Either.Local
( maybeRight
, maybeLeft
, requireEither
+ , requireEitherM
, requireEitherAlt
)
where
@@ -24,6 +25,8 @@ where
import Prelude
import Control.Applicative
+import Control.Exception
+import Control.Monad.IO.Class
maybeRight :: Either a b -> Maybe b
maybeRight (Left _) = Nothing
@@ -39,6 +42,13 @@ requireEither (Just _) (Just _) = Left True
requireEither (Just x) Nothing = Right $ Left x
requireEither Nothing (Just y) = Right $ Right y
+requireEitherM
+ :: MonadIO m => Maybe a -> Maybe b -> String -> String -> m (Either a b)
+requireEitherM mx my f t =
+ case requireEither mx my of
+ Left b -> liftIO $ throwIO $ userError $ if b then t else f
+ Right exy -> return exy
+
requireEitherAlt
:: Applicative f
=> f (Maybe a) -> f (Maybe b) -> String -> String -> f (Either a b)
diff --git a/src/Data/Tuple/Local.hs b/src/Data/Tuple/Local.hs
new file mode 100644
index 0000000..48a7524
--- /dev/null
+++ b/src/Data/Tuple/Local.hs
@@ -0,0 +1,36 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 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 Data.Tuple.Local
+ ( fst3
+ , fst4
+ , thd3
+ , fourth4
+ )
+where
+
+import Prelude
+
+fst3 :: (a, b, c) -> a
+fst3 (x, _, _) = x
+
+fst4 :: (a, b, c, d) -> a
+fst4 (x, _, _, _) = x
+
+thd3 :: (a, b, c) -> c
+thd3 (_, _, z) = z
+
+fourth4 :: (a, b, c, d) -> d
+fourth4 (_, _, _, w) = w
diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs
new file mode 100644
index 0000000..08b99e3
--- /dev/null
+++ b/src/Vervis/API.hs
@@ -0,0 +1,809 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 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.API
+ ( createNoteC
+ , getFollowersCollection
+ )
+where
+
+import Prelude
+
+import Control.Applicative
+import Control.Concurrent.MVar
+import Control.Concurrent.STM.TVar
+import Control.Exception hiding (Handler, try)
+import Control.Monad
+import Control.Monad.Logger.CallStack
+import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Reader
+import Crypto.Hash
+import Data.Aeson
+import Data.Bifunctor
+import Data.ByteString (ByteString)
+import Data.Either
+import Data.Foldable
+import Data.Function
+import Data.List (sort, deleteBy, nub, union, unionBy, partition)
+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
+import Data.Maybe
+import Data.Semigroup
+import Data.Text (Text)
+import Data.Text.Encoding
+import Data.Time.Clock
+import Data.Time.Units
+import Data.Traversable
+import Data.Tuple
+import Database.Persist hiding (deleteBy)
+import Database.Persist.Sql hiding (deleteBy)
+import Network.HTTP.Client
+import Network.HTTP.Types.Header
+import Network.HTTP.Types.URI
+import Network.TLS hiding (SHA256)
+import UnliftIO.Exception (try)
+import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
+import Yesod.Persist.Core
+
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.CaseInsensitive as CI
+import qualified Data.List as L
+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 qualified Network.Wai as W
+
+import Data.Time.Interval
+import Network.HTTP.Signature hiding (requestHeaders)
+import Yesod.HttpSignature
+
+import Crypto.PublicVerifKey
+import Database.Persist.JSON
+import Network.FedURI
+import Network.HTTP.Digest
+import Web.ActivityPub hiding (Follow)
+import Yesod.ActivityPub
+import Yesod.Auth.Unverified
+import Yesod.FedURI
+import Yesod.Hashids
+import Yesod.MonadSite
+
+import Control.Monad.Trans.Except.Local
+import Data.Aeson.Local
+import Data.Either.Local
+import Data.List.Local
+import Data.List.NonEmpty.Local
+import Data.Maybe.Local
+import Data.Tuple.Local
+import Database.Persist.Local
+import Yesod.Persist.Local
+
+import Vervis.ActivityPub
+import Vervis.ActorKey
+import Vervis.Foundation
+import Vervis.Model
+import Vervis.Model.Ident
+import Vervis.RemoteActorStore
+import Vervis.Settings
+
+data Recip
+ = RecipRA (Entity RemoteActor)
+ | RecipURA (Entity UnfetchedRemoteActor)
+ | RecipRC (Entity RemoteCollection)
+
+data LocalTicketRecipient = LocalTicketParticipants | LocalTicketTeam
+ deriving (Eq, Ord)
+
+data LocalProjectRecipient
+ = LocalProject
+ | LocalProjectFollowers
+ | LocalTicketRelated Int LocalTicketRecipient
+ deriving (Eq, Ord)
+
+data LocalSharerRecipient
+ = LocalSharer
+ | LocalProjectRelated PrjIdent LocalProjectRecipient
+ deriving (Eq, Ord)
+
+data LocalRecipient = LocalSharerRelated ShrIdent LocalSharerRecipient
+ deriving (Eq, Ord)
+
+data LocalTicketRelatedSet
+ = OnlyTicketParticipants
+ | OnlyTicketTeam
+ | BothTicketParticipantsAndTeam
+
+data LocalProjectRelatedSet = LocalProjectRelatedSet
+ { localRecipProject :: Bool
+ , localRecipProjectFollowers :: Bool
+ , localRecipTicketRelated :: [(Int, LocalTicketRelatedSet)]
+ }
+
+data LocalSharerRelatedSet = LocalSharerRelatedSet
+ { localRecipSharer :: Bool
+ , localRecipProjectRelated :: [(PrjIdent, LocalProjectRelatedSet)]
+ }
+
+type LocalRecipientSet = [(ShrIdent, LocalSharerRelatedSet)]
+
+parseComment :: LocalURI -> ExceptT Text Handler (ShrIdent, LocalMessageId)
+parseComment luParent = do
+ route <- case decodeRouteLocal luParent of
+ Nothing -> throwE "Not a local route"
+ Just r -> return r
+ case route of
+ MessageR shr hid -> (shr,) <$> decodeKeyHashidE hid "Non-existent local message hashid"
+ _ -> throwE "Not a local message route"
+
+-- | Handle a Note submitted by a local user to their outbox. It can be either
+-- a comment on a local ticket, or a comment on some remote context. Return an
+-- error message if the Note is rejected, otherwise the new 'LocalMessageId'.
+createNoteC :: Text -> Note -> Handler (Either Text LocalMessageId)
+createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source content) = runExceptT $ do
+ verifyHostLocal host "Attributed to non-local actor"
+ verifyNothing mluNote "Note specifies an id"
+ verifyNothing mpublished "Note specifies published"
+ uContext <- fromMaybeE muContext "Note without context"
+ recips <- nonEmptyE (concatRecipients aud) "Note without recipients"
+ (mparent, localRecips, mticket, remoteRecips) <- parseRecipsContextParent recips uContext muParent
+ federation <- getsYesod $ appFederation . appSettings
+ unless (federation || null remoteRecips) $
+ throwE "Federation disabled, but remote recipients specified"
+ (lmid, obid, doc, remotesHttp) <- runDBExcept $ do
+ (pid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor"
+ (did, meparent, mcollections) <- case mticket of
+ Just (shr, prj, num) -> do
+ mt <- lift $ runMaybeT $ do
+ sid <- MaybeT $ getKeyBy $ UniqueSharer shr
+ Entity jid j <- MaybeT $ getBy $ UniqueProject prj sid
+ t <- MaybeT $ getValBy $ UniqueTicket jid num
+ return (sid, projectInbox j, projectFollowers j, t)
+ (sid, ibidProject, fsidProject, t) <- fromMaybeE mt "Context: No such local ticket"
+ let did = ticketDiscuss t
+ mmidParent <- for mparent $ \ parent ->
+ case parent of
+ Left (shrParent, lmidParent) -> getLocalParentMessageId did shrParent lmidParent
+ Right (hParent, luParent) -> do
+ mrm <- lift $ runMaybeT $ do
+ iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
+ MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
+ rm <- fromMaybeE mrm "Remote parent unknown locally"
+ let mid = remoteMessageRest rm
+ m <- lift $ getJust mid
+ unless (messageRoot m == did) $
+ throwE "Remote parent belongs to a different discussion"
+ return mid
+ lift $ insertUnique_ $ Follow pid (ticketFollowers t) False
+ return (did, Left <$> mmidParent, Just (sid, ticketFollowers t, ibidProject, fsidProject))
+ Nothing -> do
+ (rd, rdnew) <- lift $ do
+ let (hContext, luContext) = f2l uContext
+ iid <- either entityKey id <$> insertBy' (Instance hContext)
+ mrd <- getValBy $ UniqueRemoteDiscussionIdent iid luContext
+ case mrd of
+ Just rd -> return (rd, False)
+ Nothing -> do
+ did <- insert Discussion
+ let rd = RemoteDiscussion iid luContext did
+ erd <- insertBy' rd
+ case erd of
+ Left (Entity _ rd') -> do
+ delete did
+ return (rd', False)
+ Right _ -> return (rd, True)
+ let did = remoteDiscussionDiscuss rd
+ meparent <- for mparent $ \ parent ->
+ case parent of
+ Left (shrParent, lmidParent) -> do
+ when rdnew $ throwE "Local parent inexistent, RemoteDiscussion is new"
+ Left <$> getLocalParentMessageId did shrParent lmidParent
+ Right (hParent, luParent) -> do
+ mrm <- lift $ runMaybeT $ do
+ iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
+ MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
+ case mrm of
+ Nothing -> return $ Right $ l2f hParent luParent
+ Just rm -> Left <$> do
+ let mid = remoteMessageRest rm
+ m <- lift $ getJust mid
+ unless (messageRoot m == did) $
+ throwE "Remote parent belongs to a different discussion"
+ return mid
+ return (did, meparent, Nothing)
+ (lmid, obid, doc) <- lift $ insertMessage luAttrib shrUser pid uContext did muParent meparent source content
+ moreRemotes <- deliverLocal pid obid localRecips mcollections
+ unless (federation || null moreRemotes) $
+ throwE "Federation disabled but remote collection members found"
+ remotesHttp <- lift $ deliverRemoteDB (furiHost uContext) obid remoteRecips moreRemotes
+ return (lmid, obid, doc, remotesHttp)
+ lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp (furiHost uContext) obid doc remotesHttp
+ return lmid
+ where
+ verifyNothing :: Monad m => Maybe a -> e -> ExceptT e m ()
+ verifyNothing Nothing _ = return ()
+ verifyNothing (Just _) e = throwE e
+
+ nonEmptyE :: Monad m => [a] -> e -> ExceptT e m (NonEmpty a)
+ nonEmptyE l e =
+ case nonEmpty l of
+ Nothing -> throwE e
+ Just ne -> return ne
+
+ parseRecipsContextParent
+ :: NonEmpty FedURI
+ -> FedURI
+ -> Maybe FedURI
+ -> ExceptT Text Handler
+ ( Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI))
+ , [ShrIdent]
+ , Maybe (ShrIdent, PrjIdent, Int)
+ , [FedURI]
+ )
+ parseRecipsContextParent recips uContext muParent = do
+ (locals, remotes) <- lift $ splitRecipients recips
+ let (localsParsed, localsRest) = parseLocalRecipients locals
+ unless (null localsRest) $
+ throwE "Note has invalid local recipients"
+ let localsSet = groupLocalRecipients localsParsed
+ (hContext, luContext) = f2l uContext
+ parent <- parseParent uContext muParent
+ local <- hostIsLocal hContext
+ let remotes' = remotes L.\\ audienceNonActors aud
+ if local
+ then do
+ ticket <- parseContextTicket luContext
+ shrs <- verifyTicketRecipients ticket localsSet
+ return (parent, shrs, Just ticket, remotes')
+ else do
+ shrs <- verifyOnlySharers localsSet
+ return (parent, shrs, Nothing, remotes')
+ where
+ -- First step: Split into remote and local:
+ splitRecipients :: NonEmpty FedURI -> Handler ([LocalURI], [FedURI])
+ splitRecipients recips = do
+ home <- getsYesod $ appInstanceHost . appSettings
+ let (local, remote) = NE.partition ((== home) . furiHost) recips
+ return (map (snd . f2l) local, remote)
+
+ -- Parse the local recipients
+ parseLocalRecipients :: [LocalURI] -> ([LocalRecipient], [Either LocalURI (Route App)])
+ parseLocalRecipients = swap . partitionEithers . map decide
+ where
+ parseLocalRecipient (SharerR shr) = Just $ LocalSharerRelated shr LocalSharer
+ parseLocalRecipient (ProjectR shr prj) =
+ Just $ LocalSharerRelated shr $ LocalProjectRelated prj LocalProject
+ parseLocalRecipient (ProjectFollowersR shr prj) =
+ Just $ LocalSharerRelated shr $ LocalProjectRelated prj LocalProjectFollowers
+ parseLocalRecipient (TicketParticipantsR shr prj num) =
+ Just $ LocalSharerRelated shr $ LocalProjectRelated prj $ LocalTicketRelated num LocalTicketParticipants
+ parseLocalRecipient (TicketTeamR shr prj num) =
+ Just $ LocalSharerRelated shr $ LocalProjectRelated prj $ LocalTicketRelated num LocalTicketTeam
+ parseLocalRecipient _ = Nothing
+ decide lu =
+ case decodeRouteLocal lu of
+ Nothing -> Left $ Left lu
+ Just route ->
+ case parseLocalRecipient route of
+ Nothing -> Left $ Right route
+ Just lr -> Right lr
+
+ -- Group local recipients
+ groupLocalRecipients :: [LocalRecipient] -> LocalRecipientSet
+ groupLocalRecipients
+ = map
+ ( second
+ $ uncurry LocalSharerRelatedSet
+ . bimap
+ (not . null)
+ ( map
+ ( second
+ $ uncurry localProjectRelatedSet
+ . bimap
+ ( bimap (not . null) (not . null)
+ . partition id
+ )
+ ( map (second ltrs2ltrs)
+ . groupWithExtract fst snd
+ )
+ . partitionEithers
+ . NE.toList
+ )
+ . groupWithExtract fst (lpr2e . snd)
+ )
+ . partitionEithers
+ . NE.toList
+ )
+ . groupWithExtract
+ (\ (LocalSharerRelated shr _) -> shr)
+ (\ (LocalSharerRelated _ lsr) -> lsr2e lsr)
+ . sort
+ where
+ lsr2e LocalSharer = Left ()
+ lsr2e (LocalProjectRelated prj lpr) = Right (prj, lpr)
+ lpr2e LocalProject = Left False
+ lpr2e LocalProjectFollowers = Left True
+ lpr2e (LocalTicketRelated num ltr) = Right (num, ltr)
+ ltrs2ltrs (LocalTicketParticipants :| l) =
+ if LocalTicketTeam `elem` l
+ then BothTicketParticipantsAndTeam
+ else OnlyTicketParticipants
+ ltrs2ltrs (LocalTicketTeam :| l) =
+ if LocalTicketParticipants `elem` l
+ then BothTicketParticipantsAndTeam
+ else OnlyTicketTeam
+ localProjectRelatedSet (f, j) t =
+ LocalProjectRelatedSet j f t
+
+ parseParent :: FedURI -> Maybe FedURI -> ExceptT Text Handler (Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI)))
+ parseParent _ Nothing = return Nothing
+ parseParent uContext (Just uParent) =
+ if uParent == uContext
+ then return Nothing
+ else Just <$> do
+ let (hParent, luParent) = f2l uParent
+ parentLocal <- hostIsLocal hParent
+ if parentLocal
+ then Left <$> parseComment luParent
+ else return $ Right (hParent, luParent)
+
+ parseContextTicket :: Monad m => LocalURI -> ExceptT Text m (ShrIdent, PrjIdent, Int)
+ parseContextTicket luContext = do
+ route <- case decodeRouteLocal luContext of
+ Nothing -> throwE "Local context isn't a valid route"
+ Just r -> return r
+ case route of
+ TicketR shr prj num -> return (shr, prj, num)
+ _ -> throwE "Local context isn't a ticket route"
+
+ atMostSharer :: e -> (ShrIdent, LocalSharerRelatedSet) -> ExceptT e Handler (Maybe ShrIdent)
+ atMostSharer _ (shr, LocalSharerRelatedSet s []) = return $ if s then Just shr else Nothing
+ atMostSharer e (_ , LocalSharerRelatedSet _ _ ) = throwE e
+
+ verifyTicketRecipients :: (ShrIdent, PrjIdent, Int) -> LocalRecipientSet -> ExceptT Text Handler [ShrIdent]
+ verifyTicketRecipients (shr, prj, num) recips = do
+ lsrSet <- fromMaybeE (lookupSorted shr recips) "Note with local context: No required recipients"
+ (prj', lprSet) <- verifySingleton (localRecipProjectRelated lsrSet) "Note project-related recipient sets"
+ unless (prj == prj') $ throwE "Note project recipients mismatch context's project"
+ unless (localRecipProject lprSet) $ throwE "Note context's project not addressed"
+ unless (localRecipProjectFollowers lprSet) $ throwE "Note context's project followers not addressed"
+ (num', ltrSet) <- verifySingleton (localRecipTicketRelated lprSet) "Note ticket-related recipient sets"
+ unless (num == num') $ throwE "Note project recipients mismatch context's ticket number"
+ case ltrSet of
+ OnlyTicketParticipants -> throwE "Note ticket participants not addressed"
+ OnlyTicketTeam -> throwE "Note ticket team not addressed"
+ BothTicketParticipantsAndTeam -> return ()
+ let rest = deleteBy ((==) `on` fst) (shr, lsrSet) recips
+ orig = if localRecipSharer lsrSet then Just shr else Nothing
+ catMaybes . (orig :) <$> traverse (atMostSharer "Note with unrelated non-sharer recipients") rest
+ where
+ verifySingleton :: Monad m => [a] -> Text -> ExceptT Text m a
+ verifySingleton [] t = throwE $ t <> ": expected 1, got 0"
+ verifySingleton [x] _ = return x
+ verifySingleton l t = throwE $ t <> ": expected 1, got " <> T.pack (show $ length l)
+
+ verifyOnlySharers :: LocalRecipientSet -> ExceptT Text Handler [ShrIdent]
+ verifyOnlySharers lrs = catMaybes <$> traverse (atMostSharer "Note with remote context but local project-related recipients") lrs
+
+ verifyIsLoggedInUser :: LocalURI -> Text -> ExceptT Text AppDB (PersonId, ShrIdent)
+ verifyIsLoggedInUser lu t = do
+ Entity pid p <- requireVerifiedAuth
+ s <- lift $ getJust $ personIdent p
+ route2local <- getEncodeRouteLocal
+ let shr = sharerIdent s
+ if route2local (SharerR shr) == lu
+ then return (pid, shr)
+ else throwE t
+
+ insertMessage
+ :: LocalURI
+ -> ShrIdent
+ -> PersonId
+ -> FedURI
+ -> DiscussionId
+ -> Maybe FedURI
+ -> Maybe (Either MessageId FedURI)
+ -> Text
+ -> Text
+ -> AppDB (LocalMessageId, OutboxItemId, Doc Activity)
+ insertMessage luAttrib shrUser pid uContext did muParent meparent source content = do
+ now <- liftIO getCurrentTime
+ mid <- insert Message
+ { messageCreated = now
+ , messageSource = source
+ , messageContent = content
+ , messageParent =
+ case meparent of
+ Just (Left midParent) -> Just midParent
+ _ -> Nothing
+ , messageRoot = did
+ }
+ let activity luAct luNote = Doc host Activity
+ { activityId = luAct
+ , activityActor = luAttrib
+ , activityAudience = aud
+ , activitySpecific = CreateActivity Create
+ { createObject = Note
+ { noteId = Just luNote
+ , noteAttrib = luAttrib
+ , noteAudience = aud
+ , noteReplyTo = Just $ fromMaybe uContext muParent
+ , noteContext = Just uContext
+ , notePublished = Just now
+ , noteContent = content
+ }
+ }
+ }
+ tempUri = LocalURI "" ""
+ obid <- insert OutboxItem
+ { outboxItemPerson = pid
+ , outboxItemActivity = PersistJSON $ activity tempUri tempUri
+ , outboxItemPublished = now
+ }
+ lmid <- insert LocalMessage
+ { localMessageAuthor = pid
+ , localMessageRest = mid
+ , localMessageCreate = obid
+ , localMessageUnlinkedParent =
+ case meparent of
+ Just (Right uParent) -> Just uParent
+ _ -> Nothing
+ }
+ route2local <- getEncodeRouteLocal
+ obhid <- encodeKeyHashid obid
+ lmhid <- encodeKeyHashid lmid
+ let luAct = route2local $ OutboxItemR shrUser obhid
+ luNote = route2local $ MessageR shrUser lmhid
+ doc = activity luAct luNote
+ update obid [OutboxItemActivity =. PersistJSON doc]
+ return (lmid, obid, doc)
+
+ -- Deliver to local recipients. For local users, find in DB and deliver.
+ -- For local collections, expand them, deliver to local users, and return a
+ -- list of remote actors found in them.
+ deliverLocal
+ :: PersonId
+ -> OutboxItemId
+ -> [ShrIdent]
+ -> Maybe (SharerId, FollowerSetId, InboxId, FollowerSetId)
+ -> ExceptT Text AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+ deliverLocal pidAuthor obid recips mticket = do
+ recipPids <- traverse getPersonId $ nub recips
+ when (pidAuthor `elem` recipPids) $
+ throwE "Note addressed to note author"
+ (morePids, remotes) <-
+ lift $ case mticket of
+ Nothing -> return ([], [])
+ Just (sid, fsidT, _, fsidJ) -> do
+ (teamPids, teamRemotes) <- getTicketTeam sid
+ (tfsPids, tfsRemotes) <- getFollowers fsidT
+ (jfsPids, jfsRemotes) <- getFollowers fsidJ
+ return
+ ( L.delete pidAuthor $ union teamPids $ union tfsPids jfsPids
+ -- TODO this is inefficient! The way this combines
+ -- same-host sharer lists is:
+ --
+ -- (1) concatenate them
+ -- (2) nubBy fst to remove duplicates
+ --
+ -- But we have knowledge that:
+ --
+ -- (1) in each of the 2 lists we're combining, each
+ -- instance occurs only once
+ -- (2) in each actor list, each actor occurs only
+ -- once
+ --
+ -- So we can improve this code by:
+ --
+ -- (1) Not assume arbitrary number of consecutive
+ -- repetition of the same instance, we may only
+ -- have repetition if the same instance occurs
+ -- in both lists
+ -- (2) Don't <> the lists, instead apply unionBy or
+ -- something better (unionBy assumes one list
+ -- may have repetition, but removes repetition
+ -- from the other; we know both lists have no
+ -- repetition, can we use that to do this
+ -- faster than unionBy?)
+ --
+ -- Also, if we ask the DB to sort by actor, then in
+ -- the (2) point above, instead of unionBy we can use
+ -- the knowledge the lists are sorted, and apply
+ -- LO.unionBy instead. Or even better, because
+ -- LO.unionBy doesn't assume no repetitions (possibly
+ -- though it still does it the fastest way).
+ --
+ -- So, in mergeConcat, don't start with merging,
+ -- because we lose the knowledge that each list's
+ -- instances aren't repeated. Use a custom merge
+ -- where we can unionBy or LO.unionBy whenever both
+ -- lists have the same instance.
+ , map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat3 teamRemotes tfsRemotes jfsRemotes
+ )
+ lift $ do
+ for_ mticket $ \ (_, _, ibidProject, _) -> do
+ ibiid <- insert $ InboxItem False
+ insert_ $ InboxItemLocal ibidProject obid ibiid
+ for_ (union recipPids morePids) $ \ pid -> do
+ ibid <- personInbox <$> getJust pid
+ ibiid <- insert $ InboxItem True
+ insert_ $ InboxItemLocal ibid obid ibiid
+ return remotes
+ where
+ getPersonId :: ShrIdent -> ExceptT Text AppDB PersonId
+ getPersonId shr = do
+ msid <- lift $ getKeyBy $ UniqueSharer shr
+ sid <- fromMaybeE msid "Local Note addresses nonexistent local sharer"
+ id_ <- lift $ getPersonOrGroupId sid
+ case id_ of
+ Left pid -> return pid
+ Right _gid -> throwE "Local Note addresses a local group"
+
+ {-
+ -- Deliver to a local sharer, if they exist as a user account
+ deliverToLocalSharer :: OutboxItemId -> ShrIdent -> ExceptT Text AppDB ()
+ deliverToLocalSharer obid shr = do
+ msid <- lift $ getKeyBy $ UniqueSharer shr
+ sid <- fromMaybeE msid "Local Note addresses nonexistent local sharer"
+ mpid <- lift $ getKeyBy $ UniquePersonIdent sid
+ mgid <- lift $ getKeyBy $ UniqueGroup sid
+ id_ <-
+ requireEitherM mpid mgid
+ "Found sharer that is neither person nor group"
+ "Found sharer that is both person and group"
+ case id_ of
+ Left pid -> lift $ insert_ $ InboxItemLocal pid obid
+ Right _gid -> throwE "Local Note addresses a local group"
+ -}
+
+ deliverRemoteDB
+ :: Text
+ -> OutboxItemId
+ -> [FedURI]
+ -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+ -> AppDB
+ ( [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
+ , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
+ , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
+ )
+ deliverRemoteDB hContext obid recips known = do
+ recips' <- for (groupByHost recips) $ \ (h, lus) -> do
+ let lus' = NE.nub lus
+ (iid, inew) <- idAndNew <$> insertBy' (Instance h)
+ if inew
+ then return ((iid, h), (Nothing, Nothing, Just lus'))
+ else do
+ es <- for lus' $ \ lu -> do
+ ma <- runMaybeT
+ $ RecipRA <$> MaybeT (getBy $ UniqueRemoteActor iid lu)
+ <|> RecipURA <$> MaybeT (getBy $ UniqueUnfetchedRemoteActor iid lu)
+ <|> RecipRC <$> MaybeT (getBy $ UniqueRemoteCollection iid lu)
+ return $
+ case ma of
+ Nothing -> Just $ Left lu
+ Just r ->
+ case r of
+ RecipRA (Entity raid ra) -> Just $ Right $ Left (raid, remoteActorIdent ra, remoteActorInbox ra, remoteActorErrorSince ra)
+ RecipURA (Entity uraid ura) -> Just $ Right $ Right (uraid, unfetchedRemoteActorIdent ura, unfetchedRemoteActorSince ura)
+ RecipRC _ -> Nothing
+ let (unknown, newKnown) = partitionEithers $ catMaybes $ NE.toList es
+ (fetched, unfetched) = partitionEithers newKnown
+ return ((iid, h), (nonEmpty fetched, nonEmpty unfetched, nonEmpty unknown))
+ let moreKnown = mapMaybe (\ (i, (f, _, _)) -> (i,) <$> f) recips'
+ unfetched = mapMaybe (\ (i, (_, uf, _)) -> (i,) <$> uf) recips'
+ stillUnknown = mapMaybe (\ (i, (_, _, uk)) -> (i,) <$> uk) recips'
+ -- TODO see the earlier TODO about merge, it applies here too
+ allFetched = map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat known moreKnown
+ fetchedDeliv <- for allFetched $ \ (i, rs) ->
+ let fwd = snd i == hContext
+ in (i,) <$> insertMany' (\ (raid, _, _, msince) -> Delivery raid obid fwd $ isNothing msince) rs
+ unfetchedDeliv <- for unfetched $ \ (i, rs) ->
+ let fwd = snd i == hContext
+ in (i,) <$> insertMany' (\ (uraid, _, msince) -> UnlinkedDelivery uraid obid fwd $ isNothing msince) rs
+ unknownDeliv <- for stillUnknown $ \ (i, lus) -> do
+ -- TODO maybe for URA insertion we should do insertUnique?
+ rs <- insertMany' (\ lu -> UnfetchedRemoteActor (fst i) lu Nothing) lus
+ let fwd = snd i == hContext
+ (i,) <$> insertMany' (\ (_, uraid) -> UnlinkedDelivery uraid obid fwd True) rs
+ return
+ ( takeNoError4 fetchedDeliv
+ , takeNoError3 unfetchedDeliv
+ , map
+ (second $ NE.map $ \ ((lu, ak), dlk) -> (ak, lu, dlk))
+ unknownDeliv
+ )
+ where
+ groupByHost :: [FedURI] -> [(Text, NonEmpty LocalURI)]
+ groupByHost = groupAllExtract furiHost (snd . f2l)
+
+ takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
+ takeNoError3 = takeNoError noError
+ where
+ noError ((ak, lu, Nothing), dlk) = Just (ak, lu, dlk)
+ noError ((_ , _ , Just _ ), _ ) = Nothing
+ takeNoError4 = takeNoError noError
+ where
+ noError ((ak, luA, luI, Nothing), dlk) = Just (ak, luA, luI, dlk)
+ noError ((_ , _ , _ , Just _ ), _ ) = Nothing
+
+ deliverRemoteHttp
+ :: Text
+ -> OutboxItemId
+ -> Doc Activity
+ -> ( [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
+ , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
+ , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
+ )
+ -> Worker ()
+ deliverRemoteHttp hContext obid doc (fetched, unfetched, unknown) = do
+ logDebug' "Starting"
+ let deliver fwd h inbox = do
+ let fwd' = if h == hContext then Just fwd else Nothing
+ (isJust fwd',) <$> deliverHttp doc fwd' h inbox
+ now <- liftIO getCurrentTime
+ logDebug' $
+ "Launching fetched " <> T.pack (show $ map (snd . fst) fetched)
+ traverse_ (fork . deliverFetched deliver now) fetched
+ logDebug' $
+ "Launching unfetched " <> T.pack (show $ map (snd . fst) unfetched)
+ traverse_ (fork . deliverUnfetched deliver now) unfetched
+ logDebug' $
+ "Launching unknown " <> T.pack (show $ map (snd . fst) unknown)
+ traverse_ (fork . deliverUnfetched deliver now) unknown
+ logDebug' "Done (async delivery may still be running)"
+ where
+ logDebug' t = logDebug $ prefix <> t
+ where
+ prefix =
+ T.concat
+ [ "Outbox POST handler: deliverRemoteHttp obid#"
+ , T.pack $ show $ fromSqlKey obid
+ , ": "
+ ]
+ fork = forkWorker "Outbox POST handler: HTTP delivery"
+ deliverFetched deliver now ((_, h), recips@(r :| rs)) = do
+ logDebug'' "Starting"
+ let (raid, luActor, luInbox, dlid) = r
+ (_, e) <- deliver luActor h luInbox
+ e' <- case e of
+ Left err -> do
+ logError $ T.concat
+ [ "Outbox DL delivery #", T.pack $ show dlid
+ , " error for <", renderFedURI $ l2f h luActor
+ , ">: ", T.pack $ displayException err
+ ]
+ return $
+ if isInstanceErrorP err
+ then Nothing
+ else Just False
+ Right _resp -> return $ Just True
+ case e' of
+ Nothing -> runSiteDB $ do
+ let recips' = NE.toList recips
+ updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
+ updateWhere [DeliveryId <-. map fourth4 recips'] [DeliveryRunning =. False]
+ Just success -> do
+ runSiteDB $
+ if success
+ then delete dlid
+ else do
+ updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
+ update dlid [DeliveryRunning =. False]
+ for_ rs $ \ (raid, luActor, luInbox, dlid) ->
+ fork $ do
+ (_, e) <- deliver luActor h luInbox
+ runSiteDB $
+ case e of
+ Left err -> do
+ logError $ T.concat
+ [ "Outbox DL delivery #", T.pack $ show dlid
+ , " error for <", renderFedURI $ l2f h luActor
+ , ">: ", T.pack $ displayException err
+ ]
+ updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
+ update dlid [DeliveryRunning =. False]
+ Right _resp -> delete dlid
+ where
+ logDebug'' t = logDebug' $ T.concat ["deliverFetched ", h, t]
+ deliverUnfetched deliver now ((iid, h), recips@(r :| rs)) = do
+ logDebug'' "Starting"
+ let (uraid, luActor, udlid) = r
+ e <- fetchRemoteActor iid h luActor
+ let e' = case e of
+ Left err -> Just Nothing
+ Right (Left err) ->
+ if isInstanceErrorG err
+ then Nothing
+ else Just Nothing
+ Right (Right mera) -> Just $ Just mera
+ case e' of
+ Nothing -> runSiteDB $ do
+ let recips' = NE.toList recips
+ updateWhere [UnfetchedRemoteActorId <-. map fst3 recips', UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now]
+ updateWhere [UnlinkedDeliveryId <-. map thd3 recips'] [UnlinkedDeliveryRunning =. False]
+ Just mmera -> do
+ for_ rs $ \ (uraid, luActor, udlid) ->
+ fork $ do
+ e <- fetchRemoteActor iid h luActor
+ case e of
+ Right (Right mera) ->
+ case mera of
+ Nothing -> runSiteDB $ delete udlid
+ Just (Entity raid ra) -> do
+ (fwd, e') <- deliver luActor h $ remoteActorInbox ra
+ runSiteDB $
+ case e' of
+ Left _ -> do
+ updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
+ delete udlid
+ insert_ $ Delivery raid obid fwd False
+ Right _ -> delete udlid
+ _ -> runSiteDB $ do
+ updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now]
+ update udlid [UnlinkedDeliveryRunning =. False]
+ case mmera of
+ Nothing -> runSiteDB $ do
+ updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now]
+ update udlid [UnlinkedDeliveryRunning =. False]
+ Just mera ->
+ case mera of
+ Nothing -> runSiteDB $ delete udlid
+ Just (Entity raid ra) -> do
+ (fwd, e'') <- deliver luActor h $ remoteActorInbox ra
+ runSiteDB $
+ case e'' of
+ Left _ -> do
+ updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
+ delete udlid
+ insert_ $ Delivery raid obid fwd False
+ Right _ -> delete udlid
+ where
+ logDebug'' t = logDebug' $ T.concat ["deliverUnfetched ", h, t]
+
+getFollowersCollection
+ :: Route App -> AppDB FollowerSetId -> Handler TypedContent
+getFollowersCollection here getFsid = do
+ (locals, remotes) <- runDB $ do
+ fsid <- getFsid
+ (,) <$> do pids <- map (followPerson . entityVal) <$>
+ selectList [FollowTarget ==. fsid] []
+ sids <-
+ map (personIdent . entityVal) <$>
+ selectList [PersonId <-. pids] []
+ map (sharerIdent . entityVal) <$>
+ selectList [SharerId <-. sids] []
+ <*> do E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` i) -> do
+ E.on $ ra E.^. RemoteActorInstance E.==. i E.^. InstanceId
+ E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId
+ E.where_ $ rf E.^. RemoteFollowTarget E.==. E.val fsid
+ return
+ ( i E.^. InstanceHost
+ , ra E.^. RemoteActorIdent
+ )
+
+ encodeRouteLocal <- getEncodeRouteLocal
+ encodeRouteHome <- getEncodeRouteHome
+ let followersAP = Collection
+ { collectionId = encodeRouteLocal here
+ , collectionType = CollectionTypeUnordered
+ , collectionTotalItems = Just $ length locals + length remotes
+ , collectionCurrent = Nothing
+ , collectionFirst = Nothing
+ , collectionLast = Nothing
+ , collectionItems =
+ map (encodeRouteHome . SharerR) locals ++
+ map (uncurry l2f . bimap E.unValue E.unValue) remotes
+ }
+ provideHtmlAndAP followersAP $ redirect (here, [("prettyjson", "true")])
diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs
new file mode 100644
index 0000000..1d7989f
--- /dev/null
+++ b/src/Vervis/ActivityPub.hs
@@ -0,0 +1,251 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 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.ActivityPub
+ ( hostIsLocal
+ , verifyHostLocal
+ , parseContext
+ , parseParent
+ , runDBExcept
+ , getLocalParentMessageId
+ , concatRecipients
+ , getPersonOrGroupId
+ , getTicketTeam
+ , getFollowers
+ , mergeConcat
+ , mergeConcat3
+ , insertMany'
+ , isInstanceErrorP
+ , isInstanceErrorG
+ , deliverHttp
+ )
+where
+
+import Prelude
+
+import Control.Exception hiding (try)
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Except
+import Control.Monad.Trans.Reader
+import Data.Bifunctor
+import Data.Function
+import Data.List.NonEmpty (NonEmpty, nonEmpty)
+import Data.Semigroup
+import Data.Text (Text)
+import Data.Time.Clock
+import Database.Persist
+import Database.Persist.Sql
+import Network.HTTP.Client
+import Network.TLS -- hiding (SHA256)
+import UnliftIO.Exception (try)
+
+import qualified Data.List.NonEmpty as NE
+import qualified Data.List.Ordered as LO
+import qualified Database.Esqueleto as E
+
+import Network.FedURI
+import Web.ActivityPub
+import Yesod.ActivityPub
+import Yesod.MonadSite
+import Yesod.FedURI
+import Yesod.Hashids
+
+import Control.Monad.Trans.Except.Local
+import Data.Either.Local
+import Data.List.NonEmpty.Local
+import Database.Persist.Local
+
+import Vervis.Foundation
+import Vervis.Model
+import Vervis.Model.Ident
+import Vervis.Settings
+
+hostIsLocal :: (MonadSite m, SiteEnv m ~ App) => Text -> m Bool
+hostIsLocal h = asksSite $ (== h) . appInstanceHost . appSettings
+
+verifyHostLocal
+ :: (MonadSite m, SiteEnv m ~ App)
+ => Text -> Text -> ExceptT Text m ()
+verifyHostLocal h t = do
+ local <- hostIsLocal h
+ unless local $ throwE t
+
+parseContext
+ :: (MonadSite m, SiteEnv m ~ App)
+ => FedURI
+ -> ExceptT Text m (Either (ShrIdent, PrjIdent, Int) (Text, LocalURI))
+parseContext uContext = do
+ let c@(hContext, luContext) = f2l uContext
+ local <- hostIsLocal hContext
+ if local
+ then Left <$> do
+ route <- case decodeRouteLocal luContext of
+ Nothing -> throwE "Local context isn't a valid route"
+ Just r -> return r
+ case route of
+ TicketR shr prj num -> return (shr, prj, num)
+ _ -> throwE "Local context isn't a ticket route"
+ else return $ Right c
+
+parseParent
+ :: (MonadSite m, SiteEnv m ~ App)
+ => FedURI
+ -> ExceptT Text m (Either (ShrIdent, LocalMessageId) (Text, LocalURI))
+parseParent uParent = do
+ let p@(hParent, luParent) = f2l uParent
+ local <- hostIsLocal hParent
+ if local
+ then Left <$> do
+ route <- case decodeRouteLocal luParent of
+ Nothing -> throwE "Local parent isn't a valid route"
+ Just r -> return r
+ case route of
+ MessageR shr lmkhid ->
+ (shr,) <$>
+ decodeKeyHashidE lmkhid
+ "Local parent has non-existent message \
+ \hashid"
+ _ -> throwE "Local parent isn't a message route"
+ else return $ Right p
+
+newtype FedError = FedError Text deriving Show
+
+instance Exception FedError
+
+runDBExcept :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App) => ExceptT Text (ReaderT SqlBackend m) a -> ExceptT Text m a
+runDBExcept action = do
+ result <-
+ lift $ try $ runSiteDB $ either abort return =<< runExceptT action
+ case result of
+ Left (FedError t) -> throwE t
+ Right r -> return r
+ where
+ abort = liftIO . throwIO . FedError
+
+getLocalParentMessageId :: DiscussionId -> ShrIdent -> LocalMessageId -> ExceptT Text AppDB MessageId
+getLocalParentMessageId did shr lmid = do
+ mlm <- lift $ get lmid
+ lm <- fromMaybeE mlm "Local parent: no such lmid"
+ p <- lift $ getJust $ localMessageAuthor lm
+ s <- lift $ getJust $ personIdent p
+ unless (shr == sharerIdent s) $ throwE "Local parent: No such message, lmid mismatches sharer"
+ let mid = localMessageRest lm
+ m <- lift $ getJust mid
+ unless (messageRoot m == did) $
+ throwE "Local parent belongs to a different discussion"
+ return mid
+
+concatRecipients :: Audience -> [FedURI]
+concatRecipients (Audience to bto cc bcc gen _) = concat [to, bto, cc, bcc, gen]
+
+getPersonOrGroupId :: SharerId -> AppDB (Either PersonId GroupId)
+getPersonOrGroupId sid = do
+ mpid <- getKeyBy $ UniquePersonIdent sid
+ mgid <- getKeyBy $ UniqueGroup sid
+ requireEitherM mpid mgid
+ "Found sharer that is neither person nor group"
+ "Found sharer that is both person and group"
+
+getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
+getTicketTeam sid = do
+ id_ <- getPersonOrGroupId sid
+ (,[]) <$> case id_ of
+ Left pid -> return [pid]
+ Right gid ->
+ map (groupMemberPerson . entityVal) <$>
+ selectList [GroupMemberGroup ==. gid] []
+
+getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
+getFollowers fsid = do
+ local <- selectList [FollowTarget ==. fsid] []
+ remote <- E.select $ E.from $ \ (rf `E.InnerJoin` rs `E.InnerJoin` i) -> do
+ E.on $ rs E.^. RemoteActorInstance E.==. i E.^. InstanceId
+ E.on $ rf E.^. RemoteFollowActor E.==. rs E.^. RemoteActorId
+ E.where_ $ rf E.^. RemoteFollowTarget E.==. E.val fsid
+ E.orderBy [E.asc $ i E.^. InstanceId]
+ return
+ ( i E.^. InstanceId
+ , i E.^. InstanceHost
+ , rs E.^. RemoteActorId
+ , rs E.^. RemoteActorIdent
+ , rs E.^. RemoteActorInbox
+ , rs E.^. RemoteActorErrorSince
+ )
+ return
+ ( map (followPerson . entityVal) local
+ , groupRemotes $
+ map (\ (E.Value iid, E.Value h, E.Value rsid, E.Value luActor, E.Value luInbox, E.Value msince) ->
+ (iid, h, rsid, luActor, luInbox, msince)
+ )
+ remote
+ )
+ where
+ groupRemotes :: [(InstanceId, Text, RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)] -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+ groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples
+ where
+ toTuples (iid, h, rsid, luA, luI, ms) = ((iid, h), (rsid, luA, luI, ms))
+
+-- | Merge 2 lists ordered on fst, concatenating snd values when
+-- multiple identical fsts occur. The resulting list is ordered on fst,
+-- and each fst value appears only once.
+--
+-- >>> mergeWith (+) [('a',3), ('a',1), ('b',5)] [('a',2), ('c',4)]
+-- [('a',6), ('b',5), ('c',4)]
+mergeConcat :: (Ord a, Semigroup b) => [(a, b)] -> [(a, b)] -> [(a, b)]
+mergeConcat xs ys = map (second sconcat) $ groupWithExtract fst snd $ LO.mergeBy (compare `on` fst) xs ys
+
+mergeConcat3 :: (Ord a, Semigroup b) => [(a, b)] -> [(a, b)] -> [(a, b)] -> [(a, b)]
+mergeConcat3 xs ys zs = mergeConcat xs $ LO.mergeBy (compare `on` fst) ys zs
+
+insertMany' mk xs = zip' xs <$> insertMany (NE.toList $ mk <$> xs)
+ where
+ zip' x y =
+ case nonEmpty y of
+ Just y' | length x == length y' -> NE.zip x y'
+ _ -> error "insertMany' returned different length!"
+
+isInstanceErrorHttp (InvalidUrlException _ _) = False
+isInstanceErrorHttp (HttpExceptionRequest _ hec) =
+ case hec of
+ ResponseTimeout -> True
+ ConnectionTimeout -> True
+ InternalException se ->
+ case fromException se of
+ Just (HandshakeFailed _) -> True
+ _ -> False
+ _ -> False
+
+isInstanceErrorP (APPostErrorSig _) = False
+isInstanceErrorP (APPostErrorHTTP he) = isInstanceErrorHttp he
+
+isInstanceErrorG Nothing = False
+isInstanceErrorG (Just e) =
+ case e of
+ APGetErrorHTTP he -> isInstanceErrorHttp he
+ APGetErrorJSON _ -> False
+ APGetErrorContentType _ -> False
+
+deliverHttp
+ :: (MonadSite m, SiteEnv m ~ App)
+ => Doc Activity
+ -> Maybe LocalURI
+ -> Text
+ -> LocalURI
+ -> m (Either APPostError (Response ()))
+deliverHttp doc mfwd h luInbox =
+ deliverActivity (l2f h luInbox) (l2f h <$> mfwd) doc
diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs
index b13e2af..31a5850 100644
--- a/src/Vervis/Federation.hs
+++ b/src/Vervis/Federation.hs
@@ -19,9 +19,7 @@ module Vervis.Federation
, handleSharerInbox
, handleProjectInbox
, fixRunningDeliveries
- , handleOutboxNote
, retryOutboxDelivery
- , getFollowersCollection
)
where
@@ -87,15 +85,19 @@ import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite
+import Control.Monad.Trans.Except.Local
import Data.Aeson.Local
import Data.Either.Local
import Data.List.Local
import Data.List.NonEmpty.Local
import Data.Maybe.Local
+import Data.Tuple.Local
import Database.Persist.Local
import Yesod.Persist.Local
+import Vervis.ActivityPub
import Vervis.ActorKey
+import Vervis.Federation.Discussion
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
@@ -382,27 +384,6 @@ authenticateActivity now = do
Left e -> throwE $ "ActivityPub-Forwarder isn't a valid FedURI: " <> T.pack e
Right u -> return u
-hostIsLocal :: (MonadHandler m, HandlerSite m ~ App) => Text -> m Bool
-hostIsLocal h = getsYesod $ (== h) . appInstanceHost . appSettings
-
-verifyHostLocal
- :: (MonadHandler m, HandlerSite m ~ App)
- => Text -> Text -> ExceptT Text m ()
-verifyHostLocal h t = do
- local <- hostIsLocal h
- unless local $ throwE t
-
-fromMaybeE :: Monad m => Maybe a -> Text -> ExceptT Text m a
-fromMaybeE Nothing t = throwE t
-fromMaybeE (Just x) _ = return x
-
-requireEitherM
- :: MonadIO m => Maybe a -> Maybe b -> String -> String -> m (Either a b)
-requireEitherM mx my f t =
- case requireEither mx my of
- Left b -> liftIO $ throwIO $ userError $ if b then t else f
- Right exy -> return exy
-
prependError :: Monad m => Text -> ExceptT Text m a -> ExceptT Text m a
prependError t a = do
r <- lift $ runExceptT a
@@ -431,139 +412,6 @@ parseTicket project luContext = do
else throwE "Local context ticket doesn't belong to the recipient project"
_ -> throwE "Local context isn't a ticket route"
-parseComment :: LocalURI -> ExceptT Text Handler (ShrIdent, LocalMessageId)
-parseComment luParent = do
- route <- case decodeRouteLocal luParent of
- Nothing -> throwE "Not a local route"
- Just r -> return r
- case route of
- MessageR shr hid -> (shr,) <$> decodeKeyHashidE hid "Non-existent local message hashid"
- _ -> throwE "Not a local message route"
-
-parseContext uContext = do
- let c@(hContext, luContext) = f2l uContext
- local <- hostIsLocal hContext
- if local
- then Left <$> do
- route <- case decodeRouteLocal luContext of
- Nothing -> throwE "Local context isn't a valid route"
- Just r -> return r
- case route of
- TicketR shr prj num -> return (shr, prj, num)
- _ -> throwE "Local context isn't a ticket route"
- else return $ Right c
-
-parseParent uParent = do
- let p@(hParent, luParent) = f2l uParent
- local <- hostIsLocal hParent
- if local
- then Left <$> do
- route <- case decodeRouteLocal luParent of
- Nothing -> throwE "Local parent isn't a valid route"
- Just r -> return r
- case route of
- MessageR shr lmkhid ->
- (shr,) <$>
- decodeKeyHashidE lmkhid
- "Local parent has non-existent message \
- \hashid"
- _ -> throwE "Local parent isn't a message route"
- else return $ Right p
-
-concatRecipients :: Audience -> [FedURI]
-concatRecipients (Audience to bto cc bcc gen _) = concat [to, bto, cc, bcc, gen]
-
-getLocalParentMessageId :: DiscussionId -> ShrIdent -> LocalMessageId -> ExceptT Text AppDB MessageId
-getLocalParentMessageId did shr lmid = do
- mlm <- lift $ get lmid
- lm <- fromMaybeE mlm "Local parent: no such lmid"
- p <- lift $ getJust $ localMessageAuthor lm
- s <- lift $ getJust $ personIdent p
- unless (shr == sharerIdent s) $ throwE "Local parent: No such message, lmid mismatches sharer"
- let mid = localMessageRest lm
- m <- lift $ getJust mid
- unless (messageRoot m == did) $
- throwE "Local parent belongs to a different discussion"
- return mid
-
-getPersonOrGroupId :: SharerId -> AppDB (Either PersonId GroupId)
-getPersonOrGroupId sid = do
- mpid <- getKeyBy $ UniquePersonIdent sid
- mgid <- getKeyBy $ UniqueGroup sid
- requireEitherM mpid mgid
- "Found sharer that is neither person nor group"
- "Found sharer that is both person and group"
-
-getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
-getTicketTeam sid = do
- id_ <- getPersonOrGroupId sid
- (,[]) <$> case id_ of
- Left pid -> return [pid]
- Right gid ->
- map (groupMemberPerson . entityVal) <$>
- selectList [GroupMemberGroup ==. gid] []
-
-getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
-getFollowers fsid = do
- local <- selectList [FollowTarget ==. fsid] []
- remote <- E.select $ E.from $ \ (rf `E.InnerJoin` rs `E.InnerJoin` i) -> do
- E.on $ rs E.^. RemoteActorInstance E.==. i E.^. InstanceId
- E.on $ rf E.^. RemoteFollowActor E.==. rs E.^. RemoteActorId
- E.where_ $ rf E.^. RemoteFollowTarget E.==. E.val fsid
- E.orderBy [E.asc $ i E.^. InstanceId]
- return
- ( i E.^. InstanceId
- , i E.^. InstanceHost
- , rs E.^. RemoteActorId
- , rs E.^. RemoteActorIdent
- , rs E.^. RemoteActorInbox
- , rs E.^. RemoteActorErrorSince
- )
- return
- ( map (followPerson . entityVal) local
- , groupRemotes $
- map (\ (E.Value iid, E.Value h, E.Value rsid, E.Value luActor, E.Value luInbox, E.Value msince) ->
- (iid, h, rsid, luActor, luInbox, msince)
- )
- remote
- )
- where
- groupRemotes :: [(InstanceId, Text, RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)] -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
- groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples
- where
- toTuples (iid, h, rsid, luA, luI, ms) = ((iid, h), (rsid, luA, luI, ms))
-
--- | Merge 2 lists ordered on fst, concatenating snd values when
--- multiple identical fsts occur. The resulting list is ordered on fst,
--- and each fst value appears only once.
---
--- >>> mergeWith (+) [('a',3), ('a',1), ('b',5)] [('a',2), ('c',4)]
--- [('a',6), ('b',5), ('c',4)]
-mergeConcat :: (Ord a, Semigroup b) => [(a, b)] -> [(a, b)] -> [(a, b)]
-mergeConcat xs ys = map (second sconcat) $ groupWithExtract fst snd $ LO.mergeBy (compare `on` fst) xs ys
-
-mergeConcat3 :: (Ord a, Semigroup b) => [(a, b)] -> [(a, b)] -> [(a, b)] -> [(a, b)]
-mergeConcat3 xs ys zs = mergeConcat xs $ LO.mergeBy (compare `on` fst) ys zs
-
-fst3 :: (a, b, c) -> a
-fst3 (x, _, _) = x
-
-fst4 :: (a, b, c, d) -> a
-fst4 (x, _, _, _) = x
-
-thd3 :: (a, b, c) -> c
-thd3 (_, _, z) = z
-
-fourth4 :: (a, b, c, d) -> d
-fourth4 (_, _, _, w) = w
-
-insertMany' mk xs = zip' xs <$> insertMany (NE.toList $ mk <$> xs)
- where
- zip' x y =
- case nonEmpty y of
- Just y' | length x == length y' -> NE.zip x y'
- _ -> error "insertMany' returned different length!"
-
handleSharerInbox
:: UTCTime
-> ShrIdent
@@ -610,91 +458,8 @@ handleSharerInbox _now shrRecip (Left pidAuthor) _raw activity = do
return $ "Activity inserted to inbox of /s/" <> recip
handleSharerInbox now shrRecip (Right iidSender) raw activity =
case activitySpecific activity of
- CreateActivity (Create note) -> handleNote note
+ CreateActivity (Create note) -> sharerCreateNoteRemoteF now shrRecip iidSender raw activity note
_ -> return "Unsupported activity type"
- where
- handleNote (Note mluNote _ _ muParent muContext mpublished _ _) = do
- _luNote <- fromMaybeE mluNote "Note without note id"
- _published <- fromMaybeE mpublished "Note without 'published' field"
- uContext <- fromMaybeE muContext "Note without context"
- context <- parseContext uContext
- mparent <-
- case muParent of
- Nothing -> return Nothing
- Just uParent ->
- if uParent == uContext
- then return Nothing
- else Just <$> parseParent uParent
- ExceptT $ runDB $ do
- personRecip <- do
- sid <- getKeyBy404 $ UniqueSharer shrRecip
- getValBy404 $ UniquePersonIdent sid
- valid <- checkContextParent context mparent
- case valid of
- Left e -> return $ Left e
- Right _ -> Right <$> insertToInbox (personInbox personRecip)
- where
- checkContextParent context mparent = runExceptT $ do
- case context of
- Left (shr, prj, num) -> do
- mdid <- lift $ runMaybeT $ do
- sid <- MaybeT $ getKeyBy $ UniqueSharer shr
- jid <- MaybeT $ getKeyBy $ UniqueProject prj sid
- t <- MaybeT $ getValBy $ UniqueTicket jid num
- return $ ticketDiscuss t
- did <- fromMaybeE mdid "Context: No such local ticket"
- for_ mparent $ \ parent ->
- case parent of
- Left (shrP, lmidP) ->
- void $ getLocalParentMessageId did shrP lmidP
- Right (hParent, luParent) -> do
- mrm <- lift $ runMaybeT $ do
- iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
- MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
- for_ mrm $ \ rm -> do
- let mid = remoteMessageRest rm
- m <- lift $ getJust mid
- unless (messageRoot m == did) $
- throwE "Remote parent belongs to a different discussion"
- Right (hContext, luContext) -> do
- mdid <- lift $ runMaybeT $ do
- iid <- MaybeT $ getKeyBy $ UniqueInstance hContext
- rd <- MaybeT $ getValBy $ UniqueRemoteDiscussionIdent iid luContext
- return $ remoteDiscussionDiscuss rd
- for_ mparent $ \ parent ->
- case parent of
- Left (shrP, lmidP) -> do
- did <- fromMaybeE mdid "Local parent inexistent, no RemoteDiscussion"
- void $ getLocalParentMessageId did shrP lmidP
- Right (hParent, luParent) -> do
- mrm <- lift $ runMaybeT $ do
- iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
- MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
- 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"
- insertToInbox ibidRecip = do
- let luActivity = activityId activity
- jsonObj = PersistJSON raw
- ract = RemoteActivity iidSender luActivity jsonObj now
- ractid <- either entityKey id <$> insertBy' ract
- ibiid <- insert $ InboxItem True
- mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
- let recip = shr2text shrRecip
- case mibrid of
- Nothing -> do
- delete ibiid
- return $ "Activity already exists in inbox of /s/" <> recip
- Just _ -> return $ "Activity inserted to inbox of /s/" <> recip
-
-data CreateNoteRecipColl
- = CreateNoteRecipProjectFollowers
- | CreateNoteRecipTicketParticipants
- | CreateNoteRecipTicketTeam
- deriving Eq
handleProjectInbox
:: UTCTime
@@ -710,272 +475,8 @@ handleProjectInbox
handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw activity =
case activitySpecific activity of
CreateActivity (Create note) ->
- handleNote (activityAudience activity) note
+ projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw activity (activityAudience activity) note
_ -> return "Unsupported activity type"
- where
- handleNote audience (Note mluNote _ _ muParent muCtx mpub src content) = do
- luNote <- fromMaybeE mluNote "Note without note id"
- published <- fromMaybeE mpub "Note without 'published' field"
- uContext <- fromMaybeE muCtx "Note without context"
- context <- parseContext uContext
- mparent <-
- case muParent of
- Nothing -> return Nothing
- Just uParent ->
- if uParent == uContext
- then return Nothing
- else Just <$> parseParent uParent
- case context of
- Right _ -> return $ recip <> " not using; context isn't local"
- Left (shr, prj, num) ->
- if shr /= shrRecip || prj /= prjRecip
- then return $ recip <> " not using; context is a different project"
- else do
- msig <- checkForward
- hLocal <- getsYesod $ appInstanceHost . appSettings
- let colls = findRelevantCollections hLocal num audience
- mremotesHttp <- runDBExcept $ do
- (sid, fsidProject, fsidTicket, jid, ibid, did, meparent) <- getContextAndParent num mparent
- lift $ join <$> do
- mmid <- insertToDiscussion luNote published ibid did meparent fsidTicket
- for mmid $ \ (ractid, mid) -> do
- updateOrphans luNote did mid
- for msig $ \ sig -> do
- remoteRecips <- deliverLocal ractid colls sid fsidProject fsidTicket
- (sig,) <$> deliverRemoteDB ractid jid sig remoteRecips
- lift $ for_ mremotesHttp $ \ (sig, remotesHttp) -> do
- let handler e = logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e)
- forkHandler handler $ deliverRemoteHttp sig remotesHttp
- return $ recip <> " inserted new ticket comment"
- where
- checkForward = join <$> do
- let hSig = hForwardingSignature
- msig <- maybeHeader hSig
- for msig $ \ sig -> do
- _proof <- withExceptT (T.pack . displayException) $ ExceptT $
- let requires = [hDigest, hActivityPubForwarder]
- in prepareToVerifyHttpSigWith hSig False requires [] Nothing
- forwarder <- requireHeader hActivityPubForwarder
- renderUrl <- getUrlRender
- let project = renderUrl $ ProjectR shrRecip prjRecip
- return $
- if forwarder == encodeUtf8 project
- then Just sig
- else Nothing
- where
- maybeHeader n = do
- let n' = decodeUtf8 $ CI.original n
- hs <- lookupHeaders n
- case hs of
- [] -> return Nothing
- [h] -> return $ Just h
- _ -> throwE $ n' <> " multiple headers found"
- requireHeader n = do
- let n' = decodeUtf8 $ CI.original n
- mh <- maybeHeader n
- case mh of
- Nothing -> throwE $ n' <> " header not found"
- Just h -> return h
- findRelevantCollections hLocal numCtx = nub . mapMaybe decide . concatRecipients
- where
- decide u = do
- let (h, lu) = f2l u
- guard $ h == hLocal
- route <- decodeRouteLocal lu
- case route of
- ProjectFollowersR shr prj
- | shr == shrRecip && prj == prjRecip
- -> Just CreateNoteRecipProjectFollowers
- TicketParticipantsR shr prj num
- | shr == shrRecip && prj == prjRecip && num == numCtx
- -> Just CreateNoteRecipTicketParticipants
- TicketTeamR shr prj num
- | shr == shrRecip && prj == prjRecip && num == numCtx
- -> Just CreateNoteRecipTicketTeam
- _ -> Nothing
- recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip]
- getContextAndParent num mparent = do
- mt <- lift $ do
- sid <- getKeyBy404 $ UniqueSharer shrRecip
- Entity jid j <- getBy404 $ UniqueProject prjRecip sid
- fmap (jid, projectInbox j, projectFollowers j, sid ,) <$>
- getValBy (UniqueTicket jid num)
- (jid, ibid, fsidProject, sid, t) <- fromMaybeE mt "Context: No such local ticket"
- let did = ticketDiscuss t
- meparent <- for mparent $ \ parent ->
- case parent of
- Left (shrParent, lmidParent) -> Left <$> getLocalParentMessageId did shrParent lmidParent
- Right p@(hParent, luParent) -> do
- mrm <- lift $ runMaybeT $ do
- iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
- MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
- case mrm of
- Just rm -> Left <$> do
- let mid = remoteMessageRest rm
- m <- lift $ getJust mid
- unless (messageRoot m == did) $
- throwE "Remote parent belongs to a different discussion"
- return mid
- Nothing -> return $ Right $ l2f hParent luParent
- return (sid, fsidProject, ticketFollowers t, jid, ibid, did, meparent)
- insertToDiscussion luNote published ibid did meparent fsid = do
- ractid <- either entityKey id <$> insertBy' RemoteActivity
- { remoteActivityInstance = iidSender
- , remoteActivityIdent = activityId activity
- , remoteActivityContent = PersistJSON raw
- , remoteActivityReceived = now
- }
- mid <- insert Message
- { messageCreated = published
- , messageSource = src
- , messageContent = content
- , messageParent =
- case meparent of
- Just (Left midParent) -> Just midParent
- _ -> Nothing
- , messageRoot = did
- }
- mrmid <- insertUnique RemoteMessage
- { remoteMessageAuthor = raidSender
- , remoteMessageInstance = iidSender
- , remoteMessageIdent = luNote
- , remoteMessageRest = mid
- , remoteMessageCreate = ractid
- , remoteMessageLostParent =
- case meparent of
- Just (Right uParent) -> Just uParent
- _ -> Nothing
- }
- case mrmid of
- Nothing -> do
- delete mid
- return Nothing
- Just _ -> do
- insertUnique_ $ RemoteFollow raidSender fsid False
- ibiid <- insert $ InboxItem False
- insert_ $ InboxItemRemote ibid ractid ibiid
- return $ Just (ractid, mid)
- updateOrphans luNote did mid = do
- let uNote = l2f hSender luNote
- related <- selectOrphans uNote (E.==.)
- for_ related $ \ (E.Value rmidOrphan, E.Value midOrphan) -> do
- logWarn $ T.concat
- [ "Found parent for related orphan RemoteMessage #"
- , T.pack (show rmidOrphan)
- , ", setting its parent now to Message #"
- , T.pack (show mid)
- ]
- update rmidOrphan [RemoteMessageLostParent =. Nothing]
- update midOrphan [MessageParent =. Just mid]
- unrelated <- selectOrphans uNote (E.!=.)
- for_ unrelated $ \ (E.Value rmidOrphan, E.Value _midOrphan) ->
- logWarn $ T.concat
- [ "Found parent for unrelated orphan RemoteMessage #"
- , T.pack (show rmidOrphan)
- , ", NOT settings its parent to Message #"
- , T.pack (show mid)
- , " because they have different DiscussionId!"
- ]
- where
- selectOrphans uNote op =
- E.select $ E.from $ \ (rm `E.InnerJoin` m) -> do
- E.on $ rm E.^. RemoteMessageRest E.==. m E.^. MessageId
- E.where_ $
- rm E.^. RemoteMessageLostParent E.==. E.just (E.val uNote) E.&&.
- m E.^. MessageRoot `op` E.val did
- return (rm E.^. RemoteMessageId, m E.^. MessageId)
- deliverLocal
- :: RemoteActivityId
- -> [CreateNoteRecipColl]
- -> SharerId
- -> FollowerSetId
- -> FollowerSetId
- -> AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
- deliverLocal ractid recips sid fsidProject fsidTicket = do
- (teamPids, teamRemotes) <-
- if CreateNoteRecipTicketTeam `elem` recips
- then getTicketTeam sid
- else return ([], [])
- (tfsPids, tfsRemotes) <-
- if CreateNoteRecipTicketParticipants `elem` recips
- then getFollowers fsidTicket
- else return ([], [])
- (jfsPids, jfsRemotes) <-
- if CreateNoteRecipProjectFollowers `elem` recips
- then getFollowers fsidProject
- else return ([], [])
- let pids = union teamPids tfsPids `union` jfsPids
- -- TODO inefficient, see the other TODOs about mergeConcat
- remotes = map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat3 teamRemotes tfsRemotes jfsRemotes
- for_ pids $ \ pid -> do
- ibid <- personInbox <$> getJust pid
- ibiid <- insert $ InboxItem True
- mibrid <- insertUnique $ InboxItemRemote ibid ractid ibiid
- when (isNothing mibrid) $
- delete ibiid
- return remotes
-
- deliverRemoteDB
- :: RemoteActivityId
- -> ProjectId
- -> ByteString
- -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
- -> AppDB
- [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
- deliverRemoteDB ractid jid sig recips = do
- let body' = BL.toStrict body
- deliv raid msince = Forwarding raid ractid body' jid sig $ isNothing msince
- fetchedDeliv <- for recips $ \ (i, rs) ->
- (i,) <$> insertMany' (\ (raid, _, _, msince) -> deliv raid msince) rs
- return $ takeNoError4 fetchedDeliv
- where
- takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
- takeNoError4 = takeNoError noError
- where
- noError ((ak, luA, luI, Nothing), dlk) = Just (ak, luA, luI, dlk)
- noError ((_ , _ , _ , Just _ ), _ ) = Nothing
-
- deliverRemoteHttp
- :: ByteString
- -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
- -> Handler ()
- deliverRemoteHttp sig fetched = do
- let deliver h inbox = do
- forwardActivity (l2f h inbox) sig (ProjectR shrRecip prjRecip) body
- now <- liftIO getCurrentTime
- traverse_ (fork . deliverFetched deliver now) fetched
- where
- fork = forkHandler $ \ e -> logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e)
- deliverFetched deliver now ((_, h), recips@(r :| rs)) = do
- let (raid, _luActor, luInbox, fwid) = r
- e <- deliver h luInbox
- let e' = case e of
- Left err ->
- if isInstanceErrorP err
- then Nothing
- else Just False
- Right _resp -> Just True
- case e' of
- Nothing -> runDB $ do
- let recips' = NE.toList recips
- updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
- updateWhere [ForwardingId <-. map fourth4 recips'] [ForwardingRunning =. False]
- Just success -> do
- runDB $
- if success
- then delete fwid
- else do
- updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
- update fwid [ForwardingRunning =. False]
- for_ rs $ \ (raid, _luActor, luInbox, fwid) ->
- fork $ do
- e <- deliver h luInbox
- runDB $
- case e of
- Left _err -> do
- updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
- update fwid [ForwardingRunning =. False]
- Right _resp -> delete fwid
fixRunningDeliveries :: (MonadIO m, MonadLogger m, IsSqlBackend backend) => ReaderT backend m ()
fixRunningDeliveries = do
@@ -998,720 +499,6 @@ fixRunningDeliveries = do
, " forwarding deliveries"
]
-data LocalTicketRecipient = LocalTicketParticipants | LocalTicketTeam
- deriving (Eq, Ord)
-
-data LocalProjectRecipient
- = LocalProject
- | LocalProjectFollowers
- | LocalTicketRelated Int LocalTicketRecipient
- deriving (Eq, Ord)
-
-data LocalSharerRecipient
- = LocalSharer
- | LocalProjectRelated PrjIdent LocalProjectRecipient
- deriving (Eq, Ord)
-
-data LocalRecipient = LocalSharerRelated ShrIdent LocalSharerRecipient
- deriving (Eq, Ord)
-
-data LocalTicketRelatedSet
- = OnlyTicketParticipants
- | OnlyTicketTeam
- | BothTicketParticipantsAndTeam
-
-data LocalProjectRelatedSet = LocalProjectRelatedSet
- { localRecipProject :: Bool
- , localRecipProjectFollowers :: Bool
- , localRecipTicketRelated :: [(Int, LocalTicketRelatedSet)]
- }
-
-data LocalSharerRelatedSet = LocalSharerRelatedSet
- { localRecipSharer :: Bool
- , localRecipProjectRelated :: [(PrjIdent, LocalProjectRelatedSet)]
- }
-
-type LocalRecipientSet = [(ShrIdent, LocalSharerRelatedSet)]
-
-newtype FedError = FedError Text deriving Show
-
-instance Exception FedError
-
-runDBExcept action = do
- result <-
- lift $ try $ runDB $ either abort return =<< runExceptT action
- case result of
- Left (FedError t) -> throwE t
- Right r -> return r
- where
- abort = liftIO . throwIO . FedError
-
-deliverHttp
- :: (MonadSite m, SiteEnv m ~ App)
- => Doc Activity
- -> Maybe LocalURI
- -> Text
- -> LocalURI
- -> m (Either APPostError (Response ()))
-deliverHttp doc mfwd h luInbox =
- deliverActivity (l2f h luInbox) (l2f h <$> mfwd) doc
-
-isInstanceErrorHttp (InvalidUrlException _ _) = False
-isInstanceErrorHttp (HttpExceptionRequest _ hec) =
- case hec of
- ResponseTimeout -> True
- ConnectionTimeout -> True
- InternalException se ->
- case fromException se of
- Just (HandshakeFailed _) -> True
- _ -> False
- _ -> False
-
-isInstanceErrorP (APPostErrorSig _) = False
-isInstanceErrorP (APPostErrorHTTP he) = isInstanceErrorHttp he
-
-isInstanceErrorG Nothing = False
-isInstanceErrorG (Just e) =
- case e of
- APGetErrorHTTP he -> isInstanceErrorHttp he
- APGetErrorJSON _ -> False
- APGetErrorContentType _ -> False
-
-data Recip
- = RecipRA (Entity RemoteActor)
- | RecipURA (Entity UnfetchedRemoteActor)
- | RecipRC (Entity RemoteCollection)
-
--- | Handle a Note submitted by a local user to their outbox. It can be either
--- a comment on a local ticket, or a comment on some remote context. Return an
--- error message if the Note is rejected, otherwise the new 'LocalMessageId'.
-handleOutboxNote :: Text -> Note -> Handler (Either Text LocalMessageId)
-handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished source content) = runExceptT $ do
- verifyHostLocal host "Attributed to non-local actor"
- verifyNothing mluNote "Note specifies an id"
- verifyNothing mpublished "Note specifies published"
- uContext <- fromMaybeE muContext "Note without context"
- recips <- nonEmptyE (concatRecipients aud) "Note without recipients"
- (mparent, localRecips, mticket, remoteRecips) <- parseRecipsContextParent recips uContext muParent
- federation <- getsYesod $ appFederation . appSettings
- unless (federation || null remoteRecips) $
- throwE "Federation disabled, but remote recipients specified"
- result <- lift $ try $ runDB $ (either abort return =<<) . runExceptT $ do
- (pid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor"
- (did, meparent, mcollections) <- case mticket of
- Just (shr, prj, num) -> do
- mt <- lift $ runMaybeT $ do
- sid <- MaybeT $ getKeyBy $ UniqueSharer shr
- Entity jid j <- MaybeT $ getBy $ UniqueProject prj sid
- t <- MaybeT $ getValBy $ UniqueTicket jid num
- return (sid, projectInbox j, projectFollowers j, t)
- (sid, ibidProject, fsidProject, t) <- fromMaybeE mt "Context: No such local ticket"
- let did = ticketDiscuss t
- mmidParent <- for mparent $ \ parent ->
- case parent of
- Left (shrParent, lmidParent) -> getLocalParentMessageId did shrParent lmidParent
- Right (hParent, luParent) -> do
- mrm <- lift $ runMaybeT $ do
- iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
- MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
- rm <- fromMaybeE mrm "Remote parent unknown locally"
- let mid = remoteMessageRest rm
- m <- lift $ getJust mid
- unless (messageRoot m == did) $
- throwE "Remote parent belongs to a different discussion"
- return mid
- lift $ insertUnique_ $ Follow pid (ticketFollowers t) False
- return (did, Left <$> mmidParent, Just (sid, ticketFollowers t, ibidProject, fsidProject))
- Nothing -> do
- (rd, rdnew) <- lift $ do
- let (hContext, luContext) = f2l uContext
- iid <- either entityKey id <$> insertBy' (Instance hContext)
- mrd <- getValBy $ UniqueRemoteDiscussionIdent iid luContext
- case mrd of
- Just rd -> return (rd, False)
- Nothing -> do
- did <- insert Discussion
- let rd = RemoteDiscussion iid luContext did
- erd <- insertBy' rd
- case erd of
- Left (Entity _ rd') -> do
- delete did
- return (rd', False)
- Right _ -> return (rd, True)
- let did = remoteDiscussionDiscuss rd
- meparent <- for mparent $ \ parent ->
- case parent of
- Left (shrParent, lmidParent) -> do
- when rdnew $ throwE "Local parent inexistent, RemoteDiscussion is new"
- Left <$> getLocalParentMessageId did shrParent lmidParent
- Right (hParent, luParent) -> do
- mrm <- lift $ runMaybeT $ do
- iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
- MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
- case mrm of
- Nothing -> return $ Right $ l2f hParent luParent
- Just rm -> Left <$> do
- let mid = remoteMessageRest rm
- m <- lift $ getJust mid
- unless (messageRoot m == did) $
- throwE "Remote parent belongs to a different discussion"
- return mid
- return (did, meparent, Nothing)
- (lmid, obid, doc) <- lift $ insertMessage luAttrib shrUser pid uContext did muParent meparent source content
- moreRemotes <- deliverLocal pid obid localRecips mcollections
- unless (federation || null moreRemotes) $
- throwE "Federation disabled but remote collection members found"
- remotesHttp <- lift $ deliverRemoteDB (furiHost uContext) obid remoteRecips moreRemotes
- return (lmid, obid, doc, remotesHttp)
- (lmid, obid, doc, remotesHttp) <- case result of
- Left (FedError t) -> throwE t
- Right r -> return r
- lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp (furiHost uContext) obid doc remotesHttp
- return lmid
- where
- verifyNothing :: Monad m => Maybe a -> e -> ExceptT e m ()
- verifyNothing Nothing _ = return ()
- verifyNothing (Just _) e = throwE e
-
- nonEmptyE :: Monad m => [a] -> e -> ExceptT e m (NonEmpty a)
- nonEmptyE l e =
- case nonEmpty l of
- Nothing -> throwE e
- Just ne -> return ne
-
- parseRecipsContextParent
- :: NonEmpty FedURI
- -> FedURI
- -> Maybe FedURI
- -> ExceptT Text Handler
- ( Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI))
- , [ShrIdent]
- , Maybe (ShrIdent, PrjIdent, Int)
- , [FedURI]
- )
- parseRecipsContextParent recips uContext muParent = do
- (locals, remotes) <- lift $ splitRecipients recips
- let (localsParsed, localsRest) = parseLocalRecipients locals
- unless (null localsRest) $
- throwE "Note has invalid local recipients"
- let localsSet = groupLocalRecipients localsParsed
- (hContext, luContext) = f2l uContext
- parent <- parseParent uContext muParent
- local <- hostIsLocal hContext
- let remotes' = remotes L.\\ audienceNonActors aud
- if local
- then do
- ticket <- parseContextTicket luContext
- shrs <- verifyTicketRecipients ticket localsSet
- return (parent, shrs, Just ticket, remotes')
- else do
- shrs <- verifyOnlySharers localsSet
- return (parent, shrs, Nothing, remotes')
- where
- -- First step: Split into remote and local:
- splitRecipients :: NonEmpty FedURI -> Handler ([LocalURI], [FedURI])
- splitRecipients recips = do
- home <- getsYesod $ appInstanceHost . appSettings
- let (local, remote) = NE.partition ((== home) . furiHost) recips
- return (map (snd . f2l) local, remote)
-
- -- Parse the local recipients
- parseLocalRecipients :: [LocalURI] -> ([LocalRecipient], [Either LocalURI (Route App)])
- parseLocalRecipients = swap . partitionEithers . map decide
- where
- parseLocalRecipient (SharerR shr) = Just $ LocalSharerRelated shr LocalSharer
- parseLocalRecipient (ProjectR shr prj) =
- Just $ LocalSharerRelated shr $ LocalProjectRelated prj LocalProject
- parseLocalRecipient (ProjectFollowersR shr prj) =
- Just $ LocalSharerRelated shr $ LocalProjectRelated prj LocalProjectFollowers
- parseLocalRecipient (TicketParticipantsR shr prj num) =
- Just $ LocalSharerRelated shr $ LocalProjectRelated prj $ LocalTicketRelated num LocalTicketParticipants
- parseLocalRecipient (TicketTeamR shr prj num) =
- Just $ LocalSharerRelated shr $ LocalProjectRelated prj $ LocalTicketRelated num LocalTicketTeam
- parseLocalRecipient _ = Nothing
- decide lu =
- case decodeRouteLocal lu of
- Nothing -> Left $ Left lu
- Just route ->
- case parseLocalRecipient route of
- Nothing -> Left $ Right route
- Just lr -> Right lr
-
- -- Group local recipients
- groupLocalRecipients :: [LocalRecipient] -> LocalRecipientSet
- groupLocalRecipients
- = map
- ( second
- $ uncurry LocalSharerRelatedSet
- . bimap
- (not . null)
- ( map
- ( second
- $ uncurry localProjectRelatedSet
- . bimap
- ( bimap (not . null) (not . null)
- . partition id
- )
- ( map (second ltrs2ltrs)
- . groupWithExtract fst snd
- )
- . partitionEithers
- . NE.toList
- )
- . groupWithExtract fst (lpr2e . snd)
- )
- . partitionEithers
- . NE.toList
- )
- . groupWithExtract
- (\ (LocalSharerRelated shr _) -> shr)
- (\ (LocalSharerRelated _ lsr) -> lsr2e lsr)
- . sort
- where
- lsr2e LocalSharer = Left ()
- lsr2e (LocalProjectRelated prj lpr) = Right (prj, lpr)
- lpr2e LocalProject = Left False
- lpr2e LocalProjectFollowers = Left True
- lpr2e (LocalTicketRelated num ltr) = Right (num, ltr)
- ltrs2ltrs (LocalTicketParticipants :| l) =
- if LocalTicketTeam `elem` l
- then BothTicketParticipantsAndTeam
- else OnlyTicketParticipants
- ltrs2ltrs (LocalTicketTeam :| l) =
- if LocalTicketParticipants `elem` l
- then BothTicketParticipantsAndTeam
- else OnlyTicketTeam
- localProjectRelatedSet (f, j) t =
- LocalProjectRelatedSet j f t
-
- parseParent :: FedURI -> Maybe FedURI -> ExceptT Text Handler (Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI)))
- parseParent _ Nothing = return Nothing
- parseParent uContext (Just uParent) =
- if uParent == uContext
- then return Nothing
- else Just <$> do
- let (hParent, luParent) = f2l uParent
- parentLocal <- hostIsLocal hParent
- if parentLocal
- then Left <$> parseComment luParent
- else return $ Right (hParent, luParent)
-
- parseContextTicket :: Monad m => LocalURI -> ExceptT Text m (ShrIdent, PrjIdent, Int)
- parseContextTicket luContext = do
- route <- case decodeRouteLocal luContext of
- Nothing -> throwE "Local context isn't a valid route"
- Just r -> return r
- case route of
- TicketR shr prj num -> return (shr, prj, num)
- _ -> throwE "Local context isn't a ticket route"
-
- atMostSharer :: e -> (ShrIdent, LocalSharerRelatedSet) -> ExceptT e Handler (Maybe ShrIdent)
- atMostSharer _ (shr, LocalSharerRelatedSet s []) = return $ if s then Just shr else Nothing
- atMostSharer e (_ , LocalSharerRelatedSet _ _ ) = throwE e
-
- verifyTicketRecipients :: (ShrIdent, PrjIdent, Int) -> LocalRecipientSet -> ExceptT Text Handler [ShrIdent]
- verifyTicketRecipients (shr, prj, num) recips = do
- lsrSet <- fromMaybeE (lookupSorted shr recips) "Note with local context: No required recipients"
- (prj', lprSet) <- verifySingleton (localRecipProjectRelated lsrSet) "Note project-related recipient sets"
- unless (prj == prj') $ throwE "Note project recipients mismatch context's project"
- unless (localRecipProject lprSet) $ throwE "Note context's project not addressed"
- unless (localRecipProjectFollowers lprSet) $ throwE "Note context's project followers not addressed"
- (num', ltrSet) <- verifySingleton (localRecipTicketRelated lprSet) "Note ticket-related recipient sets"
- unless (num == num') $ throwE "Note project recipients mismatch context's ticket number"
- case ltrSet of
- OnlyTicketParticipants -> throwE "Note ticket participants not addressed"
- OnlyTicketTeam -> throwE "Note ticket team not addressed"
- BothTicketParticipantsAndTeam -> return ()
- let rest = deleteBy ((==) `on` fst) (shr, lsrSet) recips
- orig = if localRecipSharer lsrSet then Just shr else Nothing
- catMaybes . (orig :) <$> traverse (atMostSharer "Note with unrelated non-sharer recipients") rest
- where
- verifySingleton :: Monad m => [a] -> Text -> ExceptT Text m a
- verifySingleton [] t = throwE $ t <> ": expected 1, got 0"
- verifySingleton [x] _ = return x
- verifySingleton l t = throwE $ t <> ": expected 1, got " <> T.pack (show $ length l)
-
- verifyOnlySharers :: LocalRecipientSet -> ExceptT Text Handler [ShrIdent]
- verifyOnlySharers lrs = catMaybes <$> traverse (atMostSharer "Note with remote context but local project-related recipients") lrs
-
- abort :: Text -> AppDB a
- abort = liftIO . throwIO . FedError
-
- verifyIsLoggedInUser :: LocalURI -> Text -> ExceptT Text AppDB (PersonId, ShrIdent)
- verifyIsLoggedInUser lu t = do
- Entity pid p <- requireVerifiedAuth
- s <- lift $ getJust $ personIdent p
- route2local <- getEncodeRouteLocal
- let shr = sharerIdent s
- if route2local (SharerR shr) == lu
- then return (pid, shr)
- else throwE t
-
- insertMessage
- :: LocalURI
- -> ShrIdent
- -> PersonId
- -> FedURI
- -> DiscussionId
- -> Maybe FedURI
- -> Maybe (Either MessageId FedURI)
- -> Text
- -> Text
- -> AppDB (LocalMessageId, OutboxItemId, Doc Activity)
- insertMessage luAttrib shrUser pid uContext did muParent meparent source content = do
- now <- liftIO getCurrentTime
- mid <- insert Message
- { messageCreated = now
- , messageSource = source
- , messageContent = content
- , messageParent =
- case meparent of
- Just (Left midParent) -> Just midParent
- _ -> Nothing
- , messageRoot = did
- }
- let activity luAct luNote = Doc host Activity
- { activityId = luAct
- , activityActor = luAttrib
- , activityAudience = aud
- , activitySpecific = CreateActivity Create
- { createObject = Note
- { noteId = Just luNote
- , noteAttrib = luAttrib
- , noteAudience = aud
- , noteReplyTo = Just $ fromMaybe uContext muParent
- , noteContext = Just uContext
- , notePublished = Just now
- , noteContent = content
- }
- }
- }
- tempUri = LocalURI "" ""
- obid <- insert OutboxItem
- { outboxItemPerson = pid
- , outboxItemActivity = PersistJSON $ activity tempUri tempUri
- , outboxItemPublished = now
- }
- lmid <- insert LocalMessage
- { localMessageAuthor = pid
- , localMessageRest = mid
- , localMessageCreate = obid
- , localMessageUnlinkedParent =
- case meparent of
- Just (Right uParent) -> Just uParent
- _ -> Nothing
- }
- route2local <- getEncodeRouteLocal
- obhid <- encodeKeyHashid obid
- lmhid <- encodeKeyHashid lmid
- let luAct = route2local $ OutboxItemR shrUser obhid
- luNote = route2local $ MessageR shrUser lmhid
- doc = activity luAct luNote
- update obid [OutboxItemActivity =. PersistJSON doc]
- return (lmid, obid, doc)
-
- -- Deliver to local recipients. For local users, find in DB and deliver.
- -- For local collections, expand them, deliver to local users, and return a
- -- list of remote actors found in them.
- deliverLocal
- :: PersonId
- -> OutboxItemId
- -> [ShrIdent]
- -> Maybe (SharerId, FollowerSetId, InboxId, FollowerSetId)
- -> ExceptT Text AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
- deliverLocal pidAuthor obid recips mticket = do
- recipPids <- traverse getPersonId $ nub recips
- when (pidAuthor `elem` recipPids) $
- throwE "Note addressed to note author"
- (morePids, remotes) <-
- lift $ case mticket of
- Nothing -> return ([], [])
- Just (sid, fsidT, _, fsidJ) -> do
- (teamPids, teamRemotes) <- getTicketTeam sid
- (tfsPids, tfsRemotes) <- getFollowers fsidT
- (jfsPids, jfsRemotes) <- getFollowers fsidJ
- return
- ( L.delete pidAuthor $ union teamPids $ union tfsPids jfsPids
- -- TODO this is inefficient! The way this combines
- -- same-host sharer lists is:
- --
- -- (1) concatenate them
- -- (2) nubBy fst to remove duplicates
- --
- -- But we have knowledge that:
- --
- -- (1) in each of the 2 lists we're combining, each
- -- instance occurs only once
- -- (2) in each actor list, each actor occurs only
- -- once
- --
- -- So we can improve this code by:
- --
- -- (1) Not assume arbitrary number of consecutive
- -- repetition of the same instance, we may only
- -- have repetition if the same instance occurs
- -- in both lists
- -- (2) Don't <> the lists, instead apply unionBy or
- -- something better (unionBy assumes one list
- -- may have repetition, but removes repetition
- -- from the other; we know both lists have no
- -- repetition, can we use that to do this
- -- faster than unionBy?)
- --
- -- Also, if we ask the DB to sort by actor, then in
- -- the (2) point above, instead of unionBy we can use
- -- the knowledge the lists are sorted, and apply
- -- LO.unionBy instead. Or even better, because
- -- LO.unionBy doesn't assume no repetitions (possibly
- -- though it still does it the fastest way).
- --
- -- So, in mergeConcat, don't start with merging,
- -- because we lose the knowledge that each list's
- -- instances aren't repeated. Use a custom merge
- -- where we can unionBy or LO.unionBy whenever both
- -- lists have the same instance.
- , map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat3 teamRemotes tfsRemotes jfsRemotes
- )
- lift $ do
- for_ mticket $ \ (_, _, ibidProject, _) -> do
- ibiid <- insert $ InboxItem False
- insert_ $ InboxItemLocal ibidProject obid ibiid
- for_ (union recipPids morePids) $ \ pid -> do
- ibid <- personInbox <$> getJust pid
- ibiid <- insert $ InboxItem True
- insert_ $ InboxItemLocal ibid obid ibiid
- return remotes
- where
- getPersonId :: ShrIdent -> ExceptT Text AppDB PersonId
- getPersonId shr = do
- msid <- lift $ getKeyBy $ UniqueSharer shr
- sid <- fromMaybeE msid "Local Note addresses nonexistent local sharer"
- id_ <- lift $ getPersonOrGroupId sid
- case id_ of
- Left pid -> return pid
- Right _gid -> throwE "Local Note addresses a local group"
-
- {-
- -- Deliver to a local sharer, if they exist as a user account
- deliverToLocalSharer :: OutboxItemId -> ShrIdent -> ExceptT Text AppDB ()
- deliverToLocalSharer obid shr = do
- msid <- lift $ getKeyBy $ UniqueSharer shr
- sid <- fromMaybeE msid "Local Note addresses nonexistent local sharer"
- mpid <- lift $ getKeyBy $ UniquePersonIdent sid
- mgid <- lift $ getKeyBy $ UniqueGroup sid
- id_ <-
- requireEitherM mpid mgid
- "Found sharer that is neither person nor group"
- "Found sharer that is both person and group"
- case id_ of
- Left pid -> lift $ insert_ $ InboxItemLocal pid obid
- Right _gid -> throwE "Local Note addresses a local group"
- -}
-
- deliverRemoteDB
- :: Text
- -> OutboxItemId
- -> [FedURI]
- -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
- -> AppDB
- ( [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
- , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
- , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
- )
- deliverRemoteDB hContext obid recips known = do
- recips' <- for (groupByHost recips) $ \ (h, lus) -> do
- let lus' = NE.nub lus
- (iid, inew) <- idAndNew <$> insertBy' (Instance h)
- if inew
- then return ((iid, h), (Nothing, Nothing, Just lus'))
- else do
- es <- for lus' $ \ lu -> do
- ma <- runMaybeT
- $ RecipRA <$> MaybeT (getBy $ UniqueRemoteActor iid lu)
- <|> RecipURA <$> MaybeT (getBy $ UniqueUnfetchedRemoteActor iid lu)
- <|> RecipRC <$> MaybeT (getBy $ UniqueRemoteCollection iid lu)
- return $
- case ma of
- Nothing -> Just $ Left lu
- Just r ->
- case r of
- RecipRA (Entity raid ra) -> Just $ Right $ Left (raid, remoteActorIdent ra, remoteActorInbox ra, remoteActorErrorSince ra)
- RecipURA (Entity uraid ura) -> Just $ Right $ Right (uraid, unfetchedRemoteActorIdent ura, unfetchedRemoteActorSince ura)
- RecipRC _ -> Nothing
- let (unknown, newKnown) = partitionEithers $ catMaybes $ NE.toList es
- (fetched, unfetched) = partitionEithers newKnown
- return ((iid, h), (nonEmpty fetched, nonEmpty unfetched, nonEmpty unknown))
- let moreKnown = mapMaybe (\ (i, (f, _, _)) -> (i,) <$> f) recips'
- unfetched = mapMaybe (\ (i, (_, uf, _)) -> (i,) <$> uf) recips'
- stillUnknown = mapMaybe (\ (i, (_, _, uk)) -> (i,) <$> uk) recips'
- -- TODO see the earlier TODO about merge, it applies here too
- allFetched = map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat known moreKnown
- fetchedDeliv <- for allFetched $ \ (i, rs) ->
- let fwd = snd i == hContext
- in (i,) <$> insertMany' (\ (raid, _, _, msince) -> Delivery raid obid fwd $ isNothing msince) rs
- unfetchedDeliv <- for unfetched $ \ (i, rs) ->
- let fwd = snd i == hContext
- in (i,) <$> insertMany' (\ (uraid, _, msince) -> UnlinkedDelivery uraid obid fwd $ isNothing msince) rs
- unknownDeliv <- for stillUnknown $ \ (i, lus) -> do
- -- TODO maybe for URA insertion we should do insertUnique?
- rs <- insertMany' (\ lu -> UnfetchedRemoteActor (fst i) lu Nothing) lus
- let fwd = snd i == hContext
- (i,) <$> insertMany' (\ (_, uraid) -> UnlinkedDelivery uraid obid fwd True) rs
- return
- ( takeNoError4 fetchedDeliv
- , takeNoError3 unfetchedDeliv
- , map
- (second $ NE.map $ \ ((lu, ak), dlk) -> (ak, lu, dlk))
- unknownDeliv
- )
- where
- groupByHost :: [FedURI] -> [(Text, NonEmpty LocalURI)]
- groupByHost = groupAllExtract furiHost (snd . f2l)
-
- takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
- takeNoError3 = takeNoError noError
- where
- noError ((ak, lu, Nothing), dlk) = Just (ak, lu, dlk)
- noError ((_ , _ , Just _ ), _ ) = Nothing
- takeNoError4 = takeNoError noError
- where
- noError ((ak, luA, luI, Nothing), dlk) = Just (ak, luA, luI, dlk)
- noError ((_ , _ , _ , Just _ ), _ ) = Nothing
-
- deliverRemoteHttp
- :: Text
- -> OutboxItemId
- -> Doc Activity
- -> ( [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
- , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
- , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
- )
- -> Worker ()
- deliverRemoteHttp hContext obid doc (fetched, unfetched, unknown) = do
- logDebug' "Starting"
- let deliver fwd h inbox = do
- let fwd' = if h == hContext then Just fwd else Nothing
- (isJust fwd',) <$> deliverHttp doc fwd' h inbox
- now <- liftIO getCurrentTime
- logDebug' $
- "Launching fetched " <> T.pack (show $ map (snd . fst) fetched)
- traverse_ (fork . deliverFetched deliver now) fetched
- logDebug' $
- "Launching unfetched " <> T.pack (show $ map (snd . fst) unfetched)
- traverse_ (fork . deliverUnfetched deliver now) unfetched
- logDebug' $
- "Launching unknown " <> T.pack (show $ map (snd . fst) unknown)
- traverse_ (fork . deliverUnfetched deliver now) unknown
- logDebug' "Done (async delivery may still be running)"
- where
- logDebug' t = logDebug $ prefix <> t
- where
- prefix =
- T.concat
- [ "Outbox POST handler: deliverRemoteHttp obid#"
- , T.pack $ show $ fromSqlKey obid
- , ": "
- ]
- fork = forkWorker "Outbox POST handler: HTTP delivery"
- deliverFetched deliver now ((_, h), recips@(r :| rs)) = do
- logDebug'' "Starting"
- let (raid, luActor, luInbox, dlid) = r
- (_, e) <- deliver luActor h luInbox
- e' <- case e of
- Left err -> do
- logError $ T.concat
- [ "Outbox DL delivery #", T.pack $ show dlid
- , " error for <", renderFedURI $ l2f h luActor
- , ">: ", T.pack $ displayException err
- ]
- return $
- if isInstanceErrorP err
- then Nothing
- else Just False
- Right _resp -> return $ Just True
- case e' of
- Nothing -> runSiteDB $ do
- let recips' = NE.toList recips
- updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
- updateWhere [DeliveryId <-. map fourth4 recips'] [DeliveryRunning =. False]
- Just success -> do
- runSiteDB $
- if success
- then delete dlid
- else do
- updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
- update dlid [DeliveryRunning =. False]
- for_ rs $ \ (raid, luActor, luInbox, dlid) ->
- fork $ do
- (_, e) <- deliver luActor h luInbox
- runSiteDB $
- case e of
- Left err -> do
- logError $ T.concat
- [ "Outbox DL delivery #", T.pack $ show dlid
- , " error for <", renderFedURI $ l2f h luActor
- , ">: ", T.pack $ displayException err
- ]
- updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
- update dlid [DeliveryRunning =. False]
- Right _resp -> delete dlid
- where
- logDebug'' t = logDebug' $ T.concat ["deliverFetched ", h, t]
- deliverUnfetched deliver now ((iid, h), recips@(r :| rs)) = do
- logDebug'' "Starting"
- let (uraid, luActor, udlid) = r
- e <- fetchRemoteActor iid h luActor
- let e' = case e of
- Left err -> Just Nothing
- Right (Left err) ->
- if isInstanceErrorG err
- then Nothing
- else Just Nothing
- Right (Right mera) -> Just $ Just mera
- case e' of
- Nothing -> runSiteDB $ do
- let recips' = NE.toList recips
- updateWhere [UnfetchedRemoteActorId <-. map fst3 recips', UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now]
- updateWhere [UnlinkedDeliveryId <-. map thd3 recips'] [UnlinkedDeliveryRunning =. False]
- Just mmera -> do
- for_ rs $ \ (uraid, luActor, udlid) ->
- fork $ do
- e <- fetchRemoteActor iid h luActor
- case e of
- Right (Right mera) ->
- case mera of
- Nothing -> runSiteDB $ delete udlid
- Just (Entity raid ra) -> do
- (fwd, e') <- deliver luActor h $ remoteActorInbox ra
- runSiteDB $
- case e' of
- Left _ -> do
- updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
- delete udlid
- insert_ $ Delivery raid obid fwd False
- Right _ -> delete udlid
- _ -> runSiteDB $ do
- updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now]
- update udlid [UnlinkedDeliveryRunning =. False]
- case mmera of
- Nothing -> runSiteDB $ do
- updateWhere [UnfetchedRemoteActorId ==. uraid, UnfetchedRemoteActorSince ==. Nothing] [UnfetchedRemoteActorSince =. Just now]
- update udlid [UnlinkedDeliveryRunning =. False]
- Just mera ->
- case mera of
- Nothing -> runSiteDB $ delete udlid
- Just (Entity raid ra) -> do
- (fwd, e'') <- deliver luActor h $ remoteActorInbox ra
- runSiteDB $
- case e'' of
- Left _ -> do
- updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
- delete udlid
- insert_ $ Delivery raid obid fwd False
- Right _ -> delete udlid
- where
- logDebug'' t = logDebug' $ T.concat ["deliverUnfetched ", h, t]
-
retryOutboxDelivery :: Worker ()
retryOutboxDelivery = do
logInfo "Periodic delivery starting"
@@ -2005,39 +792,3 @@ retryOutboxDelivery = do
unless (and results) $
logError $ "Periodic FW delivery error for host " <> h
return True
-
-getFollowersCollection
- :: Route App -> AppDB FollowerSetId -> Handler TypedContent
-getFollowersCollection here getFsid = do
- (locals, remotes) <- runDB $ do
- fsid <- getFsid
- (,) <$> do pids <- map (followPerson . entityVal) <$>
- selectList [FollowTarget ==. fsid] []
- sids <-
- map (personIdent . entityVal) <$>
- selectList [PersonId <-. pids] []
- map (sharerIdent . entityVal) <$>
- selectList [SharerId <-. sids] []
- <*> do E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` i) -> do
- E.on $ ra E.^. RemoteActorInstance E.==. i E.^. InstanceId
- E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId
- E.where_ $ rf E.^. RemoteFollowTarget E.==. E.val fsid
- return
- ( i E.^. InstanceHost
- , ra E.^. RemoteActorIdent
- )
-
- encodeRouteLocal <- getEncodeRouteLocal
- encodeRouteHome <- getEncodeRouteHome
- let followersAP = Collection
- { collectionId = encodeRouteLocal here
- , collectionType = CollectionTypeUnordered
- , collectionTotalItems = Just $ length locals + length remotes
- , collectionCurrent = Nothing
- , collectionFirst = Nothing
- , collectionLast = Nothing
- , collectionItems =
- map (encodeRouteHome . SharerR) locals ++
- map (uncurry l2f . bimap E.unValue E.unValue) remotes
- }
- provideHtmlAndAP followersAP $ redirect (here, [("prettyjson", "true")])
diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs
new file mode 100644
index 0000000..7d9d3a1
--- /dev/null
+++ b/src/Vervis/Federation/Discussion.hs
@@ -0,0 +1,448 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 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.Federation.Discussion
+ ( sharerCreateNoteRemoteF
+ , projectCreateNoteF
+ )
+where
+
+import Prelude
+
+--import Control.Applicative
+--import Control.Concurrent.MVar
+--import Control.Concurrent.STM.TVar
+import Control.Exception hiding (Handler, try)
+import Control.Monad
+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 Crypto.Hash
+--import Data.Aeson
+import Data.Bifunctor
+import Data.ByteString (ByteString)
+--import Data.Either
+import Data.Foldable
+import Data.Function
+import Data.List (sort, deleteBy, nub, union, unionBy, partition)
+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
+import Data.Maybe
+--import Data.Semigroup
+import Data.Text (Text)
+import Data.Text.Encoding
+import Data.Time.Clock
+--import Data.Time.Units
+import Data.Traversable
+--import Data.Tuple
+import Database.Persist
+--import Database.Persist.Sql hiding (deleteBy)
+--import Network.HTTP.Client
+--import Network.HTTP.Types.Header
+--import Network.HTTP.Types.URI
+--import Network.TLS hiding (SHA256)
+--import UnliftIO.Exception (try)
+import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
+import Yesod.Persist.Core
+
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.CaseInsensitive as CI
+--import qualified Data.List as L
+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 qualified Network.Wai as W
+
+--import Data.Time.Interval
+--import Network.HTTP.Signature hiding (requestHeaders)
+import Yesod.HttpSignature
+
+--import Crypto.PublicVerifKey
+import Database.Persist.JSON
+import Network.FedURI
+import Network.HTTP.Digest
+import Web.ActivityPub
+import Yesod.ActivityPub
+--import Yesod.Auth.Unverified
+import Yesod.FedURI
+--import Yesod.Hashids
+--import Yesod.MonadSite
+
+import Control.Monad.Trans.Except.Local
+--import Data.Aeson.Local
+--import Data.Either.Local
+--import Data.List.Local
+--import Data.List.NonEmpty.Local
+--import Data.Maybe.Local
+import Data.Tuple.Local
+import Database.Persist.Local
+import Yesod.Persist.Local
+
+import Vervis.ActivityPub
+--import Vervis.ActorKey
+import Vervis.Foundation
+import Vervis.Model
+import Vervis.Model.Ident
+--import Vervis.RemoteActorStore
+import Vervis.Settings
+
+sharerCreateNoteRemoteF now shrRecip iidSender raw activity (Note mluNote _ _ muParent muContext mpublished _ _) = do
+ _luNote <- fromMaybeE mluNote "Note without note id"
+ _published <- fromMaybeE mpublished "Note without 'published' field"
+ uContext <- fromMaybeE muContext "Note without context"
+ context <- parseContext uContext
+ mparent <-
+ case muParent of
+ Nothing -> return Nothing
+ Just uParent ->
+ if uParent == uContext
+ then return Nothing
+ else Just <$> parseParent uParent
+ ExceptT $ runDB $ do
+ personRecip <- do
+ sid <- getKeyBy404 $ UniqueSharer shrRecip
+ getValBy404 $ UniquePersonIdent sid
+ valid <- checkContextParent context mparent
+ case valid of
+ Left e -> return $ Left e
+ Right _ -> Right <$> insertToInbox (personInbox personRecip)
+ where
+ checkContextParent context mparent = runExceptT $ do
+ case context of
+ Left (shr, prj, num) -> do
+ mdid <- lift $ runMaybeT $ do
+ sid <- MaybeT $ getKeyBy $ UniqueSharer shr
+ jid <- MaybeT $ getKeyBy $ UniqueProject prj sid
+ t <- MaybeT $ getValBy $ UniqueTicket jid num
+ return $ ticketDiscuss t
+ did <- fromMaybeE mdid "Context: No such local ticket"
+ for_ mparent $ \ parent ->
+ case parent of
+ Left (shrP, lmidP) ->
+ void $ getLocalParentMessageId did shrP lmidP
+ Right (hParent, luParent) -> do
+ mrm <- lift $ runMaybeT $ do
+ iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
+ MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
+ for_ mrm $ \ rm -> do
+ let mid = remoteMessageRest rm
+ m <- lift $ getJust mid
+ unless (messageRoot m == did) $
+ throwE "Remote parent belongs to a different discussion"
+ Right (hContext, luContext) -> do
+ mdid <- lift $ runMaybeT $ do
+ iid <- MaybeT $ getKeyBy $ UniqueInstance hContext
+ rd <- MaybeT $ getValBy $ UniqueRemoteDiscussionIdent iid luContext
+ return $ remoteDiscussionDiscuss rd
+ for_ mparent $ \ parent ->
+ case parent of
+ Left (shrP, lmidP) -> do
+ did <- fromMaybeE mdid "Local parent inexistent, no RemoteDiscussion"
+ void $ getLocalParentMessageId did shrP lmidP
+ Right (hParent, luParent) -> do
+ mrm <- lift $ runMaybeT $ do
+ iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
+ MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
+ 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"
+ insertToInbox ibidRecip = do
+ let luActivity = activityId activity
+ jsonObj = PersistJSON raw
+ ract = RemoteActivity iidSender luActivity jsonObj now
+ ractid <- either entityKey id <$> insertBy' ract
+ ibiid <- insert $ InboxItem True
+ mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
+ let recip = shr2text shrRecip
+ case mibrid of
+ Nothing -> do
+ delete ibiid
+ return $ "Activity already exists in inbox of /s/" <> recip
+ Just _ -> return $ "Activity inserted to inbox of /s/" <> recip
+
+data CreateNoteRecipColl
+ = CreateNoteRecipProjectFollowers
+ | CreateNoteRecipTicketParticipants
+ | CreateNoteRecipTicketTeam
+ deriving Eq
+
+projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw activity audience (Note mluNote _ _ muParent muCtx mpub src content) = do
+ luNote <- fromMaybeE mluNote "Note without note id"
+ published <- fromMaybeE mpub "Note without 'published' field"
+ uContext <- fromMaybeE muCtx "Note without context"
+ context <- parseContext uContext
+ mparent <-
+ case muParent of
+ Nothing -> return Nothing
+ Just uParent ->
+ if uParent == uContext
+ then return Nothing
+ else Just <$> parseParent uParent
+ case context of
+ Right _ -> return $ recip <> " not using; context isn't local"
+ Left (shr, prj, num) ->
+ if shr /= shrRecip || prj /= prjRecip
+ then return $ recip <> " not using; context is a different project"
+ else do
+ msig <- checkForward
+ hLocal <- getsYesod $ appInstanceHost . appSettings
+ let colls = findRelevantCollections hLocal num audience
+ mremotesHttp <- runDBExcept $ do
+ (sid, fsidProject, fsidTicket, jid, ibid, did, meparent) <- getContextAndParent num mparent
+ lift $ join <$> do
+ mmid <- insertToDiscussion luNote published ibid did meparent fsidTicket
+ for mmid $ \ (ractid, mid) -> do
+ updateOrphans luNote did mid
+ for msig $ \ sig -> do
+ remoteRecips <- deliverLocal ractid colls sid fsidProject fsidTicket
+ (sig,) <$> deliverRemoteDB ractid jid sig remoteRecips
+ lift $ for_ mremotesHttp $ \ (sig, remotesHttp) -> do
+ let handler e = logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e)
+ forkHandler handler $ deliverRemoteHttp sig remotesHttp
+ return $ recip <> " inserted new ticket comment"
+ where
+ checkForward = join <$> do
+ let hSig = hForwardingSignature
+ msig <- maybeHeader hSig
+ for msig $ \ sig -> do
+ _proof <- withExceptT (T.pack . displayException) $ ExceptT $
+ let requires = [hDigest, hActivityPubForwarder]
+ in prepareToVerifyHttpSigWith hSig False requires [] Nothing
+ forwarder <- requireHeader hActivityPubForwarder
+ renderUrl <- getUrlRender
+ let project = renderUrl $ ProjectR shrRecip prjRecip
+ return $
+ if forwarder == encodeUtf8 project
+ then Just sig
+ else Nothing
+ where
+ maybeHeader n = do
+ let n' = decodeUtf8 $ CI.original n
+ hs <- lookupHeaders n
+ case hs of
+ [] -> return Nothing
+ [h] -> return $ Just h
+ _ -> throwE $ n' <> " multiple headers found"
+ requireHeader n = do
+ let n' = decodeUtf8 $ CI.original n
+ mh <- maybeHeader n
+ case mh of
+ Nothing -> throwE $ n' <> " header not found"
+ Just h -> return h
+ findRelevantCollections hLocal numCtx = nub . mapMaybe decide . concatRecipients
+ where
+ decide u = do
+ let (h, lu) = f2l u
+ guard $ h == hLocal
+ route <- decodeRouteLocal lu
+ case route of
+ ProjectFollowersR shr prj
+ | shr == shrRecip && prj == prjRecip
+ -> Just CreateNoteRecipProjectFollowers
+ TicketParticipantsR shr prj num
+ | shr == shrRecip && prj == prjRecip && num == numCtx
+ -> Just CreateNoteRecipTicketParticipants
+ TicketTeamR shr prj num
+ | shr == shrRecip && prj == prjRecip && num == numCtx
+ -> Just CreateNoteRecipTicketTeam
+ _ -> Nothing
+ recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip]
+ getContextAndParent num mparent = do
+ mt <- lift $ do
+ sid <- getKeyBy404 $ UniqueSharer shrRecip
+ Entity jid j <- getBy404 $ UniqueProject prjRecip sid
+ fmap (jid, projectInbox j, projectFollowers j, sid ,) <$>
+ getValBy (UniqueTicket jid num)
+ (jid, ibid, fsidProject, sid, t) <- fromMaybeE mt "Context: No such local ticket"
+ let did = ticketDiscuss t
+ meparent <- for mparent $ \ parent ->
+ case parent of
+ Left (shrParent, lmidParent) -> Left <$> getLocalParentMessageId did shrParent lmidParent
+ Right p@(hParent, luParent) -> do
+ mrm <- lift $ runMaybeT $ do
+ iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
+ MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
+ case mrm of
+ Just rm -> Left <$> do
+ let mid = remoteMessageRest rm
+ m <- lift $ getJust mid
+ unless (messageRoot m == did) $
+ throwE "Remote parent belongs to a different discussion"
+ return mid
+ Nothing -> return $ Right $ l2f hParent luParent
+ return (sid, fsidProject, ticketFollowers t, jid, ibid, did, meparent)
+ insertToDiscussion luNote published ibid did meparent fsid = do
+ ractid <- either entityKey id <$> insertBy' RemoteActivity
+ { remoteActivityInstance = iidSender
+ , remoteActivityIdent = activityId activity
+ , remoteActivityContent = PersistJSON raw
+ , remoteActivityReceived = now
+ }
+ mid <- insert Message
+ { messageCreated = published
+ , messageSource = src
+ , messageContent = content
+ , messageParent =
+ case meparent of
+ Just (Left midParent) -> Just midParent
+ _ -> Nothing
+ , messageRoot = did
+ }
+ mrmid <- insertUnique RemoteMessage
+ { remoteMessageAuthor = raidSender
+ , remoteMessageInstance = iidSender
+ , remoteMessageIdent = luNote
+ , remoteMessageRest = mid
+ , remoteMessageCreate = ractid
+ , remoteMessageLostParent =
+ case meparent of
+ Just (Right uParent) -> Just uParent
+ _ -> Nothing
+ }
+ case mrmid of
+ Nothing -> do
+ delete mid
+ return Nothing
+ Just _ -> do
+ insertUnique_ $ RemoteFollow raidSender fsid False
+ ibiid <- insert $ InboxItem False
+ insert_ $ InboxItemRemote ibid ractid ibiid
+ return $ Just (ractid, mid)
+ updateOrphans luNote did mid = do
+ let uNote = l2f hSender luNote
+ related <- selectOrphans uNote (E.==.)
+ for_ related $ \ (E.Value rmidOrphan, E.Value midOrphan) -> do
+ logWarn $ T.concat
+ [ "Found parent for related orphan RemoteMessage #"
+ , T.pack (show rmidOrphan)
+ , ", setting its parent now to Message #"
+ , T.pack (show mid)
+ ]
+ update rmidOrphan [RemoteMessageLostParent =. Nothing]
+ update midOrphan [MessageParent =. Just mid]
+ unrelated <- selectOrphans uNote (E.!=.)
+ for_ unrelated $ \ (E.Value rmidOrphan, E.Value _midOrphan) ->
+ logWarn $ T.concat
+ [ "Found parent for unrelated orphan RemoteMessage #"
+ , T.pack (show rmidOrphan)
+ , ", NOT settings its parent to Message #"
+ , T.pack (show mid)
+ , " because they have different DiscussionId!"
+ ]
+ where
+ selectOrphans uNote op =
+ E.select $ E.from $ \ (rm `E.InnerJoin` m) -> do
+ E.on $ rm E.^. RemoteMessageRest E.==. m E.^. MessageId
+ E.where_ $
+ rm E.^. RemoteMessageLostParent E.==. E.just (E.val uNote) E.&&.
+ m E.^. MessageRoot `op` E.val did
+ return (rm E.^. RemoteMessageId, m E.^. MessageId)
+ deliverLocal
+ :: RemoteActivityId
+ -> [CreateNoteRecipColl]
+ -> SharerId
+ -> FollowerSetId
+ -> FollowerSetId
+ -> AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+ deliverLocal ractid recips sid fsidProject fsidTicket = do
+ (teamPids, teamRemotes) <-
+ if CreateNoteRecipTicketTeam `elem` recips
+ then getTicketTeam sid
+ else return ([], [])
+ (tfsPids, tfsRemotes) <-
+ if CreateNoteRecipTicketParticipants `elem` recips
+ then getFollowers fsidTicket
+ else return ([], [])
+ (jfsPids, jfsRemotes) <-
+ if CreateNoteRecipProjectFollowers `elem` recips
+ then getFollowers fsidProject
+ else return ([], [])
+ let pids = union teamPids tfsPids `union` jfsPids
+ -- TODO inefficient, see the other TODOs about mergeConcat
+ remotes = map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat3 teamRemotes tfsRemotes jfsRemotes
+ for_ pids $ \ pid -> do
+ ibid <- personInbox <$> getJust pid
+ ibiid <- insert $ InboxItem True
+ mibrid <- insertUnique $ InboxItemRemote ibid ractid ibiid
+ when (isNothing mibrid) $
+ delete ibiid
+ return remotes
+
+ deliverRemoteDB
+ :: RemoteActivityId
+ -> ProjectId
+ -> ByteString
+ -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+ -> AppDB
+ [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
+ deliverRemoteDB ractid jid sig recips = do
+ let body' = BL.toStrict body
+ deliv raid msince = Forwarding raid ractid body' jid sig $ isNothing msince
+ fetchedDeliv <- for recips $ \ (i, rs) ->
+ (i,) <$> insertMany' (\ (raid, _, _, msince) -> deliv raid msince) rs
+ return $ takeNoError4 fetchedDeliv
+ where
+ takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
+ takeNoError4 = takeNoError noError
+ where
+ noError ((ak, luA, luI, Nothing), dlk) = Just (ak, luA, luI, dlk)
+ noError ((_ , _ , _ , Just _ ), _ ) = Nothing
+
+ deliverRemoteHttp
+ :: ByteString
+ -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
+ -> Handler ()
+ deliverRemoteHttp sig fetched = do
+ let deliver h inbox = do
+ forwardActivity (l2f h inbox) sig (ProjectR shrRecip prjRecip) body
+ now <- liftIO getCurrentTime
+ traverse_ (fork . deliverFetched deliver now) fetched
+ where
+ fork = forkHandler $ \ e -> logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e)
+ deliverFetched deliver now ((_, h), recips@(r :| rs)) = do
+ let (raid, _luActor, luInbox, fwid) = r
+ e <- deliver h luInbox
+ let e' = case e of
+ Left err ->
+ if isInstanceErrorP err
+ then Nothing
+ else Just False
+ Right _resp -> Just True
+ case e' of
+ Nothing -> runDB $ do
+ let recips' = NE.toList recips
+ updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
+ updateWhere [ForwardingId <-. map fourth4 recips'] [ForwardingRunning =. False]
+ Just success -> do
+ runDB $
+ if success
+ then delete fwid
+ else do
+ updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
+ update fwid [ForwardingRunning =. False]
+ for_ rs $ \ (raid, _luActor, luInbox, fwid) ->
+ fork $ do
+ e <- deliver h luInbox
+ runDB $
+ case e of
+ Left _err -> do
+ updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
+ update fwid [ForwardingRunning =. False]
+ Right _resp -> delete fwid
diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs
index faf4170..fd8cd57 100644
--- a/src/Vervis/Handler/Discussion.hs
+++ b/src/Vervis/Handler/Discussion.hs
@@ -55,6 +55,7 @@ import Yesod.Hashids
import Database.Persist.Local
import Yesod.Persist.Local
+import Vervis.API
import Vervis.Discussion
import Vervis.Form.Discussion
import Vervis.Federation
@@ -226,7 +227,7 @@ postTopReply hDest recipsA recipsC context replyP after = do
, noteSource = msg'
, noteContent = contentHtml
}
- ExceptT $ handleOutboxNote hLocal note
+ ExceptT $ createNoteC hLocal note
case elmid of
Left e -> do
setMessage $ toHtml e
@@ -309,7 +310,7 @@ postReply hDest recipsA recipsC context replyG replyP after getdid midParent = d
, noteSource = msg'
, noteContent = contentHtml
}
- ExceptT $ handleOutboxNote hLocal note
+ ExceptT $ createNoteC hLocal note
case elmid of
Left e -> do
setMessage $ toHtml e
diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs
index ee2315d..b8ba005 100644
--- a/src/Vervis/Handler/Inbox.hs
+++ b/src/Vervis/Handler/Inbox.hs
@@ -109,6 +109,7 @@ import Database.Persist.Local
import Yesod.Persist.Local
import Vervis.ActorKey
+import Vervis.API
import Vervis.Federation
import Vervis.Foundation
import Vervis.Model
@@ -480,7 +481,7 @@ postOutboxR shrAuthor = do
, noteSource = msg'
, noteContent = contentHtml
}
- ExceptT $ handleOutboxNote hLocal note
+ ExceptT $ createNoteC hLocal note
case elmid of
Left err -> setMessage $ toHtml err
Right lmid -> do
diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs
index 4fde839..983cf72 100644
--- a/src/Vervis/Handler/Project.hs
+++ b/src/Vervis/Handler/Project.hs
@@ -59,6 +59,7 @@ import Data.Either.Local
import Database.Persist.Local
import Yesod.Persist.Local
+import Vervis.API
import Vervis.Federation
import Vervis.Form.Project
import Vervis.Foundation
diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs
index cf5c052..4d4293d 100644
--- a/src/Vervis/Handler/Ticket.hs
+++ b/src/Vervis/Handler/Ticket.hs
@@ -101,6 +101,7 @@ import Data.Maybe.Local (partitionMaybePairs)
import Database.Persist.Local
import Yesod.Persist.Local
+import Vervis.API
import Vervis.Federation
import Vervis.Form.Ticket
import Vervis.Foundation
diff --git a/vervis.cabal b/vervis.cabal
index 6f348a8..0675444 100644
--- a/vervis.cabal
+++ b/vervis.cabal
@@ -42,6 +42,7 @@ library
exposed-modules: Control.Applicative.Local
Control.Concurrent.Local
Control.Concurrent.ResultShare
+ Control.Monad.Trans.Except.Local
Crypto.PubKey.Encoding
Crypto.PublicVerifKey
Darcs.Local.Repository
@@ -75,6 +76,7 @@ library
Data.Text.Lazy.UTF8.Local
Data.Time.Clock.Local
Data.Tree.Local
+ Data.Tuple.Local
Database.Esqueleto.Local
Database.Persist.Class.Local
Database.Persist.JSON
@@ -111,8 +113,10 @@ library
Yesod.SessionEntity
Vervis.Access
+ Vervis.ActivityPub
Vervis.ActivityStreams
Vervis.ActorKey
+ Vervis.API
Vervis.Application
Vervis.Avatar
Vervis.BinaryBody
@@ -123,6 +127,7 @@ library
Vervis.Darcs
Vervis.Discussion
Vervis.Federation
+ Vervis.Federation.Discussion
Vervis.Field.Key
Vervis.Field.Person
Vervis.Field.Project