1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 16:24:52 +09:00

DB: Use RemoteObject in UnfetchedRemoteActor, RemoteActor, RemoteCollection

This commit is contained in:
fr33domlover 2019-11-06 19:47:50 +00:00
parent acb86ab621
commit f8dd72d052
19 changed files with 308 additions and 112 deletions

View file

@ -12,6 +12,15 @@
-- with this software. If not, see -- with this software. If not, see
-- <http://creativecommons.org/publicdomain/zero/1.0/>. -- <http://creativecommons.org/publicdomain/zero/1.0/>.
-------------------------------------------------------------------------------
-- Instances
-------------------------------------------------------------------------------
Instance
host Host
UniqueInstance host
RemoteObject RemoteObject
instance InstanceId instance InstanceId
ident LocalURI ident LocalURI
@ -128,31 +137,23 @@ VerifKeySharedUsage
UniqueVerifKeySharedUsage key user UniqueVerifKeySharedUsage key user
UnfetchedRemoteActor UnfetchedRemoteActor
instance InstanceId ident RemoteObjectId
ident LocalURI
since UTCTime Maybe since UTCTime Maybe
UniqueUnfetchedRemoteActor instance ident UniqueUnfetchedRemoteActor ident
RemoteActor RemoteActor
ident LocalURI ident RemoteObjectId
instance InstanceId
name Text Maybe name Text Maybe
inbox LocalURI inbox LocalURI
errorSince UTCTime Maybe errorSince UTCTime Maybe
UniqueRemoteActor instance ident UniqueRemoteActor ident
Instance
host Host
UniqueInstance host
RemoteCollection RemoteCollection
instance InstanceId ident RemoteObjectId
ident LocalURI
UniqueRemoteCollection instance ident UniqueRemoteCollection ident
FollowRemoteRequest FollowRemoteRequest
person PersonId person PersonId

View file

@ -0,0 +1,5 @@
RemoteObject
instance InstanceId
ident LocalURI
UniqueRemoteObject instance ident

View file

@ -0,0 +1,20 @@
Instance
host Host
UniqueInstance host
RemoteObject
instance InstanceId
ident LocalURI
UniqueRemoteObject instance ident
RemoteActivity
instance InstanceId
ident LocalURI
identNew RemoteObjectId
content PersistJSONObject
received UTCTime
UniqueRemoteActivity instance ident
UniqueRemoteActivityNew identNew

View file

@ -0,0 +1,38 @@
Instance
host Host
UniqueInstance host
RemoteObject
instance InstanceId
ident LocalURI
UniqueRemoteObject instance ident
UnfetchedRemoteActor
instance InstanceId
ident LocalURI
identNew RemoteObjectId
since UTCTime Maybe
UniqueUnfetchedRemoteActor instance ident
UniqueUnfetchedRemoteActorNew identNew
RemoteActor
ident LocalURI
instance InstanceId
identNew RemoteObjectId
name Text Maybe
inbox LocalURI
errorSince UTCTime Maybe
UniqueRemoteActor instance ident
UniqueRemoteActorNew identNew
RemoteCollection
instance InstanceId
ident LocalURI
identNew RemoteObjectId
UniqueRemoteCollection instance ident
UniqueRemoteCollectionNew identNew

View file

@ -1060,15 +1060,16 @@ getFollowersCollection here getFsid = do
selectList [PersonId <-. pids] [] selectList [PersonId <-. pids] []
map (sharerIdent . entityVal) <$> map (sharerIdent . entityVal) <$>
selectList [SharerId <-. sids] [] selectList [SharerId <-. sids] []
<*> do E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` i) -> do <*> do E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
E.on $ ra E.^. RemoteActorInstance E.==. i E.^. InstanceId E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId
E.where_ E.where_
$ rf E.^. RemoteFollowTarget E.==. E.val fsid $ rf E.^. RemoteFollowTarget E.==. E.val fsid
E.&&. rf E.^. RemoteFollowPublic E.==. E.val True E.&&. rf E.^. RemoteFollowPublic E.==. E.val True
return return
( i E.^. InstanceHost ( i E.^. InstanceHost
, ra E.^. RemoteActorIdent , ro E.^. RemoteObjectIdent
) )
<*> count [FollowTarget ==. fsid] <*> count [FollowTarget ==. fsid]
<*> count [RemoteFollowTarget ==. fsid] <*> count [RemoteFollowTarget ==. fsid]

View file

@ -216,24 +216,25 @@ getRepoTeam = getTicketTeam
getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]) getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
getFollowers fsid = do getFollowers fsid = do
local <- selectList [FollowTarget ==. fsid] [Asc FollowPerson] local <- selectList [FollowTarget ==. fsid] [Asc FollowPerson]
remote <- E.select $ E.from $ \ (rf `E.InnerJoin` rs `E.InnerJoin` i) -> do remote <- E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
E.on $ rs E.^. RemoteActorInstance E.==. i E.^. InstanceId E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
E.on $ rf E.^. RemoteFollowActor E.==. rs E.^. RemoteActorId E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
E.on $ rf E.^. RemoteFollowActor E.==. ra E.^. RemoteActorId
E.where_ $ rf E.^. RemoteFollowTarget E.==. E.val fsid E.where_ $ rf E.^. RemoteFollowTarget E.==. E.val fsid
E.orderBy [E.asc $ i E.^. InstanceId, E.asc $ rs E.^. RemoteActorId] E.orderBy [E.asc $ i E.^. InstanceId, E.asc $ ra E.^. RemoteActorId]
return return
( i E.^. InstanceId ( i E.^. InstanceId
, i E.^. InstanceHost , i E.^. InstanceHost
, rs E.^. RemoteActorId , ra E.^. RemoteActorId
, rs E.^. RemoteActorIdent , ro E.^. RemoteObjectIdent
, rs E.^. RemoteActorInbox , ra E.^. RemoteActorInbox
, rs E.^. RemoteActorErrorSince , ra E.^. RemoteActorErrorSince
) )
return return
( map (followPerson . entityVal) local ( map (followPerson . entityVal) local
, groupRemotes $ , groupRemotes $
map (\ (E.Value iid, E.Value h, E.Value rsid, E.Value luActor, E.Value luInbox, E.Value msince) -> map (\ (E.Value iid, E.Value h, E.Value raid, E.Value luActor, E.Value luInbox, E.Value msince) ->
(iid, h, rsid, luActor, luInbox, msince) (iid, h, raid, luActor, luInbox, msince)
) )
remote remote
) )
@ -241,7 +242,7 @@ getFollowers fsid = do
groupRemotes :: [(InstanceId, Host, RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)] -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))] groupRemotes :: [(InstanceId, Host, RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)] -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples
where where
toTuples (iid, h, rsid, luA, luI, ms) = ((iid, h), (rsid, luA, luI, ms)) toTuples (iid, h, raid, luA, luI, ms) = ((iid, h), (raid, luA, luI, ms))
unionRemotes unionRemotes
:: [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))] :: [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
@ -462,17 +463,19 @@ deliverRemoteDB' hContext obid recips known = do
then return ((iid, h), (Nothing, Nothing, Just lus')) then return ((iid, h), (Nothing, Nothing, Just lus'))
else do else do
es <- for lus' $ \ lu -> do es <- for lus' $ \ lu -> do
ma <- runMaybeT ma <- runMaybeT $ do
$ RecipRA <$> MaybeT (getBy $ UniqueRemoteActor iid lu) Entity roid ro <- MaybeT $ getBy $ UniqueRemoteObject iid lu
<|> RecipURA <$> MaybeT (getBy $ UniqueUnfetchedRemoteActor iid lu) recip <- RecipRA <$> MaybeT (getBy $ UniqueRemoteActor roid)
<|> RecipRC <$> MaybeT (getBy $ UniqueRemoteCollection iid lu) <|> RecipURA <$> MaybeT (getBy $ UniqueUnfetchedRemoteActor roid)
<|> RecipRC <$> MaybeT (getBy $ UniqueRemoteCollection roid)
return (ro, recip)
return $ return $
case ma of case ma of
Nothing -> Just $ Left lu Nothing -> Just $ Left lu
Just r -> Just (ro, r) ->
case r of case r of
RecipRA (Entity raid ra) -> Just $ Right $ Left (raid, remoteActorIdent ra, remoteActorInbox ra, remoteActorErrorSince ra) RecipRA (Entity raid ra) -> Just $ Right $ Left (raid, remoteObjectIdent ro, remoteActorInbox ra, remoteActorErrorSince ra)
RecipURA (Entity uraid ura) -> Just $ Right $ Right (uraid, unfetchedRemoteActorIdent ura, unfetchedRemoteActorSince ura) RecipURA (Entity uraid ura) -> Just $ Right $ Right (uraid, remoteObjectIdent ro, unfetchedRemoteActorSince ura)
RecipRC _ -> Nothing RecipRC _ -> Nothing
let (unknown, newKnown) = partitionEithers $ catMaybes $ NE.toList es let (unknown, newKnown) = partitionEithers $ catMaybes $ NE.toList es
(fetched, unfetched) = partitionEithers newKnown (fetched, unfetched) = partitionEithers newKnown
@ -489,14 +492,15 @@ deliverRemoteDB' hContext obid recips known = do
in (i,) <$> insertMany' (\ (uraid, _, msince) -> UnlinkedDelivery uraid obid fwd $ isNothing msince) rs in (i,) <$> insertMany' (\ (uraid, _, msince) -> UnlinkedDelivery uraid obid fwd $ isNothing msince) rs
unknownDeliv <- for stillUnknown $ \ (i, lus) -> do unknownDeliv <- for stillUnknown $ \ (i, lus) -> do
-- TODO maybe for URA insertion we should do insertUnique? -- TODO maybe for URA insertion we should do insertUnique?
rs <- insertMany' (\ lu -> UnfetchedRemoteActor (fst i) lu Nothing) lus ros <- insertMany' (\ lu -> RemoteObject (fst i) lu) lus
rs <- insertMany' (\ (_lu, roid) -> UnfetchedRemoteActor roid Nothing) ros
let fwd = snd i == hContext let fwd = snd i == hContext
(i,) <$> insertMany' (\ (_, uraid) -> UnlinkedDelivery uraid obid fwd True) rs (i,) <$> insertMany' (\ (_, uraid) -> UnlinkedDelivery uraid obid fwd True) rs
return return
( takeNoError4 fetchedDeliv ( takeNoError4 fetchedDeliv
, takeNoError3 unfetchedDeliv , takeNoError3 unfetchedDeliv
, map , map
(second $ NE.map $ \ ((lu, ak), dlk) -> (ak, lu, dlk)) (second $ NE.map $ \ (((lu, _roid), ak), dlk) -> (ak, lu, dlk))
unknownDeliv unknownDeliv
) )
where where

View file

@ -58,17 +58,18 @@ getMessages getdid = runDB $ do
on $ lm ^. LocalMessageRest ==. m ^. MessageId on $ lm ^. LocalMessageRest ==. m ^. MessageId
where_ $ m ^. MessageRoot ==. val did where_ $ m ^. MessageRoot ==. val did
return (m, lm ^. LocalMessageId, s) return (m, lm ^. LocalMessageId, s)
r <- select $ from $ \ (rm `InnerJoin` m `InnerJoin` rs `InnerJoin` i) -> do r <- select $ from $ \ (rm `InnerJoin` m `InnerJoin` ra `InnerJoin` ro `InnerJoin` i) -> do
on $ rs ^. RemoteActorInstance ==. i ^. InstanceId on $ ro ^. RemoteObjectInstance ==. i ^. InstanceId
on $ rm ^. RemoteMessageAuthor ==. rs ^. RemoteActorId on $ ra ^. RemoteActorIdent ==. ro ^. RemoteObjectId
on $ rm ^. RemoteMessageAuthor ==. ra ^. RemoteActorId
on $ rm ^. RemoteMessageRest ==. m ^. MessageId on $ rm ^. RemoteMessageRest ==. m ^. MessageId
where_ $ m ^. MessageRoot ==. val did where_ $ m ^. MessageRoot ==. val did
return return
( m ( m
, i ^. InstanceHost , i ^. InstanceHost
, rm ^. RemoteMessageIdent , rm ^. RemoteMessageIdent
, rs ^. RemoteActorIdent , ro ^. RemoteObjectIdent
, rs ^. RemoteActorName , ra ^. RemoteActorName
) )
return $ map mklocal l ++ map mkremote r return $ map mklocal l ++ map mkremote r
where where

View file

@ -370,21 +370,20 @@ retryOutboxDelivery = do
(udls, dls, fws) <- runSiteDB $ do (udls, dls, fws) <- runSiteDB $ do
-- Get all unlinked deliveries which aren't running already in outbox -- Get all unlinked deliveries which aren't running already in outbox
-- post handlers -- post handlers
unlinked' <- E.select $ E.from $ \ (udl `E.InnerJoin` ob `E.InnerJoin` ura `E.InnerJoin` i `E.LeftOuterJoin` ra `E.LeftOuterJoin` rc) -> do unlinked' <- E.select $ E.from $ \ (udl `E.InnerJoin` ob `E.InnerJoin` ura `E.InnerJoin` ro `E.InnerJoin` i `E.LeftOuterJoin` ra `E.LeftOuterJoin` rc) -> do
E.on $ E.just (ura E.^. UnfetchedRemoteActorInstance) E.==. rc E.?. RemoteCollectionInstance E.on $ E.just (ro E.^. RemoteObjectId) E.==. rc E.?. RemoteCollectionIdent
E.&&. E.just (ura E.^. UnfetchedRemoteActorIdent) E.==. rc E.?. RemoteCollectionIdent E.on $ E.just (ro E.^. RemoteObjectId) E.==. ra E.?. RemoteActorIdent
E.on $ E.just (ura E.^. UnfetchedRemoteActorInstance) E.==. ra E.?. RemoteActorInstance E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
E.&&. E.just (ura E.^. UnfetchedRemoteActorIdent) E.==. ra E.?. RemoteActorIdent E.on $ ura E.^. UnfetchedRemoteActorIdent E.==. ro E.^. RemoteObjectId
E.on $ ura E.^. UnfetchedRemoteActorInstance E.==. i E.^. InstanceId
E.on $ udl E.^. UnlinkedDeliveryRecipient E.==. ura E.^. UnfetchedRemoteActorId E.on $ udl E.^. UnlinkedDeliveryRecipient E.==. ura E.^. UnfetchedRemoteActorId
E.on $ udl E.^. UnlinkedDeliveryActivity E.==. ob E.^. OutboxItemId E.on $ udl E.^. UnlinkedDeliveryActivity E.==. ob E.^. OutboxItemId
E.where_ $ udl E.^. UnlinkedDeliveryRunning E.==. E.val False E.where_ $ udl E.^. UnlinkedDeliveryRunning E.==. E.val False
E.orderBy [E.asc $ ura E.^. UnfetchedRemoteActorInstance, E.asc $ ura E.^. UnfetchedRemoteActorId] E.orderBy [E.asc $ ro E.^. RemoteObjectInstance, E.asc $ ura E.^. UnfetchedRemoteActorId]
return return
( i E.^. InstanceId ( i E.^. InstanceId
, i E.^. InstanceHost , i E.^. InstanceHost
, ura E.^. UnfetchedRemoteActorId , ura E.^. UnfetchedRemoteActorId
, ura E.^. UnfetchedRemoteActorIdent , ro E.^. RemoteObjectIdent
, ura E.^. UnfetchedRemoteActorSince , ura E.^. UnfetchedRemoteActorSince
, udl E.^. UnlinkedDeliveryId , udl E.^. UnlinkedDeliveryId
, udl E.^. UnlinkedDeliveryActivity , udl E.^. UnlinkedDeliveryActivity
@ -410,17 +409,18 @@ retryOutboxDelivery = do
deleteWhere [UnlinkedDeliveryId <-. lonelyOld] deleteWhere [UnlinkedDeliveryId <-. lonelyOld]
-- Now let's grab the linked deliveries, and similarly delete old ones -- Now let's grab the linked deliveries, and similarly delete old ones
-- and return the rest for HTTP delivery. -- and return the rest for HTTP delivery.
linked <- E.select $ E.from $ \ (dl `E.InnerJoin` ra `E.InnerJoin` i `E.InnerJoin` ob) -> do linked <- E.select $ E.from $ \ (dl `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i `E.InnerJoin` ob) -> do
E.on $ dl E.^. DeliveryActivity E.==. ob E.^. OutboxItemId E.on $ dl E.^. DeliveryActivity E.==. ob E.^. OutboxItemId
E.on $ ra E.^. RemoteActorInstance E.==. i E.^. InstanceId E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
E.on $ ra E.^. RemoteActorIdent E.==. ro E.^. RemoteObjectId
E.on $ dl E.^. DeliveryRecipient E.==. ra E.^. RemoteActorId E.on $ dl E.^. DeliveryRecipient E.==. ra E.^. RemoteActorId
E.where_ $ dl E.^. DeliveryRunning E.==. E.val False E.where_ $ dl E.^. DeliveryRunning E.==. E.val False
E.orderBy [E.asc $ ra E.^. RemoteActorInstance, E.asc $ ra E.^. RemoteActorId] E.orderBy [E.asc $ ro E.^. RemoteObjectInstance, E.asc $ ra E.^. RemoteActorId]
return return
( i E.^. InstanceId ( i E.^. InstanceId
, i E.^. InstanceHost , i E.^. InstanceHost
, ra E.^. RemoteActorId , ra E.^. RemoteActorId
, ra E.^. RemoteActorIdent , ro E.^. RemoteObjectIdent
, ra E.^. RemoteActorInbox , ra E.^. RemoteActorInbox
, ra E.^. RemoteActorErrorSince , ra E.^. RemoteActorErrorSince
, dl E.^. DeliveryId , dl E.^. DeliveryId
@ -430,13 +430,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` i `E.InnerJoin` j `E.InnerJoin` s) -> do forwarding <- E.select $ E.from $ \ (fw `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i `E.InnerJoin` j `E.InnerJoin` s) -> do
E.on $ j E.^. ProjectSharer E.==. s E.^. SharerId E.on $ j E.^. ProjectSharer E.==. s E.^. SharerId
E.on $ fw E.^. ForwardingSender E.==. j E.^. ProjectId E.on $ fw E.^. ForwardingSender E.==. j E.^. ProjectId
E.on $ ra E.^. RemoteActorInstance E.==. i E.^. InstanceId E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
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
E.where_ $ fw E.^. ForwardingRunning E.==. E.val False E.where_ $ fw E.^. ForwardingRunning E.==. E.val False
E.orderBy [E.asc $ ra E.^. RemoteActorInstance, E.asc $ ra E.^. RemoteActorId] E.orderBy [E.asc $ ro E.^. RemoteObjectInstance, E.asc $ ra E.^. RemoteActorId]
return return
( i E.^. InstanceId ( i E.^. InstanceId
, i E.^. InstanceHost , i E.^. InstanceHost

View file

@ -145,17 +145,19 @@ verifyActorSig' malgo input (Signature signature) host luKey mluActorHeader = do
Entity iid _ <- MaybeT $ getBy $ UniqueInstance host Entity iid _ <- MaybeT $ getBy $ UniqueInstance host
MaybeT $ getBy $ UniqueVerifKey iid luKey MaybeT $ getBy $ UniqueVerifKey iid luKey
for mvk $ \ vk@(Entity _ verifkey) -> do for mvk $ \ vk@(Entity _ verifkey) -> do
mremote <- for (verifKeySharer verifkey) $ \ rsid -> mremote <- for (verifKeySharer verifkey) $ \ raid -> do
(rsid,) <$> getJust rsid ra <- getJust raid
ro <- getJust $ remoteActorIdent ra
return (ro, raid, ra)
return (vk, mremote) return (vk, mremote)
case ments of case ments of
Just (Entity vkid vk, mremote) -> do Just (Entity vkid vk, mremote) -> do
(ua, s, rsid) <- (ua, s, rsid) <-
case mremote of case mremote of
Just (rsid, rs) -> do Just (ro, rsid, rs) -> do
let sharer = remoteActorIdent rs let sharer = remoteObjectIdent ro
for_ mluActorHeader $ \ u -> for_ mluActorHeader $ \ lu ->
if sharer == u if sharer == lu
then return () then return ()
else throwE "Key's owner doesn't match actor header" else throwE "Key's owner doesn't match actor header"
return (sharer, False, rsid) return (sharer, False, rsid)

View file

@ -247,6 +247,7 @@ followF
Just ractid -> do Just ractid -> do
let raidAuthor = remoteAuthorId author let raidAuthor = remoteAuthorId author
ra <- getJust raidAuthor ra <- getJust raidAuthor
ro <- getJust $ remoteActorIdent ra
(obiid, doc) <- (obiid, doc) <-
insertAcceptToOutbox insertAcceptToOutbox
ra ra
@ -255,7 +256,7 @@ followF
newFollow <- insertFollow ractid obiid $ recipFollowers recip newFollow <- insertFollow ractid obiid $ recipFollowers recip
if newFollow if newFollow
then Right <$> do then Right <$> do
let raInfo = (raidAuthor, remoteActorIdent ra, remoteActorInbox ra, remoteActorErrorSince ra) let raInfo = (raidAuthor, remoteObjectIdent ro, remoteActorInbox ra, remoteActorErrorSince ra)
iidAuthor = remoteAuthorInstance author iidAuthor = remoteAuthorInstance author
hAuthor = objUriAuthority $ remoteAuthorURI author hAuthor = objUriAuthority $ remoteAuthorURI author
hostSection = ((iidAuthor, hAuthor), raInfo :| []) hostSection = ((iidAuthor, hAuthor), raInfo :| [])

View file

@ -371,7 +371,8 @@ projectOfferTicketF
moreRemotes <- deliverLocal now sid (projectFollowers project) obiid moreRemotes <- deliverLocal now sid (projectFollowers project) obiid
let raidAuthor = remoteAuthorId author let raidAuthor = remoteAuthorId author
ra <- getJust raidAuthor ra <- getJust raidAuthor
let raInfo = (raidAuthor, remoteActorIdent ra, remoteActorInbox ra, remoteActorErrorSince ra) ro <- getJust $ remoteActorIdent ra
let raInfo = (raidAuthor, remoteObjectIdent ro, remoteActorInbox ra, remoteActorErrorSince ra)
iidAuthor = remoteAuthorInstance author iidAuthor = remoteAuthorInstance author
hAuthor = objUriAuthority $ remoteAuthorURI author hAuthor = objUriAuthority $ remoteAuthorURI author
hostSection = ((iidAuthor, hAuthor), raInfo :| []) hostSection = ((iidAuthor, hAuthor), raInfo :| [])

View file

@ -94,12 +94,13 @@ getNode getdid mid = do
return $ MessageTreeNodeLocal lmid s return $ MessageTreeNodeLocal lmid s
(Nothing, Just (Entity _rmid rm)) -> do (Nothing, Just (Entity _rmid rm)) -> do
rs <- getJust $ remoteMessageAuthor rm rs <- getJust $ remoteMessageAuthor rm
i <- getJust $ remoteActorInstance rs ro <- getJust $ remoteActorIdent rs
i <- getJust $ remoteObjectInstance ro
return $ return $
MessageTreeNodeRemote MessageTreeNodeRemote
(instanceHost i) (instanceHost i)
(remoteMessageIdent rm) (remoteMessageIdent rm)
(remoteActorIdent rs) (remoteObjectIdent ro)
(remoteActorName rs) (remoteActorName rs)
return $ MessageTreeNode mid m author return $ MessageTreeNode mid m author
@ -154,8 +155,9 @@ getDiscussionMessage shr lmid = do
return $ route2fed $ MessageR (sharerIdent s) lmhidParent return $ route2fed $ MessageR (sharerIdent s) lmhidParent
(Nothing, Just rmParent) -> do (Nothing, Just rmParent) -> do
rs <- getJust $ remoteMessageAuthor rmParent rs <- getJust $ remoteMessageAuthor rmParent
i <- getJust $ remoteActorInstance rs ro <- getJust $ remoteActorIdent rs
return $ ObjURI (instanceHost i) (remoteActorIdent rs) i <- getJust $ remoteObjectInstance ro
return $ ObjURI (instanceHost i) (remoteObjectIdent ro)
--ob <- getJust $ localMessageCreate lm --ob <- getJust $ localMessageCreate lm
--let activity = docValue $ persistJSONValue $ outboxItemActivity ob --let activity = docValue $ persistJSONValue $ outboxItemActivity ob

View file

@ -193,8 +193,9 @@ getTicketR shar proj num = do
(do mtar <- getValBy $ UniqueTicketAuthorRemote tid (do mtar <- getValBy $ UniqueTicketAuthorRemote tid
for mtar $ \ tar -> do for mtar $ \ tar -> do
ra <- getJust $ ticketAuthorRemoteAuthor tar ra <- getJust $ ticketAuthorRemoteAuthor tar
i <- getJust $ remoteActorInstance ra ro <- getJust $ remoteActorIdent ra
return (i, ra) i <- getJust $ remoteObjectInstance ro
return (i, ro, ra)
) )
"Ticket doesn't have author" "Ticket doesn't have author"
"Ticket has both local and remote author" "Ticket has both local and remote author"
@ -251,7 +252,7 @@ getTicketR shar proj num = do
let host = let host =
case author of case author of
Left _ -> hLocal Left _ -> hLocal
Right (i, _) -> instanceHost i Right (i, _, _) -> instanceHost i
ticketAP = AP.Ticket ticketAP = AP.Ticket
{ AP.ticketLocal = Just { AP.ticketLocal = Just
( hLocal ( hLocal
@ -279,8 +280,8 @@ getTicketR shar proj num = do
case author of case author of
Left sharer -> Left sharer ->
encodeRouteLocal $ SharerR $ sharerIdent sharer encodeRouteLocal $ SharerR $ sharerIdent sharer
Right (_inztance, actor) -> Right (_inztance, object, _actor) ->
remoteActorIdent actor remoteObjectIdent object
, AP.ticketPublished = Just $ ticketCreated ticket , AP.ticketPublished = Just $ ticketCreated ticket
, AP.ticketUpdated = Nothing , AP.ticketUpdated = Nothing
, AP.ticketName = Just $ "#" <> T.pack (show num) , AP.ticketName = Just $ "#" <> T.pack (show num)
@ -759,9 +760,10 @@ getTicketDeps forward shr prj num = do
\ ( td \ ( td
`E.InnerJoin` t `E.InnerJoin` t
`E.LeftOuterJoin` (tal `E.InnerJoin` p `E.InnerJoin` s) `E.LeftOuterJoin` (tal `E.InnerJoin` p `E.InnerJoin` s)
`E.LeftOuterJoin` (tar `E.InnerJoin` ra `E.InnerJoin` i) `E.LeftOuterJoin` (tar `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i)
) -> do ) -> do
E.on $ ra E.?. RemoteActorInstance E.==. i E.?. InstanceId E.on $ ro E.?. RemoteObjectInstance E.==. i E.?. InstanceId
E.on $ ra E.?. RemoteActorIdent E.==. ro E.?. RemoteObjectId
E.on $ tar E.?. TicketAuthorRemoteAuthor E.==. ra E.?. RemoteActorId E.on $ tar E.?. TicketAuthorRemoteAuthor E.==. ra E.?. RemoteActorId
E.on $ E.just (t E.^. TicketId) E.==. tar E.?. TicketAuthorRemoteTicket E.on $ E.just (t E.^. TicketId) E.==. tar E.?. TicketAuthorRemoteTicket
E.on $ p E.?. PersonIdent E.==. s E.?. SharerId E.on $ p E.?. PersonIdent E.==. s E.?. SharerId
@ -775,19 +777,20 @@ getTicketDeps forward shr prj num = do
, t E.^. TicketNumber , t E.^. TicketNumber
, s , s
, i , i
, ro
, ra , ra
, t E.^. TicketTitle , t E.^. TicketTitle
, t E.^. TicketStatus , t E.^. TicketStatus
) )
where where
toRow (E.Value dep, E.Value number, ms, mi, mra, E.Value title, E.Value status) = toRow (E.Value dep, E.Value number, ms, mi, mro, mra, E.Value title, E.Value status) =
( dep ( dep
, ( number , ( number
, case (ms, mi, mra) of , case (ms, mi, mro, mra) of
(Just s, Nothing, Nothing) -> (Just s, Nothing, Nothing, Nothing) ->
Left $ entityVal s Left $ entityVal s
(Nothing, Just i, Just ra) -> (Nothing, Just i, Just ro, Just ra) ->
Right (entityVal i, entityVal ra) Right (entityVal i, entityVal ro, entityVal ra)
_ -> error "Ticket author DB invalid state" _ -> error "Ticket author DB invalid state"
, title , title
, status , status

View file

@ -1124,6 +1124,98 @@ changes hLocal ctx =
, removeField "RemoteActivity" "ident" , removeField "RemoteActivity" "ident"
-- 158 -- 158
, renameField "RemoteActivity" "identNew" "ident" , renameField "RemoteActivity" "identNew" "ident"
-- 159
, addFieldRefRequired''
"UnfetchedRemoteActor"
(do iid <- insert $ Instance159 $ Authority "159.fake.fake" Nothing
insertEntity $ RemoteObject159 iid $ LocalURI "/fake/159"
)
(Just $ \ (Entity roidTemp roTemp) -> do
uras <- selectList ([] :: [Filter UnfetchedRemoteActor159]) []
for_ uras $ \ (Entity uraid ura) -> do
let iid = unfetchedRemoteActor159Instance ura
lu = unfetchedRemoteActor159Ident ura
roid <- insert $ RemoteObject159 iid lu
update uraid [UnfetchedRemoteActor159IdentNew =. roid]
delete roidTemp
delete $ remoteObject159Instance roTemp
)
"identNew"
"RemoteObject"
-- 160
, addUnique "UnfetchedRemoteActor" $
Unique "UniqueUnfetchedRemoteActorNew" ["identNew"]
-- 161
, addFieldRefRequired''
"RemoteActor"
(do iid <- insert $ Instance159 $ Authority "159.fake.fake" Nothing
insertEntity $ RemoteObject159 iid $ LocalURI "/fake/159"
)
(Just $ \ (Entity roidTemp roTemp) -> do
ras <- selectList ([] :: [Filter RemoteActor159]) []
for_ ras $ \ (Entity raid ra) -> do
let iid = remoteActor159Instance ra
lu = remoteActor159Ident ra
roid <- insert $ RemoteObject159 iid lu
update raid [RemoteActor159IdentNew =. roid]
delete roidTemp
delete $ remoteObject159Instance roTemp
)
"identNew"
"RemoteObject"
-- 162
, addUnique "RemoteActor" $ Unique "UniqueRemoteActorNew" ["identNew"]
-- 163
, removeUnique "UnfetchedRemoteActor" "UniqueUnfetchedRemoteActor"
-- 164
, renameUnique "UnfetchedRemoteActor" "UniqueUnfetchedRemoteActorNew" "UniqueUnfetchedRemoteActor"
-- 165
, removeUnique "RemoteActor" "UniqueRemoteActor"
-- 166
, renameUnique "RemoteActor" "UniqueRemoteActorNew" "UniqueRemoteActor"
-- 167
, removeField "UnfetchedRemoteActor" "instance"
-- 168
, removeField "UnfetchedRemoteActor" "ident"
-- 169
, renameField "UnfetchedRemoteActor" "identNew" "ident"
-- 170
, removeField "RemoteActor" "instance"
-- 171
, removeField "RemoteActor" "ident"
-- 172
, renameField "RemoteActor" "identNew" "ident"
-- 173
, addFieldRefRequired''
"RemoteCollection"
(do iid <- insert $ Instance159 $ Authority "173.fake.fake" Nothing
insertEntity $ RemoteObject159 iid $ LocalURI "/fake/173"
)
(Just $ \ (Entity roidTemp roTemp) -> do
rcs <- selectList ([] :: [Filter RemoteCollection159]) []
for_ rcs $ \ (Entity rcid rc) -> do
let iid = remoteCollection159Instance rc
lu = remoteCollection159Ident rc
roid <- insert $ RemoteObject159 iid lu
update rcid [RemoteCollection159IdentNew =. roid]
delete roidTemp
delete $ remoteObject159Instance roTemp
)
"identNew"
"RemoteCollection"
-- 174
, addUnique "RemoteCollection"
$ Unique "UniqueRemoteCollectionNew" ["identNew"]
-- 175
, removeUnique "RemoteCollection" "UniqueRemoteCollection"
-- 176
, renameUnique "RemoteCollection" "UniqueRemoteCollectionNew" "UniqueRemoteCollection"
-- 177
, removeField "RemoteCollection" "instance"
-- 178
, removeField "RemoteCollection" "ident"
-- 179
, renameField "RemoteCollection" "identNew" "ident"
] ]
migrateDB migrateDB

View file

@ -130,6 +130,14 @@ module Vervis.Migration.Model
, RemoteObject152Generic (..) , RemoteObject152Generic (..)
, RemoteActivity152Generic (..) , RemoteActivity152Generic (..)
, RemoteActivity152 , RemoteActivity152
, Instance159Generic (..)
, RemoteObject159Generic (..)
, RemoteActor159Generic (..)
, RemoteActor159
, UnfetchedRemoteActor159Generic (..)
, UnfetchedRemoteActor159
, RemoteCollection159Generic (..)
, RemoteCollection159
) )
where where
@ -266,3 +274,6 @@ model_2019_11_04 = $(schema "2019_11_04")
makeEntitiesMigration "152" makeEntitiesMigration "152"
$(modelFile "migrations/2019_11_04_remote_activity_ident.model") $(modelFile "migrations/2019_11_04_remote_activity_ident.model")
makeEntitiesMigration "159"
$(modelFile "migrations/2019_11_05_remote_actor_ident.model")

View file

@ -138,8 +138,9 @@ instanceAndActor
-> YesodDB site (InstanceId, RemoteActorId, Maybe Bool) -> YesodDB site (InstanceId, RemoteActorId, Maybe Bool)
instanceAndActor host luActor mname luInbox = do instanceAndActor host luActor mname luInbox = do
(iid, inew) <- idAndNew <$> insertBy' (Instance host) (iid, inew) <- idAndNew <$> insertBy' (Instance host)
(raid, ranew) <- (raid, ranew) <- do
idAndNew <$> insertBy' (RemoteActor luActor iid mname luInbox Nothing) roid <- either entityKey id <$> insertBy' (RemoteObject iid luActor)
idAndNew <$> insertBy' (RemoteActor roid mname luInbox Nothing)
return $ return $
( iid ( iid
, raid , raid
@ -337,11 +338,15 @@ keyListedByActorShared iid vkid host luKey luActor = do
RoomModeInstant -> do RoomModeInstant -> do
when reject $ throwE "Actor key storage limit is 0 and set to reject" when reject $ throwE "Actor key storage limit is 0 and set to reject"
actor <- ExceptT (keyListedByActor manager host luKey luActor) actor <- ExceptT (keyListedByActor manager host luKey luActor)
lift $ runDB $ either entityKey id <$> insertBy' (RemoteActor luActor iid (actorName actor <|> actorUsername actor) (actorInbox actor) Nothing) lift $ runDB $ do
roid <- either entityKey id <$> insertBy' (RemoteObject iid luActor)
either entityKey id <$> insertBy' (RemoteActor roid (actorName actor <|> actorUsername actor) (actorInbox actor) Nothing)
RoomModeCached m -> do RoomModeCached m -> do
eresult <- do eresult <- do
ments <- lift $ runDB $ do ments <- lift $ runDB $ do
mrs <- getBy $ UniqueRemoteActor iid luActor mrs <- runMaybeT $ do
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luActor
MaybeT $ getBy $ UniqueRemoteActor roid
for mrs $ \ (Entity rsid _) -> for mrs $ \ (Entity rsid _) ->
(rsid,) . isJust <$> (rsid,) . isJust <$>
getBy (UniqueVerifKeySharedUsage vkid rsid) getBy (UniqueVerifKeySharedUsage vkid rsid)
@ -360,7 +365,9 @@ keyListedByActorShared iid vkid host luKey luActor = do
vkExists <- isJust <$> get vkid vkExists <- isJust <$> get vkid
case mrsid of case mrsid of
Nothing -> do Nothing -> do
rsid <- either entityKey id <$> insertBy' (RemoteActor luActor iid (actorName actor <|> actorUsername actor) (actorInbox actor) Nothing) rsid <- do
roid <- either entityKey id <$> insertBy' (RemoteObject iid luActor)
either entityKey id <$> insertBy' (RemoteActor roid (actorName actor <|> actorUsername actor) (actorInbox actor) Nothing)
when vkExists $ insert_ $ VerifKeySharedUsage vkid rsid when vkExists $ insert_ $ VerifKeySharedUsage vkid rsid
return $ Right rsid return $ Right rsid
Just rsid -> runExceptT $ do Just rsid -> runExceptT $ do
@ -469,9 +476,10 @@ actorFetchShareAction
-> IO (Either (Maybe APGetError) (Maybe (Entity RemoteActor))) -> IO (Either (Maybe APGetError) (Maybe (Entity RemoteActor)))
actorFetchShareAction u (site, iid) = flip runWorkerT site $ do actorFetchShareAction u (site, iid) = flip runWorkerT site $ do
let ObjURI h lu = u let ObjURI h lu = u
mrecip <- runSiteDB $ runMaybeT mrecip <- runSiteDB $ runMaybeT $
$ Left <$> MaybeT (getBy $ UniqueRemoteActor iid lu) MaybeT (getKeyBy $ UniqueRemoteObject iid lu) >>= \ roid ->
<|> Right <$> MaybeT (getBy $ UniqueRemoteCollection iid lu) Left <$> MaybeT (getBy $ UniqueRemoteActor roid)
<|> Right <$> MaybeT (getBy $ UniqueRemoteCollection roid)
case mrecip of case mrecip of
Just recip -> Just recip ->
return $ Right $ return $ Right $
@ -483,18 +491,20 @@ actorFetchShareAction u (site, iid) = flip runWorkerT site $ do
erecip <- fetchRecipient manager h lu erecip <- fetchRecipient manager h lu
for erecip $ \ recip -> for erecip $ \ recip ->
case recip of case recip of
RecipientActor actor -> runSiteDB $ RecipientActor actor -> runSiteDB $ do
roid <- either entityKey id <$> insertBy' (RemoteObject iid lu)
let ra = RemoteActor let ra = RemoteActor
{ remoteActorIdent = lu { remoteActorIdent = roid
, remoteActorInstance = iid
, remoteActorName = , remoteActorName =
actorName actor <|> actorUsername actor actorName actor <|> actorUsername actor
, remoteActorInbox = actorInbox actor , remoteActorInbox = actorInbox actor
, remoteActorErrorSince = Nothing , remoteActorErrorSince = Nothing
} }
in Just . either id (flip Entity ra) <$> insertBy' ra Just . either id (flip Entity ra) <$> insertBy' ra
RecipientCollection _ -> runSiteDB $ do RecipientCollection _ -> runSiteDB $ do
insertUnique_ $ RemoteCollection iid lu mroid <- insertUnique $ RemoteObject iid lu
for_ mroid $ \ roid ->
insertUnique_ $ RemoteCollection roid
return Nothing return Nothing
fetchRemoteActor fetchRemoteActor
@ -517,9 +527,10 @@ fetchRemoteActor
(Either (Maybe APGetError) (Maybe (Entity RemoteActor))) (Either (Maybe APGetError) (Maybe (Entity RemoteActor)))
) )
fetchRemoteActor iid host luActor = do fetchRemoteActor iid host luActor = do
mrecip <- runSiteDB $ runMaybeT mrecip <- runSiteDB $ runMaybeT $
$ Left <$> MaybeT (getBy $ UniqueRemoteActor iid luActor) MaybeT (getKeyBy $ UniqueRemoteObject iid luActor) >>= \ roid ->
<|> Right <$> MaybeT (getBy $ UniqueRemoteCollection iid luActor) Left <$> MaybeT (getBy $ UniqueRemoteActor roid)
<|> Right <$> MaybeT (getBy $ UniqueRemoteCollection roid)
case mrecip of case mrecip of
Just recip -> Just recip ->
return $ Right $ Right $ return $ Right $ Right $

View file

@ -48,13 +48,14 @@ getTicketSummaries
getTicketSummaries mfilt morder jid = fmap (map toSummary) $ select $ from $ getTicketSummaries mfilt morder jid = fmap (map toSummary) $ select $ from $
\ ( t \ ( t
`LeftOuterJoin` (tal `InnerJoin` p `InnerJoin` s) `LeftOuterJoin` (tal `InnerJoin` p `InnerJoin` s)
`LeftOuterJoin` (tar `InnerJoin` ra `InnerJoin` i) `LeftOuterJoin` (tar `InnerJoin` ra `InnerJoin` ro `InnerJoin` i)
`InnerJoin` d `InnerJoin` d
`LeftOuterJoin` m `LeftOuterJoin` m
) -> do ) -> do
on $ just (d ^. DiscussionId) ==. m ?. MessageRoot on $ just (d ^. DiscussionId) ==. m ?. MessageRoot
on $ t ^. TicketDiscuss ==. d ^. DiscussionId on $ t ^. TicketDiscuss ==. d ^. DiscussionId
on $ ra ?. RemoteActorInstance ==. i ?. InstanceId on $ ro ?. RemoteObjectInstance ==. i ?. InstanceId
on $ ra ?. RemoteActorIdent ==. ro ?. RemoteObjectId
on $ tar ?. TicketAuthorRemoteAuthor ==. ra ?. RemoteActorId on $ tar ?. TicketAuthorRemoteAuthor ==. ra ?. RemoteActorId
on $ just (t ^. TicketId) ==. tar ?. TicketAuthorRemoteTicket on $ just (t ^. TicketId) ==. tar ?. TicketAuthorRemoteTicket
on $ p ?. PersonIdent ==. s ?. SharerId on $ p ?. PersonIdent ==. s ?. SharerId
@ -71,6 +72,7 @@ getTicketSummaries mfilt morder jid = fmap (map toSummary) $ select $ from $
( t ^. TicketNumber ( t ^. TicketNumber
, s , s
, i , i
, ro
, ra , ra
, t ^. TicketCreated , t ^. TicketCreated
, t ^. TicketTitle , t ^. TicketTitle
@ -78,15 +80,15 @@ getTicketSummaries mfilt morder jid = fmap (map toSummary) $ select $ from $
, count $ m ?. MessageId , count $ m ?. MessageId
) )
where where
toSummary (Value n, ms, mi, mra, Value c, Value t, Value d, Value r) = toSummary (Value n, ms, mi, mro, mra, Value c, Value t, Value d, Value r) =
TicketSummary TicketSummary
{ tsNumber = n { tsNumber = n
, tsCreatedBy = , tsCreatedBy =
case (ms, mi, mra) of case (ms, mi, mro, mra) of
(Just s, Nothing, Nothing) -> (Just s, Nothing, Nothing, Nothing) ->
Left $ entityVal s Left $ entityVal s
(Nothing, Just i, Just ra) -> (Nothing, Just i, Just ro, Just ra) ->
Right (entityVal i, entityVal ra) Right (entityVal i, entityVal ro, entityVal ra)
_ -> error "Ticket author DB invalid state" _ -> error "Ticket author DB invalid state"
, tsCreatedAt = c , tsCreatedAt = c
, tsTitle = t , tsTitle = t

View file

@ -46,18 +46,18 @@ sharerLinkW sharer =
#{shr2text $ sharerIdent sharer} #{shr2text $ sharerIdent sharer}
|] |]
sharerLinkFedW :: Either Sharer (Instance, RemoteActor) -> Widget sharerLinkFedW :: Either Sharer (Instance, RemoteObject, RemoteActor) -> Widget
sharerLinkFedW (Left sharer) = sharerLinkW sharer sharerLinkFedW (Left sharer) = sharerLinkW sharer
sharerLinkFedW (Right (inztance, actor)) = sharerLinkFedW (Right (inztance, object, actor)) =
[whamlet| [whamlet|
<a href="#{renderObjURI uActor}"> <a href="#{renderObjURI uActor}">
$maybe name <- remoteActorName actor $maybe name <- remoteActorName actor
#{name} #{name}
$nothing $nothing
#{renderAuthority $ instanceHost inztance}#{localUriPath $ remoteActorIdent actor} #{renderAuthority $ instanceHost inztance}#{localUriPath $ remoteObjectIdent object}
|] |]
where where
uActor = ObjURI (instanceHost inztance) (remoteActorIdent actor) uActor = ObjURI (instanceHost inztance) (remoteObjectIdent object)
followW :: Route App -> Route App -> AppDB FollowerSetId -> Widget followW :: Route App -> Route App -> AppDB FollowerSetId -> Widget
followW followRoute unfollowRoute getFsid = do followW followRoute unfollowRoute getFsid = do

View file

@ -47,7 +47,7 @@ import Vervis.Widget.Sharer
data TicketSummary = TicketSummary data TicketSummary = TicketSummary
{ tsNumber :: Int { tsNumber :: Int
, tsCreatedBy :: Either Sharer (Instance, RemoteActor) , tsCreatedBy :: Either Sharer (Instance, RemoteObject, RemoteActor)
, tsCreatedAt :: UTCTime , tsCreatedAt :: UTCTime
, tsTitle :: Text , tsTitle :: Text
, tsStatus :: TicketStatus , tsStatus :: TicketStatus