mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-01 09:04:53 +09:00
519 lines
21 KiB
Haskell
519 lines
21 KiB
Haskell
{- This file is part of Vervis.
|
|
-
|
|
- Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
|
|
-
|
|
- ♡ Copying is an act of love. Please copy, reuse and share.
|
|
-
|
|
- The author(s) have dedicated all copyright and related and neighboring
|
|
- rights to this software to the public domain worldwide. This software is
|
|
- distributed without any warranty.
|
|
-
|
|
- You should have received a copy of the CC0 Public Domain Dedication along
|
|
- with this software. If not, see
|
|
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
|
-}
|
|
|
|
module Vervis.Migration
|
|
( migrateDB
|
|
)
|
|
where
|
|
|
|
import Prelude
|
|
|
|
import Control.Applicative
|
|
import Control.Exception
|
|
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
|
|
import Data.Default.Instances.ByteString ()
|
|
import Data.Foldable (traverse_, for_)
|
|
import Data.Maybe
|
|
import Data.Proxy
|
|
import Data.Text (Text)
|
|
import Data.Text.Encoding (encodeUtf8)
|
|
import Data.Time.Calendar (Day (..))
|
|
import Data.Time.Clock
|
|
import Database.Persist
|
|
import Database.Persist.BackendDataType (backendDataType, PersistDefault (..))
|
|
import Database.Persist.Migration
|
|
import Database.Persist.Schema (SchemaT, Migration)
|
|
import Database.Persist.Schema.Types hiding (Entity)
|
|
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.Text as T
|
|
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 Database.Persist.Local
|
|
|
|
import Vervis.Model.Ident
|
|
import Vervis.Foundation (Route (..))
|
|
import Vervis.Migration.Model
|
|
import Vervis.Render
|
|
|
|
instance PersistDefault ByteString where
|
|
pdef = def
|
|
|
|
type Apply m = SchemaT SqlBackend m ()
|
|
type Mig m = Migration SqlBackend m
|
|
|
|
defaultTime :: UTCTime
|
|
defaultTime = UTCTime (ModifiedJulianDay 0) 0
|
|
|
|
withPrepare :: Monad m => Mig m -> Apply m -> Mig m
|
|
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 => Text -> HashidsContext -> [Mig m]
|
|
changes hLocal ctx =
|
|
[ -- 1
|
|
addEntities model_2016_08_04
|
|
-- 2
|
|
, unchecked $ S.unsetFieldDefault "Sharer" "created"
|
|
-- 3
|
|
, unchecked $ S.unsetFieldDefault "Project" "nextTicket"
|
|
-- 4
|
|
, unchecked $ S.unsetFieldDefault "Repo" "vcs"
|
|
-- 5
|
|
, unchecked $ S.unsetFieldDefault "Repo" "mainBranch"
|
|
-- 6
|
|
, removeField "Ticket" "done"
|
|
-- 7
|
|
, addFieldPrimRequired "Ticket" ("TSNew" :: Text) "status"
|
|
-- 8
|
|
, addEntities model_2016_09_01_just_workflow
|
|
-- 9
|
|
, addEntities model_2016_09_01_rest
|
|
-- 10
|
|
, let key = fromBackendKey defaultBackendKey :: Key Workflow2016
|
|
in withPrepare
|
|
(addFieldRefRequired "Project"
|
|
(toBackendKey key)
|
|
"workflow"
|
|
"Workflow"
|
|
) $ do
|
|
noProjects <- lift $
|
|
null <$> selectKeysList [] [LimitTo 1 :: SelectOpt Project2016]
|
|
unless noProjects $ lift $ do
|
|
msid <-
|
|
listToMaybe <$>
|
|
selectKeysList [] [Asc Sharer2016Id, LimitTo 1]
|
|
for_ msid $ \ sid ->
|
|
insertKey key $
|
|
Workflow2016 sid "dummy" Nothing Nothing
|
|
-- 11
|
|
, addFieldPrimRequired "Workflow" ("WSSharer" :: Text) "scope"
|
|
-- 12
|
|
, unsetFieldPrimMaybe "Person" "hash" ("" :: Text)
|
|
-- 13
|
|
, changeFieldTypePrimRequiredFreeHs "Person" "hash" encodeUtf8
|
|
-- 14
|
|
--, unsetFieldPrimMaybe "Person" "email" [email|noreply@no.such.email|]
|
|
, unsetFieldPrimMaybe "Person" "email" $
|
|
unsafeEmailAddress "noreply" "no.such.email"
|
|
-- 15
|
|
, addFieldPrimRequired "Person" True "verified"
|
|
-- 16
|
|
, addFieldPrimRequired "Person" ("" :: Text) "verifiedKey"
|
|
-- 17
|
|
, addFieldPrimRequired "Person" ("" :: Text) "resetPassphraseKey"
|
|
-- 18
|
|
, renameField "Person" "hash" "passphraseHash"
|
|
-- 19
|
|
, renameField "Person" "resetPassphraseKey" "resetPassKey"
|
|
-- 20
|
|
, addFieldPrimRequired "Person" defaultTime "verifiedKeyCreated"
|
|
-- 21
|
|
, addFieldPrimRequired "Person" defaultTime "resetPassKeyCreated"
|
|
-- 22
|
|
, addUnique "Person" $ Unique "UniquePersonEmail" ["email"]
|
|
-- 23
|
|
, renameField "ProjectCollabAnon" "repo" "project"
|
|
-- 24
|
|
, renameField "ProjectCollabUser" "repo" "project"
|
|
-- 25
|
|
, addFieldPrimRequired "Person" ("" :: Text) "about"
|
|
-- 26
|
|
, setFieldMaybe "ProjectCollab" "role"
|
|
-- 27
|
|
, removeField "RepoCollab" "role"
|
|
-- 28
|
|
, addFieldRefOptional "RepoCollab" Nothing "role" "ProjectRole"
|
|
-- 29
|
|
, removeEntity "RepoCollabAnon"
|
|
-- 30
|
|
, removeEntity "RepoCollabUser"
|
|
-- 31
|
|
, addFieldRefOptional "Repo" Nothing "collabUser" "ProjectRole"
|
|
-- 32
|
|
, addFieldRefOptional "Repo" Nothing "collabAnon" "ProjectRole"
|
|
-- 33
|
|
, addFieldRefOptional "Project" Nothing "collabUser" "ProjectRole"
|
|
-- 34
|
|
, addFieldRefOptional "Project" Nothing "collabAnon" "ProjectRole"
|
|
-- 35
|
|
, unchecked $ lift $ do
|
|
l <- E.select $ E.from $ \ (j `E.LeftOuterJoin`
|
|
jcu `E.LeftOuterJoin`
|
|
jca) -> do
|
|
E.on $
|
|
E.just (j E.^. Project2018Id) E.==.
|
|
jca E.?. ProjectCollabAnon2018Project
|
|
E.on $
|
|
E.just (j E.^. Project2018Id) E.==.
|
|
jcu E.?. ProjectCollabUser2018Project
|
|
E.where_ $ E.not_ $
|
|
E.isNothing (jcu E.?. ProjectCollabUser2018Project) E.&&.
|
|
E.isNothing (jca E.?. ProjectCollabAnon2018Project)
|
|
return
|
|
( j E.^. Project2018Id
|
|
, jca E.?. ProjectCollabAnon2018Role
|
|
, jcu E.?. ProjectCollabUser2018Role
|
|
)
|
|
for_ l $ \ (E.Value jid, E.Value malid, E.Value mulid) ->
|
|
update jid
|
|
[ Project2018CollabAnon =. malid
|
|
, Project2018CollabUser =. mulid
|
|
]
|
|
-- 36
|
|
, removeEntity "ProjectCollabAnon"
|
|
-- 37
|
|
, removeEntity "ProjectCollabUser"
|
|
-- 38
|
|
, removeEntity "RepoAccess"
|
|
-- 39
|
|
, removeEntity "RepoRoleInherit"
|
|
-- 40
|
|
, removeEntity "RepoRole"
|
|
-- 41
|
|
, addEntities model_2019_02_03_verifkey
|
|
-- 42
|
|
, unchecked $ lift $ do
|
|
deleteWhere ([] :: [Filter VerifKeySharedUsage2019])
|
|
deleteWhere ([] :: [Filter VerifKey2019])
|
|
-- 43
|
|
, removeUnique "Message" "UniqueMessage"
|
|
-- 44
|
|
, removeField "Message" "number"
|
|
-- 45
|
|
, removeField "Discussion" "nextMessage"
|
|
-- 46
|
|
, addEntities model_2019_03_19
|
|
-- 47
|
|
, unchecked $ lift $ do
|
|
msgs <- selectList ([] :: [Filter Message2019]) []
|
|
let mklocal (Entity mid m) = LocalMessage2019 (message2019Author m) mid
|
|
insertMany_ $ map mklocal msgs
|
|
-- 48
|
|
, removeField "Message" "author"
|
|
-- 49
|
|
, addUnique "Ticket" $ Unique "UniqueTicketDiscussion" ["discuss"]
|
|
-- 50
|
|
, addEntities model_2019_03_30
|
|
-- 51
|
|
, addFieldRefRequired'
|
|
"Ticket"
|
|
FollowerSet2019
|
|
(Just $ do
|
|
tids <- selectKeysList ([] :: [Filter Ticket2019]) []
|
|
for_ tids $ \ tid -> do
|
|
fsid <- insert FollowerSet2019
|
|
update tid [Ticket2019Followers =. fsid]
|
|
)
|
|
"followers"
|
|
"FollowerSet"
|
|
-- 52
|
|
, addUnique "Ticket" $ Unique "UniqueTicketFollowers" ["followers"]
|
|
-- 53
|
|
, removeField "RemoteDiscussion" "sharer"
|
|
-- 54
|
|
, addFieldPrimOptional
|
|
"LocalMessage"
|
|
(Nothing :: Maybe Text)
|
|
"unlinkedParent"
|
|
-- 55
|
|
, addEntities model_2019_04_11
|
|
-- 56
|
|
, renameEntity "RemoteSharer" "RemoteActor"
|
|
-- 57
|
|
, renameUnique "RemoteActor" "UniqueRemoteSharer" "UniqueRemoteActor"
|
|
-- 58
|
|
, addFieldPrimOptional
|
|
"RemoteActor"
|
|
(Nothing :: Maybe UTCTime)
|
|
"errorSince"
|
|
-- 59
|
|
, addEntities model_2019_04_12
|
|
-- 60
|
|
, addEntities model_2019_04_22
|
|
-- 61
|
|
, addFieldRefRequiredEmpty "RemoteMessage" "create" "RemoteActivity"
|
|
-- 62
|
|
, removeField "RemoteMessage" "raw"
|
|
-- 63
|
|
, removeEntity "RemoteRawObject"
|
|
-- 64
|
|
, addFieldPrimRequired "UnlinkedDelivery" True "forwarding"
|
|
-- 65
|
|
, addFieldPrimRequired "Delivery" True "forwarding"
|
|
-- 66
|
|
, addEntities model_2019_05_03
|
|
-- 67
|
|
, addFieldPrimRequired "Follow" False "manual"
|
|
-- 68
|
|
, addFieldPrimRequired "RemoteFollow" False "manual"
|
|
-- 69
|
|
, addEntity $ ST.Entity "InboxItem" [] []
|
|
-- 70
|
|
, addFieldRefRequiredEmpty "InboxItemLocal" "item" "InboxItem"
|
|
-- 71
|
|
, addFieldRefRequiredEmpty "InboxItemRemote" "item" "InboxItem"
|
|
-- 72
|
|
, addUnique "InboxItemLocal" $ Unique "UniqueInboxItemLocalItem" ["item"]
|
|
-- 73
|
|
, addUnique "InboxItemRemote" $ Unique "UniqueInboxItemRemoteItem" ["item"]
|
|
-- 74
|
|
, addEntities model_2019_05_17
|
|
-- 75
|
|
, 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
|
|
doc = 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 $ 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
|
|
-- 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 msg = T.filter (/= '\r') $ message201905Content m
|
|
contentHtml <-
|
|
case renderPandocMarkdown msg of
|
|
Left e -> error $ T.unpack e
|
|
Right t -> return t
|
|
|
|
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
|
|
, noteSource = msg
|
|
, noteContent = contentHtml
|
|
}
|
|
}
|
|
}
|
|
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
|
|
let pid = outboxItem201905Person ob
|
|
p <- getJust pid
|
|
delete pid
|
|
delete $ person201905Ident p
|
|
)
|
|
"create"
|
|
"OutboxItem"
|
|
-- 78
|
|
, addUnique "LocalMessage" $ Unique "UniqueLocalMessageCreate" ["create"]
|
|
-- 79
|
|
, renameEntity "ProjectRole" "Role"
|
|
-- 80
|
|
, renameUnique "Role" "UniqueProjectRole" "UniqueRole"
|
|
-- 81
|
|
, renameEntity "ProjectRoleInherit" "RoleInherit"
|
|
-- 82
|
|
, renameUnique "RoleInherit" "UniqueProjectRoleInherit" "UniqueRoleInherit"
|
|
-- 83
|
|
, renameEntity "ProjectAccess" "RoleAccess"
|
|
-- 84
|
|
, renameUnique "RoleAccess" "UniqueProjectAccess" "UniqueRoleAccess"
|
|
-- 85
|
|
, renameField "Message" "content" "source"
|
|
-- 86
|
|
, addFieldPrimRequired "Message" ("" :: Text) "content"
|
|
-- 87
|
|
, unchecked $ lift $ do
|
|
msgs <- selectList ([] :: [Filter Message201906]) []
|
|
for_ msgs $ \ (Entity mid m) ->
|
|
let source = T.filter (/= '\r') $ message201906Source m
|
|
in case renderPandocMarkdown $ message201906Source m of
|
|
Left err -> liftIO $ throwIO $ userError $ T.unpack err
|
|
Right content ->
|
|
update mid
|
|
[ Message201906Source =. source
|
|
, Message201906Content =. content
|
|
]
|
|
]
|
|
|
|
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 hLocal ctx
|