Add field localMessageCreate, pointing to the OutboxItem that created it

I added a migration that creates an ugly fake OutboxItem for messages that
don't have one. I'll try to turn it into a real one. And then very possibly
remove the whole ugly migration, replacing it with addFielfRefRequiredEmpty,
which should work for empty instances.

config/models

@@ -328,6 +328,7 @@ Message
 LocalMessage
     author         PersonId
     rest           MessageId
+    create         OutboxItemId
     unlinkedParent FedURI    Maybe
 
     UniqueLocalMessage rest

migrations/2019_05_24.model

@@ -0,0 +1,43 @@
+Sharer
+    ident   ShrIdent
+    name    Text     Maybe
+    created UTCTime
+
+    UniqueSharer ident
+
+Person
+    ident               SharerId
+    login               Text
+    passphraseHash      ByteString
+    email               Text
+    verified            Bool
+    verifiedKey         Text
+    verifiedKeyCreated  UTCTime
+    resetPassKey        Text
+    resetPassKeyCreated UTCTime
+    about               Text
+
+    UniquePersonIdent ident
+    UniquePersonLogin login
+    UniquePersonEmail email
+
+OutboxItem
+    person    PersonId
+    activity  PersistJSONValue
+    published UTCTime
+
+Discussion
+
+Message
+    created UTCTime
+    content Text               -- Assume this is Pandoc Markdown
+    parent  MessageId    Maybe
+    root    DiscussionId
+
+LocalMessage
+    author         PersonId
+    rest           MessageId
+    create         OutboxItemId
+    unlinkedParent Text    Maybe
+
+    UniqueLocalMessage rest

src/Vervis/Application.hs

@@ -171,7 +171,7 @@ makeFoundation appSettings = do
     --runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
     flip runLoggingT logFunc $
         flip runSqlPool pool $ do
-            r <- migrateDB
+            r <- migrateDB hashidsCtx
             case r of
                 Left err -> do
                     let msg = "DB migration failed: " <> err

src/Vervis/Federation.hs

@@ -1334,23 +1334,13 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
                     _                     -> Nothing
             , messageRoot    = did
             }
-        lmid <- insert LocalMessage
+        let activity luAct luNote = Doc host Activity
-            { localMessageAuthor         = pid
-            , localMessageRest           = mid
-            , localMessageUnlinkedParent =
-                case meparent of
-                    Just (Right uParent) -> Just uParent
-                    _                    -> Nothing
-            }
-        route2local <- getEncodeRouteLocal
-        lmhid <- encodeKeyHashid lmid
-        let activity luAct = Doc host Activity
                 { activityId       = luAct
                 , activityActor    = luAttrib
                 , activityAudience = aud
                 , activitySpecific = CreateActivity Create
                     { createObject = Note
-                        { noteId        = Just $ route2local $ MessageR shrUser lmhid
+                        { noteId        = Just luNote
                         , noteAttrib    = luAttrib
                         , noteAudience  = aud
                         , noteReplyTo   = Just $ fromMaybe uContext muParent
@@ -1360,14 +1350,27 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
                         }
                     }
                 }
+            tempUri = LocalURI "" ""
         obid <- insert OutboxItem
             { outboxItemPerson    = pid
-            , outboxItemActivity  = PersistJSON $ activity $ LocalURI "" ""
+            , outboxItemActivity  = PersistJSON $ activity tempUri tempUri
             , outboxItemPublished = now
             }
+        lmid <- insert LocalMessage
+            { localMessageAuthor         = pid
+            , localMessageRest           = mid
+            , localMessageCreate         = obid
+            , localMessageUnlinkedParent =
+                case meparent of
+                    Just (Right uParent) -> Just uParent
+                    _                    -> Nothing
+            }
+        route2local <- getEncodeRouteLocal
         obhid <- encodeKeyHashid obid
+        lmhid <- encodeKeyHashid lmid
         let luAct = route2local $ OutboxItemR shrUser obhid
-            doc = activity luAct
+            luNote = route2local $ MessageR shrUser lmhid
+            doc = activity luAct luNote
         update obid [OutboxItemActivity =. PersistJSON doc]
         return (lmid, obid, doc)
 

src/Vervis/Migration.hs

@@ -21,19 +21,19 @@ where
 import Prelude
 
 import Control.Monad (unless)
-import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.IO.Class
 import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
 import Data.ByteString (ByteString)
 import Data.Default.Class
 import Data.Default.Instances.ByteString ()
 import Data.Foldable (traverse_, for_)
-import Data.Maybe (fromMaybe, listToMaybe)
+import Data.Maybe
 import Data.Proxy
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Calendar (Day (..))
-import Data.Time.Clock (UTCTime (..))
+import Data.Time.Clock
 import Database.Persist
 import Database.Persist.BackendDataType (backendDataType, PersistDefault (..))
 import Database.Persist.Migration
@@ -43,12 +43,23 @@ import Database.Persist.Schema.PostgreSQL (schemaBackend)
 import Database.Persist.Sql (SqlBackend, toSqlKey)
 --import Text.Email.QuasiQuotation (email
 import Text.Email.Validate (unsafeEmailAddress)
+import Web.Hashids
 import Web.PathPieces (toPathPiece)
 
+import qualified Data.Aeson as A
 import qualified Database.Esqueleto as E
+
 import qualified Database.Persist.Schema as S
 import qualified Database.Persist.Schema.Types as ST
 
+import Network.FedURI
+import Database.Persist.JSON
+import Web.ActivityPub
+import Yesod.FedURI
+import Yesod.Hashids
+
+import Vervis.Model.Ident
+import Vervis.Foundation (Route (..))
 import Vervis.Migration.Model
 
 instance PersistDefault ByteString where
@@ -66,8 +77,8 @@ withPrepare (validate, apply) prepare = (validate, prepare >> apply)
 --withPrePost :: Monad m => Apply m -> Mig m -> Apply m -> Mig m
 --withPrePost pre (validate, apply) post = (validate, pre >> apply >> post)
 
-changes :: MonadIO m => [Mig m]
+changes :: MonadIO m => HashidsContext -> [Mig m]
-changes =
+changes ctx =
     [ -- 1
       addEntities model_2016_08_04
       -- 2
@@ -280,9 +291,85 @@ changes =
     , addFieldPrimOptional "RemoteActor" (Nothing :: Maybe Text) "name"
       -- 76
     , addFieldPrimRequired "InboxItem" False "unread"
+      -- 77
+    , addFieldRefRequired''
+        "LocalMessage"
+        (do let user = "$$temp$$"
+            sid <-
+                insert $ Sharer201905 (text2shr user) Nothing defaultTime
+            pid <-
+                insert $
+                    Person201905
+                        sid user "" "e@ma.il" False "" defaultTime ""
+                        defaultTime ""
+            let localUri = LocalURI "/x/y" ""
+                fedUri = l2f "x.y" localUri
+                d2v = fromJust . A.decode . A.encode
+                doc = d2v $ Doc "x.y" Activity
+                    { activityId       = localUri
+                    , activityActor    = localUri
+                    , activityAudience = Audience [] [] [] [] [] []
+                    , activitySpecific = AcceptActivity $ Accept fedUri
+                    }
+            insertEntity $ OutboxItem201905 pid (PersistJSON doc) defaultTime
+        )
+        (Just $ \ (Entity obid ob) -> do
+            let actNoteId (Activity _ _ _ (CreateActivity (Create note))) = noteId note
+                actNoteId _                                               = Nothing
+                obNoteId (Entity i o) =
+                    if i == obid
+                        then Nothing
+                        else (,i) <$> actNoteId (docValue $ fromJust $ A.decode $ A.encode $ persistJSONValue $ outboxItem201905Activity o)
+            obs <-
+                mapMaybe obNoteId <$>
+                    selectList ([] :: [Filter OutboxItem201905]) []
+            lms <- selectList ([] :: [Filter LocalMessage201905]) []
+            for_ lms $ \ (Entity lmid lm) -> do
+                let pid = localMessage201905Author lm
+                p <- getJust pid
+                s <- getJust $ person201905Ident p
+                let shr = sharer201905Ident s
+                    route = MessageR shr (encodeKeyHashidPure ctx $ E.toSqlKey $ E.fromSqlKey lmid)
+                    match (luNote, obid') =
+                        case decodeRouteLocal luNote of
+                            Just r@(MessageR _ _) ->
+                                if r == route
+                                    then Just obid'
+                                    else Nothing
+                            _ -> error "Invalid local luNote"
+                    mobid =
+                        case mapMaybe match obs of
+                            [] -> Nothing
+                            [k] -> Just k
+                            _ -> error "Multiple outbox IDs!"
+                obidNew <-
+                    case mobid of
+                        Just k -> return k
+                        Nothing -> do
+                            now <- liftIO getCurrentTime
+                            let localUri = LocalURI "/x/y" ""
+                                fedUri = l2f "lo.cal" localUri
+                                d2v = fromJust . A.decode . A.encode
+                                doc = PersistJSON $ d2v $ Doc "lo.cal" Activity
+                                    { activityId       = localUri
+                                    , activityActor    = localUri
+                                    , activityAudience = Audience [] [] [] [] [] []
+                                    , activitySpecific = AcceptActivity $ Accept fedUri
+                                    }
+                            insert $ OutboxItem201905 pid doc now
+                update lmid [LocalMessage201905Create =. obidNew]
+
+            delete obid
+            let pid = outboxItem201905Person ob
+            p <- getJust pid
+            delete pid
+            delete $ person201905Ident p
+        )
+        "create"
+        "OutboxItem"
     ]
 
-migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int))
+migrateDB :: MonadIO m => HashidsContext -> ReaderT SqlBackend m (Either Text (Int, Int))
-migrateDB =
+migrateDB ctx =
     let f cs = fmap (, length cs) <$> runMigrations schemaBackend 1 cs
-    in  f changes
+    in  f $ changes ctx

src/Vervis/Migration/Model.hs

@@ -40,6 +40,12 @@ module Vervis.Migration.Model
     , model_2019_04_22
     , model_2019_05_03
     , model_2019_05_17
+    , Sharer201905Generic (..)
+    , Person201905Generic (..)
+    , OutboxItem201905Generic (..)
+    , OutboxItem201905
+    , LocalMessage201905Generic (..)
+    , LocalMessage201905
     )
 where
 
@@ -110,3 +116,6 @@ model_2019_05_03 = $(schema "2019_05_03")
 
 model_2019_05_17 :: [Entity SqlBackend]
 model_2019_05_17 = $(schema "2019_05_17")
+
+makeEntitiesMigration "201905"
+    $(modelFile "migrations/2019_05_24.model")

src/Yesod/Hashids.hs

@@ -17,6 +17,7 @@ module Yesod.Hashids
     ( YesodHashids (..)
     , KeyHashid ()
     , keyHashidText
+    , encodeKeyHashidPure
     , getEncodeKeyHashid
     , encodeKeyHashid
     , decodeKeyHashidF
@@ -54,6 +55,11 @@ instance PersistEntity record => PathPiece (KeyHashid record) where
     fromPathPiece t = KeyHashid <$> fromPathPiece t
     toPathPiece (KeyHashid t) = toPathPiece t
 
+encodeKeyHashidPure
+    :: ToBackendKey SqlBackend record
+    => HashidsContext -> Key record -> KeyHashid record
+encodeKeyHashidPure ctx = KeyHashid . decodeUtf8 . encodeInt64 ctx . fromSqlKey
+
 getEncodeKeyHashid
     :: ( MonadHandler m
        , YesodHashids (HandlerSite m)
@@ -62,7 +68,7 @@ getEncodeKeyHashid
     => m (Key record -> KeyHashid record)
 getEncodeKeyHashid = do
     ctx <- getsYesod siteHashidsContext
-    return $ KeyHashid . decodeUtf8 . encodeInt64 ctx . fromSqlKey
+    return $ encodeKeyHashidPure ctx
 
 encodeKeyHashid
     :: ( MonadHandler m