Rewrite the localMessageCreate migration to insert real activities

A thing still missing there is that it sets empty audience for comments on
remote tickets, but that's fine because dev.angeley.es doesn't have such
comments in the database.

migrations/2019_05_24.model

@@ -23,7 +23,7 @@ Person
 
 OutboxItem
     person    PersonId
-    activity  PersistJSONValue
+    activity  PersistActivity
     published UTCTime
 
 Discussion
@@ -38,6 +38,61 @@ LocalMessage
     author         PersonId
     rest           MessageId
     create         OutboxItemId
-    unlinkedParent Text    Maybe
+    unlinkedParent FedURI    Maybe
 
     UniqueLocalMessage rest
+
+Instance
+    host Text
+
+    UniqueInstance host
+
+RemoteDiscussion
+    instance InstanceId
+    ident    LocalURI
+    discuss  DiscussionId
+
+    UniqueRemoteDiscussionIdent instance ident
+    UniqueRemoteDiscussion discuss
+
+Ticket
+    project  ProjectId
+    number   Int
+    created  UTCTime
+    creator  PersonId
+    title    Text
+    desc     Text -- Assume this is Pandoc Markdown
+    assignee PersonId     Maybe
+    status   Text
+    closed   UTCTime
+    closer   PersonId
+    discuss  DiscussionId
+    followers Int64
+
+    UniqueTicket project number
+    UniqueTicketDiscussion discuss
+    UniqueTicketFollowers followers
+
+Project
+    ident      PrjIdent
+    sharer     SharerId
+    name       Text          Maybe
+    desc       Text          Maybe
+    workflow   Int64
+    nextTicket Int
+    wiki       Int64        Maybe
+    collabUser Int64 Maybe
+    collabAnon Int64 Maybe
+
+    UniqueProject ident sharer
+
+RemoteMessage
+    author     Int64
+    instance   InstanceId
+    ident      LocalURI
+    rest       MessageId
+    create     Int64
+    lostParent FedURI            Maybe
+
+    UniqueRemoteMessageIdent instance ident
+    UniqueRemoteMessage rest

src/Vervis/Application.hs

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

src/Vervis/Migration.hs

@@ -20,9 +20,11 @@ where
 
 import Prelude
 
+import Control.Applicative
 import Control.Monad (unless)
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
 import Data.ByteString (ByteString)
 import Data.Default.Class
@@ -46,7 +48,7 @@ import Text.Email.Validate (unsafeEmailAddress)
 import Web.Hashids
 import Web.PathPieces (toPathPiece)
 
-import qualified Data.Aeson as A
+import qualified Data.Text as T
 import qualified Database.Esqueleto as E
 
 import qualified Database.Persist.Schema as S
@@ -58,6 +60,8 @@ import Web.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
 
+import Database.Persist.Local
+
 import Vervis.Model.Ident
 import Vervis.Foundation (Route (..))
 import Vervis.Migration.Model
@@ -77,8 +81,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 => HashidsContext -> [Mig m]
+changes :: MonadIO m => Text -> HashidsContext -> [Mig m]
-changes ctx =
+changes hLocal ctx =
     [ -- 1
       addEntities model_2016_08_04
       -- 2
@@ -304,8 +308,7 @@ changes ctx =
                         defaultTime ""
             let localUri = LocalURI "/x/y" ""
                 fedUri = l2f "x.y" localUri
-                d2v = fromJust . A.decode . A.encode
+                doc = Doc "x.y" Activity
-                doc = d2v $ Doc "x.y" Activity
                     { activityId       = localUri
                     , activityActor    = localUri
                     , activityAudience = Audience [] [] [] [] [] []
@@ -319,7 +322,7 @@ changes ctx =
                 obNoteId (Entity i o) =
                     if i == obid
                         then Nothing
-                        else (,i) <$> actNoteId (docValue $ fromJust $ A.decode $ A.encode $ persistJSONValue $ outboxItem201905Activity o)
+                        else (,i) <$> actNoteId (docValue $ persistJSONValue $ outboxItem201905Activity o)
             obs <-
                 mapMaybe obNoteId <$>
                     selectList ([] :: [Filter OutboxItem201905]) []
@@ -346,17 +349,119 @@ changes ctx =
                     case mobid of
                         Just k -> return k
                         Nothing -> do
-                            now <- liftIO getCurrentTime
+                            -- Figure out:
-                            let localUri = LocalURI "/x/y" ""
+                            --   * aud
-                                fedUri = l2f "lo.cal" localUri
+                            --   * uContext
-                                d2v = fromJust . A.decode . A.encode
+                            --   * muParent
-                                doc = PersistJSON $ d2v $ Doc "lo.cal" Activity
+                            m <- getJust $ localMessage201905Rest lm
-                                    { activityId       = localUri
+
-                                    , activityActor    = localUri
+                            let did = message201905Root m
-                                    , activityAudience = Audience [] [] [] [] [] []
+                            mcontext <-
-                                    , activitySpecific = AcceptActivity $ Accept fedUri
+                                runMaybeT
+                                    $   Left <$> MaybeT (getValBy $ UniqueTicketDiscussion201905 did)
+                                    <|> Right <$> MaybeT (getValBy $ UniqueRemoteDiscussion201905 did)
+                            let context =
+                                    case mcontext of
+                                        Nothing -> error "DiscussionId not used"
+                                        Just c -> c
+                            (uContext, recips) <-
+                                case context of
+                                    Left t -> do
+                                        j <- getJust $ ticket201905Project t
+                                        let tprj = project201905Ident j
+                                        s <- getJust $ project201905Sharer j
+                                        let tshr = sharer201905Ident s
+                                            jPath = T.concat
+                                                [ "/s/", shr2text tshr
+                                                , "/p/", prj2text tprj
+                                                ]
+                                            tPath = T.concat
+                                                [ jPath
+                                                , "/t/", T.pack $ show $ ticket201905Number t
+                                                ]
+                                        return
+                                            ( FedURI hLocal tPath ""
+                                            , map (l2f hLocal . flip LocalURI "")
+                                                [ jPath
+                                                , tPath <> "/participants"
+                                                , tPath <> "/team"
+                                                ]
+                                            )
+                                    Right rd -> do
+                                        i <- getJust $
+                                            remoteDiscussion201905Instance rd
+                                        return
+                                            ( l2f
+                                                (instance201905Host i)
+                                                (remoteDiscussion201905Ident rd)
+                                            , []
+                                            )
+
+                            -- parent
+                            muParent <-
+                                case Left <$> localMessage201905UnlinkedParent lm <|>
+                                     Right <$> message201905Parent m of
+                                    Nothing -> return Nothing
+                                    Just (Left fu) -> return $ Just fu
+                                    Just (Right midParent) -> Just <$> do
+                                        mparent <-
+                                            runMaybeT
+                                                $   Left <$> MaybeT (getBy $ UniqueLocalMessage201905 midParent)
+                                                <|> Right <$> MaybeT (getValBy $ UniqueRemoteMessage201905 midParent)
+                                        case fromJust mparent of
+                                            Left (Entity lmidP lmP) -> do
+                                                p <- getJust $ localMessage201905Author lmP
+                                                s <- getJust $ person201905Ident p
+                                                let path = T.concat
+                                                        [ "/s/", shr2text $ sharer201905Ident s
+                                                        , "/m/", toPathPiece $ encodeKeyHashidPure ctx lmidP
+                                                        ]
+                                                return $ FedURI hLocal path ""
+                                            Right rmP -> do
+                                                i <- getJust $
+                                                    remoteMessage201905Instance rmP
+                                                return $
+                                                    l2f (instance201905Host i)
+                                                        (remoteMessage201905Ident rmP)
+
+                            let aud = Audience recips [] [] [] [] []
+
+                                luAttrib = LocalURI ("/s/" <> shr2text shr) ""
+                                activity luAct luNote = Doc hLocal Activity
+                                    { activityId       = luAct
+                                    , activityActor    = luAttrib
+                                    , activityAudience = aud
+                                    , activitySpecific = CreateActivity Create
+                                        { createObject = Note
+                                            { noteId        = Just luNote
+                                            , noteAttrib    = luAttrib
+                                            , noteAudience  = aud
+                                            , noteReplyTo   = Just $ fromMaybe uContext muParent
+                                            , noteContext   = Just uContext
+                                            , notePublished = Just $ message201905Created m
+                                            , noteContent   = message201905Content m
+                                            }
+                                        }
                                     }
-                            insert $ OutboxItem201905 pid doc now
+                                tempUri = LocalURI "" ""
+                            newObid <- insert OutboxItem201905
+                                { outboxItem201905Person    = pid
+                                , outboxItem201905Activity  = PersistJSON $ activity tempUri tempUri
+                                , outboxItem201905Published = message201905Created m
+                                }
+                            let notePath = T.concat
+                                    [ "/s/", shr2text shr
+                                    , "/m/", toPathPiece $ encodeKeyHashidPure ctx lmid
+                                    ]
+                                obPath = T.concat
+                                    [ "/s/", shr2text shr
+                                    , "/outbox/", toPathPiece $ encodeKeyHashidPure ctx newObid
+                                    ]
+                                luAct = LocalURI obPath ""
+                                luNote = LocalURI notePath ""
+                                doc = activity luAct luNote
+                            update newObid [OutboxItem201905Activity =. PersistJSON doc]
+                            return newObid
                 update lmid [LocalMessage201905Create =. obidNew]
 
             delete obid
@@ -369,7 +474,7 @@ changes ctx =
         "OutboxItem"
     ]
 
-migrateDB :: MonadIO m => HashidsContext -> ReaderT SqlBackend m (Either Text (Int, Int))
+migrateDB :: MonadIO m => Text -> HashidsContext -> ReaderT SqlBackend m (Either Text (Int, Int))
-migrateDB ctx =
+migrateDB hLocal ctx =
     let f cs = fmap (, length cs) <$> runMigrations schemaBackend 1 cs
-    in  f $ changes ctx
+    in  f $ changes hLocal ctx

src/Vervis/Migration/Model.hs

@@ -15,6 +15,7 @@
 
 module Vervis.Migration.Model
     ( EntityField (..)
+    , Unique (..)
     , model_2016_08_04
     , model_2016_09_01_just_workflow
     , Sharer2016
@@ -46,6 +47,12 @@ module Vervis.Migration.Model
     , OutboxItem201905
     , LocalMessage201905Generic (..)
     , LocalMessage201905
+    , Message201905Generic (..)
+    , Project201905Generic (..)
+    , Ticket201905Generic (..)
+    , Instance201905Generic (..)
+    , RemoteDiscussion201905Generic (..)
+    , RemoteMessage201905Generic (..)
     )
 where
 
@@ -54,7 +61,7 @@ import Prelude
 import Data.ByteString (ByteString)
 import Data.Text (Text)
 import Data.Time (UTCTime)
-import Database.Persist.Class (EntityField)
+import Database.Persist.Class (EntityField, Unique)
 import Database.Persist.JSON (PersistJSONValue)
 import Database.Persist.Schema.Types (Entity)
 import Database.Persist.Schema.SQL ()
@@ -69,6 +76,16 @@ import Vervis.Model.Role
 import Vervis.Model.TH (modelFile, makeEntitiesMigration)
 import Vervis.Model.Workflow
 
+-- For migration 77
+
+import Data.Int
+
+import Database.Persist.JSON
+import Network.FedURI
+import Web.ActivityPub
+
+type PersistActivity = PersistJSON (Doc Activity)
+
 model_2016_08_04 :: [Entity SqlBackend]
 model_2016_08_04 = $(schema "2016_08_04")