forge/Vervis
1
0
Fork 0
Code Pull requests Activity

DB: Use RemoteObject in UnfetchedRemoteActor, RemoteActor, RemoteCollection

Browse source
This commit is contained in:
fr33domlover 2019-11-06 19:47:50 +00:00
parent acb86ab621
commit f8dd72d052
19 changed files with 308 additions and 112 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

31
config/models
View file

@ -12,6 +12,15 @@
-- with this software. If not, see
-- <http://creativecommons.org/publicdomain/zero/1.0/>.
-------------------------------------------------------------------------------
-- 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

5
migrations/2019_11_04.model Normal file
View file

@ -0,0 +1,5 @@
RemoteObject
instance InstanceId
ident LocalURI
UniqueRemoteObject instance ident

20
migrations/2019_11_04_remote_activity_ident.model Normal file
View 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
View 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

7
src/Vervis/API.hs
View file

@ -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]

44
src/Vervis/ActivityPub.hs
View file

@ -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

11
src/Vervis/Discussion.hs
View file

@ -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

31
src/Vervis/Federation.hs
View file

@ -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

14
src/Vervis/Federation/Auth.hs
View file

@ -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)

3
src/Vervis/Federation/Offer.hs
View file

@ -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 :| [])

3
src/Vervis/Federation/Ticket.hs
View file

@ -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 :| [])

10
src/Vervis/Handler/Discussion.hs
View file

@ -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

29
src/Vervis/Handler/Ticket.hs
View file

@ -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

92
src/Vervis/Migration.hs
View file

@ -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

11
src/Vervis/Migration/Model.hs
View file

@ -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")

43
src/Vervis/RemoteActorStore.hs
View file

@ -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 $

16
src/Vervis/Ticket.hs
View file

@ -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

10
src/Vervis/Widget/Sharer.hs
View file

@ -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|
<a href="#{renderObjURI uActor}">
$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

2
src/Vervis/Widget/Ticket.hs
View file

@ -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