From f8dd72d0520bfe8d1841000439b470d92251cdec Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Wed, 6 Nov 2019 19:47:50 +0000 Subject: [PATCH] DB: Use RemoteObject in UnfetchedRemoteActor, RemoteActor, RemoteCollection --- config/models | 31 ++++--- migrations/2019_11_04.model | 5 + .../2019_11_04_remote_activity_ident.model | 20 ++++ .../2019_11_05_remote_actor_ident.model | 38 ++++++++ src/Vervis/API.hs | 7 +- src/Vervis/ActivityPub.hs | 44 +++++---- src/Vervis/Discussion.hs | 11 ++- src/Vervis/Federation.hs | 31 ++++--- src/Vervis/Federation/Auth.hs | 14 +-- src/Vervis/Federation/Offer.hs | 3 +- src/Vervis/Federation/Ticket.hs | 3 +- src/Vervis/Handler/Discussion.hs | 10 +- src/Vervis/Handler/Ticket.hs | 29 +++--- src/Vervis/Migration.hs | 92 +++++++++++++++++++ src/Vervis/Migration/Model.hs | 11 +++ src/Vervis/RemoteActorStore.hs | 43 +++++---- src/Vervis/Ticket.hs | 16 ++-- src/Vervis/Widget/Sharer.hs | 10 +- src/Vervis/Widget/Ticket.hs | 2 +- 19 files changed, 308 insertions(+), 112 deletions(-) create mode 100644 migrations/2019_11_04.model create mode 100644 migrations/2019_11_04_remote_activity_ident.model create mode 100644 migrations/2019_11_05_remote_actor_ident.model 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