S2S: sharerCreateNoteF & projectCreateNoteF can handle sharer-hosted tickets
This commit is contained in:
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"
|
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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
|
||||||
|
|
Loading…
Reference in a new issue