forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Incomplete project inbox handler

Browse source
This commit is contained in:
fr33domlover 2019-04-24 00:47:21 +00:00
parent f462a67680
commit 825a91d185
1 changed files with 145 additions and 93 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

238
src/Vervis/Federation.hs
View file

@ -159,6 +159,39 @@ parseComment luParent = do
MessageR shr hid -> (shr,) <$> decodeKeyHashidE hid "Non-existent local message hashid" MessageR shr hid -> (shr,) <$> decodeKeyHashidE hid "Non-existent local message hashid"
_ -> throwE "Not a local message route" _ -> 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 :: DiscussionId -> ShrIdent -> LocalMessageId -> ExceptT Text AppDB MessageId
getLocalParentMessageId did shr lmid = do getLocalParentMessageId did shr lmid = do
mlm <- lift $ get lmid mlm <- lift $ get lmid
@ -205,34 +238,6 @@ handleSharerInbox now shrRecip iidSender raw activity =
Left e -> return $ Left e Left e -> return $ Left e
Right _ -> Right <$> insertToInbox pidRecip Right _ -> Right <$> insertToInbox pidRecip
where 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 checkContextParent context mparent = runExceptT $ do
case context of case context of
Left (shr, prj, num) -> do Left (shr, prj, num) -> do
@ -285,62 +290,105 @@ handleSharerInbox now shrRecip iidSender raw activity =
return $ case mibrid of return $ case mibrid of
Nothing -> "Activity already exists in inbox of /s/" <> recip Nothing -> "Activity already exists in inbox of /s/" <> recip
Just _ -> "Activity inserted to inbox of /s/" <> recip Just _ -> "Activity inserted to inbox of /s/" <> recip
{-
verifyLocal fu t = do handleProjectInbox
let (h, lu) = f2l fu :: UTCTime
local <- hostIsLocal h -> ShrIdent
if local -> PrjIdent
then return lu -> InstanceId
else throwE t -> Text
parseParent :: LocalURI -> FedURI -> ExceptT Text Handler (Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI))) -> RemoteActorId
parseParent luContext uParent = do -> Object
let (hParent, luParent) = f2l uParent -> Activity
local <- hostIsLocal hParent -> ExceptT Text Handler Text
if local handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender raw activity =
then if luParent == luContext case activitySpecific activity of
then return Nothing CreateActivity (Create note) ->
else prependError "Local parent" $ Just . Left <$> parseComment luParent handleNote (activityAudience activity) note
else return $ Just $ Right (hParent, luParent) _ -> return "Unsupported activity type"
selectOrphans uNote did op = where
E.select $ E.from $ \ (rm `E.InnerJoin` m) -> do handleNote audience (Note mluNote _ _ muParent muCtx mpub content) = do
E.on $ rm E.^. RemoteMessageRest E.==. m E.^. MessageId luNote <- fromMaybeE mluNote "Note without note id"
E.where_ $ published <- fromMaybeE mpub "Note without 'published' field"
rm E.^. RemoteMessageLostParent E.==. E.just (E.val uNote) E.&&. uContext <- fromMaybeE muCtx "Note without context"
m E.^. MessageRoot `op` E.val did context <- parseContext uContext
return (rm E.^. RemoteMessageId, m E.^. MessageId) mparent <-
handleCreate iidActor hActor rsidActor raw audience (Note mluNote _luAttrib _aud muParent muContext mpublished content) = do case muParent of
ExceptT $ runDB $ runExceptT $ do Nothing -> return Nothing
mrmid <- lift $ getKeyBy $ UniqueRemoteMessageIdent iidActor luNote Just uParent ->
for_ mrmid $ \ rmid -> if uParent == uContext
throwE $ then return Nothing
"Got a Create Note with a note ID we already have, \ else Just <$> parseParent uParent
\RemoteMessageId " <> T.pack (show rmid) case context of
mdid <- lift $ runMaybeT $ do Right _ -> return $ recip <> " not using; context isn't local"
sid <- MaybeT $ getKeyBy $ UniqueSharer shr Left (shr, prj, num) ->
jid <- MaybeT $ getKeyBy $ UniqueProject prj sid if shr /= shrRecip || prj /= prjRecip
t <- MaybeT $ getValBy $ UniqueTicket jid num then return $ recip <> " not using; context is a different project"
return $ ticketDiscuss t else do
did <- fromMaybeE mdid "Got Create Note on non-existent ticket" 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 -> meparent <- for mparent $ \ parent ->
case parent of case parent of
Left (shrParent, lmid) -> Left <$> getLocalParentMessageId did shrParent lmid Left (shrParent, lmidParent) -> Left <$> getLocalParentMessageId did shrParent lmidParent
Right (hParent, luParent) -> do Right p@(hParent, luParent) -> do
mrm <- lift $ runMaybeT $ do mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
case mrm of case mrm of
Nothing -> do Just rm -> Left <$> do
logWarn "Got Create Note replying to a remote message we don't have"
return $ Right $ l2f hParent luParent
Just rm -> do
let mid = remoteMessageRest rm let mid = remoteMessageRest rm
m <- lift $ getJust mid m <- lift $ getJust mid
unless (messageRoot m == did) $ unless (messageRoot m == did) $
throwE "Got Create Note replying to remote message which belongs to a different discussion" throwE "Remote parent belongs to a different discussion"
return $ Left mid return mid
now <- liftIO getCurrentTime Nothing -> return $ Right $ l2f hParent luParent
rroid <- lift $ insert $ RemoteRawObject (PersistJSON raw) now return (did, meparent)
mid <- lift $ insert Message 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 { messageCreated = published
, messageContent = content , messageContent = content
, messageParent = , messageParent =
@ -349,25 +397,26 @@ handleSharerInbox now shrRecip iidSender raw activity =
_ -> Nothing _ -> Nothing
, messageRoot = did , messageRoot = did
} }
lift $ insert_ RemoteMessage mrmid <- insertUnique RemoteMessage
{ remoteMessageAuthor = rsidActor { remoteMessageAuthor = raidSender
, remoteMessageInstance = iidActor , remoteMessageInstance = iidSender
, remoteMessageIdent = luNote , remoteMessageIdent = luNote
, remoteMessageRest = mid , remoteMessageRest = mid
, remoteMessageRaw = rroid , remoteMessageCreate = ractid
, remoteMessageLostParent = , remoteMessageLostParent =
case meparent of case meparent of
Just (Right uParent) -> Just uParent Just (Right uParent) -> Just uParent
_ -> Nothing _ -> Nothing
} }
-- Now we need to check orphans. These are RemoteMessages whose case mrmid of
-- associated Message doesn't have a parent, but the original Note Nothing -> do
-- does have an inReplyTo which isn't the same as the context. It's delete mid
-- possible that this new activity we just got, this new Note, is return Nothing
-- exactly that lost parent. Just _ -> return $ Just mid
let uNote = l2f hActor luNote updateOrphans luNote did mid = do
related <- lift $ selectOrphans uNote did (E.==.) let uNote = l2f hSender luNote
lift $ for_ related $ \ (E.Value rmidOrphan, E.Value midOrphan) -> do related <- selectOrphans uNote (E.==.)
for_ related $ \ (E.Value rmidOrphan, E.Value midOrphan) -> do
logWarn $ T.concat logWarn $ T.concat
[ "Found parent for related orphan RemoteMessage #" [ "Found parent for related orphan RemoteMessage #"
, T.pack (show rmidOrphan) , T.pack (show rmidOrphan)
@ -376,7 +425,7 @@ handleSharerInbox now shrRecip iidSender raw activity =
] ]
update rmidOrphan [RemoteMessageLostParent =. Nothing] update rmidOrphan [RemoteMessageLostParent =. Nothing]
update midOrphan [MessageParent =. Just mid] update midOrphan [MessageParent =. Just mid]
unrelated <- lift $ selectOrphans uNote did (E.!=.) unrelated <- selectOrphans uNote (E.!=.)
for_ unrelated $ \ (E.Value rmidOrphan, E.Value _midOrphan) -> for_ unrelated $ \ (E.Value rmidOrphan, E.Value _midOrphan) ->
logWarn $ T.concat logWarn $ T.concat
[ "Found parent for unrelated orphan RemoteMessage #" [ "Found parent for unrelated orphan RemoteMessage #"
@ -385,8 +434,14 @@ handleSharerInbox now shrRecip iidSender raw activity =
, T.pack (show mid) , T.pack (show mid)
, " because they have different DiscussionId!" , " 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 :: (MonadIO m, MonadLogger m, IsSqlBackend backend) => ReaderT backend m ()
fixRunningDeliveries = do fixRunningDeliveries = do
@ -579,9 +634,6 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
verifyNothing Nothing _ = return () verifyNothing Nothing _ = return ()
verifyNothing (Just _) e = throwE e 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 :: Monad m => [a] -> e -> ExceptT e m (NonEmpty a)
nonEmptyE l e = nonEmptyE l e =
case nonEmpty l of case nonEmpty l of