DB: Switch RemoteMessage to use RemoteObject

config/models

@@ -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,13 +439,12 @@ LocalMessage
 
 RemoteMessage
     author     RemoteActorId
-    instance   InstanceId
+    ident      RemoteObjectId
-    ident      LocalURI
     rest       MessageId
     create     RemoteActivityId
     lostParent FedURI            Maybe
 
-    UniqueRemoteMessageIdent instance ident
+    UniqueRemoteMessageIdent  ident
     UniqueRemoteMessage       rest
     UniqueRemoteMessageCreate create
 

migrations/2020_02_10_rm_point_to_ro.model

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

src/Vervis/API.hs

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

src/Vervis/Client.hs

@@ -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
+                ro <- getJust $ remoteMessageIdent rm
-                return $ ObjURI (instanceHost i) (remoteMessageIdent rm)
+                i <- getJust $ remoteObjectInstance ro
+                return $ ObjURI (instanceHost i) (remoteObjectIdent ro)
     contentHtml <- ExceptT . pure $ renderPandocMarkdown msg
     let uContext = encodeRecipRoute context
         recips = recipsA ++ recipsC

src/Vervis/Discussion.hs

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

src/Vervis/Federation/Discussion.hs

@@ -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      = roid2
-            , remoteMessageIdent      = luNote
             , remoteMessageRest       = mid
             , remoteMessageCreate     = ractid
             , remoteMessageLostParent =

src/Vervis/Handler/Discussion.hs

@@ -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
+            ra <- getJust $ remoteMessageAuthor rm
-            ro <- getJust $ remoteActorIdent rs
+            roA <- getJust $ remoteActorIdent ra
-            i <- getJust $ remoteObjectInstance ro
+            roM <- getJust $ remoteMessageIdent rm
+            i <- getJust $ remoteObjectInstance roA
             return $
                 MessageTreeNodeRemote
                     (instanceHost i)
-                    (remoteMessageIdent rm)
+                    (remoteObjectIdent roM)
-                    (remoteObjectIdent ro)
+                    (remoteObjectIdent roA)
-                    (remoteActorName rs)
+                    (remoteActorName ra)
     return $ MessageTreeNode mid m author
 
 {-

src/Vervis/Migration.hs

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

src/Vervis/Migration/Model.hs

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