{- 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 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 Text.Blaze.Html.Renderer.Text 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 Data.Text.Lazy as TL 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" verifyNothingE mluNote "Note specifies an id" verifyNothingE 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, obiid, doc, remotesHttp) <- runDBExcept $ do (pid, obid, 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) summary <- withUrlRenderer [hamlet|

{shr2text shrUser} \ commented on a # ticket. |] (lmid, obiid, doc) <- lift $ insertMessage luAttrib shrUser pid obid uContext did muParent meparent source content summary moreRemotes <- deliverLocal pid obiid localRecips mcollections unless (federation || null moreRemotes) $ throwE "Federation disabled but remote collection members found" remotesHttp <- lift $ deliverRemoteDB (furiHost uContext) obiid remoteRecips moreRemotes return (lmid, obiid, doc, remotesHttp) lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp (furiHost uContext) obiid doc remotesHttp return lmid where 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, OutboxId, 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, personOutbox p, shr) else throwE t insertMessage :: LocalURI -> ShrIdent -> PersonId -> OutboxId -> FedURI -> DiscussionId -> Maybe FedURI -> Maybe (Either MessageId FedURI) -> Text -> Text -> Html -> AppDB (LocalMessageId, OutboxItemId, Doc Activity) insertMessage luAttrib shrUser pid obid uContext did muParent meparent source content summary = 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 , activitySummary = Just $ TextHtml $ TL.toStrict $ renderHtml summary , 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 "" "" obiid <- insert OutboxItem { outboxItemOutbox = obid , outboxItemActivity = PersistJSON $ activity tempUri tempUri , outboxItemPublished = now } lmid <- insert LocalMessage { localMessageAuthor = pid , localMessageRest = mid , localMessageCreate = obiid , localMessageUnlinkedParent = case meparent of Just (Right uParent) -> Just uParent _ -> Nothing } route2local <- getEncodeRouteLocal obihid <- encodeKeyHashid obiid lmhid <- encodeKeyHashid lmid let luAct = route2local $ SharerOutboxItemR shrUser obihid luNote = route2local $ MessageR shrUser lmhid doc = activity luAct luNote update obiid [OutboxItemActivity =. PersistJSON doc] return (lmid, obiid, 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")])