mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-06 06:56:46 +09:00
820 lines
40 KiB
Haskell
820 lines
40 KiB
Haskell
{- This file is part of Vervis.
|
|
-
|
|
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
|
|
-
|
|
- ♡ Copying is an act of love. Please copy, reuse and share.
|
|
-
|
|
- The author(s) have dedicated all copyright and related and neighboring
|
|
- rights to this software to the public domain worldwide. This software is
|
|
- distributed without any warranty.
|
|
-
|
|
- You should have received a copy of the CC0 Public Domain Dedication along
|
|
- with this software. If not, see
|
|
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|
-}
|
|
|
|
module Vervis.API
|
|
( createNoteC
|
|
, getFollowersCollection
|
|
)
|
|
where
|
|
|
|
import 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|
|
|
<p>
|
|
<a href=@{SharerR shrUser}>{shr2text shrUser}
|
|
\ commented on a #
|
|
<a href=#{renderFedURI uContext}>ticket</a>.
|
|
|]
|
|
(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")])
|