diff --git a/config/models b/config/models index 20c02c6..676a070 100644 --- a/config/models +++ b/config/models @@ -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 diff --git a/migrations/2020_05_12_fwd_sender.model b/migrations/2020_05_12_fwd_sender.model new file mode 100644 index 0000000..f1a106a --- /dev/null +++ b/migrations/2020_05_12_fwd_sender.model @@ -0,0 +1,11 @@ +ForwarderSharer + task ForwardingId + sender SharerId + + UniqueForwarderSharer task + +ForwarderProject + task ForwardingId + sender ProjectId + + UniqueForwarderProject task diff --git a/migrations/2020_05_12_fwd_sender_mig.model b/migrations/2020_05_12_fwd_sender_mig.model new file mode 100644 index 0000000..9fef703 --- /dev/null +++ b/migrations/2020_05_12_fwd_sender_mig.model @@ -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 diff --git a/src/Data/Tuple/Local.hs b/src/Data/Tuple/Local.hs index b4a9c0c..d1bbebd 100644 --- a/src/Data/Tuple/Local.hs +++ b/src/Data/Tuple/Local.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019 by fr33domlover . + - Written in 2019, 2020 by fr33domlover . - - ♡ 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 diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index 98e0edd..68076bb 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -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 diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index b10cdad..04a06ae 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -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 $ diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs index cb1d9c9..22a097d 100644 --- a/src/Vervis/Federation/Discussion.hs +++ b/src/Vervis/Federation/Discussion.hs @@ -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) diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 710db64..8b8eedf 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -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" diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 6d75e42..037af95 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -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 diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 92ce755..bc8037f 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -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")