mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-27 15:24:51 +09:00
DB: Use RemoteObject in UnfetchedRemoteActor, RemoteActor, RemoteCollection
This commit is contained in:
parent
acb86ab621
commit
f8dd72d052
19 changed files with 308 additions and 112 deletions
|
@ -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
|
||||||
|
|
5
migrations/2019_11_04.model
Normal file
5
migrations/2019_11_04.model
Normal file
|
@ -0,0 +1,5 @@
|
||||||
|
RemoteObject
|
||||||
|
instance InstanceId
|
||||||
|
ident LocalURI
|
||||||
|
|
||||||
|
UniqueRemoteObject instance ident
|
20
migrations/2019_11_04_remote_activity_ident.model
Normal file
20
migrations/2019_11_04_remote_activity_ident.model
Normal 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
|
38
migrations/2019_11_05_remote_actor_ident.model
Normal file
38
migrations/2019_11_05_remote_actor_ident.model
Normal 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
|
|
@ -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]
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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 :| [])
|
||||||
|
|
|
@ -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 :| [])
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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")
|
||||||
|
|
|
@ -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 $
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue