{-# LANGUAGE DeriveAnyClass, DerivingStrategies #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Lorentz.UStore.Migration.Base
(
InitUStore
, SomeUTemplate
, UStore_
, toUStore_
, fromUStore_
, MigrationScript (..)
, maNameL
, maScriptL
, maActionsDescL
, MigrationAtom (..)
, UStoreMigration (..)
, UStoreMigrationT
, MigrationBlocks (..)
, MUStore (..)
, migrationToLambda
, mapMigrationCode
, mkUStoreMigration
, migrationToScript
, MigrationBatching (..)
, mbBatchesAsIs
, mbNoBatching
, compileMigration
, UStoreMigrationCompiled (..)
, mkUStoreBatchedMigration
, migrationToScripts
, migrationToScriptsList
, migrationToInfo
, migrationStagesNum
, buildMigrationPlan
, manualWithUStore
, manualConcatMigrationScripts
, DMigrationActionType (..)
, DMigrationActionDesc (..)
, attachMigrationActionName
, formMigrationAtom
) where
import Control.Lens (traversed, _Wrapped')
import Data.Default (def)
import qualified Data.Foldable as Foldable
import qualified Data.Kind as Kind
import Data.Singletons (SingI(..), demote)
import qualified Data.Typeable as Typeable
import Data.Vinyl.Derived (Label)
import Fmt (Buildable(..), Builder, fmt)
import Lorentz.Base
import Lorentz.Coercions
import Lorentz.Doc
import Lorentz.Instr (nop)
import Lorentz.Run
import Lorentz.UStore.Types
import Lorentz.Value
import Michelson.Typed (ExtInstr(..), Instr(..), T(..))
import Michelson.Typed.Util
import Util.Lens
import Util.TypeLits
import Lorentz.UStore.Migration.Diff
type InitUStore = UStore ()
data SomeUTemplate
type UStore_ = UStore SomeUTemplate
toUStore_ :: UStore template -> UStore_
toUStore_ (UStore s) = (UStore s)
fromUStore_ :: UStore_ -> UStore template
fromUStore_ (UStore s) = (UStore s)
newtype MigrationScript = MigrationScript
{ unMigrationScript :: Lambda UStore_ UStore_
} deriving stock (Show, Generic)
deriving anyclass IsoValue
instance Wrapped MigrationScript
instance TypeHasDoc MigrationScript where
typeDocMdDescription =
"A code which updates storage in order to make it compliant with the \
\new version of the contract."
manualWithUStore
:: forall ustore template.
(ustore ~ UStore template)
=> ('[ustore] :-> '[ustore]) -> MigrationScript
manualWithUStore action = MigrationScript $ coerce_ # action # coerce_
manualConcatMigrationScripts :: [MigrationScript] -> MigrationScript
manualConcatMigrationScripts =
MigrationScript . foldl' (#) nop . fmap unMigrationScript
data DMigrationActionType
= DAddAction Text
| DDelAction
deriving (Show)
instance Buildable DMigrationActionType where
build = \case
DAddAction a -> build a
DDelAction -> "remove"
data DMigrationActionDesc = DMigrationActionDesc
{ manAction :: DMigrationActionType
, manField :: Text
, manFieldType :: T
} deriving (Show)
instance DocItem DMigrationActionDesc where
type DocItemPosition DMigrationActionDesc = 105010
docItemSectionName = Nothing
docItemToMarkdown _ _ = "Migration action"
attachMigrationActionName
:: (KnownSymbol fieldName, SingI (ToT fieldTy))
=> DMigrationActionType
-> Label fieldName
-> Proxy fieldTy
-> s :-> s
attachMigrationActionName action (_ :: Label fieldName) (_ :: Proxy fieldTy) =
doc $ DMigrationActionDesc
{ manAction = action
, manField = symbolValT' @fieldName
, manFieldType = demote @(ToT fieldTy)
}
data MigrationAtom = MigrationAtom
{ maName :: Text
, maScript :: MigrationScript
, maActionsDesc :: [DMigrationActionDesc]
} deriving (Show)
makeLensesWith postfixLFields ''MigrationAtom
data UStoreMigration (oldStore :: Kind.Type) (newStore :: Kind.Type) where
UStoreMigration
:: (oldStore ~ UStore oldTemplate, newStore ~ UStore newTemplate)
=> [MigrationAtom]
-> UStoreMigration oldStore newStore
type UStoreMigrationT ot nt = UStoreMigration (UStore ot) (UStore nt)
migrationToLambda
:: UStoreMigrationT oldTemplate newTemplate
-> Lambda (UStore oldTemplate) (UStore newTemplate)
migrationToLambda (UStoreMigration atoms) =
coerce_ # foldMap (unMigrationScript . maScript) atoms # coerce_
mapMigrationCode
:: (forall i o. (i :-> o) -> (i :-> o))
-> UStoreMigration os ns
-> UStoreMigration os ns
mapMigrationCode f (UStoreMigration atoms) =
UStoreMigration $
atoms & traversed . maScriptL . _Wrapped' %~ f
newtype MigrationBlocks (oldTemplate :: Kind.Type) (newTemplate :: Kind.Type)
(preRemDiff :: [DiffItem]) (preTouched :: [Symbol])
(postRemDiff :: [DiffItem]) (postTouched :: [Symbol]) =
MigrationBlocks [MigrationAtom]
newtype MUStore (oldTemplate :: Kind.Type) (newTemplate :: Kind.Type)
(remDiff :: [DiffItem]) (touched :: [Symbol]) =
MUStoreUnsafe (UStore oldTemplate)
deriving stock Generic
deriving anyclass IsoValue
formMigrationAtom
:: Maybe Text
-> Lambda UStore_ UStore_
-> MigrationAtom
formMigrationAtom mname code =
MigrationAtom
{ maName = name
, maScript = MigrationScript (coerce_ # code # coerce_)
, maActionsDesc = actionsDescs
}
where
name = case mname of
Just n -> n
Nothing ->
fmt . mconcat $ intersperse ", "
[ build action <> " \"" <> build field <> "\""
| DMigrationActionDesc action field _type <- actionsDescs
]
actionsDescs =
let instr = compileLorentz code
(_, actions) = dfsInstr def (\i -> (i, pickActionDescs i)) instr
in actions
pickActionDescs :: Instr i o -> [DMigrationActionDesc]
pickActionDescs i = case i of
Ext (DOC_ITEM (SomeDocItem di)) ->
[ d
| Just d@DMigrationActionDesc{} <- pure $ Typeable.cast di
]
_ -> []
data MigrationBatching (structure :: Kind.Type -> Kind.Type) (batchInfo :: Kind.Type) =
MigrationBatching ([MigrationAtom] -> structure (batchInfo, MigrationScript))
mbBatchesAsIs :: MigrationBatching [] Text
mbBatchesAsIs = MigrationBatching $
map (maName &&& maScript)
mbNoBatching :: MigrationBatching Identity Text
mbNoBatching = MigrationBatching $
Identity . \atoms ->
( mconcat . intersperse ", " $ maName <$> atoms
, manualConcatMigrationScripts (maScript <$> atoms)
)
mkUStoreBatchedMigration
:: MigrationBlocks oldTempl newTempl (BuildDiff oldTempl newTempl) '[] '[] _1
-> UStoreMigrationT oldTempl newTempl
mkUStoreBatchedMigration (MigrationBlocks blocks) = UStoreMigration blocks
mkUStoreMigration
:: Lambda
(MUStore oldTempl newTempl (BuildDiff oldTempl newTempl) '[])
(MUStore oldTempl newTempl '[] _1)
-> UStoreMigrationT oldTempl newTempl
mkUStoreMigration code =
mkUStoreBatchedMigration $
MigrationBlocks . one . formMigrationAtom (Just "Migration") $
coerce_ # code # coerce_
newtype UStoreMigrationCompiled (structure :: Kind.Type -> Kind.Type) (batchInfo :: Kind.Type) =
UStoreMigrationCompiled
{ compiledMigrationContent :: structure (batchInfo, MigrationScript)
}
compileMigration
:: MigrationBatching t batchInfo
-> UStoreMigration ot nt
-> UStoreMigrationCompiled t batchInfo
compileMigration (MigrationBatching toBatches) (UStoreMigration blks) =
UStoreMigrationCompiled (toBatches blks)
migrationToScripts
:: Traversable t
=> UStoreMigrationCompiled t batchInfo
-> t MigrationScript
migrationToScripts = map snd . compiledMigrationContent
migrationToScriptsList
:: Traversable t
=> UStoreMigrationCompiled t batchInfo
-> [MigrationScript]
migrationToScriptsList = Foldable.toList . migrationToScripts
migrationToScript
:: UStoreMigration ot nt
-> MigrationScript
migrationToScript =
runIdentity . migrationToScripts . compileMigration mbNoBatching
migrationToInfo
:: Traversable t
=> UStoreMigrationCompiled t batchInfo
-> t batchInfo
migrationToInfo = map fst . compiledMigrationContent
migrationStagesNum
:: Traversable t
=> UStoreMigrationCompiled t batchInfo -> Int
migrationStagesNum = Foldable.length . migrationToScripts
buildMigrationPlan
:: (Traversable t, Buildable batchInfo)
=> UStoreMigrationCompiled t batchInfo -> Builder
buildMigrationPlan content =
let infos = Foldable.toList $ migrationToInfo content
in mconcat
[ "Migration stages:\n"
, mconcat $ zip [1..] infos <&> \(i :: Int, info) ->
build i <> ") " <> build info <> "\n"
]