-- SPDX-FileCopyrightText: 2020 Tocqueville Group -- -- SPDX-License-Identifier: LicenseRef-MIT-TQ {-# OPTIONS_GHC -Wno-redundant-constraints #-} {-# OPTIONS_GHC -Wno-orphans #-} {- | Basic migration primitives. All primitives in one scheme: MigrationBlocks (batched migrations writing) /| || muBlock // || mkUStoreBatchedMigration // || // || MUStore || UStore template value (simple migration writing) || (storage initialization) \\ || // \\ || // mkUStoreMigration \\ || // fillUStore \| \/ |/ UStoreMigration (whole migration) || \\ || \\ migrationToScript || \\ compileMigration || \\ MigrationBatching || \\ (way to slice migration) || \\ // || \\ // || \| |/ || UStoreMigrationCompiled || (sliced migration) || // \\ || migrationToScripts \\ buildMigrationPlan || // \\ migrationStagesNum || // \\ ... \/ |/ \| MigrationScript Information about migration (part of migration which (migration plan, stages number...) fits into Tezos transaction) -} module Lorentz.UStore.Migration.Base ( -- * 'UStore' utilities SomeUTemplate , UStore_ -- * Basic migration primitives , MigrationScript (..) , maNameL , maScriptL , maActionsDescL , MigrationScriptFrom , MigrationScriptTo , MigrationScript_ , MigrationAtom (..) , UStoreMigration (..) , MigrationBlocks (..) , MUStore (..) , migrationToLambda , mapMigrationCode -- ** Simple migrations , mkUStoreMigration , migrationToScript , migrationToScriptI -- ** Batched migrations , MigrationBatching (..) , mbBatchesAsIs , mbNoBatching , compileMigration , UStoreMigrationCompiled (..) , mkUStoreBatchedMigration , migrationToScripts , migrationToScriptsList , migrationToInfo , migrationStagesNum , buildMigrationPlan -- * Manual migrations , manualWithOldUStore , manualWithNewUStore , manualConcatMigrationScripts , manualMapMigrationScript -- * Extras , DMigrationActionType (..) , DMigrationActionDesc (..) , attachMigrationActionName -- * Internals , formMigrationAtom ) where import Control.Lens (traversed) import qualified Data.Foldable as Foldable import qualified Data.Kind as Kind import Data.Singletons (SingI(..), demote) import qualified Data.Typeable as Typeable import Fmt (Buildable(..), Builder, fmt) import Lorentz.Base import Lorentz.Coercions import Lorentz.Doc import Lorentz.UStore.Doc import Lorentz.TypeAnns (HasTypeAnn) import Lorentz.Instr (nop) import Lorentz.Run import Lorentz.UStore.Types import Lorentz.Value import Michelson.Typed.Haskell.Doc (applyWithinParens) import Michelson.Typed (ExtInstr(..), Instr(..), T(..)) import Michelson.Typed.Util import Util.Label (labelToText) import Util.Lens import Util.Markdown import Util.TypeLits import Lorentz.UStore.Migration.Diff ---------------------------------------------------------------------------- -- UStore utilities ---------------------------------------------------------------------------- -- | Dummy template for 'UStore', use this when you want to forget exact template -- and make type of store homomorphic. data SomeUTemplate -- | UStore with hidden template. type UStore_ = UStore SomeUTemplate -- | We allow casting between 'UStore_' and 'UStore' freely. instance SameUStoreTemplate template1 template2 => UStore template1 `CanCastTo` UStore template2 type family SameUStoreTemplate (template1 :: Kind.Type) (template2 :: Kind.Type) :: Constraint where SameUStoreTemplate t t = () -- case for undeducible but equal types SameUStoreTemplate SomeUTemplate _ = () SameUStoreTemplate _ SomeUTemplate = () SameUStoreTemplate t1 t2 = (t1 ~ t2) instance UStoreTemplateHasDoc SomeUTemplate where ustoreTemplateDocName = "Some" ustoreTemplateDocDescription = "This is a dummy template, usually designates that any format can be used \ \here." ustoreTemplateDocContents = mdItalic "unspecified" ustoreTemplateDocDependencies = [] ---------------------------------------------------------------------------- -- Migration primitives ---------------------------------------------------------------------------- -- | Code of migration for 'UStore'. -- -- Invariant: preferably should fit into op size / gas limits (quite obvious). -- Often this stands for exactly one stage of migration (one Tezos transaction). newtype MigrationScript (oldStore :: Kind.Type) (newStore :: Kind.Type) = MigrationScript { unMigrationScript :: Lambda UStore_ UStore_ } deriving stock (Show, Generic) deriving anyclass (IsoValue, HasTypeAnn) instance Wrapped (MigrationScript oldStore newStore) instance (Each [Typeable, UStoreTemplateHasDoc] [oldStore, newStore]) => TypeHasDoc (MigrationScript oldStore newStore) where typeDocMdDescription = "A code which updates storage in order to make it compliant with the \ \new version of the contract.\n\ \It is common to have a group of migration scripts because each of it \ \is to be used in Tezos transaction and thus should fit into gas and \ \operation size limits.\ \" typeDocMdReference tp wp = applyWithinParens wp $ mconcat [ mdLocalRef (mdTicked "MigrationScript") (docItemRef (DType tp)) , " " , dUStoreTemplateRef (DUStoreTemplate (Proxy @oldStore)) , " " , dUStoreTemplateRef (DUStoreTemplate (Proxy @newStore)) ] typeDocDependencies p = [ dTypeDep @(UStore oldStore) , dTypeDep @(UStore newStore) ] <> genericTypeDocDependencies p typeDocHaskellRep = homomorphicTypeDocHaskellRep typeDocMichelsonRep = homomorphicTypeDocMichelsonRep instance Lambda (UStore ot1) (UStore nt1) `CanCastTo` Lambda (UStore ot2) (UStore nt2) => MigrationScript ot1 nt1 `CanCastTo` MigrationScript ot2 nt2 -- | Corner case of 'MigrationScript' with some type argument unknown. -- -- You can turn this into 'MigrationScript' using 'checkedCoerce'. type MigrationScriptFrom oldStore = MigrationScript oldStore SomeUTemplate type MigrationScriptTo newStore = MigrationScript SomeUTemplate newStore type MigrationScript_ = MigrationScript SomeUTemplate SomeUTemplate -- | Manually perform a piece of migration. manualWithUStore :: forall ustore template oldStore newStore. (ustore ~ UStore template) => ('[ustore] :-> '[ustore]) -> MigrationScript oldStore newStore manualWithUStore action = MigrationScript $ checkedCoercing_ action manualWithOldUStore :: ('[UStore oldStore] :-> '[UStore oldStore]) -> MigrationScript oldStore newStore manualWithOldUStore = manualWithUStore manualWithNewUStore :: ('[UStore newStore] :-> '[UStore newStore]) -> MigrationScript oldStore newStore manualWithNewUStore = manualWithUStore -- | Modify code under given 'MigrationScript'. -- -- Avoid using this function when constructing a batched migration because -- batching logic should know size of the code precisely, consider mapping -- 'UStoreMigration' instead. manualMapMigrationScript :: (('[UStore_] :-> '[UStore_]) -> ('[UStore_] :-> '[UStore_])) -> MigrationScript oldStore newStore -> MigrationScript oldStore newStore manualMapMigrationScript f = MigrationScript . f . unMigrationScript -- | Merge several migration scripts. Used in manual migrations. -- -- This function is generally unsafe because resulting migration script can fail -- to fit into operation size limit. manualConcatMigrationScripts :: [MigrationScript os ns] -> MigrationScript os ns manualConcatMigrationScripts = MigrationScript . foldl' (#) nop . fmap unMigrationScript -- | An action on storage entry. data DMigrationActionType = DAddAction Text -- ^ Some sort of addition: "init", "set", "overwrite", e.t.c. | DDelAction -- ^ Removal. deriving stock Show instance Buildable DMigrationActionType where build = \case DAddAction a -> build a DDelAction -> "remove" -- | Describes single migration action. -- -- In most cases it is possible to derive reasonable description for migration -- atom automatically, this datatype exactly carries this information. data DMigrationActionDesc = DMigrationActionDesc { manAction :: DMigrationActionType -- ^ Action on field, e.g. "set", "remove", "overwrite". , manField :: Text -- ^ Name of affected field of 'UStore'. , manFieldType :: T -- ^ Type of affected field of 'UStore' in new storage version. } deriving stock Show -- Sad that we need to write this useless documentation instance, probably it's -- worth generalizing @doc_group@ and @doc_item@ instructions so that they -- could serve as multi-purpose markers. instance DocItem DMigrationActionDesc where type DocItemPosition DMigrationActionDesc = 105010 docItemSectionName = Nothing docItemToMarkdown _ _ = "Migration action" -- | Add description of action, it will be used in rendering migration plan and -- some batching implementations. attachMigrationActionName :: SingI (ToT fieldTy) => DMigrationActionType -> Label fieldName -> Proxy fieldTy -> s :-> s attachMigrationActionName action label (_ :: Proxy fieldTy) = doc $ DMigrationActionDesc { manAction = action , manField = labelToText label , manFieldType = demote @(ToT fieldTy) } -- | Minimal possible piece of migration script. -- -- Different atoms can be arbitrarily reordered and separated across migration -- stages, but each single atom is treated as a whole. -- -- Splitting migration into atoms is responsibility of migration writer. data MigrationAtom = MigrationAtom { maName :: Text , maScript :: MigrationScript_ , maActionsDesc :: [DMigrationActionDesc] } deriving stock (Show) makeLensesWith postfixLFields ''MigrationAtom -- | Keeps information about migration between 'UStore's with two given -- templates. data UStoreMigration (oldTempl :: Kind.Type) (newTempl :: Kind.Type) where UStoreMigration :: [MigrationAtom] -> UStoreMigration oldTempl newTempl -- | Turn 'Migration' into a whole piece of code for transforming storage. -- -- This is not want you'd want to use for contract deployment because of -- gas and operation size limits that Tezos applies to transactions. migrationToLambda :: UStoreMigration oldTemplate newTemplate -> Lambda (UStore oldTemplate) (UStore newTemplate) migrationToLambda (UStoreMigration atoms) = checkedCoerce_ # foldMap (unMigrationScript . maScript) atoms # checkedCoerce_ instance MapLorentzInstr (UStoreMigration os ns) where mapLorentzInstr f (UStoreMigration atoms) = UStoreMigration $ atoms & traversed . maScriptL . _Wrapped' %~ f -- | Modify all code in migration. mapMigrationCode :: (forall i o. (i :-> o) -> (i :-> o)) -> UStoreMigration os ns -> UStoreMigration os ns mapMigrationCode = mapLorentzInstr {-# DEPRECATED mapMigrationCode "Use 'hoistLorentzInstr' instead" #-} -- | A bunch of migration atoms produced by migration writer. newtype MigrationBlocks (oldTemplate :: Kind.Type) (newTemplate :: Kind.Type) (preRemDiff :: [DiffItem]) (preTouched :: [Symbol]) (postRemDiff :: [DiffItem]) (postTouched :: [Symbol]) = MigrationBlocks [MigrationAtom] {- | Wrapper over 'UStore' which is currently being migrated. In type-level arguments it keeps * Old and new 'UStore' templates - mostly for convenience of the implementation. * Remaining diff which yet should be covered. Here we track migration progress. Once remaining diff is empty, migration is finished. * Names of fields which have already been touched by migration. Required to make getters safe. -} newtype MUStore (oldTemplate :: Kind.Type) (newTemplate :: Kind.Type) (remDiff :: [DiffItem]) (touched :: [Symbol]) = MUStoreUnsafe (UStore oldTemplate) deriving stock Generic deriving anyclass IsoValue -- | Create migration atom from code. -- -- This is an internal function, should not be used for writing migrations. formMigrationAtom :: Maybe Text -> Lambda UStore_ UStore_ -> MigrationAtom formMigrationAtom mname code = MigrationAtom { maName = name , maScript = MigrationScript (checkedCoercing_ code) , 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 ] _ -> [] -- | Way of distributing migration atoms among batches. -- -- This also participates in describing migration plan and should contain -- information which would clarify to a user why migration is splitted -- such a way. Objects of type @batchInfo@ stand for information corresponding to -- a batch and may include e.g. names of taken actions and gas consumption. -- -- Type argument @structure@ stands for container where batches will be put to -- and is usually a list ('[]'). -- -- When writing an instance of this datatype, you should tend to produce -- as few batches as possible because Tezos transaction execution overhead -- is quite high; though these batches should still preferably fit into gas limit. -- -- Note that we never fail here because reaching perfect consistency with Tezos -- gas model is beyond dreams for now, even if our model predicts that some -- migration atom cannot be fit into gas limit, Tezos node can think differently -- and accept the migration. -- If your batching function can make predictions about fitting into gas limit, -- consider including this information in @batchInfo@ type. -- -- See batching implementations in "Lorentz.UStore.Migration.Batching" module. data MigrationBatching (structure :: Kind.Type -> Kind.Type) (batchInfo :: Kind.Type) = MigrationBatching ([MigrationAtom] -> structure (batchInfo, MigrationScript_)) -- | Put each migration atom to a separate batch. -- -- In most cases this is not what you want, but may be useful if e.g. you write -- your migration manually. mbBatchesAsIs :: MigrationBatching [] Text mbBatchesAsIs = MigrationBatching $ map (maName &&& maScript) -- | Put the whole migration into one batch. mbNoBatching :: MigrationBatching Identity Text mbNoBatching = MigrationBatching $ Identity . \atoms -> ( mconcat . intersperse ", " $ maName <$> atoms , manualConcatMigrationScripts (maScript <$> atoms) ) -- | Version of 'mkUStoreMigration' which allows splitting migration in batches. -- -- Here you supply a sequence of migration blocks which then are automatically -- distributed among migration stages. mkUStoreBatchedMigration :: MigrationBlocks oldTempl newTempl (BuildDiff oldTempl newTempl) '[] '[] _1 -> UStoreMigration oldTempl newTempl mkUStoreBatchedMigration (MigrationBlocks blocks) = UStoreMigration blocks -- | Safe way to create migration scripts for 'UStore'. -- -- You have to supply a code which would transform 'MUStore', -- coverring required diff step-by-step. -- All basic instructions work, also use @migrate*@ functions -- from this module to operate with 'MUStore'. -- -- This method produces a whole migration, it cannot be splitted in batches. -- In case if your migration is too big to be applied within a single -- transaction, use 'mkUStoreBatchedMigration'. mkUStoreMigration :: Lambda (MUStore oldTempl newTempl (BuildDiff oldTempl newTempl) '[]) (MUStore oldTempl newTempl '[] _1) -> UStoreMigration oldTempl newTempl mkUStoreMigration code = mkUStoreBatchedMigration $ MigrationBlocks . one . formMigrationAtom (Just "Migration") $ forcedCoerce_ # code # forcedCoerce_ -- | Migration script splitted in batches. -- -- This is an intermediate form of migration content and needed because -- compiling 'UStoreMigration' is a potentially heavyweight operation, -- and after compilation is performed you may need to get various information like -- number of migration steps, migration script, migration plan and other. newtype UStoreMigrationCompiled (oldStore :: Kind.Type) (newStore :: Kind.Type) (structure :: Kind.Type -> Kind.Type) (batchInfo :: Kind.Type) = UStoreMigrationCompiled { compiledMigrationContent :: structure (batchInfo, MigrationScript oldStore newStore) } -- | Compile migration for use in production. compileMigration :: (Functor t) => MigrationBatching t batchInfo -> UStoreMigration ot nt -> UStoreMigrationCompiled ot nt t batchInfo compileMigration (MigrationBatching toBatches) (UStoreMigration blks) = UStoreMigrationCompiled (second forcedCoerce <$> toBatches blks) -- | Get migration scripts, each to be executed in separate Tezos transaction. migrationToScripts :: Traversable t => UStoreMigrationCompiled os ns t batchInfo -> t (MigrationScript os ns) migrationToScripts = map snd . compiledMigrationContent -- | Get migration scripts as list. migrationToScriptsList :: Traversable t => UStoreMigrationCompiled os ns t batchInfo -> [MigrationScript os ns] migrationToScriptsList = Foldable.toList . migrationToScripts -- | Get migration script in case of simple (non-batched) migration. migrationToScriptI :: UStoreMigration os ns -> Identity (MigrationScript os ns) migrationToScriptI = migrationToScripts . compileMigration mbNoBatching -- | Get migration script in case of simple (non-batched) migration. migrationToScript :: UStoreMigration os ns -> MigrationScript os ns migrationToScript = runIdentity . migrationToScriptI -- | Get information about each batch. migrationToInfo :: Traversable t => UStoreMigrationCompiled ot nt t batchInfo -> t batchInfo migrationToInfo = map fst . compiledMigrationContent -- | Number of stages in migration. migrationStagesNum :: Traversable t => UStoreMigrationCompiled ot nt t batchInfo -> Int migrationStagesNum = Foldable.length . migrationToScripts -- | Render migration plan. buildMigrationPlan :: (Traversable t, Buildable batchInfo) => UStoreMigrationCompiled ot nt 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" ]