forge/Vervis
1
0
Fork 0
Code Pull requests Activity

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

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

13
config/models
View file

@ -115,12 +115,23 @@ Forwarding
recipient RemoteActorId
activity RemoteActivityId
activityRaw ByteString
sender ProjectId
signature ByteString
running Bool
UniqueForwarding recipient activity
ForwarderSharer
task ForwardingId
sender SharerId
UniqueForwarderSharer task
ForwarderProject
task ForwardingId
sender ProjectId
UniqueForwarderProject task
VerifKey
ident LocalRefURI
instance InstanceId

11
migrations/2020_05_12_fwd_sender.model Normal file
View file

@ -0,0 +1,11 @@
ForwarderSharer
task ForwardingId
sender SharerId
UniqueForwarderSharer task
ForwarderProject
task ForwardingId
sender ProjectId
UniqueForwarderProject task

21
migrations/2020_05_12_fwd_sender_mig.model Normal file
View file

@ -0,0 +1,21 @@
RemoteActor
RemoteActivity
Project
Forwarding
recipient RemoteActorId
activity RemoteActivityId
activityRaw ByteString
sender ProjectId
signature ByteString
running Bool
UniqueForwarding recipient activity
ForwarderProject
task ForwardingId
sender ProjectId
UniqueForwarderProject task

10
src/Data/Tuple/Local.hs
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

116
src/Vervis/ActivityPub.hs
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

76
src/Vervis/Federation.hs
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 $

418
src/Vervis/Federation/Discussion.hs
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)

12
src/Vervis/Federation/Ticket.hs
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"

10
src/Vervis/Migration.hs
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

10
src/Vervis/Migration/Model.hs
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")