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.
This commit is contained in:
fr33domlover
parent
e81eb80b8b
commit
2eade80cfb
4 changed files with 201 additions and 23 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ctx =
|
||||
changes :: MonadIO m => Text -> HashidsContext -> [Mig m]
|
||||
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 = d2v $ Doc "x.y" Activity
|
||||
doc = 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
|
||||
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
|
||||
-- Figure out:
|
||||
-- * aud
|
||||
-- * uContext
|
||||
-- * muParent
|
||||
m <- getJust $ localMessage201905Rest lm
|
||||
|
||||
let did = message201905Root m
|
||||
mcontext <-
|
||||
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 ctx =
|
||||
migrateDB :: MonadIO m => Text -> HashidsContext -> ReaderT SqlBackend m (Either Text (Int, Int))
|
||||
migrateDB hLocal ctx =
|
||||
let f cs = fmap (, length cs) <$> runMigrations schemaBackend 1 cs
|
||||
in f $ changes ctx
|
||||
in f $ changes hLocal ctx
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue