Incomplete project inbox handler
This commit is contained in:
fr33domlover
parent
f462a67680
commit
825a91d185
1 changed files with 145 additions and 93 deletions
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue