From 825a91d1853b35e0f7126b4026408efc57b2e6d5 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Wed, 24 Apr 2019 00:47:21 +0000 Subject: [PATCH] Incomplete project inbox handler --- src/Vervis/Federation.hs | 238 ++++++++++++++++++++++++--------------- 1 file changed, 145 insertions(+), 93 deletions(-) diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index cc1af18..7f67728 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -159,6 +159,39 @@ parseComment luParent = do MessageR shr hid -> (shr,) <$> decodeKeyHashidE hid "Non-existent local message hashid" _ -> throwE "Not a local message route" +parseContext uContext = do + let c@(hContext, luContext) = f2l uContext + local <- hostIsLocal hContext + if local + then Left <$> do + route <- case decodeRouteLocal luContext of + Nothing -> throwE "Local context isn't a valid route" + Just r -> return r + case route of + TicketR shr prj num -> return (shr, prj, num) + _ -> throwE "Local context isn't a ticket route" + else return $ Right c + +parseParent uParent = do + let p@(hParent, luParent) = f2l uParent + local <- hostIsLocal hParent + if local + then Left <$> do + route <- case decodeRouteLocal luParent of + Nothing -> throwE "Local parent isn't a valid route" + Just r -> return r + case route of + MessageR shr lmkhid -> + (shr,) <$> + decodeKeyHashidE lmkhid + "Local parent has non-existent message \ + \hashid" + _ -> throwE "Local parent isn't a message route" + else return $ Right p + +concatRecipients :: Audience -> [FedURI] +concatRecipients (Audience to bto cc bcc gen) = concat [to, bto, cc, bcc, gen] + getLocalParentMessageId :: DiscussionId -> ShrIdent -> LocalMessageId -> ExceptT Text AppDB MessageId getLocalParentMessageId did shr lmid = do mlm <- lift $ get lmid @@ -205,34 +238,6 @@ handleSharerInbox now shrRecip iidSender raw activity = Left e -> return $ Left e Right _ -> Right <$> insertToInbox pidRecip where - parseContext uContext = do - let c@(hContext, luContext) = f2l uContext - local <- hostIsLocal hContext - if local - then Left <$> do - route <- case decodeRouteLocal luContext of - Nothing -> throwE "Local context isn't a valid route" - Just r -> return r - case route of - TicketR shr prj num -> return (shr, prj, num) - _ -> throwE "Local context isn't a ticket route" - else return $ Right c - parseParent uParent = do - let p@(hParent, luParent) = f2l uParent - local <- hostIsLocal hParent - if local - then Left <$> do - route <- case decodeRouteLocal luParent of - Nothing -> throwE "Local parent isn't a valid route" - Just r -> return r - case route of - MessageR shr lmkhid -> - (shr,) <$> - decodeKeyHashidE lmkhid - "Local parent has non-existent message \ - \hashid" - _ -> throwE "Local parent isn't a message route" - else return $ Right p checkContextParent context mparent = runExceptT $ do case context of Left (shr, prj, num) -> do @@ -285,62 +290,105 @@ handleSharerInbox now shrRecip iidSender raw activity = return $ case mibrid of Nothing -> "Activity already exists in inbox of /s/" <> recip Just _ -> "Activity inserted to inbox of /s/" <> recip - {- - verifyLocal fu t = do - let (h, lu) = f2l fu - local <- hostIsLocal h - if local - then return lu - else throwE t - parseParent :: LocalURI -> FedURI -> ExceptT Text Handler (Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI))) - parseParent luContext uParent = do - let (hParent, luParent) = f2l uParent - local <- hostIsLocal hParent - if local - then if luParent == luContext - then return Nothing - else prependError "Local parent" $ Just . Left <$> parseComment luParent - else return $ Just $ Right (hParent, luParent) - selectOrphans uNote did 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) - handleCreate iidActor hActor rsidActor raw audience (Note mluNote _luAttrib _aud muParent muContext mpublished content) = do - ExceptT $ runDB $ runExceptT $ do - mrmid <- lift $ getKeyBy $ UniqueRemoteMessageIdent iidActor luNote - for_ mrmid $ \ rmid -> - throwE $ - "Got a Create Note with a note ID we already have, \ - \RemoteMessageId " <> T.pack (show rmid) - mdid <- lift $ runMaybeT $ do - sid <- MaybeT $ getKeyBy $ UniqueSharer shr - jid <- MaybeT $ getKeyBy $ UniqueProject prj sid - t <- MaybeT $ getValBy $ UniqueTicket jid num - return $ ticketDiscuss t - did <- fromMaybeE mdid "Got Create Note on non-existent ticket" + +handleProjectInbox + :: UTCTime + -> ShrIdent + -> PrjIdent + -> InstanceId + -> Text + -> RemoteActorId + -> Object + -> Activity + -> ExceptT Text Handler Text +handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender raw activity = + case activitySpecific activity of + CreateActivity (Create note) -> + handleNote (activityAudience activity) note + _ -> return "Unsupported activity type" + where + handleNote audience (Note mluNote _ _ muParent muCtx mpub 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 + Nothing -> return Nothing + Just uParent -> + if uParent == uContext + then return Nothing + else Just <$> parseParent uParent + case context of + Right _ -> return $ recip <> " not using; context isn't local" + Left (shr, prj, num) -> + if shr /= shrRecip || prj /= prjRecip + then return $ recip <> " not using; context is a different project" + else do + hLocal <- getsYesod $ appInstanceHost . appSettings + let colls = findRelevantCollections hLocal num audience + runDBExcept $ do + (did, meparent) <- getContextAndParent num mparent + lift $ do + mmid <- insertToDiscussion luNote published did meparent + for mmid $ updateOrphans luNote did + -- TODO CONTINUE inbox forwarding!!! + return $ recip <> " inserted new ticket comment" + where + findRelevantCollections hLocal numCtx = nub . mapMaybe decide . concatRecipients + where + decide u = do + let (h, lu) = f2l u + guard $ h == hLocal + route <- decodeRouteLocal lu + case route of + TicketParticipantsR shr prj num + | shr == shrRecip && prj == prjRecip && num == numCtx + -> Just LocalTicketParticipants + TicketTeamR shr prj num + | shr == shrRecip && prj == prjRecip && num == numCtx + -> Just LocalTicketTeam + _ -> Nothing + recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip] + runDBExcept action = do + result <- + lift $ try $ runDB $ either abort return =<< runExceptT action + case result of + Left (FedError t) -> throwE t + Right r -> return r + where + abort = liftIO . throwIO . FedError + getContextAndParent num mparent = do + mt <- lift $ do + sid <- getKeyBy404 $ UniqueSharer shrRecip + jid <- getKeyBy404 $ UniqueProject prjRecip sid + getValBy $ UniqueTicket jid num + t <- fromMaybeE mt "Context: No such local ticket" + let did = ticketDiscuss t meparent <- for mparent $ \ parent -> case parent of - Left (shrParent, lmid) -> Left <$> getLocalParentMessageId did shrParent lmid - Right (hParent, luParent) -> do + Left (shrParent, lmidParent) -> Left <$> getLocalParentMessageId did shrParent lmidParent + Right p@(hParent, luParent) -> do mrm <- lift $ runMaybeT $ do iid <- MaybeT $ getKeyBy $ UniqueInstance hParent MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent case mrm of - Nothing -> do - logWarn "Got Create Note replying to a remote message we don't have" - return $ Right $ l2f hParent luParent - Just rm -> do + Just rm -> Left <$> do let mid = remoteMessageRest rm m <- lift $ getJust mid unless (messageRoot m == did) $ - throwE "Got Create Note replying to remote message which belongs to a different discussion" - return $ Left mid - now <- liftIO getCurrentTime - rroid <- lift $ insert $ RemoteRawObject (PersistJSON raw) now - mid <- lift $ insert Message + throwE "Remote parent belongs to a different discussion" + return mid + Nothing -> return $ Right $ l2f hParent luParent + return (did, meparent) + insertToDiscussion luNote published did meparent = do + ractid <- either entityKey id <$> insertBy' RemoteActivity + { remoteActivityInstance = iidSender + , remoteActivityIdent = activityId activity + , remoteActivityContent = PersistJSON raw + , remoteActivityReceived = now + } + mid <- insert Message { messageCreated = published , messageContent = content , messageParent = @@ -349,25 +397,26 @@ handleSharerInbox now shrRecip iidSender raw activity = _ -> Nothing , messageRoot = did } - lift $ insert_ RemoteMessage - { remoteMessageAuthor = rsidActor - , remoteMessageInstance = iidActor + mrmid <- insertUnique RemoteMessage + { remoteMessageAuthor = raidSender + , remoteMessageInstance = iidSender , remoteMessageIdent = luNote , remoteMessageRest = mid - , remoteMessageRaw = rroid + , remoteMessageCreate = ractid , remoteMessageLostParent = case meparent of Just (Right uParent) -> Just uParent _ -> Nothing } - -- Now we need to check orphans. These are RemoteMessages whose - -- associated Message doesn't have a parent, but the original Note - -- does have an inReplyTo which isn't the same as the context. It's - -- possible that this new activity we just got, this new Note, is - -- exactly that lost parent. - let uNote = l2f hActor luNote - related <- lift $ selectOrphans uNote did (E.==.) - lift $ for_ related $ \ (E.Value rmidOrphan, E.Value midOrphan) -> do + case mrmid of + Nothing -> do + delete mid + return Nothing + Just _ -> return $ Just mid + updateOrphans luNote did mid = do + let uNote = l2f hSender 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) @@ -376,7 +425,7 @@ handleSharerInbox now shrRecip iidSender raw activity = ] update rmidOrphan [RemoteMessageLostParent =. Nothing] update midOrphan [MessageParent =. Just mid] - unrelated <- lift $ selectOrphans uNote did (E.!=.) + unrelated <- selectOrphans uNote (E.!=.) for_ unrelated $ \ (E.Value rmidOrphan, E.Value _midOrphan) -> logWarn $ T.concat [ "Found parent for unrelated orphan RemoteMessage #" @@ -385,8 +434,14 @@ handleSharerInbox now shrRecip iidSender raw activity = , T.pack (show mid) , " because they have different DiscussionId!" ] - return (uNote, luContext) - -} + 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) fixRunningDeliveries :: (MonadIO m, MonadLogger m, IsSqlBackend backend) => ReaderT backend m () fixRunningDeliveries = do @@ -579,9 +634,6 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c verifyNothing Nothing _ = return () verifyNothing (Just _) e = throwE e - concatRecipients :: Audience -> [FedURI] - concatRecipients (Audience to bto cc bcc gen) = concat [to, bto, cc, bcc, gen] - nonEmptyE :: Monad m => [a] -> e -> ExceptT e m (NonEmpty a) nonEmptyE l e = case nonEmpty l of