S2S: sharerCreateNoteF caches note and does inbox fwd if sharer is ticket owner

This commit is contained in:
fr33domlover 2020-05-13 13:06:28 +00:00
parent c91908941b
commit 43cd1a95f3
10 changed files with 469 additions and 228 deletions

View file

@ -115,12 +115,23 @@ Forwarding
recipient RemoteActorId recipient RemoteActorId
activity RemoteActivityId activity RemoteActivityId
activityRaw ByteString activityRaw ByteString
sender ProjectId
signature ByteString signature ByteString
running Bool running Bool
UniqueForwarding recipient activity UniqueForwarding recipient activity
ForwarderSharer
task ForwardingId
sender SharerId
UniqueForwarderSharer task
ForwarderProject
task ForwardingId
sender ProjectId
UniqueForwarderProject task
VerifKey VerifKey
ident LocalRefURI ident LocalRefURI
instance InstanceId instance InstanceId

View file

@ -0,0 +1,11 @@
ForwarderSharer
task ForwardingId
sender SharerId
UniqueForwarderSharer task
ForwarderProject
task ForwardingId
sender ProjectId
UniqueForwarderProject task

View file

@ -0,0 +1,21 @@
RemoteActor
RemoteActivity
Project
Forwarding
recipient RemoteActorId
activity RemoteActivityId
activityRaw ByteString
sender ProjectId
signature ByteString
running Bool
UniqueForwarding recipient activity
ForwarderProject
task ForwardingId
sender ProjectId
UniqueForwarderProject task

View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
- -
- Copying is an act of love. Please copy, reuse and share. - Copying is an act of love. Please copy, reuse and share.
- -
@ -16,8 +16,10 @@
module Data.Tuple.Local module Data.Tuple.Local
( fst3 ( fst3
, fst4 , fst4
, fst5
, thd3 , thd3
, fourth4 , fourth4
, fourth5
) )
where where
@ -27,8 +29,14 @@ fst3 (x, _, _) = x
fst4 :: (a, b, c, d) -> a fst4 :: (a, b, c, d) -> a
fst4 (x, _, _, _) = x fst4 (x, _, _, _) = x
fst5 :: (a, b, c, d, e) -> a
fst5 (x, _, _, _, _) = x
thd3 :: (a, b, c) -> c thd3 :: (a, b, c) -> c
thd3 (_, _, z) = z thd3 (_, _, z) = z
fourth4 :: (a, b, c, d) -> d fourth4 :: (a, b, c, d) -> d
fourth4 (_, _, _, w) = w fourth4 (_, _, _, w) = w
fourth5 :: (a, b, c, d, e) -> d
fourth5 (_, _, _, w, _) = w

View file

@ -32,8 +32,10 @@ module Vervis.ActivityPub
, isInstanceErrorG , isInstanceErrorG
, deliverHttp , deliverHttp
, deliverHttpBL , deliverHttpBL
, deliverRemoteDB , deliverRemoteDB_J
, deliverRemoteHTTP , deliverRemoteDB_S
, deliverRemoteHTTP_J
, deliverRemoteHTTP_S
, checkForward , checkForward
, parseTarget , parseTarget
--, checkDep --, checkDep
@ -59,6 +61,7 @@ import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
import Data.Bifunctor import Data.Bifunctor
import Data.Bitraversable
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Either import Data.Either
import Data.Foldable import Data.Foldable
@ -312,45 +315,67 @@ deliverHttpBL
deliverHttpBL body mfwd h luInbox = deliverHttpBL body mfwd h luInbox =
deliverActivityBL' (ObjURI h luInbox) (ObjURI h <$> mfwd) body deliverActivityBL' (ObjURI h luInbox) (ObjURI h <$> mfwd) body
deliverRemoteDB deliverRemoteDB_
:: PersistRecordBackend fwder SqlBackend
=> (ForwardingId -> Key sender -> fwder)
-> BL.ByteString
-> RemoteActivityId
-> Key sender
-> ByteString
-> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> AppDB
[((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))]
deliverRemoteDB_ makeFwder body ractid senderKey sig recips = do
let body' = BL.toStrict body
makeFwd (RemoteRecipient raid _ _ msince) =
Forwarding raid ractid body' sig (isNothing msince)
fetchedDeliv <- for recips $ bitraverse pure $ \ rs -> do
fwds <- insertMany' makeFwd rs
insertMany' (flip makeFwder senderKey . snd) fwds
return $ takeNoError5 fetchedDeliv
where
takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
takeNoError5 = takeNoError noError
where
noError ((RemoteRecipient ak luA luI Nothing , fwid), fwrid) = Just (ak, luA, luI, fwid, fwrid)
noError ((RemoteRecipient _ _ _ (Just _), _ ), _ ) = Nothing
deliverRemoteDB_J
:: BL.ByteString :: BL.ByteString
-> RemoteActivityId -> RemoteActivityId
-> ProjectId -> ProjectId
-> ByteString -> ByteString
-> [((InstanceId, Host), NonEmpty RemoteRecipient)] -> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> AppDB -> AppDB
[((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))] [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderProjectId))]
deliverRemoteDB body ractid jid sig recips = do deliverRemoteDB_J = deliverRemoteDB_ ForwarderProject
let body' = BL.toStrict body
deliv raid msince = Forwarding raid ractid body' jid sig $ isNothing msince
fetchedDeliv <- for recips $ \ (i, rs) ->
(i,) <$> insertMany' (\ (RemoteRecipient raid _ _ msince) -> deliv raid msince) rs
return $ takeNoError4 fetchedDeliv
where
takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
takeNoError4 = takeNoError noError
where
noError (RemoteRecipient ak luA luI Nothing , dlk) = Just (ak, luA, luI, dlk)
noError (RemoteRecipient _ _ _ (Just _), _ ) = Nothing
deliverRemoteHTTP deliverRemoteDB_S
:: (MonadSite m, SiteEnv m ~ App) :: BL.ByteString
-> RemoteActivityId
-> SharerId
-> ByteString
-> [((InstanceId, Host), NonEmpty RemoteRecipient)]
-> AppDB
[((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderSharerId))]
deliverRemoteDB_S = deliverRemoteDB_ ForwarderSharer
deliverRemoteHTTP'
:: (MonadSite m, SiteEnv m ~ App, PersistRecordBackend fwder SqlBackend)
=> UTCTime => UTCTime
-> ShrIdent -> LocalActor
-> PrjIdent
-> BL.ByteString -> BL.ByteString
-> ByteString -> ByteString
-> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))] -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))]
-> m () -> m ()
deliverRemoteHTTP now shrRecip prjRecip body sig fetched = do deliverRemoteHTTP' now sender body sig fetched = do
let deliver h inbox = let deliver h inbox =
let sender = ProjectR shrRecip prjRecip forwardActivity (ObjURI h inbox) sig (renderLocalActor sender) body
in forwardActivity (ObjURI h inbox) sig sender body
traverse_ (fork . deliverFetched deliver now) fetched traverse_ (fork . deliverFetched deliver now) fetched
where where
fork = forkWorker "Inbox forwarding to remote members of local collections: delivery failed" fork = forkWorker "Inbox forwarding to remote members of local collections: delivery failed"
deliverFetched deliver now ((_, h), recips@(r :| rs)) = do deliverFetched deliver now ((_, h), recips@(r :| rs)) = do
let (raid, _luActor, luInbox, fwid) = r let (raid, _luActor, luInbox, fwid, forwarderKey) = r
e <- deliver h luInbox e <- deliver h luInbox
let e' = case e of let e' = case e of
Left err -> Left err ->
@ -361,16 +386,18 @@ deliverRemoteHTTP now shrRecip prjRecip body sig fetched = do
case e' of case e' of
Nothing -> runSiteDB $ do Nothing -> runSiteDB $ do
let recips' = NE.toList recips let recips' = NE.toList recips
updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] updateWhere [RemoteActorId <-. map fst5 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
updateWhere [ForwardingId <-. map fourth4 recips'] [ForwardingRunning =. False] updateWhere [ForwardingId <-. map fourth5 recips'] [ForwardingRunning =. False]
Just success -> do Just success -> do
runSiteDB $ runSiteDB $
if success if success
then delete fwid then do
delete forwarderKey
delete fwid
else do else do
updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
update fwid [ForwardingRunning =. False] update fwid [ForwardingRunning =. False]
for_ rs $ \ (raid, _luActor, luInbox, fwid) -> for_ rs $ \ (raid, _luActor, luInbox, fwid, forwarderKey) ->
fork $ do fork $ do
e <- deliver h luInbox e <- deliver h luInbox
runSiteDB $ runSiteDB $
@ -378,9 +405,33 @@ deliverRemoteHTTP now shrRecip prjRecip body sig fetched = do
Left _err -> do Left _err -> do
updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
update fwid [ForwardingRunning =. False] update fwid [ForwardingRunning =. False]
Right _resp -> delete fwid Right _resp -> do
delete forwarderKey
delete fwid
checkForward shrRecip prjRecip = join <$> do deliverRemoteHTTP_J
:: (MonadSite m, SiteEnv m ~ App)
=> UTCTime
-> ShrIdent
-> PrjIdent
-> BL.ByteString
-> ByteString
-> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderProjectId))]
-> m ()
deliverRemoteHTTP_J now shr prj =
deliverRemoteHTTP' now $ LocalActorProject shr prj
deliverRemoteHTTP_S
:: (MonadSite m, SiteEnv m ~ App)
=> UTCTime
-> ShrIdent
-> BL.ByteString
-> ByteString
-> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, ForwarderSharerId))]
-> m ()
deliverRemoteHTTP_S now shr = deliverRemoteHTTP' now $ LocalActorSharer shr
checkForward recip = join <$> do
let hSig = hForwardingSignature let hSig = hForwardingSignature
msig <- maybeHeader hSig msig <- maybeHeader hSig
for msig $ \ sig -> do for msig $ \ sig -> do
@ -389,9 +440,8 @@ checkForward shrRecip prjRecip = join <$> do
in prepareToVerifyHttpSigWith hSig False requires [] Nothing in prepareToVerifyHttpSigWith hSig False requires [] Nothing
forwarder <- requireHeader hActivityPubForwarder forwarder <- requireHeader hActivityPubForwarder
renderUrl <- getUrlRender renderUrl <- getUrlRender
let project = renderUrl $ ProjectR shrRecip prjRecip
return $ return $
if forwarder == encodeUtf8 project if forwarder == encodeUtf8 (renderUrl $ renderLocalActor recip)
then Just sig then Just sig
else Nothing else Nothing
where where

View file

@ -373,6 +373,14 @@ fixRunningDeliveries = do
, " forwarding deliveries" , " forwarding deliveries"
] ]
data Fwder = FwderProject ForwarderProjectId | FwderSharer ForwarderSharerId
partitionFwders :: [Fwder] -> ([ForwarderProjectId], [ForwarderSharerId])
partitionFwders = foldl' f ([], [])
where
f (js, ss) (FwderProject j) = (j : js, ss)
f (js, ss) (FwderSharer s) = (js , s : ss)
retryOutboxDelivery :: Worker () retryOutboxDelivery :: Worker ()
retryOutboxDelivery = do retryOutboxDelivery = do
logInfo "Periodic delivery starting" logInfo "Periodic delivery starting"
@ -440,9 +448,14 @@ retryOutboxDelivery = do
let (linkedOld, linkedNew) = partitionEithers $ map (decideBySinceDL dropAfter now . adaptLinked) linked let (linkedOld, linkedNew) = partitionEithers $ map (decideBySinceDL dropAfter now . adaptLinked) linked
deleteWhere [DeliveryId <-. linkedOld] deleteWhere [DeliveryId <-. linkedOld]
-- Same for forwarding deliveries, which are always linked -- Same for forwarding deliveries, which are always linked
forwarding <- E.select $ E.from $ \ (fw `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i `E.InnerJoin` j `E.InnerJoin` s) -> do forwarding <- E.select $ E.from $ \ (fw `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i `E.LeftOuterJoin` (fwj `E.InnerJoin` j `E.InnerJoin` s) `E.LeftOuterJoin` (fws `E.InnerJoin` s2)) -> do
E.on $ j E.^. ProjectSharer E.==. s E.^. SharerId E.on $ fws E.?. ForwarderSharerSender E.==. s2 E.?. SharerId
E.on $ fw E.^. ForwardingSender E.==. j E.^. ProjectId E.on $ E.just (fw E.^. ForwardingId) E.==. fws E.?. ForwarderSharerTask
E.on $ j E.?. ProjectSharer E.==. s E.?. SharerId
E.on $ fwj E.?. ForwarderProjectSender E.==. j E.?. ProjectId
E.on $ E.just (fw E.^. ForwardingId) E.==. fwj E.?. ForwarderProjectTask
E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
E.on $ fw E.^. ForwardingRecipient E.==. ra E.^. RemoteActorId E.on $ fw E.^. ForwardingRecipient E.==. ra E.^. RemoteActorId
@ -456,12 +469,22 @@ retryOutboxDelivery = do
, ra E.^. RemoteActorErrorSince , ra E.^. RemoteActorErrorSince
, fw E.^. ForwardingId , fw E.^. ForwardingId
, fw E.^. ForwardingActivityRaw , fw E.^. ForwardingActivityRaw
, j E.^. ProjectIdent
, s E.^. SharerIdent , fwj E.?. ForwarderProjectId
, s E.?. SharerIdent
, j E.?. ProjectIdent
, fws E.?. ForwarderSharerId
, s2 E.?. SharerIdent
, fw E.^. ForwardingSignature , fw E.^. ForwardingSignature
) )
let (forwardingOld, forwardingNew) = partitionEithers $ map (decideBySinceFW dropAfter now . adaptForwarding) forwarding let (forwardingOld, forwardingNew) = partitionEithers $ map (decideBySinceFW dropAfter now . adaptForwarding) forwarding
deleteWhere [ForwardingId <-. forwardingOld] (fwidsOld, fwdersOld) = unzip forwardingOld
(fwjidsOld, fwsidsOld) = partitionFwders fwdersOld
deleteWhere [ForwarderProjectId <-. fwjidsOld]
deleteWhere [ForwarderSharerId <-. fwsidsOld]
deleteWhere [ForwardingId <-. fwidsOld]
return (groupUnlinked lonelyNew, groupLinked linkedNew, groupForwarding forwardingNew) return (groupUnlinked lonelyNew, groupLinked linkedNew, groupForwarding forwardingNew)
let deliver = deliverHttpBL let deliver = deliverHttpBL
logInfo "Periodic delivery prepared DB, starting async HTTP POSTs" logInfo "Periodic delivery prepared DB, starting async HTTP POSTs"
@ -548,19 +571,44 @@ retryOutboxDelivery = do
= map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd) = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd)
. groupWithExtractBy ((==) `on` fst) fst snd . groupWithExtractBy ((==) `on` fst) fst snd
adaptForwarding adaptForwarding
(E.Value iid, E.Value h, E.Value raid, E.Value inbox, E.Value since, E.Value fwid, E.Value body, E.Value prj, E.Value shr, E.Value sig) = ( E.Value iid, E.Value h, E.Value raid, E.Value inbox, E.Value since
, E.Value fwid, E.Value body
, E.Value mfwjid, E.Value mprj, E.Value mshr
, E.Value mfwsid, E.Value mshr2
, E.Value sig
) =
( ( (iid, h) ( ( (iid, h)
, ((raid, inbox), (fwid, BL.fromStrict body, ProjectR shr prj, sig)) , ( (raid, inbox)
, ( fwid
, BL.fromStrict body
, let project = together3 mfwjid mprj mshr
sharer = together2 mfwsid mshr2
in case (project, sharer) of
(Just (fwjid, shr, prj), Nothing) ->
(FwderProject fwjid, ProjectR shr prj)
(Nothing, Just (fwsid, shr)) ->
(FwderSharer fwsid, SharerR shr)
_ -> error $ "Non-single fwder for fw#" ++ show fwid
, sig
)
)
) )
, since , since
) )
decideBySinceFW dropAfter now (fw@(_, (_, (fwid, _, _, _))), msince) = where
together2 (Just x) (Just y) = Just (x, y)
together2 Nothing Nothing = Nothing
together2 _ _ = error $ "Got weird forwarder for fw#" ++ show fwid
together3 (Just x) (Just y) (Just z) = Just (x, y, z)
together3 Nothing Nothing Nothing = Nothing
together3 _ _ _ = error $ "Got weird forwarder for fw#" ++ show fwid
decideBySinceFW dropAfter now (fw@(_, (_, (fwid, _, (fwder, _), _))), msince) =
case msince of case msince of
Nothing -> Right fw Nothing -> Right fw
Just since -> Just since ->
if relevant dropAfter now since if relevant dropAfter now since
then Right fw then Right fw
else Left fwid else Left (fwid, fwder)
groupForwarding groupForwarding
= map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd) = map (second $ groupWithExtractBy1 ((==) `on` fst) fst snd)
. groupWithExtractBy ((==) `on` fst) fst snd . groupWithExtractBy ((==) `on` fst) fst snd
@ -648,12 +696,16 @@ retryOutboxDelivery = do
logDebug $ logDebug $
"Periodic deliver starting forwarding for inbox " <> "Periodic deliver starting forwarding for inbox " <>
renderObjURI (ObjURI h inbox) renderObjURI (ObjURI h inbox)
waitsD <- for delivs $ \ (fwid, body, sender, sig) -> fork $ do waitsD <- for delivs $ \ (fwid, body, (fwder, sender), sig) -> fork $ do
e <- forwardActivity (ObjURI h inbox) sig sender body e <- forwardActivity (ObjURI h inbox) sig sender body
case e of case e of
Left _err -> return False Left _err -> return False
Right _resp -> do Right _resp -> do
runSiteDB $ delete fwid runSiteDB $ do
case fwder of
FwderProject k -> delete k
FwderSharer k -> delete k
delete fwid
return True return True
results <- sequence waitsD results <- sequence waitsD
runSiteDB $ runSiteDB $

View file

@ -73,113 +73,18 @@ import Vervis.Model.Ident
import Vervis.Settings import Vervis.Settings
import Vervis.Ticket import Vervis.Ticket
sharerCreateNoteF -- | Check the note in the remote Create Note activity delivered to us.
:: UTCTime checkNote
-> ShrIdent :: Note URIMode
-> RemoteAuthor -> ExceptT Text Handler
-> ActivityBody ( LocalURI
-> Note URIMode , UTCTime
-> ExceptT Text Handler Text , Either NoteContext FedURI
sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext mpublished _ _) = do , Maybe (Either (ShrIdent, LocalMessageId) FedURI)
luCreate <- , Text
fromMaybeE (activityId $ actbActivity body) "Create without 'id'" , Text
_luNote <- fromMaybeE mluNote "Note without note id" )
_published <- fromMaybeE mpublished "Note without 'published' field" checkNote (Note mluNote _ _ muParent muCtx mpub source content) = do
uContext <- fromMaybeE muContext "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
ExceptT $ runDB $ do
personRecip <- do
sid <- getKeyBy404 $ UniqueSharer shrRecip
getValBy404 $ UniquePersonIdent sid
valid <- checkContextParent context mparent
case valid of
Left e -> return $ Left e
Right _ ->
Right <$> insertToInbox luCreate (personInbox personRecip)
where
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
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 <-
either entityKey id <$> insertBy' (RemoteObject iidAuthor luCreate)
let jsonObj = persistJSONFromBL $ actbBL body
ract = RemoteActivity roid jsonObj now
ractid <- either entityKey id <$> insertBy' ract
ibiid <- insert $ InboxItem True
mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
let recip = shr2text shrRecip
case mibrid of
Nothing -> do
delete ibiid
return $ "Activity already exists in inbox of /s/" <> recip
Just _ -> return $ "Activity inserted to inbox of /s/" <> recip
projectCreateNoteF
:: UTCTime
-> ShrIdent
-> PrjIdent
-> RemoteAuthor
-> ActivityBody
-> Note URIMode
-> ExceptT Text Handler Text
projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent muCtx mpub src content) = do
luCreate <-
fromMaybeE (activityId $ actbActivity body) "Create without 'id'"
luNote <- fromMaybeE mluNote "Note without note id" luNote <- fromMaybeE mluNote "Note without note id"
published <- fromMaybeE mpub "Note without 'published' field" published <- fromMaybeE mpub "Note without 'published' field"
uContext <- fromMaybeE muCtx "Note without context" uContext <- fromMaybeE muCtx "Note without context"
@ -191,93 +96,19 @@ 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
(localRecips, _remoteRecips) <- do return (luNote, published, context, mparent, source, content)
mrecips <- parseAudience $ activityAudience $ actbActivity body
fromMaybeE mrecips "Create Note with no recipients" -- | Insert a remote activity delivered to us into our inbox. Return its
msig <- checkForward shrRecip prjRecip -- database ID if the activity wasn't already in our inbox.
case context of insertToInbox
Right _ -> return "Not using; context isn't local" :: UTCTime
Left (NoteContextSharerTicket shr talid) -> do -> RemoteAuthor
mremotesHttp <- runDBExcept $ do -> ActivityBody
(jid, ibid) <- lift getProjectRecip404 -> InboxId
(_, _, _, project) <- do -> LocalURI
mticket <- lift $ getSharerTicket shr talid -> Bool
fromMaybeE mticket "Context: No such sharer-ticket" -> AppDB (Maybe RemoteActivityId)
case project of insertToInbox now author body ibid luCreate unread = do
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
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 let iidAuthor = remoteAuthorInstance author
roid <- roid <-
either entityKey id <$> insertBy' (RemoteObject iidAuthor luCreate) either entityKey id <$> insertBy' (RemoteObject iidAuthor luCreate)
@ -286,14 +117,22 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
, remoteActivityContent = persistJSONFromBL $ actbBL body , remoteActivityContent = persistJSONFromBL $ actbBL body
, remoteActivityReceived = now , remoteActivityReceived = now
} }
ibiid <- insert $ InboxItem False ibiid <- insert $ InboxItem unread
new <- isRight <$> insertBy' (InboxItemRemote ibid ractid ibiid) new <- isRight <$> insertBy' (InboxItemRemote ibid ractid ibiid)
return $ return $
if new if new
then Just ractid then Just ractid
else Nothing else Nothing
getParent did (Left (shrParent, lmidParent)) = Left <$> getLocalParentMessageId did shrParent lmidParent
getParent did (Right p@(ObjURI hParent luParent)) = do -- | Given the parent specified by the Note we received, check if we already
-- know and have this parent note in the DB, and whether the child and parent
-- belong to the same discussion root.
getParent
:: DiscussionId
-> Either (ShrIdent, LocalMessageId) FedURI
-> ExceptT Text AppDB (Either MessageId FedURI)
getParent did (Left (shr, lmid)) = Left <$> getLocalParentMessageId did shr lmid
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
@ -306,12 +145,26 @@ 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
insertToDiscussion luNote published did meparent ractid = do
-- | Insert the new remote comment into the discussion tree. If we didn't have
-- this comment before, return the database ID of the newly created cached
-- comment.
insertToDiscussion
:: RemoteAuthor
-> LocalURI
-> UTCTime
-> Text
-> Text
-> DiscussionId
-> Maybe (Either MessageId FedURI)
-> RemoteActivityId
-> AppDB (Maybe MessageId)
insertToDiscussion author luNote published source content did meparent ractid = do
let iidAuthor = remoteAuthorInstance author let iidAuthor = remoteAuthorInstance author
raidAuthor = remoteAuthorId author raidAuthor = remoteAuthorId author
mid <- insert Message mid <- insert Message
{ messageCreated = published { messageCreated = published
, messageSource = src , messageSource = source
, messageContent = content , messageContent = content
, messageParent = , messageParent =
case meparent of case meparent of
@ -336,7 +189,17 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
delete mid delete mid
return Nothing return Nothing
Just _ -> return $ Just mid Just _ -> return $ Just mid
updateOrphans luNote did mid = do
-- | Look for known remote comments in the database, whose parent was unknown
-- but turns out to be the new comment we just received. Fix that in the
-- database and log warnings about it.
updateOrphans
:: RemoteAuthor
-> LocalURI
-> DiscussionId
-> MessageId
-> AppDB ()
updateOrphans author luNote did mid = do
let hAuthor = objUriAuthority $ remoteAuthorURI author let hAuthor = objUriAuthority $ remoteAuthorURI author
uNote = ObjURI hAuthor luNote uNote = ObjURI hAuthor luNote
related <- selectOrphans uNote (E.==.) related <- selectOrphans uNote (E.==.)
@ -366,3 +229,208 @@ 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)
sharerCreateNoteF
:: UTCTime
-> ShrIdent
-> RemoteAuthor
-> ActivityBody
-> Note URIMode
-> ExceptT Text Handler Text
sharerCreateNoteF now shrRecip author body note = do
luCreate <-
fromMaybeE (activityId $ actbActivity body) "Create without 'id'"
(luNote, published, context, mparent, source, content) <- checkNote note
(localRecips, _remoteRecips) <- do
mrecips <- parseAudience $ activityAudience $ actbActivity body
fromMaybeE mrecips "Create Note with no recipients"
msig <- checkForward $ LocalActorSharer shrRecip
case context of
Right uContext -> runDBExcept $ do
personRecip <- lift $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip
getValBy404 $ UniquePersonIdent sid
checkContextParent uContext mparent
mractid <- lift $ insertToInbox now author body (personInbox personRecip) luCreate True
return $
case mractid of
Nothing -> "I already have this activity in my inbox, doing nothing"
Just _ -> "Context is remote, so just inserting to my inbox"
Left (NoteContextSharerTicket shr talid) -> do
mremotesHttp <- runDBExcept $ do
(sid, pid, ibid) <- lift getRecip404
(Entity _ tal, Entity _ lt, _, _) <- do
mticket <- lift $ getSharerTicket shr talid
fromMaybeE mticket "Context: No such sharer-ticket"
if ticketAuthorLocalAuthor tal == pid
then do
mractid <- lift $ insertToInbox now author body ibid luCreate True
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 author luNote published source content did meparent ractid
case mmid of
Nothing -> return $ Left "I already have this comment, just storing in inbox"
Just mid -> lift $ do
updateOrphans author luNote did mid
case msig of
Nothing ->
return $ Left "Storing in inbox, caching comment, no inbox forwarding header"
Just sig -> Right <$> do
talkhid <- encodeKeyHashid talid
let sieve =
makeRecipientSet
[]
[ LocalPersonCollectionSharerTicketFollowers shrRecip talkhid
, LocalPersonCollectionSharerTicketTeam shrRecip talkhid
]
remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips
(sig,) <$> deliverRemoteDB_S (actbBL body) ractid sid sig remoteRecips
else return $ Left "Context is a sharer-ticket of another sharer"
case mremotesHttp of
Left msg -> return msg
Right (sig, remotesHttp) -> do
forkWorker "sharerCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP_S now shrRecip (actbBL body) sig remotesHttp
return "Stored to inbox, cached comment, and did inbox forwarding"
Left (NoteContextProjectTicket shr prj ltid) -> runDBExcept $ do
personRecip <- lift $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip
getValBy404 $ UniquePersonIdent sid
(_, _, _, Entity _ lt, _, _) <- do
mticket <- lift $ getProjectTicket shr prj ltid
fromMaybeE mticket "Context: No such project-ticket"
let did = localTicketDiscuss lt
_ <- traverse (getParent did) mparent
mractid <- lift $ insertToInbox now author body (personInbox personRecip) luCreate True
return $
case mractid of
Nothing -> "I already have this activity in my inbox, doing nothing"
Just _ -> "Context is a project-ticket, so just inserting to my inbox"
where
getRecip404 = do
sid <- getKeyBy404 $ UniqueSharer shrRecip
Entity pid p <- getBy404 $ UniquePersonIdent sid
return (sid, pid, personInbox p)
checkContextParent (ObjURI hContext luContext) mparent = 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"
projectCreateNoteF
:: UTCTime
-> ShrIdent
-> PrjIdent
-> RemoteAuthor
-> ActivityBody
-> Note URIMode
-> ExceptT Text Handler Text
projectCreateNoteF now shrRecip prjRecip author body note = do
luCreate <-
fromMaybeE (activityId $ actbActivity body) "Create without 'id'"
(luNote, published, context, mparent, source, content) <- checkNote note
(localRecips, _remoteRecips) <- do
mrecips <- parseAudience $ activityAudience $ actbActivity body
fromMaybeE mrecips "Create Note with no recipients"
msig <- checkForward $ LocalActorProject shrRecip prjRecip
case context of
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 $ insertToInbox now author body ibid luCreate False
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_J (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_J 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 $ insertToInbox now author body ibid luCreate False
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 author luNote published source content did meparent ractid
case mmid of
Nothing -> return $ Left "I already have this comment, just storing in inbox"
Just mid -> lift $ do
updateOrphans author 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_J (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_J 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)

View file

@ -211,7 +211,7 @@ projectOfferTicketF
hLocal <- getsYesod siteInstanceHost hLocal <- getsYesod siteInstanceHost
{-deps <- -} {-deps <- -}
checkOffer ticket hLocal shrRecip prjRecip checkOffer ticket hLocal shrRecip prjRecip
msig <- checkForward shrRecip prjRecip msig <- checkForward $ LocalActorProject shrRecip prjRecip
let colls = let colls =
findRelevantCollections shrRecip prjRecip hLocal $ findRelevantCollections shrRecip prjRecip hLocal $
activityAudience $ actbActivity body activityAudience $ actbActivity body
@ -225,13 +225,13 @@ projectOfferTicketF
for mticket $ \ (ractid, obiidAccept, docAccept) -> do for mticket $ \ (ractid, obiidAccept, docAccept) -> do
msr <- for msig $ \ sig -> do msr <- for msig $ \ sig -> do
remoteRecips <- deliverFwdLocal ractid colls sid fsid remoteRecips <- deliverFwdLocal ractid colls sid fsid
(sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
return (msr, obiidAccept, docAccept) return (msr, obiidAccept, docAccept)
lift $ for_ mremotesHttp $ \ (msr, obiidAccept, docAccept) -> do lift $ for_ mremotesHttp $ \ (msr, obiidAccept, docAccept) -> do
let handler e = logError $ "Project Accept sender: delivery failed! " <> T.pack (displayException e) let handler e = logError $ "Project Accept sender: delivery failed! " <> T.pack (displayException e)
for msr $ \ (sig, remotesHttp) -> do for msr $ \ (sig, remotesHttp) -> do
forkHandler handler $ forkHandler handler $
deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotesHttp
forkHandler handler $ publishAccept luOffer obiidAccept docAccept forkHandler handler $ publishAccept luOffer obiidAccept docAccept
return $ recip <> " inserted new ticket" return $ recip <> " inserted new ticket"
where where
@ -541,7 +541,7 @@ projectCreateTicketF now shrRecip prjRecip author body ticket muTarget = do
case targetAndContext of case targetAndContext of
Left (_, shrContext, prjContext) Left (_, shrContext, prjContext)
| shrRecip == shrContext && prjRecip == prjContext -> do | shrRecip == shrContext && prjRecip == prjContext -> do
msig <- checkForward shrRecip prjRecip msig <- checkForward $ LocalActorProject shrRecip prjRecip
msgOrRecips <- lift $ runDB $ do msgOrRecips <- lift $ runDB $ do
(sidProject, jid, obidProject, ibidProject, fsidProject) <- getProject (sidProject, jid, obidProject, ibidProject, fsidProject) <- getProject
mractidCreate <- insertCreate luCreate ibidProject mractidCreate <- insertCreate luCreate ibidProject
@ -562,7 +562,7 @@ projectCreateTicketF now shrRecip prjRecip author body ticket muTarget = do
let colls = findRelevantCollections shrRecip prjRecip hLocal $ activityAudience $ actbActivity body let colls = findRelevantCollections shrRecip prjRecip hLocal $ activityAudience $ actbActivity body
mremoteRecipsHttpCreateFwd <- for msig $ \ sig -> do mremoteRecipsHttpCreateFwd <- for msig $ \ sig -> do
remoteRecips <- deliverFwdLocal ractidCreate colls sidProject fsidProject remoteRecips <- deliverFwdLocal ractidCreate colls sidProject fsidProject
(sig,) <$> deliverRemoteDB (actbBL body) ractidCreate jid sig remoteRecips (sig,) <$> deliverRemoteDB_J (actbBL body) ractidCreate jid sig remoteRecips
remoteRecipsHttpAccept <- do remoteRecipsHttpAccept <- do
moreRemoteRecipsAccept <- deliverLocal' False (LocalActorProject shrRecip prjRecip) ibidProject obiidAccept localRecipsAccept moreRemoteRecipsAccept <- deliverLocal' False (LocalActorProject shrRecip prjRecip) ibidProject obiidAccept localRecipsAccept
deliverRemoteDB' fwdAccept obiidAccept remoteRecipsAccept moreRemoteRecipsAccept deliverRemoteDB' fwdAccept obiidAccept remoteRecipsAccept moreRemoteRecipsAccept
@ -570,7 +570,7 @@ projectCreateTicketF now shrRecip prjRecip author body ticket muTarget = do
case msgOrRecips of case msgOrRecips of
Left msg -> return msg Left msg -> return msg
Right (mremoteRecipsHttpCreateFwd, remoteRecipsHttpAccept, obiidAccept, docAccept, fwdAccept) -> do Right (mremoteRecipsHttpCreateFwd, remoteRecipsHttpAccept, obiidAccept, docAccept, fwdAccept) -> do
for_ mremoteRecipsHttpCreateFwd $ \ (sig, recips) -> forkWorker "projectCreateTicketF inbox forwarding" $ deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig recips for_ mremoteRecipsHttpCreateFwd $ \ (sig, recips) -> forkWorker "projectCreateTicketF inbox forwarding" $ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig recips
forkWorker "projectCreateTicketF deliver Accept" $ deliverRemoteHttp fwdAccept obiidAccept docAccept remoteRecipsHttpAccept forkWorker "projectCreateTicketF deliver Accept" $ deliverRemoteHttp fwdAccept obiidAccept docAccept remoteRecipsHttpAccept
return "Accepting and listing new remote author hosted ticket" return "Accepting and listing new remote author hosted ticket"
_ -> return "Create/Ticket against different project, ignoring" _ -> return "Create/Ticket against different project, ignoring"

View file

@ -1552,6 +1552,16 @@ changes hLocal ctx =
"RemoteDiscussion" "RemoteDiscussion"
-- 239 -- 239
, addUnique "RemoteTicket" $ Unique "UniqueRemoteTicketDiscuss" ["discuss"] , addUnique "RemoteTicket" $ Unique "UniqueRemoteTicketDiscuss" ["discuss"]
-- 240
, addEntities model_2020_05_12
-- 241
, unchecked $ lift $ do
fwds <- selectList ([] :: [Filter Forwarding241]) []
let makeSender (Entity fwdid fwd) =
ForwarderProject241 fwdid (forwarding241Sender fwd)
insertMany_ $ map makeSender fwds
-- 242
, removeField "Forwarding" "sender"
] ]
migrateDB migrateDB

View file

@ -189,6 +189,10 @@ module Vervis.Migration.Model
, RemoteObject238Generic (..) , RemoteObject238Generic (..)
, Discussion238Generic (..) , Discussion238Generic (..)
, RemoteDiscussion238Generic (..) , RemoteDiscussion238Generic (..)
, model_2020_05_12
, Forwarding241
, Forwarding241Generic (..)
, ForwarderProject241Generic (..)
) )
where where
@ -371,3 +375,9 @@ model_2020_04_09 :: [Entity SqlBackend]
model_2020_04_09 = $(schema "2020_04_09_rt") model_2020_04_09 = $(schema "2020_04_09_rt")
makeEntitiesMigration "238" $(modelFile "migrations/2020_04_10_rt_rd.model") makeEntitiesMigration "238" $(modelFile "migrations/2020_04_10_rt_rd.model")
model_2020_05_12 :: [Entity SqlBackend]
model_2020_05_12 = $(schema "2020_05_12_fwd_sender")
makeEntitiesMigration "241"
$(modelFile "migrations/2020_05_12_fwd_sender_mig.model")