S2S: sharerCreateNoteF & projectCreateNoteF can handle sharer-hosted tickets

This commit is contained in:
fr33domlover 2020-05-11 18:59:29 +00:00
parent edaa3c49b2
commit c91908941b
3 changed files with 242 additions and 191 deletions

View file

@ -149,11 +149,6 @@ 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"
data NoteContext
= NoteContextSharerTicket ShrIdent TicketAuthorLocalId
| NoteContextProjectTicket ShrIdent PrjIdent LocalTicketId
deriving Eq
noteC noteC
:: Entity Person :: Entity Person
-> Sharer -> Sharer

View file

@ -14,7 +14,8 @@
-} -}
module Vervis.ActivityPub module Vervis.ActivityPub
( hostIsLocal ( NoteContext (..)
, hostIsLocal
, verifyHostLocal , verifyHostLocal
, parseContext , parseContext
, parseParent , parseParent
@ -43,6 +44,7 @@ module Vervis.ActivityPub
, deliverLocal , deliverLocal
, RemoteRecipient (..) , RemoteRecipient (..)
, deliverLocal' , deliverLocal'
, insertRemoteActivityToLocalInboxes
) )
where where
@ -119,6 +121,11 @@ import Vervis.Time
import Vervis.Widget.Repo import Vervis.Widget.Repo
import Vervis.Widget.Sharer 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 :: (MonadSite m, SiteEnv m ~ App) => Host -> m Bool
hostIsLocal h = asksSite $ (== h) . appInstanceHost . appSettings hostIsLocal h = asksSite $ (== h) . appInstanceHost . appSettings
@ -132,7 +139,7 @@ verifyHostLocal h t = do
parseContext parseContext
:: (MonadSite m, SiteEnv m ~ App) :: (MonadSite m, SiteEnv m ~ App)
=> FedURI => FedURI
-> ExceptT Text m (Either (ShrIdent, PrjIdent, KeyHashid LocalTicket) FedURI) -> ExceptT Text m (Either NoteContext FedURI)
parseContext uContext = do parseContext uContext = do
let ObjURI hContext luContext = uContext let ObjURI hContext luContext = uContext
local <- hostIsLocal hContext local <- hostIsLocal hContext
@ -142,7 +149,12 @@ parseContext uContext = do
Nothing -> throwE "Local context isn't a valid route" Nothing -> throwE "Local context isn't a valid route"
Just r -> return r Just r -> return r
case route of 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" _ -> throwE "Local context isn't a ticket route"
else return $ Right uContext else return $ Right uContext
@ -735,15 +747,25 @@ data RemoteRecipient = RemoteRecipient
-- * Insert activity to inboxes of actors -- * Insert activity to inboxes of actors
-- * If collections are listed, insert activity to the local members and return -- * If collections are listed, insert activity to the local members and return
-- the remote members -- the remote members
deliverLocal' insertActivityToLocalInboxes
:: Bool -- ^ Whether to deliver to collection only if owner actor is addressed :: PersistRecordBackend record SqlBackend
-> LocalActor => (InboxId -> InboxItemId -> record)
-> InboxId -- ^ Database record to insert as an new inbox item to each inbox
-> OutboxItemId -> 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 -> LocalRecipientSet
-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)] -> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
deliverLocal' requireOwner author ibidAuthor obiid recips = do insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor recips = do
ibidsSharer <- L.delete ibidAuthor <$> getSharerInboxes recips ibidsSharer <- deleteAuthor <$> getSharerInboxes recips
ibidsOther <- concat <$> traverse getOtherInboxes recips ibidsOther <- concat <$> traverse getOtherInboxes recips
(ibidsFollowers, remotesFollowers) <- do (ibidsFollowers, remotesFollowers) <- do
@ -754,13 +776,23 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do
ibidsTeams <- foldl' LO.union [] <$> traverse getTeams recips 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 ibiids <- insertMany $ replicate (length ibids) $ InboxItem True
insertMany_ $ insertMany_ $ zipWith makeInboxItem ibids ibiids
map (\ (ibid, ibiid) -> InboxItemLocal ibid obiid ibiid)
(zip ibids ibiids)
return remotesFollowers return remotesFollowers
where 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 :: LocalRecipientSet -> AppDB [InboxId]
getSharerInboxes sharers = do getSharerInboxes sharers = do
let shrs = let shrs =
@ -801,7 +833,7 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do
[shr | (shr, s) <- sharers [shr | (shr, s) <- sharers
, let d = localRecipSharerDirect s , let d = localRecipSharerDirect s
in localRecipSharerFollowers d && in localRecipSharerFollowers d &&
(localRecipSharer d || not requireOwner || LocalActorSharer shr == author) (localRecipSharer d || not requireOwner || isAuthor (LocalActorSharer shr))
] ]
sids <- selectKeysList [SharerIdent <-. shrs] [] sids <- selectKeysList [SharerIdent <-. shrs] []
map (personFollowers . entityVal) <$> selectList [PersonIdent <-. sids] [] map (personFollowers . entityVal) <$> selectList [PersonIdent <-. sids] []
@ -838,7 +870,7 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do
[prj | (prj, j) <- projects [prj | (prj, j) <- projects
, let d = localRecipProjectDirect j , let d = localRecipProjectDirect j
in localRecipProjectFollowers d && in localRecipProjectFollowers d &&
(localRecipProject d || not requireOwner || LocalActorProject shr prj == author) (localRecipProject d || not requireOwner || isAuthor (LocalActorProject shr prj))
] ]
fsidsJ <- fsidsJ <-
map (projectFollowers . entityVal) <$> map (projectFollowers . entityVal) <$>
@ -848,7 +880,7 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do
then then
[ (prj, localRecipProjectTicketRelated j) [ (prj, localRecipProjectTicketRelated j)
| (prj, j) <- projects | (prj, j) <- projects
, localRecipProject (localRecipProjectDirect j) || LocalActorProject shr prj == author , localRecipProject (localRecipProjectDirect j) || isAuthor (LocalActorProject shr prj)
] ]
else else
map (second localRecipProjectTicketRelated) projects map (second localRecipProjectTicketRelated) projects
@ -882,7 +914,7 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do
[rp | (rp, r) <- repos [rp | (rp, r) <- repos
, let d = localRecipRepoDirect r , let d = localRecipRepoDirect r
in localRecipRepoFollowers d && in localRecipRepoFollowers d &&
(localRecipRepo d || not requireOwner || LocalActorRepo shr rp == author) (localRecipRepo d || not requireOwner || isAuthor (LocalActorRepo shr rp))
] ]
in map (repoFollowers . entityVal) <$> in map (repoFollowers . entityVal) <$>
selectList [RepoSharer ==. sid, RepoIdent <-. rps] [] selectList [RepoSharer ==. sid, RepoIdent <-. rps] []
@ -935,7 +967,7 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do
getProjectTeams sid projects = do getProjectTeams sid projects = do
let prjs = let prjs =
[prj | (prj, LocalProjectRelatedSet d ts) <- projects [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) (localRecipProjectTeam d || any (localRecipTicketTeam . snd) ts)
] ]
jids <- selectKeysList [ProjectSharer ==. sid, ProjectIdent <-. prjs] [] jids <- selectKeysList [ProjectSharer ==. sid, ProjectIdent <-. prjs] []
@ -946,8 +978,36 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do
[rp | (rp, r) <- repos [rp | (rp, r) <- repos
, let d = localRecipRepoDirect r , let d = localRecipRepoDirect r
in localRecipRepoTeam d && 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] [] rids <- selectKeysList [RepoSharer ==. sid, RepoIdent <-. rps] []
pids <- map (repoCollabPerson . entityVal) <$> selectList [RepoCollabRepo <-. rids] [] pids <- map (repoCollabPerson . entityVal) <$> selectList [RepoCollabRepo <-. rids] []
map (personInbox . entityVal) <$> selectList [PersonId <-. pids] [Asc PersonInbox] 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

View file

@ -27,6 +27,7 @@ import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Data.Bifunctor import Data.Bifunctor
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Either
import Data.Foldable import Data.Foldable
import Data.Function import Data.Function
import Data.List (sort, deleteBy, nub, union, unionBy, partition) import Data.List (sort, deleteBy, nub, union, unionBy, partition)
@ -55,6 +56,7 @@ import Web.ActivityPub
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids import Yesod.Hashids
import Yesod.MonadSite
import Control.Monad.Trans.Except.Local import Control.Monad.Trans.Except.Local
import Data.Tuple.Local import Data.Tuple.Local
@ -69,6 +71,7 @@ import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
import Vervis.Settings import Vervis.Settings
import Vervis.Ticket
sharerCreateNoteF sharerCreateNoteF
:: UTCTime :: UTCTime
@ -101,20 +104,19 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext
Right _ -> Right _ ->
Right <$> insertToInbox luCreate (personInbox personRecip) Right <$> insertToInbox luCreate (personInbox personRecip)
where where
checkContextParent context mparent = runExceptT $ do checkContextParent (Left context) mparent = runExceptT $ do
did <-
case context of case context of
Left (shr, prj, ltkhid) -> do NoteContextSharerTicket shr talid -> do
mdid <- lift $ runMaybeT $ do (_, Entity _ lt, _, project) <- do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr mticket <- lift $ getSharerTicket shr talid
jid <- MaybeT $ getKeyBy $ UniqueProject prj sid fromMaybeE mticket "Note context no such local sharer-hosted ticket"
ltid <- decodeKeyHashidM ltkhid return $ localTicketDiscuss lt
lt <- MaybeT $ get ltid NoteContextProjectTicket shr prj ltid -> do
tpl <- (_, _, _, Entity _ lt, _, _) <- do
MaybeT $ getValBy $ mticket <- lift $ getProjectTicket shr prj ltid
UniqueTicketProjectLocal $ localTicketTicket lt fromMaybeE mticket "Note context no such local project-hosted ticket"
guard $ ticketProjectLocalProject tpl == jid
return $ localTicketDiscuss lt return $ localTicketDiscuss lt
did <- fromMaybeE mdid "Context: No such local ticket"
for_ mparent $ \ parent -> for_ mparent $ \ parent ->
case parent of case parent of
Left (shrP, lmidP) -> Left (shrP, lmidP) ->
@ -129,7 +131,7 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext
m <- lift $ getJust mid m <- lift $ getJust mid
unless (messageRoot m == did) $ unless (messageRoot m == did) $
throwE "Remote parent belongs to a different discussion" throwE "Remote parent belongs to a different discussion"
Right (ObjURI hContext luContext) -> do checkContextParent (Right (ObjURI hContext luContext)) mparent = runExceptT $ do
mdid <- lift $ runMaybeT $ do mdid <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hContext iid <- MaybeT $ getKeyBy $ UniqueInstance hContext
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luContext roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luContext
@ -167,12 +169,6 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext
return $ "Activity already exists in inbox of /s/" <> recip return $ "Activity already exists in inbox of /s/" <> recip
Just _ -> return $ "Activity inserted to inbox of /s/" <> recip Just _ -> return $ "Activity inserted to inbox of /s/" <> recip
data CreateNoteRecipColl
= CreateNoteRecipProjectFollowers
| CreateNoteRecipTicketParticipants
| CreateNoteRecipTicketTeam
deriving Eq
projectCreateNoteF projectCreateNoteF
:: UTCTime :: UTCTime
-> ShrIdent -> ShrIdent
@ -195,68 +191,109 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
if uParent == uContext if uParent == uContext
then return Nothing then return Nothing
else Just <$> parseParent uParent else Just <$> parseParent uParent
case context of (localRecips, _remoteRecips) <- do
Right _ -> return $ recip <> " not using; context isn't local" mrecips <- parseAudience $ activityAudience $ actbActivity body
Left (shr, prj, ltkhid) -> fromMaybeE mrecips "Create Note with no recipients"
if shr /= shrRecip || prj /= prjRecip
then return $ recip <> " not using; context is a different project"
else do
msig <- checkForward shrRecip prjRecip msig <- checkForward shrRecip prjRecip
hLocal <- getsYesod $ appInstanceHost . appSettings case context of
let colls = Right _ -> return "Not using; context isn't local"
findRelevantCollections hLocal ltkhid $ Left (NoteContextSharerTicket shr talid) -> do
activityAudience $ actbActivity body
mremotesHttp <- runDBExcept $ do mremotesHttp <- runDBExcept $ do
(sid, fsidProject, fsidTicket, jid, ibid, did, meparent) <- getContextAndParent ltkhid mparent (jid, ibid) <- lift getProjectRecip404
lift $ join <$> do (_, _, _, project) <- do
mmid <- insertToDiscussion luCreate luNote published ibid did meparent fsidTicket mticket <- lift $ getSharerTicket shr talid
for mmid $ \ (ractid, mid) -> do fromMaybeE mticket "Context: No such sharer-ticket"
updateOrphans luNote did mid case project of
for msig $ \ sig -> do Left (Entity _ tpl)
remoteRecips <- deliverLocal ractid colls sid fsidProject fsidTicket | 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 (sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips
lift $ for_ mremotesHttp $ \ (sig, remotesHttp) -> do _ -> return $ Left "Context is a sharer-ticket of another project"
let handler e = logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e) case mremotesHttp of
forkHandler handler $ Left msg -> return msg
deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp Right (sig, remotesHttp) -> do
return $ recip <> " inserted new ticket comment" forkWorker "projectCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp
where return "Stored to inbox and did inbox forwarding"
findRelevantCollections hLocal ctx = nub . mapMaybe decide . concatRecipients Left (NoteContextProjectTicket shr prj ltid) -> do
where mremotesHttp <- runDBExcept $ do
decide u = do (jid, ibid) <- lift getProjectRecip404
let ObjURI h lu = u (_, _, _, Entity _ lt, Entity _ tpl, _) <- do
guard $ h == hLocal mticket <- lift $ getProjectTicket shr prj ltid
route <- decodeRouteLocal lu fromMaybeE mticket "Context: No such project-ticket"
case route of if ticketProjectLocalProject tpl == jid
ProjectFollowersR shr prj then do
| shr == shrRecip && prj == prjRecip mractid <- lift $ insertToProjectInbox ibid luCreate
-> Just CreateNoteRecipProjectFollowers case mractid of
ProjectTicketParticipantsR shr prj tkhid Nothing -> return $ Left "Activity already in my inbox"
| shr == shrRecip && prj == prjRecip && tkhid == ctx Just ractid -> do
-> 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 let did = localTicketDiscuss lt
meparent <- for mparent $ \ parent -> meparent <- traverse (getParent did) mparent
case parent of mmid <- lift $ insertToDiscussion luNote published did meparent ractid
Left (shrParent, lmidParent) -> Left <$> getLocalParentMessageId did shrParent lmidParent case mmid of
Right p@(ObjURI hParent luParent) -> do 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
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 mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
@ -269,17 +306,9 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
throwE "Remote parent belongs to a different discussion" throwE "Remote parent belongs to a different discussion"
return mid return mid
Nothing -> return $ Right p Nothing -> return $ Right p
return (sid, fsidProject, localTicketFollowers lt, jid, ibid, did, meparent) insertToDiscussion luNote published did meparent ractid = do
insertToDiscussion luCreate luNote published ibid did meparent fsid = do
let iidAuthor = remoteAuthorInstance author let iidAuthor = remoteAuthorInstance author
raidAuthor = remoteAuthorId author raidAuthor = remoteAuthorId author
roid <-
either entityKey id <$> insertBy' (RemoteObject iidAuthor luCreate)
ractid <- either entityKey id <$> insertBy' RemoteActivity
{ remoteActivityIdent = roid
, remoteActivityContent = persistJSONFromBL $ actbBL body
, remoteActivityReceived = now
}
mid <- insert Message mid <- insert Message
{ messageCreated = published { messageCreated = published
, messageSource = src , messageSource = src
@ -290,11 +319,11 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
_ -> Nothing _ -> Nothing
, messageRoot = did , messageRoot = did
} }
roid2 <- roidNote <-
either entityKey id <$> insertBy' (RemoteObject iidAuthor luNote) either entityKey id <$> insertBy' (RemoteObject iidAuthor luNote)
mrmid <- insertUnique RemoteMessage mrmid <- insertUnique RemoteMessage
{ remoteMessageAuthor = raidAuthor { remoteMessageAuthor = raidAuthor
, remoteMessageIdent = roid2 , remoteMessageIdent = roidNote
, remoteMessageRest = mid , remoteMessageRest = mid
, remoteMessageCreate = ractid , remoteMessageCreate = ractid
, remoteMessageLostParent = , remoteMessageLostParent =
@ -306,11 +335,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
Nothing -> do Nothing -> do
delete mid delete mid
return Nothing return Nothing
Just _ -> do Just _ -> return $ Just mid
-- insertUnique_ $ RemoteFollow raidAuthor fsid False True
ibiid <- insert $ InboxItem False
insert_ $ InboxItemRemote ibid ractid ibiid
return $ Just (ractid, mid)
updateOrphans luNote did mid = do updateOrphans luNote did mid = do
let hAuthor = objUriAuthority $ remoteAuthorURI author let hAuthor = objUriAuthority $ remoteAuthorURI author
uNote = ObjURI hAuthor luNote 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.&&. rm E.^. RemoteMessageLostParent E.==. E.just (E.val uNote) E.&&.
m E.^. MessageRoot `op` E.val did m E.^. MessageRoot `op` E.val did
return (rm E.^. RemoteMessageId, m E.^. MessageId) 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