mirror of
https://code.sup39.dev/repos/Wqawg
synced 2025-01-06 07:16:45 +09:00
852 lines
34 KiB
Haskell
852 lines
34 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 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.List (nub)
|
|
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 Data.Traversable
|
|
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.Blaze.Html (toHtml)
|
|
import Text.Blaze.Html.Renderer.Text
|
|
--import Text.Email.QuasiQuotation (email
|
|
import Text.Email.Validate (unsafeEmailAddress)
|
|
import Text.Hamlet
|
|
import Web.Hashids
|
|
import Web.PathPieces (toPathPiece)
|
|
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Lazy as TL
|
|
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 Yesod.MonadSite
|
|
|
|
import Data.Either.Local
|
|
import Database.Persist.Local
|
|
|
|
import Vervis.Model.Ident
|
|
import Vervis.Foundation (App, Route (..))
|
|
import Vervis.Migration.Model
|
|
import Yesod.RenderSource
|
|
|
|
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 :: (MonadSite m, SiteEnv m ~ App) => 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
|
|
, activitySummary = Nothing
|
|
, 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
|
|
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
|
|
, activitySummary = Nothing
|
|
, 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 source of
|
|
Left err -> liftIO $ throwIO $ userError $ T.unpack err
|
|
Right content ->
|
|
update mid
|
|
[ Message201906Source =. source
|
|
, Message201906Content =. content
|
|
]
|
|
-- 88
|
|
, renameField "Ticket" "desc" "source"
|
|
-- 89
|
|
, addFieldPrimRequired "Ticket" ("" :: Text) "description"
|
|
-- 90
|
|
, unchecked $ lift $ do
|
|
tickets <- selectList ([] :: [Filter Ticket201906]) []
|
|
for_ tickets $ \ (Entity tid t) ->
|
|
let source = T.filter (/= '\r') $ ticket201906Source t
|
|
in case renderPandocMarkdown source of
|
|
Left err -> liftIO $ throwIO $ userError $ T.unpack err
|
|
Right content ->
|
|
update tid
|
|
[ Ticket201906Source =. source
|
|
, Ticket201906Description =. content
|
|
]
|
|
-- 91
|
|
, addEntities model_2019_06_06
|
|
-- 92
|
|
, unchecked $ lift $ do
|
|
tickets <- selectList ([] :: [Filter Ticket20190606]) []
|
|
let mklocal (Entity tid t) =
|
|
TicketAuthorLocal20190606 tid $ ticket20190606Creator t
|
|
insertMany_ $ map mklocal tickets
|
|
-- 93
|
|
, setFieldMaybe "Ticket" "closer"
|
|
-- 94
|
|
, removeField "Ticket" "creator"
|
|
-- 95
|
|
, addEntity $ ST.Entity "Inbox" [] []
|
|
-- 96
|
|
, addFieldRefRequired'
|
|
"Person"
|
|
Inbox20190607
|
|
(Just $ do
|
|
pids <- selectKeysList ([] :: [Filter Person20190607]) []
|
|
for_ pids $ \ pid -> do
|
|
ibid <- insert Inbox20190607
|
|
update pid [Person20190607Inbox =. ibid]
|
|
)
|
|
"inbox"
|
|
"Inbox"
|
|
-- 97
|
|
, addFieldRefRequired'
|
|
"InboxItemLocal"
|
|
Inbox20190607
|
|
(Just $ do
|
|
ibils <- selectList ([] :: [Filter InboxItemLocal20190607]) []
|
|
for_ ibils $ \ (Entity ibilid ibil) -> do
|
|
person <- getJust $ inboxItemLocal20190607Person ibil
|
|
let ibid = person20190607Inbox person
|
|
update ibilid [InboxItemLocal20190607Inbox =. ibid]
|
|
)
|
|
"inbox"
|
|
"Inbox"
|
|
-- 98
|
|
, addFieldRefRequired'
|
|
"InboxItemRemote"
|
|
Inbox20190607
|
|
(Just $ do
|
|
ibirs <- selectList ([] :: [Filter InboxItemRemote20190607]) []
|
|
for_ ibirs $ \ (Entity ibirid ibir) -> do
|
|
person <- getJust $ inboxItemRemote20190607Person ibir
|
|
let ibid = person20190607Inbox person
|
|
update ibirid [InboxItemRemote20190607Inbox =. ibid]
|
|
)
|
|
"inbox"
|
|
"Inbox"
|
|
-- 99
|
|
, removeUnique "InboxItemLocal" "UniqueInboxItemLocal"
|
|
-- 100
|
|
, removeField "InboxItemLocal" "person"
|
|
-- 101
|
|
, addUnique "InboxItemLocal" $
|
|
Unique "UniqueInboxItemLocal" ["inbox", "activity"]
|
|
-- 102
|
|
, removeUnique "InboxItemRemote" "UniqueInboxItemRemote"
|
|
-- 103
|
|
, removeField "InboxItemRemote" "person"
|
|
-- 104
|
|
, addUnique "InboxItemRemote" $
|
|
Unique "UniqueInboxItemRemote" ["inbox", "activity"]
|
|
-- 105
|
|
, addUnique "Person" $ Unique "UniquePersonInbox" ["inbox"]
|
|
-- 106
|
|
, addFieldRefRequired'
|
|
"Project"
|
|
Inbox20190609
|
|
(Just $ do
|
|
jids <- selectKeysList ([] :: [Filter Project20190609]) []
|
|
for_ jids $ \ jid -> do
|
|
ibid <- insert Inbox20190609
|
|
update jid [Project20190609Inbox =. ibid]
|
|
)
|
|
"inbox"
|
|
"Inbox"
|
|
-- 107
|
|
, addUnique "Project" $ Unique "UniqueProjectInbox" ["inbox"]
|
|
-- 108
|
|
, addUnique "RemoteMessage" $ Unique "UniqueRemoteMessageCreate" ["create"]
|
|
-- 109
|
|
, unchecked $ lift $ do
|
|
ibiids <- selectKeysList ([] :: [Filter InboxItem2019Fill]) []
|
|
activities <- for ibiids $ \ ibiid ->
|
|
requireEitherAlt
|
|
(fmap inboxItemLocal2019FillActivity <$>
|
|
getValBy (UniqueInboxItemLocalItem2019Fill ibiid)
|
|
)
|
|
(fmap inboxItemRemote2019FillActivity <$>
|
|
getValBy (UniqueInboxItemRemoteItem2019Fill ibiid)
|
|
)
|
|
"InboxItem neither remote nor local"
|
|
"InboxItem both remote and local"
|
|
let getValByJust = fmap fromJust . getValBy
|
|
for_ (nub activities) $ \ activity -> do
|
|
mid <- case activity of
|
|
Left obid ->
|
|
localMessage2019FillRest <$>
|
|
getValByJust
|
|
(UniqueLocalMessageCreate2019Fill obid)
|
|
Right ractid ->
|
|
remoteMessage2019FillRest <$>
|
|
getValByJust
|
|
(UniqueRemoteMessageCreate2019Fill ractid)
|
|
did <- message2019FillRoot <$> getJust mid
|
|
mt <- getValBy $ UniqueTicketDiscussion2019Fill did
|
|
for_ mt $ \ t -> do
|
|
ibid <-
|
|
project2019FillInbox <$> getJust (ticket2019FillProject t)
|
|
ibiid <- insert $ InboxItem2019Fill False
|
|
case activity of
|
|
Left obid ->
|
|
insert_ $ InboxItemLocal2019Fill ibid obid ibiid
|
|
Right ractid ->
|
|
insert_ $ InboxItemRemote2019Fill ibid ractid ibiid
|
|
-- 110
|
|
, addFieldRefRequired'
|
|
"Project"
|
|
FollowerSet20190610
|
|
(Just $ do
|
|
jids <- selectKeysList ([] :: [Filter Project20190610]) []
|
|
for_ jids $ \ jid -> do
|
|
fsid <- insert FollowerSet20190610
|
|
update jid [Project20190610Followers =. fsid]
|
|
)
|
|
"followers"
|
|
"FollowerSet"
|
|
-- 111
|
|
, addUnique "Project" $ Unique "UniqueProjectFollowers" ["followers"]
|
|
-- 112
|
|
, addFieldRefRequiredEmpty "TicketAuthorRemote" "offer" "RemoteActivity"
|
|
-- 113
|
|
, addUnique "TicketAuthorRemote" $
|
|
Unique "UniqueTicketAuthorRemoteOffer" ["offer"]
|
|
-- 114
|
|
, addFieldRefRequired''
|
|
"TicketAuthorLocal"
|
|
(do let user = "$$temp$$"
|
|
sid <-
|
|
insert $ Sharer20190612 (text2shr user) Nothing defaultTime
|
|
ibid <- insert Inbox20190612
|
|
pid <-
|
|
insert $
|
|
Person20190612
|
|
sid user "" "e@ma.il" False "" defaultTime ""
|
|
defaultTime "" ibid
|
|
let localUri = LocalURI "/x/y" ""
|
|
fedUri = l2f "x.y" localUri
|
|
doc = Doc "x.y" Activity
|
|
{ activityId = localUri
|
|
, activityActor = localUri
|
|
, activitySummary = Nothing
|
|
, activityAudience = Audience [] [] [] [] [] []
|
|
, activitySpecific = AcceptActivity $ Accept fedUri
|
|
}
|
|
insertEntity $ OutboxItem20190612 pid (PersistJSON doc) defaultTime
|
|
)
|
|
(Just $ \ (Entity obidTemp obTemp) -> do
|
|
ts <- selectList ([] :: [Filter Ticket20190612]) []
|
|
for_ ts $ \ (Entity tid ticket) -> do
|
|
let num = ticket20190612Number ticket
|
|
j <- getJust $ ticket20190612Project ticket
|
|
let prj = project20190612Ident j
|
|
ibidProject = project20190612Inbox j
|
|
sProject <- getJust $ project20190612Sharer j
|
|
let shrProject = sharer20190612Ident sProject
|
|
|
|
Entity talid tal <-
|
|
fromJust <$> getBy (UniqueTicketAuthorLocal20190612 tid)
|
|
let pidAuthor = ticketAuthorLocal20190612Author tal
|
|
pAuthor <- getJust pidAuthor
|
|
sAuthor <- getJust $ person20190612Ident pAuthor
|
|
let shrAuthor = sharer20190612Ident sAuthor
|
|
|
|
encodeRouteLocal <- getEncodeRouteLocal
|
|
encodeRouteHome <- getEncodeRouteHome
|
|
renderUrl <- askUrlRenderParams
|
|
let recips = map encodeRouteHome
|
|
[ ProjectR shrProject prj
|
|
, ProjectTeamR shrProject prj
|
|
, ProjectFollowersR shrProject prj
|
|
]
|
|
author = encodeRouteLocal $ SharerR shrAuthor
|
|
ticketAP = Ticket
|
|
{ ticketLocal = Nothing
|
|
, ticketAttributedTo = author
|
|
, ticketPublished =
|
|
Just $ ticket20190612Created ticket
|
|
, ticketUpdated = Nothing
|
|
, ticketName = Just $ "#" <> T.pack (show num)
|
|
, ticketSummary =
|
|
TextHtml $ TL.toStrict $ renderHtml $ toHtml $
|
|
ticket20190612Title ticket
|
|
, ticketContent =
|
|
TextHtml $ ticket20190612Description ticket
|
|
, ticketSource =
|
|
TextPandocMarkdown $ ticket20190612Source ticket
|
|
, ticketAssignedTo = Nothing
|
|
, ticketIsResolved = False
|
|
, ticketDependsOn = []
|
|
, ticketDependedBy = []
|
|
}
|
|
summary =
|
|
[hamlet|
|
|
<p>
|
|
<a href=@{SharerR shrAuthor}>
|
|
#{shr2text shrAuthor}
|
|
\ offered a ticket to project #
|
|
<a href=@{ProjectR shrProject prj}>
|
|
./s/#{shr2text shrProject}/p/#{prj2text prj}
|
|
: #{ticket20190612Title ticket}.
|
|
|]
|
|
doc luAct = Doc hLocal Activity
|
|
{ activityId = luAct
|
|
, activityActor = author
|
|
, activitySummary =
|
|
Just $ TextHtml $ TL.toStrict $ renderHtml $
|
|
summary renderUrl
|
|
, activityAudience = Audience recips [] [] [] [] []
|
|
, activitySpecific = OfferActivity Offer
|
|
{ offerObject = ticketAP
|
|
, offerTarget =
|
|
encodeRouteHome $ ProjectR shrProject prj
|
|
}
|
|
}
|
|
tempUri = LocalURI "" ""
|
|
obidNew <- insert OutboxItem20190612
|
|
{ outboxItem20190612Person = pidAuthor
|
|
, outboxItem20190612Activity = PersistJSON $ doc tempUri
|
|
, outboxItem20190612Published =
|
|
ticket20190612Created ticket
|
|
}
|
|
obkhidNew <-
|
|
encodeKeyHashid $ E.toSqlKey $ E.fromSqlKey obidNew
|
|
let luAct =
|
|
encodeRouteLocal $
|
|
SharerOutboxItemR shrAuthor obkhidNew
|
|
act = doc luAct
|
|
update obidNew [OutboxItem20190612Activity =. PersistJSON act]
|
|
update talid [TicketAuthorLocal20190612Offer =. obidNew]
|
|
ibiid <- insert $ InboxItem20190612 False
|
|
insert_ $ InboxItemLocal20190612 ibidProject obidNew ibiid
|
|
|
|
delete obidTemp
|
|
let pidTemp = outboxItem20190612Person obTemp
|
|
pTemp <- getJust pidTemp
|
|
delete pidTemp
|
|
delete $ person20190612Ident pTemp
|
|
delete $ person20190612Inbox pTemp
|
|
)
|
|
"offer"
|
|
"OutboxItem"
|
|
-- 115
|
|
, addUnique "TicketAuthorLocal" $
|
|
Unique "UniqueTicketAuthorLocaleOffer" ["offer"]
|
|
-- 116
|
|
, addEntity $ ST.Entity "Outbox" [] []
|
|
-- 117
|
|
, addFieldRefRequired'
|
|
"Person"
|
|
Outbox20190615
|
|
(Just $ do
|
|
pids <- selectKeysList ([] :: [Filter Person20190615]) []
|
|
for_ pids $ \ pid -> do
|
|
obid <- insert Outbox20190615
|
|
update pid [Person20190615Outbox =. obid]
|
|
)
|
|
"outbox"
|
|
"Outbox"
|
|
-- 118
|
|
, addUnique "Person" $ Unique "UniquePersonOutbox" ["outbox"]
|
|
-- 119
|
|
, addFieldRefRequired'
|
|
"OutboxItem"
|
|
Outbox20190615
|
|
(Just $ do
|
|
obiids <- selectList ([] :: [Filter OutboxItem20190615]) []
|
|
for_ obiids $ \ (Entity obiid obi) -> do
|
|
person <- getJust $ outboxItem20190615Person obi
|
|
let obid = person20190615Outbox person
|
|
update obiid [OutboxItem20190615Outbox =. obid]
|
|
)
|
|
"outbox"
|
|
"Outbox"
|
|
-- 120
|
|
, removeField "OutboxItem" "person"
|
|
-- 121
|
|
, addFieldRefRequired'
|
|
"Project"
|
|
Outbox20190616
|
|
(Just $ do
|
|
jids <- selectKeysList ([] :: [Filter Project20190616]) []
|
|
for_ jids $ \ jid -> do
|
|
obid <- insert Outbox20190616
|
|
update jid [Project20190616Outbox =. obid]
|
|
)
|
|
"outbox"
|
|
"Outbox"
|
|
-- 122
|
|
, addUnique "Project" $ Unique "UniqueProjectOutbox" ["outbox"]
|
|
-- 123
|
|
, unchecked $ lift $ do
|
|
ts <- selectList ([] :: [Filter Ticket20190612]) []
|
|
for_ ts $ \ (Entity tid t) ->
|
|
let title =
|
|
TL.toStrict $ renderHtml $ toHtml $ ticket20190612Title t
|
|
in update tid [Ticket20190612Title =. title]
|
|
]
|
|
|
|
migrateDB
|
|
:: (MonadSite m, SiteEnv m ~ App)
|
|
=> 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
|