forge/Vervis
1
0
Fork 0
Code Pull requests Activity

DB: Switch RemoteMessage to use RemoteObject

Browse source
This commit is contained in:
fr33domlover 2020-02-10 14:07:00 +00:00
parent c03dacdb11
commit 00e0f7c14f
9 changed files with 94 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
config/models
View file

@ -1,6 +1,6 @@
-- This file is part of Vervis.
--
-- Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
-- Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
--
-- ♡ Copying is an act of love. Please copy, reuse and share.
--
@ -439,14 +439,13 @@ LocalMessage
RemoteMessage
author RemoteActorId
instance InstanceId
ident LocalURI
ident RemoteObjectId
rest MessageId
create RemoteActivityId
lostParent FedURI Maybe
UniqueRemoteMessageIdent instance ident
UniqueRemoteMessage rest
UniqueRemoteMessageIdent ident
UniqueRemoteMessage rest
UniqueRemoteMessageCreate create
RepoCollab

23
migrations/2020_02_10_rm_point_to_ro.model Normal file
View file

@ -0,0 +1,23 @@
Instance
host Host
UniqueInstance host
RemoteObject
instance InstanceId
ident LocalURI
UniqueRemoteObject instance ident
RemoteMessage
author Int64
instance InstanceId
ident LocalURI
identNew RemoteObjectId
rest Int64
create Int64
lostParent FedURI Maybe
UniqueRemoteMessageIdent instance ident
UniqueRemoteMessage rest
UniqueRemoteMessageCreate create

6
src/Vervis/API.hs
View file

@ -181,7 +181,8 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
Right (ObjURI hParent luParent) -> do
mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent roid
rm <- fromMaybeE mrm "Remote parent unknown locally"
let mid = remoteMessageRest rm
m <- lift $ getJust mid
@ -216,7 +217,8 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
Right p@(ObjURI hParent luParent) -> do
mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent roid
case mrm of
Nothing -> return $ Right p
Just rm -> Left <$> do

5
src/Vervis/Client.hs
View file

@ -123,8 +123,9 @@ createReply shrAuthor (TextPandocMarkdown msg) hDest recipsA recipsC context mid
lmkhid <- encodeKeyHashid lmidParent
return $ encodeRouteHome $ MessageR (sharerIdent s) lmkhid
(Nothing, Just rm) -> do
i <- getJust $ remoteMessageInstance rm
return $ ObjURI (instanceHost i) (remoteMessageIdent rm)
ro <- getJust $ remoteMessageIdent rm
i <- getJust $ remoteObjectInstance ro
return $ ObjURI (instanceHost i) (remoteObjectIdent ro)
contentHtml <- ExceptT . pure $ renderPandocMarkdown msg
let uContext = encodeRecipRoute context
recips = recipsA ++ recipsC

5
src/Vervis/Discussion.hs
View file

@ -58,7 +58,8 @@ 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` ra `InnerJoin` ro `InnerJoin` i) -> do
r <- select $ from $ \ (rm `InnerJoin` m `InnerJoin` ra `InnerJoin` ro `InnerJoin` i `InnerJoin` ro2) -> do
on $ rm ^. RemoteMessageIdent ==. ro2 ^. RemoteObjectId
on $ ro ^. RemoteObjectInstance ==. i ^. InstanceId
on $ ra ^. RemoteActorIdent ==. ro ^. RemoteObjectId
on $ rm ^. RemoteMessageAuthor ==. ra ^. RemoteActorId
@ -67,7 +68,7 @@ getMessages getdid = runDB $ do
return
( m
, i ^. InstanceHost
, rm ^. RemoteMessageIdent
, ro2 ^. RemoteObjectIdent
, ro ^. RemoteObjectIdent
, ra ^. RemoteActorName
)

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

@ -122,7 +122,8 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext
Right (ObjURI hParent luParent) -> do
mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent roid
for_ mrm $ \ rm -> do
let mid = remoteMessageRest rm
m <- lift $ getJust mid
@ -142,7 +143,8 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext
Right (ObjURI hParent luParent) -> do
mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent roid
for_ mrm $ \ rm -> do
let mid = remoteMessageRest rm
m <- lift $ getJust mid
@ -257,7 +259,8 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
Right p@(ObjURI hParent luParent) -> do
mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent roid
case mrm of
Just rm -> Left <$> do
let mid = remoteMessageRest rm
@ -287,10 +290,11 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
_ -> Nothing
, messageRoot = did
}
roid2 <-
either entityKey id <$> insertBy' (RemoteObject iidAuthor luNote)
mrmid <- insertUnique RemoteMessage
{ remoteMessageAuthor = raidAuthor
, remoteMessageInstance = iidAuthor
, remoteMessageIdent = luNote
, remoteMessageIdent = roid2
, remoteMessageRest = mid
, remoteMessageCreate = ractid
, remoteMessageLostParent =

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

@ -93,15 +93,16 @@ getNode getdid mid = do
s <- getJust $ personIdent p
return $ MessageTreeNodeLocal lmid s
(Nothing, Just (Entity _rmid rm)) -> do
rs <- getJust $ remoteMessageAuthor rm
ro <- getJust $ remoteActorIdent rs
i <- getJust $ remoteObjectInstance ro
ra <- getJust $ remoteMessageAuthor rm
roA <- getJust $ remoteActorIdent ra
roM <- getJust $ remoteMessageIdent rm
i <- getJust $ remoteObjectInstance roA
return $
MessageTreeNodeRemote
(instanceHost i)
(remoteMessageIdent rm)
(remoteObjectIdent ro)
(remoteActorName rs)
(remoteObjectIdent roM)
(remoteObjectIdent roA)
(remoteActorName ra)
return $ MessageTreeNode mid m author
{-

34
src/Vervis/Migration.hs
View file

@ -1472,6 +1472,40 @@ changes hLocal ctx =
Unique "UniqueTicketUnderProjectAuthor" ["author"]
-- 226
, removeUnique "TicketUnderProject" "UniqueTicketUnderProject"
-- 227
, addFieldRefRequired''
"RemoteMessage"
(do iid <- insert $ Instance227 $ Authority "227.fake.fake" Nothing
insertEntity $ RemoteObject227 iid $ LocalURI "/fake/227"
)
(Just $ \ (Entity roidTemp roTemp) -> do
rmids <- selectList ([] :: [Filter RemoteMessage227]) []
for_ rmids $ \ (Entity rmid rm) -> do
let iid = remoteMessage227Instance rm
lu = remoteMessage227Ident rm
roid <- insert $ RemoteObject227 iid lu
update rmid [RemoteMessage227IdentNew =. roid]
delete roidTemp
delete $ remoteObject227Instance roTemp
)
"identNew"
"RemoteObject"
-- 228
, addUnique "RemoteMessage" $
Unique "UniqueRemoteMessageIdentNew" ["identNew"]
-- 229
, removeUnique "RemoteMessage" "UniqueRemoteMessageIdent"
-- 230
, renameUnique
"RemoteMessage"
"UniqueRemoteMessageIdentNew"
"UniqueRemoteMessageIdent"
-- 231
, removeField "RemoteMessage" "instance"
-- 232
, removeField "RemoteMessage" "ident"
-- 233
, renameField "RemoteMessage" "identNew" "ident"
]
migrateDB

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

@ -176,6 +176,10 @@ module Vervis.Migration.Model
, RemoteDiscussion215Generic (..)
, model_2020_02_09
, TicketUnderProject223Generic (..)
, Instance227Generic (..)
, RemoteObject227Generic (..)
, RemoteMessage227
, RemoteMessage227Generic (..)
)
where
@ -343,3 +347,6 @@ model_2020_02_09 = $(schema "2020_02_09_tup")
makeEntitiesMigration "223"
$(modelFile "migrations/2020_02_09_tup_mig.model")
makeEntitiesMigration "227"
$(modelFile "migrations/2020_02_10_rm_point_to_ro.model")