S2S: sharerCreateNoteF & projectCreateNoteF can handle sharer-hosted tickets
This commit is contained in:
fr33domlover
parent
edaa3c49b2
commit
c91908941b
3 changed files with 242 additions and 191 deletions
|
|
@ -149,11 +149,6 @@ parseComment luParent = do
|
|||
MessageR shr hid -> (shr,) <$> decodeKeyHashidE hid "Non-existent local message hashid"
|
||||
_ -> throwE "Not a local message route"
|
||||
|
||||
data NoteContext
|
||||
= NoteContextSharerTicket ShrIdent TicketAuthorLocalId
|
||||
| NoteContextProjectTicket ShrIdent PrjIdent LocalTicketId
|
||||
deriving Eq
|
||||
|
||||
noteC
|
||||
:: Entity Person
|
||||
-> Sharer
|
||||
|
|
|
|||
|
|
@ -14,7 +14,8 @@
|
|||
-}
|
||||
|
||||
module Vervis.ActivityPub
|
||||
( hostIsLocal
|
||||
( NoteContext (..)
|
||||
, hostIsLocal
|
||||
, verifyHostLocal
|
||||
, parseContext
|
||||
, parseParent
|
||||
|
|
@ -43,6 +44,7 @@ module Vervis.ActivityPub
|
|||
, deliverLocal
|
||||
, RemoteRecipient (..)
|
||||
, deliverLocal'
|
||||
, insertRemoteActivityToLocalInboxes
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -119,6 +121,11 @@ import Vervis.Time
|
|||
import Vervis.Widget.Repo
|
||||
import Vervis.Widget.Sharer
|
||||
|
||||
data NoteContext
|
||||
= NoteContextSharerTicket ShrIdent TicketAuthorLocalId
|
||||
| NoteContextProjectTicket ShrIdent PrjIdent LocalTicketId
|
||||
deriving Eq
|
||||
|
||||
hostIsLocal :: (MonadSite m, SiteEnv m ~ App) => Host -> m Bool
|
||||
hostIsLocal h = asksSite $ (== h) . appInstanceHost . appSettings
|
||||
|
||||
|
|
@ -132,7 +139,7 @@ verifyHostLocal h t = do
|
|||
parseContext
|
||||
:: (MonadSite m, SiteEnv m ~ App)
|
||||
=> FedURI
|
||||
-> ExceptT Text m (Either (ShrIdent, PrjIdent, KeyHashid LocalTicket) FedURI)
|
||||
-> ExceptT Text m (Either NoteContext FedURI)
|
||||
parseContext uContext = do
|
||||
let ObjURI hContext luContext = uContext
|
||||
local <- hostIsLocal hContext
|
||||
|
|
@ -142,7 +149,12 @@ parseContext uContext = do
|
|||
Nothing -> throwE "Local context isn't a valid route"
|
||||
Just r -> return r
|
||||
case route of
|
||||
ProjectTicketR shr prj num -> return (shr, prj, num)
|
||||
SharerTicketR shr talkhid ->
|
||||
NoteContextSharerTicket shr <$>
|
||||
decodeKeyHashidE talkhid "Note context invalid talkhid"
|
||||
ProjectTicketR shr prj ltkhid ->
|
||||
NoteContextProjectTicket shr prj <$>
|
||||
decodeKeyHashidE ltkhid "Note context invalid ltkhid"
|
||||
_ -> throwE "Local context isn't a ticket route"
|
||||
else return $ Right uContext
|
||||
|
||||
|
|
@ -735,15 +747,25 @@ data RemoteRecipient = RemoteRecipient
|
|||
-- * Insert activity to inboxes of actors
|
||||
-- * If collections are listed, insert activity to the local members and return
|
||||
-- the remote members
|
||||
deliverLocal'
|
||||
:: Bool -- ^ Whether to deliver to collection only if owner actor is addressed
|
||||
-> LocalActor
|
||||
-> InboxId
|
||||
-> OutboxItemId
|
||||
insertActivityToLocalInboxes
|
||||
:: PersistRecordBackend record SqlBackend
|
||||
=> (InboxId -> InboxItemId -> record)
|
||||
-- ^ Database record to insert as an new inbox item to each inbox
|
||||
-> Bool
|
||||
-- ^ Whether to deliver to collection only if owner actor is addressed
|
||||
-> Maybe LocalActor
|
||||
-- ^ An actor whose collections are excluded from requiring an owner, i.e.
|
||||
-- even if owner is required, this actor's collections will be delivered
|
||||
-- to, even if this actor isn't addressed. This is meant to be the
|
||||
-- activity's author.
|
||||
-> Maybe InboxId
|
||||
-- ^ A user person's inbox to exclude from delivery, even if this person is
|
||||
-- listed in the recipient set. This is meant to be the activity's
|
||||
-- author.
|
||||
-> LocalRecipientSet
|
||||
-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
|
||||
deliverLocal' requireOwner author ibidAuthor obiid recips = do
|
||||
ibidsSharer <- L.delete ibidAuthor <$> getSharerInboxes recips
|
||||
insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor recips = do
|
||||
ibidsSharer <- deleteAuthor <$> getSharerInboxes recips
|
||||
ibidsOther <- concat <$> traverse getOtherInboxes recips
|
||||
|
||||
(ibidsFollowers, remotesFollowers) <- do
|
||||
|
|
@ -754,13 +776,23 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do
|
|||
|
||||
ibidsTeams <- foldl' LO.union [] <$> traverse getTeams recips
|
||||
|
||||
let ibids = L.delete ibidAuthor (ibidsFollowers `LO.union` ibidsTeams `LO.union` ibidsSharer) ++ ibidsOther
|
||||
let ibids = deleteAuthor (ibidsFollowers `LO.union` ibidsTeams `LO.union` ibidsSharer) ++ ibidsOther
|
||||
ibiids <- insertMany $ replicate (length ibids) $ InboxItem True
|
||||
insertMany_ $
|
||||
map (\ (ibid, ibiid) -> InboxItemLocal ibid obiid ibiid)
|
||||
(zip ibids ibiids)
|
||||
insertMany_ $ zipWith makeInboxItem ibids ibiids
|
||||
return remotesFollowers
|
||||
where
|
||||
isAuthor :: LocalActor -> Bool
|
||||
isAuthor =
|
||||
case mauthor of
|
||||
Nothing -> const False
|
||||
Just author -> (== author)
|
||||
|
||||
deleteAuthor :: [InboxId] -> [InboxId]
|
||||
deleteAuthor =
|
||||
case mibidAuthor of
|
||||
Nothing -> id
|
||||
Just ibidAuthor -> L.delete ibidAuthor
|
||||
|
||||
getSharerInboxes :: LocalRecipientSet -> AppDB [InboxId]
|
||||
getSharerInboxes sharers = do
|
||||
let shrs =
|
||||
|
|
@ -801,7 +833,7 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do
|
|||
[shr | (shr, s) <- sharers
|
||||
, let d = localRecipSharerDirect s
|
||||
in localRecipSharerFollowers d &&
|
||||
(localRecipSharer d || not requireOwner || LocalActorSharer shr == author)
|
||||
(localRecipSharer d || not requireOwner || isAuthor (LocalActorSharer shr))
|
||||
]
|
||||
sids <- selectKeysList [SharerIdent <-. shrs] []
|
||||
map (personFollowers . entityVal) <$> selectList [PersonIdent <-. sids] []
|
||||
|
|
@ -838,7 +870,7 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do
|
|||
[prj | (prj, j) <- projects
|
||||
, let d = localRecipProjectDirect j
|
||||
in localRecipProjectFollowers d &&
|
||||
(localRecipProject d || not requireOwner || LocalActorProject shr prj == author)
|
||||
(localRecipProject d || not requireOwner || isAuthor (LocalActorProject shr prj))
|
||||
]
|
||||
fsidsJ <-
|
||||
map (projectFollowers . entityVal) <$>
|
||||
|
|
@ -848,7 +880,7 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do
|
|||
then
|
||||
[ (prj, localRecipProjectTicketRelated j)
|
||||
| (prj, j) <- projects
|
||||
, localRecipProject (localRecipProjectDirect j) || LocalActorProject shr prj == author
|
||||
, localRecipProject (localRecipProjectDirect j) || isAuthor (LocalActorProject shr prj)
|
||||
]
|
||||
else
|
||||
map (second localRecipProjectTicketRelated) projects
|
||||
|
|
@ -882,7 +914,7 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do
|
|||
[rp | (rp, r) <- repos
|
||||
, let d = localRecipRepoDirect r
|
||||
in localRecipRepoFollowers d &&
|
||||
(localRecipRepo d || not requireOwner || LocalActorRepo shr rp == author)
|
||||
(localRecipRepo d || not requireOwner || isAuthor (LocalActorRepo shr rp))
|
||||
]
|
||||
in map (repoFollowers . entityVal) <$>
|
||||
selectList [RepoSharer ==. sid, RepoIdent <-. rps] []
|
||||
|
|
@ -935,7 +967,7 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do
|
|||
getProjectTeams sid projects = do
|
||||
let prjs =
|
||||
[prj | (prj, LocalProjectRelatedSet d ts) <- projects
|
||||
, (localRecipProject d || not requireOwner || LocalActorProject shr prj == author) &&
|
||||
, (localRecipProject d || not requireOwner || isAuthor (LocalActorProject shr prj)) &&
|
||||
(localRecipProjectTeam d || any (localRecipTicketTeam . snd) ts)
|
||||
]
|
||||
jids <- selectKeysList [ProjectSharer ==. sid, ProjectIdent <-. prjs] []
|
||||
|
|
@ -946,8 +978,36 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do
|
|||
[rp | (rp, r) <- repos
|
||||
, let d = localRecipRepoDirect r
|
||||
in localRecipRepoTeam d &&
|
||||
(localRecipRepo d || not requireOwner || LocalActorRepo shr rp == author)
|
||||
(localRecipRepo d || not requireOwner || isAuthor (LocalActorRepo shr rp))
|
||||
]
|
||||
rids <- selectKeysList [RepoSharer ==. sid, RepoIdent <-. rps] []
|
||||
pids <- map (repoCollabPerson . entityVal) <$> selectList [RepoCollabRepo <-. rids] []
|
||||
map (personInbox . entityVal) <$> selectList [PersonId <-. pids] [Asc PersonInbox]
|
||||
|
||||
-- | Given a list of local recipients, which may include actors and
|
||||
-- collections,
|
||||
--
|
||||
-- * Insert activity to inboxes of actors
|
||||
-- * If collections are listed, insert activity to the local members and return
|
||||
-- the remote members
|
||||
deliverLocal'
|
||||
:: Bool -- ^ Whether to deliver to collection only if owner actor is addressed
|
||||
-> LocalActor
|
||||
-> InboxId
|
||||
-> OutboxItemId
|
||||
-> LocalRecipientSet
|
||||
-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
|
||||
deliverLocal' requireOwner author ibidAuthor obiid =
|
||||
insertActivityToLocalInboxes makeItem requireOwner (Just author) (Just ibidAuthor)
|
||||
where
|
||||
makeItem ibid ibiid = InboxItemLocal ibid obiid ibiid
|
||||
|
||||
insertRemoteActivityToLocalInboxes
|
||||
:: Bool
|
||||
-> RemoteActivityId
|
||||
-> LocalRecipientSet
|
||||
-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
|
||||
insertRemoteActivityToLocalInboxes requireOwner ractid =
|
||||
insertActivityToLocalInboxes makeItem requireOwner Nothing Nothing
|
||||
where
|
||||
makeItem ibid ibiid = InboxItemRemote ibid ractid ibiid
|
||||
|
|
|
|||
|
|
@ -27,6 +27,7 @@ import Control.Monad.Trans.Except
|
|||
import Control.Monad.Trans.Maybe
|
||||
import Data.Bifunctor
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Either
|
||||
import Data.Foldable
|
||||
import Data.Function
|
||||
import Data.List (sort, deleteBy, nub, union, unionBy, partition)
|
||||
|
|
@ -55,6 +56,7 @@ import Web.ActivityPub
|
|||
import Yesod.ActivityPub
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
import Yesod.MonadSite
|
||||
|
||||
import Control.Monad.Trans.Except.Local
|
||||
import Data.Tuple.Local
|
||||
|
|
@ -69,6 +71,7 @@ import Vervis.Foundation
|
|||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
import Vervis.Settings
|
||||
import Vervis.Ticket
|
||||
|
||||
sharerCreateNoteF
|
||||
:: UTCTime
|
||||
|
|
@ -101,56 +104,55 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext
|
|||
Right _ ->
|
||||
Right <$> insertToInbox luCreate (personInbox personRecip)
|
||||
where
|
||||
checkContextParent context mparent = runExceptT $ do
|
||||
case context of
|
||||
Left (shr, prj, ltkhid) -> do
|
||||
mdid <- lift $ runMaybeT $ do
|
||||
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
|
||||
jid <- MaybeT $ getKeyBy $ UniqueProject prj sid
|
||||
ltid <- decodeKeyHashidM ltkhid
|
||||
lt <- MaybeT $ get ltid
|
||||
tpl <-
|
||||
MaybeT $ getValBy $
|
||||
UniqueTicketProjectLocal $ localTicketTicket lt
|
||||
guard $ ticketProjectLocalProject tpl == jid
|
||||
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
|
||||
did <- fromMaybeE mdid "Context: No such local ticket"
|
||||
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"
|
||||
Right (ObjURI hContext luContext) -> do
|
||||
mdid <- lift $ runMaybeT $ do
|
||||
iid <- MaybeT $ getKeyBy $ UniqueInstance hContext
|
||||
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luContext
|
||||
rd <- MaybeT $ getValBy $ UniqueRemoteDiscussionIdent roid
|
||||
return $ remoteDiscussionDiscuss rd
|
||||
for_ mparent $ \ parent ->
|
||||
case parent of
|
||||
Left (shrP, lmidP) -> do
|
||||
did <- fromMaybeE mdid "Local parent inexistent, no RemoteDiscussion"
|
||||
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
|
||||
did <- fromMaybeE mdid "Remote parent known, but no context RemoteDiscussion"
|
||||
unless (messageRoot m == did) $
|
||||
throwE "Remote parent belongs to a different discussion"
|
||||
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
|
||||
mdid <- lift $ runMaybeT $ do
|
||||
iid <- MaybeT $ getKeyBy $ UniqueInstance hContext
|
||||
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luContext
|
||||
rd <- MaybeT $ getValBy $ UniqueRemoteDiscussionIdent roid
|
||||
return $ remoteDiscussionDiscuss rd
|
||||
for_ mparent $ \ parent ->
|
||||
case parent of
|
||||
Left (shrP, lmidP) -> do
|
||||
did <- fromMaybeE mdid "Local parent inexistent, no RemoteDiscussion"
|
||||
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
|
||||
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 <-
|
||||
|
|
@ -167,12 +169,6 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext
|
|||
return $ "Activity already exists in inbox of /s/" <> recip
|
||||
Just _ -> return $ "Activity inserted to inbox of /s/" <> recip
|
||||
|
||||
data CreateNoteRecipColl
|
||||
= CreateNoteRecipProjectFollowers
|
||||
| CreateNoteRecipTicketParticipants
|
||||
| CreateNoteRecipTicketTeam
|
||||
deriving Eq
|
||||
|
||||
projectCreateNoteF
|
||||
:: UTCTime
|
||||
-> ShrIdent
|
||||
|
|
@ -195,84 +191,94 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
|
|||
if uParent == uContext
|
||||
then return Nothing
|
||||
else Just <$> parseParent uParent
|
||||
(localRecips, _remoteRecips) <- do
|
||||
mrecips <- parseAudience $ activityAudience $ actbActivity body
|
||||
fromMaybeE mrecips "Create Note with no recipients"
|
||||
msig <- checkForward shrRecip prjRecip
|
||||
case context of
|
||||
Right _ -> return $ recip <> " not using; context isn't local"
|
||||
Left (shr, prj, ltkhid) ->
|
||||
if shr /= shrRecip || prj /= prjRecip
|
||||
then return $ recip <> " not using; context is a different project"
|
||||
else do
|
||||
msig <- checkForward shrRecip prjRecip
|
||||
hLocal <- getsYesod $ appInstanceHost . appSettings
|
||||
let colls =
|
||||
findRelevantCollections hLocal ltkhid $
|
||||
activityAudience $ actbActivity body
|
||||
mremotesHttp <- runDBExcept $ do
|
||||
(sid, fsidProject, fsidTicket, jid, ibid, did, meparent) <- getContextAndParent ltkhid mparent
|
||||
lift $ join <$> do
|
||||
mmid <- insertToDiscussion luCreate luNote published ibid did meparent fsidTicket
|
||||
for mmid $ \ (ractid, mid) -> do
|
||||
updateOrphans luNote did mid
|
||||
for msig $ \ sig -> do
|
||||
remoteRecips <- deliverLocal ractid colls sid fsidProject fsidTicket
|
||||
(sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips
|
||||
lift $ for_ mremotesHttp $ \ (sig, remotesHttp) -> do
|
||||
let handler e = logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e)
|
||||
forkHandler handler $
|
||||
deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp
|
||||
return $ recip <> " inserted new ticket comment"
|
||||
Right _ -> return "Not using; context isn't local"
|
||||
Left (NoteContextSharerTicket shr talid) -> do
|
||||
mremotesHttp <- runDBExcept $ do
|
||||
(jid, ibid) <- lift getProjectRecip404
|
||||
(_, _, _, project) <- do
|
||||
mticket <- lift $ getSharerTicket shr talid
|
||||
fromMaybeE mticket "Context: No such sharer-ticket"
|
||||
case project of
|
||||
Left (Entity _ tpl)
|
||||
| ticketProjectLocalProject tpl == jid -> do
|
||||
mractid <- lift $ insertToProjectInbox ibid luCreate
|
||||
case mractid of
|
||||
Nothing -> return $ Left "Activity already in my inbox"
|
||||
Just ractid ->
|
||||
case msig of
|
||||
Nothing ->
|
||||
return $ Left
|
||||
"Context is a sharer-ticket, \
|
||||
\but no inbox forwarding \
|
||||
\header for me, so doing \
|
||||
\nothing, just storing in inbox"
|
||||
Just sig -> lift $ Right <$> do
|
||||
let sieve =
|
||||
makeRecipientSet
|
||||
[]
|
||||
[ LocalPersonCollectionProjectFollowers shrRecip prjRecip
|
||||
, LocalPersonCollectionProjectTeam shrRecip prjRecip
|
||||
]
|
||||
remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips
|
||||
(sig,) <$> deliverRemoteDB (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
|
||||
return "Stored to inbox and did inbox forwarding"
|
||||
Left (NoteContextProjectTicket shr prj ltid) -> do
|
||||
mremotesHttp <- runDBExcept $ do
|
||||
(jid, ibid) <- lift getProjectRecip404
|
||||
(_, _, _, Entity _ lt, Entity _ tpl, _) <- do
|
||||
mticket <- lift $ getProjectTicket shr prj ltid
|
||||
fromMaybeE mticket "Context: No such project-ticket"
|
||||
if ticketProjectLocalProject tpl == jid
|
||||
then do
|
||||
mractid <- lift $ insertToProjectInbox ibid luCreate
|
||||
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
|
||||
case mmid of
|
||||
Nothing -> return $ Left "I already have this comment, just storing in inbox"
|
||||
Just mid -> lift $ do
|
||||
updateOrphans luNote did mid
|
||||
case msig of
|
||||
Nothing ->
|
||||
return $ Left "Storing in inbox, caching comment, no inbox forwarding header"
|
||||
Just sig -> Right <$> do
|
||||
ltkhid <- encodeKeyHashid ltid
|
||||
let sieve =
|
||||
makeRecipientSet
|
||||
[]
|
||||
[ LocalPersonCollectionProjectFollowers shrRecip prjRecip
|
||||
, LocalPersonCollectionProjectTeam shrRecip prjRecip
|
||||
, LocalPersonCollectionProjectTicketFollowers shrRecip prjRecip ltkhid
|
||||
, LocalPersonCollectionProjectTicketTeam shrRecip prjRecip ltkhid
|
||||
]
|
||||
remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips
|
||||
(sig,) <$> deliverRemoteDB (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
|
||||
return "Stored to inbox, cached comment, and did inbox forwarding"
|
||||
where
|
||||
findRelevantCollections hLocal ctx = nub . mapMaybe decide . concatRecipients
|
||||
where
|
||||
decide u = do
|
||||
let ObjURI h lu = u
|
||||
guard $ h == hLocal
|
||||
route <- decodeRouteLocal lu
|
||||
case route of
|
||||
ProjectFollowersR shr prj
|
||||
| shr == shrRecip && prj == prjRecip
|
||||
-> Just CreateNoteRecipProjectFollowers
|
||||
ProjectTicketParticipantsR shr prj tkhid
|
||||
| shr == shrRecip && prj == prjRecip && tkhid == ctx
|
||||
-> Just CreateNoteRecipTicketParticipants
|
||||
ProjectTicketTeamR shr prj tkhid
|
||||
| shr == shrRecip && prj == prjRecip && tkhid == ctx
|
||||
-> Just CreateNoteRecipTicketTeam
|
||||
_ -> Nothing
|
||||
recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip]
|
||||
getContextAndParent ltkhid mparent = do
|
||||
mt <- do
|
||||
sid <- lift $ getKeyBy404 $ UniqueSharer shrRecip
|
||||
Entity jid j <- lift $ getBy404 $ UniqueProject prjRecip sid
|
||||
ltid <- decodeKeyHashidE ltkhid "Context: Not a valid ticket khid"
|
||||
mlt <- lift $ get ltid
|
||||
for mlt $ \ lt -> do
|
||||
mtpl <- lift $ getValBy $ UniqueTicketProjectLocal $ localTicketTicket lt
|
||||
tpl <- fromMaybeE mtpl "No TPL"
|
||||
unless (ticketProjectLocalProject tpl == jid) $
|
||||
throwE "Context: Local ticket khid belongs to different project"
|
||||
return (jid, projectInbox j, projectFollowers j, sid, lt)
|
||||
(jid, ibid, fsidProject, sid, lt) <- fromMaybeE mt "Context: No such local ticket"
|
||||
let did = localTicketDiscuss lt
|
||||
meparent <- for mparent $ \ parent ->
|
||||
case parent of
|
||||
Left (shrParent, lmidParent) -> Left <$> getLocalParentMessageId did shrParent lmidParent
|
||||
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
|
||||
return (sid, fsidProject, localTicketFollowers lt, jid, ibid, did, meparent)
|
||||
insertToDiscussion luCreate luNote published ibid did meparent fsid = do
|
||||
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
|
||||
raidAuthor = remoteAuthorId author
|
||||
roid <-
|
||||
either entityKey id <$> insertBy' (RemoteObject iidAuthor luCreate)
|
||||
ractid <- either entityKey id <$> insertBy' RemoteActivity
|
||||
|
|
@ -280,6 +286,29 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
|
|||
, 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
|
||||
|
|
@ -290,11 +319,11 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
|
|||
_ -> Nothing
|
||||
, messageRoot = did
|
||||
}
|
||||
roid2 <-
|
||||
roidNote <-
|
||||
either entityKey id <$> insertBy' (RemoteObject iidAuthor luNote)
|
||||
mrmid <- insertUnique RemoteMessage
|
||||
{ remoteMessageAuthor = raidAuthor
|
||||
, remoteMessageIdent = roid2
|
||||
, remoteMessageIdent = roidNote
|
||||
, remoteMessageRest = mid
|
||||
, remoteMessageCreate = ractid
|
||||
, remoteMessageLostParent =
|
||||
|
|
@ -306,11 +335,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
|
|||
Nothing -> do
|
||||
delete mid
|
||||
return Nothing
|
||||
Just _ -> do
|
||||
-- insertUnique_ $ RemoteFollow raidAuthor fsid False True
|
||||
ibiid <- insert $ InboxItem False
|
||||
insert_ $ InboxItemRemote ibid ractid ibiid
|
||||
return $ Just (ractid, mid)
|
||||
Just _ -> return $ Just mid
|
||||
updateOrphans luNote did mid = do
|
||||
let hAuthor = objUriAuthority $ remoteAuthorURI author
|
||||
uNote = ObjURI hAuthor luNote
|
||||
|
|
@ -341,32 +366,3 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
|
|||
rm E.^. RemoteMessageLostParent E.==. E.just (E.val uNote) E.&&.
|
||||
m E.^. MessageRoot `op` E.val did
|
||||
return (rm E.^. RemoteMessageId, m E.^. MessageId)
|
||||
deliverLocal
|
||||
:: RemoteActivityId
|
||||
-> [CreateNoteRecipColl]
|
||||
-> SharerId
|
||||
-> FollowerSetId
|
||||
-> FollowerSetId
|
||||
-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
|
||||
deliverLocal ractid recips sid fsidProject fsidTicket = do
|
||||
(teamPids, teamRemotes) <-
|
||||
if CreateNoteRecipTicketTeam `elem` recips
|
||||
then getTicketTeam sid
|
||||
else return ([], [])
|
||||
(tfsPids, tfsRemotes) <-
|
||||
if CreateNoteRecipTicketParticipants `elem` recips
|
||||
then getFollowers fsidTicket
|
||||
else return ([], [])
|
||||
(jfsPids, jfsRemotes) <-
|
||||
if CreateNoteRecipProjectFollowers `elem` recips
|
||||
then getFollowers fsidProject
|
||||
else return ([], [])
|
||||
let pids = union teamPids tfsPids `union` jfsPids
|
||||
remotes = teamRemotes `unionRemotes` tfsRemotes `unionRemotes` jfsRemotes
|
||||
for_ pids $ \ pid -> do
|
||||
ibid <- personInbox <$> getJust pid
|
||||
ibiid <- insert $ InboxItem True
|
||||
mibrid <- insertUnique $ InboxItemRemote ibid ractid ibiid
|
||||
when (isNothing mibrid) $
|
||||
delete ibiid
|
||||
return remotes
|
||||
|
|
|
|||
Loading…
Reference in a new issue