From 7686f3777ed4c578f2226f007881eac1648aeca3 Mon Sep 17 00:00:00 2001 From: fr33domlover 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 . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Control.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 . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module 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 . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Vervis.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 . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Vervis.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 . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Vervis.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