1
0
Fork 0
mirror of https://code.naskya.net/repos/ndqEd synced 2025-03-20 15:14:54 +09:00

S2S: sharerCreateNoteF caches note and does inbox fwd if sharer is ticket owner

This commit is contained in:
fr33domlover 2020-05-13 13:06:28 +00:00
parent c91908941b
commit 43cd1a95f3
10 changed files with 469 additions and 228 deletions

View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
-
- Copying is an act of love. Please copy, reuse and share.
-
@ -16,8 +16,10 @@
module Data.Tuple.Local
( fst3
, fst4
, fst5
, thd3
, fourth4
, fourth5
)
where
@ -27,8 +29,14 @@ fst3 (x, _, _) = x
fst4 :: (a, b, c, d) -> a
fst4 (x, _, _, _) = x
fst5 :: (a, b, c, d, e) -> a
fst5 (x, _, _, _, _) = x
thd3 :: (a, b, c) -> c
thd3 (_, _, z) = z
fourth4 :: (a, b, c, d) -> d
fourth4 (_, _, _, w) = w
fourth5 :: (a, b, c, d, e) -> d
fourth5 (_, _, _, w, _) = w

View file

@ -32,8 +32,10 @@ module Vervis.ActivityPub
, isInstanceErrorG
, deliverHttp
, deliverHttpBL
, deliverRemoteDB
, deliverRemoteHTTP
, deliverRemoteDB_J
, deliverRemoteDB_S
, deliverRemoteHTTP_J
, deliverRemoteHTTP_S
, checkForward
, parseTarget
--, checkDep
@ -59,6 +61,7 @@ import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Data.Bifunctor
import Data.Bitraversable
import Data.ByteString (ByteString)
import Data.Either
import Data.Foldable
@ -312,45 +315,67 @@ deliverHttpBL
deliverHttpBL body mfwd h luInbox =
deliverActivityBL' (ObjURI h luInbox) (ObjURI h <$> mfwd) body
deliverRemoteDB
deliverRemoteDB_
:: PersistRecordBackend fwder SqlBackend
=> (ForwardingId -> Key sender -> fwder)
-> BL.ByteString
-> RemoteActivityId
-> Key sender
-> ByteString
-> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> AppDB
[((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))]
deliverRemoteDB_ makeFwder body ractid senderKey sig recips = do
let body' = BL.toStrict body
makeFwd (RemoteRecipient raid _ _ msince) =
Forwarding raid ractid body' sig (isNothing msince)
fetchedDeliv <- for recips $ bitraverse pure $ \ rs -> do
fwds <- insertMany' makeFwd rs
insertMany' (flip makeFwder senderKey . snd) fwds
return $ takeNoError5 fetchedDeliv
where
takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
takeNoError5 = takeNoError noError
where
noError ((RemoteRecipient ak luA luI Nothing , fwid), fwrid) = Just (ak, luA, luI, fwid, fwrid)
noError ((RemoteRecipient _ _ _ (Just _), _ ), _ ) = Nothing
deliverRemoteDB_J
:: BL.ByteString
-> RemoteActivityId
-> ProjectId
-> ByteString
-> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> AppDB
[((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
deliverRemoteDB body 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' (\ (RemoteRecipient 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 (RemoteRecipient ak luA luI Nothing , dlk) = Just (ak, luA, luI, dlk)
noError (RemoteRecipient _ _ _ (Just _), _ ) = Nothing
[((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderProjectId))]
deliverRemoteDB_J = deliverRemoteDB_ ForwarderProject
deliverRemoteHTTP
:: (MonadSite m, SiteEnv m ~ App)
deliverRemoteDB_S
:: BL.ByteString
-> RemoteActivityId
-> SharerId
-> ByteString
-> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> AppDB
[((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderSharerId))]
deliverRemoteDB_S = deliverRemoteDB_ ForwarderSharer
deliverRemoteHTTP'
:: (MonadSite m, SiteEnv m ~ App, PersistRecordBackend fwder SqlBackend)
=> UTCTime
-> ShrIdent
-> PrjIdent
-> LocalActor
-> BL.ByteString
-> ByteString
-> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
-> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))]
-> m ()
deliverRemoteHTTP now shrRecip prjRecip body sig fetched = do
deliverRemoteHTTP' now sender body sig fetched = do
let deliver h inbox =
let sender = ProjectR shrRecip prjRecip
in forwardActivity (ObjURI h inbox) sig sender body
forwardActivity (ObjURI h inbox) sig (renderLocalActor sender) body
traverse_ (fork . deliverFetched deliver now) fetched
where
fork = forkWorker "Inbox forwarding to remote members of local collections: delivery failed"
deliverFetched deliver now ((_, h), recips@(r :| rs)) = do
let (raid, _luActor, luInbox, fwid) = r
let (raid, _luActor, luInbox, fwid, forwarderKey) = r
e <- deliver h luInbox
let e' = case e of
Left err ->
@ -361,16 +386,18 @@ deliverRemoteHTTP now shrRecip prjRecip body sig fetched = do
case e' of
Nothing -> runSiteDB $ do
let recips' = NE.toList recips
updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
updateWhere [ForwardingId <-. map fourth4 recips'] [ForwardingRunning =. False]
updateWhere [RemoteActorId <-. map fst5 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
updateWhere [ForwardingId <-. map fourth5 recips'] [ForwardingRunning =. False]
Just success -> do
runSiteDB $
if success
then delete fwid
then do
delete forwarderKey
delete fwid
else do
updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
update fwid [ForwardingRunning =. False]
for_ rs $ \ (raid, _luActor, luInbox, fwid) ->
for_ rs $ \ (raid, _luActor, luInbox, fwid, forwarderKey) ->
fork $ do
e <- deliver h luInbox
runSiteDB $
@ -378,9 +405,33 @@ deliverRemoteHTTP now shrRecip prjRecip body sig fetched = do
Left _err -> do
updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
update fwid [ForwardingRunning =. False]
Right _resp -> delete fwid
Right _resp -> do
delete forwarderKey
delete fwid
checkForward shrRecip prjRecip = join <$> do
deliverRemoteHTTP_J
:: (MonadSite m, SiteEnv m ~ App)
=> UTCTime
-> ShrIdent
-> PrjIdent
-> BL.ByteString
-> ByteString
-> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderProjectId))]
-> m ()
deliverRemoteHTTP_J now shr prj =
deliverRemoteHTTP' now $ LocalActorProject shr prj
deliverRemoteHTTP_S
:: (MonadSite m, SiteEnv m ~ App)
=> UTCTime
-> ShrIdent
-> BL.ByteString
-> ByteString
-> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderSharerId))]
-> m ()
deliverRemoteHTTP_S now shr = deliverRemoteHTTP' now $ LocalActorSharer shr
checkForward recip = join <$> do
let hSig = hForwardingSignature
msig <- maybeHeader hSig
for msig $ \ sig -> do
@ -389,9 +440,8 @@ checkForward shrRecip prjRecip = join <$> do
in prepareToVerifyHttpSigWith hSig False requires [] Nothing
forwarder <- requireHeader hActivityPubForwarder
renderUrl <- getUrlRender
let project = renderUrl $ ProjectR shrRecip prjRecip
return $
if forwarder == encodeUtf8 project
if forwarder == encodeUtf8 (renderUrl $ renderLocalActor recip)
then Just sig
else Nothing
where

View file

@ -373,6 +373,14 @@ fixRunningDeliveries = do
, " forwarding deliveries"
]
data Fwder = FwderProject ForwarderProjectId | FwderSharer ForwarderSharerId
partitionFwders :: [Fwder] -> ([ForwarderProjectId], [ForwarderSharerId])
partitionFwders = foldl' f ([], [])
where
f (js, ss) (FwderProject j) = (j : js, ss)
f (js, ss) (FwderSharer s) = (js , s : ss)
retryOutboxDelivery :: Worker ()
retryOutboxDelivery = do
logInfo "Periodic delivery starting"
@ -440,9 +448,14 @@ retryOutboxDelivery = do
let (linkedOld, linkedNew) = partitionEithers $ map (decideBySinceDL dropAfter now . adaptLinked) linked
deleteWhere [DeliveryId <-. linkedOld]
-- Same for forwarding deliveries, which are always linked
forwarding <- E.select $ E.from $ \ (fw `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i `E.InnerJoin` j `E.InnerJoin` s) -> do
E.on $ j E.^. ProjectSharer E.==. s E.^. SharerId
E.on $ fw E.^. ForwardingSender E.==. j E.^. ProjectId
forwarding <- E.select $ E.from $ \ (fw `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i `E.LeftOuterJoin` (fwj `E.InnerJoin` j `E.InnerJoin` s) `E.LeftOuterJoin` (fws `E.InnerJoin` s2)) -> do
E.on $ fws E.?. ForwarderSharerSender E.==. s2 E.?. SharerId
E.on $ E.just (fw E.^. ForwardingId) E.==. fws E.?. ForwarderSharerTask
E.on $ j E.?. ProjectSharer E.==. s E.?. SharerId
E.on $ fwj E.?. ForwarderProjectSender E.==. j E.?. ProjectId
E.on $ E.just (fw E.^. ForwardingId) E.==. fwj E.?. ForwarderProjectTask
E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
E.on $ fw E.^. ForwardingRecipient E.==. ra E.^. RemoteActorId
@ -456,12 +469,22 @@ retryOutboxDelivery = do
, ra E.^. RemoteActorErrorSince
, fw E.^. ForwardingId
, fw E.^. ForwardingActivityRaw
, j E.^. ProjectIdent
, s E.^. SharerIdent
, fwj E.?. ForwarderProjectId
, s E.?. SharerIdent
, j E.?. ProjectIdent
, fws E.?. ForwarderSharerId
, s2 E.?. SharerIdent
, fw E.^. ForwardingSignature
)
let (forwardingOld, forwardingNew) = partitionEithers $ map (decideBySinceFW dropAfter now . adaptForwarding) forwarding
deleteWhere [ForwardingId <-. forwardingOld]
(fwidsOld, fwdersOld) = unzip forwardingOld
(fwjidsOld, fwsidsOld) = partitionFwders fwdersOld
deleteWhere [ForwarderProjectId <-. fwjidsOld]
deleteWhere [ForwarderSharerId <-. fwsidsOld]
deleteWhere [ForwardingId <-. fwidsOld]
return (groupUnlinked lonelyNew, groupLinked linkedNew, groupForwarding forwardingNew)
let deliver = deliverHttpBL
logInfo "Periodic delivery prepared DB, starting async HTTP POSTs"
@ -548,19 +571,44 @@ retryOutboxDelivery = do
= map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd)
. groupWithExtractBy ((==) `on` fst) fst snd
adaptForwarding
(E.Value iid, E.Value h, E.Value raid, E.Value inbox, E.Value since, E.Value fwid, E.Value body, E.Value prj, E.Value shr, E.Value sig) =
( E.Value iid, E.Value h, E.Value raid, E.Value inbox, E.Value since
, E.Value fwid, E.Value body
, E.Value mfwjid, E.Value mprj, E.Value mshr
, E.Value mfwsid, E.Value mshr2
, E.Value sig
) =
( ( (iid, h)
, ((raid, inbox), (fwid, BL.fromStrict body, ProjectR shr prj, sig))
, ( (raid, inbox)
, ( fwid
, BL.fromStrict body
, let project = together3 mfwjid mprj mshr
sharer = together2 mfwsid mshr2
in case (project, sharer) of
(Just (fwjid, shr, prj), Nothing) ->
(FwderProject fwjid, ProjectR shr prj)
(Nothing, Just (fwsid, shr)) ->
(FwderSharer fwsid, SharerR shr)
_ -> error $ "Non-single fwder for fw#" ++ show fwid
, sig
)
)
)
, since
)
decideBySinceFW dropAfter now (fw@(_, (_, (fwid, _, _, _))), msince) =
where
together2 (Just x) (Just y) = Just (x, y)
together2 Nothing Nothing = Nothing
together2 _ _ = error $ "Got weird forwarder for fw#" ++ show fwid
together3 (Just x) (Just y) (Just z) = Just (x, y, z)
together3 Nothing Nothing Nothing = Nothing
together3 _ _ _ = error $ "Got weird forwarder for fw#" ++ show fwid
decideBySinceFW dropAfter now (fw@(_, (_, (fwid, _, (fwder, _), _))), msince) =
case msince of
Nothing -> Right fw
Just since ->
if relevant dropAfter now since
then Right fw
else Left fwid
else Left (fwid, fwder)
groupForwarding
= map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd)
. groupWithExtractBy ((==) `on` fst) fst snd
@ -648,12 +696,16 @@ retryOutboxDelivery = do
logDebug $
"Periodic deliver starting forwarding for inbox " <>
renderObjURI (ObjURI h inbox)
waitsD <- for delivs $ \ (fwid, body, sender, sig) -> fork $ do
waitsD <- for delivs $ \ (fwid, body, (fwder, sender), sig) -> fork $ do
e <- forwardActivity (ObjURI h inbox) sig sender body
case e of
Left _err -> return False
Right _resp -> do
runSiteDB $ delete fwid
runSiteDB $ do
case fwder of
FwderProject k -> delete k
FwderSharer k -> delete k
delete fwid
return True
results <- sequence waitsD
runSiteDB $

View file

@ -73,19 +73,21 @@ import Vervis.Model.Ident
import Vervis.Settings
import Vervis.Ticket
sharerCreateNoteF
:: UTCTime
-> ShrIdent
-> RemoteAuthor
-> ActivityBody
-> Note URIMode
-> ExceptT Text Handler Text
sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext mpublished _ _) = do
luCreate <-
fromMaybeE (activityId $ actbActivity body) "Create without 'id'"
_luNote <- fromMaybeE mluNote "Note without note id"
_published <- fromMaybeE mpublished "Note without 'published' field"
uContext <- fromMaybeE muContext "Note without context"
-- | Check the note in the remote Create Note activity delivered to us.
checkNote
:: Note URIMode
-> ExceptT Text Handler
( LocalURI
, UTCTime
, Either NoteContext FedURI
, Maybe (Either (ShrIdent, LocalMessageId) FedURI)
, Text
, Text
)
checkNote (Note mluNote _ _ muParent muCtx mpub source 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
@ -94,44 +96,224 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext
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 luCreate (personInbox personRecip)
return (luNote, published, context, mparent, source, content)
-- | Insert a remote activity delivered to us into our inbox. Return its
-- database ID if the activity wasn't already in our inbox.
insertToInbox
:: UTCTime
-> RemoteAuthor
-> ActivityBody
-> InboxId
-> LocalURI
-> Bool
-> AppDB (Maybe RemoteActivityId)
insertToInbox now author body ibid luCreate unread = do
let iidAuthor = remoteAuthorInstance author
roid <-
either entityKey id <$> insertBy' (RemoteObject iidAuthor luCreate)
ractid <- either entityKey id <$> insertBy' RemoteActivity
{ remoteActivityIdent = roid
, remoteActivityContent = persistJSONFromBL $ actbBL body
, remoteActivityReceived = now
}
ibiid <- insert $ InboxItem unread
new <- isRight <$> insertBy' (InboxItemRemote ibid ractid ibiid)
return $
if new
then Just ractid
else Nothing
-- | Given the parent specified by the Note we received, check if we already
-- know and have this parent note in the DB, and whether the child and parent
-- belong to the same discussion root.
getParent
:: DiscussionId
-> Either (ShrIdent, LocalMessageId) FedURI
-> ExceptT Text AppDB (Either MessageId FedURI)
getParent did (Left (shr, lmid)) = Left <$> getLocalParentMessageId did shr lmid
getParent did (Right p@(ObjURI hParent luParent)) = do
mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent roid
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 p
-- | Insert the new remote comment into the discussion tree. If we didn't have
-- this comment before, return the database ID of the newly created cached
-- comment.
insertToDiscussion
:: RemoteAuthor
-> LocalURI
-> UTCTime
-> Text
-> Text
-> DiscussionId
-> Maybe (Either MessageId FedURI)
-> RemoteActivityId
-> AppDB (Maybe MessageId)
insertToDiscussion author luNote published source content did meparent ractid = do
let iidAuthor = remoteAuthorInstance author
raidAuthor = remoteAuthorId author
mid <- insert Message
{ messageCreated = published
, messageSource = source
, messageContent = content
, messageParent =
case meparent of
Just (Left midParent) -> Just midParent
_ -> Nothing
, messageRoot = did
}
roidNote <-
either entityKey id <$> insertBy' (RemoteObject iidAuthor luNote)
mrmid <- insertUnique RemoteMessage
{ remoteMessageAuthor = raidAuthor
, remoteMessageIdent = roidNote
, remoteMessageRest = mid
, remoteMessageCreate = ractid
, remoteMessageLostParent =
case meparent of
Just (Right uParent) -> Just uParent
_ -> Nothing
}
case mrmid of
Nothing -> do
delete mid
return Nothing
Just _ -> return $ Just mid
-- | Look for known remote comments in the database, whose parent was unknown
-- but turns out to be the new comment we just received. Fix that in the
-- database and log warnings about it.
updateOrphans
:: RemoteAuthor
-> LocalURI
-> DiscussionId
-> MessageId
-> AppDB ()
updateOrphans author luNote did mid = do
let hAuthor = objUriAuthority $ remoteAuthorURI author
uNote = ObjURI hAuthor 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
checkContextParent (Left context) mparent = runExceptT $ do
did <-
case context of
NoteContextSharerTicket shr talid -> do
(_, Entity _ lt, _, project) <- do
mticket <- lift $ getSharerTicket shr talid
fromMaybeE mticket "Note context no such local sharer-hosted ticket"
return $ localTicketDiscuss lt
NoteContextProjectTicket shr prj ltid -> do
(_, _, _, Entity _ lt, _, _) <- do
mticket <- lift $ getProjectTicket shr prj ltid
fromMaybeE mticket "Note context no such local project-hosted ticket"
return $ localTicketDiscuss lt
for_ mparent $ \ parent ->
case parent of
Left (shrP, lmidP) ->
void $ getLocalParentMessageId did shrP lmidP
Right (ObjURI hParent luParent) -> do
mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent roid
for_ mrm $ \ rm -> do
let mid = remoteMessageRest rm
m <- lift $ getJust mid
unless (messageRoot m == did) $
throwE "Remote parent belongs to a different discussion"
checkContextParent (Right (ObjURI hContext luContext)) mparent = runExceptT $ do
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)
sharerCreateNoteF
:: UTCTime
-> ShrIdent
-> RemoteAuthor
-> ActivityBody
-> Note URIMode
-> ExceptT Text Handler Text
sharerCreateNoteF now shrRecip author body note = do
luCreate <-
fromMaybeE (activityId $ actbActivity body) "Create without 'id'"
(luNote, published, context, mparent, source, content) <- checkNote note
(localRecips, _remoteRecips) <- do
mrecips <- parseAudience $ activityAudience $ actbActivity body
fromMaybeE mrecips "Create Note with no recipients"
msig <- checkForward $ LocalActorSharer shrRecip
case context of
Right uContext -> runDBExcept $ do
personRecip <- lift $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip
getValBy404 $ UniquePersonIdent sid
checkContextParent uContext mparent
mractid <- lift $ insertToInbox now author body (personInbox personRecip) luCreate True
return $
case mractid of
Nothing -> "I already have this activity in my inbox, doing nothing"
Just _ -> "Context is remote, so just inserting to my inbox"
Left (NoteContextSharerTicket shr talid) -> do
mremotesHttp <- runDBExcept $ do
(sid, pid, ibid) <- lift getRecip404
(Entity _ tal, Entity _ lt, _, _) <- do
mticket <- lift $ getSharerTicket shr talid
fromMaybeE mticket "Context: No such sharer-ticket"
if ticketAuthorLocalAuthor tal == pid
then do
mractid <- lift $ insertToInbox now author body ibid luCreate True
case mractid of
Nothing -> return $ Left "Activity already in my inbox"
Just ractid -> do
let did = localTicketDiscuss lt
meparent <- traverse (getParent did) mparent
mmid <- lift $ insertToDiscussion author luNote published source content did meparent ractid
case mmid of
Nothing -> return $ Left "I already have this comment, just storing in inbox"
Just mid -> lift $ do
updateOrphans author luNote did mid
case msig of
Nothing ->
return $ Left "Storing in inbox, caching comment, no inbox forwarding header"
Just sig -> Right <$> do
talkhid <- encodeKeyHashid talid
let sieve =
makeRecipientSet
[]
[ LocalPersonCollectionSharerTicketFollowers shrRecip talkhid
, LocalPersonCollectionSharerTicketTeam shrRecip talkhid
]
remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips
(sig,) <$> deliverRemoteDB_S (actbBL body) ractid sid sig remoteRecips
else return $ Left "Context is a sharer-ticket of another sharer"
case mremotesHttp of
Left msg -> return msg
Right (sig, remotesHttp) -> do
forkWorker "sharerCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_S now shrRecip (actbBL body) sig remotesHttp
return "Stored to inbox, cached comment, and did inbox forwarding"
Left (NoteContextProjectTicket shr prj ltid) -> runDBExcept $ do
personRecip <- lift $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip
getValBy404 $ UniquePersonIdent sid
(_, _, _, Entity _ lt, _, _) <- do
mticket <- lift $ getProjectTicket shr prj ltid
fromMaybeE mticket "Context: No such project-ticket"
let did = localTicketDiscuss lt
_ <- traverse (getParent did) mparent
mractid <- lift $ insertToInbox now author body (personInbox personRecip) luCreate True
return $
case mractid of
Nothing -> "I already have this activity in my inbox, doing nothing"
Just _ -> "Context is a project-ticket, so just inserting to my inbox"
where
getRecip404 = do
sid <- getKeyBy404 $ UniqueSharer shrRecip
Entity pid p <- getBy404 $ UniquePersonIdent sid
return (sid, pid, personInbox p)
checkContextParent (ObjURI hContext luContext) mparent = do
mdid <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hContext
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luContext
@ -153,21 +335,6 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext
did <- fromMaybeE mdid "Remote parent known, but no context RemoteDiscussion"
unless (messageRoot m == did) $
throwE "Remote parent belongs to a different discussion"
insertToInbox luCreate ibidRecip = do
let iidAuthor = remoteAuthorInstance author
roid <-
either entityKey id <$> insertBy' (RemoteObject iidAuthor luCreate)
let jsonObj = persistJSONFromBL $ actbBL body
ract = RemoteActivity roid 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
projectCreateNoteF
:: UTCTime
@ -177,24 +344,14 @@ projectCreateNoteF
-> ActivityBody
-> Note URIMode
-> ExceptT Text Handler Text
projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent muCtx mpub src content) = do
projectCreateNoteF now shrRecip prjRecip author body note = do
luCreate <-
fromMaybeE (activityId $ actbActivity body) "Create without 'id'"
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
(luNote, published, context, mparent, source, content) <- checkNote note
(localRecips, _remoteRecips) <- do
mrecips <- parseAudience $ activityAudience $ actbActivity body
fromMaybeE mrecips "Create Note with no recipients"
msig <- checkForward shrRecip prjRecip
msig <- checkForward $ LocalActorProject shrRecip prjRecip
case context of
Right _ -> return "Not using; context isn't local"
Left (NoteContextSharerTicket shr talid) -> do
@ -206,7 +363,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
case project of
Left (Entity _ tpl)
| ticketProjectLocalProject tpl == jid -> do
mractid <- lift $ insertToProjectInbox ibid luCreate
mractid <- lift $ insertToInbox now author body ibid luCreate False
case mractid of
Nothing -> return $ Left "Activity already in my inbox"
Just ractid ->
@ -225,12 +382,12 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
, LocalPersonCollectionProjectTeam shrRecip prjRecip
]
remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips
(sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips
(sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
_ -> return $ Left "Context is a sharer-ticket of another project"
case mremotesHttp of
Left msg -> return msg
Right (sig, remotesHttp) -> do
forkWorker "projectCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp
forkWorker "projectCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotesHttp
return "Stored to inbox and did inbox forwarding"
Left (NoteContextProjectTicket shr prj ltid) -> do
mremotesHttp <- runDBExcept $ do
@ -240,17 +397,17 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
fromMaybeE mticket "Context: No such project-ticket"
if ticketProjectLocalProject tpl == jid
then do
mractid <- lift $ insertToProjectInbox ibid luCreate
mractid <- lift $ insertToInbox now author body ibid luCreate False
case mractid of
Nothing -> return $ Left "Activity already in my inbox"
Just ractid -> do
let did = localTicketDiscuss lt
meparent <- traverse (getParent did) mparent
mmid <- lift $ insertToDiscussion luNote published did meparent ractid
mmid <- lift $ insertToDiscussion author luNote published source content did meparent ractid
case mmid of
Nothing -> return $ Left "I already have this comment, just storing in inbox"
Just mid -> lift $ do
updateOrphans luNote did mid
updateOrphans author luNote did mid
case msig of
Nothing ->
return $ Left "Storing in inbox, caching comment, no inbox forwarding header"
@ -265,104 +422,15 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
, LocalPersonCollectionProjectTicketTeam shrRecip prjRecip ltkhid
]
remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips
(sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips
(sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
else return $ Left "Context is a project-ticket of another project"
case mremotesHttp of
Left msg -> return msg
Right (sig, remotesHttp) -> do
forkWorker "projectCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp
forkWorker "projectCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotesHttp
return "Stored to inbox, cached comment, and did inbox forwarding"
where
getProjectRecip404 = do
sid <- getKeyBy404 $ UniqueSharer shrRecip
Entity jid j <- getBy404 $ UniqueProject prjRecip sid
return (jid, projectInbox j)
insertToProjectInbox ibid luCreate = do
let iidAuthor = remoteAuthorInstance author
roid <-
either entityKey id <$> insertBy' (RemoteObject iidAuthor luCreate)
ractid <- either entityKey id <$> insertBy' RemoteActivity
{ remoteActivityIdent = roid
, remoteActivityContent = persistJSONFromBL $ actbBL body
, remoteActivityReceived = now
}
ibiid <- insert $ InboxItem False
new <- isRight <$> insertBy' (InboxItemRemote ibid ractid ibiid)
return $
if new
then Just ractid
else Nothing
getParent did (Left (shrParent, lmidParent)) = Left <$> getLocalParentMessageId did shrParent lmidParent
getParent did (Right p@(ObjURI hParent luParent)) = do
mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent roid
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 p
insertToDiscussion luNote published did meparent ractid = do
let iidAuthor = remoteAuthorInstance author
raidAuthor = remoteAuthorId author
mid <- insert Message
{ messageCreated = published
, messageSource = src
, messageContent = content
, messageParent =
case meparent of
Just (Left midParent) -> Just midParent
_ -> Nothing
, messageRoot = did
}
roidNote <-
either entityKey id <$> insertBy' (RemoteObject iidAuthor luNote)
mrmid <- insertUnique RemoteMessage
{ remoteMessageAuthor = raidAuthor
, remoteMessageIdent = roidNote
, remoteMessageRest = mid
, remoteMessageCreate = ractid
, remoteMessageLostParent =
case meparent of
Just (Right uParent) -> Just uParent
_ -> Nothing
}
case mrmid of
Nothing -> do
delete mid
return Nothing
Just _ -> return $ Just mid
updateOrphans luNote did mid = do
let hAuthor = objUriAuthority $ remoteAuthorURI author
uNote = ObjURI hAuthor 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)

View file

@ -211,7 +211,7 @@ projectOfferTicketF
hLocal <- getsYesod siteInstanceHost
{-deps <- -}
checkOffer ticket hLocal shrRecip prjRecip
msig <- checkForward shrRecip prjRecip
msig <- checkForward $ LocalActorProject shrRecip prjRecip
let colls =
findRelevantCollections shrRecip prjRecip hLocal $
activityAudience $ actbActivity body
@ -225,13 +225,13 @@ projectOfferTicketF
for mticket $ \ (ractid, obiidAccept, docAccept) -> do
msr <- for msig $ \ sig -> do
remoteRecips <- deliverFwdLocal ractid colls sid fsid
(sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips
(sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
return (msr, obiidAccept, docAccept)
lift $ for_ mremotesHttp $ \ (msr, obiidAccept, docAccept) -> do
let handler e = logError $ "Project Accept sender: delivery failed! " <> T.pack (displayException e)
for msr $ \ (sig, remotesHttp) -> do
forkHandler handler $
deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp
deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotesHttp
forkHandler handler $ publishAccept luOffer obiidAccept docAccept
return $ recip <> " inserted new ticket"
where
@ -541,7 +541,7 @@ projectCreateTicketF now shrRecip prjRecip author body ticket muTarget = do
case targetAndContext of
Left (_, shrContext, prjContext)
| shrRecip == shrContext && prjRecip == prjContext -> do
msig <- checkForward shrRecip prjRecip
msig <- checkForward $ LocalActorProject shrRecip prjRecip
msgOrRecips <- lift $ runDB $ do
(sidProject, jid, obidProject, ibidProject, fsidProject) <- getProject
mractidCreate <- insertCreate luCreate ibidProject
@ -562,7 +562,7 @@ projectCreateTicketF now shrRecip prjRecip author body ticket muTarget = do
let colls = findRelevantCollections shrRecip prjRecip hLocal $ activityAudience $ actbActivity body
mremoteRecipsHttpCreateFwd <- for msig $ \ sig -> do
remoteRecips <- deliverFwdLocal ractidCreate colls sidProject fsidProject
(sig,) <$> deliverRemoteDB (actbBL body) ractidCreate jid sig remoteRecips
(sig,) <$> deliverRemoteDB_J (actbBL body) ractidCreate jid sig remoteRecips
remoteRecipsHttpAccept <- do
moreRemoteRecipsAccept <- deliverLocal' False (LocalActorProject shrRecip prjRecip) ibidProject obiidAccept localRecipsAccept
deliverRemoteDB' fwdAccept obiidAccept remoteRecipsAccept moreRemoteRecipsAccept
@ -570,7 +570,7 @@ projectCreateTicketF now shrRecip prjRecip author body ticket muTarget = do
case msgOrRecips of
Left msg -> return msg
Right (mremoteRecipsHttpCreateFwd, remoteRecipsHttpAccept, obiidAccept, docAccept, fwdAccept) -> do
for_ mremoteRecipsHttpCreateFwd $ \ (sig, recips) -> forkWorker "projectCreateTicketF inbox forwarding" $ deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig recips
for_ mremoteRecipsHttpCreateFwd $ \ (sig, recips) -> forkWorker "projectCreateTicketF inbox forwarding" $ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig recips
forkWorker "projectCreateTicketF deliver Accept" $ deliverRemoteHttp fwdAccept obiidAccept docAccept remoteRecipsHttpAccept
return "Accepting and listing new remote author hosted ticket"
_ -> return "Create/Ticket against different project, ignoring"

View file

@ -1552,6 +1552,16 @@ changes hLocal ctx =
"RemoteDiscussion"
-- 239
, addUnique "RemoteTicket" $ Unique "UniqueRemoteTicketDiscuss" ["discuss"]
-- 240
, addEntities model_2020_05_12
-- 241
, unchecked $ lift $ do
fwds <- selectList ([] :: [Filter Forwarding241]) []
let makeSender (Entity fwdid fwd) =
ForwarderProject241 fwdid (forwarding241Sender fwd)
insertMany_ $ map makeSender fwds
-- 242
, removeField "Forwarding" "sender"
]
migrateDB

View file

@ -189,6 +189,10 @@ module Vervis.Migration.Model
, RemoteObject238Generic (..)
, Discussion238Generic (..)
, RemoteDiscussion238Generic (..)
, model_2020_05_12
, Forwarding241
, Forwarding241Generic (..)
, ForwarderProject241Generic (..)
)
where
@ -371,3 +375,9 @@ model_2020_04_09 :: [Entity SqlBackend]
model_2020_04_09 = $(schema "2020_04_09_rt")
makeEntitiesMigration "238" $(modelFile "migrations/2020_04_10_rt_rd.model")
model_2020_05_12 :: [Entity SqlBackend]
model_2020_05_12 = $(schema "2020_05_12_fwd_sender")
makeEntitiesMigration "241"
$(modelFile "migrations/2020_05_12_fwd_sender_mig.model")