packages feed

morley-upgradeable (empty) → 0.3

raw patch · 58 files changed

+7736/−0 lines, 58 filesdep +HUnitdep +base-nopreludedep +cleveland

Dependencies added: HUnit, base-noprelude, cleveland, colourista, constraints, containers, first-class-families, fmt, hedgehog, hex-text, hspec, lens, lorentz, morley, morley-client, morley-prelude, morley-upgradeable, mtl, optparse-applicative, singletons, tasty, tasty-hspec, tasty-hunit-compat, text, vinyl, with-utf8

Files

+ CHANGES.md view
@@ -0,0 +1,8 @@+Unreleased+==========+<!-- Append new entries here -->++0.3+======+* [!7](https://gitlab.com/morley-framework/morley-upgradeable/-/merge_requests/7)+  + Use `morley-1.14.0` and `lorentz-0.11.0`.
+ LICENSE view
@@ -0,0 +1,19 @@+MIT License Copyright (c) 2020 Tocqueville Group++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is furnished+to do so, subject to the following conditions:++The above copyright notice and this permission notice (including the next+paragraph) shall be included in all copies or substantial portions of the+Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS+OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF+OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,4 @@+# Morley Upgradeable++This package contains infrastructure that one can use to implement an upgradeable contract.+For overview of upgradeability approaches please read [the related document](/docs/upgradeableContracts.md).
+ app/Main.hs view
@@ -0,0 +1,171 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Main+  ( main+  ) where++import Data.Constraint (Dict(..))+import Data.Version (showVersion)+import Fmt (build, fmtLn, pretty)+import Main.Utf8 (withUtf8)+import Options.Applicative (Parser, ReadM)+import qualified Options.Applicative as Opt+import Paths_morley_upgradeable (version)++import Lorentz.Contracts.Upgradeable.Client+import Lorentz.Value+import qualified Michelson.Macro as U+import qualified Michelson.Parser as P+import Michelson.Printer.Util+import Michelson.Text+import Michelson.TypeCheck as TC+import qualified Michelson.Typed as T+import Michelson.Typed.Scope+import qualified Michelson.Untyped as U+import Morley.Client+import Tezos.Address++data PrintCmd+  = PrintField MText U.Ty+  | PrintEntrypoint MText+  | PrintSubmap MText U.ParsedValue U.Ty U.Ty++data CmdLnArgs = CmdLnArgs MorleyClientConfig Address PrintCmd++argParser :: Parser CmdLnArgs+argParser =+  CmdLnArgs <$> clientConfigParser (pure Nothing) <*> contractOption <*> cmdOption+  where+    contractOption = Opt.option (Opt.eitherReader parseAddrDo) . mconcat $+      [ Opt.long "contract"+      , Opt.short 'c'+      , Opt.metavar "ADDRESS"+      , Opt.help "Upgradeable contract address"+      ]+      where+      parseAddrDo addr =+        either (Left . mappend "Failed to parse address: " . pretty) Right $+        parseAddress $ toText addr++    cmdOption = Opt.hsubparser $ mconcat+      [ printFieldSubCmd+      , printEntrypointSubCmd+      , printSubmapSubCmd+      ]++    printFieldSubCmd =+      Opt.command "print-field" $+      Opt.info+        (PrintField <$> fieldNameOption <*> typeOption "type" "field value")+        (Opt.progDesc "Get field value.")++    printEntrypointSubCmd =+      Opt.command "print-entrypoint" $+      Opt.info+        (PrintEntrypoint <$> fieldNameOption)+        (Opt.progDesc "Get map value.")++    printSubmapSubCmd =+      Opt.command "print-map-value" $+      Opt.info+        (PrintSubmap+         <$> fieldNameOption+         <*> submapKeyOption+         <*> typeOption "key-type" "submap key"+         <*> typeOption "value-type" "submap value"+         )+        (Opt.progDesc "Get map value.")++    fieldNameOption = Opt.option mtextReadM $ mconcat+      [ Opt.long "field"+      , Opt.short 'f'+      , Opt.metavar "NAME"+      , Opt.help "Name of upgradeable storage field"+      ]++    typeOption name helpName = Opt.option typeReadM $ mconcat+      [ Opt.long name+      , Opt.metavar "MICHELSON TYPE"+      , Opt.help $ "Type of " <> helpName+      ]++    submapKeyOption = Opt.option valueReadM $ mconcat+      [ Opt.long "key"+      , Opt.short 'k'+      , Opt.metavar "MICHELSON VALUE"+      , Opt.help "Key in upgradeable storage submap"+      ]++    valueReadM = parsingReadM P.value++    mtextReadM :: ReadM MText+    mtextReadM = Opt.eitherReader $+      first toString . mkMText . toText++    typeReadM :: ReadM U.Ty+    typeReadM = parsingReadM P.type_++    parsingReadM :: P.Parser a -> ReadM a+    parsingReadM parser = Opt.eitherReader $+      first P.errorBundlePretty .+      P.parseNoEnv parser "command line arguments" .+      toText++programInfo :: Opt.ParserInfo CmdLnArgs+programInfo = Opt.info (Opt.helper <*> versionOption <*> argParser) $+  mconcat+  [ Opt.fullDesc+  , Opt.progDesc "Morley-ustore-reader: a tool for reading upgradeable \+                 \contract storage contents."+  , Opt.header "Morley tools"+  , Opt.footerDoc $ Just+      "NOTE: when using this tool, take into account that storage fields \+      \may differ from what appears in code, check whether some \+      \preprocessing takes place upon contract printing."+  ]+  where+    versionOption =+      Opt.infoOption ("morley-ustore-reader-" <> showVersion version)+        (Opt.long "version" <> Opt.help "Show version.")++mainImpl+  :: Address+  -> PrintCmd+  -> MorleyClientM ()+mainImpl contract cmd = do+  case cmd of+    PrintField field (T.AsUType (_ :: T.Notes ty)) -> do+      case checkScope @(UnpackedValScope ty) of+        Right Dict -> do+          val <- readContractUStore @ty contract (UrField field)+          liftIO . fmtLn $ build val+        Left bad ->+          die $ "Value type is invalid: " <> pretty bad++    PrintEntrypoint field -> do+      instrs <- readContractUStoreEntrypoint contract field+      liftIO . fmtLn . printDocB False $ renderOpsList False instrs++    PrintSubmap field key (T.AsUType (_ :: T.Notes kt))+                          (T.AsUType (_ :: T.Notes vt)) -> do+      case (checkScope @(PackedValScope kt), checkScope @(UnpackedValScope vt)) of+        (Right Dict, Right Dict) -> do+          keyT <-+            either (die . pretty) pure $+            runTypeCheckInstrIsolated $+            typeCheckValue @kt (U.expandValue key)+          let keyT' = T.SomeConstrainedValue keyT+          val <- readContractUStore @vt contract (UrSubmap field keyT')+          liftIO . fmtLn $ build val+        (Left bad, _) ->+          die $ "Key type is invalid: " <> pretty bad+        (_, Left bad) ->+          die $ "Value type is invalid: " <> pretty bad++main :: IO ()+main = withUtf8 $ do+  CmdLnArgs parsedConfig contract cmd <- Opt.execParser programInfo+  env <- mkMorleyClientEnv parsedConfig+  runMorleyClientM env (mainImpl contract cmd)
+ docs/upgradeableContracts.md view
@@ -0,0 +1,306 @@+<!--+SPDX-FileCopyrightText: 2020 Tocqueville Group++SPDX-License-Identifier: LicenseRef-MIT-TQ+-->++## Introduction+During the past several years, bugs and vulnerabilities in smart contracts caused millions of dollars to get stolen or lost forever. Such cases may even require [manual intervention][eth-dao] in blockchain operation to recover the funds. Apart from improving tools and languages, the community starts to acknowledge the need for upgradeable smart-contracts.++As the contracts get more and more complicated and integrated with the infrastructure, deploying a new version that is independent from the previous one is no longer an option. There are several goals one would usually like to achieve while developing an upgradeable contract:+  1. **Address immutability.** The contract address is used in users’ wallets, exchange integration code, external DApps, etc. Forcing users to change the contract address is quite hard to achieve. Moreover, variable contract address makes phishing attacks more probable. This is why it is desirable to leave the contract address intact while upgrading the contract.+  1. **Storage migration.** The new version of the contract must somehow know about the state of the previous one. As we show later in this document, this requirement is easy to fulfill for contracts with several bytes of storage but it becomes non-trivial when the storage size grows.+  1. **Type safety.** Since smart contracts are usually used to handle value, a cost of mistake can be large. Compile-time type safety may facilitate catching common programmer mistakes before the contract is deployed. This, in turn, leads to safer contracts and less value lost or stolen.++There are platforms that support upgradeability on the protocol level. For example, EOS ties contracts to the originator accounts that are able to upgrade their contracts at any point without any restrictions. It may give rise to fraudulent contracts pretending to be innocent at the time of origination but starting to behave malevolently after an upgrade. EOS community realizes this problem exists and takes some [precautions][eos-precautions] limiting the probability of such an outcome. Another example is Neo – a blockchain platform that also [offers][neo-migrate] smart contract migrating functionality. Unlike EOS, Neo performs only storage migration, while the address of the new version does not remain the same.++Other platforms like Ethereum or Tezos neither allow the contract code section to be modified, nor provide ways to deploy a new contract with an old storage. In order to make upgrades possible on these platforms, contract developers have to be explicit about their intent.++The contract code in Ethereum is immutable by design. The [only way][eth-yp] to execute a piece of code not supplied during the contract creation in EVM is to create a new contract and perform one of the `CALL`, `CALLCODE` or `DELEGATECALL` instructions on it (the difference between these is nicely described on [Ethereum StackExchange][eth-call-delegatecall]). The most important fact for the sake of this document is that the `DELEGATECALL` instruction preserves the execution context, i.e. the contract storage, transaction sender and the value remain as if the code of the callee was copy-pasted to the caller contract. This instruction as well as the described EVM limitations on custom code execution are the reasons why [_delegate proxy_ pattern][eth-proxy] has gained popularity as a simple way to create a contract with an upgradeable implementation, and the constant address and storage.++Contrary to Ethereum, Michelson can store and execute user-supplied lambda functions from storage. On the other hand, unlike `DELEGATECALL`, Michelson operations do not preserve the execution context. Thus, applying the proxy pattern to smart-contracts in Michelson requires the contract author to carefully pass the original sender and value as parameters to the callee. Moreover, if a new version of a contract is originated, the storage must be fully or partially transferred to the new version as well.++There are three most common options for storage upgrades — manual upgrade, [eternal storage][eth-eternal] and [lazy upgrades][eth-lazy].++When one originates a new contract in Tezos, she supplies an initial storage value. If the storage has just several entries, one can get the storage of the old contract and push it to the new one. We call this a **manual upgrade**. However, this approach is limited to small contracts only. There is an intrinsic limit on `max_operation_size` that makes cloning the storage cumbersome when it comes to copying `BigMap`s, large lists and other big chunks of data. Theoretically, one can update the data after the contract is originated using some special entry points. Nevertheless, if a data structure contains millions of existing values, it would be quite expensive and impractical.++Another idea is to have a special contract that would store the data and never need upgrading. **[Eternal storage][eth-eternal]** is a contract that provides a set of endpoints `get<T>(string variableName) -> Maybe T` and  `set<T>(string variableName, T value)`, where `<T>` is the value type we expect to set or get in return. In Ethereum implementation `<T>` is restricted to a set of primitive types, and the type safety is not guaranteed. Having a dedicated storage contract in Michelson poses additional challenges: it is not easy to view external contract storage in Michelson, and it would require the contract developers to drastically change the existing code.++**[Lazy upgrades][eth-lazy]** approach requires external calls as well but preserves type-safety. The basic idea is that the new version of a contract should call the previous reincarnation if it notices some data is missing. For instance, if one tries to transfer tokens from her balance, and there are no tokens allocated to the sender in the current version, the contract emits a view transaction to the previous version in order to find out the balance. While the approach seams appealing, the resulting code of the upgraded contract would have to branch on existing/non-existing data, emit operations, provide callbacks for view calls, etc. The complicated code can potentially lead to subtle vulnerabilities in the upgraded contract, and we want to avoid complexity as possible.++All the mechanisms described above assume that there is a contract administrator that rules the upgrades. In practice, administrator-forced upgrades are not applicable to some use-cases because they require a certain degree of trust in the person or organization that manages the contract. The users of the contract have to trust that the managing party handles the wallet keys safely and takes all the necessary precautions to prevent their leakage. Incidents like [Bancor hack][bancor-hack] have been reported showing practical evidence that upgrade administrator wallets can be compromised. In response to these threats, another contract upgrade paradigm – **user-defined upgrades** – has arisen.++The main idea of [user-defined upgrades][user-upgrade] is that the user of the contract is the only party that can choose whether to upgrade and transfer value to the next version of the contract or not. This paradigm offers additional benefit in case of project hard fork, since the user can decide which of the new versions to follow. On the other hand, if the original contract has a bug or vulnerability that threats users' funds or renders the contract unusable, user-defined upgrades can be less effective than administrator-forced ones.++In Section 1 of this document we propose a mechanism for user-defined upgrade of contracts that hold value. Section 2 focuses on administrator-forced upgrades and ways to implement them using Lorentz eDSL.++## Section 1. User-defined upgrades++User-defined contract upgrades are usually employed to transfer value from an old version of a contract to a new one. The implementation of the upgrade mechanism highly depends on the kinds of data users transfer between the contract versions, and it is quite hard to propose a one-size-fits-all solution. In this section we will describe an upgradeable ledger based on two contracts that hold value, V1 and V2. This description is supposed to be as minimal as possible to demonstrate a concept, and may be extended further based on the particular application.++The upgrade is initiated by the contract administrator. However, the users are free to not migrate their funds: the value of V1 and V2 tokens is market-defined. The upgrade process is the following:++1. Someone (most probably the administrator but it is not required) originates a new version of the contract, `V2`. She should also supply the address of `V1` to `V2`.+1. The administrator of `V1` calls `V1.InitiateMigration`.+  * `V1` should remember the address of `V2` and know how to call `V2.MigrateFrom`.+1. A user, if she so desires, calls `V1.MigrateMyTokens` to migrate her tokens to the new version of the contract.+  * The tokens of the user are burned in `V1`.+  * `V1` contract emits a `V2.MigrateFrom` operation.+  * `V2` mints new tokens for the user if the preconditions hold (see below).++If any of the operations in (3) fails, the migration transaction for this user fails as well.++Here, `V1.MigrateMyTokens` is an entrypoint that accepts a `Natural` — the number of tokens to migrate, and `V2.MigrateFrom` accepts an `(Address, Natural)` tuple that denotes the receiver and the number of new tokens to mint.++Let the parameter of `V1` be the following (additional entrypoints are allowed):+```+data Parameter+  = InitiateMigration EpAddress  -- the `MigrateFrom` entrypoint should be specified in EpAddress parameter+  | MigrateMyTokens Natural+```++And in `V2` just one entrypoint is required (additional entrypoints are allowed as well; this entrypoint can be named differently):+```+data Parameter+  = MigrateFrom (Address, Natural)+```++`V2` must also store the address of `V1` in its storage or contract code.++The administrator calls `V1.InitiateMigration` and supplies the address of `V2` along with the `MigrateFrom` entrypoint. `V1` remembers the address of `V2` and the specified entrypoint.++When users choose to migrate their funds, they call `V1.MigrateMyTokens`. If the migration is initialized, `V1` burns the requested amount of tokens from the sender's balance and emits a `V2.MigrateFrom` operation with the address of the sender and the specified minting amount.++Upon receiving a `V2.MigrateFrom` call, `V2` checks if the call sender is `V1`. If this precondition holds, `V2` mints the requested amount to the specified address, otherwise the transaction fails.++## Section 2. Administrator-forced upgrades++In this section we present an administrator-forced upgrade mechanism for Lorentz contracts.+It uses Ethereum's ideas that have already been applied to hundreds of contracts, Michelson's+lambda functions, and an advanced type system offered by Lorentz to provide address immutability,+implementation and storage upgrades, and _partial_ type safety.++The proposed mechanism offers type-safe interface interaction and storage access for each version+of an upgradeable contract.++Storage and parameter of an upgradeable contract are parametrized by a particular contract+version. Below simplified types versions are presented. For actual implementation+see the following [directory](/src/Lorentz/Contracts/Upgradeable/Common).++We define the storage and the parameter of a proposed upgradeable contract as follows:+```haskell+data Storage ver = Storage+  { dataMap :: UStore ver+  , fields :: StorageFields ver+  }++data StorageFields ver = StorageFields+  { code :: UContractRouter ver+  -- ^ Dispatching code that calls the packed entrypoints.+  , permCode :: PermanentImpl ver+  -- ^ Implementation of the permanent contract entrypoints. Actual permanent+  -- interface is defined by the 'ver' type parameter.+  , admin :: Address+  , currentVersion :: Version+  , paused :: Bool+  }++-- Version defines interface, the structure of the storage and the set of+-- permanent entrypoints.+class KnownContractVersion v where+  type VerInterface v :: [EntrypointKind]+  type VerUStoreTemplate v :: Kind.Type+  type VerPermanent v :: Kind.Type++type VerParam v = UParam (VerInterface v)+type VerUStore v = UStore (VerUStoreTemplate v)++data UContractRouter ver =+  UContractRouter+    { unUContractRouter+       :: Lambda (VerParam ver, VerUStore ver)+                 ([Operation], VerUStore ver)+    }++```+Types whose name start with `Some` hide the actual version and are used in+cases when the version does not matter.+```haskell++newtype PermanentImpl ver = PermanentImpl+  { unPermanentImpl :: Entrypoint (VerPermanent ver) (VerUStore ver)+  }++type UStore ver = BigMap ByteString ByteString++data Parameter ver =+  = Run (VerParam ver)+  | RunPerm (VerPermanent ver)+  | Upgrade (OneShotUpgradeParameters ver)+  | GetVersion (View () Version)+  | SetAdministrator Address+  ...++type OneShotUpgradeParameters ver =+  ( "currentVersion" :! Version+  , "newVersion" :! Version+  , "migrationScript" :! MigrationScriptFrom (VerUStoreTemplate ver)+  , "newCode" :! Maybe SomeUContractRouter+  , "newPermCode" :! Maybe (SomePermanentImpl ver)+  )++type UStore_ = UStore SomeUTemplate++newtype MigrationScript (oldStore :: Kind.Type) (newStore :: Kind.Type) =+  MigrationScript+  { unMigrationScript :: Lambda UStore_ UStore_+  }++type MigrationScriptFrom oldStore = MigrationScript oldStore SomeUTemplate+```++Since one can not upgrade the contract interface (expressed as a sum type)+after the contract has been deployed, the proposed upgradeable contract provides+a `Run (UParam ver)` endpoint that runs the specified named endpoint.+`UParam` is a type-safe wrapper over `(MText, ByteString)` pair, where the former+is the name of an endpoint, and the latter is a packed argument. The dispatching+algorithm of the upgradeable contract unpacks the arguments and passes the execution+to the corresponding code block.++### Implementation upgrade++The proposed upgradeable contract interface has an `Upgrade` endpoint that accepts a+new version of a contract. Prior to upgrade, the code of the new version must be split+into endpoints with string identifiers. These endpoints are supplied as the `newCode`+parameter of the upgrade. Apart from this, it is possible to upgrade the implementation+of the permanent entrypoints, their implementation is supplied as the `newPermCode`.++The user also supplies a fallback function, the new version identifier, and a migration+script described in the next section. After a successful upgrade, the new version of the+code is stored in `code`, the new implementation of permanent entrypoints is stored+in `permCode`. The user of the contract may interact with the newly-deployed code+using the `Run` endpoint we described earlier. Also, user can interact with the contract+using `RunPerm` endpoint or directly calling permanent entrypoints by their names.++All contract instances should use the same versioning to make it simpler to identify the+actual contract version.++### Storage upgrade++While `UStore_` is just a big map, contract code uses a special parametrized type+`UStore a` – a special type that represents a "generic storage". It resembles the idea+of the Ethereum's Eternal storage but, unlike the latter, stores `pack`ed data and is+modelled as a `BigMap ByteString ByteString` under the hood. Thus, `UStore_` can be+coerced to `UStore a` when needed.++The `UStore` of a contract must have a parameter that we use to generate a type-safe interface.+We call this parameter a `UStoreTemplate`. The contract code should not access `UStore_`+directly but rather coerce `UStore_` to a concrete `UStore UStoreTemplate` and use+`ustore{To,Get,Set}Field #label` instructions to access the fields.++`UStore_` is upgraded using migration scripts. `MigrationScript` is a lambda that performs+all the necessary operations to transform the `UStore_` from an old `UStoreTemplate`+to the new one, i.e. it:+  * deletes old unused fields,+  * adds new fields,+  * transfers data from old data structures to the new ones.++It is expected (though, not enforced) that after a migration is applied, the resulting+`UStore` is compatible with the new version of `UStoreTemplate`.++### Versioning+When a contract gets upgraded, it is easy to make a mistake and supply a wrong version+of the code and migration scripts.++To prevent inconsistent upgrades, an upgradeable contract stores `currentVersion :: Version`,+and provides a view endpoint `GetVersion (View () Version)` so that the other contracts can+check whether the contract they are calling provides the interface they expect.+The `Upgrade` method accepts the old version number, the new version number and checks whether the old version matches the current version stored in the contract storage.++### Access control+To ensure security of the deployed contract, the access to the upgrade methods must be restricted.+Ideally, any form of access control policy should be supported, including but not limited to:+  * upgrades that require multiple signatures;+  * collective voting on upgrade proposals;+  * time-limited upgradeability;+  * etc.++Luckily, we can achieve such flexibility easily by making a contract administered by+another – access control – contract. The access control contract should mimic the+interface of the contract it controls, and proxy the upgrade requests if the preconditions+are met according to the specified access control policy. The controlled contract, in turn,+must ensure that the transaction `SENDER` equals to the current contract `administrator` prior+to upgrade. It should also provide a `SetAdministrator Address` endpoint in case the access control+policy (e.g. a set of eligible approvers) needs to be revised.++A person administering an upgradeable contract can be treated as a special case of an access+control policy contract – the one with unlimited rights for upgrades.++### More about entrypoint-wise upgrades+Tezos has an intrinsic `max_operation_size` limit which may be insufficient to originate a+complex contract. One can overcome this limitation by slightly modifying the proposed upgradeable contract.++The solution is to fill in the code of the contract endpoint by endpoint rather than doing+it in one transaction. For this purpose we have specific entrypoint-wise upgrade endpoints:+```+data Parameter ver+  ...+  | EpwBeginUpgrade ("current" :! Version, "new" :! Version)+  | EpwApplyMigration (MigrationScriptFrom (VerUStoreTemplate ver))+  | EpwSetCode SomeUContractRouter+  | EpwSetPermCode (SomePermanentImpl ver)+  | EpwFinishUpgrade+```++Entrypoint-wise upgrade endpoints have the following behavior:+  * `EpwBeginUpgrade` checks the provided current version and pauses all+  `Run` operations by setting a new `paused :: Bool` storage parameter to true.+  * `EpwApplyMigration` applies storage and code migrations; can be called multiple+  times if deemed necessary.+  * `EpwSetCode` optionally updates the source code of the contract; it contains mostly+  dispatching logic since all the entrypoints are updated using `EpwApplyMigration`.+  * `EpwSetPermCode` optionally updates code related to permanent contract+  entrypoints - ones that will be present in all versions of the contract.+  * `EpwFinishUpgrade` unpauses the contract.++### Type safe storage migrations+Instead of forcing our users to write migration scripts by hand, we provide a safe+interface for `UStoreTemplate` migrations. Type-safe migrations are provided by parametrizing+upgradeable datatypes and other primitives with desired contract versions lifted to type-level.+For particular examples you can look for upgradeable contracts [here](/src/Lorentz/Contracts/).++## Appendix A: Possible extensions to administrator-forced upgrades+This section describes optional extensions that are not strictly required but may be beneficial to+the contract authors and users. Some of these extensions are straightforward, while others may+require further research or be non-trivial to implement.++#### Lazy BigMap upgrades+Currently, it is not possible to change the data type of a nested quasi-`BigMap`, e.g. if you have a `BigMap Address Investor` in UStore, you cannot add a new field to `Investor` during migration. This limitation can be dropped if a nested `BigMap` stored version information in values, i.e.+`BigMap Address (Version, Investor)`. If the `Version` of the value is not equal to the current version, we apply all per-field migrations as described earlier. This would require us to store migration lambdas for each version, though.++#### Advanced versioning+Instead of storing a `Natural` version, an upgradeable contract can store `currentVersion :: ContractVersion`, where the elements of the `ContractVersion { major :: Natural, minor :: Natural, bugfix :: Natural)` denote the elements of the semantic version identifier. The contract also exposes the corresponding `View` endpoint. During the upgrade the contract checks that the version identifier is increasing, one step at a time, i.e.:+  * Δmajor = 1 & minor = 0 & bugfix = 0, or+  * Δmajor = 0 & Δminor = 1 & bugfix = 0, or+  * Δmajor = 0 & Δminor = 0 & Δbugfix = 1++For example, 1.1.1→1.1.2 and 1.0.58→1.1.0 are valid migrations, whereas 1.1.1→1.2.1 and 1.0.58→1.1.58 are not.++The following restrictions on the public interface may be imposed:+  * Bugfix change — no changes in the public interface are allowed;+  * Minor change — the public interface may contain new methods, the old method names and parameters must remain the same;+  * Major change — the public interface may change as desired.++While these restrictions may help to avoid incompatibility issues, unexpected breaking changes still can occur in the implementation of the exposed methods.++<!-- References -->+[eth-dao]: https://medium.com/swlh/the-story-of-the-dao-its-history-and-consequences-71e6a8a551ee "The Story of the DAO — Its History and Consequences"+[neo-migrate]: https://docs.neo.org/docs/en-us/sc/migrate.html "Migrating Smart Contracts"+[eos-precautions]: https://eosio.stackexchange.com/questions/559/how-eos-prevent-contract-upgrade-for-evil "How eos prevent contract upgrade for evil? – EOS StackExchange"+[eth-yp]: https://ethereum.github.io/yellowpaper/paper.pdf "Ethereum Yellow Paper"+[eth-call-delegatecall]: https://ethereum.stackexchange.com/questions/3667/difference-between-call-callcode-and-delegatecall?noredirect=1&lq=1 "Difference between CALL, CALLCODE and DELEGATECALL – Ethereum StackExchange"+[eth-proxy]: https://fravoll.github.io/solidity-patterns/proxy_delegate.html "Proxy Delegate – Solidity patterns"+[eth-eternal]: https://fravoll.github.io/solidity-patterns/eternal_storage.html "Eternal Storage – Solidity patterns"+[eth-lazy]: https://medium.com/bitclave/the-easy-way-to-upgrade-smart-contracts-ba30ba012784 "The Easy Way to Upgrade Smart Contracts"+[user-upgrade]: https://medium.com/@k06a/the-safest-and-probably-the-best-way-to-upgrade-smart-contracts-ea6e619d5dfd "Upgradability is a BACKDOOR!!111!"+[bancor-hack]: https://twitter.com/Bancor/status/1016420621666963457 "Bancor on Twitter: Here is the latest update on the recent security breach:… "
+ morley-upgradeable.cabal view
@@ -0,0 +1,158 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.34.3.+--+-- see: https://github.com/sol/hpack++name:           morley-upgradeable+version:        0.3+synopsis:       Upgradeability infrastructure based on Morley.+description:    Basic infrastructure for writing upgradeable contracts in Morley-based eDSL.+category:       Language+homepage:       https://gitlab.com/morley-framework/morley-upgradeable+bug-reports:    https://gitlab.com/morley-framework/morley-upgradeable/-/issues+author:         Serokell, Tocqueville Group+maintainer:     Serokell <hi@serokell.io>+copyright:      2019-2021 Tocqueville Group+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGES.md+    docs/upgradeableContracts.md++source-repository head+  type: git+  location: git@gitlab.com:morley-framework/morley-upgradeable.git++library+  exposed-modules:+      Hedgehog.Gen.Lorentz.UStore+      Lorentz.Contracts.Upgradeable.Client+      Lorentz.Contracts.Upgradeable.Common+      Lorentz.Contracts.Upgradeable.Common.Base+      Lorentz.Contracts.Upgradeable.Common.Contract+      Lorentz.Contracts.Upgradeable.Common.Doc+      Lorentz.Contracts.Upgradeable.Common.Interface+      Lorentz.Contracts.Upgradeable.EntrypointWise+      Lorentz.Contracts.Upgradeable.StorageDriven+      Lorentz.Contracts.Upgradeable.Test+      Lorentz.Contracts.UpgradeableCounter+      Lorentz.Contracts.UpgradeableCounter.V1+      Lorentz.Contracts.UpgradeableCounter.V2+      Lorentz.Contracts.UpgradeableCounterSdu+      Lorentz.Contracts.UpgradeableCounterSdu.V1+      Lorentz.Contracts.UpgradeableCounterSdu.V2+      Lorentz.Contracts.UpgradeableUnsafeLedger+      Lorentz.Contracts.UpgradeableUnsafeLedger.V1+      Lorentz.Contracts.UpgradeableUnsafeLedger.V2+      Lorentz.Contracts.UserUpgradeable.Migrations+      Lorentz.Contracts.UserUpgradeable.V1+      Lorentz.Contracts.UserUpgradeable.V2+      Lorentz.UStore+      Lorentz.UStore.Doc+      Lorentz.UStore.Haskell+      Lorentz.UStore.Instances+      Lorentz.UStore.Instr+      Lorentz.UStore.Lift+      Lorentz.UStore.Migration+      Lorentz.UStore.Migration.Base+      Lorentz.UStore.Migration.Batching+      Lorentz.UStore.Migration.Blocks+      Lorentz.UStore.Migration.Diff+      Lorentz.UStore.Traversal+      Lorentz.UStore.Types+  other-modules:+      Paths_morley_upgradeable+  hs-source-dirs:+      src+  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns NoApplicativeDo RebindableSyntax+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages -Wno-unused-do-bind+  build-depends:+      HUnit+    , base-noprelude >=4.7 && <5+    , cleveland+    , colourista+    , constraints+    , containers+    , first-class-families >=0.5.0.0+    , fmt+    , hedgehog+    , hex-text+    , lens+    , lorentz+    , morley+    , morley-client+    , morley-prelude+    , mtl+    , singletons+    , text+    , vinyl+  default-language: Haskell2010++executable morley-ustore-reader+  main-is: Main.hs+  other-modules:+      Paths_morley_upgradeable+  autogen-modules:+      Paths_morley_upgradeable+  hs-source-dirs:+      app+  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages+  build-depends:+      base-noprelude >=4.7 && <5+    , constraints+    , fmt+    , lorentz+    , morley+    , morley-client+    , morley-prelude+    , morley-upgradeable+    , optparse-applicative+    , with-utf8+  default-language: Haskell2010++test-suite morley-upgradeable-test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Test.Doc.Positions+      Test.Lorentz.Contracts.UpgradeableCounter+      Test.Lorentz.Contracts.UpgradeableCounterSdu+      Test.Lorentz.Contracts.UserUpgradeable+      Test.Lorentz.UStore.Behaviour+      Test.Lorentz.UStore.Migration.Batched+      Test.Lorentz.UStore.Migration.Batched.V1+      Test.Lorentz.UStore.Migration.Batched.V2+      Test.Lorentz.UStore.Migration.FillInParts+      Test.Lorentz.UStore.Migration.Simple+      Test.Lorentz.UStore.Migration.Simple.V1+      Test.Lorentz.UStore.Migration.Simple.V2+      Test.Lorentz.UStore.SafeLift+      Test.Lorentz.UStore.SafeLift.Helpers+      Test.Lorentz.UStore.StoreClass+      Tree+      Paths_morley_upgradeable+  hs-source-dirs:+      test+  default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingStrategies DerivingVia EmptyCase FlexibleContexts FlexibleInstances GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NegativeLiterals NumDecimals OverloadedLabels OverloadedStrings PatternSynonyms PolyKinds QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving StrictData TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances UndecidableSuperClasses ViewPatterns+  ghc-options: -Weverything -Wno-missing-exported-signatures -Wno-missing-import-lists -Wno-missed-specialisations -Wno-all-missed-specialisations -Wno-unsafe -Wno-safe -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-implicit-prelude -Wno-prepositive-qualified-module -Wno-missing-safe-haskell-mode -Wno-unused-packages -threaded -eventlog -rtsopts "-with-rtsopts=-N -A64m -AL256m"+  build-tool-depends:+      tasty-discover:tasty-discover+  build-depends:+      HUnit+    , base-noprelude >=4.7 && <5+    , cleveland+    , containers+    , hedgehog+    , hspec+    , lorentz+    , morley+    , morley-prelude+    , morley-upgradeable+    , tasty+    , tasty-hspec+    , tasty-hunit-compat+  default-language: Haskell2010
+ src/Hedgehog/Gen/Lorentz/UStore.hs view
@@ -0,0 +1,24 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Hedgehog.Gen.Lorentz.UStore+  ( genUStoreSubMap+  , genUStoreFieldExt+  ) where++import Prelude++import Hedgehog (MonadGen)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Lorentz.UStore.Types (UStoreFieldExt(..), type (|~>) (..))++import Cleveland.Util (genTuple2)++genUStoreSubMap :: (MonadGen m, Ord k) => m k -> m v -> m (k |~> v)+genUStoreSubMap genK genV = UStoreSubMap <$> Gen.map (Range.linear 0 100) (genTuple2 genK genV)++genUStoreFieldExt :: MonadGen m => m v -> m (UStoreFieldExt marker v)+genUStoreFieldExt genV = UStoreField <$> genV
+ src/Lorentz/Contracts/Upgradeable/Client.hs view
@@ -0,0 +1,89 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Operations related to upgradeable contracts.+module Lorentz.Contracts.Upgradeable.Client+  ( UStoreValueUnpackFailed (..)+  , UStoreElemRef (..)+  , readContractUStore+  , readContractUStoreEntrypoint+  ) where++import Prelude++import Data.Singletons (demote)+import Fmt (Buildable(..), pretty)+import Text.Hex (encodeHex)+import qualified Text.Show++import Lorentz.Contracts.Upgradeable.StorageDriven (UMarkerEntrypoint)+import Lorentz.UStore.Types (UMarkerPlainField, UStoreSubmapKeyT, mkFieldMarkerUKey)+import Lorentz.Value+import Michelson.Interpret.Pack+import Michelson.Interpret.Unpack+import Michelson.Typed+import Michelson.Untyped (ExpandedOp(..))++import Morley.Client++-- | Failed to code UStore value to given type.+data UStoreValueUnpackFailed = UStoreValueUnpackFailed ByteString Text+instance Exception UStoreValueUnpackFailed+instance Show UStoreValueUnpackFailed where+  show = pretty+instance Buildable UStoreValueUnpackFailed where+  build (UStoreValueUnpackFailed val ty) =+    "Unexpected UStore value of type `" <> build ty <> "`: \+    \0x" <> build (encodeHex val)+++-- | Version of 'PackedValScope' which can be partially applied.+class (Typeable a, PackedValScope a) => PackedValScope' a+instance (Typeable a, PackedValScope a) => PackedValScope' a++data UStoreElemRef+  = UrField MText+  | UrSubmap MText (SomeConstrainedValue PackedValScope')++-- | Read 'UStore' value of given contract.+--+-- This essentially requires contract having only one @big_map bytes bytes@+-- in storage.+readContractUStore+  :: forall v m.+     (UnpackedValScope v, HasTezosRpc m)+  => Address -> UStoreElemRef -> m (Value v)+readContractUStore contract ref = do+  let ukey = toVal @ByteString (refToKey ref)+  uval <- readContractBigMapValue contract ukey+  unpackValue' (fromVal @ByteString uval)+    & either (const (throwUnpackFailed uval)) pure+  where+    throwUnpackFailed uval =+      throwM $ UStoreValueUnpackFailed (fromVal uval) (pretty $ demote @v)++    refToKey :: UStoreElemRef -> ByteString+    refToKey = \case+      UrField field ->+        mkFieldMarkerUKey @UMarkerPlainField field+      UrSubmap field (SomeConstrainedValue key) ->+        packValue' @(UStoreSubmapKeyT _) $ VPair (toVal field, key)++-- | Read an 'UStore' entrypoint. For contracts which are filled with+-- storage-driven approach.+--+-- Unlike 'readContractUStore', here we don't need to know exact type of+-- value (lambda) in order to unpack it, thus returning code in untyped+-- representation.+readContractUStoreEntrypoint+  :: HasTezosRpc m+  => Address -> MText -> m [ExpandedOp]+readContractUStoreEntrypoint contract field = do+  let ukey = toVal @ByteString (mkFieldMarkerUKey @UMarkerEntrypoint field)+  uval <- readContractBigMapValue contract ukey+  unpackInstr' (fromVal @ByteString uval)+    & either (const (throwUnpackFailed uval)) pure+  where+    throwUnpackFailed uval =+      throwM $ UStoreValueUnpackFailed (fromVal uval) "code"
+ src/Lorentz/Contracts/Upgradeable/Common.hs view
@@ -0,0 +1,12 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Lorentz.Contracts.Upgradeable.Common+  ( module Exports+  ) where++import Lorentz.Contracts.Upgradeable.Common.Base as Exports+import Lorentz.Contracts.Upgradeable.Common.Contract as Exports+import Lorentz.Contracts.Upgradeable.Common.Interface as Exports+import Lorentz.Contracts.Upgradeable.Common.Doc as Exports
+ src/Lorentz/Contracts/Upgradeable/Common/Base.hs view
@@ -0,0 +1,262 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- TODO: Replace 'Empty' with 'Never' from morley+{-# OPTIONS_GHC -Wno-deprecations #-}++module Lorentz.Contracts.Upgradeable.Common.Base+  ( Version (..)+  , VersionKind+  , KnownContractVersion (..)+  , VerParam+  , VerUStore+  , EmptyContractVersion+  , SomeContractVersion+  , UStore_+  , MigrationScript (..)+  , MigrationScriptFrom+  , MigrationScriptTo+  , UContractRouter (..)+  , SomeUContractRouter+  , UpgradeableEntrypointsKind+  , PermanentImpl (..)+  , SomePermanentImpl+  , PermanentEntrypointsKind+  , mkUContractRouter+  , coerceUContractRouter+  , emptyPermanentImpl+  , mkSmallPermanentImpl++    -- * Re-exports+  , Nat+  , Empty+  , absurd_+  ) where++import Prelude (KnownNat, Num, Typeable, natVal)++import qualified Data.Kind as Kind+import Fmt (Buildable(..))+import GHC.TypeNats (Nat)+import Util.TypeTuple++import Lorentz+import Lorentz.Contracts.Upgradeable.Common.Doc (UpgradeableEntrypointsKind)+import Lorentz.UStore+import Lorentz.UStore.Migration+import Michelson.Typed.Arith++-- Versioning+----------------------------------------------------------------------------++-- | Version of a contract.+--+-- Our current versioning suggests that this type is a term-level reflection+-- of types which have 'KnownContractVersion' instance, so this version item+-- should uniquely identify storage structure and entrypoints set for a given+-- contract for all of its instances.+--+-- The old semantics of this type was that it counts number of given contract+-- instance upgrades, so different contract instances, being upgraded to the+-- recent version, could have different 'Version's. For old contracts we have+-- to follow this behaviour.+newtype Version = Version { unVersion :: Natural }+  deriving stock (Show, Eq, Ord, Generic)+  deriving newtype (Num, IsoValue)+  deriving anyclass HasAnnotation++instance ArithOpHs Add Natural Version where+  type ArithResHs Add Natural Version = Version++instance Buildable Version where+  build (Version v) = "v" <> build v++instance TypeHasDoc Version where+  typeDocMdDescription = "Contract version."++instance ParameterHasEntrypoints Version where+  type ParameterEntrypointsDerivation Version = EpdNone++-- | Kind of type-level contract version.+type VersionKind =+  -- Defining it like this as it is the simplest way to have a custom open kind+  ContractVersionTag -> Kind.Type+data ContractVersionTag++-- | Declare given type as contract version identifier.+--+-- Instances of this typeclass (versions) uniquely identify contract storage+-- scheme and code. Normally the opposite should also hold, i.e.+-- @contract version <-> (contract storage scheme, code)@ relation is a bijection.+--+-- If as part of migration you need to update contract storage without modifying+-- its structure, then contract version should not change, and you should+-- perform an upgrade to the same version as the current one.+--+-- We allow upgrades between arbitrary two versions, so one can not only upgrade+-- to the next adjacent version, but also upgrade a new contract from V0 to the+-- recent version immediately, or leave version the same (as a versatile way+-- to change storage).+class KnownContractVersion (v :: VersionKind) where+  -- | List of entrypoints of given contract version.+  type VerInterface v :: [EntrypointKind]+  -- | Storage template of given contract version.+  type VerUStoreTemplate v :: Kind.Type++  -- | Set of permanent entrypoints (as a sum type).+  --+  -- We tie this type to contract version for convenience, in order not to carry+  -- one more type argument everywhere.+  -- We do not ensure right here that all versions of a contract have the same+  -- permanent entrypoints, but if this does not hold, then (ideally) it will+  -- not be possible to construct migration between such contract versions.+  type VerPermanent v :: Kind.Type+  type VerPermanent _ = Empty++  -- | Get term-level contract version.+  -- Returned value will be stored within the contract designating the current+  -- contract version.+  contractVersion :: Proxy v -> Version+  default contractVersion :: (v ~ cid ver, KnownNat ver) => Proxy v -> Version+  contractVersion (_ :: Proxy (cid ver)) = Version $ natVal (Proxy @ver)++type VerParam v = UParam (VerInterface v)+type VerUStore v = UStore (VerUStoreTemplate v)++-- | Contract with empty interface and storage.+data EmptyContractVersion (perm :: Kind.Type) :: VersionKind+instance KnownContractVersion (EmptyContractVersion perm) where+  type VerInterface (EmptyContractVersion perm) = '[]+  type VerUStoreTemplate (EmptyContractVersion perm) = ()+  type VerPermanent (EmptyContractVersion perm) = perm+  contractVersion _ = 0++-- | Version which forgets about particular interface/storage.+data SomeContractVersion (perm :: Kind.Type) :: VersionKind+instance KnownContractVersion (SomeContractVersion perm) where+  type VerInterface (SomeContractVersion perm) = SomeInterface+  type VerUStoreTemplate (SomeContractVersion perm) = SomeUTemplate+  type VerPermanent (SomeContractVersion perm) = perm+  contractVersion _ = error "Requested version of SomeContractVersion"++-- UParam dispatching+----------------------------------------------------------------------------++-- | Keeps parameter dispatching logic.+newtype UContractRouter (ver :: VersionKind) =+  UContractRouter+    { unUContractRouter+       :: Lambda (VerParam ver, VerUStore ver)+                 ([Operation], VerUStore ver)+    }+  deriving stock (Generic, Show)+  deriving anyclass (IsoValue, HasAnnotation, Wrappable)+  deriving newtype (MapLorentzInstr)++instance ( Typeable ver+         , Typeable (VerInterface ver), Typeable (VerUStoreTemplate ver)+         , TypeHasDoc (VerUStore ver)+         ) =>+         TypeHasDoc (UContractRouter ver) where+  typeDocMdDescription =+    "Parameter dispatching logic, main purpose of this code is to pass control \+    \to an entrypoint carrying the main logic of the contract."+  typeDocMdReference tp = customTypeDocMdReference ("UContractRouter", DType tp) []+  typeDocHaskellRep = homomorphicTypeDocHaskellRep+  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep++type SomeUContractRouter = UContractRouter (SomeContractVersion ())++mkUContractRouter+  :: ([VerParam ver, VerUStore ver] :-> '[([Operation], VerUStore ver)])+  -> UContractRouter ver+mkUContractRouter code = UContractRouter $ do+  unpair+  code++instance ( VerParam ver1 `CanCastTo` VerParam ver2+         , VerUStore ver1 `CanCastTo` VerUStore ver2+         ) =>+         UContractRouter ver1 `CanCastTo` UContractRouter ver2 where+  castDummy = castDummyG++coerceUContractRouter+  :: ( Coercible_ (VerParam s1) (VerParam s2)+     , Coercible_ (VerUStore s1) (VerUStore s2)+     )+  => UContractRouter s1 -> UContractRouter s2+coerceUContractRouter (UContractRouter code) =+  UContractRouter $ checkedCoerce_ # code # checkedCoerce_++-- Permanent entrypoints parameter dispatching+----------------------------------------------------------------------------++-- | Implementation of permanent entrypoints.+--+-- This will be injected into contract storage as one of fields, so make sure+-- that code within does not exceed several instructions; an actual entrypoint+-- logic can be put into 'UStore' and called from within @PermanentImpl@ only+-- when necessary.+--+-- Regarding documentation - this have to provide code pieces wrapped into+-- 'DEntrypoint' with 'PermanentEntrypointsKind', so always use 'entryCase' as+-- implementation of this type /or/ inject documentation of code which does so+-- unless you know what you are doing.+newtype PermanentImpl ver = PermanentImpl+  { unPermanentImpl :: Entrypoint (VerPermanent ver) (VerUStore ver)+  }+  deriving stock (Generic, Show)+  deriving newtype (MapLorentzInstr)+  deriving anyclass (Wrappable)++deriving anyclass instance (WellTypedIsoValue (VerPermanent ver)) => IsoValue (PermanentImpl ver)++instance HasAnnotation (VerPermanent ver) => HasAnnotation (PermanentImpl ver)++instance ( Typeable ver, Typeable (VerUStoreTemplate ver)+         , TypeHasDoc (VerUStore ver)+         , TypeHasDoc (VerPermanent ver), KnownValue (VerPermanent ver)+         ) =>+         TypeHasDoc (PermanentImpl ver) where+  typeDocMdDescription =+    "Implementation of permanent entrypoints."+  typeDocMdReference tp = customTypeDocMdReference ("PermanentImpl", DType tp) []+  typeDocHaskellRep = homomorphicTypeDocHaskellRep+  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep++type SomePermanentImpl perm = PermanentImpl (SomeContractVersion perm)++instance ( VerPermanent ver1 `CanCastTo` VerPermanent ver2+         , VerUStore ver1 `CanCastTo` VerUStore ver2+         ) =>+         PermanentImpl ver1 `CanCastTo` PermanentImpl ver2 where+  castDummy = castDummyG++-- | Common implementation of permanent part in case contract has no such.+emptyPermanentImpl :: (VerPermanent ver ~ Empty) => PermanentImpl ver+emptyPermanentImpl = PermanentImpl $+  docGroup (DEntrypoint @PermanentEntrypointsKind "<No entrypoints>")+    absurd_++-- | Construct implementation of permanent part in a common case;+-- this works similarly to 'entryCase'.+--+-- Use this function only for very small implementations.+mkSmallPermanentImpl+  :: forall ver dt out inp clauses.+     ( CaseTC dt out inp clauses+     , DocumentEntrypoints PermanentEntrypointsKind dt+     , dt ~ VerPermanent ver, inp ~ '[VerUStore ver]+     , out ~ ContractOut (VerUStore ver)+     )+  => IsoRecTuple clauses -> PermanentImpl ver+mkSmallPermanentImpl = PermanentImpl . entryCase (Proxy @PermanentEntrypointsKind)++-- | Common marker for permanent entrypoints.+-- Can be used when parameter for permanent entrypoints is flat, i.e. does not+-- have nested subparameters with multiple entrypoints.+data PermanentEntrypointsKind+instance EntrypointKindHasDoc PermanentEntrypointsKind where+  entrypointKindPos = 1050+  entrypointKindSectionName = "Permanent entrypoints"
+ src/Lorentz/Contracts/Upgradeable/Common/Contract.hs view
@@ -0,0 +1,473 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# LANGUAGE FunctionalDependencies #-}+{-# OPTIONS_GHC -Wno-orphans #-}++{- | Template for upgradeable contract.++It provides the following features:+1. Contract with upgradeable storage format and entrypoints set.+2. Two way to upgrade the contract - one shot and entrypoint-wise.++-}+module Lorentz.Contracts.Upgradeable.Common.Contract+  ( Parameter(..)+  , UTAddress+  , UContractRef+  , PermConstraint+  , Storage+  , UpgradeableContract+  , PermanentImpl+  , InitUpgradeableContract+  , OneShotUpgradeParameters+  , DVersion (..)+  , NiceVersion+  , upgradeableContract+  , mkEmptyStorage+  , pbsContainedInRun+  , pbsContainedInRunPerm+  ) where++import Lorentz+import Prelude (Typeable)++import qualified Data.Text as T+import Fmt (Buildable(..), fmt)++import qualified Michelson.Typed as T+import Util.Instances ()+import Util.Markdown++import Lorentz.Contracts.Upgradeable.Common.Base+import Lorentz.Contracts.Upgradeable.Common.Doc+import Lorentz.UStore++{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}++-- Types+----------------------------------------------------------------------------++-- | Parameter of upgradeable contract. It contains, among others:+--+-- 1. Entrypoint for running one of upgradeable entrypoints.+-- 2. Entrypoint for running one of permanent entrypoints, suitable e.g. for+--    implementing interfaces.+-- 3a. Entrypoint for upgrade in a single call.+-- 3b. Entrypoints for entrypoint-wise upgrade.+data Parameter (ver :: VersionKind)+  = Run (VerParam ver)+  | RunPerm (VerPermanent ver)+  | Upgrade (OneShotUpgradeParameters ver)+  | GetVersion (View () Version)+  | SetAdministrator Address++  -- Entrypoint-wise upgrades are currently not protected from version mismatch+  -- in subsequent transactions, so the user ought to be careful with them.+  -- This behavior may change in future if deemed desirable.+  | EpwBeginUpgrade ("current" :! Version, "new" :! Version)+  | EpwApplyMigration (MigrationScriptFrom (VerUStoreTemplate ver))+  | EpwSetCode SomeUContractRouter+  | EpwSetPermCode (SomePermanentImpl (VerPermanent ver))+  | EpwFinishUpgrade+  deriving stock (Generic)++deriving stock instance+  (Show (VerParam ver), Show (VerPermanent ver)) => Show (Parameter ver)++instance IsoValue (VerPermanent ver) => IsoValue (Parameter ver)++instance ( interface ~ VerInterface ver+         , UnpackUParam Buildable interface+         , Buildable (VerPermanent ver)+         ) =>+         Buildable (Parameter ver) where+  build = \case+    Run uParam ->+      case unpackUParam @Buildable @interface uParam of+        Left err -> "Run with inconsistent UParam: " <> build err+        Right (name, something) ->+          "Run " <> build name <> " with argument: " <> build something+    RunPerm permParam ->+      "Run permanent entrypoint: " <> build permParam+    Upgrade ( arg #currentVersion -> curVersion+            , arg #newVersion -> newVersion, _, _, _) ->+      "Upgrade " <> build curVersion <> " -> " <> build newVersion+    GetVersion v ->+      "GetVersion (callback to " <> build (viewCallbackTo v) <> ")"+    SetAdministrator addr ->+      "SetAdministrator " <> build addr+    EpwBeginUpgrade (arg #current -> curVersion, arg #new -> newVersion) ->+      "Begin EPW upgrade " <> build curVersion <> " -> " <> build newVersion+    EpwApplyMigration _ ->+      "Apply migration during EPW upgrade"+    EpwSetCode _ ->+      "Set code during EPW upgrade"+    EpwSetPermCode _ ->+      "Set permanent code during EPW upgrade"+    EpwFinishUpgrade ->+      "Finish EPW upgrade"++-- | Constraint on abstract set of permanent entrypoints.+type PermConstraint ver =+  -- If we want to perform calls to top-level entrypoints+  -- (including calls where we pass the whole parameter), then+  -- the following constraints are necessary+  ( NiceParameterFull (VerPermanent ver)+  , NoExplicitDefaultEntrypoint (VerPermanent ver)+  , HasAnnotation (VerPermanent ver)+  , RequireAllUniqueEntrypoints (Parameter ver)+  , Typeable ver+  , Typeable (VerInterface ver)+  , Typeable (VerUStoreTemplate ver)+  )++instance (PermConstraint ver) =>+         ParameterHasEntrypoints (Parameter ver) where+  type ParameterEntrypointsDerivation (Parameter ver) = EpdDelegate++type NiceVersion ver =+  ( Typeable (VerInterface ver), Typeable (VerUStoreTemplate ver)+  , UStoreTemplateHasDoc (VerUStoreTemplate ver)+  , TypeHasDoc (VerPermanent ver), KnownValue (VerPermanent ver)+  , HasAnnotation (VerPermanent ver), Typeable ver, WellTypedIsoValue (VerPermanent ver)+  )++instance NiceVersion ver => TypeHasDoc (Parameter ver) where+  typeDocName _ = "Global.Parameter"+  typeDocMdDescription =+    "Top-level parameter of upgradeable contract.\n\+    \Use `Run` and `RunPerm` entrypoints in order to access contract logic, \+    \other top-level entrypoints are intended solely for migrations purposes."+  typeDocMdReference tp =+    customTypeDocMdReference ("Global.Parameter", DType tp) []+  typeDocHaskellRep = homomorphicTypeDocHaskellRep+  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep++-- | Parameters of one-shot upgrade.+--+-- Do not construct this value manually, consider using 'makeOneShotUpgradeParameters'.+type OneShotUpgradeParameters ver =+  ( "currentVersion" :! Version+  , "newVersion" :! Version+  , "migrationScript" :! MigrationScriptFrom (VerUStoreTemplate ver)+  , "newCode" :! Maybe SomeUContractRouter+  , "newPermCode" :! Maybe (SomePermanentImpl (VerPermanent ver))+  )++type UTAddress ver = TAddress (Parameter ver)+type UContractRef ver = ContractRef (Parameter ver)++data StorageFields (ver :: VersionKind) = StorageFields+  { code :: UContractRouter ver+  , permCode :: PermanentImpl ver+  , admin :: Address+  , currentVersion :: Version+  , paused :: Bool+  } deriving stock Generic++deriving anyclass instance (WellTypedIsoValue (VerPermanent ver)) => IsoValue (StorageFields ver)+deriving anyclass instance (HasAnnotation (VerPermanent ver)) => HasAnnotation (StorageFields ver)++data Storage (ver :: VersionKind) = Storage+  { dataMap :: VerUStore ver+  , fields :: StorageFields ver+  } deriving stock Generic++deriving anyclass instance (WellTypedIsoValue (VerPermanent ver)) => IsoValue (Storage ver)+deriving anyclass instance (HasAnnotation (VerPermanent ver)) => HasAnnotation (Storage ver)++instance NiceVersion ver => TypeHasDoc (StorageFields ver) where+  typeDocName _ = "StorageFields"+  typeDocMdDescription =+    "StorageFields of upgradeable contract.\n\+    \This type keeps general information about upgradeable \+    \contract and the logic responsible for calling entrypoints \+    \implementations kept in UStore."+  typeDocMdReference tp =+    customTypeDocMdReference ("StorageFields", DType tp) []+  typeDocHaskellRep = homomorphicTypeDocHaskellRep+  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep++instance NiceVersion ver => TypeHasDoc (Storage ver) where+  typeDocName _ = "Storage"+  typeDocMdDescription =+    "Type which defines storage of the upgradeable contract.\n\+    \It contains UStore with data related to actual contract logic \+    \and fields which relate to upgradeability logic."+  typeDocMdReference tp =+    customTypeDocMdReference ("Storage", DType tp) []+  typeDocHaskellRep = homomorphicTypeDocHaskellRep+  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep++-- Errors+----------------------------------------------------------------------------++-- | The reuested operation requires the contract to be running but+--   it is paused.+type instance ErrorArg "upgContractIsPaused" = ()++-- | The reuested operation requires the contract to be paused but+--   it is not.+type instance ErrorArg "upgContractIsNotPaused" = ()++-- | The provided expected current version differs from actual one.+type instance ErrorArg "upgVersionMismatch" =+  ("expectedCurrent" :! Version, "actualCurrent" :! Version)+++instance Buildable (CustomError "upgContractIsPaused") where+  build (CustomError _ (_, ())) =+    "The requested operation requires the contract to be running but \+    \it is paused"++instance Buildable (CustomError "upgContractIsNotPaused") where+  build (CustomError _ (_, ())) =+    "The requested operation requires the contract to be paused but \+    \it is not."++instance Buildable (CustomError "upgVersionMismatch") where+  build (CustomError _ (_, ( arg #expectedCurrent -> expected+                           , arg #actualCurrent -> actual))) =+    "The provided expected current version " <> build expected <> " \+    \differs from actual one " <> build actual <> "."+++instance CustomErrorHasDoc "upgContractIsPaused" where+  customErrClass = ErrClassActionException+  customErrDocMdCause =+    "The contract is in paused state (for migrations)."++instance CustomErrorHasDoc "upgContractIsNotPaused" where+  customErrClass = ErrClassActionException+  customErrDocMdCause =+    "The contract is not in paused state (for migrations)."++instance CustomErrorHasDoc "upgVersionMismatch" where+  customErrClass = ErrClassActionException+  customErrDocMdCause =+    "Current contract version differs from the one passed in the upgrade."++-- Doc+----------------------------------------------------------------------------++-- | Specify version if given contract.+data DVersion = DVersion Version++instance DocItem DVersion where+  docItemPos = 103+  docItemSectionName = Nothing+  docItemToMarkdown _ (DVersion (Version ver)) =+    mdSubsection "Version" (build ver)+++-- | Mentions that parameter should be wrapped into 'Run' entry point.+pbsContainedInRun, pbsContainedInRunPerm :: ParamBuildingStep+(pbsContainedInRun, pbsContainedInRunPerm) =+  ( let uparam = UParamUnsafe ([mt|s|], "a")+        mich = mkMich uparam (Run @(EmptyContractVersion ()) uparam)+    in mkPbsWrapIn "Run" mich+  , let a = 999 :: Integer+        mich = mkMich a (RunPerm @(EmptyContractVersion Integer) a)+    in mkPbsWrapIn "RunPerm" mich+  )+  where+    mkMich woCtor wCtor = ParamBuilder $ \p ->+      build $+      T.replace+        (fmt . build . T.untypeValue $ toVal woCtor)+        ("(" <> fmt p <> ")")+        (fmt . build . T.untypeValue $ toVal wCtor)+        --- ^ Kinda hacky way to show how 'Run' is represented in Michelson.+        --- It should be safe though (no extra parts of text should be replaced)+        --- because we expect wCtor to be of form+        --- @{Left|Right}+ (woCtor)@+++-- Initialization+----------------------------------------------------------------------------++-- Allowing custom V0 versions in functions below, not only+-- 'EmptyContractVersion' - in case if user wishes to declare his own zero+-- version identifier.++emptyCode :: (VerInterface ver ~ '[]) => UContractRouter ver+emptyCode = mkUContractRouter (drop # nil # pair)++notInitPermCode :: PermanentImpl ver+notInitPermCode = PermanentImpl $+  -- In V0 there most probably won't be a sane way to initialize permanent+  -- entrypoints implementation because storage is yet empty and its future+  -- structure depends on particular target version.+  -- Failing with text here because in practice no one should ever notice such+  -- error.+  failUsing [mt|Permanent entrypoints implementation is not yet initialized|]++mkEmptyStorage+  :: (VerInterface ver ~ '[], VerUStoreTemplate ver ~ ())+  => Address -> Storage ver+mkEmptyStorage admin = Storage+  { dataMap = mkUStore ()+  , fields = StorageFields+    { code = emptyCode+    , permCode = notInitPermCode+    , admin = admin+    , currentVersion = 0+    , paused = False+    }+  }++-- Aliases+----------------------------------------------------------------------------++type UpgradeableContract ver = Contract (Parameter ver) (Storage ver)++type InitUpgradeableContract perm = UpgradeableContract (EmptyContractVersion perm)++-- Code+----------------------------------------------------------------------------++upgradeableContract+  :: forall ver. (NiceVersion ver, NiceParameterFull (Parameter ver))+  => UpgradeableContract ver+upgradeableContract = defaultContract $ do+  doc $ DUpgradeability contractDoc+  doc $ T.DStorageType $ DType $ Proxy @(Storage ver)+  unpair+  entryCase @(Parameter ver) (Proxy @UpgradeableEntrypointsKind)+    ( #cRun /-> do+        doc $ DDescription runDoc+        dip $ do+          ensureNotPaused+          getField #dataMap+          dip $ do+            getField #fields+            toField #code; coerceUnwrap+        pair+        exec+        unpair+        dip $ setField #dataMap+        pair+    , #cRunPerm /-> do+        doc $ DDescription runPermDoc+        dip $ do+          ensureNotPaused+          getField #dataMap+        duupX @3; toField #fields; toField #permCode; coerceUnwrap+        execute+        unpair+        dip $ setField #dataMap+        pair+    , #cUpgrade /-> do+        doc $ DDescription upgradeDoc+        dip (ensureAdmin # ensureNotPaused)+        dup; dip (toField #currentVersion >> toNamed #current >> (checkVersion @ver))+        dup; dip (toField #newVersion >> toNamed #new >> updateVersion)+        getField #migrationScript; swap; dip applyMigration+        getField #newCode; swap; dip $ whenSome migrateCode+        toField #newPermCode; whenSome migratePermCode+        nil; pair+    , #cGetVersion /-> view_ $ do+        doc $ DDescription getVersionDoc+        drop @(); toField #fields; toField #currentVersion+    , #cSetAdministrator /-> do+        doc $ DDescription setAdministratorDoc+        dip (ensureAdmin # getField #fields)+        setField #admin+        setField #fields+        nil; pair+    , #cEpwBeginUpgrade /-> do+        doc $ DDescription epwBeginUpgradeDoc+        dip (ensureAdmin # ensureNotPaused)+        dup; dip (toFieldNamed #current >> (checkVersion @ver))+        toFieldNamed #new >> updateVersion+        setPaused True+        nil; pair+    , #cEpwApplyMigration /-> do+        doc $ DDescription epwApplyMigrationDoc+        dip (ensureAdmin # ensurePaused)+        applyMigration+        nil; pair+    , #cEpwSetCode /-> do+        doc $ DDescription epwSetCodeDoc+        dip (ensureAdmin # ensurePaused)+        migrateCode+        nil; pair+    , #cEpwSetPermCode /-> do+        doc $ DDescription epwSetPermCodeDoc+        dip (ensureAdmin # ensurePaused)+        migratePermCode+        nil; pair+    , #cEpwFinishUpgrade /-> do+        doc $ DDescription epwFinishUpgradeDoc+        ensureAdmin+        ensurePaused+        setPaused False+        nil; pair+    )++ensureAdmin :: (WellTypedIsoValue (VerPermanent ver)) => '[Storage ver] :-> '[Storage ver]+ensureAdmin = do+  getField #fields; toField #admin+  sender; eq+  if_ (nop) (failCustom_ #senderIsNotAdmin)++setPaused :: (WellTypedIsoValue (VerPermanent ver)) => Bool -> '[Storage ver] :-> '[Storage ver]+setPaused newState = do+  getField #fields+  push newState+  setField #paused+  setField #fields++ensurePaused :: (WellTypedIsoValue (VerPermanent ver)) => '[Storage ver] :-> '[Storage ver]+ensurePaused = do+  getField #fields; toField #paused+  if_ (nop) (failCustom_ #upgContractIsNotPaused)++ensureNotPaused :: (WellTypedIsoValue (VerPermanent ver)) => '[Storage ver] :-> '[Storage ver]+ensureNotPaused = do+  getField #fields; toField #paused+  if_ (failCustom_ #upgContractIsPaused) (nop)++checkVersion :: forall ver. (WellTypedIsoValue (VerPermanent ver)) => '["current" :! Version, Storage ver] :-> '[Storage ver]+checkVersion = do+  fromNamed #current; toNamed #expectedCurrent+  dip (getField #fields >> toField #currentVersion >> toNamed #actualCurrent)+  if keepIfArgs (#expectedCurrent ==. #actualCurrent)+  then nop+  else do pair; failCustom #upgVersionMismatch++updateVersion :: forall ver.(WellTypedIsoValue (VerPermanent ver)) =>  '["new" :! Version, Storage ver] :-> '[Storage ver]+updateVersion = do+  fromNamed #new+  dip $ getField #fields+  setField #currentVersion; setField #fields++applyMigration+  :: (WellTypedIsoValue (VerPermanent ver)) =>  '[MigrationScriptFrom (VerUStoreTemplate ver), Storage ver] :-> '[Storage ver]+applyMigration = do+  coerceUnwrap+  dip $ getField #dataMap+  checkedCoerce_+  swap+  exec+  setField #dataMap++migrateCode+  :: (WellTypedIsoValue (VerPermanent ver)) =>  '[SomeUContractRouter, Storage ver]+  :-> '[Storage ver]+migrateCode = do+  dip (getField #fields)+  checkedCoerce_+  setField #code+  setField #fields++migratePermCode+  :: (WellTypedIsoValue (VerPermanent ver)) =>  '[SomePermanentImpl (VerPermanent ver), Storage ver]+  :-> '[Storage ver]+migratePermCode = do+  dip (getField #fields)+  checkedCoerce_+  setField #permCode+  setField #fields
+ src/Lorentz/Contracts/Upgradeable/Common/Doc.hs view
@@ -0,0 +1,102 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Lorentz.Contracts.Upgradeable.Common.Doc+  ( DUpgradeability (..)+  , UpgradeableEntrypointsKind+  , contractDoc+  , runDoc+  , runPermDoc+  , upgradeDoc+  , getVersionDoc+  , setAdministratorDoc+  , epwBeginUpgradeDoc+  , epwApplyMigrationDoc+  , epwSetCodeDoc+  , epwSetPermCodeDoc+  , epwFinishUpgradeDoc+  ) where++import Lorentz++import Fmt (Buildable(build))++import Util.Markdown++data DUpgradeability = DUpgradeability Markdown++instance DocItem DUpgradeability where+  docItemPos = 112+  docItemSectionName = Just "Contract upgradeability"+  docItemToMarkdown _ (DUpgradeability txt) = build txt++-- | Common marker for upgradeable, or /virtual/, entrypoints.+-- Can be used when each upgradeable entrypoint is simple,+-- i.e. does not itself consist of multiple entrypoints.+data UpgradeableEntrypointsKind++instance EntrypointKindHasDoc UpgradeableEntrypointsKind where+  entrypointKindPos = 1050+  entrypointKindSectionName = "Top-level entrypoints of upgradeable contract"+  entrypointKindSectionDescription = Just+    "These entrypoints may change in new versions of the contract.\n\n\+    \Also they have a special calling routing, see the respective subsection \+    \in every entrypoint description."+++contractDoc :: Markdown+contractDoc = [md|+  This contract uses upgradeability approach described [here](https://gitlab.com/morley-framework/morley/-/blob/a30dddb633ee880761c3cbf1d4a69ee040ffad25/docs/upgradeableContracts.md#section-2-administrator-forced-upgrades).+  This mechanism provides adminstrator-forced address-preserving upgradeability+  approach. For more information check out the doc referenced earlier.+  |]++runDoc :: Markdown+runDoc =+  "This entrypoint extracts contract code kept in storage under the \+  \corresponding name and executes it on an argument supplied via `UParam`."++runPermDoc :: Markdown+runPermDoc =+  "Similar to `Run` entrypoint, but calls permanent entrypoints - ones \+  \that will be present in all versions of the contract."++upgradeDoc :: Markdown+upgradeDoc = [md|+  This entry point is used to update the contract to a new version.+  Consider using this entrypoint when your upgrade to the new version isn't very large,+  otherwise, transaction with this entrypoint call won't fit instruction size limit.+  If this is your case, consider using entrypoint-wise upgrade. This entrypoint+  basically exchange `code` field in the storage and upgrade `dataMap` using+  provided migration lambda.+  |]++getVersionDoc :: Markdown+getVersionDoc =+  "This entry point is used to get contract version."++setAdministratorDoc :: Markdown+setAdministratorDoc =+  "This entry point is used to set the administrator address."++epwBeginUpgradeDoc :: Markdown+epwBeginUpgradeDoc =+  "This entry point is used to start an entrypoint wise upgrade of the contract."++epwApplyMigrationDoc :: Markdown+epwApplyMigrationDoc =+  "This entry point is used to apply a storage migration script as part of an upgrade."++epwSetCodeDoc :: Markdown+epwSetCodeDoc =+  "This entry point is used to set the dispatching code that calls the packed entrypoints."++epwSetPermCodeDoc :: Markdown+epwSetPermCodeDoc =+  "Similar to `EpwSetCode`, but refers to permanent entrypoints - ones \+  \that will be present in all versions of the contract."++epwFinishUpgradeDoc :: Markdown+epwFinishUpgradeDoc =+  "This entry point is used to mark that an upgrade has been finsihed."
+ src/Lorentz/Contracts/Upgradeable/Common/Interface.hs view
@@ -0,0 +1,305 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- TODO: Replace 'Empty' with 'Never' from morley+{-# OPTIONS_GHC -Wno-deprecations #-}++-- | Type-safe interface for constructing contract upgrades.+--+-- Use this module as follows:+-- 1. Construct 'EpwUpgradeParameters';+-- 2. Use one of the respective functions to convert it to an actual upgrade,+--    one-shot or entrypoint-wise, for tests or production.+module Lorentz.Contracts.Upgradeable.Common.Interface+  ( EpwUpgradeParameters (..)+  , fvUpgrade+  , makeOneShotUpgradeParameters+  , makeOneShotUpgrade+  , makeEpwUpgrade+  , UpgradeWay (..)+  , SimpleUpgradeWay+  , integrationalTestUpgrade+  ) where++import Data.Constraint ((:-)(..), Constraint, Dict(..), (\\))+import Data.Foldable (toList)+import qualified Data.Kind as Kind+import Lorentz+import Prelude (Identity(..), Traversable, Void, absurd, mapM_, maybe, (<$), (<$>))++import Data.Coerce (coerce)+import Unsafe.Coerce (unsafeCoerce)++import Lorentz.Test+import Util.Instances ()+import Util.Named ((.!))+import Util.TypeLits++import Lorentz.Contracts.Upgradeable.Common.Base+import Lorentz.Contracts.Upgradeable.Common.Contract++----------------------------------------------------------------------------+-- Particular pieces updates+----------------------------------------------------------------------------++-- These datatypes are not part of the interface, they only keep+-- information about upgrade and respective invariants+data UContractRouterUpdate curVer newVer where+  -- | Do update.+  UcrUpdate :: UContractRouter newVer -> UContractRouterUpdate curVer newVer+  -- | Retain the same 'UContractRouter'.+  UcrRetain :: UContractRouterUpdate curVer newVer++data PermanentImplUpdate curVer newVer where+  -- | Do update.+  PiUpdate :: PermanentImpl newVer -> PermanentImplUpdate curVer newVer+  -- | Retain the same 'PermanentImpl'.+  PiRetain :: PermanentImplUpdate curVer newVer++-- Interface conveniences+----------------------------------------------------------------------------++-- | Helps to provide a pleasant interface, it would be inconvenient for+-- user to use 'UcrUpdate' and stuff.+class RecognizeUpgPiece expected given where+  recognizeUpgPiece :: given -> expected++instance (newVerE ~ newVerG) =>+         RecognizeUpgPiece+           (UContractRouterUpdate curVerE newVerE)+           (UContractRouter newVerG) where+  recognizeUpgPiece = UcrUpdate++instance ( RequireSameVersionStorageParts curVer newVer+             "upgradeable part implementation"+         , RequireSameVersionInterfaces curVer newVer+         , x ~ Void+         ) =>+         RecognizeUpgPiece (UContractRouterUpdate curVer newVer) (Maybe x) where+  recognizeUpgPiece = maybe UcrRetain absurd++instance (newVerE ~ newVerG) =>+         RecognizeUpgPiece+           (PermanentImplUpdate curVerE newVerE)+           (PermanentImpl newVerG) where+  recognizeUpgPiece = PiUpdate++instance ( RequireSameVersionStorageParts curVer newVer+           "permanent part implementation"+         , RequireSameVersionPermanents curVer newVer+         , x ~ Void+         ) =>+         RecognizeUpgPiece (PermanentImplUpdate curVer newVer) (Maybe x) where+  recognizeUpgPiece = maybe PiRetain absurd++-- Type errors+----------------------------------------------------------------------------++type family RequireSameStorageParts curStore newStore desc :: Constraint where+  RequireSameStorageParts store store _ = ()+  RequireSameStorageParts curStore newStore desc = TypeError+    ( 'Text "Leaving " ':<>: 'Text desc ':<>:+        'Text " unchanged is not safe when storage format changes" ':$$:+      'Text "Old storage is `" ':<>: 'ShowType curStore ':<>: 'Text "`" ':$$:+      'Text "while new one is `" ':<>: 'ShowType newStore ':<>: 'Text "`"+    )+    -- Updates which error tells about are not safe because old code may refer+    -- to a field which was removed in new version of storage.++type RequireSameVersionStorageParts curVer newVer desc =+  RequireSameStorageParts+    (VerUStoreTemplate curVer)+    (VerUStoreTemplate newVer)+    desc++type family RequireSameInterfaces curInterface newInterface :: Constraint where+  RequireSameInterfaces interface interface = ()+  RequireSameInterfaces curInterface newInterface = TypeError+    ( 'Text "Need to update interface" ':$$:+      'Text "Old interface is `" ':<>: 'ShowType curInterface ':<>: 'Text "`" ':$$:+      'Text "while new one is `" ':<>: 'ShowType newInterface ':<>: 'Text "`"+    )++type RequireSameVersionInterfaces curVer newVer =+  RequireSameInterfaces (VerInterface curVer) (VerInterface newVer)++type family RequireSamePermanents (curPerm :: Kind.Type) (newPerm :: Kind.Type)+              :: Kind.Constraint where+  RequireSamePermanents perm perm = ()+  RequireSamePermanents curPerm Empty =+    TypeError+      ( 'Text "Permanent part of contract version is set to default" ':$$:+        'Text "while in existing contract version it is `"+          ':<>: 'ShowType curPerm ':<>: 'Text "`" ':$$:+        'Text "Have you set it in KnownContractVersion instance?"+      )+  RequireSamePermanents curPerm newPerm =+    TypeError+      ( 'Text "Need to update permanent part implementation" ':$$:+        'Text "Parameter of previous version part is of type `"+          ':<>: 'ShowType curPerm ':<>: 'Text "`" ':$$:+        'Text "while in new one it is `" ':<>: 'ShowType newPerm ':<>: 'Text "`"+      )++type RequireSameVersionPermanents curVer newVer =+  RequireSamePermanents (VerPermanent curVer) (VerPermanent newVer)++----------------------------------------------------------------------------+-- Exposed interface+----------------------------------------------------------------------------++-- | Type-safe upgrade construction.+data EpwUpgradeParameters (t :: Kind.Type -> Kind.Type)+                          (curVer :: VersionKind)+                          (newVer :: VersionKind) =+  forall code codePerm.+  ( Traversable t+  , KnownContractVersion curVer, KnownContractVersion newVer+  , RequireSamePermanents (VerPermanent curVer) (VerPermanent newVer)+  , RecognizeUpgPiece (UContractRouterUpdate curVer newVer) code+  , RecognizeUpgPiece (PermanentImplUpdate curVer newVer) codePerm+  ) =>+  EpwUpgradeParameters+  { upMigrationScripts :: t (MigrationScript (VerUStoreTemplate curVer) (VerUStoreTemplate newVer))+    -- ^ Storage migration script.+    -- Supply this field with result of 'migrationToScriptI' or+    -- 'migrationToScripts' call.++  , upNewCode :: code+    -- ^ Updated parameter dispatching logic.+    -- Pass 'UContractRouter' or 'Nothing'.++  , upNewPermCode :: codePerm+    -- ^ Updates implementation of permanent part.+    -- Pass 'PermanentImpl' or 'Nothing'.+  }++permanentsAreSameEvi+  :: RequireSamePermanents (VerPermanent ver1) (VerPermanent ver2)+  :- (VerPermanent ver1 ~ VerPermanent ver2)+permanentsAreSameEvi = Sub $+  unsafeCoerce $ Dict @(Integer ~ Integer)++-- | New version getter.+upNewVersion+  :: forall t curVer newVer.+     EpwUpgradeParameters t curVer newVer -> Version+upNewVersion EpwUpgradeParameters{} =+  contractVersion (Proxy @newVer)++-- | The current version getter.+upCurVersion+  :: forall t curVer newVer.+     EpwUpgradeParameters t curVer newVer -> Version+upCurVersion EpwUpgradeParameters{} =+  contractVersion (Proxy @curVer)++-- | New 'UContractRouter' getter.+upNewCode'+  :: forall curVer newVer t.+      EpwUpgradeParameters t curVer newVer -> Maybe (UContractRouter newVer)+upNewCode' EpwUpgradeParameters{..} =+  case recognizeUpgPiece @(UContractRouterUpdate curVer newVer) upNewCode of+    UcrUpdate code -> Just code+    UcrRetain -> Nothing++-- | New 'PermanentImpl' getter.+upNewPermCode'+  :: forall curVer newVer t.+      EpwUpgradeParameters t curVer newVer -> Maybe (PermanentImpl newVer)+upNewPermCode' EpwUpgradeParameters{..} =+  case recognizeUpgPiece @(PermanentImplUpdate curVer newVer) upNewPermCode of+    PiUpdate code -> Just code+    PiRetain -> Nothing++-- | Make up a "fixed version" upgrade.+-- As argument you supply result of 'migrationToScriptI' or 'migrationToScripts'+-- and entrypoint-wise migration will be used inside.+--+-- Use this method in case you need to authoritatively perform arbitrary+-- modifications of contract storage.+fvUpgrade+  :: forall ver t.+     (KnownContractVersion ver, Traversable t)+  => t (MigrationScript (VerUStoreTemplate ver) (VerUStoreTemplate ver))+  -> EpwUpgradeParameters t ver ver+fvUpgrade migrationScripts = EpwUpgradeParameters+  { upMigrationScripts = migrationScripts+  , upNewCode = Nothing+  , upNewPermCode = Nothing+  }++-- | Construct 'OneShotUpgradeParameters'.+--+-- Naturally, you can construct this kind of upgrade only if your migration+-- has exactly one stage; for batched migrations use 'makeEpwUpgrade'.+makeOneShotUpgradeParameters+  :: forall curVer newVer.+     EpwUpgradeParameters Identity curVer newVer+  -> OneShotUpgradeParameters curVer+makeOneShotUpgradeParameters epw@EpwUpgradeParameters{} =+  ( #currentVersion .!+      upCurVersion epw+  , #newVersion .!+      upNewVersion epw+  , #migrationScript .!+      checkedCoerce (runIdentity $ upMigrationScripts epw)+  , #newCode .! (coerceUContractRouter <$> upNewCode' epw)+  , #newPermCode .! (checkedCoerce <$> upNewPermCode' epw)+                    \\ permanentsAreSameEvi @curVer @newVer+  )++-- | Construct a call which should be performed in order to perform migration.+makeOneShotUpgrade+  :: forall oldVer newVer.+     (EpwUpgradeParameters Identity oldVer newVer)+  -> Parameter oldVer+makeOneShotUpgrade =+  Upgrade . makeOneShotUpgradeParameters++-- | Construct calls which should be performed in order to perform full+-- entrypoint-wise migration.+makeEpwUpgrade+  :: forall curVer newVer t.+     (EpwUpgradeParameters t curVer newVer)+  -> [Parameter curVer]+makeEpwUpgrade epw@EpwUpgradeParameters{} =+  mconcat+  [ [EpwBeginUpgrade (#current .! upCurVersion epw, #new .! upNewVersion epw)]+  , EpwApplyMigration . checkedCoerce <$> toList (upMigrationScripts epw)+  , [EpwSetCode $ coerceUContractRouter code+      | Just code <- pure $ upNewCode' epw+      ]+  , [EpwSetPermCode $ checkedCoerce code+      | Just code <- pure $ upNewPermCode' epw+      ]+     \\ permanentsAreSameEvi @curVer @newVer+  , [EpwFinishUpgrade]+  ]++-- | Way of performing an upgrade.+data UpgradeWay (t :: Kind.Type -> Kind.Type) where+  -- | Perform upgrade in a single transaction.+  -- This, naturally, cannot be used with batched migrations.+  UpgOneShot :: UpgradeWay Identity++  -- | Perform upgrade calling one entrypoint per transaction.+  UpgEntrypointWise :: UpgradeWay t++deriving stock instance Show (UpgradeWay t)++-- | 'UpgradeWay' which can be used with simple (non-batched) migrations.+type SimpleUpgradeWay = UpgradeWay Identity++-- | Perform a contract upgrade in an integrational test scenario.+integrationalTestUpgrade+  :: (PermConstraint curVer)+  => EpwUpgradeParameters t curVer newVer+  -> UpgradeWay t+  -> UTAddress curVer+  -> IntegrationalScenarioM (UTAddress newVer)+integrationalTestUpgrade upgParams way addr =+  coerce addr <$ case way of+    UpgOneShot -> lCallDef addr (makeOneShotUpgrade upgParams)+    UpgEntrypointWise -> mapM_ (lCallDef addr) (makeEpwUpgrade upgParams)
+ src/Lorentz/Contracts/Upgradeable/EntrypointWise.hs view
@@ -0,0 +1,230 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Lorentz.Contracts.Upgradeable.EntrypointWise+  ( EntrypointImpl+  , EpwFallback+  , EpwContract (..)+  , EpwCaseClause (..)+  , mkEpwContract+  , mkEpwContractT+  , epwFallbackFail+  , (/==>)+  , removeEndpoint+  , EpwDocumented (..)+  , epwContractDoc+  ) where++import Lorentz+import Prelude (Typeable, fmap)++import Lorentz.Contracts.Upgradeable.Common+import Lorentz.UStore+import Michelson.Text+import Util.TypeLits+import Util.TypeTuple++-- | This data type represents the new contract code and migrations necessary+--   to upgrade the contract endpoints to the new version.+data EpwContract ver = EpwContract+  { epwServe :: UContractRouter ver+  -- ^ `epwServe` does  the dispatching logic and is assumed to be used for+  --   the `code` lambda of the upgradeable contract.++  , epwCodeMigrations :: forall oldStore. [MigrationScript oldStore (VerUStoreTemplate ver)]+  -- ^ `epwCodeMigrations` is a list of packed migrations the client ought to+  --   pass to the `EpwUpgrade` method in order to upgrade the implementation.+  }+++-- | Creates the EpwContract data structure from a Rec of case clauses+mkEpwContract+  :: forall (ver :: VersionKind) (interface :: [EntrypointKind]) store.+  ( interface ~ VerInterface ver, store ~ VerUStoreTemplate ver+  , CodeMigrations interface+  , HasUStore "code" MText (EntrypointImpl store) store+  , HasUField "fallback" (EpwFallback store) store+  , Typeable store+  )+  => Rec (EpwCaseClause store) interface+  -> EpwFallback store+  -> EpwContract ver+mkEpwContract entries fallback = EpwContract+  { epwServe = mkUContractRouter $+      caseUParamUnsafe' @store @interface+  , epwCodeMigrations =+      fmap (MigrationScript . checkedCoercing_ @UStore_ @(UStore store)) $+        (push fallback # ustoreSetField #fallback) : mkMigrations entries+  }++-- | Like 'mkEpwContract', but accepts a tuple of clauses, not a 'Rec'.+mkEpwContractT+  :: forall clauses ver (interface :: [EntrypointKind]) store.+  ( interface ~ VerInterface ver, store ~ VerUStoreTemplate ver+  , clauses ~ Rec (EpwCaseClause store) interface+  , RecFromTuple clauses+  , CodeMigrations interface+  , HasUStore "code" MText (EntrypointImpl store) store+  , HasUField "fallback" (EpwFallback store) store+  , Typeable store+  )+  => IsoRecTuple clauses+  -> EpwFallback store+  -> EpwContract ver+mkEpwContractT clauses fallback = mkEpwContract (recFromTuple clauses) fallback++-- | A helper type that defines an entrypoint that receives+--   an unpacked argument+type TypedEntrypointImpl arg store =+  Lambda (arg, UStore store) ([Operation], UStore store)++-- | A helper type that defines an entrypoint that receives+--   a packed argument, i.e. it's basically an unpack instruction+--   followed by a TypedEntrypoint code+type EntrypointImpl store =+  Lambda (ByteString, UStore store) ([Operation], UStore store)++-- | A helper type that defines a function being called in case+--   no implementation matches the requested entrypoint+type EpwFallback store =+  Lambda ((MText, ByteString), UStore store) ([Operation], UStore store)++-- | A data type representing a full case clause with the name+--   and implementation of an entrypoint.+data EpwCaseClause store (entry :: EntrypointKind) where+  EpwCaseClause+    :: TypedEntrypointImpl arg store+    -> EpwCaseClause store '(name, arg)++(/==>)+  :: Label name+  -> Lambda (arg, UStore store) ([Operation], UStore store)+  -> EpwCaseClause store '(name, arg)+(/==>) _ = EpwCaseClause+infixr 0 /==>++-- | A greatly simplified version of UParam lookup code.+--+--   While it does not provide the same safety guarantees as UParam's lookup,+--   it does a map search instead of a linear search, and thus it may consume+--   less gas in practice.+caseUParamUnsafe'+  :: forall store (entries :: [EntrypointKind]).+  ( HasUStore "code" MText (EntrypointImpl store) store+  , HasUField "fallback" (EpwFallback store) store+  )+  => '[UParam entries, UStore store] :-> '[([Operation], UStore store)]+caseUParamUnsafe' = do+  dup+  unwrapUParam+  unpair+  dip (duupX @3)+  ustoreGet #code+  if IsSome+  then dip (dip (drop) # pair) # swap # exec+  else do+    drop+    dip (ustoreGetField #fallback # swap)+    unwrapUParam+    pair+    exec++-- | Default implementation for 'EpwFallback' reports an error just like its+--   UParam counterpart+epwFallbackFail :: EpwFallback store+epwFallbackFail =+  car # car # failCustom #uparamNoSuchEntrypoint++-- | These functions create the code blocks one has to supply in order+--   upgrade a contract. These code blocks write the code of the contract+--   to a submap of UStore. Code migrations _do not delete_ the old code+--   blocks from UStore, so would still be possible to call the old entry+--   points manually after applying migrations.+class CodeMigrations (entries :: [EntrypointKind]) where+  mkMigrations+    :: forall store.+    ( Typeable store+    , GetUStoreKey store "code" ~ MText+    , GetUStoreValue store "code" ~ EntrypointImpl store+    )+    =>  Rec (EpwCaseClause store) entries+    -> ['[UStore store] :-> '[UStore store]]++instance+  ( CodeMigrations entries+  , KnownSymbol name+  , NiceUnpackedValue arg+  )+  => CodeMigrations ((name ?: arg) ': entries) where+    mkMigrations (EpwCaseClause impl :& clauses) =+      (push untypedLambda # push (symbolToMText @name) # ustoreInsert #code)+      : mkMigrations clauses+      where+        untypedLambda = do+          unpair+          unpackRaw @arg+          ifSome nop $ failCustom_ #uparamArgumentUnpackFailed+          pair+          impl++instance CodeMigrations '[] where+  mkMigrations _ = []++-- | Removes an endpoint from the #code submap+removeEndpoint+  :: forall store name s.+     GetUStoreKey store "code" ~ MText+  => Label name+  -> UStore store ': s :-> UStore store ': s+removeEndpoint Label = do+  push $ symbolToMText @name+  ustoreDelete #code++-- | Helper for documenting entrypoints with EPW interface.+class EpwDocumented (entries :: [EntrypointKind]) where+  -- | Make up documentation for given entry points.+  --+  -- As result you get a fake contract from which you can later build desired+  -- documentation. Although, you may want to add contract name and+  -- description first.+  epwDocument+    :: Rec (EpwCaseClause store) entries+    -> Lambda () ()++instance EpwDocumented '[] where+  epwDocument RNil = nop++instance (KnownSymbol name, EpwDocumented es) =>+         EpwDocumented ('(name, a) ': es) where+  epwDocument (EpwCaseClause code :& es) =+    let documentedCode = clarifyParamBuildingSteps (pbsUParam @name) code+    in cutLorentzNonDoc documentedCode # epwDocument es++-- | By given list of entrypoints make up a fake contract which contains+-- documentation for the body of given upgradeable contract.+epwContractDoc+  :: forall ver.+     ( NiceVersion ver+     , KnownContractVersion ver+     , EpwDocumented (VerInterface ver)+     , PermConstraint ver+     )+  => Rec (EpwCaseClause (VerUStoreTemplate ver)) (VerInterface ver)+  -> PermanentImpl ver+  -> Lambda () ()+epwContractDoc upgImpl permImpl =+  fakeCoercing . finalizeParamCallingDoc @(Parameter ver) $ do+    doc $ DVersion (contractVersion (Proxy @ver))+    fakeCoercing $+      cCode $ upgradeableContract @ver+    fakeCoercing $+      -- We have to put this part (which describes actual logic of our contract)+      -- separately, because this is not directly part of @Run@ entrypoint of+      -- 'upgradeableContract', and also because Markdown editors usually do not+      -- render deeply nested headers well.+      clarifyParamBuildingSteps pbsContainedInRun $+        epwDocument upgImpl+    fakeCoercing $+      clarifyParamBuildingSteps pbsContainedInRunPerm $+        unPermanentImpl permImpl
+ src/Lorentz/Contracts/Upgradeable/StorageDriven.hs view
@@ -0,0 +1,342 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Contracts based on storage-driven upgrages.+--+-- Here entrypoints are declared as part of UStore template, then+-- we automatically derive public API of the contract from it.+--+-- Migration mechanism for storage (see 'Lorentz.UStore.Migration') also applies+-- to these entrypoints.+--+-- This approach differs from one in "Lorentz.Contracts.Upgradeable.EntrypointWise"+-- in the following points:+-- 1. Storage migrations are not handled here, only 'UContractRouter' creation.+--    The former is comprehensively handled by 'Lorentz.UStore.Migration'.+-- 2. Contract interface is declared via storage - 'UStoreEntrypoint' entries+--    in storage define which public entrypoints (those which are callable via+--    passing 'UParam') the contract will have.+-- 3. Parameter dispatch fallback is made part of 'UContractRouter',+--    not storing it in storage here for simplicity.+--    The user can still decide to keep fallback implementation in storage if it+--    is big and then refer to it in 'SduFallback'.+module Lorentz.Contracts.Upgradeable.StorageDriven+  ( UStoreEntrypoint+  , UMarkerEntrypoint+  , SduEntrypoint+  , pattern UStoreEntrypoint+  , mkSduEntrypoint+  , mkUStoreEntrypoint+  , SduFallback+  , UStoreEpInterface+  , mkSduContract+  , callUStoreEntrypoint+  , sduFallbackFail++    -- * Documentation+  , sduDocument+  , SduDocumentTW+  , sduAddEntrypointDoc+  , SduAddEntrypointDocTW+  , sduContractDoc+  ) where++import Lorentz+import Prelude (Const(..), Identity(..), Typeable, id)++import qualified Data.Kind as Kind++import Lorentz.Contracts.Upgradeable.Common+import qualified Lorentz.Instr as L+import Lorentz.UStore+import Lorentz.UStore.Doc+import Lorentz.UStore.Traversal+import Util.TypeLits++----------------------------------------------------------------------------+-- Types+----------------------------------------------------------------------------++type SduEntrypointUntyped store =+  Lambda (ByteString, UStore store) ([Operation], UStore store)++-- | An entrypoint which is assumed to be kept in 'UStore'.+--   It accepts a packed argument.+newtype SduEntrypoint (store :: Kind.Type) (arg :: Kind.Type) = SduEntrypoint+  { unSduEntrypoint :: SduEntrypointUntyped store+  } deriving stock (Eq, Generic)+    deriving anyclass (IsoValue, Wrappable)++instance ( Typeable store, Typeable arg+         , TypeHasDoc (UStore store), TypeHasDoc arg+         ) =>+         TypeHasDoc (SduEntrypoint store arg) where+  typeDocMdDescription =+    "Public upgradeable entrypoint of a contract."+  typeDocMdReference tp =+    customTypeDocMdReference ("SduEntrypoint", DType tp) [DType (Proxy @arg)]+  typeDocHaskellRep =+    concreteTypeDocHaskellRep @(SduEntrypoint () Integer)+  typeDocMichelsonRep =+    concreteTypeDocMichelsonRep @(SduEntrypoint () Integer)+  typeDocDependencies p = mconcat+    [ [SomeDocDefinitionItem $ DUStoreTemplate $ Proxy @()]+        --- ^ for example of repr+    , genericTypeDocDependencies p+    ]++-- | A helper type that defines a function being called in case+--   no implementation matches the requested entrypoint+type SduFallback store =+  Lambda ((MText, ByteString), UStore store) ([Operation], UStore store)++-- | Public entrypoint of a contract kept in 'UStore'.+--+-- These are mere 'UStore' fields but treated specially by 'mkSduContract'+-- function which produces 'UContractRouter' capable of calling these+-- entrypoints.+--+-- This type is not intended for keeping internal code, in such case consider+-- using 'UStoreField' instead.+type UStoreEntrypoint store arg =+  UStoreFieldExt UMarkerEntrypoint (SduEntrypoint store arg)+data UMarkerEntrypoint :: UStoreMarkerType++-- | Access code of 'UStoreEntrypoint'.+pattern UStoreEntrypoint :: SduEntrypointUntyped store -> UStoreEntrypoint store arg+pattern UStoreEntrypoint code = UStoreField (SduEntrypoint code)++type UStoreEpKey = (Lambda () (), MText)++instance KnownUStoreMarker UMarkerEntrypoint where+  mkFieldMarkerUKey field =+    -- Using special encoding to avoid finding non-entrypoints in parameter+    -- dispatch.+    -- Packing an empty lambda is quite cheap, and seems to fit semantically+    -- best.+    lPackValueRaw @UStoreEpKey (L.nop, field)++  type ShowUStoreField UMarkerEntrypoint (SduEntrypoint store arg) =+    'Text "entrypoint with argument " ':<>: 'ShowType arg ':<>:+    'Text " over storage " ':<>: 'ShowType store++instance UStoreMarkerHasDoc UMarkerEntrypoint where+  ustoreMarkerKeyEncoding k = "pack ({} :: lambda, " <> k <> ")"++----------------------------------------------------------------------------+-- Logic+----------------------------------------------------------------------------++-- | Get the set of entrypoints (i.e. 'UStoreEntrypoint' entries) stored in UStore+-- with given template.+type UStoreEpInterface utemplate =+  ExtractInterface utemplate (PickMarkedFields UMarkerEntrypoint utemplate)++type family ExtractInterface (utemplate :: Kind.Type) (ufields :: [(Symbol, Kind.Type)])+              :: [EntrypointKind] where+  ExtractInterface _ '[] = '[]+  ExtractInterface utemplate (entry ': entries) =+    ExtractEntrypoint utemplate entry ': ExtractInterface utemplate entries++type family ExtractEntrypoint (utemplate :: Kind.Type) (ufields :: (Symbol, Kind.Type))+              :: EntrypointKind where+  ExtractEntrypoint utemplate '(name, SduEntrypoint utemplate arg) =+    name ?: arg+  ExtractEntrypoint _ '(name, SduEntrypoint (UStore _) _) =+    TypeError ('Text "UStore passed to entrypoint, expected UStore template" ':$$:+               'Text "In UStore field " ':<>: 'ShowType name+              )+  ExtractEntrypoint utemplate' '(name, SduEntrypoint utemplate _) =+    TypeError ('Text "Entrypoint polymorphic over foreign storage: UStore " ':<>:+               'ShowType utemplate ':$$:+               'Text "In storage UStore " ':<>: 'ShowType utemplate' ':$$:+               'Text "In field " ':<>: 'ShowType name+              )+  ExtractEntrypoint _ v =+    TypeError ('Text "Field with entrypoint of unknown type " ':<>: 'ShowType v)++-- | Construct 'UContractRouter' which allows calling all entrypoints stored+-- as 'UStoreEntrypoint' entries of 'UStore'.+mkSduContract+  :: (Typeable (VerUStoreTemplate ver))+  => SduFallback (VerUStoreTemplate ver) -> UContractRouter ver+mkSduContract fallback = mkUContractRouter $ do+  dup @(UParam _)+  unwrapUParam; car+  dip (duupX @2)+  -- Further fetching UStore field manually because field name comes from stack+  push nop; pair; packRaw @UStoreEpKey+  get+  if IsSome+  then do+    unpackRaw @(SduEntrypointUntyped _)+    -- This error normally should not occur by construction of @interface@ type+    assertSome [mt|Wrong sdu entrypoint type|]+    dip $ do+      unwrapUParam; cdr+      pair+    swap+    exec+  else do+    unwrapUParam+    pair+    fallback++-- | Construct public entrypoint.+mkSduEntrypoint+  :: NiceUnpackedValue arg+  => Entrypoint arg (UStore store)+  -> SduEntrypoint store arg+mkSduEntrypoint code = SduEntrypoint $ do+  unpair+  unpackRaw+  ifSome nop $ failCustom_ #uparamArgumentUnpackFailed+  code++-- | Construct public entrypoint for 'UStore'.+mkUStoreEntrypoint+  :: NiceUnpackedValue arg+  => Entrypoint arg (UStore store)+  -> UStoreEntrypoint store arg+mkUStoreEntrypoint = UStoreField . mkSduEntrypoint++-- | Call an entrypoint since it appeared on stack.+callSduEntrypoint+  :: NicePackedValue arg+  => arg : SduEntrypoint store arg : UStore store : s+     :-> ([Operation], UStore store) : s+callSduEntrypoint = do+  dip $ coerceUnwrap >> swap+  packRaw+  pair+  exec++-- | Call an entrypoint stored under the given field.+callUStoreEntrypoint+  :: (NicePackedValue arg, HasUField field (SduEntrypoint store arg) store)+  => Label field+  -> arg : UStore store : s :-> ([Operation], UStore store) : s+callUStoreEntrypoint label = do+  dip $ ustoreGetField label+  callSduEntrypoint++-- | Default implementation for 'SduFallback' reports an error just like its+--   UParam counterpart.+sduFallbackFail :: SduFallback store+sduFallbackFail =+  car # car # failCustom #uparamNoSuchEntrypoint++----------------------------------------------------------------------------+-- Documentation+----------------------------------------------------------------------------++-- | Gather documentation of entrypoints kept in given storage.+-- Unfortunatelly, this seems to be the only place where we can pick the code+-- for documenting it.+--+-- Note: in most cases you want to use this function is couple with+-- 'sduAddEntrypointDoc'.+sduDocument+  :: UStoreTraversable SduDocumentTW template+  => template -> Lambda () ()+sduDocument = foldUStore SduDocumentTW++data SduDocumentTW = SduDocumentTW++instance UStoreTraversalWay SduDocumentTW where+  type UStoreTraversalArgumentWrapper SduDocumentTW = Identity+  type UStoreTraversalMonad SduDocumentTW = Const (Lambda () ())++instance {-# OVERLAPPING #-}+         UStoreTraversalFieldHandler SduDocumentTW+           UMarkerEntrypoint (SduEntrypoint store arg) where+  ustoreTraversalFieldHandler+      SduDocumentTW (Label :: Label fieldName) (Identity (SduEntrypoint ep)) =+    Const $+    cutLorentzNonDoc $ clarifyParamBuildingSteps (pbsUParam @fieldName) ep++instance UStoreTraversalFieldHandler SduDocumentTW marker v where+  ustoreTraversalFieldHandler SduDocumentTW _ _ = Const mempty+instance UStoreTraversalSubmapHandler SduDocumentTW k v where+  ustoreTraversalSubmapHandler SduDocumentTW _ _ = Const mempty++-- | Mark all public code kept in given storage as atomic entrypoints.+--+-- Sometimes you want your 'SduEntrypoint's to contain multiple sub-entrypoints+-- inside, in this case using 'entryCase' function you get documentation for each+-- of sub-entrypoints automatically and calling this function is not necessary.+-- In case when this __does not__ hold and 'SduEntrypoint' keeps exactly one+-- entrypoint, you still need to mark it as such in order for 'sduDocument'+-- to handle it properly. This function does exactly that - it finds all+-- UStore entrypoints and marks them for documentation.+sduAddEntrypointDoc+  :: ( UStoreTraversable SduAddEntrypointDocTW template+     , DocItem (DEntrypoint epKind)+     )+  => Proxy epKind -> template -> template+sduAddEntrypointDoc epKindP = modifyUStore (SduAddEntrypointDocTW epKindP)++data SduAddEntrypointDocTW =+  -- I don't want this type to be polymorphic over @epKind@ because this way+  -- phantom type would appear in 'sduAddEntrypointDoc' signature and any+  -- helper over this function would need to write the respective constraint+  -- with @epKind@. So using existential quantification.+  forall epKind. (DocItem (DEntrypoint epKind)) =>+  SduAddEntrypointDocTW (Proxy epKind)++instance UStoreTraversalWay SduAddEntrypointDocTW where+  type UStoreTraversalArgumentWrapper SduAddEntrypointDocTW = Identity+  type UStoreTraversalMonad SduAddEntrypointDocTW = Identity++instance {-# OVERLAPPING #-}+         ( TypeHasDoc arg, NiceParameterFull arg+         ) =>+         UStoreTraversalFieldHandler SduAddEntrypointDocTW+           UMarkerEntrypoint (SduEntrypoint store arg) where+  ustoreTraversalFieldHandler+      (SduAddEntrypointDocTW (_ :: Proxy epKind))+      (Label :: Label fieldName) (Identity (SduEntrypoint ep)) =+    Identity . SduEntrypoint $+      docGroup (DEntrypoint @epKind (symbolValT' @fieldName))+        (doc (constructDEpArg @arg) # ep)++instance UStoreTraversalFieldHandler SduAddEntrypointDocTW marker v where+  ustoreTraversalFieldHandler _ _ = id+instance UStoreTraversalSubmapHandler SduAddEntrypointDocTW k v where+  ustoreTraversalSubmapHandler _ _ = id++-- | By given storage make up a fake contract which contains+-- documentation of all entrypoints declared by this storage.+--+-- Note: in most cases you want to use this function in couple with+-- 'sduAddEntrypointDoc'.+--+-- Note: we intentionally allow accepted @UStore@ template not to correspond+-- to the contract version storage, this is useful when one does not want to+-- provide the full storage (construction of which may require passing some+-- parameters), rather only part of storage with entrypoints.+sduContractDoc+  :: forall utemplate ver.+     ( NiceVersion ver+     , KnownContractVersion ver+     , UStoreTraversable SduDocumentTW utemplate+     , PermConstraint ver+     )+  => utemplate+  -> PermanentImpl ver+  -> Lambda () ()+sduContractDoc store permImpl = do+    doc $ DVersion (contractVersion (Proxy @ver))+    fakeCoercing $+      cCode $ upgradeableContract @ver+    finalizeParamCallingDoc @(Parameter ver) . fakeCoercing $+      -- We have to put this part (which describes actual logic of our contract)+      -- separately, because this is not directly part of @Run@ entrypoint of+      -- 'upgradeableContract', and also because Markdown editors usually do not+      -- render deeply nested headers well.+      clarifyParamBuildingSteps pbsContainedInRun $+        sduDocument store+    finalizeParamCallingDoc @(Parameter ver) . fakeCoercing $+      clarifyParamBuildingSteps pbsContainedInRunPerm $+        unPermanentImpl permImpl
+ src/Lorentz/Contracts/Upgradeable/Test.hs view
@@ -0,0 +1,36 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Lorentz.Contracts.Upgradeable.Test+  ( -- * Test predicates+    testUpgradeableContractDoc++    -- * Individual test predicates+  , testSingleVersion+  ) where++import Prelude++import Test.HUnit (assertFailure)++import Lorentz.Contracts.Upgradeable.Common+import Lorentz.Test.Doc++-- | Check that contract documentation mentions version only once.+testSingleVersion :: DocTest+testSingleVersion =+  mkDocTest "Version documented" $+  \doc ->+    case allContractDocItems @DVersion doc of+      [] -> assertFailure "Contract contains no 'DVersion'"+      [_] -> pass+      _ -> assertFailure "Contract contains several 'DVersion's"++-- | Test all properties of upgradeable contract.+testUpgradeableContractDoc :: [DocTest]+testUpgradeableContractDoc = mconcat+  [ testLorentzDoc+  , [ testSingleVersion+    ]+  ]
+ src/Lorentz/Contracts/UpgradeableCounter.hs view
@@ -0,0 +1,36 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- TODO: Replace 'Empty' with 'Never' from morley+{-# OPTIONS_GHC -Wno-deprecations #-}++-- | UpgradeableCounter demonstrates the implementation of a simple contract+--   that has upgradeable storage, interface, and implementation.+--+--   In the first version it stores a Natural and allows to add some value+--   to it or multiply the current value by a certain natural number.+--+--   The second version changes the type of the stored value to Integer,+--   and instead of providing Mul Natural and Add Natural endpoints, it+--   just allows to increment or decrement the current value.+--+--   While the contract does not have any advanced functionality, it provides+--   a birds-eye view on all the aspects of the upgradeable contracts concept+--   and serves as an example on how to apply this concept.+++module Lorentz.Contracts.UpgradeableCounter+  ( Parameter(..)+  , Storage+  , CounterV0+  , upgradeableCounterContract+  , mkEmptyStorage+  ) where++import Lorentz.Contracts.Upgradeable.Common++type CounterV0 = EmptyContractVersion Empty++upgradeableCounterContract :: UpgradeableContract CounterV0+upgradeableCounterContract = upgradeableContract
+ src/Lorentz/Contracts/UpgradeableCounter/V1.hs view
@@ -0,0 +1,108 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Lorentz.Contracts.UpgradeableCounter.V1+  ( CounterV1+  , migrate+  , migrations+  , counterContract+  , counterUpgradeParameters+  , UStoreV1+  , UStoreTemplateV1+  ) where++import Lorentz+import Lorentz.Contracts.Upgradeable.Common+import Lorentz.Contracts.Upgradeable.EntrypointWise+import Lorentz.UStore+import Lorentz.UStore.Migration++import Lorentz.Contracts.UpgradeableCounter++{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}++data CounterV1 :: VersionKind++data UStoreTemplateV1 = UStoreTemplateV1+  { counterValue :: UStoreField Natural+  , code :: MText |~> EntrypointImpl UStoreTemplateV1+  , fallback :: UStoreField $ EpwFallback UStoreTemplateV1+  } deriving stock (Eq, Generic)++type UStoreV1 = UStore UStoreTemplateV1++type Interface =+  [ "add" ?: Natural+  , "mul" ?: Natural+  , "getCounterValue" ?: Void_ () Natural+  ]++instance KnownContractVersion CounterV1 where+  type VerInterface CounterV1 = Interface+  type VerUStoreTemplate CounterV1 = UStoreTemplateV1+  contractVersion _ = 1++runAdd :: Lambda (Natural, UStoreV1) ([Operation], UStoreV1)+runAdd = do+  unpair+  dip $ ustoreGetField #counterValue+  add+  ustoreSetField #counterValue+  nil; pair++runMul :: Lambda (Natural, UStoreV1) ([Operation], UStoreV1)+runMul = do+  unpair+  dip $ ustoreGetField #counterValue+  mul+  ustoreSetField #counterValue+  nil; pair++runGetCounterValue :: Lambda (Void_ () Natural, UStoreV1) ([Operation], UStoreV1)+runGetCounterValue = do+  unpair+  void_ $ do+    drop @()+    ustoreGetField #counterValue+    dip drop++epwContract :: EpwContract CounterV1+epwContract = mkEpwContractT+  ( #add /==> runAdd+  , #mul /==> runMul+  , #getCounterValue /==> runGetCounterValue+  ) epwFallbackFail++-- | Migrations represent entrypoint-wise upgrades. Each migration puts+--   an implementation of a method to UStore. The contract code itself+--   (`epwServe`) does not do anything special except for taking these+--   lambdas out of the big map.+migrations :: [MigrationScript () UStoreTemplateV1]+migrations =+  migrateStorage :+  (epwCodeMigrations epwContract)++-- | This function migrates the storage from an empty one to UStoreV1,+--   i.e. it populates the empty BigMap with entries and initial values+--   for each field. Currently it is not guaranteed that all fields will be set+--   according to the template. See /docs/upgradeableContracts.md for type-safe+--   migrations idea description. The result is expected to adhere+--   to V1.UStoreTemplateV1.+migrateStorage :: MigrationScript () UStoreTemplateV1+migrateStorage = manualWithNewUStore $ do+  push @Natural 0+  ustoreSetField #counterValue++migrate :: MigrationScript () UStoreTemplateV1+migrate = manualConcatMigrationScripts migrations++counterContract :: UContractRouter CounterV1+counterContract = epwServe epwContract++counterUpgradeParameters :: EpwUpgradeParameters [] CounterV0 CounterV1+counterUpgradeParameters = EpwUpgradeParameters+  { upMigrationScripts = migrations+  , upNewCode = counterContract+  , upNewPermCode = emptyPermanentImpl+  }
+ src/Lorentz/Contracts/UpgradeableCounter/V2.hs view
@@ -0,0 +1,109 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Lorentz.Contracts.UpgradeableCounter.V2+  ( Interface+  , UStoreV2+  , CounterV2+  , migrate+  , migrations+  , counterContract+  , counterUpgradeParameters+  ) where++import Lorentz++import Lorentz.Contracts.Upgradeable.Common+import Lorentz.Contracts.Upgradeable.EntrypointWise+import Lorentz.Contracts.UpgradeableCounter.V1 (CounterV1, UStoreTemplateV1)+import Lorentz.UStore+import Lorentz.UStore.Migration++data CounterV2 :: VersionKind++data UStoreTemplateV2 = UStoreTemplateV2+  { newCounterValue :: UStoreField Integer+  , code :: MText |~> EntrypointImpl UStoreTemplateV2+  , fallback :: UStoreField $ EpwFallback UStoreTemplateV2+  } deriving stock (Eq, Generic)++type UStoreV2 = UStore UStoreTemplateV2++type Interface =+  [ "inc" ?: ()+  , "dec" ?: ()+  , "getCounterValue" ?: Void_ () Integer+  ]++instance KnownContractVersion CounterV2 where+  type VerInterface CounterV2 = Interface+  type VerUStoreTemplate CounterV2 = UStoreTemplateV2+  contractVersion _ = 2++epwContract :: EpwContract CounterV2+epwContract = mkEpwContractT+  ( #inc /==> runInc+  , #dec /==> runDec+  , #getCounterValue /==> runView+  ) epwFallbackFail++addInt :: Integer -> Lambda ((), UStoreV2) ([Operation], UStoreV2)+addInt x = do+  unpair+  drop+  ustoreGetField #newCounterValue+  push x+  add+  ustoreSetField #newCounterValue+  nil; pair++runInc :: Lambda ((), UStoreV2) ([Operation], UStoreV2)+runInc = addInt 1++runDec :: Lambda ((), UStoreV2) ([Operation], UStoreV2)+runDec = addInt (-1)++runView :: Lambda (Void_ () Integer, UStoreV2) ([Operation], UStoreV2)+runView = do+  unpair+  void_ $ do+    drop @()+    ustoreGetField #newCounterValue+    dip drop+++migrations :: [MigrationScript UStoreTemplateV1 UStoreTemplateV2]+migrations =+    migrationToScript migrateStorage+  : removeOldEndpoints+  : epwCodeMigrations epwContract++removeOldEndpoints :: MigrationScript UStoreTemplateV1 UStoreTemplateV2+removeOldEndpoints = manualWithOldUStore $ do+  removeEndpoint #add+  removeEndpoint #mul++migrateStorage :: UStoreMigration UStoreTemplateV1 UStoreTemplateV2+migrateStorage = mkUStoreMigration $ do+  migrateExtractField #counterValue+  int+  migrateAddField #newCounterValue++  migrateCoerceUnsafe #code+  migrateCoerceUnsafe #fallback++  migrationFinish++migrate :: MigrationScript UStoreTemplateV1 UStoreTemplateV2+migrate = manualConcatMigrationScripts migrations++counterContract :: UContractRouter CounterV2+counterContract = epwServe epwContract++counterUpgradeParameters :: EpwUpgradeParameters [] CounterV1 CounterV2+counterUpgradeParameters = EpwUpgradeParameters+  { upMigrationScripts = migrations+  , upNewCode = counterContract+  , upNewPermCode = emptyPermanentImpl+  }
+ src/Lorentz/Contracts/UpgradeableCounterSdu.hs view
@@ -0,0 +1,61 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- TODO: Replace 'Empty' with 'Never' from morley+{-# OPTIONS_GHC -Wno-deprecations #-}++-- | UpgradeableCounterSdu demonstrates the implementation of a simple contract+--   that has upgradeable storage, interface, and implementation and uses+--   storage-driven upgrades. Aside from the latter, this contract is similar+--   to "UpgradeableCounter".+--+--   In the first version it stores a Natural and allows to add some value+--   to it.+--+--   The second version changes the type of the stored value to Integer,+--   and instead of providing Add Natural and Inc () endpoints, it+--   just allows to increment or decrement the current value.+--+--   While the contract does not have any advanced functionality, it provides+--   a birds-eye view on all the aspects of the upgradeable contracts concept+--   and serves as an example on how to apply this concept.+++module Lorentz.Contracts.UpgradeableCounterSdu+  ( CounterSduV+  , Parameter(..)+  , Storage+  , Permanent (..)+  , upgradeableCounterContractSdu+  , mkEmptyStorage+  ) where++import Lorentz++import Lorentz.Contracts.Upgradeable.Common++-- | Version identifier for this contract.+--+-- It a bit differs from how we do in other contracts - this type is supposed+-- to be used in all versions of the contract, but it has type parameter which+-- is supposed to designate contract version.+data CounterSduV (v :: Nat) :: VersionKind++data Permanent+  = GetCounter (Void_ () Integer)+  | GetNothing Empty+  deriving stock Generic+  deriving anyclass (IsoValue, HasAnnotation)++instance ParameterHasEntrypoints Permanent where+  type ParameterEntrypointsDerivation Permanent = EpdPlain++instance TypeHasDoc Permanent where+  typeDocMdDescription = "Parameter for permanent entrypoints."++deriving via (EmptyContractVersion Permanent)+  instance KnownContractVersion (CounterSduV 0)++upgradeableCounterContractSdu :: UpgradeableContract (CounterSduV 0)+upgradeableCounterContractSdu = upgradeableContract
+ src/Lorentz/Contracts/UpgradeableCounterSdu/V1.hs view
@@ -0,0 +1,124 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-orphans #-}++module Lorentz.Contracts.UpgradeableCounterSdu.V1+  ( counterContract+  , migration+  , counterUpgradeParameters+  , counterDoc++    -- * Internals+  , runGetCounterValue+  , runAdd+  , permImpl+  ) where++import Lorentz+import Prelude (Identity)++import Data.Constraint (Dict(..))++import Lorentz.Contracts.Upgradeable.Common+import Lorentz.Contracts.Upgradeable.StorageDriven+import Lorentz.Contracts.UpgradeableCounterSdu+import Lorentz.UStore++{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}++data UStoreTemplate = UStoreTemplate+  { counterValue :: UStoreField Natural+  , epInc :: UStoreEntrypoint UStoreTemplate ()+  , epAdd :: UStoreEntrypoint UStoreTemplate Natural+  , epGetCounterValue :: UStoreEntrypoint UStoreTemplate (Void_ () Natural)+  } deriving stock (Eq, Generic)++instance UStoreTemplateHasDoc UStoreTemplate where+  ustoreTemplateDocName = "V1"+  ustoreTemplateDocDescription =+    "Template for version 1 of the contract."++type UStorage = UStore UStoreTemplate++type Interface = UStoreEpInterface UStoreTemplate++instance KnownContractVersion (CounterSduV 1) where+  type VerInterface (CounterSduV 1) = Interface+  type VerUStoreTemplate (CounterSduV 1) = UStoreTemplate+  type VerPermanent (CounterSduV 1) = Permanent++_checkInterface :: Dict $ Interface ~+  [ "epInc" ?: ()+  , "epAdd" ?: Natural+  , "epGetCounterValue" ?: Void_ () Natural+  ]+_checkInterface = Dict++runInc :: Entrypoint () UStorage+runInc = do+  drop @()+  ustoreGetField #counterValue+  push @Natural 1; add+  ustoreSetField #counterValue+  nil; pair++runAdd :: Entrypoint Natural UStorage+runAdd = do+  dip $ ustoreGetField #counterValue+  add+  ustoreSetField #counterValue+  nil; pair++runGetCounterValue :: Entrypoint (Void_ () Natural) UStorage+runGetCounterValue = void_ $ do+  drop @()+  ustoreGetField #counterValue+  dip drop++counterContract :: UContractRouter (CounterSduV 1)+counterContract = mkSduContract sduFallbackFail++permImpl :: PermanentImpl (CounterSduV 1)+permImpl = mkSmallPermanentImpl+  ( #cGetCounter /-> void_ $ do+      drop @(); ustoreToField #counterValue; int+  , #cGetNothing /-> absurd_+  )++mkStorage :: UStoreTemplate+mkStorage = UStoreTemplate+  { counterValue = UStoreField 0+  , epInc = mkUStoreEntrypoint runInc+  , epAdd = mkUStoreEntrypoint runAdd+  , epGetCounterValue = mkUStoreEntrypoint runGetCounterValue+  }++-- | This function migrates the storage from an empty one to UStorage,+--   i.e. it populates the empty BigMap with initial values for each field+--   and entrypoints.+--   The result is expected to adhere to V1.UStoreTemplate.+migration :: UStoreMigration () UStoreTemplate+migration = fillUStore mkStorage++counterUpgradeParameters :: EpwUpgradeParameters Identity (CounterSduV 0) (CounterSduV 1)+counterUpgradeParameters = EpwUpgradeParameters+  { upMigrationScripts = migrationToScriptI migration+  , upNewCode = counterContract+  , upNewPermCode = permImpl+  }+++-- TODO: come up with a proper way to include documentation to the+-- storage-driven upgradeable contracts+counterDoc :: '[()] :-> '[()]+counterDoc =+  docGroup (DName "Upgradeable counter (SDU)") $ do+    contractGeneralDefault++    doc $ DDescription+      "Sample of storage-driven upgradeable contract."+    sduContractDoc+      (sduAddEntrypointDoc (Proxy @UpgradeableEntrypointsKind) mkStorage)+      permImpl
+ src/Lorentz/Contracts/UpgradeableCounterSdu/V2.hs view
@@ -0,0 +1,152 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-orphans #-}++module Lorentz.Contracts.UpgradeableCounterSdu.V2+  ( CounterSduV+  , counterContract+  , migration+  , counterUpgradeParameters+  , counterUpgradeParametersFromV0+  , counterRollbackParameters+  ) where++import Lorentz+import Prelude (Identity)++import Lorentz.Contracts.Upgradeable.Common+import Lorentz.Contracts.Upgradeable.StorageDriven+import Lorentz.Contracts.UpgradeableCounterSdu+import qualified Lorentz.Contracts.UpgradeableCounterSdu.V1 as V1+import Lorentz.UStore+import Lorentz.UStore.Migration+import Util.Named++-- Moved all entrypoints to a dedicated datatype for convenience+data UStoreEntrypoints store = UStoreEntrypoints+  { epInc :: UStoreEntrypoint store ()+  , epDec :: UStoreEntrypoint store ()+  , epGetCounterValue :: UStoreEntrypoint store (Void_ () Integer)+  } deriving stock (Eq, Generic)++data UStoreTemplate = UStoreTemplate+  { -- We want to keep a value of significantly different type comparing to V1+    counterValue :: UStoreField ("i" :! Integer, ())+  , code :: UStoreEntrypoints UStoreTemplate+  } deriving stock (Eq, Generic)++type UStorage = UStore UStoreTemplate++type Interface = UStoreEpInterface UStoreTemplate++instance KnownContractVersion (CounterSduV 2) where+  type VerInterface (CounterSduV 2) = Interface+  type VerUStoreTemplate (CounterSduV 2) = UStoreTemplate+  type VerPermanent (CounterSduV 2) = Permanent++addInt :: Integer -> Entrypoint () UStorage+addInt x = do+  drop @()+  ustoreGetField #counterValue+  getField #i+  push x+  add+  setField #i+  ustoreSetField #counterValue+  nil; pair++runInc :: Entrypoint () UStorage+runInc = addInt 1++runDec :: Entrypoint () UStorage+runDec = addInt (-1)++runGetCounterValue :: Entrypoint (Void_ () Integer) UStorage+runGetCounterValue = void_ $ do+  drop @()+  ustoreGetField #counterValue+  toField #i+  dip drop++counterContract :: UContractRouter (CounterSduV 2)+counterContract = mkSduContract sduFallbackFail++permImpl :: PermanentImpl (CounterSduV 2)+permImpl = mkSmallPermanentImpl+  ( #cGetCounter /-> void_ $ do+      drop @(); ustoreToField #counterValue; toField #i+  , #cGetNothing /-> absurd_+  )++mkStorage :: UStoreTemplate+mkStorage = UStoreTemplate+  { counterValue = UStoreField (#i .! 0, ())+  , code = UStoreEntrypoints+    { epInc = mkUStoreEntrypoint runInc+    , epDec = mkUStoreEntrypoint runDec+    , epGetCounterValue = mkUStoreEntrypoint runGetCounterValue+    }+  }++migration :: UStoreMigration (VerUStoreTemplate (CounterSduV 1)) UStoreTemplate+migration = mkUStoreMigration $ do+  migrateExtractField #counterValue+  int; toNamed #i+  unit; swap; pair+  migrateAddField #counterValue++  migrateRemoveField #epAdd++  push (mkSduEntrypoint runInc)+  migrateOverwriteField #epInc++  push (mkSduEntrypoint runDec)+  migrateAddField #epDec++  push (mkSduEntrypoint runGetCounterValue)+  migrateOverwriteField #epGetCounterValue++  migrationFinish++counterUpgradeParameters :: EpwUpgradeParameters Identity (CounterSduV 1) (CounterSduV 2)+counterUpgradeParameters = EpwUpgradeParameters+  { upMigrationScripts = migrationToScriptI migration+  , upNewCode = counterContract+  , upNewPermCode = permImpl+  }++counterUpgradeParametersFromV0 :: EpwUpgradeParameters Identity (CounterSduV 0) (CounterSduV 2)+counterUpgradeParametersFromV0 = EpwUpgradeParameters+  { upMigrationScripts = migrationToScriptI $ fillUStore mkStorage+  , upNewCode = counterContract+  , upNewPermCode = permImpl+  }++rollback :: UStoreMigration UStoreTemplate (VerUStoreTemplate (CounterSduV 1))+rollback = mkUStoreMigration $ do+  migrateExtractField #counterValue+  toField #i; isNat+  assertSome [mt|Rollback is impossible|]+  migrateAddField #counterValue++  push (mkSduEntrypoint V1.runAdd)+  migrateAddField #epAdd++  migrateCoerceUnsafe #epInc++  migrateRemoveField #epDec++  push (mkSduEntrypoint V1.runGetCounterValue)+  migrateOverwriteField #epGetCounterValue++  migrationFinish++-- Needed for one of our tests+counterRollbackParameters :: EpwUpgradeParameters Identity (CounterSduV 2) (CounterSduV 1)+counterRollbackParameters = EpwUpgradeParameters+  { upMigrationScripts = migrationToScriptI rollback+  , upNewCode = V1.counterContract+  , upNewPermCode = V1.permImpl+  }
+ src/Lorentz/Contracts/UpgradeableUnsafeLedger.hs view
@@ -0,0 +1,27 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- TODO: Replace 'Empty' with 'Never' from morley+{-# OPTIONS_GHC -Wno-deprecations #-}++-- | UpgradeableUnsafeLedger demonstrates a real-world use case of+--   an upgradeable contract. Its V1 contains a bug that makes it return+--   an incorrect totalSupply. Fortunately, we can upgrade the contract and fix+--   the bug. This contract does not use entrypoint-wise upgrades. Instead, it+--   upgrades atomically in one transaction. For non-atomic upgrades please+--   see the UpgradeableCounter example.++module Lorentz.Contracts.UpgradeableUnsafeLedger+  ( Parameter(..)+  , Storage+  , upgradeableUnsafeLedgerContract+  , mkEmptyStorage+  ) where++import Lorentz.Contracts.Upgradeable.Common++type Permanent = Empty++upgradeableUnsafeLedgerContract :: InitUpgradeableContract Permanent+upgradeableUnsafeLedgerContract = upgradeableContract
+ src/Lorentz/Contracts/UpgradeableUnsafeLedger/V1.hs view
@@ -0,0 +1,119 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | A buggy implementation of Unsafe ledger, returns balances multiplied by 2++module Lorentz.Contracts.UpgradeableUnsafeLedger.V1+  ( UnsafeLedgerV1+  , Interface+  , migrate+  , unsafeLedgerContract++  -- The following are used in V2+  , UStoreTemplate+  , UStoreV1+  , TransferParams+  , transfer+  , getTotalSupply+  ) where++import Lorentz++import Lorentz.Contracts.Upgradeable.Common+import Lorentz.UStore++data UnsafeLedgerV1 :: VersionKind++type Interface =+  [ "transfer" ?: TransferParams+  , "getTotalSupply" ?: Void_ () Natural+  , "getBalance" ?: Void_ Address (Maybe Natural)+  ]++type TransferParams = (Address, Natural)++data UStoreTemplate = UStoreTemplate+  { ledger      :: Address |~> Natural+  , totalSupply :: UStoreField Natural+  } deriving stock (Eq, Generic)++type UStoreV1 = UStore UStoreTemplate++instance KnownContractVersion UnsafeLedgerV1 where+  type VerInterface UnsafeLedgerV1 = Interface+  type VerUStoreTemplate UnsafeLedgerV1 = UStoreTemplate+  contractVersion _ = 1++-- | Like in UpgradeableCounter, this function  populates the empty UStore_+--   with entries and initial values for each field. The result is expected+--   to adhere to V1.UStoreTemplate+migrate :: '[UStore_] :-> '[UStore_]+migrate = checkedCoercing_ @_ @UStoreV1 $ do+  push @Natural 500+  dup+  dip $ ustoreSetField #totalSupply+  sender+  ustoreInsert #ledger++unsafeLedgerContract :: UContractRouter UnsafeLedgerV1+unsafeLedgerContract = mkUContractRouter $ do+  caseUParamT @Interface+    ( #transfer /-> transfer+    , #getTotalSupply /-> getTotalSupply+    , #getBalance /-> buggyGetBalance+    )+    uparamFallbackFail++transfer :: '[TransferParams, UStoreV1]+         :-> '[([Operation], UStoreV1)]+transfer = do+  debitSource; creditTo; nil; pair;++getTotalSupply :: '[Void_ () Natural, UStoreV1]+               :-> '[([Operation], UStoreV1)]+getTotalSupply = void_ (do drop @(); ustoreToField #totalSupply)++-- Buggy getBalance returns balance multiplied by 2+buggyGetBalance :: '[Void_ Address (Maybe Natural), UStoreV1]+                :-> '[([Operation], UStoreV1)]+buggyGetBalance = void_ $ do+  ustoreGet #ledger+  if IsSome+  then push @Natural 2 >> mul >> some+  else none++debitSource :: '[TransferParams, UStoreV1]+            :-> '[TransferParams, UStoreV1]+debitSource = do+  dip $ do+    sender+    dip dup+    ustoreGet #ledger+    assertSome [mt|Sender address is not in ledger|]+  swap+  dip (dup # cdr)+  subGt0+  swap+  dip (do sender; ustoreUpdate #ledger)++creditTo :: '[TransferParams, UStoreV1] :-> '[UStoreV1]+creditTo = do+  dup; car+  swap+  dip (dip dup # ustoreGet #ledger)+  swap+  if IsSome then dip (dup >> cdr) >> add @Natural else (dup >> cdr)+  some+  dip (car)+  swap+  ustoreUpdate #ledger++subGt0 :: Natural ': Natural ': s :-> Maybe Natural ': s+subGt0 = do+  sub;+  dup; assertGe0 [mt|Transferred value is greater than balance|]+  dup; eq0+  if Holds+  then drop >> none+  else isNat
+ src/Lorentz/Contracts/UpgradeableUnsafeLedger/V2.hs view
@@ -0,0 +1,50 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | The implementation of Unsafe ledger with V1 balance bug fixed++module Lorentz.Contracts.UpgradeableUnsafeLedger.V2+  ( UnsafeLedgerV2+  , migrate+  , unsafeLedgerContract+  ) where++import Lorentz++import Lorentz.Contracts.Upgradeable.Common+import qualified Lorentz.Contracts.UpgradeableUnsafeLedger.V1 as V1+import Lorentz.UStore++data UnsafeLedgerV2 :: VersionKind++-- The storage does not change+type UStoreV2 = V1.UStoreV1++type Interface = V1.Interface++instance KnownContractVersion UnsafeLedgerV2 where+  type VerInterface UnsafeLedgerV2 = Interface+  type VerUStoreTemplate UnsafeLedgerV2 = VerUStoreTemplate V1.UnsafeLedgerV1+  contractVersion _ = 2++-- | Storage migration function. Since the storage is the same,+--   there's nothing to migrate+migrate :: '[UStore_] :-> '[UStore_]+migrate = nop++-- | The second version of the UpgradeableUnsafeLedger.+--   Most of the functions are from V1 except for getBalance.+unsafeLedgerContract :: UContractRouter UnsafeLedgerV2+unsafeLedgerContract = mkUContractRouter $ do+  caseUParamT @Interface+    ( #transfer /-> V1.transfer+    , #getTotalSupply /-> V1.getTotalSupply+    , #getBalance /-> getBalance+    )+    uparamFallbackFail++-- Note that the new getBalance returns the correct balance+getBalance :: '[Void_ Address (Maybe Natural), UStoreV2]+           :-> '[([Operation], UStoreV2)]+getBalance = void_ (ustoreGet #ledger)
+ src/Lorentz/Contracts/UserUpgradeable/Migrations.hs view
@@ -0,0 +1,110 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-orphans #-}++-- | This module contains common functions and types related to user-defined+-- upgrades. It intentionally does not include mint- and burn-related+-- functionality because these should be handled by particular token+-- implementations (V2 and V1 correspondingly).+--+-- Note that the naming in this module is different from+-- Lorentz.Contracts.Upgradeable: by "migration" here we mean the process+-- of transferring the value from an old contract to the new one rather than+-- applying a transformation to storage.++module Lorentz.Contracts.UserUpgradeable.Migrations+  ( MigrationTarget+  , callMigrationTarget+  , initiateMigration+  ) where++import Lorentz++type MigrationTarget = FutureContract (Address, Natural)++type HasMigrationTarget storage =+  storage `HasFieldsOfType` '["migrationTarget" := Maybe MigrationTarget]++type HasAdmin storage =+  storage `HasFieldsOfType` '["admin" := Address]++-- | Migration is already in progress and cannot be initiated again.+type instance ErrorArg "alreadyMigrating" = ()++-- | Migration script has not been set.+type instance ErrorArg "nowhereToMigrate" = ()++-- | Specified contract (which keeps the new version of the code) does not exist+-- or does not have the specified entrypoint of type (Address, Natural)+type instance ErrorArg "migrationTargetDoesNotExist" = EpAddress+++instance CustomErrorHasDoc "alreadyMigrating" where+  customErrClass = ErrClassActionException+  customErrDocMdCause =+    "Migration is already in progress. \+    \Raised in repeated attempt to initiate migration."++instance CustomErrorHasDoc "nowhereToMigrate" where+  customErrClass = ErrClassActionException+  customErrDocMdCause =+    "Migration script has not been set. \+    \Raised on attempt to initiate migration."++instance CustomErrorHasDoc "migrationTargetDoesNotExist" where+  customErrClass = ErrClassActionException+  customErrDocMdCause =+    "Contract with specified address (to which we migrate) does \+    \not exist or has unexpected parameter type"++-- | Starts a migration from an old version of a contract to a new one.+initiateMigration+  :: forall storage. (HasAdmin storage, HasMigrationTarget storage)+  => '[MigrationTarget, storage] :-> '[([Operation], storage)]+initiateMigration = do+  dip $ do ensureAdmin; ensureNotMigrated+  some; setField #migrationTarget+  nil; pair+  where+    ensureAdmin :: '[storage] :-> '[storage]+    ensureAdmin = do+      getField #admin+      sender+      if IsEq+      then nop+      else failCustom_ #senderIsNotAdmin++    ensureNotMigrated :: '[storage] :-> '[storage]+    ensureNotMigrated = do+      getField #migrationTarget+      if IsSome+      then failCustom_ #alreadyMigrating+      else nop++-- |Forges a call to the new version; the forged operation contans the+-- address of the sender, and the amount of tokens to mint.+callMigrationTarget+  :: forall storage. HasMigrationTarget storage+  => '[Natural, storage] :-> '[([Operation], storage)]+callMigrationTarget = do+  sender+  pair+  stackType @('[(Address, Natural), storage])+  dip $ do+    getField #migrationTarget+    ifSome nop $ failCustom_ #nowhereToMigrate+    dup+    runFutureContract+    if IsSome+    then dip drop+    else do+      checkedCoerce_+      failCustom #migrationTargetDoesNotExist+    push (toMutez 0)++  stackType @('[(Address, Natural), Mutez, ContractRef (Address, Natural), _])+  transferTokens+  stackType @('[Operation, storage])+  dip nil; cons; pair
+ src/Lorentz/Contracts/UserUpgradeable/V1.hs view
@@ -0,0 +1,95 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-orphans #-}++-- | The first version of a minimal user-upgradeable ledger. It does not+-- offer common ledger functions like Transfer/GetTotalSupply/etc. to+-- demonstrate a concept and keep the code consise.+--+-- Note that the naming in this module is different from+-- Lorentz.Contracts.Upgradeable: by "migration" here we mean the process+-- of transferring the value from an old contract to the new one rather than+-- applying a transformation to storage. Thus, MigrationScript here is a lambda+-- that forges an operation to migrate user's funds rather than a function+-- that upgrades storage in-place.++module Lorentz.Contracts.UserUpgradeable.V1+  ( Parameter(..)+  , Storage(..)+  , mkStorage+  , userUpgradeableContract+  ) where++import Lorentz++import Lorentz.Contracts.UserUpgradeable.Migrations+  (MigrationTarget, callMigrationTarget, initiateMigration)++data Storage = Storage+  { ledger :: BigMap Address Natural+  , admin :: Address+  , migrationTarget :: Maybe MigrationTarget+  }+  deriving stock Generic+  deriving anyclass (IsoValue, HasAnnotation)++mkStorage :: BigMap Address Natural -> Address -> Storage+mkStorage balances admin = Storage+  { ledger = balances+  , admin = admin+  , migrationTarget = Nothing+  }++data Parameter+  = InitiateMigration MigrationTarget+  -- ^ Token admin calls this entrypoint and provides a lambda to forge+  -- V2.MigrateFrom operation.+  | MigrateMyTokens Natural+  -- ^ Users are supposed to call this entrypoint if they want to upgrade+  -- their tokens.+  | GetBalance (View Address Natural)+  -- ^ Returns the balance of a holder.+  deriving stock Generic+  deriving anyclass IsoValue++instance ParameterHasEntrypoints Parameter where+  type ParameterEntrypointsDerivation Parameter = EpdPlain++type instance ErrorArg "userUpgradable'notEnoughTokens" = ()++instance CustomErrorHasDoc "userUpgradable'notEnoughTokens" where+  customErrClass = ErrClassActionException+  customErrDocMdCause = "Not enough tokens."++userUpgradeableContract :: Contract Parameter Storage+userUpgradeableContract = defaultContract $ do+  unpair+  caseT @Parameter+    ( #cInitiateMigration /-> initiateMigration+    , #cMigrateMyTokens /-> do dup; dip burnFromSender; callMigrationTarget+    , #cGetBalance /-> view_ $ do+        dip (toField #ledger); get; ifSome nop (push 0)+    )++-- | Burns tokens from the sender+burnFromSender :: '[Natural, Storage] :-> '[Storage]+burnFromSender = do+  dip $ do+    getField #ledger+    sender+    get+    ifSome nop $ failCustom_ #userUpgradable'notEnoughTokens+  swap+  stackType @('[Natural, Natural, Storage])+  sub+  isNat+  ifSome nop $ failCustom_ #userUpgradable'notEnoughTokens+  dup; push @Natural 0+  if IsEq+  then drop # none+  else some+  stackType @('[Maybe Natural, Storage])+  dip (getField #ledger);+  sender; update; setField #ledger
+ src/Lorentz/Contracts/UserUpgradeable/V2.hs view
@@ -0,0 +1,94 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-orphans #-}++-- | The second version of a minimal user-upgradeable ledger. This version+-- is not designed to be upgraded further — it lacks InitiateMigration and+-- MigrateMyTokens entrypoints. However, it has MigrateFrom (callable from V1),+-- and mints new tokens when a user calls V1.MigrateMyTokens. Other functions+-- (either upgradeability-related or standard Transfer/GetTotalSupply may be+-- added if deemed desirable).+--+-- Note that the naming in this module is different from+-- Lorentz.Contracts.Upgradeable: by "migration" here we mean the process+-- of transferring the value from an old contract to the new one rather than+-- applying a transformation to storage. Thus, MigrationScript here is a lambda+-- that forges an operation to migrate user's funds rather than a function+-- that upgrades storage in-place.++module Lorentz.Contracts.UserUpgradeable.V2+  ( Parameter(..)+  , Storage(..)+  , mkStorage+  , userUpgradeableContract+  ) where++import Lorentz++import Lorentz.Contracts.UserUpgradeable.Migrations (MigrationTarget)+import qualified Lorentz.Contracts.UserUpgradeable.V1 as V1++data Storage = Storage+  { ledger :: Map Address Natural+    -- ^ We use a Map instead of a BigMap to simplify the implementation a bit.+  , previousVersion :: Maybe (TAddress V1.Parameter)+  , migrationTarget :: Maybe MigrationTarget+  }+  deriving stock Generic+  deriving anyclass (IsoValue, HasAnnotation)++type instance ErrorArg "userUpgradable'unauthorizedMigrateFrom" = ()++instance CustomErrorHasDoc "userUpgradable'unauthorizedMigrateFrom" where+  customErrClass = ErrClassActionException+  customErrDocMdCause = "Unauthorized call is performed."++mkStorage :: TAddress V1.Parameter -> Storage+mkStorage prevVersion = Storage+  { ledger = mempty+  , previousVersion = Just prevVersion+  , migrationTarget = Nothing+  }++data Parameter+  = MigrateFrom (Address, Natural)+  -- ^ When called by V1, mints new tokens to Address+  | GetBalance (View Address Natural)+  -- ^ Returns the balance of a holder.+  deriving stock Generic+  deriving anyclass IsoValue++instance ParameterHasEntrypoints Parameter where+  type ParameterEntrypointsDerivation Parameter = EpdPlain++userUpgradeableContract :: Contract Parameter Storage+userUpgradeableContract = defaultContract $ do+  unpair+  caseT @Parameter+    ( #cMigrateFrom /-> checkedCoerce_ # migrateFrom+    , #cGetBalance /-> view_ $ do+        dip (toField #ledger); get; ifSome nop (push 0)+    )++-- | Mints new tokens to Address if called by V1+migrateFrom :: '[(Address, Natural), Storage] :-> '[([Operation], Storage)]+migrateFrom = do+  dip ensurePrevVersion+  dip $ getField #ledger+  unpair; swap+  dip $ do+    dup+    dip $ do dip dup; get; ifSome nop (push @Natural 0)+    swap+  stackType @('[Natural, Natural, Address, Map Address Natural, Storage])+  add; some; swap; update+  setField #ledger+  nil; pair+  where+    ensurePrevVersion :: '[Storage] :-> '[Storage]+    ensurePrevVersion = do+      getField #previousVersion; checkedCoerce_+      ifSome (sender # eq) (push False)+      if_ nop $ failCustom_ #userUpgradable'unauthorizedMigrateFrom
+ src/Lorentz/UStore.hs view
@@ -0,0 +1,107 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{- | This module contains implementation of 'UStore'.++@UStore@ is essentially+  @forall store field type. Lorentz.StoreClass.StoreHasField store field type@+modified for the sake of upgradeability.++In API it differs from @Store@ in the following ways:+1. It keeps both virtual @big_map@s and plain fields;+2. Neat conversion between Michelson and Haskell values+is implemented;+3. Regarding composabililty, one can operate with one @UStore@+and then lift it to a bigger one which includes the former.+This allows for simpler management of stores and clearer error messages.+In spite of this, operations with 'UStore's over deeply nested templates will+still work as before.++We represent 'UStore' as @big_map bytes bytes@.++* Plain fields are stored as+@key = pack fieldName; value = pack originalValue@.++* Virtual @big_map@s are kept as+@key = pack (bigMapName, originalKey); value = pack originalValue@.++-}+module Lorentz.UStore+  ( -- * UStore and related type definitions+    UStore+  , type (|~>)(..)+  , UStoreFieldExt (..)+  , UStoreField+  , UStoreMarkerType+  , KnownUStoreMarker (..)++    -- ** Type-lookup-by-name+  , GetUStoreKey+  , GetUStoreValue+  , GetUStoreField+  , GetUStoreFieldMarker++    -- ** Instructions+  , ustoreMem+  , ustoreGet+  , ustoreUpdate+  , ustoreInsert+  , ustoreInsertNew+  , ustoreDelete++  , ustoreToField+  , ustoreGetField+  , ustoreSetField++    -- ** Instruction constraints+  , HasUStore+  , HasUField+  , HasUStoreForAllIn++    -- * UStore composability+  , liftUStore+  , unliftUStore++    -- * Documentation+  , UStoreTemplateHasDoc (..)+  , UStoreMarkerHasDoc (..)++    -- * UStore management from Haskell+  , mkUStore+  , ustoreDecompose+  , ustoreDecomposeFull+  , fillUStore+  , MkUStoreTW+  , DecomposeUStoreTW+  , FillUStoreTW++    -- * Migrations+  , MigrationScript (..)+  , MigrationScript_+  , UStoreMigration+  , migrationToScript+  , migrationToScriptI+  , migrationToLambda+  , mkUStoreMigration+  , mustoreToOld+  , migrateGetField+  , migrateAddField+  , migrateRemoveField+  , migrateExtractField+  , migrateOverwriteField+  , migrateModifyField++    -- * Extras+  , PickMarkedFields+  , UStoreTraversable+  ) where++import Lorentz.UStore.Types+import Lorentz.UStore.Instr+import Lorentz.UStore.Traversal+import Lorentz.UStore.Instances ()+import Lorentz.UStore.Haskell+import Lorentz.UStore.Doc+import Lorentz.UStore.Lift+import Lorentz.UStore.Migration
+ src/Lorentz/UStore/Doc.hs view
@@ -0,0 +1,240 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# LANGUAGE NoRebindableSyntax #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Autodoc for UStore.+module Lorentz.UStore.Doc+  ( UStoreTemplateHasDoc (..)+  , UStoreMarkerHasDoc (..)+  , DUStoreTemplate (..)+  , dUStoreTemplateRef+  , DocumentTW+  ) where++import Prelude++import Data.Constraint (Dict(..))+import Fmt (build)+import Lorentz.Doc+import Lorentz.UStore.Traversal+import Lorentz.UStore.Types+import Michelson.Typed.Haskell.Doc+import Util.Generic+import Util.Label+import Util.Markdown+import Util.Typeable+import Util.TypeLits++-- | Information for UStore template required for documentation.+--+-- You only need to instantiate this for templates used directly in+-- UStore, nested subtemplates do not need this instance.+class Typeable template => UStoreTemplateHasDoc template where+  -- | UStore template name as it appears in documentation.+  --+  -- Should be only 1 word.+  ustoreTemplateDocName :: Text+  default ustoreTemplateDocName+    :: (Generic template, KnownSymbol (GenericTypeName template))+    => Text+  ustoreTemplateDocName = symbolValT' @(GenericTypeName template)+    where _needGeneric = Dict @(Generic template)++  -- | Description of template.+  ustoreTemplateDocDescription :: Markdown++  -- | Description of template entries.+  ustoreTemplateDocContents :: Markdown+  default ustoreTemplateDocContents+    :: (UStoreTraversable DocumentTW template) => Markdown+  ustoreTemplateDocContents =+    "\n" <> documentUStore (Proxy @template)++  ustoreTemplateDocDependencies :: [SomeTypeWithDoc]+  default ustoreTemplateDocDependencies+    :: (UStoreTraversable DocumentTW template) => [SomeTypeWithDoc]+  ustoreTemplateDocDependencies =+    gatherUStoreDeps (Proxy @template)++-- | Instantiated for documented UStore markers.+class (KnownUStoreMarker marker) =>+      UStoreMarkerHasDoc (marker :: UStoreMarkerType) where++  -- | Specifies key encoding.+  --+  -- You accept description of field name, and should return how is it encoded+  -- as key of @big_map bytes bytes@.+  ustoreMarkerKeyEncoding :: Text -> Text++instance UStoreTemplateHasDoc template =>+         TypeHasDoc (UStore template) where+  typeDocName _ = "Upgradeable storage"+  typeDocMdDescription = [md|+    Storage with not hardcoded structure, which allows upgrading the contract+    in place. UStore is capable of storing simple fields and multiple submaps.+    |]+  typeDocMdReference tp wp =+    applyWithinParens wp $ mconcat+      [ mdLocalRef (mdTicked "UStore") (docItemRef (DType tp))+      , " "+      , dUStoreTemplateRef (DUStoreTemplate (Proxy @template))+      ]+  typeDocHaskellRep = homomorphicTypeDocHaskellRep+  typeDocMichelsonRep = homomorphicTypeDocMichelsonRep+  typeDocDependencies p =+    genericTypeDocDependencies p <>+    [SomeDocDefinitionItem (DUStoreTemplate $ Proxy @template)]++data DUStoreTemplate where+  DUStoreTemplate+    :: UStoreTemplateHasDoc template+    => Proxy template -> DUStoreTemplate++instance Eq DUStoreTemplate where+  DUStoreTemplate p1 == DUStoreTemplate p2 = eqParam1 p1 p2+instance Ord DUStoreTemplate where+  DUStoreTemplate p1 `compare` DUStoreTemplate p2 = compareExt p1 p2++instance DocItem DUStoreTemplate where+  type DocItemPlacement DUStoreTemplate = 'DocItemInDefinitions+  type DocItemReferenced DUStoreTemplate = 'True++  docItemPos = 12700+  docItemSectionName = Just "Used upgradeable storage formats"+  docItemSectionDescription = Just+    "This section describes formats (aka _templates_) of upgradeable storages \+    \mentioned across the given document. \+    \Each format describes set of fields and virtual submaps which the storage \+    \must have."++  docItemToMarkdown lvl (DUStoreTemplate (_ :: Proxy template)) =+    mconcat+    [ mdSeparator+    , mdHeader lvl (mdTicked . build $ ustoreTemplateDocName @template)+    , ustoreTemplateDocDescription @template+    , "\n\n"+    , mdSubsection "Contents" $ ustoreTemplateDocContents @template+    , "\n\n"+    ]++  docItemRef (DUStoreTemplate (_ :: Proxy template)) =+    DocItemRef . DocItemId $+      "ustore-template-" <> ustoreTemplateDocName @template++  docItemDependencies (DUStoreTemplate (_ :: Proxy template)) =+    ustoreTemplateDocDependencies @template <&>+      \(SomeTypeWithDoc t) -> SomeDocDefinitionItem (DType t)++-- | Make a reference to given UStore template description.+dUStoreTemplateRef :: DUStoreTemplate -> Markdown+dUStoreTemplateRef (DUStoreTemplate (_ :: Proxy template)) =+  mdLocalRef (mdTicked . build $ ustoreTemplateDocName @template)+             (docItemRef (DUStoreTemplate (Proxy @template)))++-- Instances+----------------------------------------------------------------------------++instance UStoreTemplateHasDoc () where+  ustoreTemplateDocName = "empty"+  ustoreTemplateDocDescription = ""+  ustoreTemplateDocContents =+    mdItalic "empty"++instance UStoreMarkerHasDoc UMarkerPlainField where+  ustoreMarkerKeyEncoding k = "pack (" <> k <> ")"++-- Internals+----------------------------------------------------------------------------++documentUStore+  :: forall template.+     (UStoreTraversable DocumentTW template)+  => Proxy template -> Markdown+documentUStore _ =+  let Const collected = traverseUStore @_ @template DocumentTW (Const ())+      entries = appEndo (dcEntries collected) []+  in if null entries+     then mdTicked "<empty>"+     else mconcat $ map (\e -> "* " <> e <> "\n") entries++gatherUStoreDeps+  :: forall template.+     (UStoreTraversable DocumentTW template)+  => Proxy template -> [SomeTypeWithDoc]+gatherUStoreDeps _ =+  let Const collected = traverseUStore @_ @template DocumentTW (Const ())+  in appEndo (dcDependencies collected) []++data DocCollector = DocCollector+  { dcEntries :: Endo [Markdown]+  , dcDependencies :: Endo [SomeTypeWithDoc]+  }++data DocumentTW = DocumentTW++instance Semigroup DocCollector where+  DocCollector e1 d1 <> DocCollector e2 d2 = DocCollector (e1 <> e2) (d1 <> d2)+instance Monoid DocCollector where+  mempty = DocCollector mempty mempty++instance UStoreTraversalWay DocumentTW where+  type UStoreTraversalArgumentWrapper DocumentTW = Const ()+  type UStoreTraversalMonad DocumentTW = Const DocCollector++instance (UStoreMarkerHasDoc marker, TypeHasDoc v) =>+         UStoreTraversalFieldHandler DocumentTW marker v where+  ustoreTraversalFieldHandler DocumentTW fieldName (Const ()) =+    Const DocCollector+    { dcEntries = Endo . (:) $ mconcat+        [ mdBold "Field" <> " "+        , mdTicked (build $ labelToText fieldName)+        , ": "+        , typeDocMdReference (Proxy @v) (WithinParens False)+        , "\n"++        , mdSpoiler "Encoding" $ mconcat+          [ "\n"+          , let key = build $+                  ustoreMarkerKeyEncoding @marker+                  ("\"" <> labelToText fieldName <> "\"")+            in+            "  + " <> mdTicked ("key = " <> key) <> "\n\n"+          , "  + " <> mdTicked "value = pack (<field value>)" <> "\n\n"+          , mdSeparator+          ]+        , "\n"+        ]+    , dcDependencies = Endo . (<>) $+        [ SomeTypeWithDoc (Proxy @v)+        ]+    }++instance (TypeHasDoc k, TypeHasDoc v) =>+         UStoreTraversalSubmapHandler DocumentTW k v where+  ustoreTraversalSubmapHandler DocumentTW fieldName (Const ()) =+    Const DocCollector+    { dcEntries = Endo . (:) $ mconcat+        [ mdBold "Submap" <> " "+        , mdTicked (build $ labelToText fieldName)+        , ": "+        , typeDocMdReference (Proxy @k) (WithinParens False)+        , " -> "+        , typeDocMdReference (Proxy @v) (WithinParens False)+        , "\n"++        , mdSpoiler "Encoding" $ mconcat+          [ "\n"+          , " + " <> mdTicked "key = pack (<submap key>)" <> "\n\n"+          , " + " <> mdTicked "value = pack (<submap value>)" <> "\n\n"+          , mdSeparator+          ]+        , "\n"+        ]+    , dcDependencies = Endo . (<>) $+        [ SomeTypeWithDoc (Proxy @k)+        , SomeTypeWithDoc (Proxy @v)+        ]+    }
+ src/Lorentz/UStore/Haskell.hs view
@@ -0,0 +1,310 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Conversion between 'UStore' in Haskell and Michelson representation.+module Lorentz.UStore.Haskell+  ( mkUStore+  , MkUStoreTW+  , ustoreDecompose+  , ustoreDecomposeFull+  , DecomposeUStoreTW+  , fillUStore+  , migrateFillUStore+  , fillUStoreMigrationBlock+  , FillUStoreTW+  ) where++import Prelude+import qualified Unsafe++import Control.Monad.Except (runExcept, throwError)+import qualified Data.List as L+import qualified Data.Map as Map+import Data.Singletons (demote)+import Fcf (type (=<<), Eval, Pure2)+import qualified Fcf+import Fmt ((+|), (+||), (|+), (||+))++import Lorentz.Base+import Lorentz.Coercions+import Lorentz.Constraints+import qualified Lorentz.Instr as L+import Lorentz.Pack+import Lorentz.UStore.Migration+import Lorentz.UStore.Migration.Diff+import Lorentz.UStore.Traversal+import Lorentz.UStore.Types+import Michelson.Text+import Michelson.Typed.Haskell.Value+import Util.Type++-- | 'UStore' content represented as key-value pairs.+type UStoreContent = [(ByteString, ByteString)]++-- | Make 'UStore' from separate @big_map@s and fields.+mkUStore+  :: (UStoreTraversable MkUStoreTW template)+  => template -> UStore template+mkUStore = UStore . BigMap . mkUStoreInternal++-- | Decompose 'UStore' into separate @big_map@s and fields.+--+-- Along with resulting value, you get a list of @UStore@ entries which+-- were not recognized as belonging to any submap or field according to+-- @UStore@'s template - this should be empty unless @UStore@ invariants+-- were violated.+ustoreDecompose+  :: forall template.+     (UStoreTraversable DecomposeUStoreTW template)+  => UStore template -> Either Text (UStoreContent, template)+ustoreDecompose = storeDecomposeInternal . Map.toList . unBigMap . unUStore++-- | Like 'ustoreDecompose', but requires all entries from @UStore@ to be+-- recognized.+ustoreDecomposeFull+  :: forall template.+     (UStoreTraversable DecomposeUStoreTW template)+  => UStore template -> Either Text template+ustoreDecomposeFull ustore = do+  (remained, res) <- ustoreDecompose ustore+  unless (null remained) $+    Left $ "Unrecognized entries in UStore: " +|| remained ||+ ""+  return res++-- | Make migration script which initializes 'UStore' from scratch.+fillUStore+  :: (UStoreTraversable FillUStoreTW template)+  => template -> UStoreMigration () template+fillUStore v = UStoreMigration $ fillUStoreInternal v++-- | Version of 'migrateFillUStore' for batched migrations.+--+-- Each field write will be placed to a separate batch.+fillUStoreMigrationBlock+  :: ( UStoreTraversable FillUStoreTW template+     , allFieldsExp ~ AllUStoreFieldsF template+     , newDiff ~ FillingNewDiff template diff+     , newTouched ~ FillingNewTouched template touched+     , PatternMatchL newDiff, PatternMatchL newTouched+     )+  => template+  -> MigrationBlocks oldTempl newTempl diff touched newDiff newTouched+fillUStoreMigrationBlock v = MigrationBlocks $ fillUStoreInternal v++-- | Fill 'UStore' with entries from the given template as part of simple+-- migration.+--+-- Sometimes you already have some fields initialized and 'fillUStore' does not+-- suit, then in case if your UStore template is a nested structure you can use+-- sub-templates to initialize the corresponding parts of UStore.+--+-- For batched migrations see 'fillUStoreMigrationBlock'.+migrateFillUStore+  :: ( UStoreTraversable FillUStoreTW template+     , allFieldsExp ~ AllUStoreFieldsF template+     , newDiff ~ FillingNewDiff template diff+     , newTouched ~ FillingNewTouched template touched+     , PatternMatchL newDiff, PatternMatchL newTouched+     )+  => template+  -> Lambda+       (MUStore oldTempl newTempl diff touched)+       (MUStore oldTempl newTempl newDiff newTouched)+migrateFillUStore v =+  let atoms = fillUStoreInternal v+      script = foldMap (unMigrationScript . maScript) atoms+  in forcedCoerce_ # script # forcedCoerce_++type FillingNewDiff template diff =+  CoverDiffMany diff+    (Eval (Fcf.Map (Pure2 '(,) 'DcAdd) =<< LinearizeUStoreF template))++type FillingNewTouched template touched =+  Eval (AllUStoreFieldsF template) ++ touched++-- Implementation+----------------------------------------------------------------------------++-- | Internal helper for 'mkUStore'.+mkUStoreInternal+  :: (UStoreTraversable MkUStoreTW template)+  => template -> Map ByteString ByteString+mkUStoreInternal = foldUStore MkUStoreTW++-- | Internal helper for 'ustoreDecompose'.+storeDecomposeInternal+  :: forall template.+     (UStoreTraversable DecomposeUStoreTW template)+  => UStoreContent -> Either Text (UStoreContent, template)+storeDecomposeInternal =+  runExcept . fmap swap . runStateT (genUStore DecomposeUStoreTW)++-- | Internal helper for 'fillUStore'.+fillUStoreInternal+  :: (UStoreTraversable FillUStoreTW template)+  => template+  -> [MigrationAtom]+fillUStoreInternal a = appEndo (foldUStore FillUStoreTW a) []++-- | Declares handlers for UStore creation from template.+data MkUStoreTW = MkUStoreTW++instance UStoreTraversalWay MkUStoreTW where+  type UStoreTraversalArgumentWrapper MkUStoreTW = Identity+  type UStoreTraversalMonad MkUStoreTW = Const (Map ByteString ByteString)++instance (NicePackedValue val) =>+         UStoreTraversalFieldHandler MkUStoreTW marker val where+  ustoreTraversalFieldHandler MkUStoreTW fieldName (Identity val) =+    Const $+    one ( mkFieldMarkerUKeyL @marker fieldName+        , lPackValueRaw val+        )++instance (NicePackedValue k, NicePackedValue v) =>+         UStoreTraversalSubmapHandler MkUStoreTW k v where+  ustoreTraversalSubmapHandler MkUStoreTW fieldName (Identity m) =+    Const $+    mconcat+      [ one ( lPackValueRaw (labelToMText fieldName, k)+            , lPackValueRaw v+            )+      | (k, v) <- Map.toList m+      ]++-- | Declares handlers for UStore conversion to template.+data DecomposeUStoreTW = DecomposeUStoreTW++instance UStoreTraversalWay DecomposeUStoreTW where+  type UStoreTraversalArgumentWrapper DecomposeUStoreTW = Const ()+  type UStoreTraversalMonad DecomposeUStoreTW =+    StateT UStoreContent (ExceptT Text Identity)++instance (NiceUnpackedValue val) =>+         UStoreTraversalFieldHandler DecomposeUStoreTW marker val where+  ustoreTraversalFieldHandler DecomposeUStoreTW fieldName (Const ()) = do+    let expectedKey = mkFieldMarkerUKey @marker (labelToMText fieldName)+    allMatched <- mapMaybesState $ \(key, value) -> do+      unless (key == expectedKey) mzero+      case lUnpackValueRaw value of+        Left err -> throwError $+          "Failed to parse UStore value for field " +|+          demote @(ToT val) |+ ": " +| err |+ ""+        Right valValue ->+          pure valValue+    case allMatched of+        [] -> throwError $+          "Failed to find field in UStore: " +| labelToMText fieldName |+ ""+        [matched] ->+          pure matched+        (_ : _ : _) ->+          error "UStore content contained multiple entries with the same key"++instance (Ord k, NiceUnpackedValue k, NiceUnpackedValue v) =>+         UStoreTraversalSubmapHandler DecomposeUStoreTW k v where+  ustoreTraversalSubmapHandler _ fieldName (Const ()) =+    fmap Map.fromList $+    mapMaybesState $ \(key, value) ->+      case lUnpackValueRaw @(UStoreSubmapKey k) key of+        Left _ -> mzero+        Right (name :: MText, keyValue :: k)+          | name /= labelToMText fieldName ->+              mzero+          | otherwise ->+            case lUnpackValueRaw value of+              Left err -> throwError $+                "Failed to parse UStore value for " +|+                demote @(ToT k) |+ " |~> " +| demote @(ToT v) |++                ": " +| err |+ ""+              Right valValue ->+                pure (keyValue, valValue)++-- | Declares handlers for UStore filling via lambda.+data FillUStoreTW = FillUStoreTW++instance UStoreTraversalWay FillUStoreTW where+  type UStoreTraversalArgumentWrapper FillUStoreTW = Identity+  type UStoreTraversalMonad FillUStoreTW = Const (Endo [MigrationAtom])++instance (NiceConstant v) =>+         UStoreTraversalFieldHandler FillUStoreTW marker v where+  ustoreTraversalFieldHandler FillUStoreTW fieldName (Identity val) =+    Const $+    Endo . (:) . formMigrationAtom Nothing $+      attachMigrationActionName (DAddAction "init field") fieldName (Proxy @v) #+      -- Not pushing already packed value (which would be more efficient) because+      -- analyzers cannot work with packed values.+      -- TODO: make optimizer compress this to @push (Just $ lPackValueRaw val)@+      L.push val # L.packRaw # L.some #++      L.push (mkFieldMarkerUKeyL @marker fieldName) #+      L.update++instance (NiceConstant k, NiceConstant v) =>+         UStoreTraversalSubmapHandler FillUStoreTW k v where+  ustoreTraversalSubmapHandler _ fieldName (Identity m) =+    Const $+    Endo . (<>) $+    Map.toList m <&> \(k, v) ->+    formMigrationAtom Nothing $+      attachMigrationActionName (DAddAction "init submap") fieldName (Proxy @v) #+      -- @PUSH + PACK@ will be merged by optimizer, but there is still place+      -- for further improvement both for value and key pushing.+      -- We cannot push already packed value because that would break code+      -- analyzers and transformers, consider adding necessary rules to+      -- optimizer.+      -- TODO [TM-379]: consider improving this case+      -- or+      -- TODO: add necessary rules to optimizer+      L.push v # L.packRaw # L.some #+      L.push k # L.push (labelToMText fieldName) # L.pair #+      L.packRaw @(UStoreSubmapKey _) #+      L.update++-- | Tries to map all items in the state and returns those which were mapped+-- successfully; others are retained in the state.+mapMaybesState :: forall a b m. MonadState [a] m => (a -> MaybeT m b) -> m [b]+mapMaybesState mapper =+  get >>= \st -> do+    mapped <- mapM (\a -> (a, ) <$> runMaybeT (mapper a)) st+    let+      (passed, failed) =+        bimap (map (Unsafe.fromJust . snd)) (map fst) $+        L.partition @(a, Maybe b) (isJust . snd) $+        mapped+    put failed+    return passed++-- Examples+----------------------------------------------------------------------------++data MyStoreTemplate = MyStoreTemplate+  { ints :: Integer |~> ()+  , flag :: UStoreField Bool+  }+  deriving stock (Generic)++data MyStoreTemplateBig = MyStoreTemplateBig+  { templ :: MyStoreTemplate+  , bytes :: ByteString |~> ByteString+  }+  deriving stock (Generic)++_storeSample :: UStore MyStoreTemplate+_storeSample = mkUStore+  MyStoreTemplate+  { ints = UStoreSubMap $ one (1, ())+  , flag = UStoreField False+  }++_storeSampleBig :: UStore MyStoreTemplateBig+_storeSampleBig = mkUStore $+  MyStoreTemplateBig+    MyStoreTemplate+      { ints = UStoreSubMap $ one (1, ())+      , flag = UStoreField False+      }+    (UStoreSubMap $ one ("a", "b"))
+ src/Lorentz/UStore/Instances.hs view
@@ -0,0 +1,45 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-orphans #-}++module Lorentz.UStore.Instances+  ( ustoreFieldOps+  , ustoreSubmapOps+  ) where++import Prelude ((.))++import Lorentz.StoreClass+import Lorentz.UStore.Instr+import Lorentz.UStore.Types++ustoreFieldOps+  :: HasUField fname ftype templ+  => StoreFieldOps (UStore templ) fname ftype+ustoreFieldOps =+  StoreFieldOps+  { sopToField = ustoreToField . fieldNameToLabel+  , sopSetField = ustoreSetField . fieldNameToLabel+  }++instance HasUField fname ftype templ =>+         StoreHasField (UStore templ) fname ftype where+  storeFieldOps = ustoreFieldOps++ustoreSubmapOps+  :: HasUStore mname key value templ+  => StoreSubmapOps (UStore templ) mname key value+ustoreSubmapOps = StoreSubmapOps+  { sopMem = ustoreMem . fieldNameToLabel+  , sopGet = ustoreGet . fieldNameToLabel+  , sopUpdate = ustoreUpdate . fieldNameToLabel+  , sopDelete = ustoreDelete . fieldNameToLabel+  , sopInsert = ustoreInsert . fieldNameToLabel+  }++instance {-# OVERLAPPING #-}+         HasUStore mname key value templ =>+         StoreHasSubmap (UStore templ) mname key value where+  storeSubmapOps = ustoreSubmapOps
+ src/Lorentz/UStore/Instr.hs view
@@ -0,0 +1,356 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Instructions to work with 'UStore'.+module Lorentz.UStore.Instr+  ( unsafeEmptyUStore+  , ustoreMem+  , ustoreGet+  , ustoreUpdate+  , ustoreInsert+  , ustoreInsertNew+  , ustoreDelete++  , ustoreToField+  , ustoreGetField+  , ustoreSetField+  , ustoreRemoveFieldUnsafe++    -- ** Instruction constraints+  , HasUStore+  , HasUField+  , HasUStoreForAllIn++    -- ** Internals+  , packSubMapUKey+  ) where++import Prelude++import qualified Data.Kind as Kind+import GHC.Generics ((:*:), (:+:))+import qualified GHC.Generics as G+import GHC.TypeLits (KnownSymbol, Symbol)+import Type.Reflection ((:~:)(Refl))++import Lorentz.Base+import Lorentz.Coercions (coerceWrap)+import Lorentz.Constraints+import Lorentz.Errors+import Lorentz.Instr as L+import Lorentz.Macro+import Lorentz.UStore.Types+import Michelson.Text+import Michelson.Typed.Haskell.Value+import Util.Label (Label)++-- Helpers+----------------------------------------------------------------------------++type KeyAccessC store name =+  ( NiceFullPackedValue (GetUStoreKey store name)+  , KnownSymbol name+  )++type ValueAccessC store name =+  ( NiceFullPackedValue (GetUStoreValue store name)+  , KnownSymbol name+  )++type FieldAccessC store name =+  ( NiceFullPackedValue (GetUStoreField store name)+  , KnownUStoreMarker (GetUStoreFieldMarker store name)+  , KnownSymbol name+  )++packSubMapUKey+  :: forall (field :: Symbol) k s.+     (KnownSymbol field, NicePackedValue k)+  => (k : s) :-> (ByteString : s)+packSubMapUKey = push submapName # pair # packRaw @(UStoreSubmapKey _)+  where+    submapName = symbolToMText @field++unpackUValueUnsafe+  :: forall (field :: Symbol) val s.+     (KnownSymbol field, NiceUnpackedValue val)+  => (ByteString : s) :-> (val : s)+unpackUValueUnsafe = unpackRaw @val # ifSome nop (failUsing failErr)+  where+    failErr = mconcat+      [ [mt|UStore: failed to unpack |]+      , symbolToMText @field+      ]++-- Main instructions+----------------------------------------------------------------------------++-- | Put an empty 'UStore' onto the stack. This function is generally unsafe:+-- if store template contains a 'UStoreField', the resulting 'UStore' is not+-- immediately usable.+-- If you are sure that 'UStore' contains only submaps, feel free to just use+-- the result of this function. Otherwise you must set all fields.+unsafeEmptyUStore :: forall store s. s :-> UStore store ': s+unsafeEmptyUStore = emptyBigMap # coerceWrap++ustoreMem+  :: forall store name s.+     (KeyAccessC store name)+  => Label name+  -> GetUStoreKey store name : UStore store : s :-> Bool : s+ustoreMem _ = packSubMapUKey @name # mem++ustoreGet+  :: forall store name s.+     (KeyAccessC store name, ValueAccessC store name)+  => Label name+  -> GetUStoreKey store name : UStore store : s+       :-> Maybe (GetUStoreValue store name) : s+ustoreGet _ =+  packSubMapUKey @name #+  L.get #+  lmap (unpackUValueUnsafe @name @(GetUStoreValue store name))++ustoreUpdate+  :: forall store name s.+     (KeyAccessC store name, ValueAccessC store name)+  => Label name+  -> GetUStoreKey store name+      : Maybe (GetUStoreValue store name)+      : UStore store+      : s+  :-> UStore store : s+ustoreUpdate _ =+  packSubMapUKey @name #+  dip (lmap packRaw) #+  update++ustoreInsert+  :: forall store name s.+     (KeyAccessC store name, ValueAccessC store name)+  => Label name+  -> GetUStoreKey store name+      : GetUStoreValue store name+      : UStore store+      : s+  :-> UStore store : s+ustoreInsert _ =+  packSubMapUKey @name #+  dip (packRaw # L.some) #+  update++-- | Insert a key-value pair, but fail if it will overwrite some existing entry.+ustoreInsertNew+  :: forall store name s.+     (KeyAccessC store name, ValueAccessC store name)+  => Label name+  -> (forall s0 any. GetUStoreKey store name : s0 :-> any)+  -> GetUStoreKey store name+      : GetUStoreValue store name+      : UStore store+      : s+  :-> UStore store : s+ustoreInsertNew label doFail =+  duupX @3 # duupX @2 # ustoreMem label #+  if_ doFail (ustoreInsert label)++ustoreDelete+  :: forall store name s.+     (KeyAccessC store name)+  => Label name+  -> GetUStoreKey store name : UStore store : s+     :-> UStore store : s+ustoreDelete _ =+  packSubMapUKey @name #+  dip none #+  update++-- | Like 'toField', but for 'UStore'.+--+-- This may fail only if 'UStore' was made up incorrectly during contract+-- initialization.+ustoreToField+  :: forall store name s.+     (FieldAccessC store name)+  => Label name+  -> UStore store : s+     :-> GetUStoreField store name : s+ustoreToField l =+  push (mkFieldUKey @store l) #+  L.get #+  ensureFieldIsPresent #+  unpackUValueUnsafe @name @(GetUStoreField store name)+  where+    ensureFieldIsPresent =+      ifSome nop $ failUsing $ mconcat+        [ [mt|UStore: no field |]+        , symbolToMText @name+        ]++-- | Like 'getField', but for 'UStore'.+--+-- This may fail only if 'UStore' was made up incorrectly during contract+-- initialization.+ustoreGetField+  :: forall store name s.+     (FieldAccessC store name)+  => Label name+  -> UStore store : s+     :-> GetUStoreField store name : UStore store : s+ustoreGetField label = dup # ustoreToField label++-- | Like 'setField', but for 'UStore'.+ustoreSetField+  :: forall store name s.+     (FieldAccessC store name)+  => Label name+  -> GetUStoreField store name : UStore store : s+     :-> UStore store : s+ustoreSetField l =+  packRaw # L.some #+  push (mkFieldUKey @store l) #+  L.update++-- | Remove a field from 'UStore', for internal purposes only.+ustoreRemoveFieldUnsafe+  :: forall store name s.+     (FieldAccessC store name)+  => Label name+  -> UStore store : s+     :-> UStore store : s+ustoreRemoveFieldUnsafe l =+  L.none #+  push (mkFieldUKey @store l) #+  L.update++-- | This constraint can be used if a function needs to work with+-- /big/ store, but needs to know only about some submap(s) of it.+--+-- It can use all UStore operations for a particular name, key and+-- value without knowing whole template.+type HasUStore name key value store =+   ( KeyAccessC store name, ValueAccessC store name+   , GetUStoreKey store name ~ key+   , GetUStoreValue store name ~ value+   )++-- | This constraint can be used if a function needs to work with+-- /big/ store, but needs to know only about some field of it.+type HasUField name ty store =+   ( FieldAccessC store name+   , GetUStoreField store name ~ ty+   )++-- | Write down all sensisble constraints which given @store@ satisfies+-- and apply them to @constrained@.+--+-- This store should have '|~>' and 'UStoreField' fields in its immediate fields,+-- no deep inspection is performed.+type HasUStoreForAllIn store constrained =+  (Generic store, GHasStoreForAllIn constrained (G.Rep store))++type family GHasStoreForAllIn (store :: Kind.Type) (x :: Kind.Type -> Kind.Type)+            :: Constraint where+  GHasStoreForAllIn store (G.D1 _ x) = GHasStoreForAllIn store x+  GHasStoreForAllIn store (x :+: y) =+    (GHasStoreForAllIn store x, GHasStoreForAllIn store y)+  GHasStoreForAllIn store (x :*: y) =+    (GHasStoreForAllIn store x, GHasStoreForAllIn store y)+  GHasStoreForAllIn store (G.C1 _ x) = GHasStoreForAllIn store x+  GHasStoreForAllIn store (G.S1 ('G.MetaSel ('Just name) _ _ _)+                            (G.Rec0 (key |~> value))) =+    HasUStore name key value store+  GHasStoreForAllIn store (G.S1 ('G.MetaSel ('Just name) _ _ _)+                            (G.Rec0 (UStoreFieldExt _ value))) =+    HasUField name value store+  GHasStoreForAllIn _ G.V1 = ()+  GHasStoreForAllIn _ G.U1 = ()++----------------------------------------------------------------------------+-- Examples+----------------------------------------------------------------------------++data MyStoreTemplate = MyStoreTemplate+  { ints :: Integer |~> ()+  , bytes :: ByteString |~> ByteString+  , flag :: UStoreField Bool+  , entrypoint :: UStoreFieldExt Marker1 Integer+  }+  deriving stock (Generic)++type MyStore = UStore MyStoreTemplate++data Marker1 :: UStoreMarkerType+  deriving anyclass KnownUStoreMarker++_sample1 :: Integer : MyStore : s :-> MyStore : s+_sample1 = ustoreDelete @MyStoreTemplate #ints++_sample2 :: ByteString : ByteString : MyStore : s :-> MyStore : s+_sample2 = ustoreInsert @MyStoreTemplate #bytes++_sample3 :: MyStore : s :-> Bool : s+_sample3 = ustoreToField @MyStoreTemplate #flag++_sample3'5 :: MyStore : s :-> Integer : s+_sample3'5 = ustoreToField @MyStoreTemplate #entrypoint++data MyStoreTemplate2 = MyStoreTemplate2+  { bools :: Bool |~> Bool+  , ints2 :: Integer |~> Integer+  , ints3 :: Integer |~> Bool+  }+  deriving stock (Generic)++newtype MyNatural = MyNatural Natural+  deriving newtype (IsoValue)++data MyStoreTemplate3 = MyStoreTemplate3 { store3 :: Natural |~> MyNatural }+  deriving stock Generic++data MyStoreTemplateBig = MyStoreTemplateBig+  MyStoreTemplate+  MyStoreTemplate2+  MyStoreTemplate3+  deriving stock Generic++_MyStoreTemplateBigTextsStore ::+  GetUStore "bytes" MyStoreTemplateBig :~: 'MapSignature ByteString ByteString+_MyStoreTemplateBigTextsStore = Refl++_MyStoreTemplateBigBoolsStore ::+  GetUStore "bools" MyStoreTemplateBig :~: 'MapSignature Bool Bool+_MyStoreTemplateBigBoolsStore = Refl++_MyStoreTemplateBigMyStoreTemplate3 ::+  GetUStore "store3" MyStoreTemplateBig :~: 'MapSignature Natural MyNatural+_MyStoreTemplateBigMyStoreTemplate3 = Refl++type MyStoreBig = UStore MyStoreTemplateBig++_sample4 :: Integer : MyStoreBig : s :-> MyStoreBig : s+_sample4 = ustoreDelete #ints2++_sample5 :: ByteString : MyStoreBig : s :-> Bool : s+_sample5 = ustoreMem #bytes++_sample6 :: Natural : MyNatural : MyStoreBig : s :-> MyStoreBig : s+_sample6 = ustoreInsert #store3++-- | When you want to express a constraint like+-- "given big store contains all elements present in given small concrete store",+-- you can use 'HasUStoreForAllIn'.+--+-- Here @store@ is a big store, and we expect it to contain 'MyStoreTemplate'+-- entirely.+_sample7+  :: HasUStoreForAllIn MyStoreTemplate store+  => UStore store : s :-> Bool : Maybe ByteString : s+_sample7 = ustoreGetField #flag # dip (push "x" # ustoreGet #bytes)++-- | '_sample7' with @store@ instantiated to 'MyStoreTemplateBig'.+_sample7' :: UStore MyStoreTemplateBig : s :-> Bool : Maybe ByteString : s+_sample7' = _sample7
+ src/Lorentz/UStore/Lift.hs view
@@ -0,0 +1,115 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Composability helper for 'UStore'.+module Lorentz.UStore.Lift+  ( liftUStore+  , unliftUStore++    -- * Internals+  , UStoreFieldsAreUnique+  ) where++import Prelude++import qualified Data.Kind as Kind+import GHC.Generics (type (:+:), type (:*:))+import qualified GHC.Generics as G+import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError)++import Lorentz.Base+import Lorentz.Coercions+import Lorentz.Instr+import Lorentz.UStore.Types+import Michelson.Typed.Haskell+import Util.Label (Label)+import Util.Type++-- | Get all fields names accessible in given 'UStore' template.+type UStoreFields (template :: Kind.Type) = GUStoreFields (G.Rep template)++type family GUStoreFields (x :: Kind.Type -> Kind.Type) :: [Symbol] where+  -- We are not oblidged to fail in case of bad template - this will be handled+  -- in other operations with 'UStore' anyway.+  GUStoreFields (G.D1 _ x) = GUStoreFields x+  GUStoreFields (_ :+: _) = '[]+  GUStoreFields G.V1 = '[]+  GUStoreFields (G.C1 _ x) = GUStoreFields x+  GUStoreFields (x :*: y) = GUStoreFields x ++ GUStoreFields y+  GUStoreFields (G.S1 ('G.MetaSel ('Just fieldName) _ _ _) (G.Rec0 (_ |~> _))) =+    '[fieldName]+  GUStoreFields (G.S1 ('G.MetaSel ('Just fieldName) _ _ _) (G.Rec0 (UStoreFieldExt _ _))) =+    '[fieldName]+  GUStoreFields (G.S1 _ (G.Rec0 a)) =+    UStoreFields a++type UStoreFieldsAreUnique template = AllUnique (UStoreFields template)++type family RequireAllUniqueFields (template :: Kind.Type) :: Constraint where+  RequireAllUniqueFields template =+    If (UStoreFieldsAreUnique template)+       (() :: Constraint)+       (TypeError ('Text "Some field in template is duplicated"))+      -- TODO: if this ever fires for you and it's not clear which exact field+      -- is duplicated, please create a ticket to implement the corresponding+      -- logic.++-- | Lift an 'UStore' to another 'UStore' which contains all the entries+-- of the former under given field.+--+-- This function is not intended for use in migrations, only in normal+-- entry points.+--+-- Note that this function ensures that template of resulting store+-- does not contain inner nested templates with duplicated fields,+-- otherwise 'UStore' invariants could get broken.+liftUStore+  :: (Generic template, RequireAllUniqueFields template)+  => Label name+  -> UStore (GetFieldType template name) : s :-> UStore template : s+liftUStore _ = forcedCoerce_++-- | Unlift an 'UStore' to a smaller 'UStore' which is part of the former.+--+-- This function is not intended for use in migrations, only in normal+-- entry points.+--+-- Surprisingly, despite smaller 'UStore' may have extra entries,+-- this function is safe when used in contract code.+-- Truly, all getters and setters are still safe to use.+-- Also, there is no way for the resulting small @UStore@ to leak outside+-- of the contract since the only place where 'big_map' can appear+-- is contract storage, so this small @UStore@ can be either dropped+-- or lifted back via 'liftUStore' to appear as part of the new contract's state.+--+-- When this function is run as part of standalone instructions sequence,+-- not as part of contract code (e.g. in tests), you may get an @UStore@+-- with entries not inherent to it.+unliftUStore+  :: (Generic template)+  => Label name+  -> UStore template : s :-> UStore (GetFieldType template name) : s+unliftUStore _ = forcedCoerce_++-- Examples+----------------------------------------------------------------------------++data MyStoreTemplate = MyStoreTemplate+  { ints :: Integer |~> Integer+  } deriving stock Generic++data MyStoreTemplateBig = MyStoreTemplateBig+  { bool :: UStoreField Bool+  , substore :: MyStoreTemplate+  } deriving stock Generic++-- | This example demostrates a way to run an instruction, operating on small+-- 'UStore', so that it works on a larger 'UStore'.+_sampleWithMyStore+  :: ('[param, UStore MyStoreTemplate] :-> '[UStore MyStoreTemplate])+  -> ('[param, UStore MyStoreTemplateBig] :-> '[UStore MyStoreTemplateBig])+_sampleWithMyStore instr =+  dip (unliftUStore #substore) # instr # liftUStore #substore
+ src/Lorentz/UStore/Migration.hs view
@@ -0,0 +1,93 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{- | Type-safe migrations of UStore.++This implements imperative approach to migration when we make user+write a code of migration and track whether all new fields were indeed added+and all unnecessary fields were removed.++You can find migration examples in tests.++== How to write your simple migration++1. Start with migration template:++    @+    migration :: 'UStoreMigration' V1.Storage V2.Storage+    migration = 'mkUStoreMigration' $ do+      -- migration code to be put here+      'migrationFinish'+    @++    You will be prompted with a list of fields which should be added or removed.++2. Add/remove necessary fields using 'migrateAddField', 'migrateExtractField'+and other instructions.+They allow you to operate with 'MUStore' — it is similar to 'UStore'+but used within 'mkUStoreMigration' to track migration progress.++3. Use 'migrationToScript' or 'migrationToTestScript' to turn 'UStoreMigration'+into something useful.++Note that here you will get a solid 'MigrationScript', thus migration has+to fit into single Tezos transaction. If that's an issue, see the next section.++== How to write batched migration++1. Insert migration template.++    It looks like:++    @+    migration :: 'UStoreMigration' V1.Storage V2.Storage+    migration = 'mkUStoreBatchedMigration' $+      -- place for migration blocks+      'migrationFinish'+    @++2. Fill migration code with blocks like++    @+    'mkUStoreBatchedMigration' $+      'muBlock' '$:' do+        -- code for block 1+      '<-->'+      'muBlock' '$:' do+        -- code for block 2+      '<-->'+      'migrationFinish'+    @++    Migration blocks have to be the smallest actions which can safely be mixed+    and splitted across migration stages.++3. Compile migration with 'compileBatchedMigration'.++    Here you have to supply batching implementation. Alternatives include++    * 'mbNoBatching';+    * 'mbBatchesAsIs';+    * Functions from 'Lorentz.UStore.Migration.Batching' module.++4. Get the required information about migration.++    * 'migrationToScripts' picks the migration scripts, each has to be put+      in a separate Tezos transaction.++    * 'buildMigrationPlan' - dump description of each migration stage.++== Manual migrations++If for some reasons you need to define migration manually, you can use+functions from @Manual migrations@ section of "Lorentz.UStore.Migration.Base".++-}+module Lorentz.UStore.Migration+  ( module Exports+  ) where++import Lorentz.UStore.Migration.Base as Exports+import Lorentz.UStore.Migration.Batching as Exports+import Lorentz.UStore.Migration.Blocks as Exports
+ src/Lorentz/UStore/Migration/Base.hs view
@@ -0,0 +1,530 @@+-- 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++    -- ** 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 Prelude++import Control.Lens (iso, 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.Annotation (HasAnnotation)+import Lorentz.Base+import Lorentz.Coercions+import Lorentz.Doc+import Lorentz.UStore.Doc+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 CastableUStoreTemplate template1 template2 =>+         UStore template1 `CanCastTo` UStore template2++type family CastableUStoreTemplate (template1 :: Kind.Type) (template2 :: Kind.Type)+              :: Constraint where+  CastableUStoreTemplate t t = ()  -- case for undeducible but equal types+  CastableUStoreTemplate SomeUTemplate _ = ()+  CastableUStoreTemplate _ SomeUTemplate = ()+  CastableUStoreTemplate t1 t2 = t1 `CanCastTo` 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, HasAnnotation, Wrappable)++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+  docItemPos = 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 distributed across migration+-- stages, but each single atom is treated as a whole and cannot be splitted.+--+-- 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.+--+-- Mostly for testing purposes.+-- 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+    where+      wrapped = iso unMigrationScript MigrationScript++-- | 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"+     ]
+ src/Lorentz/UStore/Migration/Batching.hs view
@@ -0,0 +1,121 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# LANGUAGE NoRebindableSyntax #-}++-- | Different approaches to batching.+--+-- For now we do not support perfect batching because operation size evaluation+-- (as well as gas consumption evaluation) is not implemented yet.+-- The only non-trivial batching implementation we provide is+-- 'mbSeparateLambdas'.+module Lorentz.UStore.Migration.Batching+  ( -- * Separate-lambdas batching+    SlBatchType (..)+  , SlBatchInfo (..)+  , mbSeparateLambdas+  ) where++import Prelude++import Colourista (blue, formatWith, green, red, yellow)+import qualified Data.List as L+import Fmt (Buildable(..))++import Lorentz.UStore.Migration.Base+import Michelson.Typed++----------------------------------------------------------------------------+-- Separating lambdas+----------------------------------------------------------------------------++-- | Type of batch.+data SlBatchType+  = SlbtData+    -- ^ Addition of any type of data.+  | SlbtLambda+    -- ^ Addition of code.+  | SlbtCustom+    -- ^ Several joined actions of different types.+  | SlbtUnknown+    -- ^ No information about batching.+    -- This means that the given action does not contain 'DMigrationActionDesc'.+  deriving stock (Show, Eq)++slbtIsData :: SlBatchType -> Bool+slbtIsData = \case { SlbtData -> True; _ -> False }++data SlBatchInfo = SlBatchInfo+  { slbiType :: SlBatchType+  , slbiActions :: [Text]+  }++instance Buildable SlBatchInfo where+  build (SlBatchInfo ty actions) = mconcat+    [ build @Text $ case ty of+        SlbtData -> formatWith [blue] "[data]"+        SlbtLambda -> formatWith [green] "[code]"+        SlbtCustom -> formatWith [yellow] "[custom]"+        SlbtUnknown -> formatWith [red] "[unknown]"+    , " "+    , case actions of+        [] -> "-"+        [a] -> build a+        as -> foldMap (\a -> "\n  * " <> build a) as+    ]++-- | Puts all data updates in one batch, and all lambdas in separate batches,+-- one per batch.+--+-- The reason for such behaviour is that in production contracts amount of+-- changed data (be it in contract initialization or contract upgrade) is small,+-- while stored entrypoints are huge and addition of even one entrypoint often+-- barely fits into gas limit.+mbSeparateLambdas :: MigrationBatching [] SlBatchInfo+mbSeparateLambdas = MigrationBatching $ \atoms ->+  let+    atomsWithType = atoms <&> \a -> (atomType a, a)+    (dataAtoms, otherAtoms) = L.partition (slbtIsData . fst) atomsWithType+    dataMigration =+      ( SlBatchInfo SlbtData (nubCounting $ maName . snd <$> dataAtoms)+      , manualConcatMigrationScripts (maScript . snd <$> dataAtoms)+      )+    otherMigrations =+      [ (SlBatchInfo ty [maName atom], maScript atom)+      | (ty, atom) <- otherAtoms+      ]+  in dataMigration : otherMigrations+  where+    atomType :: MigrationAtom -> SlBatchType+    atomType = chooseType . maActionsDesc++    chooseType :: [DMigrationActionDesc] -> SlBatchType+    chooseType = \case+      [] -> SlbtUnknown+      xs | all isLambda xs -> SlbtLambda+      xs | (not . any isAddLambda) xs -> SlbtData+         | otherwise -> SlbtCustom++    isLambda :: DMigrationActionDesc -> Bool+    isLambda = \case { TLambda{} -> True; _ -> False } . manFieldType++    isAddLambda :: DMigrationActionDesc -> Bool+    isAddLambda a = and+      [ isLambda a+      , case manAction a of { DAddAction _ -> True; _ -> False }+      ]++-- | Similar to 'nub', counts number of invocations and attaches to text entry.+--+-- >>> nubCounting ["a", "b", "a"]+-- ["a (x2)", "b"]+nubCounting :: [Text] -> [Text]+nubCounting = \case+  [] -> []+  x : xs ->+    let ((length -> repetitions), others) = L.partition (== x) xs+        x' = if repetitions == 0+             then x+             else x <> " (x" <> show (repetitions + 1) <> ")"+    in x' : nubCounting others
+ src/Lorentz/UStore/Migration/Blocks.hs view
@@ -0,0 +1,293 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -Wno-redundant-constraints #-}++-- | Elemental building blocks for migrations.+module Lorentz.UStore.Migration.Blocks+  ( -- * General+    mustoreToOld+  , MigrationFinishCheckPosition (..)++    -- * Elemental steps+  , migrateCoerceUnsafe+  , migrateGetField+  , migrateAddField+  , migrateRemoveField+  , migrateExtractField+  , migrateOverwriteField+  , migrateModifyField++    -- * Migration batches+  , muBlock+  , muBlockNamed+  , (<-->)+  , ($:)+  ) where++import Prelude++import Lorentz.Base+import Lorentz.Coercions+import Lorentz.Instr (dip)+import Lorentz.UStore.Instr+import Lorentz.UStore.Migration.Base+import Lorentz.UStore.Migration.Diff+import Lorentz.UStore.Types+import Util.Label (Label)+import Util.Type+import Util.TypeLits++-- | Helper for 'mustoreToOld' which ensures that given store hasn't been+-- migrated entirely yet.+type family RequireBeInitial (touched :: [Symbol]) :: Constraint where+  RequireBeInitial '[] = ()+  RequireBeInitial _ =+    TypeError ('Text "Migration has already been started over this store")++type family RequireUntouched (field :: Symbol) (wasTouched :: Bool)+             :: Constraint where+  RequireUntouched _ 'False = ()+  RequireUntouched field 'True = TypeError+    ('Text ("Field `" `AppendSymbol` field `AppendSymbol` "` has already been \+            \migrated and cannot be read")+    )++-- | Cast field or submap pretending that its value fits to the new type.+--+-- Useful when type of field, e.g. lambda or set of lambdas, is polymorphic+-- over storage type.+migrateCoerceUnsafe+  :: forall field oldTempl newTempl diff touched newDiff newDiff0 _1 _2 s.+     ( '(_1, newDiff0) ~ CoverDiff 'DcRemove field diff+     , '(_2, newDiff) ~ CoverDiff 'DcAdd field newDiff0+     )+  => Label field+  -> MUStore oldTempl newTempl diff touched : s+  :-> MUStore oldTempl newTempl newDiff touched : s+migrateCoerceUnsafe _ =+  forcedCoerce_++-- Migrating fields+----------------------------------------------------------------------------++-- | Get a field present in old version of 'UStore'.+migrateGetField+  :: forall field oldTempl newTempl diff touched fieldTy s.+     ( HasUField field fieldTy oldTempl+     , RequireUntouched field (field `IsElem` touched)+     )+  => Label field+  -> MUStore oldTempl newTempl diff touched : s+  :-> fieldTy : MUStore oldTempl newTempl diff touched : s+migrateGetField label =+  forcedCoerce_ @_ @(UStore oldTempl) # ustoreGetField label # dip forcedCoerce_++-- | Add a field which was not present before.+-- This covers one addition from the diff and any removals of field with given+-- name.+--+-- This function cannot overwrite existing field with the same name, if this+-- is necessary use 'migrateOverwriteField' which would declare removal+-- explicitly.+migrateAddField+  :: forall field oldTempl newTempl diff touched fieldTy newDiff marker s.+     ( '(UStoreFieldExt marker fieldTy, newDiff) ~ CoverDiff 'DcAdd field diff+     , HasUField field fieldTy newTempl+     )+  => Label field+  -> fieldTy : MUStore oldTempl newTempl diff touched : s+  :-> MUStore oldTempl newTempl newDiff (field ': touched) : s+migrateAddField label =+  attachMigrationActionName (DAddAction "add") label (Proxy @fieldTy) #+  dip (forcedCoerce_ @_ @(UStore newTempl)) # ustoreSetField label # forcedCoerce_++-- | Remove a field which should not be present in new version of storage.+-- This covers one removal from the diff.+--+-- In fact, this action could be performed automatically, but since+-- removal is a destructive operation, being explicit about it seems+-- like a good thing.+migrateRemoveField+  :: forall field oldTempl newTempl diff touched fieldTy newDiff marker s.+     ( '(UStoreFieldExt marker fieldTy, newDiff) ~ CoverDiff 'DcRemove field diff+     , HasUField field fieldTy oldTempl+     )+  => Label field+  -> MUStore oldTempl newTempl diff touched : s+  :-> MUStore oldTempl newTempl newDiff (field ': touched) : s+migrateRemoveField label =+  attachMigrationActionName DDelAction label (Proxy @fieldTy) #+  forcedCoerce_ @_ @(UStore oldTempl) # ustoreRemoveFieldUnsafe label # forcedCoerce_++-- | Get and remove a field from old version of 'UStore'.+--+-- You probably want to use this more often than plain 'migrateRemoveField'.+migrateExtractField+  :: forall field oldTempl newTempl diff touched fieldTy newDiff marker s.+     ( '(UStoreFieldExt marker fieldTy, newDiff) ~ CoverDiff 'DcRemove field diff+     , HasUField field fieldTy oldTempl+     , RequireUntouched field (field `IsElem` touched)+     )+  => Label field+  -> MUStore oldTempl newTempl diff touched : s+  :-> fieldTy : MUStore oldTempl newTempl newDiff (field ': touched) : s+migrateExtractField label =+  attachMigrationActionName DDelAction label (Proxy @fieldTy) #+  migrateGetField label # dip (migrateRemoveField label)++-- | Remove field and write new one in place of it.+--+-- This is semantically equivalent to+-- @dip (migrateRemoveField label) >> migrateAddField label@,+-- but is cheaper.+migrateOverwriteField+  :: forall field oldTempl newTempl diff touched fieldTy oldFieldTy+            marker oldMarker newDiff newDiff0 s.+     ( '(UStoreFieldExt oldMarker oldFieldTy, newDiff0) ~ CoverDiff 'DcRemove field diff+     , '(UStoreFieldExt marker fieldTy, newDiff) ~ CoverDiff 'DcAdd field newDiff0+     , HasUField field fieldTy newTempl+     )+  => Label field+  -> fieldTy : MUStore oldTempl newTempl diff touched : s+  :-> MUStore oldTempl newTempl newDiff (field ': touched) : s+migrateOverwriteField label =+  attachMigrationActionName (DAddAction "overwrite") label (Proxy @fieldTy) #+  dip (forcedCoerce_ @_ @(UStore newTempl)) # ustoreSetField label # forcedCoerce_++-- | Modify field which should stay in new version of storage.+-- This does not affect remaining diff.+migrateModifyField+  :: forall field oldTempl newTempl diff touched fieldTy s.+     ( HasUField field fieldTy oldTempl+     , HasUField field fieldTy newTempl+     )+  => Label field+  -> fieldTy : MUStore oldTempl newTempl diff touched : s+  :-> MUStore oldTempl newTempl diff touched : s+migrateModifyField label =+  attachMigrationActionName (DAddAction "modify") label (Proxy @fieldTy) #+  dip (forcedCoerce_ @_ @(UStore oldTempl)) # ustoreSetField label # forcedCoerce_++-- Migrating virtual submaps (strict migration)+----------------------------------------------------------------------------++{- For now we do not support this kind of migration.++"Strict" means that we want to modify maps right here rather than signal to+do modification of each entry on first access to it (which would be simpler+in some sense).++Implementing this is slightly less trivial than migrating individial fields.+1. One needs current value of UStore picked from the contract, because it's+not possible to iterate over big_map from within a contract in the current mainnet.+Even if it was, we can't assume that iteration of the whole submap would fit+into gas limit of single transaction, thus iteration should be performed+from outside of the contract by someone who knows the current storage.++2. We need to split migration in batches smartly. Too big batches would hit+operation size limit, while small ones would cause high overhead of+contract/storage deserialization.+Will be resolved in TM-330.+-}++----------------------------------------------------------------------------+-- Blocks for batched migrations+----------------------------------------------------------------------------++-- | Define a migration block.+-- Batched migrations consist of such blocks.+--+-- It will be named automatically according to the set of actions it performs+-- (via 'DMigrationActionDesc's).+-- This may be what you want for small sequences of actions, but for complex ones+-- consider using 'muBlockNamed'.+-- Names will be used in rendering migration plan.+muBlock+  :: ('[MUStore o n d1 t1] :-> '[MUStore o n d2 t2])+  -> MigrationBlocks o n d1 t1 d2 t2+muBlock code =+  MigrationBlocks . one . formMigrationAtom Nothing $+    forcedCoerce_ # code # forcedCoerce_++-- | Define a migration block with given name.+--+-- Name will be used when rendering migration plan.+muBlockNamed+  :: Text+  -> ('[MUStore o n d1 t1] :-> '[MUStore o n d2 t2])+  -> MigrationBlocks o n d1 t1 d2 t2+muBlockNamed name code =+  MigrationBlocks . one . formMigrationAtom (Just name) $+    forcedCoerce_ # code # forcedCoerce_++-- | Composition of migration blocks.+(<-->)+  :: MigrationBlocks o n d1 t1 d2 t2+  -> MigrationBlocks o n d2 t2 d3 t3+  -> MigrationBlocks o n d1 t1 d3 t3+MigrationBlocks blocks1 <--> MigrationBlocks blocks2 =+  MigrationBlocks (blocks1 <> blocks2)+infixl 2 <-->++{- | This is '$' operator with priority higher than '<-->'.++It allows you writing++@+mkUStoreBatchedMigration =+  muBlock $: do+    migrateAddField ...+  <-->+  muBlock $: do+    migrateRemoveField ...+@++Alternatively, @BlockArguments@ extension can be used.+-}+($:) :: (a -> b) -> a -> b+($:) = ($)+infixr 7 $:++----------------------------------------------------------------------------+-- Common+----------------------------------------------------------------------------++-- | Get the old version of storage.+--+-- This can be applied only in the beginning of migration.+--+-- In fact this function is not very useful, all required operations should+-- be available for 'MUStore', but leaving it here just in case.+mustoreToOld+  :: RequireBeInitial touched+  => MUStore oldTemplate newTemplate remDiff touched : s+  :-> UStore oldTemplate : s+mustoreToOld = forcedCoerce_++class MigrationFinishCheckPosition a where+  -- | Put this in the end of migration script to get a human-readable message+  -- about remaining diff which yet should be covered.+  -- Use of this function in migration is fully optional.+  --+  -- This function is not part of 'mkUStoreMigration' for the sake of+  -- proper error messages ordering, during development+  -- you probably want errors in migration script to be located earlier+  -- in code than errors about not fully covered diff (if you used+  -- to fix errors in the same order in which they appear).+  migrationFinish :: a++-- | This version can be used in 'mkUStoreMigration'.+instance ( i ~ (MUStore oldTempl newTempl diff touched : s)+         , o ~ (MUStore oldTempl newTempl '[] touched : s)+         , RequireEmptyDiff diff+         ) =>+         MigrationFinishCheckPosition (i :-> o) where+  migrationFinish = forcedCoerce_++-- | This version can be used in 'mkUStoreBatchedMigration' as the last migration+-- block.+instance (RequireEmptyDiff d1, t1 ~ t2) =>+         MigrationFinishCheckPosition (MigrationBlocks o n d1 t1 '[] t2) where+  migrationFinish = MigrationBlocks []
+ src/Lorentz/UStore/Migration/Diff.hs view
@@ -0,0 +1,202 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Lorentz.UStore.Migration.Diff+  ( FieldInfo+  , DiffKind (..)+  , DiffItem+  , BuildDiff+  , ShowDiff+  , RequireEmptyDiff++  , LinearizeUStore+  , LinearizeUStoreF+  , AllUStoreFieldsF++  , DiffCoverage (..)+  , CoverDiff+  , CoverDiffMany+  ) where++import Prelude++import qualified Data.Kind as Kind+import Fcf (type (***), type (=<<), Eval, Exp, Fst, Pure)+import qualified Fcf+import Fcf.Data.List (Cons)+import Fcf.Utils (TError)+import GHC.Generics ((:*:), (:+:))+import qualified GHC.Generics as G++import Lorentz.UStore.Types+import Util.Type+import Util.TypeLits++-- Diff definition+----------------------------------------------------------------------------++-- | Information about single field of UStore.+type FieldInfo = (Symbol, Kind.Type)++-- | What should happen with a particular 'UStoreItem'.+data DiffKind = ToAdd | ToDel++-- | Single piece of a diff.+type DiffItem = (DiffKind, FieldInfo)++-- Building diff+----------------------------------------------------------------------------++-- | Get information about all fields of UStore template in a list.+--+-- In particular, this recursivelly traverses template and retrives+-- names and types of fields. Semantic wrappers like 'UStoreField'+-- and '|~>' in field types are returned as-is.+type LinearizeUStore a = GLinearizeUStore (G.Rep a)++data LinearizeUStoreF (template :: Kind.Type) :: Exp [FieldInfo]+type instance Eval (LinearizeUStoreF template) = LinearizeUStore template++-- | Get only field names of UStore template.+type family AllUStoreFieldsF (template :: Kind.Type) :: Exp [Symbol] where+  AllUStoreFieldsF template = Fcf.Map Fst =<< LinearizeUStoreF template++type family GLinearizeUStore (template :: Kind.Type -> Kind.Type)+    :: [FieldInfo] where+  GLinearizeUStore (G.D1 _ x) = GLinearizeUStore x+  GLinearizeUStore (G.C1 _ x) = GLinearizeUStore x+  GLinearizeUStore (_ :+: _) = TypeError+    ('Text "Unexpected sum type in UStore template")+  GLinearizeUStore G.V1 = TypeError+    ('Text "Unexpected void-like type in UStore template")+  GLinearizeUStore G.U1 = '[]+  GLinearizeUStore (x :*: y) = GLinearizeUStore x ++ GLinearizeUStore y++  GLinearizeUStore (G.S1 ('G.MetaSel mfield _ _ _) (G.Rec0 (k |~> v))) =+    '[ '(RequireFieldName mfield, k |~> v) ]+  GLinearizeUStore (G.S1 ('G.MetaSel mfield _ _ _) (G.Rec0 (UStoreFieldExt m v))) =+    '[ '(RequireFieldName mfield, UStoreFieldExt m v) ]+  GLinearizeUStore (G.S1 _ (G.Rec0 a)) =+    LinearizeUStore a++-- | Helper to make sure that datatype field is named and then extract this name.+type family RequireFieldName (mfield :: Maybe Symbol) :: Symbol where+  RequireFieldName ('Just field) = field+  RequireFieldName 'Nothing = TypeError ('Text "Unnamed field in UStore template")++-- | Lift a list of 'FieldInfo' to 'DiffItem's via attaching given 'DiffKind'.+type family LiftToDiff (kind :: DiffKind) (items :: [FieldInfo]) :: [DiffItem] where+  LiftToDiff _ '[] = '[]+  LiftToDiff kind (item ': items) = '(kind, item) ': LiftToDiff kind items++-- | Make up a migration diff between given old and new 'UStore' templates.+type BuildDiff oldTemplate newTemplate =+  LiftToDiff 'ToAdd (LinearizeUStore newTemplate // LinearizeUStore oldTemplate)+  +++  LiftToDiff 'ToDel (LinearizeUStore oldTemplate // LinearizeUStore newTemplate)++-- Pretty-printing diff+----------------------------------------------------------------------------++-- | Renders human-readable message describing given diff.+type ShowDiff diff =+  'Text "Migration is incomplete, remaining diff:" ':$$: ShowDiffItems diff++type family ShowDiffItems (diff :: [DiffItem]) :: ErrorMessage where+  ShowDiffItems '[d] = ShowDiffItem d+  ShowDiffItems (d : ds) = ShowDiffItem d ':$$: ShowDiffItems ds++type family ShowDiffKind (kind :: DiffKind) :: Symbol where+  ShowDiffKind 'ToAdd = "+"+  ShowDiffKind 'ToDel = "-"++type family ShowUStoreElement (ty :: Kind.Type) :: ErrorMessage where+  ShowUStoreElement (UStoreFieldExt m f) =+    ShowUStoreField m f+  ShowUStoreElement (k |~> v) =+    'Text "submap " ':<>: 'ShowType k ':<>: 'Text " -> " ':<>: 'ShowType v++type family ShowDiffItem (diff :: DiffItem) :: ErrorMessage where+  ShowDiffItem '(kind, '(field, ty)) =+    'Text (ShowDiffKind kind `AppendSymbol`+           " `" `AppendSymbol`+           field `AppendSymbol`+           "`") ':<>:+    'Text ": " ':<>: ShowUStoreElement ty++-- | Helper type family which dumps error message about remaining diff+-- if such is present.+type family RequireEmptyDiff (diff :: [DiffItem]) :: Constraint where+  RequireEmptyDiff '[] = ()+  RequireEmptyDiff diff = TypeError (ShowDiff diff)++-- Diff coverage+----------------------------------------------------------------------------++-- | Cover the respective part of diff.+-- Maybe fail if such action is not required.+--+-- This type is very similar to 'DiffKind', but we still use another type as+-- 1. Their kinds will differ - no chance to mix up anything.+-- 2. One day there might appear more complex actions.+data DiffCoverage+  = DcAdd+  | DcRemove++type family PrefixSecond (a :: k2) (r :: (k1, [k2])) :: (k1, [k2]) where+  PrefixSecond a '(t, l) = '(t, (a ': l))++-- | Apply given diff coverage, returning type of affected field and modified+-- diff.+type family CoverDiff (cover :: DiffCoverage) (field :: Symbol) (diff :: [DiffItem])+            :: (Kind.Type, [DiffItem]) where+  CoverDiff cover field diff = Eval (CoverDiffF '(cover, field) diff)++type family CoverDiffF (arg :: (DiffCoverage, Symbol)) (diff :: [DiffItem])+            :: Exp (Kind.Type, [DiffItem]) where+  CoverDiffF '( 'DcAdd, field) diff = RemoveDiffF 'ToAdd field diff+  CoverDiffF '( 'DcRemove, field) diff = RemoveDiffF 'ToDel field diff++type family RemoveDiffF (kind :: DiffKind) (field :: Symbol) (diff :: [DiffItem])+            :: Exp (Kind.Type, [DiffItem]) where+  RemoveDiffF kind field ('(kind, '(field, ty)) ': diff) = Pure '(ty, diff)+  RemoveDiffF kind field (d ': diff) = (Pure *** Cons d) =<< RemoveDiffF kind field diff+  RemoveDiffF kind field '[] =+    TError ('Text (ShowDiffKindWord kind) ':<>: 'Text " field " ':<>:+            'ShowType field ':<>: 'Text " is not required")++type family ShowDiffKindWord (kind :: DiffKind) :: Symbol where+  ShowDiffKindWord 'ToAdd = "Adding"+  ShowDiffKindWord 'ToDel = "Removing"++-- | Single piece of a coverage.+type DiffCoverageItem = (DiffCoverage, FieldInfo)++-- | Apply multiple coverage steps.+type family CoverDiffMany (diff :: [DiffItem]) (covers :: [DiffCoverageItem])+            :: [DiffItem] where+  CoverDiffMany diff '[] = diff+  CoverDiffMany diff ('(dc, '(field, ty)) ': cs) =+    CoverDiffMany (HandleCoverRes field ty (CoverDiff dc field diff)) cs++type family HandleCoverRes (field :: Symbol) (ty :: Kind.Type) (res :: (Kind.Type, [DiffItem]))+            :: [DiffItem] where+  HandleCoverRes _ ty '(ty, diff) = diff+  HandleCoverRes field tyCover '(tyDiff, _) = TypeError+    ('Text "Type mismatch when covering diff for field " ':<>: 'ShowType field+     ':$$:+     'Text "Expected type `" ':<>: 'ShowType tyDiff ':<>: 'Text "` (in requested diff)"+     ':$$:+     'Text "but covered with value of type `" ':<>: 'ShowType tyCover ':<>: 'Text "`"+    )++type family EnsureDiffHasNoRemovalF (field :: Symbol) (diff :: [DiffItem])+             :: Exp [DiffItem] where+  EnsureDiffHasNoRemovalF _ '[] = Pure '[]+  EnsureDiffHasNoRemovalF field ('( 'ToDel, '(field, _)) ': _) =+    TError ('Text "Field with name " ':<>: 'ShowType field ':<>:+            'Text " is present in old version of storage"+           )+  EnsureDiffHasNoRemovalF field (d ': diff) =+    Cons d =<< EnsureDiffHasNoRemovalF field diff
+ src/Lorentz/UStore/Traversal.hs view
@@ -0,0 +1,195 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | UStore templates generic traversals.+--+-- Normally you work with functionality of this module as follows:+-- 1. Pick the function fitting most for your traversal, one of+--    'traverseUStore', 'foldUStore' e.t.c.+-- 2. Create a custom datatype value of which will be put to that function.+-- 3. Implement a respective 'UStoreTemplateTraversable' instance for this+--    datatype.+module Lorentz.UStore.Traversal+  ( UStoreTraversalWay (..)+  , UStoreTraversalFieldHandler (..)+  , UStoreTraversalSubmapHandler (..)+  , UStoreTraversable+  , traverseUStore+  , modifyUStore+  , foldUStore+  , genUStore+  ) where++import Prelude++import qualified Data.Kind as Kind+import GHC.Generics ((:*:)(..), (:+:))+import qualified GHC.Generics as G++import Lorentz.UStore.Types+import Util.Label+import Util.TypeLits++----------------------------------------------------------------------------+-- Interface+----------------------------------------------------------------------------++-- | Defines general parameters of UStore template traversal.+-- You need a separate @way@ datatype with an instance of this typeclass for each+-- type of traversal.+class ( Applicative (UStoreTraversalArgumentWrapper way)+      , Applicative (UStoreTraversalMonad way)+      ) =>+      UStoreTraversalWay (way :: Kind.Type) where++  -- | Wrapper which will accompany the existing value of traversed template,+  -- aka argument.+  -- This is usually @'Identity'@ or @'Const' a@.+  type UStoreTraversalArgumentWrapper way :: Kind.Type -> Kind.Type++  -- | Additional constraints on monadic action used in traversal.+  -- Common ones include 'Identity', @'Const'@, @(,) a@+  type UStoreTraversalMonad way :: Kind.Type -> Kind.Type++-- | Declares a handler for UStore fields when given traversal way is applied.+class (UStoreTraversalWay way) =>+      UStoreTraversalFieldHandler+        (way :: Kind.Type) (marker :: UStoreMarkerType) (v :: Kind.Type) where+  -- | How to process each of UStore fields.+  ustoreTraversalFieldHandler+    :: (KnownUStoreMarker marker)+    => way+    -> Label name+    -> UStoreTraversalArgumentWrapper way v+    -> UStoreTraversalMonad way v++-- | Declares a handler for UStore submaps when given traversal way is applied.+class (UStoreTraversalWay way) =>+      UStoreTraversalSubmapHandler+        (way :: Kind.Type) (k :: Kind.Type) (v :: Kind.Type) where+  -- | How to process each of UStore submaps.+  ustoreTraversalSubmapHandler+    :: way+    -> Label name+    -> UStoreTraversalArgumentWrapper way (Map k v)+    -> UStoreTraversalMonad way (Map k v)++-- | Constraint for UStore traversal.+type UStoreTraversable way a =+  (Generic a, GUStoreTraversable way (G.Rep a), UStoreTraversalWay way)++-- | Perform UStore traversal. The most general way to perform a traversal.+traverseUStore+  :: forall way template.+     (UStoreTraversable way template)+  => way+  -> UStoreTraversalArgumentWrapper way template+  -> UStoreTraversalMonad way template+traverseUStore way =+  fmap G.to . gTraverseUStore way . fmap G.from++-- | Modify each UStore entry.+modifyUStore+  :: ( UStoreTraversable way template+     , UStoreTraversalArgumentWrapper way ~ Identity+     , UStoreTraversalMonad way ~ Identity+     )+  => way+  -> template+  -> template+modifyUStore way a =+  runIdentity $ traverseUStore way (Identity a)++-- | Collect information about UStore entries into monoid.+foldUStore+  :: ( UStoreTraversable way template+     , UStoreTraversalArgumentWrapper way ~ Identity+     , UStoreTraversalMonad way ~ Const res+     )+  => way+  -> template+  -> res+foldUStore way a =+  getConst $ traverseUStore way (Identity a)++-- | Fill UStore template with entries.+genUStore+  :: ( UStoreTraversable way template+     , UStoreTraversalArgumentWrapper way ~ Const ()+     )+  => way -> UStoreTraversalMonad way template+genUStore way =+  traverseUStore way (Const ())++-- Implementation+----------------------------------------------------------------------------++-- | Generic traversal of UStore template.+class GUStoreTraversable (way :: Kind.Type) (x :: Kind.Type -> Kind.Type) where+  gTraverseUStore+    :: (UStoreTraversalWay way)+    => way+    -> UStoreTraversalArgumentWrapper way (x p)+    -> UStoreTraversalMonad way (x p)++instance GUStoreTraversable way x =>+         GUStoreTraversable way (G.D1 i x) where+  gTraverseUStore way x =+    G.M1 <$> gTraverseUStore way (G.unM1 <$> x)++instance GUStoreTraversable way x =>+         GUStoreTraversable way (G.C1 i x) where+  gTraverseUStore way x =+    G.M1 <$> gTraverseUStore way (G.unM1 <$> x)++instance TypeError ('Text "Unexpected sum type in UStore template") =>+         GUStoreTraversable way (x :+: y) where+  gTraverseUStore _ = error "imposible"++instance TypeError ('Text "Unexpected void-like type in UStore template") =>+         GUStoreTraversable way G.V1 where+  gTraverseUStore _ = error "impossible"++instance ( GUStoreTraversable way x+         , GUStoreTraversable way y+         ) =>+         GUStoreTraversable way (x :*: y) where+  gTraverseUStore way a =+    (:*:) <$> gTraverseUStore way (a <&> \(x :*: _) -> x)+          <*> gTraverseUStore way (a <&> \(_ :*: y) -> y)++instance GUStoreTraversable way G.U1 where+  gTraverseUStore _ _ = pure G.U1++instance {-# OVERLAPPABLE #-}+         UStoreTraversable way template =>+         GUStoreTraversable way (G.S1 i (G.Rec0 template)) where+  gTraverseUStore way sub =+    G.M1 . G.K1 <$> traverseUStore way (G.unK1 . G.unM1 <$> sub)++instance ( UStoreTraversalFieldHandler way marker v, KnownUStoreMarker marker+         , KnownSymbol ctor+         ) =>+         GUStoreTraversable+           way+           (G.S1 ('G.MetaSel ('Just ctor) _1 _2 _3) (G.Rec0 (UStoreFieldExt marker v))) where+  gTraverseUStore way entry =+    G.M1 . G.K1 . UStoreField <$>+      ustoreTraversalFieldHandler+        @_+        @marker+        way+        (Label @ctor)+        (entry <&> \(G.M1 (G.K1 (UStoreField v))) -> v)++instance (UStoreTraversalSubmapHandler way k v, KnownSymbol ctor) =>+         GUStoreTraversable+           way+           (G.S1 ('G.MetaSel ('Just ctor) _1 _2 _3) (G.Rec0 (k |~> v))) where+  gTraverseUStore way entry =+    G.M1 . G.K1 . UStoreSubMap <$>+      ustoreTraversalSubmapHandler+        way+        (Label @ctor)+        (entry <&> \(G.M1 (G.K1 (UStoreSubMap m))) -> m)
+ src/Lorentz/UStore/Types.hs view
@@ -0,0 +1,281 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | 'UStore' definition and common type-level stuff.+module Lorentz.UStore.Types+  ( -- * UStore and related type definitions+    UStore (..)+  , type (|~>)(..)+  , UStoreFieldExt (..)+  , UStoreField+  , UStoreMarkerType+  , UMarkerPlainField++    -- ** Extras+  , KnownUStoreMarker (..)+  , mkFieldMarkerUKeyL+  , mkFieldUKey+  , UStoreSubmapKey+  , UStoreSubmapKeyT++    -- ** Type-lookup-by-name+  , GetUStoreKey+  , GetUStoreValue+  , GetUStoreField+  , GetUStoreFieldMarker++    -- ** Marked fields+  , PickMarkedFields++   -- * Internals+  , ElemSignature (..)+  , GetUStore+  , MSKey+  , MSValue+  , FSValue+  , FSMarker+  ) where++import Prelude++import qualified Data.Kind as Kind+import GHC.Generics ((:*:)(..), (:+:)(..))+import qualified GHC.Generics as G+import GHC.TypeLits (ErrorMessage(..), Symbol, TypeError)++import Lorentz.Annotation (HasAnnotation)+import Lorentz.Coercions (Wrappable, CanCastTo)+import Lorentz.Pack+import Lorentz.Polymorphic+import Lorentz.Value+import Michelson.Text (labelToMText)+import Michelson.Typed.T+import Util.Type++-- | Gathers multple fields and 'BigMap's under one object.+--+-- Type argument of this datatype stands for a "store template" -+-- a datatype with one constructor and multiple fields, each containing+-- an object of type 'UStoreField' or '|~>' and corresponding to single+-- virtual field or 'BigMap' respectively.+-- It's also possible to parameterize it with a larger type which is+-- a product of types satisfying the above property.+newtype UStore (a :: Kind.Type) = UStore+  { unUStore :: BigMap ByteString ByteString+  } deriving stock (Eq, Show, Generic)+    deriving newtype (Default, Semigroup, Monoid, IsoValue,+                      MemOpHs, GetOpHs, UpdOpHs)+    deriving anyclass (HasAnnotation, Wrappable)++-- | Describes one virtual big map in the storage.+newtype k |~> v = UStoreSubMap { unUStoreSubMap :: Map k v }+  deriving stock (Show, Eq)+  deriving newtype (Default)++-- | Describes plain field in the storage.+newtype UStoreFieldExt (m :: UStoreMarkerType) (v :: Kind.Type) = UStoreField { unUStoreField :: v }+  deriving stock (Show, Eq)++-- | Just a servant type.+data UStoreMarker++-- | Specific kind used to designate markers for 'UStoreFieldExt'.+--+-- We suggest that fields may serve different purposes and so annotated with+-- special markers accordingly, which influences translation to Michelson.+-- See example below.+--+-- This Haskell kind is implemented like that because we want markers to differ from all+-- other types in kind; herewith 'UStoreMarkerType' is still an open kind+-- (has potentially infinite number of inhabitants).+type UStoreMarkerType = UStoreMarker -> Kind.Type++-- | Just a plain field used as data.+type UStoreField = UStoreFieldExt UMarkerPlainField+data UMarkerPlainField :: UStoreMarkerType++-- | What do we serialize when constructing big_map key for accessing+-- an UStore submap.+type UStoreSubmapKey k = (MText, k)+type UStoreSubmapKeyT k = 'TPair (ToT MText) k++-- Extra attributes of fields+----------------------------------------------------------------------------++-- | Allows to specify format of key under which fields of this type are stored.+-- Useful to avoid collisions.+class KnownUStoreMarker (marker :: UStoreMarkerType) where+  -- | By field name derive key under which field should be stored.+  mkFieldMarkerUKey :: MText -> ByteString+  default mkFieldMarkerUKey :: MText -> ByteString+  mkFieldMarkerUKey = lPackValueRaw++  -- | Display type-level information about UStore field with given marker and+  -- field value type.+  -- Used for error messages.+  type ShowUStoreField marker v :: ErrorMessage+  type ShowUStoreField _ v = 'Text "field of type " ':<>: 'ShowType v++-- | Version of 'mkFieldMarkerUKey' which accepts label.+mkFieldMarkerUKeyL+  :: forall marker field.+     KnownUStoreMarker marker+  => Label field -> ByteString+mkFieldMarkerUKeyL label =+  mkFieldMarkerUKey @marker (labelToMText label)++-- | Shortcut for 'mkFieldMarkerUKey' which accepts not marker but store template+-- and name of entry.+mkFieldUKey+  :: forall (store :: Kind.Type) field.+     KnownUStoreMarker (GetUStoreFieldMarker store field)+  => Label field -> ByteString+mkFieldUKey = mkFieldMarkerUKeyL @(GetUStoreFieldMarker store field)++instance KnownUStoreMarker UMarkerPlainField where++-- Extra instaces+----------------------------------------------------------------------------++instance (m1 ~ m2, a1 `CanCastTo` a2) =>+         UStoreFieldExt m1 a1 `CanCastTo` UStoreFieldExt m2 a2++instance (k1 `CanCastTo` k2, v1 `CanCastTo` v2) =>+         (k1 |~> v1) `CanCastTo` (k2 |~> v2)++----------------------------------------------------------------------------+-- Type-safe lookup magic+----------------------------------------------------------------------------++{- Again we use generic magic to implement methods for 'Store'+(and thus 'Store' type constructor accepts a datatype, not a type-level list).++There are two reasons for this:++1. This gives us expected balanced tree of 'Or's for free.++2. This allows us selecting a map by field name, not by+e.g. type of map value. This is subjective, but looks like a good thing+for me (@martoon). On the other hand, it prevents us from sharing the+same interface between maps and 'Store'.++-}++-- | What was found on lookup by constructor name.+--+-- This keeps either type arguments of '|~>' or 'UStoreField'.+data ElemSignature+  = MapSignature Kind.Type Kind.Type+  | FieldSignature UStoreMarkerType Kind.Type++-- Again, we will use these getters instead of binding types within+-- 'MapSignature' using type equality because getters does not produce extra+-- compile errors on "field not found" cases.+type family MSKey (ms :: ElemSignature) :: Kind.Type where+  MSKey ('MapSignature k _) = k+  MSKey ('FieldSignature _ _) =+    TypeError ('Text "Expected UStore submap, but field was referred")+type family MSValue (ms :: ElemSignature) :: Kind.Type where+  MSValue ('MapSignature _ v) = v+  MSValue ('FieldSignature _ _) =+    TypeError ('Text "Expected UStore submap, but field was referred")+type family FSValue (ms :: ElemSignature) :: Kind.Type where+  FSValue ('FieldSignature _ v) = v+  FSValue ('MapSignature _ _) =+    TypeError ('Text "Expected UStore field, but submap was referred")+type family FSMarker (ms :: ElemSignature) :: UStoreMarkerType where+  FSMarker ('FieldSignature m _) = m+  FSMarker ('MapSignature _ _) =+    TypeError ('Text "Expected UStore field, but submap was referred")++-- | Get map signature from the constructor with a given name.+type GetUStore name a = MERequireFound name a (GLookupStore name (G.Rep a))++type family MERequireFound+  (name :: Symbol)+  (a :: Kind.Type)+  (mlr :: Maybe ElemSignature)+    :: ElemSignature where+  MERequireFound _ _ ('Just ms) = ms+  MERequireFound name a 'Nothing = TypeError+    ('Text "Failed to find plain field or submap in store template: datatype `"+     ':<>: 'ShowType a ':<>: 'Text "` has no field " ':<>: 'ShowType name)++type family GLookupStore (name :: Symbol) (x :: Kind.Type -> Kind.Type)+              :: Maybe ElemSignature where+  GLookupStore name (G.D1 _ x) = GLookupStore name x+  GLookupStore _ (_ :+: _) =+    TypeError ('Text "Templates used in UStore should have only one constructor")+  GLookupStore _ G.V1 =+    TypeError ('Text "No constructors in UStore template")++  GLookupStore name (G.C1 _ x) = GLookupStore name x++  GLookupStore name (x :*: y) = LSMergeFound name (GLookupStore name x)+                                                  (GLookupStore name y)++  -- When we encounter a field there are three cases we are interested in:+  -- 1. This field has type '|~>'. Then we check its name and return 'Just'+  -- with all required info on match, and 'Nothing' otherwise.+  -- 2. This field has type 'UStoreField'. We act in the same way+  -- as for '|~>', attaching 'ThePlainFieldKey' as key.+  -- 3. This field type is a different one. Then we expect this field to store+  -- '|~>' or 'UStoreField' somewhere deeper and try to find it there.+  GLookupStore name (G.S1 ('G.MetaSel mFieldName _ _ _) (G.Rec0 (k |~> v))) =+    Guard ('Just name == mFieldName) ('MapSignature k v)+  GLookupStore name (G.S1 ('G.MetaSel mFieldName _ _ _) (G.Rec0 (UStoreFieldExt m v))) =+    Guard ('Just name == mFieldName) ('FieldSignature m v)++  GLookupStore name (G.S1 _ (G.Rec0 a)) =+    GLookupStore name (G.Rep a)++  GLookupStore _ G.U1 = 'Nothing++type family LSMergeFound (name :: Symbol)+  (f1 :: Maybe ElemSignature) (f2 :: Maybe ElemSignature)+  :: Maybe ElemSignature where+  LSMergeFound _ 'Nothing 'Nothing = 'Nothing+  LSMergeFound _ ('Just ms) 'Nothing = 'Just ms+  LSMergeFound _ 'Nothing ('Just ms) = 'Just ms+  -- It's possible that there are two constructors with the same name,+  -- because main template pattern may be a sum of smaller template+  -- patterns with same constructor names.+  LSMergeFound ctor ('Just _) ('Just _) = TypeError+    ('Text "Found more than one constructor matching " ':<>: 'ShowType ctor)+++-- | Get type of submap key.+type GetUStoreKey store name = MSKey (GetUStore name store)++-- | Get type of submap value.+type GetUStoreValue store name = MSValue (GetUStore name store)++-- | Get type of plain field.+-- This ignores marker with field type.+type GetUStoreField store name = FSValue (GetUStore name store)++-- | Get kind of field.+type GetUStoreFieldMarker store name = FSMarker (GetUStore name store)++-- One more magic+----------------------------------------------------------------------------++-- | Collect all fields with the given marker.+type PickMarkedFields marker template = GPickMarkedFields marker (G.Rep template)++type family GPickMarkedFields (marker :: UStoreMarkerType) (x :: Kind.Type -> Kind.Type)+             :: [(Symbol, Kind.Type)] where+  GPickMarkedFields m (G.D1 _ x) = GPickMarkedFields m x+  GPickMarkedFields m (G.C1 _ x) = GPickMarkedFields m x+  GPickMarkedFields m (x :*: y) = GPickMarkedFields m x ++ GPickMarkedFields m y+  GPickMarkedFields _ G.U1 = '[]++  GPickMarkedFields m (G.S1 ('G.MetaSel ('Just fieldName) _ _ _) (G.Rec0 (UStoreFieldExt m v))) =+    '[ '(fieldName, v) ]+  GPickMarkedFields _ (G.S1 _ (G.Rec0 (UStoreFieldExt _ _))) =+    '[]+  GPickMarkedFields _ (G.S1 _ (G.Rec0 (_ |~> _))) =+    '[]+  GPickMarkedFields m (G.S1 _ (G.Rec0 a)) =+    PickMarkedFields m a
+ test/Main.hs view
@@ -0,0 +1,16 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Main+  ( main+  ) where++import Test.Tasty (defaultMainWithIngredients)++import Cleveland.Ingredients (ourIngredients)++import Tree (tests)++main :: IO ()+main = tests >>= defaultMainWithIngredients ourIngredients
+ test/Test/Doc/Positions.hs view
@@ -0,0 +1,20 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Tests on ordering of documentation items.+module Test.Doc.Positions+  ( test_Errors+  ) where++import Test.Tasty (TestTree)++import Cleveland.Util (goesBefore)+import Lorentz.Contracts.Upgradeable.Common.Base (PermanentEntrypointsKind, UpgradeableEntrypointsKind)+import Lorentz.Entrypoints.Doc (DEntrypoint, PlainEntrypointsKind)++test_Errors :: [TestTree]+test_Errors =+  [ Proxy @(DEntrypoint PlainEntrypointsKind) `goesBefore` Proxy @(DEntrypoint PermanentEntrypointsKind)+  , Proxy @(DEntrypoint PermanentEntrypointsKind) `goesBefore` Proxy @(DEntrypoint UpgradeableEntrypointsKind)+  ]
+ test/Test/Lorentz/Contracts/UpgradeableCounter.hs view
@@ -0,0 +1,197 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.Lorentz.Contracts.UpgradeableCounter+  ( spec_UpgradeableCounter+  ) where++import Lorentz (VoidResult(..), mkView, mkVoid, ( # ))+import qualified Lorentz as L++import Data.Coerce (coerce)+import Test.Hspec (Spec, describe, it)++import Lorentz.Constraints+import Lorentz.Contracts.Upgradeable.Common+import Lorentz.Contracts.UpgradeableCounter+import qualified Lorentz.Contracts.UpgradeableCounter.V1 as V1+import qualified Lorentz.Contracts.UpgradeableCounter.V2 as V2+import Lorentz.Test+import Lorentz.UParam+import Lorentz.UStore+import Lorentz.Value+import Util.Instances ()++{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}++admin, admin2, adversary :: Address+admin = genesisAddress1+admin2 = genesisAddress2+adversary = genesisAddress3++originateUpgradeableCounter+  :: IntegrationalScenarioM (UTAddress CounterV0)+originateUpgradeableCounter =+  lOriginate upgradeableCounterContract "UpgradeableCounter"+    (mkEmptyStorage admin) (toMutez 1000)++originateUpgradeableCounterV1+  :: IntegrationalScenarioM (UTAddress V1.CounterV1)+originateUpgradeableCounterV1 = do+  contract <- originateUpgradeableCounter+  withSender admin $ upgradeToV1 contract+  return (coerce contract)++-- We deliberately use forall here so that we can test incorrect upgrades+upgradeToV1+  :: forall sign.+     UTAddress sign+  -> IntegrationalScenarioM (UTAddress V1.CounterV1)+upgradeToV1 =+  integrationalTestUpgrade V1.counterUpgradeParameters UpgEntrypointWise+  . coerce++-- We deliberately use forall here so that we can test incorrect upgrades+upgradeToV2+  :: forall sign.+     UTAddress sign+  -> IntegrationalScenarioM (UTAddress V2.CounterV2)+upgradeToV2 =+  integrationalTestUpgrade V2.counterUpgradeParameters UpgEntrypointWise+  . coerce++uCall+  :: forall a name (ver :: VersionKind) (interface :: [EntrypointKind]).+  ( interface ~ VerInterface ver+  , NicePackedValue a+  , RequireUniqueEntrypoints interface+  , PermConstraint ver+  , LookupEntrypoint name interface ~ a+  )+  => UTAddress ver+  -> Label name+  -> a+  -> IntegrationalScenarioM ()+uCall contract method arg = do+  lCallDef contract $ Run ((mkUParam method arg) :: UParam interface)++getCounterValueV1+  :: UTAddress V1.CounterV1+  -> IntegrationalScenarioM ()+getCounterValueV1 contract = do+  uCall contract #getCounterValue $ mkVoid ()++getVersion+  :: (PermConstraint ver)+  => UTAddress ver+  -> TAddress Version+  -> IntegrationalScenarioM ()+getVersion contract consumer = do+  lCallDef contract $ GetVersion (mkView () consumer)++getCounterValueV2+  :: UTAddress V2.CounterV2+  -> IntegrationalScenarioM ()+getCounterValueV2 contract = do+  uCall contract #getCounterValue $ mkVoid ()++spec_UpgradeableCounter :: Spec+spec_UpgradeableCounter = do+  describe "v1" $ do+    it "Initially contains zero" $ do+      integrationalTestExpectation $ do+        contract <- originateUpgradeableCounterV1+        getCounterValueV1 contract `catchExpectedError`+          lExpectError (== VoidResult @Natural 0)++    it "Updates counter after each operation" $ do+      integrationalTestExpectation $ do+        contract <- originateUpgradeableCounterV1++        uCall contract #add (2 :: Natural)+        uCall contract #mul (3 :: Natural)+        getCounterValueV1 contract `catchExpectedError`+          lExpectError (== VoidResult @Natural 6)++  describe "v2" $ do+    it "Upgrades to v2" $ do+      integrationalTestExpectation $ do+        contract <- originateUpgradeableCounterV1+        consumer <- lOriginateEmpty contractConsumer "consumer"++        getVersion contract consumer+        contract2 <- withSender admin $ upgradeToV2 contract+        getVersion contract2 consumer++        lExpectViewConsumerStorage consumer [1, 2]++    it "Preserves the counter after the upgrade" $ do+      integrationalTestExpectation $ do+        contract <- originateUpgradeableCounterV1++        uCall contract #add (42 :: Natural)+        contract2 <- withSender admin $ upgradeToV2 contract+        getCounterValueV2 contract2 `catchExpectedError`+          lExpectError (== VoidResult @Integer 42)++    it "Exposes new methods" $ do+      integrationalTestExpectation $ do+        contract <- originateUpgradeableCounterV1++        contract2 <- withSender admin $ upgradeToV2 contract+        uCall contract2 #inc ()+        uCall contract2 #inc ()++        branchout+          [ "2 inc" ?-+              getCounterValueV2 contract2 `catchExpectedError`+                lExpectError (== VoidResult @Integer 2)++          , "2 inc, 1 dec" ?- do+              uCall contract2 #dec ()+              getCounterValueV2 contract2 `catchExpectedError`+                lExpectError (== VoidResult @Integer 1)+          ]++    it "Allows to decrement below zero" $ do+      integrationalTestExpectation $ do+        contract <- originateUpgradeableCounterV1++        contract2 <- withSender admin $ upgradeToV2 contract+        uCall contract2 #dec ()+        uCall contract2 #dec ()+        uCall contract2 #dec ()+        getCounterValueV2 contract2 `catchExpectedError`+          lExpectError (== VoidResult @Integer (-3))++  describe "Cross-version" do+    it "Can migrate to the same version" $ do+      integrationalTestExpectation $ do+        contract <- originateUpgradeableCounterV1+        void $ withSender admin $ integrationalTestUpgrade+          ( fvUpgrade . migrationToScriptI . mkUStoreMigration $+                L.push 100 # migrateModifyField #counterValue+          )+          UpgOneShot+          contract++  describe "Illegal migrations" $ do+    it "Cannot migrate if sender is not admin" $ do+      integrationalTestExpectation $ do+        contract <- originateUpgradeableCounter+        withSender adversary (upgradeToV1 contract) `catchExpectedError`+          lExpectCustomError_ #senderIsNotAdmin++  describe "Administrator change" $ do+    it "Admin can set a new administrator" $ do+      integrationalTestExpectation $ do+        contract <- originateUpgradeableCounter+        withSender admin . lCallDef contract $ SetAdministrator admin2+        void $ withSender admin2 $ upgradeToV1 contract++    it "Non-admin cannot set a new administrator" $ do+      integrationalTestExpectation $ do+        contract <- originateUpgradeableCounter+        withSender adversary (lCallDef contract $ SetAdministrator admin2) `catchExpectedError`+          lExpectCustomError_ #senderIsNotAdmin
+ test/Test/Lorentz/Contracts/UpgradeableCounterSdu.hs view
@@ -0,0 +1,198 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.Lorentz.Contracts.UpgradeableCounterSdu+  ( spec_UpgradeableCounterSdu+  , test_Documentation+  ) where++import Lorentz (VoidResult(..), mkView, mkVoid)++import Data.Coerce (coerce)+import Test.Hspec (Spec, describe, it)+import Test.Tasty (TestTree)++import Lorentz.Constraints+import Lorentz.Contracts.Upgradeable.Common+import Lorentz.Contracts.Upgradeable.Test+import Lorentz.Contracts.UpgradeableCounterSdu+import qualified Lorentz.Contracts.UpgradeableCounterSdu.V1 as V1+import qualified Lorentz.Contracts.UpgradeableCounterSdu.V2 as V2+import Lorentz.Test+import Lorentz.Test.Doc+import Lorentz.UParam+import Lorentz.Value+import Util.Instances ()+import Util.Named++{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}++admin :: Address+admin = genesisAddress1++originateUpgradeableCounter+  :: IntegrationalScenarioM (UTAddress (CounterSduV 0))+originateUpgradeableCounter =+  lOriginate upgradeableCounterContractSdu "UpgradeableCounter"+    (mkEmptyStorage admin) (toMutez 1000)++originateUpgradeableCounterV1+  :: IntegrationalScenarioM (UTAddress (CounterSduV 1))+originateUpgradeableCounterV1 = do+  contract <- originateUpgradeableCounter+  withSender admin $ upgradeToV1 UpgEntrypointWise contract++upgradeToV1+  :: SimpleUpgradeWay+  -> UTAddress (CounterSduV 0)+  -> IntegrationalScenarioM (UTAddress (CounterSduV 1))+upgradeToV1 = integrationalTestUpgrade V1.counterUpgradeParameters++upgradeToV2+  :: SimpleUpgradeWay+  -> UTAddress (CounterSduV 1)+  -> IntegrationalScenarioM (UTAddress (CounterSduV 2))+upgradeToV2 = integrationalTestUpgrade V2.counterUpgradeParameters++upgradeV0ToV2+  :: SimpleUpgradeWay+  -> UTAddress (CounterSduV 0)+  -> IntegrationalScenarioM (UTAddress (CounterSduV 2))+upgradeV0ToV2 = integrationalTestUpgrade V2.counterUpgradeParametersFromV0++uCall+  :: forall a name (ver :: VersionKind) (interface :: [EntrypointKind]).+  ( interface ~ VerInterface ver+  , NicePackedValue a+  , PermConstraint ver+  , RequireUniqueEntrypoints interface+  , LookupEntrypoint name interface ~ a+  )+  => UTAddress ver+  -> Label name+  -> a+  -> IntegrationalScenarioM ()+uCall contract method arg = do+  lCallDef contract $ Run ((mkUParam method arg) :: UParam interface)++getCounterValueV1+  :: UTAddress (CounterSduV 1)+  -> IntegrationalScenarioM ()+getCounterValueV1 contract = do+  uCall contract #epGetCounterValue $ mkVoid ()++getCounterValueV2+  :: UTAddress (CounterSduV 2)+  -> IntegrationalScenarioM ()+getCounterValueV2 contract = do+  uCall contract #epGetCounterValue $ mkVoid ()++spec_UpgradeableCounterSdu :: Spec+spec_UpgradeableCounterSdu =+  forM_ [UpgOneShot, UpgEntrypointWise] $ \upgWay ->+  describe (show upgWay) $ do+    -- Most of the logic is covered in tests for similar 'UpgradeableCounter'+    -- contract (with entrypoint-wise migration way), not including such tests+    -- here, only ones on the main functionality+    describe "v1" $ do+      it "Updates counter after each operation" $ do+        integrationalTestExpectation $ do+          contract <- originateUpgradeableCounterV1++          uCall contract #epAdd (2 :: Natural)+          uCall contract #epInc ()+          getCounterValueV1 contract `catchExpectedError`+            lExpectError (== VoidResult @Natural 3)++      it "Can call permanent entrypoint" $ do+        integrationalTestExpectation $ do+          contract <- originateUpgradeableCounterV1++          uCall contract #epAdd (5 :: Natural)+          lCallEP contract (Call @"GetCounter") (mkVoid ()) `catchExpectedError`+            lExpectError (== VoidResult @Integer 5)++    describe "v2" $ do+      it "Upgrade and further operations work fine" $ do+        integrationalTestExpectation $ do+          contract <- originateUpgradeableCounterV1++          uCall contract #epAdd (2 :: Natural)++          offshoot "Before migration" $ do+            getCounterValueV1 contract `catchExpectedError`+              lExpectError (== VoidResult @Natural 2)++          contract2 <- withSender admin $ upgradeToV2 upgWay contract++          offshoot "Right after migration" $ do+            getCounterValueV2 contract2 `catchExpectedError`+              lExpectError (== VoidResult @Integer 2)++          offshoot "Cannot call removed entrypoint" $ do+            uCall contract #epAdd (5 :: Natural) `catchExpectedError`+              lExpectCustomError #uparamNoSuchEntrypoint [mt|epAdd|]++          uCall contract2 #epDec ()++          offshoot "After dec" $ do+            getCounterValueV2 contract2 `catchExpectedError`+              lExpectError (== VoidResult @Integer 1)++      it "Upgrade from scratch works fine" $+        integrationalTestExpectation $ do+          contractV0 <- originateUpgradeableCounter+          contract <- withSender admin $ upgradeV0ToV2 upgWay contractV0++          branchout+            [ "Can call operations" ?- do+                uCall contract #epInc ()+                uCall contract #epDec ()++            , "Version field has expected value" ?- do+                consumer <- lOriginateEmpty contractConsumer "consumer"+                lCallEP contract (Call @"GetVersion") (mkView () consumer)+                lExpectViewConsumerStorage consumer [2]+            ]++      it "Can decrease version" $ do+        integrationalTestExpectation $ do+          contractV2 <- originateUpgradeableCounterV1 >>=+                        withSender admin . upgradeToV2 upgWay++          contractV1 <-+            withSender admin $+              integrationalTestUpgrade V2.counterRollbackParameters upgWay contractV2++          consumer <- lOriginateEmpty contractConsumer "consumer"++          lCallDef contractV1 $ GetVersion (mkView () consumer)++          lExpectViewConsumerStorage consumer [1]++      it "Fails if wrong old version is provided" $ do+        integrationalTestExpectation $ do+          contract <- originateUpgradeableCounterV1+          withSender admin (upgradeV0ToV2 upgWay (coerce contract)) `catchExpectedError`+            lExpectCustomError #upgVersionMismatch+            (#expectedCurrent .! 0, #actualCurrent .! 1)++      it "Can call permanent entrypoint" $ do+        integrationalTestExpectation $ do+          contract <- originateUpgradeableCounterV1+          uCall contract #epAdd (5 :: Natural)++          contract2 <- withSender admin $ upgradeToV2 upgWay contract+          uCall contract2 #epInc ()+          lCallDef contract2 (RunPerm (GetCounter $ mkVoid ())) `catchExpectedError`+            lExpectError (== VoidResult @Integer 6)++test_Documentation :: [TestTree]+test_Documentation =+  runDocTests testSuites V1.counterDoc+  where+    testSuites =+      testUpgradeableContractDoc `excludeDocTests`+      [ testEachEntrypointIsDescribed+      ]
+ test/Test/Lorentz/Contracts/UserUpgradeable.hs view
@@ -0,0 +1,133 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Tests for user-defined upgrades++module Test.Lorentz.Contracts.UserUpgradeable+  ( test_UserUpgradeable+  ) where++import qualified Data.Map as Map+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)++import Lorentz (mkView)+import Lorentz.Contracts.UserUpgradeable.Migrations (MigrationTarget)+import qualified Lorentz.Contracts.UserUpgradeable.V1 as V1+import qualified Lorentz.Contracts.UserUpgradeable.V2 as V2+import Lorentz.Test+import Lorentz.Value++{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}++wallet1, admin :: Address+wallet1 = genesisAddress1+admin = genesisAddress2++originateV1 :: IntegrationalScenarioM (TAddress V1.Parameter)+originateV1 =+  lOriginate V1.userUpgradeableContract "UserUpgradeable V1"+    (V1.mkStorage balances admin) (toMutez 1000)+  where+    balances = BigMap $ Map.fromList+      [ (wallet1, 100)+      ]++originateV2+  :: TAddress V1.Parameter -> IntegrationalScenarioM (TAddress V2.Parameter)+originateV2 prevVersion =+  lOriginate V2.userUpgradeableContract "UserUpgradeable V2"+    (V2.mkStorage prevVersion) (toMutez 1000)++-- | A helper function that originates v1 and v2, and initiates an upgrade+-- from v1 to v2.+initMigration+  :: IntegrationalScenarioM (TAddress V1.Parameter, TAddress V2.Parameter)+initMigration = do+  v1 <- originateV1+  v2 <- originateV2 v1+  withSender admin $+    lCallDef v1 $ V1.InitiateMigration (migrateFromEntrypoint v2)+  return (v1, v2)++migrateMyTokens+  :: TAddress V1.Parameter -> Address -> Natural+  -> IntegrationalScenarioM ()+migrateMyTokens v1 wallet amount = do+  withSender wallet $+    lCallDef v1 $ V1.MigrateMyTokens amount++migrateFromEntrypoint :: TAddress V2.Parameter -> MigrationTarget+migrateFromEntrypoint c =+  fromContractRef . callingTAddress c $ Call @"MigrateFrom"++test_UserUpgradeable :: [TestTree]+test_UserUpgradeable =+  [ testCase "Arbitrary user can not initiate an upgrade" $+      integrationalTestExpectation $ do+        v1 <- originateV1+        v2 <- originateV2 v1+        lCallDef v1 (V1.InitiateMigration (migrateFromEntrypoint v2)) `catchExpectedError`+          lExpectCustomError_ #senderIsNotAdmin++  , testCase "Cannot initiate an upgrade twice" $+      integrationalTestExpectation $ do+        (v1, v2) <- initMigration+        withSender admin+          (lCallDef v1 $ V1.InitiateMigration (migrateFromEntrypoint v2))+          `catchExpectedError` lExpectCustomError_ #alreadyMigrating++  , testCase "Cannot call migrate if the migration is not initiated" $+      integrationalTestExpectation $ do+        v1 <- originateV1+        migrateMyTokens v1 wallet1 100 `catchExpectedError`+          lExpectCustomError_ #nowhereToMigrate++  , testCase "Migrations burn old tokens" $+      integrationalTestExpectation $ do+        (v1, _) <- initMigration+        consumer <- lOriginateEmpty @Natural contractConsumer "consumer"++        migrateMyTokens v1 wallet1 90+        migrateMyTokens v1 wallet1 9++        lCallDef v1 $ V1.GetBalance (mkView wallet1 consumer)+        lExpectViewConsumerStorage consumer [1]++  , testCase "Can migrate the whole balance" $+      integrationalTestExpectation $ do+        (v1, _) <- initMigration+        consumer <- lOriginateEmpty @Natural contractConsumer "consumer"++        migrateMyTokens v1 wallet1 100++        lCallDef v1 $ V1.GetBalance (mkView wallet1 consumer)+        lExpectViewConsumerStorage consumer [0]++  , testCase "Cannot migrate more than you have" $+      integrationalTestExpectation $ do+        (v1, _) <- initMigration++        migrateMyTokens v1 wallet1 101 `catchExpectedError`+          lExpectCustomError_ #userUpgradable'notEnoughTokens++  , testCase "Migrations mint new tokens" $+      integrationalTestExpectation $ do+        (v1, v2) <- initMigration+        consumer <- lOriginateEmpty @Natural contractConsumer "consumer"++        migrateMyTokens v1 wallet1 90+        migrateMyTokens v1 wallet1 9++        lCallDef v2 $ V2.GetBalance (mkView wallet1 consumer)+        lExpectViewConsumerStorage consumer [99]++  , testCase "Cannot call MigrateFrom directly" $+      integrationalTestExpectation $ do+        (_, v2) <- initMigration++        withSender wallet1+          (lCallDef v2 $ V2.MigrateFrom (wallet1, 100))+          `catchExpectedError` lExpectCustomError_ #userUpgradable'unauthorizedMigrateFrom+  ]
+ test/Test/Lorentz/UStore/Behaviour.hs view
@@ -0,0 +1,206 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Tests for Lorentz 'UStore'.+module Test.Lorentz.UStore.Behaviour+  ( test_Roundtrip+  , test_Conversions+  , test_Script+  ) where++import qualified Data.Map as M+import Hedgehog (Gen)+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Test.HUnit (Assertion, assertFailure, (@?=))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)++import Cleveland.Util+import Hedgehog.Gen.Lorentz.UStore (genUStoreFieldExt, genUStoreSubMap)+import Lorentz.Base+import Lorentz.Instr as L+import Lorentz.Pack+import Lorentz.Run+import Lorentz.Run.Simple+import Lorentz.UStore+import Lorentz.Value+import Michelson.Test.Dummy++data MyTemplate = MyTemplate+  { ints :: Integer |~> ()+  , bool :: UStoreField Bool+  } deriving stock (Eq, Show, Generic)++genMyTemplate :: Gen MyTemplate+genMyTemplate = MyTemplate+  <$> genUStoreSubMap (Gen.integral (Range.linearFrom 0 -1000 1000)) (pure ())+  <*> genUStoreFieldExt Gen.bool++data MyTemplateBig = MyTemplateBig+  { small :: MyTemplate+  , bytes :: ByteString |~> Natural+  , total :: UStoreField Integer+  } deriving stock (Eq, Show, Generic)++genMyTemplateBig :: Gen MyTemplateBig+genMyTemplateBig = MyTemplateBig+  <$> genMyTemplate+  <*> genUStoreSubMap (Gen.bytes (Range.linear 0 100)) (Gen.integral (Range.linear 0 1000))+  <*> genUStoreFieldExt (Gen.integral (Range.linearFrom 0 -1000 1000))++data MyMarker :: UStoreMarkerType+instance KnownUStoreMarker MyMarker where+  mkFieldMarkerUKey name = lPackValueRaw ([mt|X|] <> name)++data MyTemplateWithMarker = MyTemplateWithMarker+  { mint :: UStoreField Integer+  , mbool :: UStoreFieldExt MyMarker Bool+  } deriving stock (Eq, Show, Generic)++genMyTemplateWithMarker :: Gen MyTemplateWithMarker+genMyTemplateWithMarker = MyTemplateWithMarker+  <$> genUStoreFieldExt (Gen.integral (Range.linearFrom 0 -1000 1000))+  <*> genUStoreFieldExt Gen.bool++test_Roundtrip :: [TestTree]+test_Roundtrip =+  [ roundtripTree genMyTemplate (mkUStore @MyTemplate) ustoreDecomposeFull+  , roundtripTree genMyTemplateBig (mkUStore @MyTemplateBig) ustoreDecomposeFull+  , roundtripTree genMyTemplateWithMarker (mkUStore @MyTemplateWithMarker) ustoreDecomposeFull+  ]++test_Conversions :: [TestTree]+test_Conversions =+  [ testGroup "Simple store template"+    [ testCase "No action" $+        ustoreChangeTest+          ( nop+          , MyTemplate (UStoreSubMap def) (UStoreField False)+          , MyTemplate (UStoreSubMap def) (UStoreField False)+          )+    , testCase "Insert into submap" $+        ustoreChangeTest+          ( unit # push 5 # ustoreInsert #ints+          , MyTemplate (UStoreSubMap def) (UStoreField False)+          , MyTemplate (UStoreSubMap $ one (5, ())) (UStoreField False)+          )+    , testCase "Delete from submap" $+        ustoreChangeTest+          ( push 3 # ustoreDelete #ints+          , MyTemplate (UStoreSubMap $ one (3, ())) (UStoreField False)+          , MyTemplate (UStoreSubMap mempty) (UStoreField False)+          )+    , testCase "Get from submap" $+        ustoreChangeTest+          ( dup # push 0 # ustoreGet #ints #+            ifNone (push 10) (L.drop # push 11) # dip unit # ustoreInsert #ints+          , MyTemplate (UStoreSubMap $ one (0, ())) (UStoreField False)+          , MyTemplate (UStoreSubMap $ M.fromList [(0, ()), (11, ())]) (UStoreField False)+          )+    , testCase "Set field" $+        ustoreChangeTest+          ( push True # ustoreSetField #bool+          , MyTemplate (UStoreSubMap mempty) (UStoreField False)+          , MyTemplate (UStoreSubMap mempty) (UStoreField True)+          )+    , testCase "Get field" $+        ustoreChangeTest+          ( ustoreGetField #bool #+            if_ (push 5) (push 0) # dip unit # ustoreInsert #ints+          , MyTemplate (UStoreSubMap mempty) (UStoreField False)+          , MyTemplate (UStoreSubMap $ one (0, ())) (UStoreField False)+          )+    , testCase "Leave some entries untouched" $+        ustoreChangeTest+          ( push 0 # ustoreDelete #ints #+            unit # push 2 # ustoreInsert #ints+          , MyTemplate (UStoreSubMap $ M.fromList [(0, ()), (1, ())]) (UStoreField False)+          , MyTemplate (UStoreSubMap $ M.fromList [(1, ()), (2, ())]) (UStoreField False)+          )+    ]++  , testGroup "Non-flat store template"+    [ testCase "Custom scenario 1" $+        ustoreChangeTest+          ( push "a" # ustoreDelete #bytes #+            push 2 # push "b" # ustoreInsert #bytes #+            ustoreGetField #total # push @Integer 1 # add # ustoreSetField #total #+            unliftUStore #small #+            unit # push 0 # ustoreInsert #ints #+            push True # ustoreSetField #bool #+            liftUStore #small+          , MyTemplateBig+            { small = MyTemplate (UStoreSubMap def) (UStoreField False)+            , bytes = UStoreSubMap $ one ("a", 1)+            , total = UStoreField 10+            }+          , MyTemplateBig+            { small = MyTemplate (UStoreSubMap $ one (0, ())) (UStoreField True)+            , bytes = UStoreSubMap $ one ("b", 2)+            , total = UStoreField 11+            }+          )+    ]+  ]+  where+    -- We accept a tuple as argument to avoid many parentheses+    ustoreChangeTest+      :: ( Each [Eq, Show, Generic] '[template]+         , UStoreTraversable MkUStoreTW template+         , UStoreTraversable DecomposeUStoreTW template+         , HasCallStack+         )+      => ( '[UStore template] :-> '[UStore template]+         , template+         , template+         )+      -> Assertion+    ustoreChangeTest (instr, initStoreHs, expectedNewStore) =+      let+        initStore = mkUStore initStoreHs+        ustore = instr -$ initStore+      in case ustoreDecomposeFull ustore of+          Left err -> assertFailure (toString err)+          Right ustoreHs -> ustoreHs @?= expectedNewStore++test_Script :: [TestTree]+test_Script =+  [ testCase "Only fields" $+      ustoreScriptTest MyTemplate+        { ints = UStoreSubMap mempty+        , bool = UStoreField True+        }++  , testCase "Fields and submaps" $+      ustoreScriptTest MyTemplate+        { ints = UStoreSubMap $ one (5, ())+        , bool = UStoreField True+        }++  , testCase "Complex" $+      ustoreScriptTest MyTemplateBig+        { small = MyTemplate (UStoreSubMap $ one (0, ())) (UStoreField True)+        , bytes = UStoreSubMap $ one ("b", 2)+        , total = UStoreField 11+        }+  ]+  where+    ustoreScriptTest+      :: ( Each [Eq, Show, Generic] '[template]+         , UStoreTraversable FillUStoreTW template+         , UStoreTraversable DecomposeUStoreTW template+         , HasCallStack+         )+      => template+      -> Assertion+    ustoreScriptTest store =+      let+        filling = migrationToLambda (fillUStore store)+        ustoreFilled =+          leftToPrettyPanic $+          interpretLorentzLambda dummyContractEnv filling (mkUStore ())+      in case ustoreDecomposeFull ustoreFilled of+          Left err -> assertFailure (toString err)+          Right ustoreHs -> ustoreHs @?= store
+ test/Test/Lorentz/UStore/Migration/Batched.hs view
@@ -0,0 +1,80 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.Lorentz.UStore.Migration.Batched+  ( test_Separated_lambdas+  ) where++import qualified Data.Map as M+import Test.HUnit ((@?=))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase)++import qualified Lorentz as L+import Lorentz.UStore+import Lorentz.UStore.Migration++import qualified Test.Lorentz.UStore.Migration.Batched.V1 as V1+import qualified Test.Lorentz.UStore.Migration.Batched.V2 as V2++initMigration :: UStoreMigration () V1.MyTemplate+initMigration = fillUStore V1.MyTemplate+  { bytes = UStoreSubMap $ M.fromList [(1, "a"), (2, "b")]+  , int1 = UStoreField 1+  , int2 = UStoreField 2+  , code1 = UStoreField L.nop+  , code2 = UStoreField L.int+  , code3 = UStoreField L.nop+  }++v2migration :: UStoreMigration V1.MyTemplate V2.MyTemplate+v2migration = mkUStoreBatchedMigration $+  muBlock $:+    L.push @Natural 1 L.#+    migrateOverwriteField #int1+  <-->+  muBlock $:+    migrateRemoveField #int2+  <-->+  muBlock $:+    -- Normally such joined blocks should not be present, but we+    -- want to test different scenarios+    L.push L.nop L.#+    migrateModifyField #code1 L.#++    migrateRemoveField #code2+  <-->+  muBlock $:+    migrateRemoveField #code3+  <-->+  migrationFinish++test_Separated_lambdas :: [TestTree]+test_Separated_lambdas =+  [ testGroup "V0 -> V1" $+      let cmigration = compileMigration mbSeparateLambdas initMigration+      in+    [ testCase "Split is correct" $+        (slbiType <$> migrationToInfo cmigration)+        @?=+        [ SlbtData+        , SlbtLambda+        , SlbtLambda+        , SlbtLambda+        ]+    ]++  , testGroup "V1 -> V2" $+      let cmigration = compileMigration mbSeparateLambdas v2migration+      in+    [ testCase "Split is correct" $+        (slbiType <$> migrationToInfo cmigration)+        @?=+        [ SlbtData+        , SlbtLambda+        , SlbtLambda+          -- Lambda removals should not be put separatelly, so one lambda is gone+        ]+    ]+  ]
+ test/Test/Lorentz/UStore/Migration/Batched/V1.hs view
@@ -0,0 +1,19 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.Lorentz.UStore.Migration.Batched.V1+  ( MyTemplate (..)+  ) where++import Lorentz.Base+import Lorentz.UStore++data MyTemplate = MyTemplate+  { bytes :: Integer |~> ByteString+  , int1 :: UStoreField Integer+  , int2 :: UStoreField Integer+  , code1 :: UStoreField $ Lambda () ()+  , code2 :: UStoreField $ Lambda Natural Integer+  , code3 :: UStoreField $ Lambda () ()+  } deriving stock Generic
+ test/Test/Lorentz/UStore/Migration/Batched/V2.hs view
@@ -0,0 +1,16 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.Lorentz.UStore.Migration.Batched.V2+  ( MyTemplate (..)+  ) where++import Lorentz.Base+import Lorentz.UStore++data MyTemplate = MyTemplate+  { bytes :: Integer |~> ByteString+  , int1 :: UStoreField Natural+  , code1 :: UStoreField $ Lambda () ()+  } deriving stock Generic
+ test/Test/Lorentz/UStore/Migration/FillInParts.hs view
@@ -0,0 +1,81 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.Lorentz.UStore.Migration.FillInParts+  ( test_Migration_works+  ) where++import Test.HUnit (assertFailure, (@?=))+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)++import qualified Lorentz as L+import Lorentz.Run.Simple+import Lorentz.UStore+import Lorentz.UStore.Haskell+import Lorentz.UStore.Migration+import Michelson.Text++data MyTemplateWrapper substore = MyTemplateWrapper+  { commonField :: UStoreField MText+  , custom :: substore+  } deriving stock (Eq, Show, Generic)++data MySubTemplatePart1 = MySubTemplatePart1+  { int :: UStoreField Integer+  , nat :: UStoreField Natural+  } deriving stock (Eq, Show, Generic)++part1Val :: MySubTemplatePart1+part1Val = MySubTemplatePart1{ int = UStoreField -1, nat = UStoreField 1 }++data MySubTemplatePart2 = MySubTemplatePart2+  { string :: UStoreField MText+  } deriving stock (Eq, Show, Generic)++part2Val :: MySubTemplatePart2+part2Val = MySubTemplatePart2{ string = UStoreField [mt|bb|] }++type MyTemplateV0 = MyTemplateWrapper ()++type MyTemplateV1 = MyTemplateWrapper (MySubTemplatePart1, MySubTemplatePart2)++migrationBatched :: UStoreMigration MyTemplateV0 MyTemplateV1+migrationBatched = mkUStoreBatchedMigration $+  muBlock $:+    L.push [mt|bb|] L.#+    migrateModifyField #commonField+  <-->+  fillUStoreMigrationBlock part1Val+  <-->+  fillUStoreMigrationBlock part2Val+  <-->+  migrationFinish++migrationSimple :: UStoreMigration MyTemplateV0 MyTemplateV1+migrationSimple = mkUStoreMigration $+  L.push [mt|bb|] L.# migrateModifyField #commonField L.#+  migrateFillUStore part1Val L.#+  migrateFillUStore part2Val L.#+  migrationFinish++test_Migration_works :: [TestTree]+test_Migration_works =+  [ ("simple migration", migrationSimple)+  , ("batched migration", migrationBatched)+  ] <&> \(desc, migration) ->+    testCase desc $ migratesToWith migration+      MyTemplateWrapper+      { commonField = UStoreField [mt|aa|]+      , custom = ()+      }+      MyTemplateWrapper+      { commonField = UStoreField [mt|bb|]+      , custom = (part1Val, part2Val)+      }+  where+    migratesToWith migration storeV1 expectedStoreV2 =+      either (assertFailure . toString) (@?= expectedStoreV2) $ do+        let storeV2 = migrationToLambda migration -$ mkUStore storeV1+        ustoreDecomposeFull storeV2
+ test/Test/Lorentz/UStore/Migration/Simple.hs view
@@ -0,0 +1,79 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.Lorentz.UStore.Migration.Simple+  ( test_Migration_works+  ) where++import Test.HUnit (assertFailure, (@?=))+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)++import qualified Lorentz as L+import Lorentz.Run.Simple+import Lorentz.UStore+import Lorentz.UStore.Migration+import Lorentz.UStore.Migration.Diff+import Michelson.Text++import qualified Test.Lorentz.UStore.Migration.Simple.V1 as V1+import qualified Test.Lorentz.UStore.Migration.Simple.V2 as V2++_checkDiff :: Proxy (BuildDiff V1.MyTemplate V2.MyTemplate)+_checkDiff = Proxy @+  [ '( 'ToAdd, '("theName", UStoreField MText))+  , '( 'ToAdd, '("transformed", UStoreField Integer))+  , '( 'ToDel, '("useless", UStoreField MText))+  , '( 'ToDel, '("transformed", UStoreField Natural))+  ]++migrationBatched :: UStoreMigration V1.MyTemplate V2.MyTemplate+migrationBatched = mkUStoreBatchedMigration $+  muBlock $:+    migrateExtractField #useless L.#+    L.push [mt|Token-|] L.#+    L.concat L.#+    migrateAddField #theName+  <-->+  muBlock $:+    L.push 3 L.#+    migrateOverwriteField #transformed+  <-->+  migrationFinish++migrationSimple :: UStoreMigration V1.MyTemplate V2.MyTemplate+migrationSimple = mkUStoreMigration $+  migrateExtractField #useless L.#+  L.push [mt|Token-|] L.#+  L.concat L.#+  migrateAddField #theName L.#++  L.push 3 L.#+  migrateOverwriteField #transformed L.#++  migrationFinish++test_Migration_works :: [TestTree]+test_Migration_works =+  [ ("simple migration", migrationSimple)+  , ("batched migration", migrationBatched)+  ] <&> \(desc, migration) ->+    testCase desc $ migratesWith migration+      V1.MyTemplate+      { V1.bytes = UStoreSubMap mempty+      , V1.count = UStoreField 5+      , V1.useless = UStoreField [mt|pog|]+      , V1.transformed = UStoreField 10+      }+      V2.MyTemplate+      { V2.theName = UStoreField [mt|Token-pog|]+      , V2.bytes = UStoreSubMap mempty+      , V2.count = UStoreField 5+      , V2.transformed = UStoreField 3+      }+  where+    migratesWith migration storeV1 expectedStoreV2 =+      either (assertFailure . toString) (@?= expectedStoreV2) $ do+        let storeV2 = migrationToLambda migration -$ mkUStore storeV1+        ustoreDecomposeFull storeV2
+ test/Test/Lorentz/UStore/Migration/Simple/V1.hs view
@@ -0,0 +1,17 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.Lorentz.UStore.Migration.Simple.V1+  ( MyTemplate (..)+  ) where++import Lorentz.UStore+import Lorentz.Value++data MyTemplate = MyTemplate+  { bytes :: Integer |~> ByteString+  , count :: UStoreField Integer+  , useless :: UStoreField MText+  , transformed :: UStoreField Natural+  } deriving stock Generic
+ test/Test/Lorentz/UStore/Migration/Simple/V2.hs view
@@ -0,0 +1,17 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++module Test.Lorentz.UStore.Migration.Simple.V2+  ( MyTemplate (..)+  ) where++import Lorentz.UStore+import Lorentz.Value++data MyTemplate = MyTemplate+  { theName :: UStoreField MText+  , bytes :: Integer |~> ByteString+  , count :: UStoreField Integer+  , transformed :: UStoreField Integer+  } deriving stock (Eq, Show, Generic)
+ test/Test/Lorentz/UStore/SafeLift.hs view
@@ -0,0 +1,46 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | We have a constraint in 'ustoreLift' which+-- forbids nested store templates with duplicated fields.+-- This module checks this constraint will work fine.+module Test.Lorentz.UStore.SafeLift+  ( test_UStore_lift+  ) where++import Data.Typeable ((:~:)(..))+import Test.Tasty (TestTree)++import Lorentz.UStore+import Lorentz.UStore.Lift++import Test.Lorentz.UStore.SafeLift.Helpers++-- Fake tests to deceive "weeder".+-- All the test suite consist of typechecking some stuff, see below.+test_UStore_lift :: [TestTree]+test_UStore_lift = []++_checkDuplicates0 :: UStoreFieldsAreUnique MySimpleTemplate :~: 'True+_checkDuplicates0 = Refl++data MyTemplateBig = MyTemplateBig+  { ints :: Integer |~> Natural+  , small :: MySimpleTemplate+  } deriving stock (Generic)++_checkDuplicates1 :: UStoreFieldsAreUnique MyTemplateBig :~: 'False+_checkDuplicates1 = Refl++data MyTemplate2 = MyTemplate2+  { bool :: UStoreField Bool+  } deriving stock (Generic)++data MyTemplateSuperBig = MyTemplateSuperBig+  { ssmall :: MySimpleTemplate+  , ssmall2 :: MyTemplate2+  } deriving stock (Generic)++_checkDuplicates2 :: UStoreFieldsAreUnique MyTemplateSuperBig :~: 'False+_checkDuplicates2 = Refl
+ test/Test/Lorentz/UStore/SafeLift/Helpers.hs view
@@ -0,0 +1,18 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Contains a template for safe lifting check.+--+-- We are going to define another template with the same field name,+-- so putting this template in a separate module.+module Test.Lorentz.UStore.SafeLift.Helpers+  ( MySimpleTemplate (..)+  ) where++import Lorentz.UStore++data MySimpleTemplate = MySimpleTemplate+  { ints :: Integer |~> ()+  , bool :: UStoreField Bool+  } deriving stock (Generic)
+ test/Test/Lorentz/UStore/StoreClass.hs view
@@ -0,0 +1,74 @@+-- SPDX-FileCopyrightText: 2021 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++-- | Tests for Lorentz 'UStore'.+module Test.Lorentz.UStore.StoreClass+  ( test_Fields+  , test_Submaps+  ) where++import Test.HUnit ((@?=))+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (testCase)++import Lorentz.ADT+import Lorentz.Run.Simple+import Lorentz.StoreClass+import Lorentz.UStore+import Lorentz.Value++data MyTemplate = MyTemplate+  { ints :: Integer |~> ()+  , flag :: UStoreField Bool+  } deriving stock (Eq, Show, Generic)++initTemplate :: MyTemplate+initTemplate = MyTemplate+  { ints = UStoreSubMap mempty+  , flag = UStoreField False+  }++data Storage = Storage+  { dummy :: ()+  , upgradeable :: UStore MyTemplate+  } deriving stock (Generic)+    deriving anyclass (IsoValue)++instance HasFieldOfType Storage name ty =>+         StoreHasField Storage name ty where+  storeFieldOps = storeFieldOpsADT++initStorage :: Storage+initStorage = Storage () (mkUStore initTemplate)++test_Fields :: [TestTree]+test_Fields =+  [ testCase "Get field" $+      mkUStore initTemplate+      &- stToField #flag+      @?= False++  , testCase "Set field" $+      (True, mkUStore initTemplate)+      &- stSetField #flag+      @?= mkUStore initTemplate{ flag = UStoreField True }++  , testCase "Nested access" $+      initStorage+      &- stToField (#upgradeable :-| #flag)+      @?= False+  ]++test_Submaps :: [TestTree]+test_Submaps =+  [ testCase "Get submap entry" $+      (5, mkUStore initTemplate)+      &- stMem #ints+      @?= False++  , testCase "Update submap entry" $+      (5, ((), mkUStore initTemplate))+      &- stInsert #ints+      @?= mkUStore initTemplate{ ints = UStoreSubMap $ one (5, ()) }+  ]
+ test/Tree.hs view
@@ -0,0 +1,5 @@+-- SPDX-FileCopyrightText: 2020 Tocqueville Group+--+-- SPDX-License-Identifier: LicenseRef-MIT-TQ++{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --tree-display -optF --generated-module -optF Tree #-}