diff --git a/src/Vervis/Web/Delivery.hs b/src/Vervis/Web/Delivery.hs index 7bf1f6f..386cdd0 100644 --- a/src/Vervis/Web/Delivery.hs +++ b/src/Vervis/Web/Delivery.hs @@ -87,6 +87,7 @@ import Vervis.Data.Actor import Vervis.FedURI import Vervis.Foundation import Vervis.Model +import Vervis.Persist.Actor import Vervis.Recipient import Vervis.RemoteActorStore import Vervis.Settings @@ -893,14 +894,6 @@ fork action = do return False Right success -> return success -localActor Nothing Nothing Nothing Nothing Nothing = error "Found unused Actor" -localActor (Just p) Nothing Nothing Nothing Nothing = LocalActorPerson p -localActor Nothing (Just g) Nothing Nothing Nothing = LocalActorGroup g -localActor Nothing Nothing (Just r) Nothing Nothing = LocalActorRepo r -localActor Nothing Nothing Nothing (Just d) Nothing = LocalActorDeck d -localActor Nothing Nothing Nothing Nothing (Just l) = LocalActorLoom l -localActor _ _ _ _ _ = error "Found multiple-use Actor" - retryUnlinkedDelivery :: Worker () retryUnlinkedDelivery = do now <- liftIO $ getCurrentTime @@ -909,18 +902,7 @@ retryUnlinkedDelivery = do -- Get all unlinked deliveries which aren't running already in outbox -- post handlers unlinked' <- E.select $ E.from $ - \ (udl `E.InnerJoin` obi `E.InnerJoin` a `E.InnerJoin` ura `E.InnerJoin` ro `E.InnerJoin` i `E.LeftOuterJoin` ra `E.LeftOuterJoin` rc - `E.LeftOuterJoin` p - `E.LeftOuterJoin` g - `E.LeftOuterJoin` r - `E.LeftOuterJoin` d - `E.LeftOuterJoin` l - ) -> do - E.on $ E.just (a E.^. ActorId) E.==. l E.?. LoomActor - E.on $ E.just (a E.^. ActorId) E.==. d E.?. DeckActor - E.on $ E.just (a E.^. ActorId) E.==. r E.?. RepoActor - E.on $ E.just (a E.^. ActorId) E.==. g E.?. GroupActor - E.on $ E.just (a E.^. ActorId) E.==. p E.?. PersonActor + \ (udl `E.InnerJoin` obi `E.InnerJoin` a `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 @@ -941,23 +923,16 @@ retryUnlinkedDelivery = do , obi E.^. OutboxItemActivity , ra E.?. RemoteActorId , rc E.?. RemoteCollectionId - , a E.^. ActorId - - , p E.?. PersonId - , g E.?. GroupId - , r E.?. RepoId - , d E.?. DeckId - , l E.?. LoomId ) -- Strip the E.Value wrappers and organize the records for the -- filtering and grouping we'll need to do - let unlinked = map adaptUnlinked unlinked' + unlinked <- traverse adaptUnlinked unlinked' -- Split into found (recipient has been reached) and lonely (recipient -- hasn't been reached - (found, lonely) = partitionMaybes unlinked + let (found, lonely) = partitionMaybes unlinked -- Turn the found ones into linked deliveries deleteWhere [UnlinkedDeliveryId <-. map (unlinkedID . snd) found] @@ -988,10 +963,9 @@ retryUnlinkedDelivery = do where - adaptUnlinked - ( Entity iid (Instance h), E.Value uraid, E.Value luRecip, E.Value since, E.Value udlid, E.Value obid, E.Value fwd, E.Value act, E.Value mraid, E.Value mrcid - , E.Value actorID, E.Value mp, E.Value mg, E.Value mr, E.Value md, E.Value ml - ) = + adaptUnlinked (Entity iid (Instance h), E.Value uraid, E.Value luRecip, E.Value since, E.Value udlid, E.Value obid, E.Value fwd, E.Value act, E.Value mraid, E.Value mrcid, E.Value actorID) = do + actorByKey <- getLocalActor actorID + return ( Left <$> mraid <|> Right <$> mrcid , ( ( (iid, h) , ( (uraid, luRecip) @@ -1000,7 +974,7 @@ retryUnlinkedDelivery = do , obid , BL.fromStrict $ persistJSONBytes act , actorID - , localActor mp mg mr md ml + , actorByKey ) ) ) @@ -1073,18 +1047,7 @@ retryLinkedDelivery = do -- 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` ro `E.InnerJoin` i `E.InnerJoin` obi `E.InnerJoin` a - `E.LeftOuterJoin` p - `E.LeftOuterJoin` g - `E.LeftOuterJoin` r - `E.LeftOuterJoin` d - `E.LeftOuterJoin` l - ) -> do - E.on $ E.just (a E.^. ActorId) E.==. l E.?. LoomActor - E.on $ E.just (a E.^. ActorId) E.==. d E.?. DeckActor - E.on $ E.just (a E.^. ActorId) E.==. r E.?. RepoActor - E.on $ E.just (a E.^. ActorId) E.==. g E.?. GroupActor - E.on $ E.just (a E.^. ActorId) E.==. p E.?. PersonActor + \ (dl `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i `E.InnerJoin` obi `E.InnerJoin` a) -> do E.on $ obi E.^. OutboxItemOutbox E.==. a E.^. ActorOutbox E.on $ dl E.^. DeliveryActivity E.==. obi E.^. OutboxItemId E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId @@ -1102,19 +1065,12 @@ retryLinkedDelivery = do , dl E.^. DeliveryId , dl E.^. DeliveryForwarding , obi E.^. OutboxItemActivity - , a E.^. ActorId - - , p E.?. PersonId - , g E.?. GroupId - , r E.?. RepoId - , d E.?. DeckId - , l E.?. LoomId ) dropAfter <- lift $ asksSite $ appDropDeliveryAfter . appSettings + linked' <- traverse adaptLinked linked let (linkedOld, linkedNew) = - partitionEithers $ - map (decideBySinceDL dropAfter now . adaptLinked) linked + partitionEithers $ map (decideBySinceDL dropAfter now) linked' deleteWhere [DeliveryId <-. linkedOld] return $ groupLinked linkedNew @@ -1134,17 +1090,16 @@ retryLinkedDelivery = do where - adaptLinked - ( E.Value iid, E.Value h, E.Value raid, E.Value ident, E.Value inbox, E.Value since, E.Value dlid, E.Value fwd, E.Value act - , E.Value actorID, E.Value mp, E.Value mg, E.Value mr, E.Value md, E.Value ml - ) = + adaptLinked (E.Value iid, E.Value h, E.Value raid, E.Value ident, E.Value inbox, E.Value since, E.Value dlid, E.Value fwd, E.Value act, E.Value actorID) = do + actorByKey <- getLocalActor actorID + return ( ( (iid, h) , ( (raid, (ident, inbox)) , ( dlid , fwd , BL.fromStrict $ persistJSONBytes act , actorID - , localActor mp mg mr md ml + , actorByKey ) ) ) @@ -1205,36 +1160,18 @@ retryForwarding = do -- Same for forwarding deliveries, which are always linked forwarding <- E.select $ E.from $ - \ (fw `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i - `E.LeftOuterJoin` p - `E.LeftOuterJoin` g - `E.LeftOuterJoin` r - `E.LeftOuterJoin` d - `E.LeftOuterJoin` l - ) -> do - E.on $ E.just (fw E.^. ForwardingForwarder) E.==. l E.?. LoomActor - E.on $ E.just (fw E.^. ForwardingForwarder) E.==. d E.?. DeckActor - E.on $ E.just (fw E.^. ForwardingForwarder) E.==. r E.?. RepoActor - E.on $ E.just (fw E.^. ForwardingForwarder) E.==. g E.?. GroupActor - E.on $ E.just (fw E.^. ForwardingForwarder) E.==. p E.?. PersonActor + \ (fw `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 $ fw E.^. ForwardingRecipient E.==. ra E.^. RemoteActorId E.where_ $ fw E.^. ForwardingRunning E.==. E.val False E.orderBy [E.asc $ ro E.^. RemoteObjectInstance, E.asc $ ra E.^. RemoteActorId] - return - (i, ra, fw - , p E.?. PersonId - , g E.?. GroupId - , r E.?. RepoId - , d E.?. DeckId - , l E.?. LoomId - ) + return (i, ra, fw) dropAfter <- lift $ asksSite $ appDropDeliveryAfter . appSettings + forwarding' <- traverse adaptForwarding forwarding let (forwardingOld, forwardingNew) = partitionEithers $ - map (decideBySinceFW dropAfter now . adaptForwarding) - forwarding + map (decideBySinceFW dropAfter now) forwarding' deleteWhere [ForwardingId <-. forwardingOld] return $ groupForwarding forwardingNew @@ -1258,20 +1195,21 @@ retryForwarding = do ( Entity iid (Instance h) , Entity raid (RemoteActor _ _ inbox _ since) , Entity fwid (Forwarding _ _ body sig fwderID _) - , E.Value mp, E.Value mg, E.Value mr, E.Value md, E.Value ml - ) = - ( ( (iid, h) - , ( (raid, inbox) - , ( fwid - , BL.fromStrict body - , localActor mp mg mr md ml - , sig - , fwderID + ) = do + actorByKey <- getLocalActor fwderID + return + ( ( (iid, h) + , ( (raid, inbox) + , ( fwid + , BL.fromStrict body + , actorByKey + , sig + , fwderID + ) + ) ) + , since ) - ) - , since - ) decideBySinceFW dropAfter now (fw@(_, (_, (fwid, _, _, _, _))), msince) = case msince of