diff --git a/config/models b/config/models
index 8ace824..29ef535 100644
--- a/config/models
+++ b/config/models
@@ -12,6 +12,15 @@
-- with this software. If not, see
-- .
+-------------------------------------------------------------------------------
+-- Instances
+-------------------------------------------------------------------------------
+
+Instance
+ host Host
+
+ UniqueInstance host
+
RemoteObject
instance InstanceId
ident LocalURI
@@ -128,31 +137,23 @@ VerifKeySharedUsage
UniqueVerifKeySharedUsage key user
UnfetchedRemoteActor
- instance InstanceId
- ident LocalURI
- since UTCTime Maybe
+ ident RemoteObjectId
+ since UTCTime Maybe
- UniqueUnfetchedRemoteActor instance ident
+ UniqueUnfetchedRemoteActor ident
RemoteActor
- ident LocalURI
- instance InstanceId
+ ident RemoteObjectId
name Text Maybe
inbox LocalURI
errorSince UTCTime Maybe
- UniqueRemoteActor instance ident
-
-Instance
- host Host
-
- UniqueInstance host
+ UniqueRemoteActor ident
RemoteCollection
- instance InstanceId
- ident LocalURI
+ ident RemoteObjectId
- UniqueRemoteCollection instance ident
+ UniqueRemoteCollection ident
FollowRemoteRequest
person PersonId
diff --git a/migrations/2019_11_04.model b/migrations/2019_11_04.model
new file mode 100644
index 0000000..0f293ef
--- /dev/null
+++ b/migrations/2019_11_04.model
@@ -0,0 +1,5 @@
+RemoteObject
+ instance InstanceId
+ ident LocalURI
+
+ UniqueRemoteObject instance ident
diff --git a/migrations/2019_11_04_remote_activity_ident.model b/migrations/2019_11_04_remote_activity_ident.model
new file mode 100644
index 0000000..d2e3a39
--- /dev/null
+++ b/migrations/2019_11_04_remote_activity_ident.model
@@ -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
diff --git a/migrations/2019_11_05_remote_actor_ident.model b/migrations/2019_11_05_remote_actor_ident.model
new file mode 100644
index 0000000..542c499
--- /dev/null
+++ b/migrations/2019_11_05_remote_actor_ident.model
@@ -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
diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs
index 579ba85..a5a59b2 100644
--- a/src/Vervis/API.hs
+++ b/src/Vervis/API.hs
@@ -1060,15 +1060,16 @@ getFollowersCollection here getFsid = do
selectList [PersonId <-. pids] []
map (sharerIdent . entityVal) <$>
selectList [SharerId <-. sids] []
- <*> do E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` i) -> do
- E.on $ ra E.^. RemoteActorInstance E.==. i E.^. InstanceId
+ <*> do E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
+ 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.where_
$ rf E.^. RemoteFollowTarget E.==. E.val fsid
E.&&. rf E.^. RemoteFollowPublic E.==. E.val True
return
( i E.^. InstanceHost
- , ra E.^. RemoteActorIdent
+ , ro E.^. RemoteObjectIdent
)
<*> count [FollowTarget ==. fsid]
<*> count [RemoteFollowTarget ==. fsid]
diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs
index 2a6c701..c9d2643 100644
--- a/src/Vervis/ActivityPub.hs
+++ b/src/Vervis/ActivityPub.hs
@@ -216,24 +216,25 @@ getRepoTeam = getTicketTeam
getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
getFollowers fsid = do
local <- selectList [FollowTarget ==. fsid] [Asc FollowPerson]
- remote <- E.select $ E.from $ \ (rf `E.InnerJoin` rs `E.InnerJoin` i) -> do
- E.on $ rs E.^. RemoteActorInstance E.==. i E.^. InstanceId
- E.on $ rf E.^. RemoteFollowActor E.==. rs E.^. RemoteActorId
+ remote <- E.select $ E.from $ \ (rf `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) -> do
+ 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.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
( i E.^. InstanceId
, i E.^. InstanceHost
- , rs E.^. RemoteActorId
- , rs E.^. RemoteActorIdent
- , rs E.^. RemoteActorInbox
- , rs E.^. RemoteActorErrorSince
+ , ra E.^. RemoteActorId
+ , ro E.^. RemoteObjectIdent
+ , ra E.^. RemoteActorInbox
+ , ra E.^. RemoteActorErrorSince
)
return
( map (followPerson . entityVal) local
, groupRemotes $
- map (\ (E.Value iid, E.Value h, E.Value rsid, E.Value luActor, E.Value luInbox, E.Value msince) ->
- (iid, h, rsid, luActor, luInbox, msince)
+ map (\ (E.Value iid, E.Value h, E.Value raid, E.Value luActor, E.Value luInbox, E.Value msince) ->
+ (iid, h, raid, luActor, luInbox, msince)
)
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 = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples
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
:: [((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'))
else do
es <- for lus' $ \ lu -> do
- ma <- runMaybeT
- $ RecipRA <$> MaybeT (getBy $ UniqueRemoteActor iid lu)
- <|> RecipURA <$> MaybeT (getBy $ UniqueUnfetchedRemoteActor iid lu)
- <|> RecipRC <$> MaybeT (getBy $ UniqueRemoteCollection iid lu)
+ ma <- runMaybeT $ do
+ Entity roid ro <- MaybeT $ getBy $ UniqueRemoteObject iid lu
+ recip <- RecipRA <$> MaybeT (getBy $ UniqueRemoteActor roid)
+ <|> RecipURA <$> MaybeT (getBy $ UniqueUnfetchedRemoteActor roid)
+ <|> RecipRC <$> MaybeT (getBy $ UniqueRemoteCollection roid)
+ return (ro, recip)
return $
case ma of
Nothing -> Just $ Left lu
- Just r ->
+ Just (ro, r) ->
case r of
- RecipRA (Entity raid ra) -> Just $ Right $ Left (raid, remoteActorIdent ra, remoteActorInbox ra, remoteActorErrorSince ra)
- RecipURA (Entity uraid ura) -> Just $ Right $ Right (uraid, unfetchedRemoteActorIdent ura, unfetchedRemoteActorSince ura)
+ RecipRA (Entity raid ra) -> Just $ Right $ Left (raid, remoteObjectIdent ro, remoteActorInbox ra, remoteActorErrorSince ra)
+ RecipURA (Entity uraid ura) -> Just $ Right $ Right (uraid, remoteObjectIdent ro, unfetchedRemoteActorSince ura)
RecipRC _ -> Nothing
let (unknown, newKnown) = partitionEithers $ catMaybes $ NE.toList es
(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
unknownDeliv <- for stillUnknown $ \ (i, lus) -> do
-- 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
(i,) <$> insertMany' (\ (_, uraid) -> UnlinkedDelivery uraid obid fwd True) rs
return
( takeNoError4 fetchedDeliv
, takeNoError3 unfetchedDeliv
, map
- (second $ NE.map $ \ ((lu, ak), dlk) -> (ak, lu, dlk))
+ (second $ NE.map $ \ (((lu, _roid), ak), dlk) -> (ak, lu, dlk))
unknownDeliv
)
where
diff --git a/src/Vervis/Discussion.hs b/src/Vervis/Discussion.hs
index 5fc2a59..302156a 100644
--- a/src/Vervis/Discussion.hs
+++ b/src/Vervis/Discussion.hs
@@ -58,17 +58,18 @@ getMessages getdid = runDB $ do
on $ lm ^. LocalMessageRest ==. m ^. MessageId
where_ $ m ^. MessageRoot ==. val did
return (m, lm ^. LocalMessageId, s)
- r <- select $ from $ \ (rm `InnerJoin` m `InnerJoin` rs `InnerJoin` i) -> do
- on $ rs ^. RemoteActorInstance ==. i ^. InstanceId
- on $ rm ^. RemoteMessageAuthor ==. rs ^. RemoteActorId
+ r <- select $ from $ \ (rm `InnerJoin` m `InnerJoin` ra `InnerJoin` ro `InnerJoin` i) -> do
+ on $ ro ^. RemoteObjectInstance ==. i ^. InstanceId
+ on $ ra ^. RemoteActorIdent ==. ro ^. RemoteObjectId
+ on $ rm ^. RemoteMessageAuthor ==. ra ^. RemoteActorId
on $ rm ^. RemoteMessageRest ==. m ^. MessageId
where_ $ m ^. MessageRoot ==. val did
return
( m
, i ^. InstanceHost
, rm ^. RemoteMessageIdent
- , rs ^. RemoteActorIdent
- , rs ^. RemoteActorName
+ , ro ^. RemoteObjectIdent
+ , ra ^. RemoteActorName
)
return $ map mklocal l ++ map mkremote r
where
diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs
index 540e0f4..842e570 100644
--- a/src/Vervis/Federation.hs
+++ b/src/Vervis/Federation.hs
@@ -370,21 +370,20 @@ retryOutboxDelivery = do
(udls, dls, fws) <- runSiteDB $ do
-- Get all unlinked deliveries which aren't running already in outbox
-- post handlers
- unlinked' <- E.select $ E.from $ \ (udl `E.InnerJoin` ob `E.InnerJoin` ura `E.InnerJoin` i `E.LeftOuterJoin` ra `E.LeftOuterJoin` rc) -> do
- E.on $ E.just (ura E.^. UnfetchedRemoteActorInstance) E.==. rc E.?. RemoteCollectionInstance
- E.&&. E.just (ura E.^. UnfetchedRemoteActorIdent) E.==. rc E.?. RemoteCollectionIdent
- E.on $ E.just (ura E.^. UnfetchedRemoteActorInstance) E.==. ra E.?. RemoteActorInstance
- E.&&. E.just (ura E.^. UnfetchedRemoteActorIdent) E.==. ra E.?. RemoteActorIdent
- E.on $ ura E.^. UnfetchedRemoteActorInstance E.==. i E.^. InstanceId
+ 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 (ro E.^. RemoteObjectId) E.==. rc E.?. RemoteCollectionIdent
+ E.on $ E.just (ro E.^. RemoteObjectId) E.==. ra E.?. RemoteActorIdent
+ E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId
+ E.on $ ura E.^. UnfetchedRemoteActorIdent E.==. ro E.^. RemoteObjectId
E.on $ udl E.^. UnlinkedDeliveryRecipient E.==. ura E.^. UnfetchedRemoteActorId
E.on $ udl E.^. UnlinkedDeliveryActivity E.==. ob E.^. OutboxItemId
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
( i E.^. InstanceId
, i E.^. InstanceHost
, ura E.^. UnfetchedRemoteActorId
- , ura E.^. UnfetchedRemoteActorIdent
+ , ro E.^. RemoteObjectIdent
, ura E.^. UnfetchedRemoteActorSince
, udl E.^. UnlinkedDeliveryId
, udl E.^. UnlinkedDeliveryActivity
@@ -410,17 +409,18 @@ retryOutboxDelivery = do
deleteWhere [UnlinkedDeliveryId <-. lonelyOld]
-- Now let's grab the linked deliveries, and similarly delete old ones
-- 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 $ 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.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
( i E.^. InstanceId
, i E.^. InstanceHost
, ra E.^. RemoteActorId
- , ra E.^. RemoteActorIdent
+ , ro E.^. RemoteObjectIdent
, ra E.^. RemoteActorInbox
, ra E.^. RemoteActorErrorSince
, dl E.^. DeliveryId
@@ -430,13 +430,14 @@ retryOutboxDelivery = do
let (linkedOld, linkedNew) = partitionEithers $ map (decideBySinceDL dropAfter now . adaptLinked) linked
deleteWhere [DeliveryId <-. linkedOld]
-- 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 $ 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.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
( i E.^. InstanceId
, i E.^. InstanceHost
diff --git a/src/Vervis/Federation/Auth.hs b/src/Vervis/Federation/Auth.hs
index 645f966..ffcd62c 100644
--- a/src/Vervis/Federation/Auth.hs
+++ b/src/Vervis/Federation/Auth.hs
@@ -145,17 +145,19 @@ verifyActorSig' malgo input (Signature signature) host luKey mluActorHeader = do
Entity iid _ <- MaybeT $ getBy $ UniqueInstance host
MaybeT $ getBy $ UniqueVerifKey iid luKey
for mvk $ \ vk@(Entity _ verifkey) -> do
- mremote <- for (verifKeySharer verifkey) $ \ rsid ->
- (rsid,) <$> getJust rsid
+ mremote <- for (verifKeySharer verifkey) $ \ raid -> do
+ ra <- getJust raid
+ ro <- getJust $ remoteActorIdent ra
+ return (ro, raid, ra)
return (vk, mremote)
case ments of
Just (Entity vkid vk, mremote) -> do
(ua, s, rsid) <-
case mremote of
- Just (rsid, rs) -> do
- let sharer = remoteActorIdent rs
- for_ mluActorHeader $ \ u ->
- if sharer == u
+ Just (ro, rsid, rs) -> do
+ let sharer = remoteObjectIdent ro
+ for_ mluActorHeader $ \ lu ->
+ if sharer == lu
then return ()
else throwE "Key's owner doesn't match actor header"
return (sharer, False, rsid)
diff --git a/src/Vervis/Federation/Offer.hs b/src/Vervis/Federation/Offer.hs
index 5f5db66..68e2124 100644
--- a/src/Vervis/Federation/Offer.hs
+++ b/src/Vervis/Federation/Offer.hs
@@ -247,6 +247,7 @@ followF
Just ractid -> do
let raidAuthor = remoteAuthorId author
ra <- getJust raidAuthor
+ ro <- getJust $ remoteActorIdent ra
(obiid, doc) <-
insertAcceptToOutbox
ra
@@ -255,7 +256,7 @@ followF
newFollow <- insertFollow ractid obiid $ recipFollowers recip
if newFollow
then Right <$> do
- let raInfo = (raidAuthor, remoteActorIdent ra, remoteActorInbox ra, remoteActorErrorSince ra)
+ let raInfo = (raidAuthor, remoteObjectIdent ro, remoteActorInbox ra, remoteActorErrorSince ra)
iidAuthor = remoteAuthorInstance author
hAuthor = objUriAuthority $ remoteAuthorURI author
hostSection = ((iidAuthor, hAuthor), raInfo :| [])
diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs
index 4c76aae..7020796 100644
--- a/src/Vervis/Federation/Ticket.hs
+++ b/src/Vervis/Federation/Ticket.hs
@@ -371,7 +371,8 @@ projectOfferTicketF
moreRemotes <- deliverLocal now sid (projectFollowers project) obiid
let raidAuthor = remoteAuthorId author
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
hAuthor = objUriAuthority $ remoteAuthorURI author
hostSection = ((iidAuthor, hAuthor), raInfo :| [])
diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs
index b09c609..c7d73d6 100644
--- a/src/Vervis/Handler/Discussion.hs
+++ b/src/Vervis/Handler/Discussion.hs
@@ -94,12 +94,13 @@ getNode getdid mid = do
return $ MessageTreeNodeLocal lmid s
(Nothing, Just (Entity _rmid rm)) -> do
rs <- getJust $ remoteMessageAuthor rm
- i <- getJust $ remoteActorInstance rs
+ ro <- getJust $ remoteActorIdent rs
+ i <- getJust $ remoteObjectInstance ro
return $
MessageTreeNodeRemote
(instanceHost i)
(remoteMessageIdent rm)
- (remoteActorIdent rs)
+ (remoteObjectIdent ro)
(remoteActorName rs)
return $ MessageTreeNode mid m author
@@ -154,8 +155,9 @@ getDiscussionMessage shr lmid = do
return $ route2fed $ MessageR (sharerIdent s) lmhidParent
(Nothing, Just rmParent) -> do
rs <- getJust $ remoteMessageAuthor rmParent
- i <- getJust $ remoteActorInstance rs
- return $ ObjURI (instanceHost i) (remoteActorIdent rs)
+ ro <- getJust $ remoteActorIdent rs
+ i <- getJust $ remoteObjectInstance ro
+ return $ ObjURI (instanceHost i) (remoteObjectIdent ro)
--ob <- getJust $ localMessageCreate lm
--let activity = docValue $ persistJSONValue $ outboxItemActivity ob
diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs
index 6d71f76..9005c54 100644
--- a/src/Vervis/Handler/Ticket.hs
+++ b/src/Vervis/Handler/Ticket.hs
@@ -193,8 +193,9 @@ getTicketR shar proj num = do
(do mtar <- getValBy $ UniqueTicketAuthorRemote tid
for mtar $ \ tar -> do
ra <- getJust $ ticketAuthorRemoteAuthor tar
- i <- getJust $ remoteActorInstance ra
- return (i, ra)
+ ro <- getJust $ remoteActorIdent ra
+ i <- getJust $ remoteObjectInstance ro
+ return (i, ro, ra)
)
"Ticket doesn't have author"
"Ticket has both local and remote author"
@@ -250,8 +251,8 @@ getTicketR shar proj num = do
encodeRouteHome <- getEncodeRouteHome
let host =
case author of
- Left _ -> hLocal
- Right (i, _) -> instanceHost i
+ Left _ -> hLocal
+ Right (i, _, _) -> instanceHost i
ticketAP = AP.Ticket
{ AP.ticketLocal = Just
( hLocal
@@ -279,8 +280,8 @@ getTicketR shar proj num = do
case author of
Left sharer ->
encodeRouteLocal $ SharerR $ sharerIdent sharer
- Right (_inztance, actor) ->
- remoteActorIdent actor
+ Right (_inztance, object, _actor) ->
+ remoteObjectIdent object
, AP.ticketPublished = Just $ ticketCreated ticket
, AP.ticketUpdated = Nothing
, AP.ticketName = Just $ "#" <> T.pack (show num)
@@ -759,9 +760,10 @@ getTicketDeps forward shr prj num = do
\ ( td
`E.InnerJoin` t
`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
- 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 $ E.just (t E.^. TicketId) E.==. tar E.?. TicketAuthorRemoteTicket
E.on $ p E.?. PersonIdent E.==. s E.?. SharerId
@@ -775,19 +777,20 @@ getTicketDeps forward shr prj num = do
, t E.^. TicketNumber
, s
, i
+ , ro
, ra
, t E.^. TicketTitle
, t E.^. TicketStatus
)
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
, ( number
- , case (ms, mi, mra) of
- (Just s, Nothing, Nothing) ->
+ , case (ms, mi, mro, mra) of
+ (Just s, Nothing, Nothing, Nothing) ->
Left $ entityVal s
- (Nothing, Just i, Just ra) ->
- Right (entityVal i, entityVal ra)
+ (Nothing, Just i, Just ro, Just ra) ->
+ Right (entityVal i, entityVal ro, entityVal ra)
_ -> error "Ticket author DB invalid state"
, title
, status
diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs
index 0378fbe..cce628e 100644
--- a/src/Vervis/Migration.hs
+++ b/src/Vervis/Migration.hs
@@ -1124,6 +1124,98 @@ changes hLocal ctx =
, removeField "RemoteActivity" "ident"
-- 158
, 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
diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs
index fcf5410..75af9e2 100644
--- a/src/Vervis/Migration/Model.hs
+++ b/src/Vervis/Migration/Model.hs
@@ -130,6 +130,14 @@ module Vervis.Migration.Model
, RemoteObject152Generic (..)
, RemoteActivity152Generic (..)
, RemoteActivity152
+ , Instance159Generic (..)
+ , RemoteObject159Generic (..)
+ , RemoteActor159Generic (..)
+ , RemoteActor159
+ , UnfetchedRemoteActor159Generic (..)
+ , UnfetchedRemoteActor159
+ , RemoteCollection159Generic (..)
+ , RemoteCollection159
)
where
@@ -266,3 +274,6 @@ model_2019_11_04 = $(schema "2019_11_04")
makeEntitiesMigration "152"
$(modelFile "migrations/2019_11_04_remote_activity_ident.model")
+
+makeEntitiesMigration "159"
+ $(modelFile "migrations/2019_11_05_remote_actor_ident.model")
diff --git a/src/Vervis/RemoteActorStore.hs b/src/Vervis/RemoteActorStore.hs
index 816f213..c7c6899 100644
--- a/src/Vervis/RemoteActorStore.hs
+++ b/src/Vervis/RemoteActorStore.hs
@@ -138,8 +138,9 @@ instanceAndActor
-> YesodDB site (InstanceId, RemoteActorId, Maybe Bool)
instanceAndActor host luActor mname luInbox = do
(iid, inew) <- idAndNew <$> insertBy' (Instance host)
- (raid, ranew) <-
- idAndNew <$> insertBy' (RemoteActor luActor iid mname luInbox Nothing)
+ (raid, ranew) <- do
+ roid <- either entityKey id <$> insertBy' (RemoteObject iid luActor)
+ idAndNew <$> insertBy' (RemoteActor roid mname luInbox Nothing)
return $
( iid
, raid
@@ -337,11 +338,15 @@ keyListedByActorShared iid vkid host luKey luActor = do
RoomModeInstant -> do
when reject $ throwE "Actor key storage limit is 0 and set to reject"
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
eresult <- 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 _) ->
(rsid,) . isJust <$>
getBy (UniqueVerifKeySharedUsage vkid rsid)
@@ -360,7 +365,9 @@ keyListedByActorShared iid vkid host luKey luActor = do
vkExists <- isJust <$> get vkid
case mrsid of
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
return $ Right rsid
Just rsid -> runExceptT $ do
@@ -469,9 +476,10 @@ actorFetchShareAction
-> IO (Either (Maybe APGetError) (Maybe (Entity RemoteActor)))
actorFetchShareAction u (site, iid) = flip runWorkerT site $ do
let ObjURI h lu = u
- mrecip <- runSiteDB $ runMaybeT
- $ Left <$> MaybeT (getBy $ UniqueRemoteActor iid lu)
- <|> Right <$> MaybeT (getBy $ UniqueRemoteCollection iid lu)
+ mrecip <- runSiteDB $ runMaybeT $
+ MaybeT (getKeyBy $ UniqueRemoteObject iid lu) >>= \ roid ->
+ Left <$> MaybeT (getBy $ UniqueRemoteActor roid)
+ <|> Right <$> MaybeT (getBy $ UniqueRemoteCollection roid)
case mrecip of
Just recip ->
return $ Right $
@@ -483,18 +491,20 @@ actorFetchShareAction u (site, iid) = flip runWorkerT site $ do
erecip <- fetchRecipient manager h lu
for erecip $ \ recip ->
case recip of
- RecipientActor actor -> runSiteDB $
+ RecipientActor actor -> runSiteDB $ do
+ roid <- either entityKey id <$> insertBy' (RemoteObject iid lu)
let ra = RemoteActor
- { remoteActorIdent = lu
- , remoteActorInstance = iid
+ { remoteActorIdent = roid
, remoteActorName =
actorName actor <|> actorUsername actor
, remoteActorInbox = actorInbox actor
, remoteActorErrorSince = Nothing
}
- in Just . either id (flip Entity ra) <$> insertBy' ra
+ Just . either id (flip Entity ra) <$> insertBy' ra
RecipientCollection _ -> runSiteDB $ do
- insertUnique_ $ RemoteCollection iid lu
+ mroid <- insertUnique $ RemoteObject iid lu
+ for_ mroid $ \ roid ->
+ insertUnique_ $ RemoteCollection roid
return Nothing
fetchRemoteActor
@@ -517,9 +527,10 @@ fetchRemoteActor
(Either (Maybe APGetError) (Maybe (Entity RemoteActor)))
)
fetchRemoteActor iid host luActor = do
- mrecip <- runSiteDB $ runMaybeT
- $ Left <$> MaybeT (getBy $ UniqueRemoteActor iid luActor)
- <|> Right <$> MaybeT (getBy $ UniqueRemoteCollection iid luActor)
+ mrecip <- runSiteDB $ runMaybeT $
+ MaybeT (getKeyBy $ UniqueRemoteObject iid luActor) >>= \ roid ->
+ Left <$> MaybeT (getBy $ UniqueRemoteActor roid)
+ <|> Right <$> MaybeT (getBy $ UniqueRemoteCollection roid)
case mrecip of
Just recip ->
return $ Right $ Right $
diff --git a/src/Vervis/Ticket.hs b/src/Vervis/Ticket.hs
index 8066d2b..204ab2c 100644
--- a/src/Vervis/Ticket.hs
+++ b/src/Vervis/Ticket.hs
@@ -48,13 +48,14 @@ getTicketSummaries
getTicketSummaries mfilt morder jid = fmap (map toSummary) $ select $ from $
\ ( t
`LeftOuterJoin` (tal `InnerJoin` p `InnerJoin` s)
- `LeftOuterJoin` (tar `InnerJoin` ra `InnerJoin` i)
+ `LeftOuterJoin` (tar `InnerJoin` ra `InnerJoin` ro `InnerJoin` i)
`InnerJoin` d
`LeftOuterJoin` m
) -> do
on $ just (d ^. DiscussionId) ==. m ?. MessageRoot
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 $ just (t ^. TicketId) ==. tar ?. TicketAuthorRemoteTicket
on $ p ?. PersonIdent ==. s ?. SharerId
@@ -71,6 +72,7 @@ getTicketSummaries mfilt morder jid = fmap (map toSummary) $ select $ from $
( t ^. TicketNumber
, s
, i
+ , ro
, ra
, t ^. TicketCreated
, t ^. TicketTitle
@@ -78,15 +80,15 @@ getTicketSummaries mfilt morder jid = fmap (map toSummary) $ select $ from $
, count $ m ?. MessageId
)
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
{ tsNumber = n
, tsCreatedBy =
- case (ms, mi, mra) of
- (Just s, Nothing, Nothing) ->
+ case (ms, mi, mro, mra) of
+ (Just s, Nothing, Nothing, Nothing) ->
Left $ entityVal s
- (Nothing, Just i, Just ra) ->
- Right (entityVal i, entityVal ra)
+ (Nothing, Just i, Just ro, Just ra) ->
+ Right (entityVal i, entityVal ro, entityVal ra)
_ -> error "Ticket author DB invalid state"
, tsCreatedAt = c
, tsTitle = t
diff --git a/src/Vervis/Widget/Sharer.hs b/src/Vervis/Widget/Sharer.hs
index e85e7bf..008a78a 100644
--- a/src/Vervis/Widget/Sharer.hs
+++ b/src/Vervis/Widget/Sharer.hs
@@ -46,18 +46,18 @@ sharerLinkW sharer =
#{shr2text $ sharerIdent sharer}
|]
-sharerLinkFedW :: Either Sharer (Instance, RemoteActor) -> Widget
-sharerLinkFedW (Left sharer) = sharerLinkW sharer
-sharerLinkFedW (Right (inztance, actor)) =
+sharerLinkFedW :: Either Sharer (Instance, RemoteObject, RemoteActor) -> Widget
+sharerLinkFedW (Left sharer) = sharerLinkW sharer
+sharerLinkFedW (Right (inztance, object, actor)) =
[whamlet|
$maybe name <- remoteActorName actor
#{name}
$nothing
- #{renderAuthority $ instanceHost inztance}#{localUriPath $ remoteActorIdent actor}
+ #{renderAuthority $ instanceHost inztance}#{localUriPath $ remoteObjectIdent object}
|]
where
- uActor = ObjURI (instanceHost inztance) (remoteActorIdent actor)
+ uActor = ObjURI (instanceHost inztance) (remoteObjectIdent object)
followW :: Route App -> Route App -> AppDB FollowerSetId -> Widget
followW followRoute unfollowRoute getFsid = do
diff --git a/src/Vervis/Widget/Ticket.hs b/src/Vervis/Widget/Ticket.hs
index d16fbc4..365bc90 100644
--- a/src/Vervis/Widget/Ticket.hs
+++ b/src/Vervis/Widget/Ticket.hs
@@ -47,7 +47,7 @@ import Vervis.Widget.Sharer
data TicketSummary = TicketSummary
{ tsNumber :: Int
- , tsCreatedBy :: Either Sharer (Instance, RemoteActor)
+ , tsCreatedBy :: Either Sharer (Instance, RemoteObject, RemoteActor)
, tsCreatedAt :: UTCTime
, tsTitle :: Text
, tsStatus :: TicketStatus