{-# LANGUAGE DeriveAnyClass, DerivingStrategies #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} {- | 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 InitUStore , SomeUTemplate , UStore_ , toUStore_ , fromUStore_ -- * Basic migration primitives , MigrationScript (..) , maNameL , maScriptL , maActionsDescL , MigrationAtom (..) , UStoreMigration (..) , UStoreMigrationT , MigrationBlocks (..) , MUStore (..) , migrationToLambda , mapMigrationCode -- ** Simple migrations , mkUStoreMigration , migrationToScript -- ** Batched migrations , MigrationBatching (..) , mbBatchesAsIs , mbNoBatching , compileMigration , UStoreMigrationCompiled (..) , mkUStoreBatchedMigration , migrationToScripts , migrationToScriptsList , migrationToInfo , migrationStagesNum , buildMigrationPlan -- * Manual migrations , manualWithUStore , manualConcatMigrationScripts -- * Extras , DMigrationActionType (..) , DMigrationActionDesc (..) , attachMigrationActionName -- * Internals , 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 ---------------------------------------------------------------------------- -- UStore utilities ---------------------------------------------------------------------------- -- | Absolutely empty storage. type InitUStore = UStore () -- | 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 toUStore_ :: UStore template -> UStore_ toUStore_ (UStore s) = (UStore s) fromUStore_ :: UStore_ -> UStore template fromUStore_ (UStore s) = (UStore s) ---------------------------------------------------------------------------- -- 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 = 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." -- | Manually perform a piece of migration. manualWithUStore :: forall ustore template. (ustore ~ UStore template) => ('[ustore] :-> '[ustore]) -> MigrationScript manualWithUStore action = MigrationScript $ coerce_ # action # coerce_ -- | 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] -> MigrationScript 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 (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 (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 :: (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) } -- | 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 (Show) makeLensesWith postfixLFields ''MigrationAtom -- | Keeps information about migration between 'UStore's with two given -- templates. -- Note that it is polymorphic over whole storage types, not their templates, -- for convenience (so that there is no need to export the template). data UStoreMigration (oldStore :: Kind.Type) (newStore :: Kind.Type) where UStoreMigration :: (oldStore ~ UStore oldTemplate, newStore ~ UStore newTemplate) => [MigrationAtom] -> UStoreMigration oldStore newStore -- | Alias for 'UStoreMigration' which accepts UStore templates -- as type arguments. type UStoreMigrationT ot nt = UStoreMigration (UStore ot) (UStore nt) -- | 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 :: UStoreMigrationT oldTemplate newTemplate -> Lambda (UStore oldTemplate) (UStore newTemplate) migrationToLambda (UStoreMigration atoms) = coerce_ # foldMap (unMigrationScript . maScript) atoms # coerce_ -- | Modify all code in migration. mapMigrationCode :: (forall i o. (i :-> o) -> (i :-> o)) -> UStoreMigration os ns -> UStoreMigration os ns mapMigrationCode f (UStoreMigration atoms) = UStoreMigration $ atoms & traversed . maScriptL . _Wrapped' %~ f -- | 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 (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 ] _ -> [] -- | 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 -> UStoreMigrationT 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) -> UStoreMigrationT oldTempl newTempl mkUStoreMigration code = mkUStoreBatchedMigration $ MigrationBlocks . one . formMigrationAtom (Just "Migration") $ coerce_ # code # coerce_ -- | 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 (structure :: Kind.Type -> Kind.Type) (batchInfo :: Kind.Type) = UStoreMigrationCompiled { compiledMigrationContent :: structure (batchInfo, MigrationScript) } -- | Compile migration for use in production. compileMigration :: MigrationBatching t batchInfo -> UStoreMigration ot nt -> UStoreMigrationCompiled t batchInfo compileMigration (MigrationBatching toBatches) (UStoreMigration blks) = UStoreMigrationCompiled (toBatches blks) -- | Get migration scripts, each to be executed in separate Tezos transaction. migrationToScripts :: Traversable t => UStoreMigrationCompiled t batchInfo -> t MigrationScript migrationToScripts = map snd . compiledMigrationContent -- | Get migration scripts as list. migrationToScriptsList :: Traversable t => UStoreMigrationCompiled t batchInfo -> [MigrationScript] migrationToScriptsList = Foldable.toList . migrationToScripts -- | Get migration script in case of simple (non-batched) migration. migrationToScript :: UStoreMigration ot nt -> MigrationScript migrationToScript = runIdentity . migrationToScripts . compileMigration mbNoBatching -- | Get information about each batch. migrationToInfo :: Traversable t => UStoreMigrationCompiled t batchInfo -> t batchInfo migrationToInfo = map fst . compiledMigrationContent -- | Number of stages in migration. migrationStagesNum :: Traversable t => UStoreMigrationCompiled t batchInfo -> Int migrationStagesNum = Foldable.length . migrationToScripts -- | Render migration plan. 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" ]