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