{-# OPTIONS_GHC -Wno-redundant-constraints #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Lorentz.UStore.Migration.Base
(
SomeUTemplate
, UStore_
, MigrationScript (..)
, maNameL
, maScriptL
, maActionsDescL
, MigrationScriptFrom
, MigrationScriptTo
, MigrationScript_
, MigrationAtom (..)
, UStoreMigration (..)
, MigrationBlocks (..)
, MUStore (..)
, migrationToLambda
, mapMigrationCode
, mkUStoreMigration
, migrationToScript
, migrationToScriptI
, MigrationBatching (..)
, mbBatchesAsIs
, mbNoBatching
, compileMigration
, UStoreMigrationCompiled (..)
, mkUStoreBatchedMigration
, migrationToScripts
, migrationToScriptsList
, migrationToInfo
, migrationStagesNum
, buildMigrationPlan
, manualWithOldUStore
, manualWithNewUStore
, manualConcatMigrationScripts
, manualMapMigrationScript
, 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
data SomeUTemplate
type UStore_ = UStore SomeUTemplate
instance SameUStoreTemplate template1 template2 =>
UStore template1 `CanCastTo` UStore template2
type family SameUStoreTemplate (template1 :: Kind.Type) (template2 :: Kind.Type)
:: Constraint where
SameUStoreTemplate t t = ()
SameUStoreTemplate SomeUTemplate _ = ()
SameUStoreTemplate _ SomeUTemplate = ()
SameUStoreTemplate t1 t2 = (t1 ~ t2)
newtype MigrationScript (oldStore :: Kind.Type) (newStore :: Kind.Type) =
MigrationScript
{ unMigrationScript :: Lambda UStore_ UStore_
} deriving stock (Show, Generic)
deriving anyclass IsoValue
instance Wrapped (MigrationScript oldStore newStore)
instance (Typeable oldStore, Typeable 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."
typeDocMdReference tp = customTypeDocMdReference ("MigrationScript", DType tp) []
typeDocHaskellRep = homomorphicTypeDocHaskellRep
typeDocMichelsonRep = homomorphicTypeDocMichelsonRep
instance Lambda (UStore ot1) (UStore nt1) `CanCastTo` Lambda (UStore ot2) (UStore nt2) =>
MigrationScript ot1 nt1 `CanCastTo` MigrationScript ot2 nt2
type MigrationScriptFrom oldStore = MigrationScript oldStore SomeUTemplate
type MigrationScriptTo newStore = MigrationScript SomeUTemplate newStore
type MigrationScript_ = MigrationScript SomeUTemplate SomeUTemplate
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
manualMapMigrationScript
:: (('[UStore_] :-> '[UStore_]) -> ('[UStore_] :-> '[UStore_]))
-> MigrationScript oldStore newStore
-> MigrationScript oldStore newStore
manualMapMigrationScript f = MigrationScript . f . unMigrationScript
manualConcatMigrationScripts :: [MigrationScript os ns] -> MigrationScript os ns
manualConcatMigrationScripts =
MigrationScript . foldl' (#) nop . fmap unMigrationScript
data DMigrationActionType
= DAddAction Text
| DDelAction
deriving stock (Show)
instance Buildable DMigrationActionType where
build = \case
DAddAction a -> build a
DDelAction -> "remove"
data DMigrationActionDesc = DMigrationActionDesc
{ manAction :: DMigrationActionType
, manField :: Text
, manFieldType :: T
} deriving stock (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 stock (Show)
makeLensesWith postfixLFields ''MigrationAtom
data UStoreMigration (oldTempl :: Kind.Type) (newTempl :: Kind.Type) where
UStoreMigration
:: [MigrationAtom]
-> UStoreMigration oldTempl newTempl
migrationToLambda
:: UStoreMigration oldTemplate newTemplate
-> Lambda (UStore oldTemplate) (UStore newTemplate)
migrationToLambda (UStoreMigration atoms) =
checkedCoerce_ # foldMap (unMigrationScript . maScript) atoms # checkedCoerce_
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 (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
]
_ -> []
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
-> UStoreMigration oldTempl newTempl
mkUStoreBatchedMigration (MigrationBlocks blocks) = UStoreMigration blocks
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_
newtype UStoreMigrationCompiled
(oldStore :: Kind.Type) (newStore :: Kind.Type)
(structure :: Kind.Type -> Kind.Type) (batchInfo :: Kind.Type) =
UStoreMigrationCompiled
{ compiledMigrationContent
:: structure (batchInfo, MigrationScript oldStore newStore)
}
compileMigration
:: (Functor t)
=> MigrationBatching t batchInfo
-> UStoreMigration ot nt
-> UStoreMigrationCompiled ot nt t batchInfo
compileMigration (MigrationBatching toBatches) (UStoreMigration blks) =
UStoreMigrationCompiled (second forcedCoerce <$> toBatches blks)
migrationToScripts
:: Traversable t
=> UStoreMigrationCompiled os ns t batchInfo
-> t (MigrationScript os ns)
migrationToScripts = map snd . compiledMigrationContent
migrationToScriptsList
:: Traversable t
=> UStoreMigrationCompiled os ns t batchInfo
-> [MigrationScript os ns]
migrationToScriptsList = Foldable.toList . migrationToScripts
migrationToScriptI
:: UStoreMigration os ns
-> Identity (MigrationScript os ns)
migrationToScriptI =
migrationToScripts . compileMigration mbNoBatching
migrationToScript
:: UStoreMigration os ns
-> MigrationScript os ns
migrationToScript =
runIdentity . migrationToScriptI
migrationToInfo
:: Traversable t
=> UStoreMigrationCompiled ot nt t batchInfo
-> t batchInfo
migrationToInfo = map fst . compiledMigrationContent
migrationStagesNum
:: Traversable t
=> UStoreMigrationCompiled ot nt t batchInfo -> Int
migrationStagesNum = Foldable.length . migrationToScripts
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"
]