diff --git a/.editorconfig b/.editorconfig new file mode 100644 index 00000000000..3762e9ed18f --- /dev/null +++ b/.editorconfig @@ -0,0 +1,17 @@ +root = true + +[*] +indent_style = space +indent_size = 2 +end_of_line = lf +charset = utf-8 +trim_trailing_whitespace = true +insert_final_newline = true + +[Makefile] +indent_style = tab +indent_size = 8 + +[*.hs] +indent_size = 4 +max_line_length = 80 diff --git a/.gitignore b/.gitignore index 03c092ac7a7..af4f9a21571 100644 --- a/.gitignore +++ b/.gitignore @@ -27,6 +27,7 @@ wdb-*/ keys !secrets/*.key !scripts/tls-files/server.key +tmp-secrets/ # Node runtime data logs @@ -58,14 +59,14 @@ tags* *.swp # Compiled-scripts cruft -scripts/haskell/dependencies.hs scripts/haskell/dependencies.hi scripts/haskell/dependencies.o scripts/haskell/dependencies # 'pkgs/stack2nix' is a symlink into the nix store, it can safely be ignored pkgs/stack2nix -nixpkgs # in case generate.sh clones nixpkgs in here +# in case generate.sh clones nixpkgs in here +nixpkgs pkgs/result # explorer @@ -84,6 +85,9 @@ custom-wallet-config.nix wallet-new/bench/results/*.csv wallet-new/bench/results/*.txt +# wallet web API golden tests +wallet-new/test/golden/*.txt.new + # cardano-state-* for wallet data cardano-state-* state-* @@ -94,3 +98,112 @@ exchange-topology.yaml # launch scripts launch_* result* +*.patch + +# remove when done debugging +1.1.1-1-w/ + + +# Created by https://www.gitignore.io/api/python + +### Python ### +# Byte-compiled / optimized / DLL files +__pycache__/ +*.py[cod] +*$py.class + +# C extensions +*.so + +# Distribution / packaging +.Python +build/ +develop-eggs/ +dist/ +downloads/ +eggs/ +.eggs/ +# lib/ +# lib64/ +parts/ +sdist/ +var/ +wheels/ +*.egg-info/ +.installed.cfg +*.egg + +# PyInstaller +# Usually these files are written by a python script from a template +# before PyInstaller builds the exe, so as to inject date/other infos into it. +*.manifest +*.spec + +# Installer logs +pip-log.txt +pip-delete-this-directory.txt + +# Unit test / coverage reports +htmlcov/ +.tox/ +.coverage +.coverage.* +.cache +.pytest_cache/ +nosetests.xml +coverage.xml +*.cover +.hypothesis/ + +# Translations +*.mo +*.pot + +# Flask stuff: +instance/ +.webassets-cache + +# Scrapy stuff: +.scrapy + +# Sphinx documentation +docs/_build/ + +# PyBuilder +target/ + +# Jupyter Notebook +.ipynb_checkpoints + +# pyenv +.python-version + +# celery beat schedule file +celerybeat-schedule.* + +# SageMath parsed files +*.sage.py + +# Environments +.env +.venv +env/ +venv/ +ENV/ +env.bak/ +venv.bak/ + +# Spyder project settings +.spyderproject +.spyproject + +# Rope project settings +.ropeproject + +# mkdocs documentation +/site + +# mypy +.mypy_cache/ + +# End of https://www.gitignore.io/api/python diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 00000000000..747875b7aa5 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,93 @@ +# HLint configuration file +# https://github.com/ndmitchell/hlint +########################## + +# This file contains a template configuration file, which is typically +# placed as .hlint.yaml in the root of your project + +- arguments: [-XTypeApplications, --cpp-define=CONFIG=dev] + +- ignore: {name: Redundant do} +- ignore: {name: Redundant bracket} +- ignore: {name: Redundant $} +- ignore: {name: Redundant flip} +- ignore: {name: Move brackets to avoid $} +- ignore: {name: Eta reduce} +- ignore: {name: Avoid lambda} +- ignore: {name: Use camelCase} +- ignore: {name: Use const} +- ignore: {name: Use if} +- ignore: {name: Use notElem} +- ignore: {name: Use fromMaybe} +- ignore: {name: Use maybe} +- ignore: {name: Use fmap} +- ignore: {name: Use foldl} +- ignore: {name: 'Use :'} +- ignore: {name: Use ++} +- ignore: {name: Use ||} +- ignore: {name: Use &&} +- ignore: {name: 'Use ?~'} +- ignore: {name: Use <$>} +- ignore: {name: Use .} +- ignore: {name: Use head} +- ignore: {name: Use String} +- ignore: {name: Use Foldable.forM_} +- ignore: {name: Unused LANGUAGE pragma} +- ignore: {name: Use newtype instead of data} +# Rules not found in old HLint.hs file (prior to HLint 2.0) +# Added when we made the change. +- ignore: {name: Redundant lambda} +- ignore: {name: Use section} + +# Specify additional command line arguments +# +# - arguments: [--color, --cpp-simple, -XQuasiQuotes] + + +# Control which extensions/flags/modules/functions can be used +# +# - extensions: +# - default: false # all extension are banned by default +# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used +# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module +# +# - flags: +# - {name: -w, within: []} # -w is allowed nowhere +# +# - modules: +# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' +# - {name: Control.Arrow, within: []} # Certain modules are banned entirely +# +# - functions: +# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules + + +# Add custom hints for this project +# +# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" +# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} + + +# Turn on hints that are off by default +# +# Ban "module X(module X) where", to require a real export list +# - warn: {name: Use explicit module export list} +# +# Replace a $ b $ c with a . b $ c +# - group: {name: dollar, enabled: true} +# +# Generalise map to fmap, ++ to <> +# - group: {name: generalise, enabled: true} + + +# Ignore some builtin hints +# - ignore: {name: Use let} +# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules + + +# Define some custom infix operators +# - fixity: infixr 3 ~^#^~ + + +# To generate a suitable file for HLint do: +# $ hlint --default > .hlint.yaml diff --git a/.nonsense b/.nonsense index aebfc75ecef..392775099d2 100644 --- a/.nonsense +++ b/.nonsense @@ -1,2 +1,3 @@ File with no meaning, just to trigger CI rebuild +trigger! diff --git a/CHANGELOG.md b/CHANGELOG.md index 565268d5cf7..3eef0ffed04 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,10 +1,78 @@ # CHANGELOG +## Cardano SL 1.3.0 (Mainnet) + +### Features + +- The V1 API and its test coverage are finalized (CBR-101). + +- Expose SubscriptionStatus as part of /api/v1/node-info (CBR-186). + +- Better error message for missing charset (Wallet Backend - CBR-223). + +- Create AVVM mnemonic page screenshot (CBR-281). + +- Sending raw data, without deserialization, to the network using diffusion layer (CBR-277). + +- Speed up block retrieval (CDEC-49). + +- Back port Timer to Pos.Diffusion.Subscription.Common (CDEC-243). + +- Message size limits should not be configurable (CDEC-260). + +- Consolidate the block and undo into a single file per block (CDEC-293). + +- Upgrade to GHC 8.2.2 (CBR-51). + +### Specifications & documentation + +- The formal specifications for the new wallet backend are finished (CBR-60). + +- Document the new Wallet V1 API (CBR-102, CBR-183, CO-105 & CBR-278). + +- Write a devops guide for the Exchanges (CBR-137). + +- Feedback about the current Wallet API has been collected from Exchanges (CBR-104). + +- Complete Peer Discovery (P2P) design (CDEC-157). + +- Specification of shared seed generation via VSS (CDEC-180). + +- Specification of Randomness Generation (CDEC-208). + +- As-is specifications of ATRedeem addresses (CDEC-366). + +### Testing + +- Implement WalletActiveLayer & WalletPassiveLayer for wallet testing purposes (CBR-163). + +- Add integration deterministic tests for the Transaction endpoints (CBR-184). + +### Fixes + +- High (and recurrent) IO traffic in Wallet is solved by removing bad logging of made transaction (CBR-83). + +- V1 API wallet restoration issues solved by using asynchronous restoration (CBR-185). + +- Fix AppVeyor hard limitation on Windows (CBR-268). + +- Node doesn't reconnect to the network (CDEC-259). + +- Wallet balance shows wrong Ada amount. Transaction is irrelevant to given wallet (CO-256). + +- Fix tmux versions in demo-script (CO-295). + +- Cannot create a Wallet via API V1 Wallet API (CO-315). + +- Clean script fails if file is missing (CO-316). + +- The endpoint /api/settings/time/difference sometimes returns incorrect value (TSD-42). + ## Cardano SL 1.2.1 (Mainnet) Bug fix release. -- The wallet launcher now uses a lock file. This prevents problems on +- The Wallet Launcher now uses a lock file. This prevents problems on Windows if upgrading Daedalus while the old version is still running. (DEVOPS-872) diff --git a/CODEOWNERS b/CODEOWNERS index 5fe4a6b5df0..902ee5f3695 100644 --- a/CODEOWNERS +++ b/CODEOWNERS @@ -1,42 +1,38 @@ -# Unless a later match takes precedence, @gromakovsky will be requested -# for review when someone opens a pull request, because @gromakovsky -# is the Head Vulture of this project. +# Unless a later match takes precedence, @erikd will be requested +# for review when someone opens a pull request. Anybody who would +# like to be added as a reviewer should feel free to add themselves +# below. -* @gromakovsky +* @erikd # Order is important; the last matching pattern takes the most precedence. *.purs @akegalj # Explorer -explorer/ @akegaljj +explorer/ @akegalj explorer/frontend/ @sectore explorer/src/ @ksaric -explorer/src/Pos/Explorer/Socket/ @martoon explorer/test/ @ksaric # CI, Nix -*.nix @domenkozar -appveyor.yml @domenkozar -nixpkgs-src.json @domenkozar -pkgs/generate.sh @domenkozar +*.nix @iohk-devops +appveyor.yml @iohk-devops +nixpkgs-src.json @iohk-devops +pkgs/generate.sh @iohk-devops pkgs/default.nix @ignore-autogenerated-file scripts/ci/ @iohk-devops .buildkite/ @iohk-devops scripts/set_nixpath.sh @iohk-devops -# Documentation -*.md @denisshevchenko - -Delegation/ @volhovm - -txp/ @gromakovsky @pva701 -update/ @gromakovsky @pva701 -lrc/ @pva701 -ssc/ @gromakovsky - -lib/test/ @rockbmb -lib/test/Test/Pos/Block/Logic/ @gromakovsky +# Core components not included in the catch all above. +delegation/ @akegalj +txp/ @erikd +update/ @adinapoli-iohk @parsonsmatt +lrc/ @akegalj +ssc/ @parsonsmatt +lib/test/ @erikd +crypto/ @vincenthz # Networking infra/Pos/Network @dcoutts @avieth @@ -47,9 +43,8 @@ networking/ @dcoutts @avieth scripts/bench @kantp @avieth # Wallet -wallet/ @martoon @akegalj @adinapoli-iohk -wallet/web-api-swagger @martoon @adinapoli-iohk -wallet-new/ @adinapoli-iohk - -## Auxx -auxx @int-index +wallet/ @adinapoli-iohk @akegalj +wallet/web-api-swagger @adinapoli-iohk +wallet-new/ @adinapoli-iohk @parsonsmatt @denisshevchenko +wallet-new/coq-formal-spec/* @edsko @polinavino +wallet-new/docs/spec.* @edsko @dcoutts diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index a4799981e61..780be37e9dd 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -1,5 +1,12 @@ # Contributors Guide +## Discussion + +Developer discussion can be found on the official Telegram channel [here](https://t.me/CardanoDevelopersOfficial). +This channel is intended as a developer/contribution channel. It should not be used for customer support requests, +comedy/memes, or price talk. Feel free to discuss current issues, future possibilities, and visions for how you +think Cardano should progress. + ## Bug Reports Please [open an issue](https://github.com/input-output-hk/cardano-sl/issues/new) @@ -27,6 +34,12 @@ Please make sure your contributions adhere to our coding guidelines: Please note that Cardano SL uses a custom prelude [Universum](https://github.com/serokell/universum) instead of the default one. +### Development Tricks + +Common tasks for development are kept in `Makefile`s, one per package and one for the whole project. +Run `make help` to get assistance on custom commands. +As an example, you can run `make ghcid-test` in the `wallet-new` package to get a test-running `ghcid` process running. + ### Code Quality Cardano SL uses [HLint](https://github.com/ndmitchell/hlint) as a code quality tool. @@ -49,11 +62,14 @@ configuration file requires `stylish-haskell` version `0.8.1.0` or newer. You can install it using `stack install stylish-haskell` command. +We also use [`editorconfig`](https://editorconfig.org/) to maintain consistent indentation and maximum line length. +You can [download a plugin](https://editorconfig.org/#download) for almost any common editor. + ## Documentation Cardano SL Documentation is published at [cardanodocs.com](https://cardanodocs.com). -Please note that we have a [separate repository for documentation](https://github.com/input-output-hk/cardanodocs.com/). +Please note that we have a [separate repository for documentation](https://github.com/input-output-hk/cardanodocs.com/). So if you would like to help with documentation, please [submit a pull request](https://github.com/input-output-hk/cardanodocs.com/pulls) with your changes/additions. diff --git a/HLint.hs b/HLint.hs deleted file mode 100644 index afddd3d5073..00000000000 --- a/HLint.hs +++ /dev/null @@ -1,516 +0,0 @@ ----------------------------------------------------------------------------- --- Settings ----------------------------------------------------------------------------- - -import "hint" HLint.Default -import "hint" HLint.Builtin.All - --- These are just too annoying -ignore "Redundant do" -ignore "Redundant bracket" -ignore "Redundant lambda" -ignore "Redundant $" -ignore "Redundant flip" -ignore "Move brackets to avoid $" - --- Losing variable names can be not-nice -ignore "Eta reduce" -ignore "Avoid lambda" - --- Humans know better -ignore "Use camelCase" -ignore "Use const" -ignore "Use section" -ignore "Use if" -ignore "Use notElem" -ignore "Use fromMaybe" -ignore "Use maybe" -ignore "Use fmap" -ignore "Use foldl" -ignore "Use :" -ignore "Use ++" -ignore "Use ||" -ignore "Use &&" - --- There's no 'head' in Universum -ignore "Use head" - --- Sometimes [Char] is okay (if it means "a set of characters") -ignore "Use String" - --- We have 'whenJust' for this -ignore "Use Foldable.forM_" - --- Sometimes TemplateHaskell is needed to please stylish-haskell -ignore "Unused LANGUAGE pragma" - --- Some 'data' records will be extended with more fields later, --- so they shouldn't be replaced with 'newtype' blindly -ignore "Use newtype instead of data" - - ----------------------------------------------------------------------------- --- Hints with 'id' should use 'identity' ----------------------------------------------------------------------------- - -warn = any identity ==> or -warn = all identity ==> and -warn = (x >>= identity) ==> join x -warn = (identity =<< x) ==> join x -warn = mapM identity ==> sequence -warn = mapM_ identity ==> sequence_ --- This hint had to be given a name because we ignore "Use fromMaybe" above --- but we want to keep this one – so we add single quotes here -warn "Use 'fromMaybe'" = maybe x identity ==> fromMaybe x -warn = mapMaybe identity ==> catMaybes -warn = maybe Nothing identity ==> join - - ----------------------------------------------------------------------------- --- Various stuff ----------------------------------------------------------------------------- - -warn "Avoid 'both'" = both ==> Control.Lens.each - where - note = "If you use 'both' on a 2-tuple and later it's accidentally\n\ - \replaced with a longer tuple, 'both' will be silently applied to only\n\ - \the *last two elements* instead of failing with a type error.\n\ - \ * If you want to traverse all elements of the tuple, use 'each'.\n\ - \ * If 'both' is used on 'Either' here, replace it with 'chosen'." - -warn = either (const True) (const False) ==> isLeft -warn = either (const False) (const True) ==> isRight - -warn = Data.Map.toAscList (Data.Map.fromList x) ==> - Universum.sortWith fst x -warn = Data.Map.toDescList (Data.Map.fromList x) ==> - Universum.sortWith (Down . fst) x - -warn = map fst &&& map snd ==> unzip - - ----------------------------------------------------------------------------- --- Universum ----------------------------------------------------------------------------- - -warn = Data.Text.pack ==> Universum.toText -warn = Data.Text.unpack ==> Universum.toString - -warn = Data.Text.Lazy.pack ==> Universum.toLText -warn = Data.Text.Lazy.unpack ==> Universum.toString - -warn = Data.Text.Lazy.toStrict ==> Universum.toText -warn = Data.Text.Lazy.fromStrict ==> Universum.toLText - -warn = Data.Text.pack (show x) ==> Universum.show x -warn = Data.Text.Lazy.pack (show x) ==> Universum.show x - -warn = Control.Exception.evaluate ==> evaluateWHNF -warn = Control.Exception.evaluate (force x) ==> evaluateNF x -warn = Control.Exception.evaluate (x `deepseq` ()) ==> evaluateNF_ x - -warn = void (evaluateWHNF x) ==> evaluateWHNF_ x -warn = void (evaluateNF x) ==> evaluateNF_ x - -suggest = nub ==> Universum.ordNub - where - note = "'nub' is O(n^2), 'ordNub' is O(n log n)" - -warn = sortBy (comparing f) ==> Universum.sortOn f - where note = "If the function you are using for 'comparing' is fast \ - \(e.g. 'fst'), use 'sortWith' instead of 'sortOn', because 'sortOn' \ - \caches applications the function and 'sortWith' doesn't." - -warn = sortOn fst ==> Universum.sortWith fst - where note = "'sortWith' will be faster here because it doesn't do caching" -warn = sortOn snd ==> Universum.sortWith snd - where note = "'sortWith' will be faster here because it doesn't do caching" -warn = sortOn (Down . fst) ==> Universum.sortWith (Down . fst) - where note = "'sortWith' will be faster here because it doesn't do caching" -warn = sortOn (Down . snd) ==> Universum.sortWith (Down . snd) - where note = "'sortWith' will be faster here because it doesn't do caching" - -warn = fmap concat (mapM f s) ==> Universum.concatMapM f s -warn = concat <$> mapM f s ==> Universum.concatMapM f s - --- Removed for now since we don't want to make people use (some of) our ad-hoc stuff. --- warn = fmap concat (forM f s) ==> Universum.concatForM s f --- warn = fmap concat (for f s) ==> Universum.concatForM s f --- warn = concat <$> forM f s ==> Universum.concatForM s f --- warn = concat <$> for f s ==> Universum.concatForM s f - -suggest = fmap and (sequence s) ==> Universum.andM s - where note = "Applying this hint would mean that some actions\n\ - \that were being executed previously would no longer be executed." -suggest = and <$> sequence s ==> Universum.andM s - where note = "Applying this hint would mean that some actions\n\ - \that were being executed previously would no longer be executed." - -suggest = fmap or (sequence s) ==> Universum.orM s - where note = "Applying this hint would mean that some actions\n\ - \that were being executed previously would no longer be executed." -suggest = or <$> sequence s ==> Universum.orM s - where note = "Applying this hint would mean that some actions\n\ - \that were being executed previously would no longer be executed." - -suggest = fmap and (mapM f s) ==> Universum.allM f s - where note = "Applying this hint would mean that some actions\n\ - \that were being executed previously would no longer be executed." -suggest = and <$> mapM f s ==> Universum.allM f s - where note = "Applying this hint would mean that some actions\n\ - \that were being executed previously would no longer be executed." - -suggest = fmap or (mapM f s) ==> Universum.anyM f s - where note = "Applying this hint would mean that some actions\n\ - \that were being executed previously would no longer be executed." -suggest = or <$> mapM f s ==> Universum.anyM f s - where note = "Applying this hint would mean that some actions\n\ - \that were being executed previously would no longer be executed." - --- Unfortunately, these are often bad because they remove a variable name --- (which usually clarifies things): --- suggest = (do x <- m; when x a) ==> Universum.whenM m a --- suggest = (do x <- m; unless x a) ==> Universum.unlessM m a - -warn = whenM (not <$> x) ==> unlessM x -warn = unlessM (not <$> x) ==> whenM x - --- Oh boy, we sure have many ways of spelling “pure ()”. Also I checked and --- HLint isn't smart enough to see reordered case branches. -warn = (case m of Just x -> f x; Nothing -> pure () ) ==> Universum.whenJust m f -warn = (case m of Just x -> f x; Nothing -> return ()) ==> Universum.whenJust m f -warn = (case m of Just x -> f x; Nothing -> pass ) ==> Universum.whenJust m f -warn = (case m of Nothing -> pure () ; Just x -> f x) ==> Universum.whenJust m f -warn = (case m of Nothing -> return (); Just x -> f x) ==> Universum.whenJust m f -warn = (case m of Nothing -> pass ; Just x -> f x) ==> Universum.whenJust m f -warn = (maybe (pure ()) f m) ==> Universum.whenJust m f -warn = (maybe (return ()) f m) ==> Universum.whenJust m f -warn = (maybe pass f m) ==> Universum.whenJust m f - -warn = (m >>= \case Just x -> f x; Nothing -> pure () ) ==> Universum.whenJustM m f -warn = (m >>= \case Just x -> f x; Nothing -> return ()) ==> Universum.whenJustM m f -warn = (m >>= \case Just x -> f x; Nothing -> pass ) ==> Universum.whenJustM m f -warn = (m >>= \case Nothing -> pure () ; Just x -> f x) ==> Universum.whenJustM m f -warn = (m >>= \case Nothing -> return (); Just x -> f x) ==> Universum.whenJustM m f -warn = (m >>= \case Nothing -> pass ; Just x -> f x) ==> Universum.whenJustM m f -warn = (maybe (pure ()) f =<< m) ==> Universum.whenJustM m f -warn = (maybe (return ()) f =<< m) ==> Universum.whenJustM m f -warn = (maybe pass f =<< m) ==> Universum.whenJustM m f -warn = (m >>= maybe (pure ()) f) ==> Universum.whenJustM m f -warn = (m >>= maybe (return ()) f) ==> Universum.whenJustM m f -warn = (m >>= maybe pass f) ==> Universum.whenJustM m f - -warn = (case m of Just _ -> pure () ; Nothing -> x) ==> Universum.whenNothing_ m x -warn = (case m of Just _ -> return (); Nothing -> x) ==> Universum.whenNothing_ m x -warn = (case m of Just _ -> pass ; Nothing -> x) ==> Universum.whenNothing_ m x -warn = (case m of Nothing -> x; Just _ -> pure () ) ==> Universum.whenNothing_ m x -warn = (case m of Nothing -> x; Just _ -> return ()) ==> Universum.whenNothing_ m x -warn = (case m of Nothing -> x; Just _ -> pass ) ==> Universum.whenNothing_ m x -warn = (maybe x (\_ -> pure () ) m) ==> Universum.whenNothing_ m x -warn = (maybe x (\_ -> return () ) m) ==> Universum.whenNothing_ m x -warn = (maybe x (\_ -> pass ) m) ==> Universum.whenNothing_ m x -warn = (maybe x (const (pure () )) m) ==> Universum.whenNothing_ m x -warn = (maybe x (const (return ())) m) ==> Universum.whenNothing_ m x -warn = (maybe x (const (pass )) m) ==> Universum.whenNothing_ m x - -warn = (m >>= \case Just _ -> pure () ; Nothing -> x) ==> Universum.whenNothingM_ m x -warn = (m >>= \case Just _ -> return (); Nothing -> x) ==> Universum.whenNothingM_ m x -warn = (m >>= \case Just _ -> pass ; Nothing -> x) ==> Universum.whenNothingM_ m x -warn = (m >>= \case Nothing -> x; Just _ -> pure () ) ==> Universum.whenNothingM_ m x -warn = (m >>= \case Nothing -> x; Just _ -> return ()) ==> Universum.whenNothingM_ m x -warn = (m >>= \case Nothing -> x; Just _ -> pass ) ==> Universum.whenNothingM_ m x -warn = (maybe x (\_ -> pure () ) =<< m) ==> Universum.whenNothingM_ m x -warn = (maybe x (\_ -> return () ) =<< m) ==> Universum.whenNothingM_ m x -warn = (maybe x (\_ -> pass ) =<< m) ==> Universum.whenNothingM_ m x -warn = (maybe x (const (pure () )) =<< m) ==> Universum.whenNothingM_ m x -warn = (maybe x (const (return ())) =<< m) ==> Universum.whenNothingM_ m x -warn = (maybe x (const (pass )) =<< m) ==> Universum.whenNothingM_ m x -warn = (m >>= maybe x (\_ -> pure ()) ) ==> Universum.whenNothingM_ m x -warn = (m >>= maybe x (\_ -> return ()) ) ==> Universum.whenNothingM_ m x -warn = (m >>= maybe x (\_ -> pass) ) ==> Universum.whenNothingM_ m x -warn = (m >>= maybe x (const (pure ()) )) ==> Universum.whenNothingM_ m x -warn = (m >>= maybe x (const (return ()))) ==> Universum.whenNothingM_ m x -warn = (m >>= maybe x (const (pass) )) ==> Universum.whenNothingM_ m x - -warn = (case m of Left x -> f x; Right _ -> pure () ) ==> Universum.whenLeft m f -warn = (case m of Left x -> f x; Right _ -> return ()) ==> Universum.whenLeft m f -warn = (case m of Left x -> f x; Right _ -> pass ) ==> Universum.whenLeft m f -warn = (case m of Right _ -> pure () ; Left x -> f x) ==> Universum.whenLeft m f -warn = (case m of Right _ -> return (); Left x -> f x) ==> Universum.whenLeft m f -warn = (case m of Right _ -> pass ; Left x -> f x) ==> Universum.whenLeft m f -warn = (either f (\_ -> pure () ) m) ==> Universum.whenLeft m f -warn = (either f (\_ -> return () ) m) ==> Universum.whenLeft m f -warn = (either f (\_ -> pass ) m) ==> Universum.whenLeft m f -warn = (either f (const (pure () )) m) ==> Universum.whenLeft m f -warn = (either f (const (return ())) m) ==> Universum.whenLeft m f -warn = (either f (const (pass )) m) ==> Universum.whenLeft m f - -warn = (m >>= \case Left x -> f x; Right _ -> pure () ) ==> Universum.whenLeftM m f -warn = (m >>= \case Left x -> f x; Right _ -> return ()) ==> Universum.whenLeftM m f -warn = (m >>= \case Left x -> f x; Right _ -> pass ) ==> Universum.whenLeftM m f -warn = (m >>= \case Right _ -> pure () ; Left x -> f x) ==> Universum.whenLeftM m f -warn = (m >>= \case Right _ -> return (); Left x -> f x) ==> Universum.whenLeftM m f -warn = (m >>= \case Right _ -> pass ; Left x -> f x) ==> Universum.whenLeftM m f -warn = (either f (\_ -> pure () ) =<< m) ==> Universum.whenLeftM m f -warn = (either f (\_ -> return () ) =<< m) ==> Universum.whenLeftM m f -warn = (either f (\_ -> pass ) =<< m) ==> Universum.whenLeftM m f -warn = (either f (const (pure () )) =<< m) ==> Universum.whenLeftM m f -warn = (either f (const (return ())) =<< m) ==> Universum.whenLeftM m f -warn = (either f (const (pass )) =<< m) ==> Universum.whenLeftM m f -warn = (m >>= either f (\_ -> pure ()) ) ==> Universum.whenLeftM m f -warn = (m >>= either f (\_ -> return ()) ) ==> Universum.whenLeftM m f -warn = (m >>= either f (\_ -> pass) ) ==> Universum.whenLeftM m f -warn = (m >>= either f (const (pure ()) )) ==> Universum.whenLeftM m f -warn = (m >>= either f (const (return ()))) ==> Universum.whenLeftM m f -warn = (m >>= either f (const (pass) )) ==> Universum.whenLeftM m f - -warn = (case m of Right x -> f x; Left _ -> pure () ) ==> Universum.whenRight m f -warn = (case m of Right x -> f x; Left _ -> return ()) ==> Universum.whenRight m f -warn = (case m of Right x -> f x; Left _ -> pass ) ==> Universum.whenRight m f -warn = (case m of Left _ -> pure () ; Right x -> f x) ==> Universum.whenRight m f -warn = (case m of Left _ -> return (); Right x -> f x) ==> Universum.whenRight m f -warn = (case m of Left _ -> pass ; Right x -> f x) ==> Universum.whenRight m f -warn = (either (\_ -> pure () ) f m) ==> Universum.whenRight m f -warn = (either (\_ -> return () ) f m) ==> Universum.whenRight m f -warn = (either (\_ -> pass ) f m) ==> Universum.whenRight m f -warn = (either (const (pure () )) f m) ==> Universum.whenRight m f -warn = (either (const (return ())) f m) ==> Universum.whenRight m f -warn = (either (const (pass )) f m) ==> Universum.whenRight m f - -warn = (m >>= \case Right x -> f x; Left _ -> pure () ) ==> Universum.whenRightM m f -warn = (m >>= \case Right x -> f x; Left _ -> return ()) ==> Universum.whenRightM m f -warn = (m >>= \case Right x -> f x; Left _ -> pass ) ==> Universum.whenRightM m f -warn = (m >>= \case Left _ -> pure () ; Right x -> f x) ==> Universum.whenRightM m f -warn = (m >>= \case Left _ -> return (); Right x -> f x) ==> Universum.whenRightM m f -warn = (m >>= \case Left _ -> pass ; Right x -> f x) ==> Universum.whenRightM m f -warn = (either (\_ -> pure () ) f =<< m) ==> Universum.whenRightM m f -warn = (either (\_ -> return () ) f =<< m) ==> Universum.whenRightM m f -warn = (either (\_ -> pass ) f =<< m) ==> Universum.whenRightM m f -warn = (either (const (pure () )) f =<< m) ==> Universum.whenRightM m f -warn = (either (const (return ())) f =<< m) ==> Universum.whenRightM m f -warn = (either (const (pass )) f =<< m) ==> Universum.whenRightM m f -warn = (m >>= either (\_ -> pure ()) f) ==> Universum.whenRightM m f -warn = (m >>= either (\_ -> return ()) f) ==> Universum.whenRightM m f -warn = (m >>= either (\_ -> pass) f) ==> Universum.whenRightM m f -warn = (m >>= either (const (pure ()) ) f) ==> Universum.whenRightM m f -warn = (m >>= either (const (return ())) f) ==> Universum.whenRightM m f -warn = (m >>= either (const (pass) ) f) ==> Universum.whenRightM m f - -warn = mapMaybe leftToMaybe ==> lefts -warn = mapMaybe rightToMaybe ==> rights - -warn "Use 'nonEmpty' from Universum" = - Data.List.NonEmpty.nonEmpty ==> Universum.nonEmpty - -warn "Use 'newTVar' from Universum" = - Control.Concurrent.STM.TVar.newTVar ==> Universum.newTVar -warn "Use 'readTVar' from Universum" = - Control.Concurrent.STM.TVar.readTVar ==> Universum.readTVar -warn "Use 'writeTVar' from Universum" = - Control.Concurrent.STM.TVar.writeTVar ==> Universum.writeTVar -warn "Use 'modifyTVar'' from Universum" = - Control.Concurrent.STM.TVar.modifyTVar' ==> Universum.modifyTVar' -warn "Use 'newTVarIO' from Universum" = - Control.Concurrent.STM.TVar.newTVarIO ==> Universum.newTVarIO -warn "Use 'readTVarIO' from Universum" = - Control.Concurrent.STM.TVar.readTVarIO ==> Universum.readTVarIO - -warn "Use 'newIORef' from Universum" = - Data.IORef.newIORef ==> Universum.newIORef -warn "Use 'readIORef' from Universum" = - Data.IORef.readIORef ==> Universum.readIORef -warn "Use 'writeIORef' from Universum" = - Data.IORef.writeIORef ==> Universum.writeIORef -warn "Use 'modifyIORef' from Universum" = - Data.IORef.modifyIORef ==> Universum.modifyIORef -warn "Use 'modifyIORef'' from Universum" = - Data.IORef.modifyIORef' ==> Universum.modifyIORef' -warn "Use 'atomicModifyIORef' from Universum" = - Data.IORef.atomicModifyIORef ==> Universum.atomicModifyIORef -warn "Use 'atomicModifyIORef'' from Universum" = - Data.IORef.atomicModifyIORef' ==> Universum.atomicModifyIORef' -warn "Use 'atomicWriteIORef' from Universum" = - Data.IORef.atomicWriteIORef ==> Universum.atomicWriteIORef - -warn "Use 'lines' from Universum" = - Data.Text.lines ==> Universum.lines -warn "Use 'unlines' from Universum" = - Data.Text.unlines ==> Universum.unlines -warn "Use 'words' from Universum" = - Data.Text.words ==> Universum.words -warn "Use 'unwords' from Universum" = - Data.Text.unwords ==> Universum.unwords - -warn "Use 'fromStrict' from Universum" = - Data.Text.Lazy.fromStrict ==> Universum.fromStrict -warn "Use 'toStrict' from Universum" = - Data.Text.Lazy.toStrict ==> Universum.toStrict - -warn "Use 'getLine' from Universum" = - Data.Text.IO.getLine ==> Universum.getLine -warn "Use 'readFile' from Universum" = - Data.Text.IO.readFile ==> Universum.readFile -warn "Use 'writeFile' from Universum" = - Data.Text.IO.writeFile ==> Universum.writeFile -warn "Use 'appendFile' from Universum" = - Data.Text.IO.appendFile ==> Universum.appendFile -warn "Use 'interact' from Universum" = - Data.Text.Lazy.IO.interact ==> Universum.interact -warn "Use 'getContents' from Universum" = - Data.Text.Lazy.IO.getContents ==> Universum.getContents - -warn "Use '(&&&)' from Universum" = - (Control.Arrow.&&&) ==> (Universum.&&&) - -warn "Use 'MaybeT' from Universum" = - Control.Monad.Trans.Maybe.MaybeT ==> Universum.MaybeT -warn "Use 'maybeToExceptT' from Universum" = - Control.Monad.Trans.Maybe.maybeToExceptT ==> Universum.maybeToExceptT -warn "Use 'exceptToMaybeT' from Universum" = - Control.Monad.Trans.Maybe.exceptToMaybeT ==> Universum.exceptToMaybeT - ----------------------------------------------------------------------------- --- Lifted functions in Universum ----------------------------------------------------------------------------- - --- concurrency - -warn "liftIO is not needed" = liftIO newEmptyMVar ==> Universum.newEmptyMVar - where - note = "If you import 'newEmptyMVar' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (newMVar x) ==> Universum.newMVar x - where - note = "If you import 'newMVar' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (putMVar x y) ==> Universum.putMVar x y - where - note = "If you import 'putMVar' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (readMVar x) ==> Universum.readMVar x - where - note = "If you import 'readMVar' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (swapMVar x y) ==> Universum.swapMVar x y - where - note = "If you import 'swapMVar' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (takeMVar x) ==> Universum.takeMVar x - where - note = "If you import 'takeMVar' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (tryPutMVar x y) ==> Universum.tryPutMVar x y - where - note = "If you import 'tryPutMVar' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (tryReadMVar x) ==> Universum.tryReadMVar x - where - note = "If you import 'tryReadMVar' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (tryTakeMVar x) ==> Universum.tryTakeMVar x - where - note = "If you import 'tryTakeMVar' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (atomically x) ==> Universum.atomically x - where - note = "If you import 'atomically' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (newTVarIO x) ==> Universum.newTVarIO x - where - note = "If you import 'newTVarIO' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (readTVarIO x) ==> Universum.readTVarIO x - where - note = "If you import 'readTVarIO' from Universum, it's already lifted" - --- IORef - -warn "liftIO is not needed" = liftIO (newIORef x) ==> Universum.newIORef x - where - note = "If you import 'newIORef' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (readIORef x) ==> Universum.readIORef x - where - note = "If you import 'readIORef' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (writeIORef x y) ==> Universum.writeIORef x y - where - note = "If you import 'writeIORef' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (modifyIORef x y) ==> Universum.modifyIORef x y - where - note = "If you import 'modifyIORef' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (modifyIORef' x y) ==> Universum.modifyIORef' x y - where - note = "If you import 'modifyIORef'' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (atomicModifyIORef x y) ==> Universum.atomicModifyIORef x y - where - note = "If you import 'atomicModifyIORef' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (atomicModifyIORef' x y) ==> Universum.atomicModifyIORef' x y - where - note = "If you import 'atomicModifyIORef'' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (atomicWriteIORef x y) ==> Universum.atomicWriteIORef x y - where - note = "If you import 'atomicWriteIORef' from Universum, it's already lifted" - --- others - -warn "liftIO is not needed" = liftIO Universum.getContents ==> Universum.getContents - where - note = "If you import 'getContents' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO Universum.getLine ==> Universum.getLine - where - note = "If you import 'getLine' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (Universum.interact x) ==> Universum.interact x - where - note = "If you import 'interact' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (Universum.interact x) ==> Universum.interact x - where - note = "If you import 'interact' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (Universum.readFile x) ==> Universum.readFile x - where - note = "If you import 'readFile' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (Universum.writeFile x y) ==> Universum.writeFile x y - where - note = "If you import 'writeFile' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (Universum.appendFile x y) ==> Universum.appendFile x y - where - note = "If you import 'appendFile' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (Universum.openFile x y) ==> Universum.openFile x y - where - note = "If you import 'openFile' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO getArgs ==> Universum.getArgs - where - note = "If you import 'getArgs' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (exitWith x) ==> Universum.exitWith x - where - note = "If you import 'exitWith' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO exitFailure ==> Universum.exitFailure - where - note = "If you import 'exitFailure' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO exitSuccess ==> Universum.exitSuccess - where - note = "If you import 'exitSuccess' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (die x) ==> Universum.die x - where - note = "If you import 'die' from Universum, it's already lifted" - -warn "liftIO is not needed" = liftIO (stToIO x) ==> Universum.stToIO x - where - note = "If you import 'stToIO' from Universum, it's already lifted" diff --git a/Makefile b/Makefile new file mode 100644 index 00000000000..1fd28e35759 --- /dev/null +++ b/Makefile @@ -0,0 +1,24 @@ +help: ## Print documentation + @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' + +lint: ## Run hlint for the project + ./scripts/haskell/lint.sh + +stylish: ## Run stylish-haskell on the entire project + ./scripts/haskell/stylish.sh + +ghcid: ## Pass DIR=package-directory to run that directory's ghcid command. +ifeq ($(DIR),) + echo "You must specify the package directory for this command." +else + cd $(DIR) && make ghcid +endif + +ghcid-test: ## Pass DIR=package-directory to run that directory's ghcid command. +ifeq ($(DIR),) + echo "You must specify the package directory for this command." +else + cd $(DIR) && make ghcid-test +endif + +.PHONY: help stylish lint ghcid ghcid-test diff --git a/appveyor.yml b/appveyor.yml index 867a549e252..3ea15cfddb1 100644 --- a/appveyor.yml +++ b/appveyor.yml @@ -28,6 +28,21 @@ before_test: # Restore cache - Echo %APPVEYOR_BUILD_VERSION% > build-id - ps: >- + Write-Host "in pagefile script" ; + $c = Get-WmiObject Win32_computersystem -EnableAllPrivileges ; + if($c.AutomaticManagedPagefile){ + Write-Host "disabling managed page file settings" + $c.AutomaticManagedPagefile = $false + $c.Put() | Out-Null + } ; + $new_page_size=25000 ; + $CurrentPageFile = Get-WmiObject -Class Win32_PageFileSetting ; + if ($CurrentPageFile.InitialSize -ne $new_page_size) { + Write-Host "setting new page file size to $new_page_size" + $CurrentPageFile.InitialSize=$new_page_size + $CurrentPageFile.MaximumSize=$new_page_size + $CurrentPageFile.Put() | Out-Null + } ; if ( $env:CACHE_S3_READY -eq $true ) { Start-FileDownload https://github.com/fpco/cache-s3/releases/download/$env:CACHE_S3_VERSION/cache-s3-$env:CACHE_S3_VERSION-windows-x86_64.zip -FileName cache-s3.zip 7z x cache-s3.zip cache-s3.exe @@ -35,6 +50,18 @@ before_test: .\cache-s3 --max-size=$env:CACHE_S3_MAX_SIZE --prefix=$env:APPVEYOR_PROJECT_NAME --git-branch=$env:APPVEYOR_REPO_BRANCH --suffix=windows -v info -c restore stack work --base-branch=develop } +# Get custom GHC +- ps: >- + mkdir C:\ghc + + Invoke-WebRequest "https://s3.eu-central-1.amazonaws.com/ci-static/ghc-8.2.2-x86_64-unknown-mingw32.tar.xz" -OutFile "C:\ghc\ghc.tar.xz" -UserAgent "Curl" + + 7z x C:\ghc\ghc.tar.xz -oC:\ghc + + 7z x C:\ghc\ghc.tar -oC:\ghc + + $env:PATH="$env:PATH;C:\ghc\ghc-8.2.2\bin" + # Install OpenSSL 1.0.2 (see https://github.com/appveyor/ci/issues/1665) - ps: (New-Object Net.WebClient).DownloadFile('https://slproweb.com/download/Win64OpenSSL-1_0_2o.exe', "$($env:USERPROFILE)\Win64OpenSSL.exe") - ps: cmd /c start /wait "$($env:USERPROFILE)\Win64OpenSSL.exe" /silent /verysilent /sp- /suppressmsgboxes /DIR=C:\OpenSSL-Win64-v102 @@ -46,7 +73,7 @@ before_test: # Install rocksdb - git clone https://github.com/facebook/rocksdb.git --branch v4.13.5 -- ps: Start-FileDownload 'https://ci.appveyor.com/api/buildjobs/kbpteb8j55p6sa2m/artifacts/rocksdb%2Fbuild%2FRocksdb.zip' -FileName rocksdb.zip +- ps: Start-FileDownload 'https://s3.eu-central-1.amazonaws.com/ci-static/serokell-rocksdb-haskell-325427fc709183c8fdf777ad5ea09f8d92bf8585.zip' -FileName rocksdb.zip - 7z x rocksdb.zip # CSL-1509: After moving the 'cardano-sl' project itself into a separate folder ('lib/'), the 'cardano-text.exe' executable fails on AppVeyor CI. @@ -62,6 +89,7 @@ before_test: test_script: - cd "%WORK_DIR%" + - stack config --system-ghc set system-ghc --global true - stack exec -- ghc-pkg recache - stack --verbosity warn setup --no-reinstall > nul # Install happy separately: https://github.com/commercialhaskell/stack/issues/3151#issuecomment-310642487. Also install cpphs because it's a build-tool and Stack can't figure out by itself that it should be installed @@ -81,10 +109,9 @@ test_script: # Retry transient failures due to https://github.com/haskell/cabal/issues/4005 # We intentionally don't build auxx here, because this build is for installer. - scripts\ci\appveyor-retry call stack --dump-logs install cardano-sl cardano-sl-tools cardano-sl-wallet cardano-sl-wallet-new - -j 2 + -j 3 --no-terminal --local-bin-path %WORK_DIR% - --test --no-haddock-deps --flag cardano-sl-core:-asserts --flag cardano-sl-tools:for-installer @@ -103,23 +130,42 @@ test_script: - copy lib\*genesis*.json daedalus\ - copy cardano-launcher.exe daedalus\ - copy cardano-node.exe daedalus\ + - copy cardano-x509-certificates.exe daedalus\ - cd daedalus - Echo %APPVEYOR_BUILD_VERSION% > build-id - Echo %APPVEYOR_REPO_COMMIT% > commit-id - Echo https://ci.appveyor.com/project/%APPVEYOR_ACCOUNT_NAME%/%APPVEYOR_PROJECT_SLUG%/build/%APPVEYOR_BUILD_VERSION% > ci-url after_test: + - xcopy /q /s /e /r /k /i /v /h /y "%WORK_DIR%\daedalus" "%APPVEYOR_BUILD_FOLDER%\daedalus" + - cd "%WORK_DIR%/daedalus" + - 7z a "%APPVEYOR_REPO_COMMIT%.zip" * + - appveyor PushArtifact "%APPVEYOR_REPO_COMMIT%.zip" - cd "%WORK_DIR%" # Get back to where cache-s3.exe is located - ps: >- if ( ($env:CACHE_S3_READY -eq $true) -and (-not $env:APPVEYOR_PULL_REQUEST_NUMBER) ) { if ($env:APPVEYOR_REPO_BRANCH -eq "master" -Or $env:APPVEYOR_REPO_BRANCH -eq "develop" -Or $env:APPVEYOR_REPO_BRANCH -like "release*") { + Write-Host "saving stack" .\cache-s3 --max-size=$env:CACHE_S3_MAX_SIZE --prefix=$env:APPVEYOR_PROJECT_NAME --git-branch=$env:APPVEYOR_REPO_BRANCH --suffix=windows -c -v info save stack + Write-Host "done stack" } + Write-Host "saving stack work" .\cache-s3 --max-size=$env:CACHE_S3_MAX_SIZE --prefix=$env:APPVEYOR_PROJECT_NAME --git-branch=$env:APPVEYOR_REPO_BRANCH --suffix=windows -c -v info save stack work + Write-Host "done stack work" } - - xcopy /q /s /e /r /k /i /v /h /y "%WORK_DIR%\daedalus" "%APPVEYOR_BUILD_FOLDER%\daedalus" - artifacts: - path: daedalus/ name: CardanoSL type: zip + +deploy: + provider: S3 + access_key_id: + secure: IEky6PsMzHaKHNBMxR8tQaQI8X7qWRB9+HuEroTVRBk= + secret_access_key: + secure: cqjzG96hWB1x3JDbVSbF9E+aJ5jKvIGacJRUDWATHaTOYfSt6Rvive/NrF4lKBIm + bucket: appveyor-ci-deploy + region: ap-northeast-1 + set_public: true + folder: cardano-sl + artifact: $(APPVEYOR_REPO_COMMIT).zip diff --git a/auxx/Main.hs b/auxx/Main.hs index 3f6239afd2e..154425a71c5 100644 --- a/auxx/Main.hs +++ b/auxx/Main.hs @@ -3,44 +3,36 @@ module Main ) where import Universum -import Unsafe (unsafeFromJust) import Control.Exception.Safe (handle) +import Data.Maybe (fromMaybe) import Formatting (sformat, shown, (%)) -import Mockable (Production, runProduction) -import JsonLog (jsonLog) +import Mockable (Production (..), runProduction) import qualified Network.Transport.TCP as TCP (TCPAddr (..)) import qualified System.IO.Temp as Temp import System.Wlog (LoggerName, logInfo) import qualified Pos.Client.CLI as CLI -import Pos.Communication (OutSpecs) -import Pos.Communication.Util (ActionSpec (..)) -import Pos.Core (ConfigurationError) -import Pos.Configuration (networkConnectionTimeout) +import Pos.Context (NodeContext (..)) +import Pos.Core (ConfigurationError, epochSlots) +import Pos.Crypto (ProtocolMagic) import Pos.DB.DB (initNodeDBs) -import Pos.Diffusion.Transport.TCP (bracketTransportTCP) -import Pos.Diffusion.Types (DiffusionLayer (..)) -import Pos.Diffusion.Full (diffusionLayerFull) -import Pos.Logic.Full (logicLayerFull) -import Pos.Logic.Types (LogicLayer (..)) -import Pos.Launcher (HasConfigurations, NodeParams (..), NodeResources, +import Pos.Infra.Diffusion.Types (Diffusion, hoistDiffusion) +import Pos.Infra.Network.Types (NetworkConfig (..), Topology (..), topologyDequeuePolicy, + topologyEnqueuePolicy, topologyFailurePolicy) +import Pos.Infra.Ntp.Configuration (NtpConfiguration) +import Pos.Launcher (HasConfigurations, NodeParams (..), NodeResources (..), bracketNodeResources, loggerBracket, lpConsoleLog, runNode, - elimRealMode, withConfigurations) -import Pos.Ntp.Configuration (NtpConfiguration) -import Pos.Network.Types (NetworkConfig (..), Topology (..), topologyDequeuePolicy, - topologyEnqueuePolicy, topologyFailurePolicy) + runRealMode, withConfigurations) import Pos.Txp (txpGlobalSettings) -import Pos.Update (lastKnownBlockVersion) import Pos.Util (logException) import Pos.Util.CompileInfo (HasCompileInfo, retrieveCompileTimeInfo, withCompileInfo) import Pos.Util.Config (ConfigurationException (..)) import Pos.Util.UserSecret (usVss) import Pos.WorkMode (EmptyMempoolExt, RealMode) -import Pos.Worker.Types (WorkerSpec) import AuxxOptions (AuxxAction (..), AuxxOptions (..), AuxxStartMode (..), getAuxxOptions) -import Mode (AuxxContext (..), AuxxMode) +import Mode (AuxxContext (..), AuxxMode, realModeToAuxx) import Plugin (auxxPlugin, rawExec) import Repl (PrintAction, WithCommandAction (..), withAuxxRepl) @@ -80,11 +72,12 @@ correctNodeParams AuxxOptions {..} np = do runNodeWithSinglePlugin :: (HasConfigurations, HasCompileInfo) - => NodeResources EmptyMempoolExt - -> (WorkerSpec AuxxMode, OutSpecs) - -> (WorkerSpec AuxxMode, OutSpecs) -runNodeWithSinglePlugin nr (plugin, plOuts) = - runNode nr ([plugin], plOuts) + => ProtocolMagic + -> NodeResources EmptyMempoolExt + -> (Diffusion AuxxMode -> AuxxMode ()) + -> Diffusion AuxxMode -> AuxxMode () +runNodeWithSinglePlugin pm nr plugin = + runNode pm nr [plugin] action :: HasCompileInfo => AuxxOptions -> Either WithCommandAction Text -> Production () action opts@AuxxOptions {..} command = do @@ -94,23 +87,23 @@ action opts@AuxxOptions {..} command = do -> handle @_ @ConfigurationException (\_ -> runWithoutNode pa) . handle @_ @ConfigurationError (\_ -> runWithoutNode pa) - $ withConfigurations conf (runWithConfig pa) + $ withConfigurations Nothing conf (runWithConfig pa) Light -> runWithoutNode pa - _ -> withConfigurations conf (runWithConfig pa) + _ -> withConfigurations Nothing conf (runWithConfig pa) where runWithoutNode :: PrintAction Production -> Production () - runWithoutNode printAction = printAction "Mode: light" >> rawExec Nothing opts Nothing command + runWithoutNode printAction = printAction "Mode: light" >> rawExec Nothing Nothing opts Nothing command - runWithConfig :: HasConfigurations => PrintAction Production -> NtpConfiguration -> Production () - runWithConfig printAction ntpConfig = do + runWithConfig :: HasConfigurations => PrintAction Production -> NtpConfiguration -> ProtocolMagic -> Production () + runWithConfig printAction ntpConfig pm = do printAction "Mode: with-config" CLI.printInfoOnStart aoCommonNodeArgs ntpConfig (nodeParams, tempDbUsed) <- correctNodeParams opts =<< CLI.getNodeParams loggerName cArgs nArgs - let - toRealMode :: AuxxMode a -> RealMode EmptyMempoolExt a + + let toRealMode :: AuxxMode a -> RealMode EmptyMempoolExt a toRealMode auxxAction = do realModeContext <- ask let auxxContext = @@ -118,17 +111,18 @@ action opts@AuxxOptions {..} command = do { acRealModeContext = realModeContext , acTempDbUsed = tempDbUsed } lift $ runReaderT auxxAction auxxContext - let vssSK = unsafeFromJust $ npUserSecret nodeParams ^. usVss - let sscParams = CLI.gtSscParams cArgs vssSK (npBehaviorConfig nodeParams) - bracketNodeResources nodeParams sscParams txpGlobalSettings initNodeDBs $ \nr -> - elimRealMode nr $ toRealMode $ - logicLayerFull jsonLog $ \logicLayer -> - bracketTransportTCP networkConnectionTimeout (ncTcpAddr (npNetworkConfig nodeParams)) $ \transport -> - diffusionLayerFull (runProduction . elimRealMode nr . toRealMode) (npNetworkConfig nodeParams) lastKnownBlockVersion transport Nothing $ \withLogic -> do - diffusionLayer <- withLogic (logic logicLayer) - let modifier = if aoStartMode == WithNode then runNodeWithSinglePlugin nr else identity - (ActionSpec auxxModeAction, _) = modifier (auxxPlugin opts command) - runLogicLayer logicLayer (runDiffusionLayer diffusionLayer (auxxModeAction (diffusion diffusionLayer))) + vssSK = fromMaybe (error "no user secret given") + (npUserSecret nodeParams ^. usVss) + sscParams = CLI.gtSscParams cArgs vssSK (npBehaviorConfig nodeParams) + + bracketNodeResources nodeParams sscParams (txpGlobalSettings pm) (initNodeDBs pm epochSlots) $ \nr -> Production $ + let NodeContext {..} = nrContext nr + modifier = if aoStartMode == WithNode + then runNodeWithSinglePlugin pm nr + else identity + auxxModeAction = modifier (auxxPlugin pm opts command) + in runRealMode pm nr $ \diffusion -> + toRealMode (auxxModeAction (hoistDiffusion realModeToAuxx toRealMode diffusion)) cArgs@CLI.CommonNodeArgs {..} = aoCommonNodeArgs conf = CLI.configurationOptions (CLI.commonArgs cArgs) diff --git a/auxx/cardano-sl-auxx.cabal b/auxx/cardano-sl-auxx.cabal index 280190d9841..800288d5482 100644 --- a/auxx/cardano-sl-auxx.cabal +++ b/auxx/cardano-sl-auxx.cabal @@ -1,5 +1,5 @@ name: cardano-sl-auxx -version: 1.2.1 +version: 1.3.0 synopsis: Cardano SL - Auxx description: Cardano SL - Auxx license: MIT @@ -51,6 +51,7 @@ library , cardano-sl-block , cardano-sl-client , cardano-sl-core + , cardano-sl-core-test , cardano-sl-crypto , cardano-sl-db , cardano-sl-generator @@ -126,15 +127,17 @@ library executable cardano-auxx main-is: Main.hs - build-depends: cardano-sl + build-depends: base + , cardano-sl , cardano-sl-auxx + , cardano-sl-block , cardano-sl-core + , cardano-sl-crypto , cardano-sl-infra , cardano-sl-networking , cardano-sl-txp , cardano-sl-util , cardano-sl-update - , constraints , log-warper , temporary , network-transport-tcp @@ -144,7 +147,6 @@ executable cardano-auxx default-language: Haskell2010 ghc-options: -threaded -rtsopts -Wall - -fno-warn-orphans -O2 -- linker speed up for linux @@ -207,7 +209,6 @@ test-suite cardano-auxx-test ghc-options: -threaded -rtsopts -Wall - -fno-warn-orphans -- linker speed up for linux if os(linux) diff --git a/auxx/src/Command.hs b/auxx/src/Command.hs index c1c8d90a928..dca93b30345 100644 --- a/auxx/src/Command.hs +++ b/auxx/src/Command.hs @@ -1,3 +1,19 @@ -- | Command. -{-# OPTIONS_GHC -F -pgmF autoexporter #-} +module Command + ( module Command.BlockGen + , module Command.Help + , module Command.Proc + , module Command.Rollback + , module Command.Tx + , module Command.TyProjection + , module Command.Update + ) where + +import Command.BlockGen +import Command.Help +import Command.Proc +import Command.Rollback +import Command.Tx +import Command.TyProjection +import Command.Update \ No newline at end of file diff --git a/auxx/src/Command/BlockGen.hs b/auxx/src/Command/BlockGen.hs index 353a688ff17..42fea2ac8c5 100644 --- a/auxx/src/Command/BlockGen.hs +++ b/auxx/src/Command/BlockGen.hs @@ -14,9 +14,10 @@ import System.Wlog (logInfo) import Pos.AllSecrets (mkAllSecretsSimple) import Pos.Client.KeyStorage (getSecretKeysPlain) import Pos.Core (gdBootStakeholders, genesisData) -import Pos.Crypto (encToSecret) +import Pos.Crypto (ProtocolMagic, encToSecret) import Pos.Generator.Block (BlockGenParams (..), genBlocks, tgpTxCountRange) -import Pos.StateLock (Priority (..), withStateLock) +import Pos.Infra.StateLock (Priority (..), withStateLock) +import Pos.Infra.Util.JsonLog.Events (MemPoolModifyReason (..)) import Pos.Txp (txpGlobalSettings) import Pos.Util.CompileInfo (withCompileInfo) @@ -24,8 +25,8 @@ import Lang.Value (GenBlocksParams (..)) import Mode (MonadAuxxMode) -generateBlocks :: MonadAuxxMode m => GenBlocksParams -> m () -generateBlocks GenBlocksParams{..} = withStateLock HighPriority "auxx" $ \_ -> do +generateBlocks :: MonadAuxxMode m => ProtocolMagic -> GenBlocksParams -> m () +generateBlocks pm GenBlocksParams{..} = withStateLock HighPriority ApplyBlock $ \_ -> do seed <- liftIO $ maybe randomIO pure bgoSeed logInfo $ "Generating with seed " <> show seed @@ -40,9 +41,9 @@ generateBlocks GenBlocksParams{..} = withStateLock HighPriority "auxx" $ \_ -> d , _bgpTxGenParams = def & tgpTxCountRange .~ (0,0) , _bgpInplaceDB = True , _bgpSkipNoKey = True - , _bgpTxpGlobalSettings = txpGlobalSettings + , _bgpTxpGlobalSettings = txpGlobalSettings pm } - withCompileInfo def $ evalRandT (genBlocks bgenParams (const ())) (mkStdGen seed) + withCompileInfo def $ evalRandT (genBlocks pm bgenParams (const ())) (mkStdGen seed) -- We print it twice because there can be a ton of logs and -- you don't notice the first message. logInfo $ "Generated with seed " <> show seed diff --git a/auxx/src/Command/Proc.hs b/auxx/src/Command/Proc.hs index 040f0be7a57..c6b33f50632 100644 --- a/auxx/src/Command/Proc.hs +++ b/auxx/src/Command/Proc.hs @@ -23,12 +23,12 @@ import Pos.Core (AddrStakeDistribution (..), Address, HeavyDlgIndex (. import Pos.Core.Common (AddrAttributes (..), AddrSpendingData (..), makeAddress) import Pos.Core.Configuration (genesisSecretKeys) import Pos.Core.Txp (TxOut (..)) -import Pos.Crypto (PublicKey, emptyPassphrase, encToPublic, fullPublicKeyF, hashHexF, - noPassEncrypt, safeCreatePsk, unsafeCheatingHashCoerce, withSafeSigner) +import Pos.Crypto (ProtocolMagic, PublicKey, emptyPassphrase, encToPublic, fullPublicKeyF, + hashHexF, noPassEncrypt, safeCreatePsk, unsafeCheatingHashCoerce, + withSafeSigner) import Pos.DB.Class (MonadGState (..)) -import Pos.Diffusion.Types (Diffusion (..)) +import Pos.Infra.Diffusion.Types (Diffusion (..)) import Pos.Update (BlockVersionModifier (..)) -import Pos.Util.CompileInfo (HasCompileInfo) import Pos.Util.UserSecret (WalletUserSecret (..), readUserSecret, usKeys, usPrimKey, usWallet, userSecret) import Pos.Util.Util (eitherToThrow) @@ -55,12 +55,13 @@ import Mode (MonadAuxxMode, deriveHDAddressAuxx, makePubKeyAddressAuxx import Repl (PrintAction) createCommandProcs :: - forall m. (HasCompileInfo, MonadIO m, CanLog m, HasLoggerName m) - => Maybe (Dict (MonadAuxxMode m)) + forall m. (MonadIO m, CanLog m, HasLoggerName m) + => Maybe ProtocolMagic + -> Maybe (Dict (MonadAuxxMode m)) -> PrintAction m -> Maybe (Diffusion m) -> [CommandProc m] -createCommandProcs hasAuxxMode printAction mDiffusion = rights . fix $ \commands -> [ +createCommandProcs mpm hasAuxxMode printAction mDiffusion = rights . fix $ \commands -> [ return CommandProc { cpName = "L" @@ -202,24 +203,25 @@ createCommandProcs hasAuxxMode printAction mDiffusion = rights . fix $ \commands }, let name = "send-to-all-genesis" in + needsProtocolMagic name >>= \pm -> needsDiffusion name >>= \diffusion -> needsAuxxMode name >>= \Dict -> return CommandProc { cpName = name , cpArgumentPrepare = identity , cpArgumentConsumer = do - stagpDuration <- getArg tyInt "dur" + stagpGenesisTxsPerThread <- getArg tyInt "genesisTxsPerThread" + stagpTxsPerThread <- getArg tyInt "txsPerThread" stagpConc <- getArg tyInt "conc" stagpDelay <- getArg tyInt "delay" stagpTpsSentFile <- getArg tyFilePath "file" return Tx.SendToAllGenesisParams{..} , cpExec = \stagp -> do - Tx.sendToAllGenesis diffusion stagp + Tx.sendToAllGenesis pm diffusion stagp return ValueUnit , cpHelp = "create and send transactions from all genesis addresses \ \ for seconds, in ms. is the \ - \ number of threads that send transactions concurrently. \ - \ is either 'neighbours', 'round-robin', or 'send-random'" + \ number of threads that send transactions concurrently." }, let name = "send-from-file" in @@ -236,6 +238,7 @@ createCommandProcs hasAuxxMode printAction mDiffusion = rights . fix $ \commands }, let name = "send" in + needsProtocolMagic name >>= \pm -> needsDiffusion name >>= \diffusion -> needsAuxxMode name >>= \Dict -> return CommandProc @@ -245,13 +248,14 @@ createCommandProcs hasAuxxMode printAction mDiffusion = rights . fix $ \commands (,) <$> getArg tyInt "i" <*> getArgSome tyTxOut "out" , cpExec = \(i, outputs) -> do - Tx.send diffusion i outputs + Tx.send pm diffusion i outputs return ValueUnit , cpHelp = "send from #i to specified transaction outputs \ \ (use 'tx-out' to build them)" }, let name = "vote" in + needsProtocolMagic name >>= \pm -> needsDiffusion name >>= \diffusion -> needsAuxxMode name >>= \Dict -> return CommandProc @@ -262,7 +266,7 @@ createCommandProcs hasAuxxMode printAction mDiffusion = rights . fix $ \commands <*> getArg tyBool "agree" <*> getArg tyHash "up-id" , cpExec = \(i, decision, upId) -> do - Update.vote diffusion i decision upId + Update.vote pm diffusion i decision upId return ValueUnit , cpHelp = "send vote for update proposal and \ \ decision ('true' or 'false'), \ @@ -318,6 +322,7 @@ createCommandProcs hasAuxxMode printAction mDiffusion = rights . fix $ \commands }, let name = "propose-update" in + needsProtocolMagic name >>= \pm -> needsDiffusion name >>= \diffusion -> needsAuxxMode name >>= \Dict -> return CommandProc @@ -339,7 +344,7 @@ createCommandProcs hasAuxxMode printAction mDiffusion = rights . fix $ \commands -- FIXME: confuses existential/universal. A better solution -- is to have two ValueHash constructors, one with universal and -- one with existential (relevant via singleton-style GADT) quantification. - ValueHash . unsafeCheatingHashCoerce <$> Update.propose diffusion params + ValueHash . unsafeCheatingHashCoerce <$> Update.propose pm diffusion params , cpHelp = "propose an update with one positive vote for it \ \ using secret key #i" }, @@ -355,6 +360,7 @@ createCommandProcs hasAuxxMode printAction mDiffusion = rights . fix $ \commands }, let name = "delegate-heavy" in + needsProtocolMagic name >>= \pm -> needsDiffusion name >>= \diffusion -> needsAuxxMode name >>= \Dict -> return CommandProc @@ -370,7 +376,7 @@ createCommandProcs hasAuxxMode printAction mDiffusion = rights . fix $ \commands withSafeSigner issuerSk (pure emptyPassphrase) $ \case Nothing -> logError "Invalid passphrase" Just ss -> do - let psk = safeCreatePsk ss delegatePk (HeavyDlgIndex curEpoch) + let psk = safeCreatePsk pm ss delegatePk (HeavyDlgIndex curEpoch) if dry then do printAction $ @@ -388,6 +394,7 @@ createCommandProcs hasAuxxMode printAction mDiffusion = rights . fix $ \commands }, let name = "generate-blocks" in + needsProtocolMagic name >>= \pm -> needsAuxxMode name >>= \Dict -> return CommandProc { cpName = name @@ -397,7 +404,7 @@ createCommandProcs hasAuxxMode printAction mDiffusion = rights . fix $ \commands bgoSeed <- getArgOpt tyInt "seed" return GenBlocksParams{..} , cpExec = \params -> do - generateBlocks params + generateBlocks pm params return ValueUnit , cpHelp = "generate blocks" }, @@ -441,6 +448,7 @@ createCommandProcs hasAuxxMode printAction mDiffusion = rights . fix $ \commands }, let name = "rollback" in + needsProtocolMagic name >>= \pm -> needsAuxxMode name >>= \Dict -> return CommandProc { cpName = name @@ -450,7 +458,7 @@ createCommandProcs hasAuxxMode printAction mDiffusion = rights . fix $ \commands rpDumpPath <- getArg tyFilePath "dump-file" pure RollbackParams{..} , cpExec = \RollbackParams{..} -> do - Rollback.rollbackAndDump rpNum rpDumpPath + Rollback.rollbackAndDump pm rpNum rpDumpPath return ValueUnit , cpHelp = "" }, @@ -501,6 +509,9 @@ createCommandProcs hasAuxxMode printAction mDiffusion = rights . fix $ \commands needsDiffusion :: Name -> Either UnavailableCommand (Diffusion m) needsDiffusion name = maybe (Left $ UnavailableCommand name "Diffusion layer is not available") Right mDiffusion + needsProtocolMagic :: Name -> Either UnavailableCommand ProtocolMagic + needsProtocolMagic name = + maybe (Left $ UnavailableCommand name "ProtocolMagic is not available") Right mpm procConst :: Applicative m => Name -> Value -> CommandProc m procConst name value = diff --git a/auxx/src/Command/Rollback.hs b/auxx/src/Command/Rollback.hs index 49ee8899775..035f54957ae 100644 --- a/auxx/src/Command/Rollback.hs +++ b/auxx/src/Command/Rollback.hs @@ -18,27 +18,26 @@ import Pos.Block.Slog (ShouldCallBListener (..)) import Pos.Block.Types (Blund) import Pos.Core (difficultyL, epochIndexL) import Pos.Core.Block (mainBlockTxPayload) +import Pos.Core.Chrono (NewestFirst, _NewestFirst) import Pos.Core.Txp (TxAux) +import Pos.Crypto (ProtocolMagic) import qualified Pos.DB.Block.Load as DB import qualified Pos.DB.BlockIndex as DB -import Pos.Ssc.Configuration (HasSscConfiguration) -import Pos.StateLock (Priority (..), withStateLock) +import Pos.Infra.StateLock (Priority (..), withStateLock) +import Pos.Infra.Util.JsonLog.Events (MemPoolModifyReason (..)) import Pos.Txp (flattenTxPayload) -import Pos.Util.Chrono (NewestFirst, _NewestFirst) -import Pos.Util.CompileInfo (HasCompileInfo) import Mode (MonadAuxxMode) -- | Rollback given number of blocks from the DB and dump transactions -- from it to the given file. rollbackAndDump - :: ( MonadAuxxMode m - , HasCompileInfo - ) - => Word + :: MonadAuxxMode m + => ProtocolMagic + -> Word -> FilePath -> m () -rollbackAndDump numToRollback outFile = withStateLock HighPriority "auxx" $ \_ -> do +rollbackAndDump pm numToRollback outFile = withStateLock HighPriority ApplyBlockWithRollback $ \_ -> do printTipDifficulty blundsMaybeEmpty <- modifyBlunds <$> DB.loadBlundsFromTipByDepth (fromIntegral numToRollback) @@ -55,14 +54,14 @@ rollbackAndDump numToRollback outFile = withStateLock HighPriority "auxx" $ \_ - liftIO $ BSL.writeFile outFile (encode allTxs) logInfo $ sformat ("Dumped "%int%" transactions to "%string) (length allTxs) (outFile) - rollbackBlocksUnsafe (BypassSecurityCheck True) (ShouldCallBListener True) blunds + rollbackBlocksUnsafe pm (BypassSecurityCheck True) (ShouldCallBListener True) blunds logInfo $ sformat ("Rolled back "%int%" blocks") (length blunds) printTipDifficulty where -- It's illegal to rollback 0-th genesis block. We also may load -- more blunds than necessary, because genesis blocks don't -- contribute to depth counter. - modifyBlunds :: HasSscConfiguration => NewestFirst [] Blund -> NewestFirst [] Blund + modifyBlunds :: NewestFirst [] Blund -> NewestFirst [] Blund modifyBlunds = over _NewestFirst (genericTake numToRollback . skip0thGenesis) skip0thGenesis = filter (not . is0thGenesis) diff --git a/auxx/src/Command/Tx.hs b/auxx/src/Command/Tx.hs index 52edcbe4e1e..4540d06b8de 100644 --- a/auxx/src/Command/Tx.hs +++ b/auxx/src/Command/Tx.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE NamedFieldPuns #-} -- | Tx sending functionality in Auxx. @@ -13,6 +14,7 @@ import Universum import Control.Concurrent.STM.TQueue (newTQueue, tryReadTQueue, writeTQueue) import Control.Exception.Safe (Exception (..), try) +import Control.Monad (when) import Control.Monad.Except (runExceptT) import Data.Aeson (eitherDecodeStrict) import qualified Data.ByteString as BS @@ -20,13 +22,14 @@ import Data.Default (def) import qualified Data.HashMap.Strict as HM import Data.List ((!!)) import qualified Data.List.NonEmpty as NE +import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.IO as T -import Data.Time.Units (toMicroseconds) +import Data.Time.Units (Microsecond, fromMicroseconds, toMicroseconds) import Formatting (build, int, sformat, shown, stext, (%)) import Mockable (Mockable, SharedAtomic, SharedAtomicT, concurrently, currentTime, delay, forConcurrently, modifySharedAtomic, newSharedAtomic) -import Serokell.Util (ms, sec) +import System.Environment (lookupEnv) import System.IO (BufferMode (LineBuffering), hClose, hSetBuffering) import System.Wlog (logError, logInfo) @@ -37,10 +40,10 @@ import Pos.Client.Txp.Util (createTx) import Pos.Core (BlockVersionData (bvdSlotDuration), IsBootstrapEraAddr (..), Timestamp (..), deriveFirstHDAddress, makePubKeyAddress, mkCoin) import Pos.Core.Configuration (genesisBlockVersionData, genesisSecretKeys) -import Pos.Core.Txp (TxAux, TxOut (..), TxOutAux (..), txaF) -import Pos.Crypto (EncryptedSecretKey, emptyPassphrase, encToPublic, fakeSigner, - safeToPublic, toPublic, withSafeSigners) -import Pos.Diffusion.Types (Diffusion (..)) +import Pos.Core.Txp (TxAux (..), TxIn (TxInUtxo), TxOut (..), TxOutAux (..), txaF) +import Pos.Crypto (EncryptedSecretKey, ProtocolMagic, emptyPassphrase, encToPublic, + fakeSigner, hash, safeToPublic, toPublic, withSafeSigners) +import Pos.Infra.Diffusion.Types (Diffusion (..)) import Pos.Txp (topsortTxAuxes) import Pos.Util.UserSecret (usWallet, userSecret, wusRootKey) import Pos.Util.Util (maybeThrow) @@ -53,42 +56,37 @@ import Mode (MonadAuxxMode, makePubKeyAddressAuxx) -- | Parameters for 'SendToAllGenesis' command. data SendToAllGenesisParams = SendToAllGenesisParams - { stagpDuration :: !Int - , stagpConc :: !Int - , stagpDelay :: !Int - , stagpTpsSentFile :: !FilePath + { stagpGenesisTxsPerThread :: !Int + , stagpTxsPerThread :: !Int + , stagpConc :: !Int + , stagpDelay :: !Int + , stagpTpsSentFile :: !FilePath } deriving (Show) --- | Count submitted and failed transactions. +-- | Count submitted transactions. -- -- This is used in the benchmarks using send-to-all-genesis data TxCount = TxCount { _txcSubmitted :: !Int - , _txcFailed :: !Int -- How many threads are still sending transactions. , _txcThreads :: !Int } addTxSubmit :: Mockable SharedAtomic m => SharedAtomicT m TxCount -> m () addTxSubmit = flip modifySharedAtomic - (\(TxCount submitted failed sending) -> - pure (TxCount (submitted + 1) failed sending, ())) - -addTxFailed :: Mockable SharedAtomic m => SharedAtomicT m TxCount -> m () -addTxFailed = - flip modifySharedAtomic - (\(TxCount submitted failed sending) -> - pure (TxCount submitted (failed + 1) sending, ())) + (\(TxCount submitted sending) -> + pure (TxCount (submitted + 1) sending, ())) sendToAllGenesis :: forall m. MonadAuxxMode m - => Diffusion m + => ProtocolMagic + -> Diffusion m -> SendToAllGenesisParams -> m () -sendToAllGenesis diffusion (SendToAllGenesisParams duration conc delay_ tpsSentFile) = do +sendToAllGenesis pm diffusion (SendToAllGenesisParams genesisTxsPerThread txsPerThread conc delay_ tpsSentFile) = do let genesisSlotDuration = fromIntegral (toMicroseconds $ bvdSlotDuration genesisBlockVersionData) `div` 1000000 :: Int keysToSend = fromMaybe (error "Genesis secret keys are unknown") genesisSecretKeys - tpsMVar <- newSharedAtomic $ TxCount 0 0 conc + tpsMVar <- newSharedAtomic $ TxCount 0 conc startTime <- show . toInteger . getTimestamp . Timestamp <$> currentTime bracket (openFile tpsSentFile WriteMode) (liftIO . hClose) $ \h -> do liftIO $ hSetBuffering h LineBuffering @@ -97,65 +95,112 @@ sendToAllGenesis diffusion (SendToAllGenesisParams duration conc delay_ tpsSentF , "startTime=" <> startTime , "delay=" <> show delay_ ] liftIO $ T.hPutStrLn h "time,txCount,txType" - txQueue <- atomically $ newTQueue - -- prepare a queue with all transactions + -- prepare a queue for the transactions to be send + -- and a queue with necessary data for the creation of txs whose inputs + -- don't belong in genesis block + txQueue <- atomically $ newTQueue + txPreparationQueue <- atomically $ newTQueue logInfo $ sformat ("Found "%shown%" keys in the genesis block.") (length keysToSend) - forM_ keysToSend $ \secretKey -> do - outAddr <- makePubKeyAddressAuxx (toPublic secretKey) - let val1 = mkCoin 1 - txOut1 = TxOut { + startAtTxt <- liftIO $ lookupEnv "AUXX_START_AT" + let startAt = fromMaybe 0 . readMaybe . fromMaybe "" $ startAtTxt :: Int + -- construct a transaction, and add it to the queue + let addTx secretKey = do + let signer = fakeSigner secretKey + publicKey = toPublic secretKey + -- construct transaction output + outAddr <- makePubKeyAddressAuxx publicKey + let txOut1 = TxOut { txOutAddress = outAddr, - txOutValue = val1 + txOutValue = mkCoin 1 } - txOuts = TxOutAux txOut1 :| [] - atomically $ writeTQueue txQueue (secretKey, txOuts) - - -- every seconds, write the number of sent and failed transactions to a CSV file. + txOuts = TxOutAux txOut1 :| [] + utxo <- getOwnUtxoForPk $ safeToPublic signer + etx <- createTx pm mempty utxo signer txOuts publicKey + case etx of + Left err -> logError (sformat ("Error: "%build%" while trying to contruct tx") err) + Right (tx, _) -> do + atomically $ writeTQueue txQueue tx + atomically $ writeTQueue txPreparationQueue (tx, txOut1, secretKey) + let genesisTxs = conc * genesisTxsPerThread + nTxs = conc * txsPerThread + genesisKeys = take genesisTxs (drop startAt keysToSend) + -- Construct transactions whose inputs does not belong in genesis + -- block. Send as many coins as were received in the previous round + -- back to yourself. + prepareTxs :: Int -> m () + prepareTxs n + | n <= 0 = return () + | otherwise = (atomically $ tryReadTQueue txPreparationQueue) >>= \case + Just (tx, txOut1', senderKey) -> do + let txInp = TxInUtxo (hash (taTx tx)) 0 + utxo' = M.fromList [(txInp, TxOutAux txOut1')] + txOuts2 = TxOutAux txOut1' :| [] + -- It is expected that the output from the previously sent transaction is + -- included in the UTxO by the time this transaction will actually be sent. + etx' <- createTx pm mempty utxo' (fakeSigner senderKey) txOuts2 (toPublic senderKey) + case etx' of + Left err -> logError (sformat ("Error: "%build%" while trying to contruct tx") err) + Right (tx', _) -> do + atomically $ writeTQueue txQueue tx' + -- add to preparation queue one more time data + -- necessary to construct one more transaction + -- with the same sender + when (n > genesisTxs) $ + atomically $ writeTQueue txPreparationQueue (tx', txOut1', senderKey) + prepareTxs $ n - 1 + Nothing -> logInfo "No more txOuts in the queue." + -- every seconds, write the number of sent transactions to a CSV file. let writeTPS :: m () writeTPS = do - delay (sec genesisSlotDuration) + delay (fromMicroseconds . fromIntegral . (*) 1000000 $ genesisSlotDuration :: Microsecond) curTime <- show . toInteger . getTimestamp . Timestamp <$> currentTime - finished <- modifySharedAtomic tpsMVar $ \(TxCount submitted failed sending) -> do + finished <- modifySharedAtomic tpsMVar $ \(TxCount submitted sending) -> do -- CSV is formatted like this: -- time,txCount,txType liftIO $ T.hPutStrLn h $ T.intercalate "," [curTime, show $ submitted, "submitted"] - liftIO $ T.hPutStrLn h $ T.intercalate "," [curTime, show $ failed, "failed"] - return (TxCount 0 0 sending, sending <= 0) + return (TxCount 0 sending, sending <= 0) if finished - then logInfo "Finished writing TPS samples." - else writeTPS + then logInfo "Finished writing TPS samples." + else writeTPS -- Repeatedly take transactions from the queue and send them. -- Do this n times. sendTxs :: Int -> m () sendTxs n | n <= 0 = do logInfo "All done sending transactions on this thread." - modifySharedAtomic tpsMVar $ \(TxCount submitted failed sending) -> - return (TxCount submitted failed (sending - 1), ()) + modifySharedAtomic tpsMVar $ \(TxCount submitted sending) -> + return (TxCount submitted (sending - 1), ()) | otherwise = (atomically $ tryReadTQueue txQueue) >>= \case - Just (key, txOuts) -> do - utxo <- getOwnUtxoForPk $ safeToPublic (fakeSigner key) - etx <- createTx mempty utxo (fakeSigner key) txOuts (toPublic key) - case etx of - Left err -> do - addTxFailed tpsMVar - logError (sformat ("Error: "%build%" while trying to send") err) - Right (tx, _) -> do - res <- submitTxRaw diffusion tx - addTxSubmit tpsMVar - logInfo $ if res - then sformat ("Submitted transaction: "%txaF) tx - else sformat ("Applied transaction "%txaF%", however no neighbour applied it") tx - delay $ ms delay_ + Just tx -> do + res <- submitTxRaw diffusion tx + addTxSubmit tpsMVar + logInfo $ if res + then sformat ("Submitted transaction: "%txaF) tx + else sformat ("Applied transaction "%txaF%", however no neighbour applied it") tx + delay $ (fromMicroseconds . fromIntegral . (*) 1000 $ delay_ :: Microsecond) logInfo "Continuing to send transactions." sendTxs (n - 1) - Nothing -> logInfo "No more transactions in the queue." + Nothing -> do + logInfo "No more transactions in the queue." + sendTxs 0 + sendTxsConcurrently n = void $ forConcurrently [1..conc] (const (sendTxs n)) + -- pre construct the transactions that send funds from genesis. + -- Otherwise, we'll be CPU bound and will not achieve high transaction + -- rates. If we pre construct all the transactions, the + -- startup time will be quite long. + forM_ genesisKeys addTx -- Send transactions while concurrently writing the TPS numbers every -- slot duration. The 'writeTPS' action takes care to *always* write -- after every slot duration, even if it is killed, so as to -- guarantee that we don't miss any numbers. - void $ concurrently writeTPS (sendTxsConcurrently duration) + -- + -- While we're sending, we're constructing the transactions + -- that don't send coins from genesis and send 1 coin back to + -- themselves over and over. + void $ + concurrently (prepareTxs $ nTxs - genesisTxs) $ + concurrently writeTPS (sendTxsConcurrently txsPerThread) ---------------------------------------------------------------------------- -- Casual sending @@ -168,11 +213,12 @@ instance Exception AuxxException send :: forall m. MonadAuxxMode m - => Diffusion m + => ProtocolMagic + -> Diffusion m -> Int -> NonEmpty TxOut -> m () -send diffusion idx outputs = do +send pm diffusion idx outputs = do skey <- takeSecret let curPk = encToPublic skey let plainAddresses = map (flip makePubKeyAddress curPk . IsBootstrapEraAddr) [False, True] @@ -185,7 +231,7 @@ send diffusion idx outputs = do let addrSig = HM.fromList $ zip allAddresses signers let getSigner addr = HM.lookup addr addrSig -- BE CAREFUL: We create remain address using our pk, wallet doesn't show such addresses - (txAux,_) <- lift $ prepareMTx getSigner mempty def (NE.fromList allAddresses) (map TxOutAux outputs) curPk + (txAux,_) <- lift $ prepareMTx pm getSigner mempty def (NE.fromList allAddresses) (map TxOutAux outputs) curPk txAux <$ (ExceptT $ try $ submitTxRaw diffusion txAux) case etx of Left err -> logError $ sformat ("Error: "%stext) (toText $ displayException err) diff --git a/auxx/src/Command/TyProjection.hs b/auxx/src/Command/TyProjection.hs index 508ad816ede..fe7ab521e85 100644 --- a/auxx/src/Command/TyProjection.hs +++ b/auxx/src/Command/TyProjection.hs @@ -31,9 +31,8 @@ module Command.TyProjection import Universum import Data.Scientific (Scientific, floatingOrInteger, toBoundedInteger, toRealFloat) -import Data.Time.Units (TimeUnit, convertUnit) +import Data.Time.Units (TimeUnit, Microsecond, convertUnit, fromMicroseconds) import Serokell.Data.Memory.Units (Byte, fromBytes) -import Serokell.Util (sec) import Pos.Core (AddrStakeDistribution (..), Address, BlockVersion, Coin, CoinPortion, EpochIndex, ScriptVersion, SoftwareVersion, StakeholderId, @@ -93,8 +92,10 @@ tyByte = fromBytes <$> TyProjection "Byte" (sciToInteger <=< preview _ValueNumbe sciToInteger :: Scientific -> Maybe Integer sciToInteger = either (const Nothing) Just . floatingOrInteger @Double @Integer -tySecond :: TimeUnit a => TyProjection a -tySecond = convertUnit . sec <$> TyProjection "Second" (toBoundedInteger <=< preview _ValueNumber) +tySecond :: forall a . TimeUnit a => TyProjection a +tySecond = + convertUnit . (fromMicroseconds . fromIntegral . (*) 1000000 :: Int -> Microsecond) <$> + TyProjection "Second" (toBoundedInteger <=< preview _ValueNumber) tyScriptVersion :: TyProjection ScriptVersion tyScriptVersion = TyProjection "ScriptVersion" (toBoundedInteger <=< preview _ValueNumber) @@ -149,10 +150,10 @@ tyProposeUpdateSystem :: TyProjection ProposeUpdateSystem tyProposeUpdateSystem = TyProjection "ProposeUpdateSystem" (preview _ValueProposeUpdateSystem) tySystemTag :: TyProjection SystemTag -tySystemTag = TyProjection "SystemTag" ((fmap . fmap) (SystemTag . fromString) (preview _ValueString)) +tySystemTag = TyProjection "SystemTag" ((fmap . fmap) (SystemTag) (preview _ValueString)) tyApplicationName :: TyProjection ApplicationName -tyApplicationName = TyProjection "ApplicationName" ((fmap . fmap) (ApplicationName . fromString) (preview _ValueString)) +tyApplicationName = TyProjection "ApplicationName" ((fmap . fmap) (ApplicationName) (preview _ValueString)) -tyString :: TyProjection String +tyString :: TyProjection Text tyString = TyProjection "String" (preview _ValueString) diff --git a/auxx/src/Command/Update.hs b/auxx/src/Command/Update.hs index 08ca08f4866..3c7645efdf7 100644 --- a/auxx/src/Command/Update.hs +++ b/auxx/src/Command/Update.hs @@ -20,10 +20,10 @@ import System.Wlog (CanLog, HasLoggerName, logDebug, logError, logInfo import Pos.Binary (Raw) import Pos.Client.KeyStorage (getSecretKeysPlain) import Pos.Client.Update.Network (submitUpdateProposal, submitVote) -import Pos.Crypto (Hash, emptyPassphrase, hash, hashHexF, unsafeHash, withSafeSigner, - withSafeSigners) -import Pos.Diffusion.Types (Diffusion (..)) +import Pos.Crypto (Hash, ProtocolMagic, emptyPassphrase, hash, hashHexF, unsafeHash, + withSafeSigner, withSafeSigners) import Pos.Exception (reportFatalError) +import Pos.Infra.Diffusion.Types (Diffusion (..)) import Pos.Update (SystemTag, UpId, UpdateData (..), installerHash, mkUpdateProposalWSign, mkUpdateVoteSafe) @@ -37,16 +37,17 @@ import Repl (PrintAction) vote :: MonadAuxxMode m - => Diffusion m + => ProtocolMagic + -> Diffusion m -> Int -> Bool -> UpId -> m () -vote diffusion idx decision upid = do +vote pm diffusion idx decision upid = do logDebug $ "Submitting a vote :" <> show (idx, decision, upid) skey <- (!! idx) <$> getSecretKeysPlain mbVoteUpd <- withSafeSigner skey (pure emptyPassphrase) $ mapM $ \signer -> - pure $ mkUpdateVoteSafe signer upid decision + pure $ mkUpdateVoteSafe pm signer upid decision case mbVoteUpd of Nothing -> logError "Invalid passphrase" Just voteUpd -> do @@ -59,10 +60,11 @@ vote diffusion idx decision upid = do propose :: MonadAuxxMode m - => Diffusion m + => ProtocolMagic + -> Diffusion m -> ProposeUpdateParams -> m UpId -propose diffusion ProposeUpdateParams{..} = do +propose pm diffusion ProposeUpdateParams{..} = do logDebug "Proposing update..." skey <- (!! puSecretKeyIdx) <$> getSecretKeysPlain updateData <- mapM updateDataElement puUpdates @@ -76,6 +78,7 @@ propose diffusion ProposeUpdateParams{..} = do let publisherSS = ss !! if not puVoteAll then 0 else puSecretKeyIdx let updateProposal = mkUpdateProposalWSign + pm puBlockVersion puBlockVersionModifier puSoftwareVersion @@ -83,7 +86,7 @@ propose diffusion ProposeUpdateParams{..} = do def publisherSS let upid = hash updateProposal - submitUpdateProposal diffusion ss updateProposal + submitUpdateProposal pm diffusion ss updateProposal if not puVoteAll then putText (sformat ("Update proposal submitted, upId: "%hashHexF) upid) else diff --git a/auxx/src/Lang.hs b/auxx/src/Lang.hs index 9cc0f056f3b..5d98eeb2761 100644 --- a/auxx/src/Lang.hs +++ b/auxx/src/Lang.hs @@ -1,3 +1,23 @@ -- | Language. -{-# OPTIONS_GHC -F -pgmF autoexporter #-} +module Lang + ( module Lang.Value + , module Lang.Argument + , module Lang.Command + , module Lang.DisplayError + , module Lang.Interpreter + , module Lang.Lexer + , module Lang.Name + , module Lang.Parser + , module Lang.Syntax + ) where + +import Lang.Value +import Lang.Argument +import Lang.Command +import Lang.DisplayError +import Lang.Interpreter +import Lang.Lexer +import Lang.Name +import Lang.Parser +import Lang.Syntax \ No newline at end of file diff --git a/auxx/src/Lang/DisplayError.hs b/auxx/src/Lang/DisplayError.hs index 27a70fdbe34..29c67ae2b0d 100644 --- a/auxx/src/Lang/DisplayError.hs +++ b/auxx/src/Lang/DisplayError.hs @@ -104,7 +104,7 @@ ppParseError (ParseError str (Report {..})) = <+> hcat (punctuate (text ", or ") $ map text expected) <$> renderLines where - unconsumedDesc = maybe "end of input" show . head . fmap snd $ unconsumed + unconsumedDesc = maybe "end of input" show . (fmap fst . uncons) . fmap snd $ unconsumed strLines = nonEmpty $ take spanLines . drop (spanLineStart - 1) $ lines str renderLines = case strLines of Nothing -> diff --git a/auxx/src/Lang/Lexer.hs b/auxx/src/Lang/Lexer.hs index b850bffe4e4..ee3d50b5c82 100644 --- a/auxx/src/Lang/Lexer.hs +++ b/auxx/src/Lang/Lexer.hs @@ -24,9 +24,10 @@ module Lang.Lexer , tokenize , tokenize' , detokenize + , tokenRender ) where -import Universum +import Universum hiding (try) import qualified Control.Applicative.Combinators.NonEmpty as NonEmpty import Control.Lens (makePrisms) @@ -45,16 +46,17 @@ import Text.Megaparsec (Parsec, SourcePos (..), between, choice, eof, manyTill, notFollowedBy, parseMaybe, skipMany, takeP, takeWhile1P, try, unPos, ()) import Text.Megaparsec.Char (anyChar, char, satisfy, spaceChar, string) -import Text.Megaparsec.Char.Lexer (charLiteral, decimal, scientific, signed) +import Text.Megaparsec.Char.Lexer (decimal, scientific, signed) import Lang.Name (Letter, Name (..), unsafeMkLetter) -import Pos.Arbitrary.Core () -import Pos.Core (Address, BlockVersion (..), SoftwareVersion (..), StakeholderId, - decodeTextAddress, ApplicationName (..)) +import Pos.Core (Address, ApplicationName (..), BlockVersion (..), SoftwareVersion (..), + StakeholderId, decodeTextAddress) import Pos.Crypto (AHash (..), PublicKey, decodeAbstractHash, fullPublicKeyF, hashHexF, parseFullPublicKey, unsafeCheatingHashCoerce) import Pos.Util.Util (toParsecError) +import Test.Pos.Core.Arbitrary () + data BracketSide = BracketSideOpening | BracketSideClosing deriving (Eq, Ord, Show, Generic) @@ -98,7 +100,7 @@ isFilePathChar c = isAlphaNum c || c `elem` ['.', '/', '-', '_'] data Token = TokenSquareBracket BracketSide | TokenParenthesis BracketSide - | TokenString String + | TokenString Text | TokenNumber Scientific | TokenAddress Address | TokenPublicKey PublicKey @@ -124,7 +126,14 @@ tokenRender :: Token -> Text tokenRender = \case TokenSquareBracket bs -> withBracketSide "[" "]" bs TokenParenthesis bs -> withBracketSide "(" ")" bs - TokenString s -> show s + -- Double up every double quote, and surround the whole thing with double + -- quotes. + TokenString t -> quote (escapeQuotes t) + where + quote :: Text -> Text + quote t' = Text.concat [Text.singleton '\"', t', Text.singleton '\"'] + escapeQuotes :: Text -> Text + escapeQuotes = Text.intercalate "\"\"" . Text.splitOn "\"" TokenNumber n -> show n TokenAddress a -> pretty a TokenPublicKey pk -> sformat fullPublicKeyF pk @@ -186,7 +195,7 @@ pToken' = choice , string "~software~" *> (TokenSoftwareVersion <$> try pSoftwareVersion) , marking "filepath" $ TokenFilePath <$> pFilePath , marking "num" $ TokenNumber <$> pScientific - , marking "str" $ TokenString <$> pString + , marking "str" $ TokenString <$> pText , marking "ident" $ pIdent ] "token" @@ -200,10 +209,21 @@ pPunct = choice , char ';' $> TokenSemicolon ] "punct" -pString :: Lexer String -pString = - char '\"' *> - manyTill (charLiteral <|> anyChar) (char '\"') +pText :: Lexer Text +pText = do + _ <- char '\"' + Text.pack <$> loop [] + where + loop :: [Char] -> Lexer [Char] + loop !acc = do + next <- anyChar + case next of + -- Check for double double quotes. If it's a single double quote, + -- it's the end of the string. + '\"' -> try (doubleQuote acc) <|> pure (reverse acc) + c -> loop (c : acc) + doubleQuote :: [Char] -> Lexer [Char] + doubleQuote !acc = char '\"' >> loop ('\"' : acc) pSomeAlphaNum :: Lexer Text pSomeAlphaNum = takeWhile1P (Just "alphanumeric") isAlphaNum @@ -281,3 +301,5 @@ pScientific = do n <- signed (return ()) scientific p <- isJust <$> optional (char '%') return $ if p then n / 100 else n + +{-# ANN module ("HLint: ignore Use toText" :: Text) #-} diff --git a/auxx/src/Lang/Name.hs b/auxx/src/Lang/Name.hs index 50e0b8a0d80..7e92730bf12 100644 --- a/auxx/src/Lang/Name.hs +++ b/auxx/src/Lang/Name.hs @@ -13,8 +13,8 @@ import Data.Coerce (coerce) import qualified Data.List.NonEmpty as NonEmpty import Data.List.Split (splitWhen) import qualified Data.Text.Buildable as Buildable -import Test.QuickCheck.Arbitrary.Generic (Arbitrary (..), genericArbitrary, genericShrink) -import Test.QuickCheck.Gen (suchThat) +import Test.QuickCheck.Arbitrary.Generic (Arbitrary (..)) +import Test.QuickCheck.Gen (Gen, suchThat, listOf) -- | Invariant: @isAlpha . getLetter = const True@ newtype Letter = Letter { getLetter :: Char } @@ -33,8 +33,10 @@ unsafeMkName :: [String] -> Name unsafeMkName = coerce . fmap NonEmpty.fromList . NonEmpty.fromList instance Arbitrary Name where - arbitrary = genericArbitrary - shrink = genericShrink + arbitrary = Name <$> neList (neList arbitrary) + where + neList :: Gen a -> Gen (NonEmpty a) + neList gen = (:|) <$> gen <*> listOf gen instance Buildable Name where build diff --git a/auxx/src/Lang/Syntax.hs b/auxx/src/Lang/Syntax.hs index 75a2c9b359e..3ceb4b96071 100644 --- a/auxx/src/Lang/Syntax.hs +++ b/auxx/src/Lang/Syntax.hs @@ -29,7 +29,7 @@ deriving instance Show cmd => Show (Expr cmd) data Lit = LitNumber Scientific - | LitString String + | LitString Text | LitAddress Address | LitPublicKey PublicKey | LitStakeholderId StakeholderId diff --git a/auxx/src/Lang/Value.hs b/auxx/src/Lang/Value.hs index fd3a4d190c3..b40f3ab1680 100644 --- a/auxx/src/Lang/Value.hs +++ b/auxx/src/Lang/Value.hs @@ -86,7 +86,7 @@ data AddKeyParams = AddKeyParams data Value = ValueUnit | ValueNumber Scientific - | ValueString String + | ValueString Text | ValueBool Bool | ValueList [Value] | ValueAddress Address diff --git a/auxx/src/Mode.hs b/auxx/src/Mode.hs index b71befd09e6..3b090cda194 100644 --- a/auxx/src/Mode.hs +++ b/auxx/src/Mode.hs @@ -35,37 +35,34 @@ import Pos.Block.Slog (HasSlogContext (..), HasSlogGState (..)) import Pos.Client.KeyStorage (MonadKeys (..), MonadKeysRead (..), getSecretDefault, modifySecretDefault) import Pos.Client.Txp.Addresses (MonadAddresses (..)) -import Pos.Client.Txp.Balances (MonadBalances(..), getBalanceFromUtxo, +import Pos.Client.Txp.Balances (MonadBalances (..), getBalanceFromUtxo, getOwnUtxosGenesis) import Pos.Client.Txp.History (MonadTxHistory (..), getBlockHistoryDefault, getLocalHistoryDefault, saveTxDefault) -import Pos.Communication.Limits (HasAdoptedBlockVersionData (..)) import Pos.Context (HasNodeContext (..)) -import Pos.Core (Address, HasConfiguration, HasPrimaryKey (..), - IsBootstrapEraAddr (..), deriveFirstHDAddress, largestPubKeyAddressBoot, +import Pos.Core (Address, HasConfiguration, HasPrimaryKey (..), IsBootstrapEraAddr (..), + deriveFirstHDAddress, largestPubKeyAddressBoot, largestPubKeyAddressSingleKey, makePubKeyAddress, siEpoch) import Pos.Crypto (EncryptedSecretKey, PublicKey, emptyPassphrase) import Pos.DB (DBSum (..), MonadGState (..), NodeDBs, gsIsBootstrapEra) import Pos.DB.Class (MonadDB (..), MonadDBRead (..)) import Pos.Generator.Block (BlockGenMode) import Pos.GState (HasGStateContext (..), getGStateImplicit) -import Pos.KnownPeers (MonadFormatPeers (..)) +import Pos.Infra.Network.Types (HasNodeType (..), NodeType (..)) +import Pos.Infra.Reporting (HasMisbehaviorMetrics (..), MonadReporting (..)) +import Pos.Infra.Shutdown (HasShutdownContext (..)) +import Pos.Infra.Slotting.Class (MonadSlots (..)) +import Pos.Infra.Slotting.MemState (HasSlottingVar (..), MonadSlotsData) +import Pos.Infra.Util.JsonLog.Events (HasJsonLogConfig (..)) +import Pos.Infra.Util.TimeWarp (CanJsonLog (..)) import Pos.Launcher (HasConfigurations) -import Pos.Network.Types (HasNodeType (..), NodeType (..)) -import Pos.Reporting (HasReportingContext (..)) -import Pos.Shutdown (HasShutdownContext (..)) -import Pos.Slotting.Class (MonadSlots (..)) -import Pos.Slotting.MemState (HasSlottingVar (..), MonadSlotsData) -import Pos.Ssc.Configuration (HasSscConfiguration) import Pos.Ssc.Types (HasSscContext (..)) import Pos.Txp (HasTxpConfiguration, MempoolExt, MonadTxpLocal (..), txNormalize, txProcessTransaction, txProcessTransactionNoLock) import Pos.Txp.DB.Utxo (getFilteredUtxo) import Pos.Util (HasLens (..), postfixLFields) import Pos.Util.CompileInfo (HasCompileInfo, withCompileInfo) -import Pos.Util.JsonLog (HasJsonLogConfig (..)) import Pos.Util.LoggerName (HasLoggerName' (..)) -import Pos.Util.TimeWarp (CanJsonLog (..)) import Pos.Util.UserSecret (HasUserSecret (..)) import Pos.WorkMode (EmptyMempoolExt, RealMode, RealModeContext (..)) @@ -113,8 +110,17 @@ instance HasSscContext AuxxContext where instance HasPrimaryKey AuxxContext where primaryKey = acRealModeContext_L . primaryKey -instance HasReportingContext AuxxContext where - reportingContext = acRealModeContext_L . reportingContext +-- | Ignore reports. +-- FIXME it's a bad sign that we even need this instance. +-- The pieces of the software which the block generator uses should never +-- even try to report. +instance MonadReporting AuxxMode where + report _ = pure () + +-- | Ignore reports. +-- FIXME it's a bad sign that we even need this instance. +instance HasMisbehaviorMetrics AuxxContext where + misbehaviorMetrics = lens (const Nothing) const instance HasUserSecret AuxxContext where userSecret = acRealModeContext_L . userSecret @@ -185,10 +191,7 @@ instance HasConfiguration => MonadDB AuxxMode where instance HasConfiguration => MonadGState AuxxMode where gsAdoptedBVData = realModeToAuxx ... gsAdoptedBVData -instance HasConfiguration => HasAdoptedBlockVersionData AuxxMode where - adoptedBVData = gsAdoptedBVData - -instance HasConfiguration => MonadBListener AuxxMode where +instance MonadBListener AuxxMode where onApplyBlocks = realModeToAuxx ... onApplyBlocks onRollbackBlocks = realModeToAuxx ... onRollbackBlocks @@ -197,18 +200,13 @@ instance HasConfiguration => MonadBalances AuxxMode where getBalance = getBalanceFromUtxo instance ( HasConfiguration - , HasSscConfiguration , HasTxpConfiguration - , HasCompileInfo ) => MonadTxHistory AuxxMode where getBlockHistory = getBlockHistoryDefault getLocalHistory = getLocalHistoryDefault saveTx = saveTxDefault -instance MonadFormatPeers AuxxMode where - formatKnownPeers formatter = withReaderT acRealModeContext (formatKnownPeers formatter) - instance (HasConfigurations, HasCompileInfo) => MonadAddresses AuxxMode where type AddrData AuxxMode = PublicKey @@ -229,11 +227,10 @@ type instance MempoolExt AuxxMode = EmptyMempoolExt instance ( HasConfiguration , HasTxpConfiguration - , HasCompileInfo ) => MonadTxpLocal AuxxMode where - txpNormalize = withReaderT acRealModeContext txNormalize - txpProcessTx = withReaderT acRealModeContext . txProcessTransaction + txpNormalize = withReaderT acRealModeContext . txNormalize + txpProcessTx pm = withReaderT acRealModeContext . txProcessTransaction pm instance (HasConfigurations) => MonadTxpLocal (BlockGenMode EmptyMempoolExt AuxxMode) where diff --git a/auxx/src/Plugin.hs b/auxx/src/Plugin.hs index 22fea81542d..d8eef3b5312 100644 --- a/auxx/src/Plugin.hs +++ b/auxx/src/Plugin.hs @@ -16,18 +16,15 @@ import System.Posix.Process (exitImmediately) #endif import Control.Monad.Except (ExceptT (..), withExceptT) import Data.Constraint (Dict (..)) +import Data.Time.Units (Second) import Formatting (float, int, sformat, (%)) import Mockable (Delay, Mockable, delay) -import Serokell.Util (sec) import System.IO (hFlush, stdout) import System.Wlog (CanLog, HasLoggerName, logInfo) -import Pos.Communication (OutSpecs (..)) -import Pos.Crypto (AHash (..), fullPublicKeyF, hashHexF) -import Pos.Diffusion.Types (Diffusion) +import Pos.Crypto (AHash (..), ProtocolMagic, fullPublicKeyF, hashHexF) +import Pos.Infra.Diffusion.Types (Diffusion) import Pos.Txp (genesisUtxo, unGenesisUtxo) -import Pos.Util.CompileInfo (HasCompileInfo) -import Pos.Worker.Types (WorkerSpec, worker) import AuxxOptions (AuxxOptions (..)) import Command (createCommandProcs) @@ -42,73 +39,72 @@ import Repl (PrintAction, WithCommandAction (..)) {-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-} auxxPlugin :: - (HasCompileInfo, MonadAuxxMode m, Mockable Delay m) - => AuxxOptions + (MonadAuxxMode m, Mockable Delay m) + => ProtocolMagic + -> AuxxOptions -> Either WithCommandAction Text - -> (WorkerSpec m, OutSpecs) -auxxPlugin auxxOptions repl = worker mempty $ \diffusion -> do + -> Diffusion m + -> m () +auxxPlugin pm auxxOptions repl = \diffusion -> do logInfo $ sformat ("Length of genesis utxo: " %int) (length $ unGenesisUtxo genesisUtxo) - rawExec (Just Dict) auxxOptions (Just diffusion) repl + rawExec (Just pm) (Just Dict) auxxOptions (Just diffusion) repl rawExec :: - ( HasCompileInfo - , MonadIO m + ( MonadIO m , MonadCatch m , CanLog m , HasLoggerName m , Mockable Delay m ) - => Maybe (Dict (MonadAuxxMode m)) + => Maybe ProtocolMagic + -> Maybe (Dict (MonadAuxxMode m)) -> AuxxOptions -> Maybe (Diffusion m) -> Either WithCommandAction Text -> m () -rawExec mHasAuxxMode AuxxOptions{..} mDiffusion = \case +rawExec pm mHasAuxxMode AuxxOptions{..} mDiffusion = \case Left WithCommandAction{..} -> do printAction "... the auxx plugin is ready" - forever $ withCommand $ runCmd mHasAuxxMode mDiffusion printAction - Right cmd -> runWalletCmd mHasAuxxMode mDiffusion cmd + forever $ withCommand $ runCmd pm mHasAuxxMode mDiffusion printAction + Right cmd -> runWalletCmd pm mHasAuxxMode mDiffusion cmd runWalletCmd :: - ( HasCompileInfo - , MonadIO m - , MonadCatch m + ( MonadIO m , CanLog m , HasLoggerName m , Mockable Delay m ) - => Maybe (Dict (MonadAuxxMode m)) + => Maybe ProtocolMagic + -> Maybe (Dict (MonadAuxxMode m)) -> Maybe (Diffusion m) -> Text -> m () -runWalletCmd mHasAuxxMode mDiffusion line = do - runCmd mHasAuxxMode mDiffusion printAction line +runWalletCmd pm mHasAuxxMode mDiffusion line = do + runCmd pm mHasAuxxMode mDiffusion printAction line printAction "Command execution finished" printAction " " -- for exit by SIGPIPE liftIO $ hFlush stdout #if !(defined(mingw32_HOST_OS)) - delay $ sec 3 + delay (3 :: Second) liftIO $ exitImmediately ExitSuccess #endif where printAction = putText runCmd :: - ( HasCompileInfo - , MonadIO m - , MonadCatch m + ( MonadIO m , CanLog m , HasLoggerName m - , Mockable Delay m ) - => Maybe (Dict (MonadAuxxMode m)) + => Maybe ProtocolMagic + -> Maybe (Dict (MonadAuxxMode m)) -> Maybe (Diffusion m) -> PrintAction m -> Text -> m () -runCmd mHasAuxxMode mDiffusion printAction line = do - let commandProcs = createCommandProcs mHasAuxxMode printAction mDiffusion +runCmd pm mHasAuxxMode mDiffusion printAction line = do + let commandProcs = createCommandProcs pm mHasAuxxMode printAction mDiffusion parse = withExceptT Lang.ppParseError . ExceptT . return . Lang.parse resolveCommandProcs = withExceptT Lang.ppResolveErrors . ExceptT . return . diff --git a/auxx/test/Test/Auxx/Lang/ArgumentSpec.hs b/auxx/test/Test/Auxx/Lang/ArgumentSpec.hs index a1639e9bc20..2a09e2890e2 100644 --- a/auxx/test/Test/Auxx/Lang/ArgumentSpec.hs +++ b/auxx/test/Test/Auxx/Lang/ArgumentSpec.hs @@ -53,7 +53,7 @@ unitFailureExample1 args err = do consumeArguments acExample1 args `shouldBe` Left err -acExample1 :: ArgumentConsumer (String, Int) +acExample1 :: ArgumentConsumer (Text, Int) acExample1 = do x <- getArg tyString "s" y <- getArg tyInt "i" diff --git a/auxx/test/Test/Auxx/Lang/LexerSpec.hs b/auxx/test/Test/Auxx/Lang/LexerSpec.hs index a904411f862..62d7a774da2 100644 --- a/auxx/test/Test/Auxx/Lang/LexerSpec.hs +++ b/auxx/test/Test/Auxx/Lang/LexerSpec.hs @@ -31,7 +31,7 @@ propHandlesValidInput = property $ liftA2 (==) (map snd . tokenize . detokenize) unitLexerSample1 :: Expectation unitLexerSample1 = map snd (tokenize input) `shouldBe` output where - input = " ( \"Hello\"; [=propose-patak-update ./secret.key /home/a_b\\ b-c] \"\\\"\" ) " + input = " ( \"Hello\"; [=propose-patak-update ./secret.key /home/a_b\\ b-c] \"\"\"\" ) " output = [ TokenParenthesis BracketSideOpening , TokenString "Hello" diff --git a/benchmarks/check_fork.sh b/benchmarks/check_fork.sh new file mode 100755 index 00000000000..cce6e65e100 --- /dev/null +++ b/benchmarks/check_fork.sh @@ -0,0 +1,34 @@ +#!/bin/bash + +## needs 'gnused' from Nix on MacOSX + +if [ $# -lt 1 ]; then + echo "$0 " + exit 1 +fi + +BASEDIR=$(dirname "$0") +REPFILE=$1 +BLIDs= +NODES="c-a-1 c-a-2 c-a-3 c-b-1 c-b-2 c-c-1 c-c-2" + +BLIDs=$(awk '/transactions in fork:/{start=1;next} start; !NF && start{start=0}' "$REPFILE" \ + | cut -d " " -f 2 | sort | uniq | sed -ne '2,$p' | paste -s -d " " -) + + +echo -n " " +for BLID in ${BLIDs}; do + echo -n " ${BLID} " +done +echo +for NODE in ${NODES}; do + echo -n "$NODE" + FN="${NODE}.log" + "${BASEDIR}/xblocks.sh" "$FN" > "${FN}.blocks" + for BLID in ${BLIDs}; do + #CNT=`fgrep "previous block: ${BLID}" $FN | wc -l` + CNT=$( "${BASEDIR}/parse.hs" "${BLID}" < "${FN}.blocks" | tail -1 | cut -d \" \" -f 1 ) + echo -n " ${CNT}" + done + echo +done diff --git a/benchmarks/parse.hs b/benchmarks/parse.hs new file mode 100755 index 00000000000..f7429c85de2 --- /dev/null +++ b/benchmarks/parse.hs @@ -0,0 +1,74 @@ +#!/usr/bin/env stack +-- stack script --resolver lts-9.17 --package bytestring --package conduit-combinators --package conduit-extra --package containers --package optparse-applicative --package unix +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE OverloadedStrings #-} + +{- running GHCi + stack ghci --package bytestring --package conduit-combinators --package conduit-extra --package containers --package optparse-applicative --package text --package unix + + :set -XOverloadedStrings +-} + +module ParseBlocks +where + +import Conduit +import Control.Monad (forM) +import Data.ByteString.Char8 hiding (head, map) +import qualified Data.Conduit.Binary as CB +import qualified Data.List as L (length, map, sortBy) +import qualified Data.Map as M +import Options.Applicative (argument, execParser, info, metavar, some, str) +import Prelude hiding (isPrefixOf, putStrLn) + +type BlockRel = M.Map ByteString ByteString +type BlockPair = (ByteString, ByteString) + +interpretBP :: ByteString -> BlockPair +interpretBP s = read s' + where s' = unpack s + +list2map :: [ByteString] -> BlockRel +list2map ls = M.fromList $ L.map ( interpretBP ) ls + +successors :: Int -> BlockRel -> ByteString -> IO (Int) +successors n br h = do + putStrLn $ ((pack . show) n) `append` " : " `append` h + case M.lookup h br of + Just suc -> successors (n + 1) br suc + Nothing -> return (n) + +findBlock rb h = + case M.toList $ M.filter (\v -> h `isPrefixOf` v) rb of + [] -> "" + ll -> (snd . head) ll + + +{- entry point -} +main :: IO () +main = do + let parser = some (argument str (metavar "Block hashes ...")) + opts = info parser mempty + args <- fmap (map pack) (execParser opts :: IO [String]) + + {- read list of pairs from stdin -} + ll <- runConduitRes $ stdinC + .| CB.lines + .| sinkList + + {- create map of hashes -} + rb <- return $ list2map ll + + {- for every argument on the command line -} + forks <- forM args (\h0 -> do + -- find a block hash that starts with + h <- return $ findBlock rb h0 + putStrLn h + -- find successors to a block hash + n <- successors 0 rb h + return $ (n, h) + ) + case L.sortBy (\(v1,v2) (w1,w2) -> (-v1) `compare` (-w1)) forks of + [] -> print "[]" + ((n,h):_) -> putStrLn $ ((pack . show) n) `append` " " `append` h + return () diff --git a/benchmarks/plots.r b/benchmarks/plots.r new file mode 100644 index 00000000000..c5249571683 --- /dev/null +++ b/benchmarks/plots.r @@ -0,0 +1,596 @@ +# +# call: Rscript ../plots.r 2018-02-03_053826 +# (curr. workdir is where the run-???.csv is) +# +# packages to install: dplyr, ggplot2, svglite, gplots, anytime, gridExtra +# (e.g. install.packages('svglite')) +# + +# if run in RStudio one can select the csv ("run-2018???.csv") in a file dialogue +INTERACTIVE <- FALSE + +library(dplyr) +library(ggplot2) +library(gplots) +library(anytime) +library(grid) +library(gridExtra) + +if (INTERACTIVE) { + #library('ggedit') # only if interactive editing + #pdf(NULL) # prevent PDF output + fnames <- file.choose() + fname <- fnames[1] + RUN <- sub('.*run-([-_0-9]+).csv', '\\1', fname) + bp <- dirname(fname) +} else { + args = commandArgs(trailingOnly=TRUE) + RUN <- args[1] + bp <- "." + fname <- paste('run-', RUN, '.csv', sep='') + pdf(paste("BM-",RUN,".pdf",sep=''), onefile=TRUE, compress=TRUE, paper="a4") # PDF output to file +} +fname2 <- paste(bp, '/report_', RUN, '.txt', sep='') +fname3 <- paste(bp, '/bench-settings', sep='') +fname4 <- paste(bp, '/times.csv', sep='') + +DESC='' # Add custom text to titles +k <- 6 #12 #24 # Protocol parameters determining +SLOTLENGTH <- 20 # the length of an epoch +EPOCHLENGTH <- 10*k*SLOTLENGTH + +# general constants which should correspond to the recording script +# these are defaults to which we fall back if they cannot be extracted from the log +#recDelay0 <- 5 # seconds +recCpuTicks0 <- 100 # `getconf CLK_TCK` +recPageSize0 <- 4096 # memory is indicated in pages + +# have trx times? +hasTrxTimes <- FALSE +if (file.exists(fname4)) { + hasTrxTimes <- TRUE +} + +# names of relay nodes +relays <- c('r-a-1', 'r-a-2', 'r-a-3' + , 'r-b-1', 'r-b-2' + , 'r-c-1', 'r-c-2' + , 'u-a-1', 'u-b-1', 'u-c-1' + ) + +# names of unprivileged relay nodes +uRelays <- c('u-a-1', 'u-b-1', 'u-c-1') + +coreNodes <- c('c-a-1', 'c-a-2', 'c-a-3', 'c-b-1', 'c-b-2', 'c-c-1', 'c-c-2') + +# read in transaction times +if (hasTrxTimes) { + times <- read.csv(fname4, header=FALSE, col.names=c("time", "cumm")) +} + +# prep and read in benchmark parameters +system(paste("sed -e 's/, /\\\n/g' ", fname3, " > ", fname3, "2", sep='')) +params <- read.csv(paste(fname3, "2", sep=''), header=FALSE, + col.names = c("parameter","value"), sep="=", + stringsAsFactor=FALSE) + +maxparam <- length(params[,2]) +if (params[maxparam,1]=="systemstart") { + params[maxparam+1,1] <- "time UTC" + params[maxparam+1,2] <- paste("", anytime(as.numeric(params[maxparam,2]), tz="UTC"), sep='') +} + +# read the report of the benchmark run +readReport <- function(filename, run=RUN) { + print(paste('reading data from', filename, sep=' ')) + report <- read.table(filename, sep=':', nrows=3, skip=1, col.names = c("desc", "count")) + return (report); +} + +# read and pre-process data from a benchmark run +readData <- function(filename, run=RUN) { + #filename <- paste('run-', run, '.csv', sep='') + print(paste('reading data from', filename, sep=' ')) + data <- read.csv(filename) + t0 <- min(data$time) + + # find first block created + txWritten <- data %>% filter(txType %in% c("written")) %>% filter(txCount > 0) + tFirstBlock <- min(txWritten$time) + tFirstBlock <- trunc((tFirstBlock - t0) / 1000 / EPOCHLENGTH) * EPOCHLENGTH * 1000 + t0 + data <- filter(data, time >= tFirstBlock) + + # time after start of experiment, in seconds + data$t <- (data$time - t0) %/% 1e6 + data$clustersize <- as.factor(data$clustersize) + data$concF <- as.factor(data$conc) + data$delayF <- as.factor(data$delay) + data <- data[!(data$txType %in% c('failed')),] + data$endT <- ave(data$t, data$run, FUN=max) + data$isRelay <- data$node %in% relays + data$isRelay <- as.factor(data$isRelay) + levels(data$isRelay) <- c('Core Nodes', 'Relay Nodes') + + # make the labels shorter + levels(data$txType)[levels(data$txType)=="mp_ProcessTransaction_Modify"] <- "hold tx" + levels(data$txType)[levels(data$txType)=="mp_ProcessTransaction_Wait"] <- "wait tx" + levels(data$txType)[levels(data$txType)=="mp_ApplyBlock_Modify"] <- "hold block" + levels(data$txType)[levels(data$txType)=="mp_ApplyBlock_Wait"] <- "wait block" + levels(data$txType)[levels(data$txType)=="mp_ApplyBlockWithRollback_Modify"] <- "hold rollback" + levels(data$txType)[levels(data$txType)=="mp_ApplyBlockWithRollback_Wait"] <- "wait rollback" + levels(data$txType)[levels(data$txType)=="mp_ApplyBlock_SizeAfter"] <- "size after block" + levels(data$txType)[levels(data$txType)=="mp_ApplyBlockWithRollback_SizeAfter"] <- "size after rollback" + levels(data$txType)[levels(data$txType)=="mp_ProcessTransaction_SizeAfter"] <- "size after tx" + + return(data) +} + +# reads os metrics from a file per node and returns dataframe with (io, statm, stat) +readOSmetrics <- function(nodename) { + fn <- paste(bp, '/', nodename, '-ts.log', sep='') + metrics <- {} + if (file.exists(fn)) { + isNewFile <- TRUE + # add to read.csv? stringsAsFactors=FALSE + if (isNewFile) { + metrics_csv <- read.csv(fn, as.is = c(TRUE), header=FALSE, skip=7, sep=" ") + } else { + metrics_csv <- read.csv(fn, as.is = c(TRUE), header=FALSE, skip=5, sep=" ") + } + mlen <- dim(metrics_csv)[1] + colnames(metrics_csv)[1:2] <- c("time", "stats") + metrics_csv <- cbind(nodename, metrics_csv[1:(mlen-2),]) # skip last 2 lines + metrics_csv$stats <- as.factor(metrics_csv$stats) + metrics_csv$time <- as.numeric(metrics_csv$time) + + metrics$io <- select(metrics_csv %>% filter(stats %in% c("io")), nodename : V9) + colnames(metrics$io) <- c("nodename", "time", "stats", "rchar", "wchar", "syscr", "syscw", "readbytes", "writebytes", "cxwbytes") + # convert columns from char to numeric + metrics$io$rchar <- as.numeric(metrics$io$rchar) + metrics$io$wchar <- as.numeric(metrics$io$wchar) + metrics$io$syscr <- as.numeric(metrics$io$syscr) + + metrics$mstat <- select(metrics_csv %>% filter(stats %in% c("statm")), nodename : V9) + colnames(metrics$mstat) <- c("nodename", "time", "stats", "size", "resident", "shared", "text", "lib", "data", "dt") + # convert columns from char to numeric + metrics$mstat$size <- as.numeric(metrics$mstat$size) + metrics$mstat$resident <- as.numeric(metrics$mstat$resident) + metrics$mstat$shared <- as.numeric(metrics$mstat$shared) + #plot(metrics$statm$size) + + metrics$stat <- metrics_csv %>% filter(stats %in% c("stat")) + colnames(metrics$stat) <- c("nodename", "time", "stats", "pid", "comm", "state", "ppid", "pgrp", "session", "tty", "tpgid", "flags", "minflt","cminflt","majflt","cmajflt", "utime", "stime", "cutime", "cstime", "priority", "nice", "nthr", "itrv", "starttime", "vsize", "rss", "rsslim", "startcode", "endcode", "startstack", "kstkesp", "kstkeip", "signal", + "blocked", "sigignore", "sigcatch", "wchan", "nswap", "cnswap", "exitsig", "processor", "rtprio", "policy", "delayio", "guesttime", "cguesttime", "startdata", "enddata", "startbrk", "argstart", "argend", "envstart", "envend", "exitcode") + metrics$stat$pid <- as.factor(metrics$stat$pid) + metrics$stat$comm <- as.factor(metrics$stat$comm) + metrics$stat$state <- as.factor(metrics$stat$state) + metrics$stat$ppid <- as.factor(metrics$stat$ppid) + metrics$stat$pgrp <- as.factor(metrics$stat$pgrp) + metrics$stat$session <- as.factor(metrics$stat$session) + metrics$stat$tty <- as.factor(metrics$stat$tty) + metrics$stat$tpgid <- as.factor(metrics$stat$tpgid) + metrics$stat$priority <- as.factor(metrics$stat$priority) + metrics$stat$starttime <- as.factor(metrics$stat$starttime) + metrics$stat$policy <- as.factor(metrics$stat$policy) + + # kernel constants per node; read from log file once they are there + if (isNewFile) { + metrics_params <- read.csv(fn, as.is = c(TRUE), header=FALSE, skip=5, nrows=1, sep=" ") + metrics_params <- strsplit(t(metrics_params), "=") + for (q in metrics_params) { + if (q[1] == "PAGESIZE") { metrics$pagesize[nodename] <- as.numeric(q[2]); } + if (q[1] == "CLKTCK") { metrics$clktck[nodename] <- as.numeric(q[2]); } + } + if (is.na(metrics$pagesize[nodename])) { + metrics$pagesize[nodename] <- recPageSize0; + } + if (is.na(metrics$clktck[nodename])) { metrics$clktck[nodename] <- recCpuTicks0; } + } else { + metrics$pagesize[nodename] <- recPageSize0 + #metrics$delay[nodename] <- recDelay0 + metrics$clktck[nodename] <- recCpuTicks0 + } + + # adjust + recPageSize <- recPageSize0 + if (! is.null(metrics$pagesize[nodename])) { recPageSize <- metrics$pagesize[nodename] } + recCpuTicks <- recCpuTicks0 + if (! is.null(metrics$clktck[nodename])) { recCpuTicks <- metrics$clktck[nodename] } + metrics$stat$rss <- metrics$stat$rss * recPageSize + metrics$stat$utime <- metrics$stat$utime / recCpuTicks * 100 + metrics$stat$stime <- metrics$stat$stime / recCpuTicks * 100 + #plot(metrics$stat$nthr) + #plot(metrics$stat$vsize) + } + return(metrics) +} + +# dashed vertical lines at the epoch boundaries +epochs <- function(d) { + tmin <- min(d$t) + tmin <- trunc(tmin / EPOCHLENGTH) * EPOCHLENGTH + epochs <- data.frame(start=seq(from=tmin, to=max(d$t), by=EPOCHLENGTH)) + geom_vline(data=epochs, + aes(xintercept = start, alpha=0.60) + , colour='red' + , linetype='dashed' + ) + } + +# dotted vertical lines every k slots +kslots <- function(d) { + tmin <- min(d$t) + tmin <- trunc(tmin / EPOCHLENGTH) * EPOCHLENGTH + kslots <- data.frame(start=seq(from=tmin, to=max(d$t), by=k*SLOTLENGTH)) + geom_vline(data=kslots, + aes(xintercept = start, alpha=0.60) + , colour='red' + , linetype='dotted' + ) + } + + +# histograms the rate of sent and written transactions +histTxs <- function(d, run=RUN, desc=DESC) { + dd <- d %>% + filter(txType %in% c("submitted", "written")) + maxtx <- max(dd$txCount) + crit <- "submitted" + dd <- d %>% + filter(txType %in% c(crit)) %>% + filter(txCount > 0) ### only blocks with transactions + + hist(dd$txCount, main=paste('generated (>0)', desc, sep = ' ') + , breaks=seq(0,maxtx, by=1) + , col=gray.colors(maxtx/2) + , xlab = "transactions/slot" ) + + crit <- "written" + dd <- d %>% + filter(txType %in% c(crit)) %>% + filter(txCount > 0) ### only blocks with transactions + + hist(dd$txCount, main=paste('integrated in blocks (>0)', desc, sep = ' ') + , breaks=seq(0,maxtx, by=1) + , col=gray.colors(maxtx/2) + , xlab = "transactions/slot" ) +} + +# plot the rate of sent and written transactions +plotTxs <- function(d, run=RUN, desc=DESC) { + dd <- d %>% + filter(txType %in% c("submitted", "written")) %>% + filter(txCount > 0) ### only blocks with transactions + ggplot(dd, aes(t, txCount/slotDuration)) + + epochs(d) + kslots(d) + + geom_point(aes(colour=node)) + + geom_smooth() + + ggtitle(paste( + 'Transaction frequency for core and relay nodes, run at ' + , run, desc, sep = ' ')) + + xlab("t [s] after start of experiment") + + ylab("transaction rate [Hz]") + + facet_grid(txType ~ run) + + guides(size = "none", colour = "legend", alpha = "none") + } + +# plot the mempool residency for core and relay nodes +plotMempools <- function(d, str='core and relay', run=RUN, desc=DESC) { + dd <- d %>% + filter(txType %in% c("size after block" + , "size after rollback" + , "size after tx")) + ggplot(dd, aes(t, txCount)) + + epochs(d) + + geom_point(aes(colour=node)) + + ggtitle(paste( + 'Mempool sizes for', str, 'nodes, run at ' + , run, desc, sep = ' ')) + + xlab("t [s] after start of experiment") + + ylab("Mempool size [# of transactions]") + + facet_grid(txType ~ isRelay, scales= "free", space = "free") + + guides(size = "none", colour = "legend", alpha = "none") +} + +# plot the wait and hold times for the local state lock +plotTimes <- function(d, str='core and relay', run=RUN, desc=DESC, lin=TRUE, minfilter = 0) { + if (lin) { + desc <- paste("\n(", desc, "linear scale,", "min =", minfilter, ")", sep=" ") + } else { + desc <- paste("\n(", desc, "log scale,", "min =", minfilter, ")", sep=" ") + } + dd <- d %>% + filter(txType %in% c("hold tx" + , "wait tx" + , "hold block" + , "wait block" + , "hold rollback" + , "wait rollback" + )) %>% filter(txCount > minfilter) ### <<<<<< + ggplot(dd, aes(t, txCount/1000)) + + epochs(d) + + geom_point(aes(colour=node)) + +# geom_smooth() + + ggtitle(paste( + 'Wait and work times for', str, 'nodes, run at ' + , run, desc, sep = ' ')) + + xlab("t [s] after start of experiment") + + ylab("Times waiting for/holding the lock [milliseconds]") + + (if (lin) { scale_y_continuous(); } else { scale_y_log10(); }) + ### <<<<<< + facet_grid(txType ~ isRelay) + + guides(size = "none", colour = "legend", alpha = "none") +} + +plotOverview <- function(d, report, run=RUN, desc=DESC) { + def.par <- par(no.readonly = TRUE) + layout(mat = matrix(c(1,1,1,1,2,3,4,4,5,5,6,6), 3, 4, byrow = TRUE), heights=c(2,3,4)) + + textplot(paste("\nBenchmark of ", run), cex = 2, valign = "top") + bp <- barplot(as.matrix(report[,2]), col=c("green", "blue", "red")) + textplot(report, show.rownames = FALSE) + textplot(params, show.rownames = FALSE) + + histTxs(data) + + par(def.par) + #layout(matrix(c(1,1), 1, 1, byrow = TRUE)) +} + +plotDuration <- function(run=RUN, desc=DESC) { + + formatylabels <- function(x) { lab <- sprintf("%1.2f", x) } + + # 1 + t1 <- grid.text(paste("\nTransaction times ", run), draw = FALSE) + # 2 + bxstats <- boxplot.stats(times$time) + t2 <- grid.text(paste("median time", sprintf("%1.1f", bxstats$stats[3]), "seconds", sep=" "), draw = FALSE) + # 3 + g1 <- ggplot(times, aes(x=time, y=cumm)) + + geom_point(col="blue") + + geom_vline(xintercept = bxstats$stats, col=c("grey","grey60","darkgreen","grey60","grey")) + + xlab("time (s)") + ylab("") + + scale_y_continuous(label=formatylabels) + # 4 + g2 <- ggplot(times, aes(y=time, x=1)) + + geom_boxplot(fill = "lightblue", outlier.color = "darkred", outlier.size = 3, outlier.shape = 6) + + coord_flip() + + xlab("") + ylab("") + + scale_x_continuous(label=formatylabels) + + theme(axis.text.y = element_text(color="white"), axis.ticks.y = element_blank()) + + grid.arrange(t1, t2, g1, g2, ncol = 1, heights = c(1,0.5,4,1)) +} + +plotMessages <- function(d, run=RUN, desc=DESC) { + messages_by_type <- aggregate(txCount ~ txType, data, sum) + submitted_by_node <- aggregate(txCount ~ node, data %>% filter(txType %in% c("submitted")), sum) + colnames(submitted_by_node) <- c("node", "submitted") + written_by_node <- aggregate(txCount ~ node, data %>% filter(txType %in% c("written")), sum) %>% filter(txCount > 0) + core_nodes <- select(written_by_node %>% filter(txCount > 0), node) + colnames(written_by_node) <- c("node", "written") + colnames(core_nodes) <- c("core") + rollbackwait_by_node <- {} + try({ + rollbackwait_by_node <- aggregate(txCount ~ node, data %>% filter(txType %in% c("wait rollback")), sum) + colnames(rollbackwait_by_node) <- c("node", "wait rollback") }, + TRUE + ) + rollbacksize_by_node <- {} + try({ + rollbacksize_by_node <- aggregate(txCount ~ node, data %>% filter(txType %in% c("size after rollback")), sum) + colnames(rollbacksize_by_node) <- c("node", "size rollback") }, + TRUE + ) + maxparam <- length(submitted_by_node[,2]) + summsg <- sum(submitted_by_node[,2]) + #submitted_by_node[maxparam+1,1] <- "sum" + submitted_by_node[maxparam+1,2] <- summsg + maxparam <- length(written_by_node[,2]) + summsg <- sum(written_by_node[,2]) + #written_by_node[maxparam+1,1] <- "sum" + written_by_node[maxparam+1,2] <- summsg + + def.par <- par(no.readonly = TRUE) + layout(mat = matrix(c(1,1,1,1,2,2,3,4,5,6,7,0), 3, 4, byrow = TRUE), heights=c(2,4,3)) + + layout(matrix(c(1,1,1,2,3,4,5,6,7), 3, 3, byrow = TRUE)) + textplot(paste("\nMessage counts of ", run), cex = 2, valign = "top") + + defborder <- c(1,0,1,1) + textplot(messages_by_type, show.rownames = FALSE, mar=defborder, cex=1, valign="top") + textplot(submitted_by_node, show.rownames = FALSE, mar=defborder, cex=1.1, valign="top") + textplot(written_by_node, show.rownames = FALSE, mar=defborder, cex=1.1, valign="top") + + if (! is.null(rollbackwait_by_node)) { + textplot(rollbackwait_by_node, show.rownames = FALSE, mar=defborder, cex=1.1, valign="top") + } + if (! is.null(rollbacksize_by_node)) { + textplot(rollbacksize_by_node, show.rownames = FALSE, mar=defborder, cex=1.1, valign="top") + } + #textplot(core_nodes, show.rownames = FALSE, mar=defborder, cex=1.1, valign="top") + + par(def.par) +} + +report <- readReport(fname2) +data <- readData(fname) + + +if (! INTERACTIVE) { + png(filename=paste('overview-', RUN, '.png', sep='')) + plotOverview(data, report) + dev.off() + p1 <- plotOverview(data, report) + + png(filename=paste('msgcount-', RUN, '.png', sep='')) + plotMessages(data) + dev.off() + p2 <- plotMessages(data) + + p3 <- if (hasTrxTimes) { + png(filename=paste('duration-', RUN, '.png', sep='')) + plotDuration() + dev.off() + plotDuration() + } + + p4 <- plotTxs(data) + #ggsave(paste('txs-', RUN, '.svg', sep='')) + ggsave(paste('txs-', RUN, '.png', sep='')) + + p5 <- plotMempools(data) + #ggsave(paste('mempools-', RUN, '.svg', sep='')) + ggsave(paste('mempools-', RUN, '.png', sep='')) + + p6 <- plotTimes(data, lin=FALSE) + #ggsave(paste('times-', RUN, '.svg', sep='')) + ggsave(paste('times-', RUN, '.png', sep='')) + + p7 <- plotTimes(data, lin=TRUE, minfilter=1e+03) + #ggsave(paste('times-', RUN, '.svg', sep='')) + ggsave(paste('times-', RUN, '-linear_scale.png', sep='')) + + #observe only core nodes: + #plotMempools(data %>% filter(!(node %in% relays)), 'core') + + #observe only unprivileged relays: + #plotMempools(data %>% filter(node %in% uRelays), 'unprivileged relay') + + #observe only privileged relays: + #plotMempools(data %>% filter((node %in% relays) & (!(node %in% uRelays))), 'privileged relay') + + #plotTimes(data %>% filter(!(node %in% relays)), 'core') + list(p1,p2,p3,p4,p5,p6,p7) +} + +# plot the rate of sent and written transactions +plotOSMetrics <- function(d, run=RUN, labx="", laby="", desc=DESC) { + ggplot(d, aes(x=(time), y=metrics)) + + epochs(data) + kslots(data) + + geom_point(colour = "blue", size=0.1) + + ggtitle(paste( + desc + , run, sep = ' ')) + + xlab(if (labx == "") {"t [s] since start of experiment"} else labx) + + ylab(if (laby == "") {"[??]"} else laby) + + facet_grid(node ~ category, scales = "fixed") + + guides(size = "none", colour = "legend", alpha = "none") + + scale_y_continuous(labels = scales::comma) + } + +# first block was written +#t1stBlock <- min(trunc(data$time/1000/1000)) +#tlastBlock <- max(trunc(data$time/1000/1000)) + +prepareOSMetrics4nodes <- function (nodes, target, title) { + # read in OS metrics from all core nodes + osmetrics = {} + for (n in nodes) { + m <- readOSmetrics(n) + osmetrics$io <- rbind(osmetrics$io, m$io) + osmetrics$mstat <- rbind(osmetrics$mstat, m$mstat) + osmetrics$stat <- rbind(osmetrics$stat, m$stat) + } + + # we only run this if there are some ts data + # older runs that lack them can still be analyzed + if (! is.null(osmetrics$io)) { + # skip first 20 datapoins (start up of process) + tmin <- min(osmetrics$io$time) + tmax <- max(osmetrics$io$time) + tstartup <- 20 + osmetrics$io <- osmetrics$io %>% filter(time >= tmin + tstartup) + osmetrics$mstat <- osmetrics$mstat %>% filter(time >= tmin + tstartup) + osmetrics$stat <- osmetrics$stat %>% filter(time >= tmin + tstartup) + + # epoch start time, aligned to times in `data` + t0 <- round(data$time[1] / 1e6) - data$t[1] + + osmetrics$io$time0 <- osmetrics$io$time + osmetrics$mstat$time0 <- osmetrics$mstat$time + osmetrics$stat$time0 <- osmetrics$stat$time + osmetrics$io$time <- osmetrics$io$time - t0 + osmetrics$mstat$time <- osmetrics$mstat$time - t0 + osmetrics$stat$time <- osmetrics$stat$time - t0 + + osmetrics$io <- osmetrics$io %>% filter(time >= 0) + osmetrics$mstat <- osmetrics$mstat %>% filter(time >= 0) + osmetrics$stat <- osmetrics$stat %>% filter(time >= 0) + + # prepare plot data (I/O) + plotdata <- {} + for (n in nodes) { + # extract node's data and sort it by the 'time' column: + d <- osmetrics$io %>% filter(nodename == n) %>% arrange_all(c(time)) + if (dim(d)[1] > 50) { + print(c(dim(d), n)) + td <- d$time[2:length(d$time)] - d$time[1:length(d$time)-1] + plotdata <- rbind(plotdata, data.frame(node=d$nodename, time=d$time, metrics=append(0,diff(d$rchar) / td), category='read')) + plotdata <- rbind(plotdata, data.frame(node=d$nodename, time=d$time, metrics=append(0,diff(d$wchar) / td), category='written')) + } + } + + p1 <- plotOSMetrics(plotdata %>% filter(metrics > 0), laby="bytes per s", desc=paste("I/O metrics", title, sep=" ")) + ggsave(paste('os-io-', target, "-", RUN, '.png', sep='')) + + # prepare plot data (CPU) + plotdata <- {} + for (n in nodes) { + #recDelay <- recDelay0 + #if (! is.null(osmetrics$delay[n])) { recDelay <- osmetrics$delay[n] } + # extract node's data and sort it by the 'time' column: + d <- osmetrics$stat %>% filter(nodename == n) %>% arrange_all(c(time)) + if (dim(d)[1] > 50) { + print(c(dim(d), n)) + td <- d$time[2:length(d$time)] - d$time[1:length(d$time)-1] + plotdata <- rbind(plotdata, data.frame(node=d$nodename, time=d$time, metrics=append(0,diff(d$utime) / td), category='CPU (user time)')) + plotdata <- rbind(plotdata, data.frame(node=d$nodename, time=d$time, metrics=append(0,diff(d$stime) / td), category='CPU (kernel time)')) + } + } + + p2 <- plotOSMetrics(plotdata %>% filter(metrics > 0), laby="single CPU %", desc=paste("CPU metrics", title, sep=" ")) + ggsave(paste('os-cpu-', target, "-", RUN, '.png', sep='')) + + # prepare plot data (memory) + plotdata <- {} + for (n in nodes) { + # extract node's data and sort it by the 'time' column: + d <- osmetrics$stat %>% filter(nodename == n) %>% arrange_all(c(time)) + if (dim(d)[1] > 50) { + print(c(dim(d), n)) + plotdata <- rbind(plotdata, data.frame(node=d$nodename, time=d$time, metrics=(d$rss / 1024 / 1024), category='memory (RSS)')) + } + } + + p3 <- plotOSMetrics(plotdata %>% filter(metrics > 0), laby="megabytes", desc=paste("Memory usage", title, sep=" ")) + ggsave(paste('os-mem-', target, "-", RUN, '.png', sep='')) + + # prepare plot data (read bytes / sys. calls, wbytes / sys. calls) + plotdata <- {} + for (n in nodes) { + d <- osmetrics$io %>% filter(nodename == n) %>% arrange_all(c(time)) + if (dim(d)[1] > 50) { + print(c(dim(d), n)) + td <- d$time[2:length(d$time)] - d$time[1:length(d$time)-1] + tr <- append(0,diff(d$syscr) / td) #d$rchar / d$syscr + tw <- append(0,diff(d$syscw) / td) #d$wchar / d$syscw + plotdata <- rbind(plotdata, data.frame(node=d$nodename, time=d$time, metrics=tr, category='read syscalls')) + plotdata <- rbind(plotdata, data.frame(node=d$nodename, time=d$time, metrics=tw, category='write syscalls')) + } + } + + p4 <- plotOSMetrics(plotdata %>% filter(metrics > 0), laby="syscalls per second", desc=paste("I/O work", title, sep=" ")) + ggsave(paste('os-io-work-', target, "-", RUN, '.png', sep='')) + + list(p1,p2,p3,p4); + } +} + +prepareOSMetrics4nodes(coreNodes, "core", "for core nodes") + +prepareOSMetrics4nodes(relays, "relays", "for relay nodes") + +print("all done.") +dev.off() + diff --git a/benchmarks/xblocks.sh b/benchmarks/xblocks.sh new file mode 100755 index 00000000000..e6507e7b092 --- /dev/null +++ b/benchmarks/xblocks.sh @@ -0,0 +1,15 @@ +#!/bin/bash + +## needs 'gnused' from Nix on MacOSX + +if [ $# -ne 1 ]; then + echo "$0 " + exit 1 +fi + +# BASE BLOCK -> NEW BLOCK +sed -ne '/^MainBlockHeader:/{ + n + N + s/hash: \([0-9a-f]\+\).*previous block: \([0-9a-f]\+\)/("\2", "\1")/p + }' "$1" diff --git a/binary/Pos/Binary/Class.hs b/binary/Pos/Binary/Class.hs deleted file mode 100644 index 610f7c7cd50..00000000000 --- a/binary/Pos/Binary/Class.hs +++ /dev/null @@ -1,4 +0,0 @@ --- Pos.Binary.Class -{-# OPTIONS_GHC -F -pgmF autoexporter #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} diff --git a/binary/cardano-sl-binary.cabal b/binary/cardano-sl-binary.cabal index 1fb097fcf6a..1b612f6e7a4 100644 --- a/binary/cardano-sl-binary.cabal +++ b/binary/cardano-sl-binary.cabal @@ -1,5 +1,5 @@ name: cardano-sl-binary -version: 1.2.1 +version: 1.3.0 synopsis: Cardano SL - binary serialization description: This package defines a type class for binary serialization, helpers and instances. @@ -16,9 +16,7 @@ cabal-version: >=1.10 library exposed-modules: Pos.Binary.Class - - Test.Pos.Cbor.Canonicity - Test.Pos.Cbor.RefImpl + Pos.Binary.Limit other-modules: Pos.Binary.Class.Core @@ -26,7 +24,6 @@ library Pos.Binary.Class.TH build-depends: QuickCheck - , autoexporter , base , binary , bytestring @@ -50,8 +47,6 @@ library , unordered-containers , vector - default-language: Haskell2010 - default-extensions: DeriveDataTypeable DeriveGeneric GeneralizedNewtypeDeriving @@ -76,9 +71,97 @@ library ScopedTypeVariables MonadFailDesugaring + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall - -fno-warn-orphans -O2 build-tools: cpphs >= 1.19 ghc-options: -pgmP cpphs -optP --cpp + + +test-suite test + main-is: test.hs + other-modules: + Spec + Test.Pos.Binary.Cbor.CborSpec + Test.Pos.Binary.Helpers + Test.Pos.Binary.BiSerialize + Test.Pos.Cbor.RefImpl + Test.Pos.Cbor.Canonicity + + type: exitcode-stdio-1.0 + build-depends: QuickCheck + , base + , bytestring + , canonical-json + , cardano-sl-binary + , cardano-sl-util + , cardano-sl-util-test + , cborg + , cereal + , containers + , cryptonite + , data-default + , extra + , filelock + , fmt + , formatting + , generic-arbitrary + , half + , hedgehog + , hspec + , lens + , mtl + , pvss + , quickcheck-instances + , random + , reflection + , safecopy + , serokell-util >= 0.1.3.4 + , tagged + , text + , text-format + , time-units + , universum >= 0.1.11 + , unordered-containers + , vector + + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -threaded + -rtsopts + -Wall + + -- linker speed up for linux + if os(linux) + ghc-options: -optl-fuse-ld=gold + ld-options: -fuse-ld=gold + + default-extensions: DeriveDataTypeable + DeriveGeneric + GeneralizedNewtypeDeriving + StandaloneDeriving + FlexibleContexts + FlexibleInstances + MultiParamTypeClasses + FunctionalDependencies + DefaultSignatures + NoImplicitPrelude + OverloadedStrings + TypeApplications + TupleSections + ViewPatterns + LambdaCase + MultiWayIf + ConstraintKinds + UndecidableInstances + BangPatterns + TemplateHaskell + ScopedTypeVariables + GADTs + MonadFailDesugaring + + build-tools: cpphs >= 1.19 + ghc-options: -pgmP cpphs -optP --cpp diff --git a/binary/src/Pos/Binary/Class.hs b/binary/src/Pos/Binary/Class.hs new file mode 100644 index 00000000000..390fb9085b2 --- /dev/null +++ b/binary/src/Pos/Binary/Class.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} + +module Pos.Binary.Class + ( module Pos.Binary.Class.Core + , module Pos.Binary.Class.Primitive + , module Pos.Binary.Class.TH + ) where + +import Pos.Binary.Class.Core +import Pos.Binary.Class.Primitive +import Pos.Binary.Class.TH \ No newline at end of file diff --git a/binary/Pos/Binary/Class/Core.hs b/binary/src/Pos/Binary/Class/Core.hs similarity index 100% rename from binary/Pos/Binary/Class/Core.hs rename to binary/src/Pos/Binary/Class/Core.hs diff --git a/binary/Pos/Binary/Class/Primitive.hs b/binary/src/Pos/Binary/Class/Primitive.hs similarity index 98% rename from binary/Pos/Binary/Class/Primitive.hs rename to binary/src/Pos/Binary/Class/Primitive.hs index 4e4da477b36..a2e379b1721 100644 --- a/binary/Pos/Binary/Class/Primitive.hs +++ b/binary/src/Pos/Binary/Class/Primitive.hs @@ -42,11 +42,11 @@ import qualified Codec.CBOR.Read as CBOR.Read import qualified Codec.CBOR.Write as CBOR.Write import Control.Exception.Safe (impureThrow) import Control.Monad.ST (ST, runST) -import Data.ByteString.Builder (Builder) import qualified Data.ByteString as BS +import Data.ByteString.Builder (Builder) +import qualified Data.ByteString.Builder.Extra as Builder import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Internal as BSL -import qualified Data.ByteString.Builder.Extra as Builder import Data.Digest.CRC32 (CRC32 (..)) import Data.Typeable (typeOf) import Formatting (sformat, shown, (%)) @@ -135,8 +135,9 @@ deserializeOrFail deserializeOrFail bs0 = runST (supplyAllInput bs0 =<< deserializeIncremental) where - supplyAllInput _bs (CBOR.Read.Done bs _ x) = return (Right (x, bs)) - supplyAllInput bs (CBOR.Read.Partial k) = + supplyAllInput bs' (CBOR.Read.Done bs _ x) = + return (Right (x, bs <> BSL.toStrict bs')) + supplyAllInput bs (CBOR.Read.Partial k) = case bs of BSL.Chunk chunk bs' -> k (Just chunk) >>= supplyAllInput bs' BSL.Empty -> k Nothing >>= supplyAllInput BSL.Empty diff --git a/binary/Pos/Binary/Class/TH.hs b/binary/src/Pos/Binary/Class/TH.hs similarity index 55% rename from binary/Pos/Binary/Class/TH.hs rename to binary/src/Pos/Binary/Class/TH.hs index 5b5d923e572..8ae043c5a97 100644 --- a/binary/Pos/Binary/Class/TH.hs +++ b/binary/src/Pos/Binary/Class/TH.hs @@ -1,3 +1,27 @@ +module Pos.Binary.Class.TH + ( deriveSimpleBi + , deriveSimpleBiCxt + , deriveIndexedBi + , deriveIndexedBiCxt + , Cons (..) + , Field (Field) + ) where + +import Universum hiding (Type) + +import qualified Codec.CBOR.Decoding as Cbor +import qualified Codec.CBOR.Encoding as Cbor +import Control.Lens (imap) +import Data.Function (on) +import Data.List (nubBy, (!!), (\\)) +import Data.Maybe (listToMaybe) +import Formatting (sformat, shown, (%)) +import Language.Haskell.TH +import TH.ReifySimple (DataCon (..), DataType (..), reifyDataType) +import TH.Utilities (plainInstanceD) + +import qualified Pos.Binary.Class.Core as Bi + {- TH helpers for Bi. @@ -55,25 +79,10 @@ instance Bi User where _ -> cborError "Found invalid tag while getting User" -} -module Pos.Binary.Class.TH - ( deriveSimpleBi - , deriveSimpleBiCxt - , Cons (..) - , Field (Field) - ) where - -import Universum - -import qualified Codec.CBOR.Decoding as Cbor -import qualified Codec.CBOR.Encoding as Cbor -import Control.Lens (imap) -import Data.List (nubBy) -import Formatting (sformat, shown, (%)) -import Language.Haskell.TH -import TH.ReifySimple (DataCon (..), DataType (..), reifyDataType) -import TH.Utilities (plainInstanceD) - -import qualified Pos.Binary.Class.Core as Bi +-- HLint complains about duplication between deriveIndexedBiInternal and +-- deriveSimpleBiInternal. I (Michael Hueschen) am unable to get a function +-- specific HLint ignore to work, so am ignoring global to the module. +{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-} -- | This function must match the one from 'Pos.Util.Util'. It is copied here -- to avoid a dependency and facilitate parallel builds. @@ -98,6 +107,7 @@ data Field -- ^ You're expected to write something like @[|foo :: Bar|]@ here } + -- | Turn something like @[|foo :: Bar|]@ into @(foo, Bar)@. expToNameAndType :: ExpQ -> Q (Name, Type) expToNameAndType ex = ex >>= \case @@ -109,6 +119,215 @@ expToNameAndType ex = ex >>= \case fieldToPair :: Field -> Q (Name, Maybe Type) fieldToPair (Field ex) = over _2 Just <$> expToNameAndType ex +fieldToIdxTypePair :: Field -> Q (Int, Type) +fieldToIdxTypePair (Field ex) = ex >>= \case + SigE (LitE (IntegerL i)) t -> (,t) <$> checkTruncateInteger i + other -> templateHaskellError $ + "fieldToIdxTypePair: expression should look like \ + \[| idx :: Type |], where idx is an Int. got instead: " + <> show other + +checkTruncateInteger :: Integer -> Q Int +checkTruncateInteger i = + if 0 <= i && i <= 255 + then return (fromIntegral i) + else templateHaskellError $ + "Integer literal `" <> show i <> "` should be in range [0,255]" + +-------------------------------------------------------------------------------- +-- Indexed derivations +-------------------------------------------------------------------------------- +deriveIndexedBi :: Name -> [Cons] -> Q [Dec] +deriveIndexedBi = deriveIndexedBiInternal Nothing + +deriveIndexedBiCxt :: TypeQ -> Name -> [Cons] -> Q [Dec] +deriveIndexedBiCxt = deriveIndexedBiInternal . Just + +deriveIndexedBiInternal :: Maybe TypeQ -> Name -> [Cons] -> Q [Dec] +deriveIndexedBiInternal predsMB headTy constrs = do + when (null constrs) $ + templateHaskellError "You passed no constructors to deriveIndexedBi" + when (length constrs > 255) $ + templateHaskellError "You passed too many constructors to deriveIndexedBi" + when (length (nubBy ((==) `on` cName) constrs) /= length constrs) $ + templateHaskellError "You passed two constructors with the same name" + preds <- maybe (pure []) (fmap one) predsMB + dt <- reifyDataType headTy + case matchAllConstrs constrs (dtCons dt) of + MissedCons cons -> templateHaskellError $ + sformat ("Constructor '"%shown%"' isn't passed to deriveIndexedBi") $ + cons + UnknownCons cons -> templateHaskellError $ + sformat ("Unknown constructor '"%shown%"' is passed to deriveIndexedBi") $ + cons + MatchedCons matchedConstrs -> + forM_ (zip constrs matchedConstrs) $ \(constr, dataConstr) -> do + let name = cName constr + realFields = dcFields dataConstr + fieldIndicesAndTypes <- mapM fieldToIdxTypePair (cFields constr) + case checkAllIndexedFields fieldIndicesAndTypes realFields of + MatchedFields -> return () + MissedField field -> templateHaskellError $ + sformat ("Field '"%shown%"' of the constructor '" + %shown%"' isn't passed to deriveIndexedBi") + field name + UnknownField field -> templateHaskellError $ + sformat ("Unknown field '"%shown%"' of the constructor '" + %shown%"' is passed to deriveIndexedBi") + field name + TypeMismatched field realType passedType -> templateHaskellError $ + sformat ("The type of '"%shown%"' of the constructor '" + %shown%"' is mismatched: real type '" + %shown%"', passed type '"%shown%"'") + field name realType passedType + ty <- conT headTy + makeBiInstanceTH preds ty <$> biEncodeExpr <*> biDecodeExpr + where + shortNameTy :: Text + shortNameTy = toText $ nameBase headTy + + -- The type used to tag & distinguish constructors + tagType :: TypeQ + tagType = [t| Word8 |] + + -- Encode definition -- + biEncodeExpr :: Q Exp + biEncodeExpr = do + x <- newName "x" + lam1E (varP x) $ + caseE (varE x) $ + imap biEncodeConstr constrs + + -- For an example constructor, the 2nd constructor of a datatype which + -- has 3 fields: + -- `(Example field_0 field_1 field_2)` + -- We generate the following code: + -- ``` + -- encodeListLen 4 + -- <> encode (1 :: Word8) + -- <> encode field_0 + -- <> encode field_1 + -- <> encode field_2 + -- ``` + -- + -- For a singleton constructor: + -- `(Unit field_0)` + -- We generate the following code: + -- ``` + -- encodeListLen 1 + -- <> encode field_0 + -- ``` + -- There is no tag needed because we know there is only one constructor + -- possible to encode or decode. + -- + biEncodeConstr :: Int -> Cons -> MatchQ + biEncodeConstr ix (Cons name fields) = do + + fieldIdxs <- mapM (\f -> fst <$> fieldToIdxTypePair f) fields + + fieldIdxPairs <- mapM (\i -> (i,) <$> idxToFieldVar i) fieldIdxs + let -- We sort the indices so they match the fields of the constructor in order + sortedFieldIdxNames = map snd (sortWith fst fieldIdxPairs) + -- These we leave unsorted because the serialization order might not match + -- constructor order + fieldIdxNames = map snd fieldIdxPairs + + match (conP name (map varP sortedFieldIdxNames)) + (body fieldIdxNames) + [] + where + body fieldIdxNames = normalB $ + let (len, optTag) = if length constrs > 1 + then (length fields + 1, [encodeTag ix]) + else (length fields , [] ) + in mconcatE (encodeFlat len : optTag ++ map encodeName fieldIdxNames) + + -- We could use `mkName` instead of `newName`, as we shouldn't have concerns about + -- capture, but this is safer. + idxToFieldVar :: Int -> Q Name + idxToFieldVar idx = newName ("field_" <> show idx) + + encodeFlat :: Int -> Q Exp + encodeFlat listLen = [| Cbor.encodeListLen listLen |] + + encodeTag :: Int -> Q Exp + encodeTag ix = [| Bi.encode (ix :: $tagType) |] + + encodeName :: Name -> Q Exp + encodeName name = + [| Bi.encode $(varE name) |] + + actualLen :: Name + actualLen = mkName "actualLen" + + -- Decode definition -- + biDecodeExpr :: Q Exp + biDecodeExpr = case constrs of + [] -> templateHaskellError $ + sformat ("Attempting to decode type without constructors "%shown) headTy + [con] -> do + doE [ bindS (varP actualLen) [| Cbor.decodeListLenCanonical |] + , noBindS (biDecodeConstr con) -- There is one constructor + ] + _ -> do + let tagName = mkName "tag" + let getMatch ix con = match (litP (IntegerL (fromIntegral ix))) + (normalB (biDecodeConstr con)) [] + let mismatchConstr = + match wildP (normalB + [| cborError $ "Found invalid tag while decoding " <> shortNameTy |]) [] + doE + [ bindS (varP actualLen) [| Cbor.decodeListLenCanonical |] + , bindS (varP tagName) [| Bi.decode |] + , noBindS (caseE + (sigE (varE tagName) tagType) + (imap getMatch constrs ++ [mismatchConstr])) + ] + + biDecodeConstr :: Cons -> Q Exp + biDecodeConstr (Cons name fields) = do + let numFields = length fields + expectedLen = varE actualLen + prettyName :: String = show name + -- Given `n` fields, if this is the only constructor of this type, there + -- will be no tag, and we'll have a length `n` list. If there are multiple + -- constructors, we'll have a length `n+1` list (number of fields plus tag). + cborListLen :: Int = if length constrs > 1 then numFields+1 else numFields + + fieldIdxs <- mapM (\f -> fst <$> fieldToIdxTypePair f) fields + + fieldIdxPairs <- mapM (\i -> (i,) <$> idxToFieldVar i) fieldIdxs + let -- We sort the indices so they match the fields of the constructor in order + sortedFieldIdxNames = map snd (sortWith fst fieldIdxPairs) + -- These we leave unsorted because the serialization order might not match + -- constructor order + fieldIdxNames = map snd fieldIdxPairs + + varPs :: [Pat] <- mapM varP fieldIdxNames + decoders :: [Exp] <- replicateM (length varPs) [| Bi.decode |] + bindExprs :: [Stmt] <- zipWithM (\pat dec -> bindS (pure pat) (pure dec)) + varPs + decoders + let lenCheck = noBindS [| Bi.matchSize cborListLen + ("biDecodeConstr@" <> prettyName) + $expectedLen + |] + constructDatatype <- noBindS $ appE (varE 'pure) + (applyMultiArg (conE name) + (map varE sortedFieldIdxNames)) + doE $ lenCheck : map pure (bindExprs ++ [constructDatatype]) + + +-- Apply a multi-arg function application to a series of App's +applyMultiArg :: ExpQ -> [ExpQ] -> Q Exp +applyMultiArg f [] = f +applyMultiArg f (x:xs) = applyMultiArg (appE f x) xs + +-------------------------------------------------------------------------------- +-- End Indexed +-------------------------------------------------------------------------------- + + -- Some part of code copied from -- https://hackage.haskell.org/package/store-0.4.3.1/docs/src/Data-Store-TH-Internal.html#makeStore @@ -339,6 +558,41 @@ checkAllFields passedFields realFields inclusion :: [Name] -> [Name] -> Maybe Name inclusion c1 c2 = find (`notElem` c2) c1 +checkAllIndexedFields :: [(Int, Type)] -> [(Maybe Name, Type)] -> MatchFields +checkAllIndexedFields passedFields realFields + | Just nm <- inclusion (map fst passedFields) = UnknownField nm + | Just nm <- exclusion (map fst passedFields) = MissedField nm + | otherwise = + case dropWhile checkTypes (zip passedFields realFields) of + [] -> MatchedFields + (((idx, passed), (_, real)):_) -> TypeMismatched (indexToName idx) real passed + where + checkTypes :: ((Int, Type), (Maybe Name, Type)) -> Bool + checkTypes ((_, t1), (_, t2)) = t1 == t2 + + -- find the first out-of-range index, and return it wrapped as a name + inclusion :: [Int] -> Maybe Name + inclusion is = indexToName <$> find (not . inRange) is + + exclusion :: [Int] -> Maybe Name + exclusion is = do + let realIdxs = [0 .. length realFields - 1] + excludedIdx <- listToMaybe (realIdxs \\ is) + return (indexToName excludedIdx) + + -- Because we may not have named fields, we try to find a name, and otherwise + -- render the index directly. + indexToName :: Int -> Name + indexToName idx + | inRange idx = case (map fst realFields) !! idx of + Just nm -> nm + Nothing -> mkName (show idx) + | otherwise = mkName (show idx) + + -- check that an index is within valid range: (0, len(realFields)] + inRange :: Int -> Bool + inRange idx = 0 <= idx && idx < length realFields + ---------------------------------------------------------------------------- -- Utilities ---------------------------------------------------------------------------- diff --git a/binary/src/Pos/Binary/Limit.hs b/binary/src/Pos/Binary/Limit.hs new file mode 100644 index 00000000000..256467fcc81 --- /dev/null +++ b/binary/src/Pos/Binary/Limit.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} + +module Pos.Binary.Limit + ( Limit (..) + , (<+>) + , mlBool + , mlMaybe + , mlEither + , mlTuple + , mlTriple + , vectorOf + , vectorOfNE + ) where + +import Universum + +-- | A limit on the length of something (in bytes). +-- TODO should check for overflow in the Num instance. +-- Although, if the limit is anywhere near maxBound :: Word32 then something +-- is almost certainly amiss. +newtype Limit t = Limit { getLimit :: Word32 } + deriving (Eq, Ord, Show, Num, Enum, Real, Integral) + +instance Functor Limit where + fmap _ (Limit x) = Limit x + +-- TODO: use <*> instead of <+> +infixl 4 <+> +(<+>) :: Limit (a -> b) -> Limit a -> Limit b +Limit x <+> Limit y = Limit $ x + y + +mlBool :: Limit Bool +mlBool = 1 + +mlMaybe :: Limit a -> Limit (Maybe a) +mlMaybe lim = Just <$> lim + 1 + +mlEither :: Limit a -> Limit b -> Limit (Either a b) +mlEither limA limB = 1 + max (Left <$> limA) (Right <$> limB) + +mlTuple :: Limit a -> Limit b -> Limit (a, b) +mlTuple limA limB = (,) <$> limA <+> limB + +mlTriple :: Limit a -> Limit b -> Limit c -> Limit (a, b, c) +mlTriple limA limB limC = (,,) <$> limA <+> limB <+> limC + +-- | Given a limit for a list item, generate limit for a list with N elements +vectorOf :: Int -> Limit l -> Limit [l] +vectorOf k (Limit x) = + Limit $ encodedListLength + x * (fromIntegral k) + where + -- should be enough for most reasonable cases + -- FIXME this is silly. + -- Better solution: never read in an arbitrary-length structure from the + -- network. If you want a list, read in one item at a time. + encodedListLength = 20 + +vectorOfNE :: Int -> Limit l -> Limit (NonEmpty l) +vectorOfNE k (Limit x) = + Limit $ encodedListLength + x * (fromIntegral k) + where + encodedListLength = 20 diff --git a/binary/test/LICENSE b/binary/test/LICENSE new file mode 100644 index 00000000000..74d83558329 --- /dev/null +++ b/binary/test/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2017 IOHK + +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 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. diff --git a/binary/test/Spec.hs b/binary/test/Spec.hs new file mode 100644 index 00000000000..5416ef6a866 --- /dev/null +++ b/binary/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-} diff --git a/binary/test/Test/Pos/Binary/BiSerialize.hs b/binary/test/Test/Pos/Binary/BiSerialize.hs new file mode 100644 index 00000000000..64a191a903b --- /dev/null +++ b/binary/test/Test/Pos/Binary/BiSerialize.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE TemplateHaskell #-} +module Test.Pos.Binary.BiSerialize + ( tests + ) where + +import Universum + +import Hedgehog (Gen, Property, discover, (===)) +import qualified Hedgehog as H +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range + +import Pos.Binary.Class (Cons (..), Field (..), cborError, deriveIndexedBi, + deriveSimpleBi, serialize') + +import qualified Serokell.Util.Base16 as B16 + + +-------------------------------------------------------------------------------- + +data TestSimple + = TsInt + { unTsInt :: Int } + | TsIntList + { unTsIntList :: [Int] } + | TsChar2 + { unTsChar2L :: Char + , unTsChar2R :: Char } + | TsInteger + { unTsInteger :: Integer } + | TsMaybeInt + { unTsMaybeInt :: Maybe Int } + | TsChar2Permuted + { unTsChar2PermutedL :: Char + , unTsChar2PermutedR :: Char } + | TsPair + { unTsPairL :: TestSimple + , unTsPairR :: TestSimple } + deriving (Eq, Show, Typeable) + +deriveSimpleBi ''TestSimple [ + Cons 'TsInt [ + Field [| unTsInt :: Int |] + ], + Cons 'TsIntList [ + Field [| unTsIntList :: [Int] |] + ], + Cons 'TsChar2 [ + Field [| unTsChar2L :: Char |], + Field [| unTsChar2R :: Char |] + ], + Cons 'TsInteger [ + Field [| unTsInteger :: Integer |] + ], + Cons 'TsMaybeInt [ + Field [| unTsMaybeInt :: Maybe Int |] + ], + Cons 'TsChar2Permuted [ + Field [| unTsChar2PermutedR :: Char |], + Field [| unTsChar2PermutedL :: Char |] + ], + Cons 'TsPair [ + Field [| unTsPairL :: TestSimple |], + Field [| unTsPairR :: TestSimple |] + ] + ] + +-------------------------------------------------------------------------------- + +data TestIndexed + = TiInt Int + | TiIntList [Int] + | TiChar2 Char Char + | TiInteger Integer + | TiMaybeInt (Maybe Int) + | TiChar2Permuted Char Char + | TiPair TestIndexed TestIndexed + deriving (Eq, Show, Typeable) + +deriveIndexedBi ''TestIndexed [ + Cons 'TiInt [ + Field [| 0 :: Int |] + ], + Cons 'TiIntList [ + Field [| 0 :: [Int] |] + ], + Cons 'TiChar2 [ + Field [| 0 :: Char |], + Field [| 1 :: Char |] + ], + Cons 'TiInteger [ + Field [| 0 :: Integer |] + ], + Cons 'TiMaybeInt [ + Field [| 0 :: Maybe Int |] + ], + Cons 'TiChar2Permuted [ + Field [| 1 :: Char |], + Field [| 0 :: Char |] + ], + Cons 'TiPair [ + Field [| 0 :: TestIndexed |], + Field [| 1 :: TestIndexed |] + ] + ] + +-------------------------------------------------------------------------------- + +-- The validity of our comparison tests relies on this function. Fortunately, +-- it's a pretty straightforward translation. +simpleToIndexed :: TestSimple -> TestIndexed +simpleToIndexed (TsInt i) = TiInt i +simpleToIndexed (TsIntList is) = TiIntList is +simpleToIndexed (TsChar2 l r) = TiChar2 l r +simpleToIndexed (TsInteger i) = TiInteger i +simpleToIndexed (TsMaybeInt mi) = TiMaybeInt mi +simpleToIndexed (TsChar2Permuted l r) = TiChar2Permuted l r +simpleToIndexed (TsPair l r) = TiPair (simpleToIndexed l) + (simpleToIndexed r) + +-------------------------------------------------------------------------------- + +genTestSimple :: Range.Size -> Gen TestSimple +genTestSimple sz + | sz > 0 = Gen.choice (pairType : flatTypes) + | otherwise = Gen.choice flatTypes + where + pairType = TsPair <$> genTestSimple (sz `div` 2) + <*> genTestSimple (sz `div` 2) + flatTypes = + [ TsInt <$> Gen.int Range.constantBounded + , TsIntList <$> Gen.list (Range.linear 0 20) (Gen.int Range.constantBounded) + , TsChar2 <$> Gen.unicode <*> Gen.unicode + , TsInteger <$> Gen.integral (Range.linear (- bignum) bignum) + , TsMaybeInt <$> Gen.maybe (Gen.int Range.constantBounded) + , TsChar2Permuted <$> Gen.unicode <*> Gen.unicode + ] + bignum = 2 ^ (80 :: Integer) + + +prop_TestSimple_TestIndexed_equivalent :: Property +prop_TestSimple_TestIndexed_equivalent = H.withTests 2000 $ H.property $ + H.forAll (Gen.sized genTestSimple) >>= \ts -> + B16.encode (serialize' ts) + === + B16.encode (serialize' (simpleToIndexed ts)) + + +tests :: IO Bool +tests = + H.checkParallel $$discover diff --git a/binary/test/Test/Pos/Binary/Cbor/CborSpec.hs b/binary/test/Test/Pos/Binary/Cbor/CborSpec.hs new file mode 100644 index 00000000000..091d154c1d5 --- /dev/null +++ b/binary/test/Test/Pos/Binary/Cbor/CborSpec.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Test.Pos.Binary.Cbor.CborSpec + ( spec + , U + , extensionProperty + ) where + +import Universum + +import Data.Bits (shiftL) +import qualified Data.ByteString as BS +import Data.Fixed (Nano) +import Data.Time.Units (Microsecond, Millisecond) +import Serokell.Data.Memory.Units (Byte) +import Test.Hspec (Arg, Expectation, Spec, SpecWith, describe, it, shouldBe) +import Test.Hspec.QuickCheck (modifyMaxSize, modifyMaxSuccess, prop) +import Test.QuickCheck (Arbitrary (..), choose, oneof, sized, (===)) +import Test.QuickCheck.Arbitrary.Generic (genericShrink) +import Test.QuickCheck.Instances () + +import qualified Codec.CBOR.FlatTerm as CBOR + +import Pos.Binary.Class +import Test.Pos.Binary.Helpers (U, binaryTest, extensionProperty) +import qualified Test.Pos.Cbor.RefImpl as R +import Test.Pos.Util.Orphans () +import Test.Pos.Util.QuickCheck.Property (expectationError) + +-- | Wrapper for Integer with Arbitrary instance that can generate "proper" big +-- integers, i.e. ones that don't fit in Int64. This really needs to be fixed +-- within QuickCheck though (https://github.com/nick8325/quickcheck/issues/213). +newtype LargeInteger = LargeInteger Integer + deriving (Eq, Show) + +instance Arbitrary LargeInteger where + arbitrary = sized $ \sz -> do + n <- choose (1, sz) + sign <- arbitrary + LargeInteger . (if sign then negate else identity) . foldr f 0 + <$> replicateM n arbitrary + where + f :: Word8 -> Integer -> Integer + f w acc = (acc `shiftL` 8) + fromIntegral w + +instance Bi LargeInteger where + encode (LargeInteger n) = encode n + decode = LargeInteger <$> decode + +---------------------------------------- + +data User + = Login { login :: String + , age :: Int } + | FullName { firstName :: String + , lastName :: String + , sex :: Bool } + deriving (Show, Eq) + +deriveSimpleBi ''User [ + Cons 'Login [ + Field [| login :: String |], + Field [| age :: Int |] + ], + Cons 'FullName [ + Field [| firstName :: String |], + Field [| lastName :: String |], + Field [| sex :: Bool |] + ]] + +---------------------------------------- +data ARecord = ARecord String Int ARecord + | ANull + deriving (Generic, Eq, Show) + +instance Bi ARecord where + encode = genericEncode + decode = genericDecode + +instance Arbitrary ARecord where + arbitrary = oneof [ + ARecord <$> arbitrary <*> arbitrary <*> arbitrary + , pure ANull + ] + shrink = genericShrink + +data AUnit = AUnit + deriving (Generic, Eq, Show) + +instance Bi AUnit where + encode = genericEncode + decode = genericDecode + +instance Arbitrary AUnit where + arbitrary = pure AUnit + shrink = genericShrink + +newtype ANewtype = ANewtype Int + deriving (Generic, Eq, Show) + +instance Bi ANewtype where + encode = genericEncode + decode = genericDecode + +instance Arbitrary ANewtype where + arbitrary = ANewtype <$> arbitrary + shrink = genericShrink + +---------------------------------------- + +data T = T1 Int | T2 Int Int | Unknown Word8 BS.ByteString + deriving Show + +instance Bi T where + encode = \case + T1 a -> encode (0::Word8) + <> encode (serialize' a) + T2 a b -> encode (1::Word8) + <> encode (serialize' (a, b)) + Unknown n bs -> encode n + <> encode bs + + decode = decode @Word8 >>= \case + 0 -> T1 <$> (deserialize' =<< decode) + 1 -> uncurry T2 <$> (deserialize' =<< decode) + t -> Unknown t <$> decode + +---------------------------------------- + +testANewtype :: SpecWith () +testANewtype = testAgainstFile "a newtype" x rep + where + x :: ANewtype + x = ANewtype 42 + + rep :: [CBOR.TermToken] + rep = [CBOR.TkListLen 1, CBOR.TkInt 42] + +testAUnit :: SpecWith () +testAUnit = testAgainstFile "a unit" x rep + where + x :: AUnit + x = AUnit + + rep :: [CBOR.TermToken] + rep = [CBOR.TkListLen 0] + +testARecord :: SpecWith () +testARecord = testAgainstFile "a record" x rep + where + x :: ARecord + x = ARecord "hello" 42 (ARecord "world" 52 ANull) + + rep :: [CBOR.TermToken] + rep = [CBOR.TkListLen 4, CBOR.TkInt 0, CBOR.TkString "hello", CBOR.TkInt 42, + CBOR.TkListLen 4, CBOR.TkInt 0, CBOR.TkString "world", CBOR.TkInt 52, + CBOR.TkListLen 1, CBOR.TkInt 1 + ] + +testAgainstFile + :: (Eq a, Show a, Bi a) + => String + -> a + -> CBOR.FlatTerm + -> SpecWith (Arg Expectation) +testAgainstFile name x expected = + describe name $ do + it "serialise" $ do + let actual = CBOR.toFlatTerm $ encode x + expected `shouldBe` actual + it "deserialise" $ do + case CBOR.fromFlatTerm decode expected of + Left err -> expectationError (fromString err) + Right actual -> x `shouldBe` actual + +spec :: Spec +spec = do + describe "Cbor.Bi instances" $ + modifyMaxSuccess (const 1000) $ + prop "User" (let u1 = Login "asd" 34 in (unsafeDeserialize $ serialize u1) === u1) + + describe "Reference implementation" $ do + describe "properties" $ do + prop "encoding/decoding initial byte" R.prop_InitialByte + prop "encoding/decoding additional info" R.prop_AdditionalInfo + prop "encoding/decoding token header" R.prop_TokenHeader + prop "encoding/decoding token header 2" R.prop_TokenHeader2 + prop "encoding/decoding tokens" R.prop_Token + modifyMaxSuccess (const 1000) . modifyMaxSize (const 150) $ do + prop "encoding/decoding terms" R.prop_Term + describe "internal properties" $ do + prop "Integer to/from bytes" R.prop_integerToFromBytes + prop "Word16 to/from network byte order" R.prop_word16ToFromNet + prop "Word32 to/from network byte order" R.prop_word32ToFromNet + prop "Word64 to/from network byte order" R.prop_word64ToFromNet + modifyMaxSuccess (const 1) $ do + -- Using once inside the property would be lovely (as it tests + -- all the Halfs) but it doesn't work for some reason. + prop "Numeric.Half to/from Float" R.prop_halfToFromFloat + + describe "Cbor.Bi instances" $ do + modifyMaxSuccess (const 1000) $ do + describe "Generic deriving" $ do + testARecord + testAUnit + testANewtype + binaryTest @ARecord + binaryTest @AUnit + binaryTest @ANewtype + + describe "Primitive instances" $ do + binaryTest @() + binaryTest @Bool + binaryTest @Char + binaryTest @Integer + binaryTest @LargeInteger + binaryTest @Word + binaryTest @Word8 + binaryTest @Word16 + binaryTest @Word32 + binaryTest @Word64 + binaryTest @Int + binaryTest @Float + binaryTest @Int32 + binaryTest @Int64 + binaryTest @Nano + binaryTest @Millisecond + binaryTest @Microsecond + binaryTest @Byte + binaryTest @(Map Int Int) + binaryTest @(HashMap Int Int) + binaryTest @(Set Int) + binaryTest @(HashSet Int) + binaryTest @ByteString + binaryTest @Text diff --git a/binary/test/Test/Pos/Binary/Helpers.hs b/binary/test/Test/Pos/Binary/Helpers.hs new file mode 100644 index 00000000000..ce527b4d1c2 --- /dev/null +++ b/binary/test/Test/Pos/Binary/Helpers.hs @@ -0,0 +1,282 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE RankNTypes #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- Need this to avoid a warning on the `typeName` helper function. +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Test.Pos.Binary.Helpers + ( IdTestingRequiredClassesAlmost + + -- * General helpers + , runTests + + -- * From/to + , binaryEncodeDecode + , binaryTest + , safeCopyEncodeDecode + , safeCopyTest + , serDeserId + , showReadId + , showReadTest + , identityTest + + -- * Binary test helpers + , U + , U24 + , extensionProperty + + -- * Message length + , msgLenLimitedTest + ) where + +import Universum + +import Codec.CBOR.FlatTerm (toFlatTerm, validFlatTerm) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.SafeCopy (SafeCopy, safeGet, safePut) +import Data.Serialize (runGet, runPut) +import Data.Typeable (typeRep) +import Formatting (formatToString, int, (%)) +import Prelude (read) +import Test.Hspec (Spec, describe) +import Test.Hspec.QuickCheck (modifyMaxSize, modifyMaxSuccess, prop) +import Test.QuickCheck (Arbitrary (arbitrary), Gen, Property, choose, conjoin, + counterexample, forAll, property, resize, suchThat, vectorOf, + (.&&.), (===)) +import Test.QuickCheck.Instances () + +import Pos.Binary.Class (AsBinaryClass (..), Bi (..), decodeFull, + decodeListLenCanonicalOf, decodeUnknownCborDataItem, + encodeListLen, encodeUnknownCborDataItem, serialize, serialize', + unsafeDeserialize) +import Pos.Binary.Limit (Limit (..)) + +import Test.Pos.Cbor.Canonicity (perturbCanonicity) +import qualified Test.Pos.Cbor.RefImpl as R +import Test.Pos.Util.QuickCheck.Arbitrary (SmallGenerator (..)) + +---------------------------------------------------------------------------- +-- General helpers +---------------------------------------------------------------------------- + +runTests :: [IO Bool] -> IO () +runTests tests = do + result <- and <$> sequence tests + unless result + exitFailure + +---------------------------------------------------------------------------- +-- From/to tests +---------------------------------------------------------------------------- + +-- | Basic binary serialization/deserialization identity. +binaryEncodeDecode :: (Show a, Eq a, Bi a) => a -> Property +binaryEncodeDecode a = (unsafeDeserialize . serialize $ a) === a + +-- | Machinery to test we perform "flat" encoding. +cborFlatTermValid :: Bi a => a -> Property +cborFlatTermValid = property . validFlatTerm . toFlatTerm . encode + +-- Test that serialized 'a' has canonical representation, i.e. if we're able to +-- change its serialized form, it won't be successfully deserialized. +cborCanonicalRep :: forall a. (Bi a, Show a) => a -> Property +cborCanonicalRep a = property $ do + let sa = serialize a + sa' <- R.serialise <$> perturbCanonicity (R.deserialise sa) + let out = decodeFull @a $ sa' + pure $ case out of + -- perturbCanonicity may have not changed anything. Decoding can + -- succeed in this case. + Right a' -> + counterexample (show a') $ counterexample (show sa) $ counterexample + (show sa') + (sa == sa') + -- It didn't decode. The error had better be a canonicity violation. + Left err -> counterexample (show err) (isCanonicityViolation err) + where + -- FIXME cbor errors are just text. + -- Regex matching on "non-canonical" might work. + -- Would be nice if we had a sum type for these errors. + isCanonicityViolation = const True + +safeCopyEncodeDecode :: (Show a, Eq a, SafeCopy a) => a -> Property +safeCopyEncodeDecode a = + either (error . toText) identity + (runGet safeGet $ runPut $ safePut a) === a + +serDeserId :: forall t . (Show t, Eq t, AsBinaryClass t) => t -> Property +serDeserId a = + either (error . toText) identity + (fromBinary $ asBinary @t a) === a + +showReadId :: (Show a, Eq a, Read a) => a -> Property +showReadId a = read (show a) === a + +type IdTestingRequiredClassesAlmost a = (Eq a, Show a, Arbitrary a, Typeable a) + +type IdTestingRequiredClasses f a = (Eq a, Show a, Arbitrary a, Typeable a, f a) + +identityTest :: forall a. (IdTestingRequiredClassesAlmost a) => (a -> Property) -> Spec +identityTest fun = prop (typeName @a) fun + where + -- GHC 8.2.2 says the `Typeable x` constraint is not necessary, but won't compile + -- this without it. + typeName :: forall x. Typeable x => String + typeName = show $ typeRep (Proxy @a) + +binaryTest :: forall a. IdTestingRequiredClasses Bi a => Spec +binaryTest = + identityTest @a $ \x -> binaryEncodeDecode x + .&&. cborFlatTermValid x + .&&. cborCanonicalRep x + +-- This tend to be expensive and cause a lot of disk I/O, which can be +-- devastating on the developer's desktop system, so we limit the size and +-- max success count. +safeCopyTest :: forall a. IdTestingRequiredClasses SafeCopy a => Spec +safeCopyTest = modifyMaxSize (const 8) $ modifyMaxSuccess (const 10) $ + identityTest @a safeCopyEncodeDecode + +showReadTest :: forall a. IdTestingRequiredClasses Read a => Spec +showReadTest = identityTest @a showReadId + +---------------------------------------------------------------------------- + +-- Type to be used to simulate a breaking change in the serialisation +-- schema, so we can test instances which uses the `UnknownXX` pattern +-- for extensibility. +-- Check the `extensionProperty` for more details. +data U = U Word8 BS.ByteString deriving (Show, Eq) + +instance Bi U where + encode (U word8 bs) = encodeListLen 2 <> encode (word8 :: Word8) <> encodeUnknownCborDataItem (LBS.fromStrict bs) + decode = do + decodeListLenCanonicalOf 2 + U <$> decode <*> decodeUnknownCborDataItem + +instance Arbitrary U where + arbitrary = U <$> choose (0, 255) <*> arbitrary + +-- | Like `U`, but we expect to read back the Cbor Data Item when decoding. +data U24 = U24 Word8 BS.ByteString deriving (Show, Eq) + +instance Bi U24 where + encode (U24 word8 bs) = encodeListLen 2 <> encode (word8 :: Word8) <> encodeUnknownCborDataItem (LBS.fromStrict bs) + decode = do + decodeListLenCanonicalOf 2 + U24 <$> decode <*> decodeUnknownCborDataItem + +-- | Given a data type which can be extended, verify we can indeed do so +-- without breaking anything. This should work with every time which adopted +-- the schema of having at least one constructor of the form: +-- .... | Unknown Word8 ByteString +extensionProperty :: forall a. (Arbitrary a, Eq a, Show a, Bi a) => Property +extensionProperty = forAll @a (arbitrary :: Gen a) $ \input -> +{- This function works as follows: + + 1. When we call `serialized`, we are implicitly assuming (as contract of this + function) that the input type would be of a shape such as: + + data MyType = Constructor1 Int Bool + | Constructor2 String + | UnknownConstructor Word8 ByteString + + Such type will be encoded, roughly, like this: + + encode (Constructor1 a b) = encodeWord 0 <> encodeKnownCborDataItem (a,b) + encode (Constructor2 a b) = encodeWord 1 <> encodeKnownCborDataItem a + encode (UnknownConstructor tag bs) = encodeWord tag <> encodeUnknownCborDataItem bs + + In CBOR terms, we would produce something like this: + + + + 2. Now, when we call `unsafeDeserialize serialized`, we are effectively asking to produce as + output a value of type `U`. `U` is defined by only 1 constructor, it + being `U Word8 ByteString`, but this is still compatible with our `tag + cborDataItem` + format. So now we will have something like: + + U + + (The has been removed as part of the decoding process). + + 3. We now call `unsafeDeserialize (serialize u)`, which means: Can you produce a CBOR binary + from `U`, and finally try to decode it into a value of type `a`? This will work because + our intermediate encoding into `U` didn't touch the inital ``, so we will + be able to reconstruct the original object back. + More specifically, `serialize u` would produce once again: + + + + (The has been added as part of the encoding process). + + `unsafeDeserialize` would then consume the tag (to understand which type constructor this corresponds to), + remove the token and finally proceed to deserialise the rest. + +-} + let serialized = serialize input -- Step 1 + (u :: U) = unsafeDeserialize serialized -- Step 2 + (encoded :: a) = unsafeDeserialize (serialize u) -- Step 3 + in encoded === input + +---------------------------------------------------------------------------- +-- Message length +---------------------------------------------------------------------------- + +msgLenLimitedCheck + :: Bi a => Limit a -> a -> Property +msgLenLimitedCheck limit msg = + let sz = BS.length . serialize' $ msg + in if sz <= fromIntegral limit + then property True + else flip counterexample False $ + formatToString ("Message size (max found "%int%") exceedes \ + \limit ("%int%")") sz limit + +msgLenLimitedTest' + :: forall a. IdTestingRequiredClasses Bi a + => Limit a -> String -> (a -> Bool) -> Spec +msgLenLimitedTest' limit desc whetherTest = + -- instead of checking for `arbitrary` values, we'd better generate + -- many values and find maximal message size - it allows user to get + -- correct limit on the spot, if needed. + addDesc $ + modifyMaxSuccess (const 1) $ + identityTest @a $ \_ -> findLargestCheck .&&. listsCheck + where + addDesc act = if null desc then act else describe desc act + + genNice = arbitrary `suchThat` whetherTest + + findLargestCheck = + forAll (resize 1 $ vectorOf 50 genNice) $ + \samples -> counterexample desc $ msgLenLimitedCheck limit $ + maximumBy (comparing $ BS.length . serialize') samples + + -- In this test we increase length of lists, maps, etc. generated + -- by `arbitrary` (by default lists sizes are bounded by 100). + -- + -- Motivation: if your structure contains lists, you should ensure + -- their lengths are limited in practise. If you did, use `MaxSize` + -- wrapper to generate `arbitrary` objects of that type with lists of + -- exactly maximal possible size. + listsCheck = + let doCheck power = forAll (resize (2 ^ power) genNice) $ + \a -> counterexample desc $ + counterexample "Potentially unlimited size!" $ + msgLenLimitedCheck limit a + -- Increase lists length gradually to avoid hanging. + in conjoin $ doCheck <$> [1..13 :: Int] + +msgLenLimitedTest + :: forall a. (IdTestingRequiredClasses Bi a) + => Limit a -> Spec +msgLenLimitedTest lim = msgLenLimitedTest' @a lim "" (const True) + +---------------------------------------------------------------------------- +-- Orphans +---------------------------------------------------------------------------- + +deriving instance Bi bi => Bi (SmallGenerator bi) diff --git a/binary/test/Test/Pos/Binary/Helpers/GoldenRoundTrip.hs b/binary/test/Test/Pos/Binary/Helpers/GoldenRoundTrip.hs new file mode 100644 index 00000000000..3b7712456d3 --- /dev/null +++ b/binary/test/Test/Pos/Binary/Helpers/GoldenRoundTrip.hs @@ -0,0 +1,195 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Test.Pos.Binary.Helpers.GoldenRoundTrip + ( goldenTestBi + , embedGoldenTest + , discoverGolden + , discoverRoundTrip + , roundTripsBiShow + , roundTripsBiBuildable + , roundTripsAesonShow + , roundTripsAesonBuildable + , compareHexDump + , eachOf + ) where + + +import Universum + +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Aeson as JSON (decode, encode) +import qualified Data.ByteString.Lazy.Char8 as BS +import Data.FileEmbed (embedStringFile) +import qualified Data.List as List +import Data.Text.Buildable (Buildable (..)) +import Data.Text.Internal.Builder (fromText, toLazyText) +import Language.Haskell.TH (ExpQ, Q, loc_filename, runIO) +import Language.Haskell.TH.Syntax (qLocation) +import System.Directory (canonicalizePath) +import System.FilePath (takeDirectory, ()) + +import Hedgehog (Gen, Group, MonadTest, Property, PropertyT, TestLimit, discoverPrefix, + eval, forAll, property, success, tripping, withTests, (===)) +import Hedgehog.Internal.Property (Diff (..), failWith) +import Hedgehog.Internal.Show (LineDiff, lineDiff, mkValue, renderLineDiff, showPretty, + valueDiff) +import Hedgehog.Internal.TH (TExpQ) + +import Pos.Binary.Class (Bi (..), decodeFull, serialize) + +import qualified Prelude + +import Text.Show.Pretty (Value (..), parseValue) + +import qualified Test.Pos.Util.Base16 as B16 + +type HexDump = LByteString + +type HexDumpDiff = [LineDiff] + +renderHexDumpDiff :: HexDumpDiff -> String +renderHexDumpDiff = Prelude.unlines . fmap renderLineDiff + +-- | Diff two @HexDump@s by comparing lines pairwise +hexDumpDiff :: HexDump -> HexDump -> Maybe HexDumpDiff +hexDumpDiff x y = + concatMap (uncurry lineDiff) + ... zipWithPadding (String "") (String "") + <$> (sequence $ mkValue <$> BS.lines x) + <*> (sequence $ mkValue <$> BS.lines y) + +zipWithPadding :: a -> b -> [a] -> [b] -> [(a,b)] +zipWithPadding a b (x:xs) (y:ys) = (x,y) : zipWithPadding a b xs ys +zipWithPadding a _ [] ys = zip (repeat a) ys +zipWithPadding _ b xs [] = zip xs (repeat b) + +-- | A custom version of @(===)@ for @HexDump@s to get prettier diffs +compareHexDump :: (MonadTest m, HasCallStack) => HexDump -> HexDump -> m () +compareHexDump x y = do + ok <- withFrozenCallStack $ eval (x == y) + if ok then success else withFrozenCallStack $ failHexDumpDiff x y + +-- | Fail with a nice line diff of the two HexDumps +failHexDumpDiff :: (MonadTest m, HasCallStack) => HexDump -> HexDump -> m () +failHexDumpDiff x y = + case hexDumpDiff x y of + Nothing -> + withFrozenCallStack $ + failWith Nothing $ Prelude.unlines [ + "━━━ Not Equal ━━━" + , showPretty x + , showPretty y + ] + Just diff -> + withFrozenCallStack $ failWith Nothing $ renderHexDumpDiff diff + +makeRelativeToTestDir :: FilePath -> Q FilePath +makeRelativeToTestDir rel = do + loc <- qLocation + fp <- runIO $ canonicalizePath $ loc_filename loc + case findTestDir fp of + Nothing -> + error $ "Couldn't find directory 'test' in path: " <> toText fp + Just testDir -> pure $ testDir rel + where + findTestDir f = + let dir = takeDirectory f + in if dir == f + then Nothing + else if "/test" `List.isSuffixOf` dir + then Just dir + else findTestDir dir + +-- | A handy shortcut for embedding golden testing files +embedGoldenTest :: FilePath -> ExpQ +embedGoldenTest path = + makeRelativeToTestDir ("golden/" <> path) >>= embedStringFile + +discoverGolden :: TExpQ Group +discoverGolden = discoverPrefix "golden_" + +discoverRoundTrip :: TExpQ Group +discoverRoundTrip = discoverPrefix "roundTrip" + +goldenTestBi :: (Bi a, Eq a, Show a, HasCallStack) => a -> FilePath -> Property +goldenTestBi x path = withFrozenCallStack $ do + let bs' = B16.encodeWithIndex . serialize $ x + withTests 1 . property $ do + bs <- liftIO $ BS.readFile path + let target = B16.decode bs + compareHexDump bs bs' + fmap decodeFull target === Just (Right x) + +eachOf :: (Show a) => TestLimit -> Gen a -> (a -> PropertyT IO ()) -> Property +eachOf testLimit things hasProperty = + withTests testLimit . property $ forAll things >>= hasProperty + +-- | Round trip test a value (any instance of both the 'Bi' and 'Show' classes) +-- by serializing it to a ByteString and back again and +-- that also has a 'Show' instance. +-- If the 'a' type has both 'Show' and 'Buildable' instances, its best to +-- use this version. +roundTripsBiShow :: (Bi a, Eq a, MonadTest m, Show a) => a -> m () +roundTripsBiShow x = + tripping x serialize decodeFull + +-- | Round trip (via ByteString) any instance of the 'Bi' class +-- that also has a 'Buildable' instance. +roundTripsBiBuildable :: (Bi a, Eq a, MonadTest m, Buildable a) => a -> m () +roundTripsBiBuildable a = trippingBuildable a serialize decodeFull + +roundTripsAesonShow + :: (Eq a, MonadTest m, ToJSON a, FromJSON a, Show a) => a -> m () +roundTripsAesonShow a = tripping a JSON.encode JSON.decode + +-- | Round trip any `a` with both `ToJSON` and `FromJSON` instances +roundTripsAesonBuildable + :: (Eq a, MonadTest m, ToJSON a, FromJSON a, Buildable a) => a -> m () +roundTripsAesonBuildable a = trippingBuildable a JSON.encode JSON.decode + +-- | Round trip using given encode and decode functions for types with a +-- `Buildable` instance +trippingBuildable :: (Buildable (f a), Eq (f a), Show b, Applicative f, MonadTest m) => a -> (a -> b) -> (b -> f a) -> m () +trippingBuildable x enc dec = + let mx = pure x + i = enc x + my = dec i + in if mx == my + then success + else case valueDiff <$> buildValue mx <*> buildValue my of + Nothing -> + withFrozenCallStack $ + failWith Nothing $ Prelude.unlines + [ "━━━ Original ━━━" + , buildPretty mx + , "━━━ Intermediate ━━━" + , show i + , "━━━ Roundtrip ━━━" + , buildPretty my + ] + + Just diff -> + withFrozenCallStack $ + failWith + (Just $ Diff "━━━ " "- Original" "/" "+ Roundtrip" " ━━━" diff) $ + Prelude.unlines + [ "━━━ Intermediate ━━━" + , show i + ] + +instance Buildable a => Buildable (Either Text a) where + build (Left t) = fromText t + build (Right a) = build a + +instance Buildable () where + build () = "()" + +buildPretty :: Buildable a => a -> String +buildPretty = show . buildValue + +buildValue :: Buildable a => a -> Maybe Value +buildValue = parseValue . stringBuild + +stringBuild :: Buildable a => a -> String +stringBuild = toString . toLazyText . build diff --git a/binary/Test/Pos/Cbor/Canonicity.hs b/binary/test/Test/Pos/Cbor/Canonicity.hs similarity index 100% rename from binary/Test/Pos/Cbor/Canonicity.hs rename to binary/test/Test/Pos/Cbor/Canonicity.hs diff --git a/binary/Test/Pos/Cbor/RefImpl.hs b/binary/test/Test/Pos/Cbor/RefImpl.hs similarity index 99% rename from binary/Test/Pos/Cbor/RefImpl.hs rename to binary/test/Test/Pos/Cbor/RefImpl.hs index 845648ced94..2a17219d659 100644 --- a/binary/Test/Pos/Cbor/RefImpl.hs +++ b/binary/test/Test/Pos/Cbor/RefImpl.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | Reference implementation of CBOR (de)serialization. diff --git a/binary/test/cardano-sl-binary-test.cabal b/binary/test/cardano-sl-binary-test.cabal new file mode 100644 index 00000000000..79b2e48f330 --- /dev/null +++ b/binary/test/cardano-sl-binary-test.cabal @@ -0,0 +1,82 @@ +name: cardano-sl-binary-test +version: 1.3.0 +synopsis: Cardano SL - binary serializarion (tests) +description: This package contains test helpers for cardano-sl-binary. +license: MIT +license-file: LICENSE +author: Serokell +maintainer: hi@serokell.io +copyright: 2016 IOHK +category: Currency +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: + Test.Pos.Binary.Helpers + Test.Pos.Binary.Helpers.GoldenRoundTrip + Test.Pos.Cbor.Canonicity + Test.Pos.Cbor.RefImpl + + build-depends: QuickCheck + , aeson + , base + , bytestring + , cardano-sl-binary + , cardano-sl-util + , cardano-sl-util-test + , cborg + , cereal + , cryptonite + , directory + , filepath + , file-embed + , formatting + , half + , hedgehog + , hspec + , mtl + , pretty-show + , quickcheck-instances + , safecopy + , template-haskell + , text + , text-format + , tagged + , universum + + default-language: Haskell2010 + + default-extensions: DeriveDataTypeable + DeriveGeneric + DeriveFunctor + DeriveFoldable + DeriveTraversable + GeneralizedNewtypeDeriving + StandaloneDeriving + FlexibleContexts + FlexibleInstances + MultiParamTypeClasses + FunctionalDependencies + DefaultSignatures + NoImplicitPrelude + OverloadedStrings + RecordWildCards + TypeApplications + TupleSections + ViewPatterns + LambdaCase + MultiWayIf + ConstraintKinds + UndecidableInstances + BangPatterns + TemplateHaskell + ScopedTypeVariables + MonadFailDesugaring + GADTs + + ghc-options: -Wall + -O2 + + build-tools: cpphs >= 1.19 + ghc-options: -pgmP cpphs -optP --cpp diff --git a/binary/test/test.hs b/binary/test/test.hs new file mode 100644 index 00000000000..8e4923aab31 --- /dev/null +++ b/binary/test/test.hs @@ -0,0 +1,15 @@ +import Universum + +import Test.Hspec (hspec) + +import Spec (spec) + +import qualified Test.Pos.Binary.BiSerialize +import Test.Pos.Binary.Helpers (runTests) + +main :: IO () +main = do + hspec spec + runTests + [ Test.Pos.Binary.BiSerialize.tests + ] diff --git a/block/bench/Block.hs b/block/bench/Block.hs index eaa538472c6..ad5af07f12a 100644 --- a/block/bench/Block.hs +++ b/block/bench/Block.hs @@ -12,7 +12,6 @@ import qualified Data.ByteString.Lazy as LBS import Formatting (build, sformat, shown) import System.Environment (lookupEnv) -import Pos.Arbitrary.Block.Generate (generateBlock) import Pos.Binary.Class (Bi, serialize, unsafeDeserialize) import qualified Pos.Block.BHelpers as Verify import Pos.Core (Block, BlockHeader, BlockVersionData (..), Body, BodyProof, @@ -25,85 +24,25 @@ import Pos.Core (Block, BlockHeader, BlockVersionData (..), Body, Body _mbUpdatePayload) import Pos.Core.Block.Main () import Pos.Core.Common (CoinPortion, SharedSeed (..)) -import Pos.Core.Configuration +import Pos.Core.ProtocolConstants (ProtocolConstants (..)) import Pos.Core.Genesis import Pos.Crypto (ProtocolMagic (..)) --- We need configurations in order to get Arbitrary and Bi instances for --- Block stuff. +import Test.Pos.Block.Arbitrary.Generate (generateMainBlock) -cc :: CoreConfiguration -cc = CoreConfiguration - { ccGenesis = GCSpec genesisSpec - , ccDbSerializeVersion = 0 - } +-- We need 'ProtocolMagic' and 'ProtocolConstants' in order to generate a +-- 'MainBlock'. + +pm :: ProtocolMagic +pm = ProtocolMagic 0 pc :: ProtocolConstants pc = ProtocolConstants { pcK = 7 - , pcProtocolMagic = ProtocolMagic 0 , pcVssMaxTTL = maxBound , pcVssMinTTL = minBound } -bvd :: BlockVersionData -bvd = BlockVersionData - { bvdScriptVersion = 0 - , bvdSlotDuration = 20000 - , bvdMaxBlockSize = limit - , bvdMaxHeaderSize = limit - , bvdMaxTxSize = limit - , bvdMaxProposalSize = limit - , bvdMpcThd = unsafeCoinPortionFromDouble 0 - , bvdHeavyDelThd = unsafeCoinPortionFromDouble 0 - , bvdUpdateVoteThd = unsafeCoinPortionFromDouble 0 - , bvdUpdateProposalThd = unsafeCoinPortionFromDouble 0 - , bvdUpdateImplicit = 0 - , bvdSoftforkRule = SoftforkRule - { srInitThd = unsafeCoinPortionFromDouble 0 - , srMinThd = unsafeCoinPortionFromDouble 0 - , srThdDecrement = unsafeCoinPortionFromDouble 0 - } - , bvdTxFeePolicy = TxFeePolicyUnknown 0 mempty - , bvdUnlockStakeEpoch = EpochIndex { getEpochIndex = 0 } - } - where - limit = fromIntegral ((2 :: Int) ^ (32 :: Int)) - -genesisInitializer :: GenesisInitializer -genesisInitializer = GenesisInitializer - { giTestBalance = balance - , giFakeAvvmBalance = FakeAvvmOptions - { faoCount = 1 - , faoOneBalance = maxBound - } - , giAvvmBalanceFactor = unsafeCoinPortionFromDouble 0 - , giUseHeavyDlg = False - , giSeed = 0 - } - -balance :: TestnetBalanceOptions -balance = TestnetBalanceOptions - { tboPoors = 1 - , tboRichmen = 1 - , tboTotalBalance = maxBound - , tboRichmenShare = 1 - , tboUseHDAddresses = False - } - -genesisSpec :: GenesisSpec -genesisSpec = UnsafeGenesisSpec - { gsAvvmDistr = GenesisAvvmBalances mempty - , gsFtsSeed = SharedSeed mempty - , gsHeavyDelegation = UnsafeGenesisDelegation mempty - , gsBlockVersionData = bvd - , gsProtocolConstants = pc - , gsInitializer = genesisInitializer - } - -confDir :: FilePath -confDir = "./lib" - -- | A test subject: a MainBlock, and its various components, each paired with -- its serialization. data TestSubject = TestSubject @@ -161,13 +100,13 @@ withSerialized a = (a, serialize a) -- | Make a TestSubject using a seed for a PRNG and size. testSubject - :: ( HasConfiguration ) + :: ( ) => Int -- ^ Seed -> Int -- ^ Size -> TestSubject testSubject seed size = let block :: MainBlock - block = generateBlock seed size + block = generateMainBlock pm pc seed size tsBlock = withSerialized block tsHeader = withSerialized (_gbHeader $ block) @@ -183,13 +122,10 @@ testSubject seed size = in TestSubject {..} -benchMain :: ( HasConfiguration ) => Int -> Int -> IO () +benchMain :: ( ) => Int -> Int -> IO () benchMain seed size = defaultMain [ env (return (testSubject seed size) >>= printSizes) $ \ts -> bgroup "block" $ - [ bgroup "verify" $ - [ bench "all" (nf (either (Prelude.error "invalid") identity . Verify.verifyMainBlock :: MainBlock -> ()) (fst . tsBlock $ ts)) - ] - , bgroup "serialize" $ + [ bgroup "serialize" $ [ bench "all" (nf serialize (fst . tsBlock $ ts)) , bgroup "header" $ [ bench "all" (nf serialize (fst . tsHeader $ ts)) @@ -227,7 +163,7 @@ benchMain seed size = defaultMain ] main :: IO () -main = withCoreConfigurations cc confDir (Just (Timestamp 0)) Nothing $ do +main = do sizeStr <- lookupEnv "SIZE" seedStr <- lookupEnv "SEED" let size = case fmap reads sizeStr of diff --git a/block/bench/LICENSE b/block/bench/LICENSE new file mode 100644 index 00000000000..74d83558329 --- /dev/null +++ b/block/bench/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2017 IOHK + +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 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. diff --git a/block/bench/Setup.hs b/block/bench/Setup.hs new file mode 100644 index 00000000000..44671092b28 --- /dev/null +++ b/block/bench/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/block/bench/cardano-sl-block-bench.cabal b/block/bench/cardano-sl-block-bench.cabal new file mode 100644 index 00000000000..b9a2bfcdda8 --- /dev/null +++ b/block/bench/cardano-sl-block-bench.cabal @@ -0,0 +1,29 @@ +name: cardano-sl-block-bench +version: 1.3.0 +synopsis: Cardano SL - block benchmark +description: Cardano SL - block benchmark +license: MIT +license-file: LICENSE +author: IOHK +maintainer: IOHK +copyright: 2018 IOHK +category: Currency +build-type: Simple +cabal-version: >=1.10 + +benchmark bench-block + type: exitcode-stdio-1.0 + main-is: Block.hs + default-language: Haskell2010 + ghc-options: -O2 + build-depends: base + , bytestring + , criterion >= 1.3.0.0 + , cardano-sl-binary + , cardano-sl-block + , cardano-sl-block-test + , cardano-sl-crypto + , cardano-sl-core + , formatting + , universum + , deepseq diff --git a/block/cardano-sl-block.cabal b/block/cardano-sl-block.cabal index cd2b8b81931..99bf25e4668 100644 --- a/block/cardano-sl-block.cabal +++ b/block/cardano-sl-block.cabal @@ -1,5 +1,5 @@ name: cardano-sl-block -version: 1.2.1 +version: 1.3.0 synopsis: Cardano SL - block processing description: Cardano SL - block processing license: MIT @@ -14,17 +14,13 @@ cabal-version: >=1.10 library exposed-modules: - Pos.Arbitrary.Block - Pos.Arbitrary.Block.Message - Pos.Arbitrary.Block.Generate - - Pos.Block.Base Pos.Block.BHelpers Pos.Block.BListener Pos.Block.BlockWorkMode Pos.Block.Configuration Pos.Block.Error Pos.Block.Logic + Pos.Block.Lrc Pos.Block.RetrievalQueue Pos.Block.Slog Pos.Block.Types @@ -40,18 +36,10 @@ library Pos.GState.BlockExtra Pos.GState.SanityCheck - -- LRC - Pos.Lrc - Pos.Lrc.DB - Pos.Lrc.Genesis - -- Binary serialization Pos.Binary.Block.Types Pos.Binary.Block.Network - -- Utilities - Pos.Util.JsonLog - -- Exposed for tests Pos.Block.Logic.VAR Pos.Block.Logic.Integrity @@ -67,17 +55,7 @@ library Pos.Block.Slog.Logic Pos.Block.Slog.Types - -- LRC - Pos.Lrc.Consumers - Pos.Lrc.DB.Leaders - Pos.Lrc.DB.Lrc - Pos.Lrc.DB.Richmen - Pos.Lrc.Logic - Pos.Lrc.Worker - - - build-depends: QuickCheck - , aeson + build-depends: aeson , base , bytestring , cardano-sl-binary @@ -94,6 +72,7 @@ library , cardano-sl-util , cborg , conduit + , containers , cryptonite , data-default , directory @@ -102,13 +81,13 @@ library , exceptions , filepath , formatting - , generic-arbitrary , lens , log-warper , mtl , random , reflection , rocksdb-haskell-ng + , pipes , safe-exceptions , serokell-util , stm @@ -149,28 +128,7 @@ library default-language: Haskell2010 ghc-options: -Wall - -fno-warn-orphans -O2 build-tools: cpphs >= 1.19 ghc-options: -pgmP cpphs -optP --cpp - -Benchmark bench-block - type: exitcode-stdio-1.0 - main-is: Block.hs - hs-source-dirs: bench - ghc-options: -O2 - build-depends: base - , bytestring - , criterion >= 1.3.0.0 - , cardano-sl-binary - , cardano-sl-block - , cardano-sl-crypto - , cardano-sl-core - , cardano-sl-txp - , cardano-sl-update - , cardano-sl-ssc - , cardano-sl-delegation - , formatting - , universum - , deepseq diff --git a/block/src/Pos/Arbitrary/Block/Generate.hs b/block/src/Pos/Arbitrary/Block/Generate.hs deleted file mode 100644 index 485439209e3..00000000000 --- a/block/src/Pos/Arbitrary/Block/Generate.hs +++ /dev/null @@ -1,28 +0,0 @@ --- | Utility to generate a random block using an Arbitrary instance. - -module Pos.Arbitrary.Block.Generate - ( generateBlock - ) where - -import Universum - -import Test.QuickCheck (arbitrary) -import qualified Test.QuickCheck.Gen as QC -import qualified Test.QuickCheck.Random as QC - -import Pos.Core (MainBlock, HasConfiguration) -import qualified Pos.Arbitrary.Block () - --- The arbitrary instances requires configuration, unfortunately. --- That's because it does verification. Yes, indeed, the arbitrary instance --- does verification, which uses a protocol magic, epoch slot data, etc. etc. - - -generateBlock - :: ( HasConfiguration ) - => Int -- ^ Seed for random generator. - -> Int -- ^ Size of the generated value (see QuickCheck docs). - -> MainBlock -generateBlock genSeed = QC.unGen arbitrary qcGen - where - qcGen = QC.mkQCGen genSeed diff --git a/block/src/Pos/Arbitrary/Block/Message.hs b/block/src/Pos/Arbitrary/Block/Message.hs deleted file mode 100644 index b231dea9d40..00000000000 --- a/block/src/Pos/Arbitrary/Block/Message.hs +++ /dev/null @@ -1,46 +0,0 @@ - -module Pos.Arbitrary.Block.Message - ( - ) where - -import Test.QuickCheck (Arbitrary (..)) -import Test.QuickCheck.Arbitrary.Generic (genericArbitrary, genericShrink) - -import Pos.Arbitrary.Block () -import Pos.Arbitrary.Ssc (SscPayloadDependsOnSlot (..)) -import Pos.Arbitrary.Txp () -import Pos.Arbitrary.Update () -import Pos.Binary.Class (Bi, Raw) -import qualified Pos.Block.Network.Types as T -import Pos.Core (HasConfiguration) -import Pos.Core.Ssc (SscPayload, SscProof) - ------------------------------------------------------------------------------------------- --- Block network types ------------------------------------------------------------------------------------------- - -instance HasConfiguration => Arbitrary T.MsgGetHeaders where - arbitrary = genericArbitrary - shrink = genericShrink - -instance HasConfiguration => Arbitrary T.MsgGetBlocks where - arbitrary = genericArbitrary - shrink = genericShrink - -instance ( Arbitrary SscPayload - , Arbitrary SscProof - , Bi Raw - , HasConfiguration - ) => - Arbitrary T.MsgHeaders where - arbitrary = genericArbitrary - shrink = genericShrink - -instance ( Arbitrary SscPayload - , Arbitrary SscProof - , Arbitrary SscPayloadDependsOnSlot - , HasConfiguration - ) => - Arbitrary T.MsgBlock where - arbitrary = genericArbitrary - shrink = genericShrink diff --git a/block/src/Pos/Binary/Block/Types.hs b/block/src/Pos/Binary/Block/Types.hs index ce47bc34e57..fdb45876904 100644 --- a/block/src/Pos/Binary/Block/Types.hs +++ b/block/src/Pos/Binary/Block/Types.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | Binary serialization of Pos.Block.* Types. module Pos.Binary.Block.Types @@ -6,13 +8,13 @@ module Pos.Binary.Block.Types import Universum -import Pos.Binary.Class (Cons (..), Field (..), deriveSimpleBi, deriveSimpleBiCxt) +import Pos.Binary.Class (Cons (..), Field (..), deriveSimpleBi) import Pos.Binary.Core () import Pos.Binary.Delegation () import Pos.Binary.Update () import Pos.Block.Slog.Types (SlogUndo (..)) import Pos.Block.Types (Undo (..)) -import Pos.Core (FlatSlotId, HasConfiguration, TxpUndo) +import Pos.Core (FlatSlotId, TxpUndo) import Pos.Delegation.Types (DlgUndo) import Pos.Update.Poll.Types (USUndo) @@ -21,7 +23,7 @@ deriveSimpleBi ''SlogUndo [ Field [| getSlogUndo :: Maybe FlatSlotId |] ]] -deriveSimpleBiCxt [t|HasConfiguration|] ''Undo [ +deriveSimpleBi ''Undo [ Cons 'Undo [ Field [| undoTx :: TxpUndo |], Field [| undoDlg :: DlgUndo |], diff --git a/block/src/Pos/Block/BHelpers.hs b/block/src/Pos/Block/BHelpers.hs index d478ee5c044..cfc4021c62c 100644 --- a/block/src/Pos/Block/BHelpers.hs +++ b/block/src/Pos/Block/BHelpers.hs @@ -22,46 +22,43 @@ import Control.Monad.Except (MonadError (throwError)) import Pos.Binary.Class (Bi) import Pos.Binary.Core () -import Pos.Core.Block (Block) +import Pos.Core.Block (Block, GenesisBlockchain, MainBlockchain, MainConsensusData (..), + MainToSign (..)) import Pos.Core.Block.Blockchain (Blockchain (..), GenericBlock (..), GenericBlockHeader (..), gbExtra) -import Pos.Core.Block.Genesis (GenesisBlockchain) -import Pos.Core.Block.Main (Body (..), ConsensusData (..), MainBlockHeader, - MainBlockchain, MainExtraHeaderData (..), MainToSign (..), +import Pos.Core.Block.Main (MainBody (..), MainExtraHeaderData (..), MainProof, mainBlockEBDataProof) import Pos.Core.Block.Union (BlockHeader (..), BlockSignature (..)) -import Pos.Core.Class (IsMainHeader (..)) -import Pos.Core.Configuration (HasConfiguration) +import Pos.Core.Configuration (HasProtocolConstants) import Pos.Core.Delegation (LightDlgIndices (..), checkDlgPayload) import Pos.Core.Slotting (SlotId (..)) import Pos.Core.Ssc (checkSscPayload) import Pos.Core.Txp (checkTxPayload) import Pos.Core.Update (checkSoftwareVersion, checkUpdatePayload) -import Pos.Crypto (ProxySignature (..), SignTag (..), checkSig, hash, isSelfSignedPsk, - proxyVerify) +import Pos.Crypto (ProtocolMagic, ProxySignature (..), SignTag (..), checkSig, hash, + isSelfSignedPsk, proxyVerify) import Pos.Ssc.Functions (verifySscPayload) import Pos.Util.Some (Some (Some)) -- | Verify a BlockHeader in isolation. There is nothing to be done for -- genesis headers. verifyBlockHeader - :: (HasConfiguration, MonadError Text m, Bi (BodyProof MainBlockchain)) - => BlockHeader + :: MonadError Text m + => ProtocolMagic + -> BlockHeader -> m () -verifyBlockHeader (BlockHeaderGenesis _) = pure () -verifyBlockHeader (BlockHeaderMain bhm) = verifyMainBlockHeader bhm +verifyBlockHeader _ (BlockHeaderGenesis _) = pure () +verifyBlockHeader pm (BlockHeaderMain bhm) = verifyMainBlockHeader pm bhm -- | Verify a Block in isolation. verifyBlock - :: ( HasConfiguration - , MonadError Text m - , Bi BlockHeader - , Bi (BodyProof MainBlockchain) - , IsMainHeader MainBlockHeader + :: ( MonadError Text m + , HasProtocolConstants ) - => Block + => ProtocolMagic + -> Block -> m () -verifyBlock = either verifyGenesisBlock verifyMainBlock +verifyBlock pm = either verifyGenesisBlock (verifyMainBlock pm) -- | To verify a genesis block we only have to check the body proof. verifyGenesisBlock @@ -69,25 +66,25 @@ verifyGenesisBlock => GenericBlock GenesisBlockchain -> m () verifyGenesisBlock UnsafeGenericBlock {..} = - checkBodyProof _gbBody (_gbhBodyProof _gbHeader) + checkBodyProof @GenesisBlockchain _gbBody (_gbhBodyProof _gbHeader) verifyMainBlock - :: ( HasConfiguration - , MonadError Text m + :: ( MonadError Text m , Bi BlockHeader - , Bi (BodyProof MainBlockchain) - , IsMainHeader MainBlockHeader + , Bi MainProof + , HasProtocolConstants ) - => GenericBlock MainBlockchain + => ProtocolMagic + -> GenericBlock MainBlockchain -> m () -verifyMainBlock block@UnsafeGenericBlock {..} = do - verifyMainBlockHeader _gbHeader - verifyMainBody _gbBody +verifyMainBlock pm block@UnsafeGenericBlock {..} = do + verifyMainBlockHeader pm _gbHeader + verifyMainBody pm _gbBody -- No need to verify the main extra body data. It's an 'Attributes ()' -- which is valid whenever it's well-formed. -- -- Check internal consistency: the body proofs are all correct. - checkBodyProof _gbBody (_gbhBodyProof _gbHeader) + checkBodyProof @MainBlockchain _gbBody (_gbhBodyProof _gbHeader) -- Check that the headers' extra body data hash is correct. -- This isn't subsumed by the body proof check. unless (hash (block ^. gbExtra) == (block ^. mainBlockEBDataProof)) $ @@ -96,27 +93,30 @@ verifyMainBlock block@UnsafeGenericBlock {..} = do -- be done in 'verifyMainBody'. either (throwError . pretty) pure $ verifySscPayload + pm (Right (Some _gbHeader)) (_mbSscPayload _gbBody) -- | Verify the body of a block. There are no internal consistency checks, -- it's just a verification of its sub-components (payloads). verifyMainBody - :: ( HasConfiguration, MonadError Text m ) - => Body MainBlockchain + :: MonadError Text m + => ProtocolMagic + -> MainBody -> m () -verifyMainBody MainBody {..} = do +verifyMainBody pm MainBody {..} = do checkTxPayload _mbTxPayload - checkSscPayload _mbSscPayload - checkDlgPayload _mbDlgPayload - checkUpdatePayload _mbUpdatePayload + checkSscPayload pm _mbSscPayload + checkDlgPayload pm _mbDlgPayload + checkUpdatePayload pm _mbUpdatePayload -- | Verify a main block header in isolation. verifyMainBlockHeader - :: (HasConfiguration, MonadError Text m, Bi (BodyProof MainBlockchain)) - => GenericBlockHeader MainBlockchain + :: MonadError Text m + => ProtocolMagic + -> GenericBlockHeader MainBlockchain -> m () -verifyMainBlockHeader UnsafeGenericBlockHeader {..} = do +verifyMainBlockHeader pm UnsafeGenericBlockHeader {..} = do -- Previous header hash is always valid. -- Body proof is just a bunch of hashes, which is always valid (although -- must be checked against the actual body, in verifyMainBlock. @@ -131,16 +131,17 @@ verifyMainBlockHeader UnsafeGenericBlockHeader {..} = do where verifyBlockSignature (BlockSignature sig) = - checkSig SignMainBlock leaderPk signature sig + checkSig pm SignMainBlock leaderPk signature sig verifyBlockSignature (BlockPSignatureLight proxySig) = proxyVerify + pm SignMainBlockLight proxySig (\(LightDlgIndices (epochLow, epochHigh)) -> epochLow <= epochId && epochId <= epochHigh) signature verifyBlockSignature (BlockPSignatureHeavy proxySig) = - proxyVerify SignMainBlockHeavy proxySig (const True) signature + proxyVerify pm SignMainBlockHeavy proxySig (const True) signature signature = MainToSign _gbhPrevBlock _gbhBodyProof slotId difficulty _gbhExtra epochId = siEpoch slotId MainConsensusData @@ -153,7 +154,7 @@ verifyMainBlockHeader UnsafeGenericBlockHeader {..} = do -- | Verify the consensus data in isolation. verifyMainConsensusData :: ( MonadError Text m ) - => ConsensusData MainBlockchain + => MainConsensusData -> m () verifyMainConsensusData MainConsensusData {..} = do when (selfSignedProxy _mcdSignature) $ diff --git a/block/src/Pos/Block/BListener.hs b/block/src/Pos/Block/BListener.hs index ee92f62a0ec..ce90e85a074 100644 --- a/block/src/Pos/Block/BListener.hs +++ b/block/src/Pos/Block/BListener.hs @@ -17,7 +17,7 @@ import Mockable (SharedAtomicT) import Pos.Block.Types (Blund) import Pos.DB.BatchOp (SomeBatchOp) -import Pos.Util.Chrono (NE, NewestFirst (..), OldestFirst (..)) +import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..)) class Monad m => MonadBListener m where -- Callback will be called after putting blocks into BlocksDB diff --git a/block/src/Pos/Block/Base.hs b/block/src/Pos/Block/Base.hs deleted file mode 100644 index 8bc62590c03..00000000000 --- a/block/src/Pos/Block/Base.hs +++ /dev/null @@ -1,151 +0,0 @@ --- | Block constructors and basic functions. - -module Pos.Block.Base - ( mkMainBlock - , mkMainHeader - , emptyMainBody - - , mkGenesisHeader - , mkGenesisBlock - , genesisBlock0 - ) where - -import Universum - -import Data.Default (Default (def)) - -import Pos.Block.BHelpers () -import Pos.Core (EpochIndex, HasConfiguration, HasDifficulty (..), LocalSlotIndex, SlotId, - SlotLeaders) -import Pos.Core.Block (BlockHeader, BlockSignature (..), GenesisBlock, GenesisBlockHeader, - GenesisBlockchain, GenesisExtraBodyData (..), - GenesisExtraHeaderData (..), MainBlock, MainBlockHeader, - MainBlockchain, MainExtraBodyData (..), MainExtraHeaderData (..), - MainToSign (..), mkGenericHeader, GenericBlock (..)) -import Pos.Core.Block.Genesis (Body (..), ConsensusData (..)) -import Pos.Core.Block.Main (Body (..), ConsensusData (..)) -import Pos.Crypto (SecretKey, SignTag (..), hash, proxySign, sign, toPublic) -import Pos.Data.Attributes (mkAttributes) -import Pos.Delegation.Types (ProxySKBlockInfo) -import Pos.Lrc.Genesis (genesisLeaders) -import Pos.Ssc.Base (defaultSscPayload) -import Pos.Txp.Base (emptyTxPayload) -import Pos.Update.Configuration (HasUpdateConfiguration, curSoftwareVersion, - lastKnownBlockVersion) - ----------------------------------------------------------------------------- --- Main smart constructors ----------------------------------------------------------------------------- - --- | Smart constructor for 'MainBlockHeader'. -mkMainHeader - :: HasConfiguration - => Maybe BlockHeader - -> SlotId - -> SecretKey - -> ProxySKBlockInfo - -> Body MainBlockchain - -> MainExtraHeaderData - -> MainBlockHeader -mkMainHeader prevHeader slotId sk pske body extra = - mkGenericHeader prevHeader body consensus extra - where - difficulty = maybe 0 (succ . view difficultyL) prevHeader - makeSignature toSign (psk,_) = - BlockPSignatureHeavy $ proxySign SignMainBlockHeavy sk psk toSign - signature prevHash proof = - let toSign = MainToSign prevHash proof slotId difficulty extra - in maybe - (BlockSignature $ sign SignMainBlock sk toSign) - (makeSignature toSign) - pske - leaderPk = maybe (toPublic sk) snd pske - consensus prevHash proof = - MainConsensusData - { _mcdSlot = slotId - , _mcdLeaderKey = leaderPk - , _mcdDifficulty = difficulty - , _mcdSignature = signature prevHash proof - } - --- | Smart constructor for 'MainBlock'. --- --- FIXME TBD do we need to verify here? This is not used on untrusted data, --- so why bother? -mkMainBlock - :: (HasUpdateConfiguration, HasConfiguration) - => Maybe BlockHeader - -> SlotId - -> SecretKey - -> ProxySKBlockInfo - -> Body MainBlockchain - -> MainBlock -mkMainBlock prevHeader slotId sk pske body = - UnsafeGenericBlock - (mkMainHeader prevHeader slotId sk pske body extraH) - body - extraB - where - extraB :: MainExtraBodyData - extraB = MainExtraBodyData (mkAttributes ()) - extraH :: MainExtraHeaderData - extraH = - MainExtraHeaderData - lastKnownBlockVersion - curSoftwareVersion - (mkAttributes ()) - (hash extraB) - --- | Empty (i. e. no payload) body of main block for given local slot index. -emptyMainBody - :: HasConfiguration - => LocalSlotIndex - -> Body MainBlockchain -emptyMainBody slot = - MainBody - { _mbTxPayload = emptyTxPayload - , _mbSscPayload = defaultSscPayload slot - , _mbDlgPayload = def - , _mbUpdatePayload = def - } - ----------------------------------------------------------------------------- --- Genesis smart constructors ----------------------------------------------------------------------------- - --- | Smart constructor for 'GenesisBlockHeader'. Uses 'mkGenericHeader'. -mkGenesisHeader - :: HasConfiguration - => Maybe BlockHeader - -> EpochIndex - -> Body GenesisBlockchain - -> GenesisBlockHeader -mkGenesisHeader prevHeader epoch body = - -- here we know that genesis header construction can not fail - mkGenericHeader - prevHeader - body - consensus - (GenesisExtraHeaderData $ mkAttributes ()) - where - difficulty = maybe 0 (view difficultyL) prevHeader - consensus _ _ = - GenesisConsensusData {_gcdEpoch = epoch, _gcdDifficulty = difficulty} - --- | Smart constructor for 'GenesisBlock'. -mkGenesisBlock - :: HasConfiguration - => Maybe BlockHeader - -> EpochIndex - -> SlotLeaders - -> GenesisBlock -mkGenesisBlock prevHeader epoch leaders = - UnsafeGenericBlock header body extra - where - header = mkGenesisHeader prevHeader epoch body - body = GenesisBody leaders - extra = GenesisExtraBodyData $ mkAttributes () - --- | Creates the very first genesis block. -genesisBlock0 :: HasConfiguration => GenesisBlock -genesisBlock0 = mkGenesisBlock Nothing 0 genesisLeaders diff --git a/block/src/Pos/Block/BlockWorkMode.hs b/block/src/Pos/Block/BlockWorkMode.hs index bdfd6edfc2d..baffa0de401 100644 --- a/block/src/Pos/Block/BlockWorkMode.hs +++ b/block/src/Pos/Block/BlockWorkMode.hs @@ -15,29 +15,29 @@ import System.Wlog (WithLogger) import Pos.Binary.Class (Bi) import Pos.Block.Configuration (HasBlockConfiguration) +import Pos.Block.Lrc (LrcModeFull) import Pos.Block.Network.Types (MsgBlock, MsgGetBlocks, MsgGetHeaders, MsgHeaders) import Pos.Block.RetrievalQueue (BlockRetrievalQueue, BlockRetrievalQueueTag) import Pos.Block.Slog (HasSlogContext) import Pos.Block.Types (LastKnownHeader, LastKnownHeaderTag, RecoveryHeader, RecoveryHeaderTag) -import Pos.Communication.Limits.Types (MessageLimited) -import Pos.Communication.Protocol (Message) import Pos.Core.Context (HasPrimaryKey) -import Pos.Lrc (LrcModeFull) -import Pos.Recovery.Info (MonadRecoveryInfo) +import Pos.Infra.Communication.Protocol (Message) +import Pos.Infra.Recovery.Info (MonadRecoveryInfo) +import Pos.Infra.Shutdown.Class (HasShutdownContext) +import Pos.Infra.StateLock (StateLock, StateLockMetrics) +import Pos.Infra.Util.JsonLog.Events (MemPoolModifyReason) +import Pos.Infra.Util.TimeWarp (CanJsonLog) import Pos.Security.Params (SecurityParams) -import Pos.Shutdown.Class (HasShutdownContext) -import Pos.StateLock (StateLock, StateLockMetrics) import Pos.Txp (GenericTxpLocalData, MempoolExt, MonadTxpLocal, TxpHolderTag) import Pos.Update.Context (UpdateContext) -import Pos.Util.TimeWarp (CanJsonLog) import Pos.Util.Util (HasLens, HasLens') -- | These instances are implemented in @Pos.Binary.Communication@, -- @Pos.Communication.Message@ and @Pos.Communication.Limits@, which -- are unavailable at this point, hence we defer providing them -- to the calling site. -type BlockInstancesConstraint m = +type BlockInstancesConstraint = ( Each '[Bi] [ MsgGetHeaders , MsgHeaders @@ -48,15 +48,11 @@ type BlockInstancesConstraint m = , MsgHeaders , MsgGetBlocks , MsgBlock ] - , MessageLimited MsgGetHeaders m - , MessageLimited MsgHeaders m - , MessageLimited MsgGetBlocks m - , MessageLimited MsgBlock m ) -- | A subset of @WorkMode@. type BlockWorkMode ctx m = - ( BlockInstancesConstraint m + ( BlockInstancesConstraint , Default (MempoolExt m) , Mockables m [Delay, SharedAtomic] @@ -75,7 +71,7 @@ type BlockWorkMode ctx m = , HasLens TxpHolderTag ctx (GenericTxpLocalData (MempoolExt m)) , HasLens' ctx SecurityParams , HasLens' ctx StateLock - , HasLens' ctx StateLockMetrics + , HasLens' ctx (StateLockMetrics MemPoolModifyReason) , HasLens' ctx UpdateContext , CanJsonLog m diff --git a/block/src/Pos/Block/Configuration.hs b/block/src/Pos/Block/Configuration.hs index ea54ebe946c..ec913b5da0f 100644 --- a/block/src/Pos/Block/Configuration.hs +++ b/block/src/Pos/Block/Configuration.hs @@ -22,15 +22,15 @@ module Pos.Block.Configuration -- * Other constants , recoveryHeadersMessage + , streamWindow ) where import Universum import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON) import Data.Reflection (Given (..), give) -import Data.Time.Units (Microsecond, Second, convertUnit) +import Data.Time.Units (Microsecond, Second, convertUnit, fromMicroseconds) import Serokell.Aeson.Options (defaultOptions) -import Serokell.Util (sec) import Pos.Aeson.Core () @@ -48,6 +48,8 @@ data BlockConfiguration = BlockConfiguration -- ^ Estimated time for broadcasting messages , ccRecoveryHeadersMessage :: !Int -- ^ Numbers of headers put in message in recovery mode. + , ccStreamWindow :: !Int + -- ^ Number of blocks to have inflight -- Chain quality thresholds and other constants to detect -- suspicious things. @@ -85,7 +87,7 @@ instance FromJSON BlockConfiguration where -- | Estimated time needed to broadcast message from one node to all -- other nodes. Also see 'Pos.NodeConfiguration.ccNetworkDiameter'. networkDiameter :: HasBlockConfiguration => Microsecond -networkDiameter = sec . ccNetworkDiameter $ blockConfiguration +networkDiameter = fromMicroseconds . (*) 1000000 . fromIntegral . ccNetworkDiameter $ blockConfiguration ---------------------------------------------------------------------------- -- Chain quality @@ -133,3 +135,9 @@ fixedTimeCQSec = ccFixedTimeCQ blockConfiguration -- 'blkSecurityParam'. recoveryHeadersMessage :: (HasBlockConfiguration, Integral a) => a recoveryHeadersMessage = fromIntegral . ccRecoveryHeadersMessage $ blockConfiguration + +-- | The maximum number of blocks to have in flight. +-- Provides back-preassure from client to server when streaming. +streamWindow :: (HasBlockConfiguration, Integral a) => a +streamWindow = fromIntegral . ccStreamWindow $ blockConfiguration + diff --git a/block/src/Pos/Block/Logic.hs b/block/src/Pos/Block/Logic.hs index f06e9bb59bc..2571992c12e 100644 --- a/block/src/Pos/Block/Logic.hs +++ b/block/src/Pos/Block/Logic.hs @@ -1,3 +1,16 @@ -- | This module re-exports everything from 'Pos.Block.Logic.*'. +module Pos.Block.Logic + ( module Pos.Block.Logic.VAR + , module Pos.Block.Logic.Util + , module Pos.Block.Logic.Internal + , module Pos.Block.Logic.Header + , module Pos.Block.Logic.Creation + , module Pos.Block.Logic.Integrity + ) where -{-# OPTIONS_GHC -F -pgmF autoexporter #-} +import Pos.Block.Logic.VAR +import Pos.Block.Logic.Util +import Pos.Block.Logic.Internal +import Pos.Block.Logic.Header +import Pos.Block.Logic.Creation +import Pos.Block.Logic.Integrity diff --git a/block/src/Pos/Block/Logic/Creation.hs b/block/src/Pos/Block/Logic/Creation.hs index 86d07b28734..578c4c7b238 100644 --- a/block/src/Pos/Block/Logic/Creation.hs +++ b/block/src/Pos/Block/Logic/Creation.hs @@ -20,54 +20,57 @@ import Control.Lens (uses, (-=), (.=), _Wrapped) import Control.Monad.Except (MonadError (throwError), runExceptT) import Data.Default (Default (def)) import Formatting (build, fixed, ords, sformat, stext, (%)) +import JsonLog (CanJsonLog (..)) import Serokell.Data.Memory.Units (Byte, memory) import System.Wlog (WithLogger, logDebug) import Pos.Binary.Class (biSize) -import Pos.Block.Base (mkGenesisBlock, mkMainBlock) import Pos.Block.Logic.Internal (MonadBlockApply, applyBlocksUnsafe, normalizeMempool) import Pos.Block.Logic.Util (calcChainQualityM) import Pos.Block.Logic.VAR (verifyBlocksPrefix) +import Pos.Block.Lrc (LrcModeFull, lrcSingleShot) import Pos.Block.Slog (HasSlogGState (..), ShouldCallBListener (..)) -import Pos.Core (Blockchain (..), EpochIndex, EpochOrSlot (..), HasConfiguration, +import Pos.Core (Blockchain (..), EpochIndex, EpochOrSlot (..), HasProtocolConstants, HeaderHash, SlotId (..), chainQualityThreshold, epochIndexL, epochSlots, flattenSlotId, getEpochOrSlot, headerHash) import Pos.Core.Block (BlockHeader (..), GenesisBlock, MainBlock, MainBlockchain) import qualified Pos.Core.Block as BC +import Pos.Core.Block.Constructors (mkGenesisBlock, mkMainBlock) import Pos.Core.Context (HasPrimaryKey, getOurSecretKey) import Pos.Core.Ssc (SscPayload) import Pos.Core.Txp (TxAux (..), mkTxPayload) import Pos.Core.Update (UpdatePayload (..)) -import Pos.Crypto (SecretKey) +import Pos.Crypto (ProtocolMagic, SecretKey) import qualified Pos.DB.BlockIndex as DB import Pos.DB.Class (MonadDBRead) import Pos.Delegation (DelegationVar, DlgPayload (..), ProxySKBlockInfo, clearDlgMemPool, getDlgMempool) import Pos.Exception (assertionFailed, reportFatalError) -import Pos.Lrc (HasLrcContext, LrcModeFull, lrcSingleShot) +import Pos.Infra.Reporting (HasMisbehaviorMetrics, reportError) +import Pos.Infra.StateLock (Priority (..), StateLock, StateLockMetrics, modifyStateLock) +import Pos.Infra.Util.JsonLog.Events (MemPoolModifyReason (..)) +import Pos.Infra.Util.LogSafe (logInfoS) +import Pos.Lrc (HasLrcContext) import Pos.Lrc.Context (lrcActionOnEpochReason) import qualified Pos.Lrc.DB as LrcDB -import Pos.Reporting (reportError) import Pos.Ssc.Base (defaultSscPayload, stripSscPayload) import Pos.Ssc.Logic (sscGetLocalPayload) import Pos.Ssc.Mem (MonadSscMem) import Pos.Ssc.State (sscResetLocal) -import Pos.StateLock (Priority (..), StateLock, StateLockMetrics, modifyStateLock) import Pos.Txp (MempoolExt, MonadTxpLocal (..), MonadTxpMem, clearTxpMemPool, txGetPayload, withTxpLocalData) import Pos.Txp.Base (emptyTxPayload) import Pos.Update (UpdateContext) -import Pos.Update.Configuration (HasUpdateConfiguration) +import Pos.Update.Configuration (HasUpdateConfiguration, curSoftwareVersion, + lastKnownBlockVersion) import qualified Pos.Update.DB as UDB import Pos.Update.Logic (clearUSMemPool, usCanCreateBlock, usPreparePayload) import Pos.Util (_neHead) -import Pos.Util.LogSafe (logInfoS) import Pos.Util.Util (HasLens (..), HasLens') -- | A set of constraints necessary to create a block from mempool. type MonadCreateBlock ctx m - = ( HasConfiguration - , HasUpdateConfiguration + = ( HasUpdateConfiguration , MonadReader ctx m , HasPrimaryKey ctx , HasSlogGState ctx -- to check chain quality @@ -108,15 +111,17 @@ type MonadCreateBlock ctx m createGenesisBlockAndApply :: forall ctx m. ( MonadCreateBlock ctx m - , MonadBlockApply ctx m + , CanJsonLog m , HasLens StateLock ctx StateLock - , HasLens StateLockMetrics ctx StateLockMetrics + , HasLens (StateLockMetrics MemPoolModifyReason) ctx (StateLockMetrics MemPoolModifyReason) + , HasMisbehaviorMetrics ctx ) - => EpochIndex + => ProtocolMagic + -> EpochIndex -> m (Maybe GenesisBlock) -- Genesis block for 0-th epoch is hardcoded. -createGenesisBlockAndApply 0 = pure Nothing -createGenesisBlockAndApply epoch = do +createGenesisBlockAndApply _ 0 = pure Nothing +createGenesisBlockAndApply pm epoch = do tipHeader <- DB.getTipHeader -- preliminary check outside the lock, -- must be repeated inside the lock @@ -124,17 +129,19 @@ createGenesisBlockAndApply epoch = do if needGen then modifyStateLock HighPriority - "createGenesisBlockAndApply" - (\_ -> createGenesisBlockDo epoch) + ApplyBlock + (\_ -> createGenesisBlockDo pm epoch) else return Nothing createGenesisBlockDo :: forall ctx m. ( MonadCreateBlock ctx m - , MonadBlockApply ctx m) - => EpochIndex + , HasMisbehaviorMetrics ctx + ) + => ProtocolMagic + -> EpochIndex -> m (HeaderHash, Maybe GenesisBlock) -createGenesisBlockDo epoch = do +createGenesisBlockDo pm epoch = do tipHeader <- DB.getTipHeader logDebug $ sformat msgTryingFmt epoch tipHeader needCreateGenesisBlock epoch tipHeader >>= \case @@ -146,17 +153,17 @@ createGenesisBlockDo epoch = do -- Note that it shouldn't fail, because 'shouldCreate' guarantees that we -- have enough blocks for LRC. actuallyCreate tipHeader = do - lrcSingleShot epoch + lrcSingleShot pm epoch leaders <- lrcActionOnEpochReason epoch "createGenesisBlockDo " LrcDB.getLeadersForEpoch - let blk = mkGenesisBlock (Just tipHeader) epoch leaders + let blk = mkGenesisBlock pm (Right tipHeader) epoch leaders let newTip = headerHash blk - verifyBlocksPrefix (one (Left blk)) >>= \case + verifyBlocksPrefix pm (one (Left blk)) >>= \case Left err -> reportFatalError $ pretty err Right (undos, pollModifier) -> do let undo = undos ^. _Wrapped . _neHead - applyBlocksUnsafe (ShouldCallBListener True) (one (Left blk, undo)) (Just pollModifier) - normalizeMempool + applyBlocksUnsafe pm (ShouldCallBListener True) (one (Left blk, undo)) (Just pollModifier) + normalizeMempool pm pure (newTip, Just blk) logShouldNot = logDebug @@ -167,7 +174,6 @@ createGenesisBlockDo epoch = do needCreateGenesisBlock :: ( MonadCreateBlock ctx m - , MonadBlockApply ctx m ) => EpochIndex -> BlockHeader @@ -206,20 +212,21 @@ needCreateGenesisBlock epoch tipHeader = do createMainBlockAndApply :: forall ctx m. ( MonadCreateBlock ctx m - , MonadBlockApply ctx m + , CanJsonLog m , HasLens' ctx StateLock - , HasLens' ctx StateLockMetrics + , HasLens' ctx (StateLockMetrics MemPoolModifyReason) ) - => SlotId + => ProtocolMagic + -> SlotId -> ProxySKBlockInfo -> m (Either Text MainBlock) -createMainBlockAndApply sId pske = - modifyStateLock HighPriority "createMainBlockAndApply" createAndApply +createMainBlockAndApply pm sId pske = + modifyStateLock HighPriority ApplyBlock createAndApply where createAndApply tip = - createMainBlockInternal sId pske >>= \case + createMainBlockInternal pm sId pske >>= \case Left reason -> pure (tip, Left reason) - Right blk -> convertRes <$> applyCreatedBlock pske blk + Right blk -> convertRes <$> applyCreatedBlock pm pske blk convertRes createdBlk = (headerHash createdBlk, Right createdBlk) ---------------------------------------------------------------------------- @@ -232,11 +239,14 @@ createMainBlockAndApply sId pske = -- block. It only checks whether a block can be created (see -- 'createMainBlockAndApply') and creates it checks passes. createMainBlockInternal :: - forall ctx m. (MonadCreateBlock ctx m) - => SlotId + forall ctx m. + ( MonadCreateBlock ctx m + ) + => ProtocolMagic + -> SlotId -> ProxySKBlockInfo -> m (Either Text MainBlock) -createMainBlockInternal sId pske = do +createMainBlockInternal pm sId pske = do tipHeader <- DB.getTipHeader logInfoS $ sformat msgFmt tipHeader canCreateBlock sId tipHeader >>= \case @@ -252,13 +262,12 @@ createMainBlockInternal sId pske = do -- overhead. You can see that in bitcoin blocks are 1-2kB less -- than limit. So i guess it's fine in general. sizeLimit <- (\x -> bool 0 (x - 100) (x > 100)) <$> lift UDB.getMaxBlockSize - block <- createMainBlockPure sizeLimit prevHeader pske sId sk rawPay + block <- createMainBlockPure pm sizeLimit prevHeader pske sId sk rawPay logInfoS $ "Created main block of size: " <> sformat memory (biSize block) block <$ evaluateNF_ block -canCreateBlock :: - forall ctx m. (MonadCreateBlock ctx m) +canCreateBlock :: MonadCreateBlock ctx m => SlotId -> BlockHeader -> m (Either Text ()) @@ -293,18 +302,19 @@ canCreateBlock sId tipHeader = createMainBlockPure :: forall m. - (MonadError Text m, HasConfiguration, HasUpdateConfiguration) - => Byte -- ^ Block size limit (real max.value) + ( MonadError Text m, HasUpdateConfiguration, HasProtocolConstants ) + => ProtocolMagic + -> Byte -- ^ Block size limit (real max.value) -> BlockHeader -> ProxySKBlockInfo -> SlotId -> SecretKey -> RawPayload -> m MainBlock -createMainBlockPure limit prevHeader pske sId sk rawPayload = do +createMainBlockPure pm limit prevHeader pske sId sk rawPayload = do bodyLimit <- execStateT computeBodyLimit limit body <- createMainBody bodyLimit sId rawPayload - pure (mkMainBlock (Just prevHeader) sId sk pske body) + pure (mkMainBlock pm bv sv (Right prevHeader) sId sk pske body) where -- default ssc to put in case we won't fit a normal one defSsc :: SscPayload @@ -314,11 +324,13 @@ createMainBlockPure limit prevHeader pske sId sk rawPayload = do -- account for block header and serialization overhead, etc; let musthaveBody = BC.MainBody emptyTxPayload defSsc def def let musthaveBlock = - mkMainBlock (Just prevHeader) sId sk pske musthaveBody + mkMainBlock pm bv sv (Right prevHeader) sId sk pske musthaveBody let mhbSize = biSize musthaveBlock when (mhbSize > limit) $ throwError $ "Musthave block size is more than limit: " <> show mhbSize identity -= biSize musthaveBlock + sv = curSoftwareVersion + bv = lastKnownBlockVersion ---------------------------------------------------------------------------- -- MainBlock apply @@ -335,25 +347,27 @@ applyCreatedBlock :: ( MonadBlockApply ctx m , MonadCreateBlock ctx m ) - => ProxySKBlockInfo + => ProtocolMagic + -> ProxySKBlockInfo -> MainBlock -> m MainBlock -applyCreatedBlock pske createdBlock = applyCreatedBlockDo False createdBlock +applyCreatedBlock pm pske createdBlock = applyCreatedBlockDo False createdBlock where slotId = createdBlock ^. BC.mainBlockSlot applyCreatedBlockDo :: Bool -> MainBlock -> m MainBlock applyCreatedBlockDo isFallback blockToApply = - verifyBlocksPrefix (one (Right blockToApply)) >>= \case + verifyBlocksPrefix pm (one (Right blockToApply)) >>= \case Left (pretty -> reason) | isFallback -> onFailedFallback reason | otherwise -> fallback reason Right (undos, pollModifier) -> do let undo = undos ^. _Wrapped . _neHead applyBlocksUnsafe + pm (ShouldCallBListener True) (one (Right blockToApply, undo)) (Just pollModifier) - normalizeMempool + normalizeMempool pm pure blockToApply clearMempools :: m () clearMempools = do @@ -369,7 +383,7 @@ applyCreatedBlock pske createdBlock = applyCreatedBlockDo False createdBlock logDebug $ "Clearing mempools" clearMempools logDebug $ "Creating empty block" - createMainBlockInternal slotId pske >>= \case + createMainBlockInternal pm slotId pske >>= \case Left err -> assertionFailed $ sformat ("Couldn't create a block in fallback: "%stext) err @@ -390,8 +404,7 @@ data RawPayload = RawPayload , rpUpdate :: !UpdatePayload } -getRawPayload :: - forall ctx m. (MonadCreateBlock ctx m) +getRawPayload :: MonadCreateBlock ctx m => HeaderHash -> SlotId -> m RawPayload @@ -416,7 +429,7 @@ getRawPayload tip slotId = do -- Given limit applies only to body, not to other data from block. createMainBody :: forall m . - (MonadError Text m, HasConfiguration) + ( MonadError Text m, HasProtocolConstants ) => Byte -- ^ Body limit -> SlotId -> RawPayload diff --git a/block/src/Pos/Block/Logic/Header.hs b/block/src/Pos/Block/Logic/Header.hs index 273bb30cd60..9e923c49a70 100644 --- a/block/src/Pos/Block/Logic/Header.hs +++ b/block/src/Pos/Block/Logic/Header.hs @@ -16,12 +16,13 @@ module Pos.Block.Logic.Header , getHashesRange ) where -import Universum -import Unsafe (unsafeLast) +import Universum hiding (elems) import Control.Lens (to) import Control.Monad.Except (MonadError (throwError)) import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT) +import qualified Data.List as List (last) +import qualified Data.List.NonEmpty as NE (toList) import qualified Data.Text as T import Formatting (build, int, sformat, (%)) import Serokell.Util.Text (listJson) @@ -31,25 +32,24 @@ import UnliftIO (MonadUnliftIO) import Pos.Block.Logic.Integrity (VerifyHeaderParams (..), verifyHeader, verifyHeaders) import Pos.Block.Logic.Util (lcaWithMainChain) -import Pos.Core (BlockCount, EpochOrSlot (..), HasConfiguration, HeaderHash, SlotId (..), - blkSecurityParam, bvdMaxHeaderSize, difficultyL, epochIndexL, - epochOrSlotG, getChainDifficulty, getEpochOrSlot, headerHash, - headerHashG, headerSlotL, prevBlockL) +import Pos.Core (BlockCount, EpochOrSlot (..), HeaderHash, SlotId (..), blkSecurityParam, + bvdMaxHeaderSize, difficultyL, epochIndexL, epochOrSlotG, + getChainDifficulty, getEpochOrSlot, headerHash, headerHashG, headerSlotL, + prevBlockL) import Pos.Core.Block (BlockHeader (..)) -import Pos.Crypto (hash) +import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..), toNewestFirst, + toOldestFirst, _NewestFirst, _OldestFirst) +import Pos.Crypto (ProtocolMagic, hash) import Pos.DB (MonadDBRead) import qualified Pos.DB.Block.Load as DB import qualified Pos.DB.BlockIndex as DB import qualified Pos.DB.GState.Common as GS (getTip) import Pos.Delegation.Cede (dlgVerifyHeader, runDBCede) import qualified Pos.GState.BlockExtra as GS -import Pos.Lrc.Context (HasLrcContext) +import Pos.Infra.Slotting.Class (MonadSlots (getCurrentSlot)) import qualified Pos.Lrc.DB as LrcDB -import Pos.Slotting.Class (MonadSlots (getCurrentSlot)) import qualified Pos.Update.DB as GS (getAdoptedBVFull) import Pos.Util (buildListBounds, _neHead, _neLast) -import Pos.Util.Chrono (NE, NewestFirst (..), OldestFirst (..), toNewestFirst, - toOldestFirst, _NewestFirst, _OldestFirst) -- | Result of single (new) header classification. data ClassifyHeaderRes @@ -76,17 +76,14 @@ mkCHRinvalid = CHInvalid . T.intercalate "; " -- as ClassifyHeaderRes type. classifyNewHeader :: forall ctx m. - ( HasConfiguration - , MonadSlots ctx m + ( MonadSlots ctx m , MonadDBRead m , MonadUnliftIO m - , MonadSlots ctx m - , HasLrcContext ctx ) - => BlockHeader -> m ClassifyHeaderRes + => ProtocolMagic -> BlockHeader -> m ClassifyHeaderRes -- Genesis headers seem useless, we can create them by ourselves. -classifyNewHeader (BlockHeaderGenesis _) = pure $ CHUseless "genesis header is useless" -classifyNewHeader (BlockHeaderMain header) = fmap (either identity identity) <$> runExceptT $ do +classifyNewHeader _ (BlockHeaderGenesis _) = pure $ CHUseless "genesis header is useless" +classifyNewHeader pm (BlockHeaderMain header) = fmap (either identity identity) <$> runExceptT $ do curSlot <- getCurrentSlot tipHeader <- lift DB.getTipHeader let tipEoS = getEpochOrSlot tipHeader @@ -129,8 +126,8 @@ classifyNewHeader (BlockHeaderMain header) = fmap (either identity identity) <$> , vhpMaxSize = Just maxBlockHeaderSize , vhpVerifyNoUnknown = False } - case verifyHeader vhp (BlockHeaderMain header) of - VerFailure errors -> throwError $ mkCHRinvalid errors + case verifyHeader pm vhp (BlockHeaderMain header) of + VerFailure errors -> throwError $ mkCHRinvalid (NE.toList errors) _ -> pass dlgHeaderValid <- lift $ runDBCede $ dlgVerifyHeader header @@ -153,7 +150,7 @@ data ClassifyHeadersRes | CHsUseless !Text -- ^ Header is useless. | CHsInvalid !Text -- ^ Header is invalid. -deriving instance Show BlockHeader => Show ClassifyHeadersRes +deriving instance Show ClassifyHeadersRes -- | Classify headers received in response to 'GetHeaders' message. -- @@ -168,23 +165,21 @@ deriving instance Show BlockHeader => Show ClassifyHeadersRes classifyHeaders :: forall ctx m. ( MonadDBRead m - , MonadCatch m - , HasLrcContext ctx , MonadSlots ctx m , WithLogger m - , HasConfiguration ) - => Bool -- recovery in progress? + => ProtocolMagic + -> Bool -- recovery in progress? -> NewestFirst NE BlockHeader -> m ClassifyHeadersRes -classifyHeaders inRecovery headers = do +classifyHeaders pm inRecovery headers = do tipHeader <- DB.getTipHeader let tip = headerHash tipHeader haveOldestParent <- isJust <$> DB.getHeader oldestParentHash leaders <- LrcDB.getLeadersForEpoch oldestHeaderEpoch let headersValid = isVerSuccess $ - verifyHeaders leaders (headers & _NewestFirst %~ toList) + verifyHeaders pm leaders (headers & _NewestFirst %~ toList) mbCurrentSlot <- getCurrentSlot let newestHeaderConvertedSlot = case newestHeader ^. epochOrSlotG of @@ -260,7 +255,6 @@ data GetHeadersFromManyToError = GHFBadInput Text deriving (Show,Generic) getHeadersFromManyTo :: ( MonadDBRead m , WithLogger m - , HasConfiguration ) => Maybe Word -- ^ Optional limit on how many to bring in. -> NonEmpty HeaderHash -- ^ Checkpoints; not guaranteed to be @@ -278,6 +272,8 @@ getHeadersFromManyTo mLimit checkpoints startM = runExceptT $ do -- This filters out invalid/unknown checkpoints also. inMainCheckpoints <- maybe (throwLocal "no checkpoints are in the main chain") pure =<< + -- FIXME wasteful. If we mandated an order on the checkpoints we + -- wouldn't have to check them all. lift (nonEmpty <$> filterM GS.isBlockInMainChain (toList checkpoints)) let inMainCheckpointsHashes = map headerHash inMainCheckpoints when (tipHash `elem` inMainCheckpointsHashes) $ @@ -313,7 +309,7 @@ getHeadersFromManyTo mLimit checkpoints startM = runExceptT $ do -- it returns not more than 'blkSecurityParam' blocks distributed -- exponentially base 2 relatively to the depth in the blockchain. getHeadersOlderExp - :: (HasConfiguration, MonadDBRead m) + :: MonadDBRead m => Maybe HeaderHash -> m (OldestFirst NE HeaderHash) getHeadersOlderExp upto = do tip <- GS.getTip @@ -375,7 +371,7 @@ throwGHR = throwError . GHRBadInput -- of headers in the chain (which should be returned) is more than -- @depthLimit@, error will be thrown. getHashesRange :: - forall m. (HasConfiguration, MonadDBRead m) + forall m. (MonadDBRead m) => Maybe Word -> HeaderHash -> HeaderHash @@ -447,7 +443,7 @@ getHashesRange depthLimitM older newer = runExceptT $ do "May be (very rare) concurrency problem, just retry" -- It's safe to use 'unsafeLast' here after the last check. - let lastElem = allExceptNewest ^. _OldestFirst . to unsafeLast + let lastElem = allExceptNewest ^. _OldestFirst . to List.last when (newerHd ^. prevBlockL . headerHashG /= lastElem) $ throwGHR $ sformat ("getHashesRange: newest block parent is not "% diff --git a/block/src/Pos/Block/Logic/Integrity.hs b/block/src/Pos/Block/Logic/Integrity.hs index f355559852d..f72eb9a2783 100644 --- a/block/src/Pos/Block/Logic/Integrity.hs +++ b/block/src/Pos/Block/Logic/Integrity.hs @@ -27,15 +27,16 @@ import qualified Pos.Binary.Class as Bi import Pos.Binary.Core () import Pos.Binary.Update () import qualified Pos.Block.BHelpers as BHelpers -import Pos.Core (BlockVersionData (..), ChainDifficulty, EpochOrSlot, HasConfiguration, - HasDifficulty (..), HasEpochIndex (..), HasEpochOrSlot (..), - HasHeaderHash (..), HeaderHash, SlotId (..), SlotLeaders, addressHash, +import Pos.Core (BlockVersionData (..), ChainDifficulty, EpochOrSlot, HasDifficulty (..), + HasEpochIndex (..), HasEpochOrSlot (..), HasHeaderHash (..), + HasProtocolConstants, HeaderHash, SlotId (..), SlotLeaders, addressHash, gbExtra, gbhExtra, getSlotIndex, headerSlotL, prevBlockL) -import Pos.Core.Block (Block, BlockHeader (..), gebAttributes, gehAttributes, - genBlockLeaders, getBlockHeader, mainHeaderLeaderKey, - mebAttributes, mehAttributes) +import Pos.Core.Block (Block, BlockHeader (..), blockHeaderProtocolMagic, gebAttributes, + gehAttributes, genBlockLeaders, getBlockHeader, + mainHeaderLeaderKey, mebAttributes, mehAttributes) +import Pos.Core.Chrono (NewestFirst (..), OldestFirst) +import Pos.Crypto (ProtocolMagic (getProtocolMagic)) import Pos.Data.Attributes (areAttributesKnown) -import Pos.Util.Chrono (NewestFirst (..), OldestFirst) ---------------------------------------------------------------------------- -- Header @@ -61,8 +62,8 @@ data VerifyHeaderParams = VerifyHeaderParams } deriving (Eq, Show) verifyFromEither :: Text -> Either Text b -> VerificationRes -verifyFromEither txt (Left reason) = verifyGeneric [(False, txt <> ": " <> reason)] -verifyFromEither txt (Right _) = verifyGeneric [(True, txt)] +verifyFromEither txt (Left reason) = verifyGeneric [(False, txt <> ": " <> reason)] +verifyFromEither txt (Right _) = verifyGeneric [(True, txt)] -- CHECK: @verifyHeader -- | Check some predicates (determined by 'VerifyHeaderParams') about @@ -83,15 +84,15 @@ verifyFromEither txt (Right _) = verifyGeneric [(True, txt)] -- 4. Header size does not exceed `bvdMaxHeaderSize`. -- 5. (Optional) Header has no unknown attributes. verifyHeader - :: HasConfiguration - => VerifyHeaderParams -> BlockHeader -> VerificationRes -verifyHeader VerifyHeaderParams {..} h = - verifyFromEither "internal header consistency" (BHelpers.verifyBlockHeader h) + :: ProtocolMagic -> VerifyHeaderParams -> BlockHeader -> VerificationRes +verifyHeader pm VerifyHeaderParams {..} h = + verifyFromEither "internal header consistency" (BHelpers.verifyBlockHeader pm h) <> verifyGeneric checks where checks = mconcat - [ maybe mempty relatedToPrevHeader vhpPrevHeader + [ checkProtocolMagic + , maybe mempty relatedToPrevHeader vhpPrevHeader , maybe mempty relatedToCurrentSlot vhpCurrentSlot , maybe mempty relatedToLeaders vhpLeaders , checkSize @@ -123,9 +124,18 @@ verifyHeader VerifyHeaderParams {..} h = ("two adjacent blocks are from different epochs ("%build%" != "%build%")") oldEpoch newEpoch ) + checkProtocolMagic = + [ ( pm == blockHeaderProtocolMagic h + , sformat + ("protocol magic number mismatch: got "%int%" but expected "%int) + (getProtocolMagic (blockHeaderProtocolMagic h)) + (getProtocolMagic pm) + ) + ] checkSize = case vhpMaxSize of Nothing -> mempty + -- FIXME do not use 'biSize'! It's expensive. Just maxSize -> [ ( Bi.biSize h <= maxSize , sformat @@ -189,12 +199,12 @@ verifyHeader VerifyHeaderParams {..} h = -- | Verifies a set of block headers. Only basic consensus check and -- linking checks are performed! verifyHeaders :: - HasConfiguration - => Maybe SlotLeaders + ProtocolMagic + -> Maybe SlotLeaders -> NewestFirst [] BlockHeader -> VerificationRes -verifyHeaders _ (NewestFirst []) = mempty -verifyHeaders leaders (NewestFirst (headers@(_:xh))) = +verifyHeaders _ _ (NewestFirst []) = mempty +verifyHeaders pm leaders (NewestFirst (headers@(_:xh))) = snd $ foldr foldFoo (leaders,mempty) $ headers `zip` (map Just xh ++ [Nothing]) where @@ -204,7 +214,7 @@ verifyHeaders leaders (NewestFirst (headers@(_:xh))) = BlockHeaderGenesis _ -> Nothing _ -> prevLeaders - in (curLeaders, verifyHeader (toVHP curLeaders prev) cur <> res) + in (curLeaders, verifyHeader pm (toVHP curLeaders prev) cur <> res) toVHP l p = VerifyHeaderParams { vhpPrevHeader = p @@ -242,11 +252,14 @@ data VerifyBlockParams = VerifyBlockParams -- 2. The size of each block does not exceed `bvdMaxBlockSize`. -- 3. (Optional) No block has any unknown attributes. verifyBlock - :: HasConfiguration - => VerifyBlockParams -> Block -> VerificationRes -verifyBlock VerifyBlockParams {..} blk = mconcat - [ verifyFromEither "internal block consistency" (BHelpers.verifyBlock blk) - , verifyHeader vbpVerifyHeader (getBlockHeader blk) + :: HasProtocolConstants + => ProtocolMagic + -> VerifyBlockParams + -> Block + -> VerificationRes +verifyBlock pm VerifyBlockParams {..} blk = mconcat + [ verifyFromEither "internal block consistency" (BHelpers.verifyBlock pm blk) + , verifyHeader pm vbpVerifyHeader (getBlockHeader blk) , checkSize vbpMaxSize , bool mempty (verifyNoUnknown blk) vbpVerifyNoUnknown ] @@ -288,17 +301,15 @@ type VerifyBlocksIter = (SlotLeaders, Maybe BlockHeader, VerificationRes) -- laziness of 'VerificationRes' which is good because laziness for this data -- type is crucial. verifyBlocks - :: ( t ~ OldestFirst f Block - , NontrivialContainer t - , HasConfiguration - ) - => Maybe SlotId + :: HasProtocolConstants + => ProtocolMagic + -> Maybe SlotId -> Bool -> BlockVersionData -> SlotLeaders - -> OldestFirst f Block + -> OldestFirst [] Block -> VerificationRes -verifyBlocks curSlotId verifyNoUnknown bvd initLeaders = view _3 . foldl' step start +verifyBlocks pm curSlotId verifyNoUnknown bvd initLeaders = view _3 . foldl' step start where start :: VerifyBlocksIter -- Note that here we never know previous header before this @@ -327,4 +338,4 @@ verifyBlocks curSlotId verifyNoUnknown bvd initLeaders = view _3 . foldl' step s , vbpMaxSize = bvdMaxBlockSize bvd , vbpVerifyNoUnknown = verifyNoUnknown } - in (newLeaders, Just $ getBlockHeader blk, res <> verifyBlock vbp blk) + in (newLeaders, Just $ getBlockHeader blk, res <> verifyBlock pm vbp blk) diff --git a/block/src/Pos/Block/Logic/Internal.hs b/block/src/Pos/Block/Logic/Internal.hs index 06a4ec24a92..4a4a1baa13e 100644 --- a/block/src/Pos/Block/Logic/Internal.hs +++ b/block/src/Pos/Block/Logic/Internal.hs @@ -37,10 +37,12 @@ import Pos.Block.BListener (MonadBListener) import Pos.Block.Slog (BypassSecurityCheck (..), MonadSlogApply, MonadSlogBase, ShouldCallBListener, slogApplyBlocks, slogRollbackBlocks) import Pos.Block.Types (Blund, Undo (undoDlg, undoTx, undoUS)) -import Pos.Core (ComponentBlock (..), HasConfiguration, IsGenesisHeader, epochIndexL, - gbHeader, headerHash, mainBlockDlgPayload, mainBlockSscPayload, - mainBlockTxPayload, mainBlockUpdatePayload) +import Pos.Core (ComponentBlock (..), IsGenesisHeader, epochIndexL, gbHeader, headerHash, + mainBlockDlgPayload, mainBlockSscPayload, mainBlockTxPayload, + mainBlockUpdatePayload) import Pos.Core.Block (Block, GenesisBlock, MainBlock) +import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..)) +import Pos.Crypto (ProtocolMagic) import Pos.DB (MonadDB, MonadDBRead, MonadGState, SomeBatchOp (..)) import qualified Pos.DB.GState.Common as GS (writeBatchGState) import Pos.Delegation.Class (MonadDelegation) @@ -48,12 +50,13 @@ import Pos.Delegation.Logic (dlgApplyBlocks, dlgNormalizeOnRollback, d import Pos.Delegation.Types (DlgBlock, DlgBlund) import Pos.Exception (assertionFailed) import Pos.GState.SanityCheck (sanityCheckDB) +import Pos.Infra.Reporting (MonadReporting) import Pos.Lrc.Context (HasLrcContext) -import Pos.Reporting (MonadReporting) import Pos.Ssc.Configuration (HasSscConfiguration) import Pos.Ssc.Logic (sscApplyBlocks, sscNormalize, sscRollbackBlocks) import Pos.Ssc.Mem (MonadSscMem) import Pos.Ssc.Types (SscBlock) +import Pos.Txp.Configuration (HasTxpConfiguration) import Pos.Txp.MemState (MonadTxpLocal (..)) import Pos.Txp.Settings (TxpBlock, TxpBlund, TxpGlobalSettings (..)) import Pos.Update (UpdateBlock) @@ -61,7 +64,6 @@ import Pos.Update.Context (UpdateContext) import Pos.Update.Logic (usApplyBlocks, usNormalize, usRollbackBlocks) import Pos.Update.Poll (PollModifier) import Pos.Util (Some (..), spanSafe) -import Pos.Util.Chrono (NE, NewestFirst (..), OldestFirst (..)) import Pos.Util.Util (HasLens', lensOf) -- | Set of basic constraints used by high-level block processing. @@ -81,7 +83,7 @@ type MonadBlockBase ctx m -- 'MonadRandom' for crypto. , Rand.MonadRandom m -- To report bad things. - , MonadReporting ctx m + , MonadReporting m , HasSscConfiguration ) @@ -115,7 +117,7 @@ type MonadMempoolNormalization ctx m , MonadDBRead m , MonadGState m -- Needed for error reporting. - , MonadReporting ctx m + , MonadReporting m -- 'MonadRandom' for crypto. , Rand.MonadRandom m , Mockable CurrentTime m @@ -123,15 +125,13 @@ type MonadMempoolNormalization ctx m ) -- | Normalize mempool. -normalizeMempool - :: forall ctx m . (MonadMempoolNormalization ctx m) - => m () -normalizeMempool = do +normalizeMempool :: MonadMempoolNormalization ctx m => ProtocolMagic -> m () +normalizeMempool pm = do -- We normalize all mempools except the delegation one. -- That's because delegation mempool normalization is harder and is done -- within block application. - sscNormalize - txpNormalize + sscNormalize pm + txpNormalize pm usNormalize -- | Applies a definitely valid prefix of blocks. This function is unsafe, @@ -140,12 +140,15 @@ normalizeMempool = do -- -- Invariant: all blocks have the same epoch. applyBlocksUnsafe - :: forall ctx m . (MonadBlockApply ctx m) - => ShouldCallBListener + :: ( MonadBlockApply ctx m + , HasTxpConfiguration + ) + => ProtocolMagic + -> ShouldCallBListener -> OldestFirst NE Blund -> Maybe PollModifier -> m () -applyBlocksUnsafe scb blunds pModifier = do +applyBlocksUnsafe pm scb blunds pModifier = do -- Check that all blunds have the same epoch. unless (null nextEpoch) $ assertionFailed $ sformat ("applyBlocksUnsafe: tried to apply more than we should"% @@ -165,29 +168,32 @@ applyBlocksUnsafe scb blunds pModifier = do (b@(Left _,_):|(x:xs)) -> app' (b:|[]) >> app' (x:|xs) _ -> app blunds where - app x = applyBlocksDbUnsafeDo scb x pModifier + app x = applyBlocksDbUnsafeDo pm scb x pModifier app' = app . OldestFirst (thisEpoch, nextEpoch) = spanSafe ((==) `on` view (_1 . epochIndexL)) $ getOldestFirst blunds applyBlocksDbUnsafeDo - :: forall ctx m . (MonadBlockApply ctx m) - => ShouldCallBListener + :: ( MonadBlockApply ctx m + , HasTxpConfiguration + ) + => ProtocolMagic + -> ShouldCallBListener -> OldestFirst NE Blund -> Maybe PollModifier -> m () -applyBlocksDbUnsafeDo scb blunds pModifier = do +applyBlocksDbUnsafeDo pm scb blunds pModifier = do let blocks = fmap fst blunds -- Note: it's important to do 'slogApplyBlocks' first, because it -- puts blocks in DB. slogBatch <- slogApplyBlocks scb blunds TxpGlobalSettings {..} <- view (lensOf @TxpGlobalSettings) - usBatch <- SomeBatchOp <$> usApplyBlocks (map toUpdateBlock blocks) pModifier + usBatch <- SomeBatchOp <$> usApplyBlocks pm (map toUpdateBlock blocks) pModifier delegateBatch <- SomeBatchOp <$> dlgApplyBlocks (map toDlgBlund blunds) txpBatch <- tgsApplyBlocks $ map toTxpBlund blunds sscBatch <- SomeBatchOp <$> -- TODO: pass not only 'Nothing' - sscApplyBlocks (map toSscBlock blocks) Nothing + sscApplyBlocks pm (map toSscBlock blocks) Nothing GS.writeBatchGState [ delegateBatch , usBatch @@ -200,12 +206,13 @@ applyBlocksDbUnsafeDo scb blunds pModifier = do -- | Rollback sequence of blocks, head-newest order expected with head being -- current tip. It's also assumed that lock on block db is taken already. rollbackBlocksUnsafe - :: forall ctx m. (MonadBlockApply ctx m) - => BypassSecurityCheck -- ^ is rollback for more than k blocks allowed? + :: MonadBlockApply ctx m + => ProtocolMagic + -> BypassSecurityCheck -- ^ is rollback for more than k blocks allowed? -> ShouldCallBListener -> NewestFirst NE Blund -> m () -rollbackBlocksUnsafe bsc scb toRollback = do +rollbackBlocksUnsafe pm bsc scb toRollback = do slogRoll <- slogRollbackBlocks bsc scb toRollback dlgRoll <- SomeBatchOp <$> dlgRollbackBlocks (map toDlgBlund toRollback) usRoll <- SomeBatchOp <$> usRollbackBlocks @@ -227,44 +234,32 @@ rollbackBlocksUnsafe bsc scb toRollback = do -- We don't normalize other mempools, because they are normalized -- in 'applyBlocksUnsafe' and we always ensure that some blocks -- are applied after rollback. - dlgNormalizeOnRollback + dlgNormalizeOnRollback pm sanityCheckDB -toComponentBlock :: HasConfiguration => (MainBlock -> payload) -> Block -> ComponentBlock payload +toComponentBlock :: (MainBlock -> payload) -> Block -> ComponentBlock payload toComponentBlock fnc block = case block of Left genBlock -> ComponentBlockGenesis (convertGenesis genBlock) Right mainBlock -> ComponentBlockMain (Some $ mainBlock ^. gbHeader) (fnc mainBlock) -toTxpBlock - :: HasConfiguration - => Block -> TxpBlock +toTxpBlock :: Block -> TxpBlock toTxpBlock = toComponentBlock (view mainBlockTxPayload) -toUpdateBlock - :: HasConfiguration - => Block -> UpdateBlock +toUpdateBlock :: Block -> UpdateBlock toUpdateBlock = toComponentBlock (view mainBlockUpdatePayload) -toTxpBlund - :: HasConfiguration - => Blund -> TxpBlund +toTxpBlund :: Blund -> TxpBlund toTxpBlund = bimap toTxpBlock undoTx -toSscBlock - :: HasConfiguration - => Block -> SscBlock +toSscBlock :: Block -> SscBlock toSscBlock = toComponentBlock (view mainBlockSscPayload) -toDlgBlund - :: HasConfiguration - => Blund -> DlgBlund +toDlgBlund :: Blund -> DlgBlund toDlgBlund = bimap toDlgBlock undoDlg where - toDlgBlock - :: HasConfiguration - => Block -> DlgBlock + toDlgBlock :: Block -> DlgBlock toDlgBlock = toComponentBlock (view mainBlockDlgPayload) -convertGenesis :: HasConfiguration => GenesisBlock -> Some IsGenesisHeader +convertGenesis :: GenesisBlock -> Some IsGenesisHeader convertGenesis = Some . view gbHeader diff --git a/block/src/Pos/Block/Logic/Util.hs b/block/src/Pos/Block/Logic/Util.hs index c8fa752a627..533ce000410 100644 --- a/block/src/Pos/Block/Logic/Util.hs +++ b/block/src/Pos/Block/Logic/Util.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} -- | Utilities for finding LCA and calculating chain quality. @@ -7,6 +8,7 @@ module Pos.Block.Logic.Util ( -- * Common/Utils lcaWithMainChain + , lcaWithMainChainSuffix , calcChainQuality , calcChainQualityM , calcOverallChainQuality @@ -25,17 +27,18 @@ import System.Wlog (WithLogger) import Pos.Block.Configuration (HasBlockConfiguration, fixedTimeCQ) import Pos.Block.Slog.Context (slogGetLastSlots) import Pos.Block.Slog.Types (HasSlogGState) -import Pos.Core (BlockCount, FlatSlotId, HeaderHash, Timestamp (..), difficultyL, - flattenSlotId, headerHash, prevBlockL) +import Pos.Core (BlockCount, FlatSlotId, HasProtocolConstants, HeaderHash, Timestamp (..), + difficultyL, flattenSlotId, headerHash, prevBlockL) import Pos.Core.Block (BlockHeader) -import Pos.Core.Configuration (HasConfiguration, blkSecurityParam) +import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..)) +import Pos.Core.Configuration (blkSecurityParam) import qualified Pos.DB.BlockIndex as DB import Pos.DB.Class (MonadBlockDBRead) import Pos.Exception (reportFatalError) import Pos.GState.BlockExtra (isBlockInMainChain) -import Pos.Slotting (MonadSlots (..), getCurrentSlotFlat, slotFromTimestamp) +import Pos.Infra.Slotting (MonadSlots (..), getCurrentSlotFlat, + slotFromTimestamp) import Pos.Util (_neHead) -import Pos.Util.Chrono (NE, OldestFirst (..)) -- | Find LCA of headers list and main chain, including oldest -- header's parent hash. Acts as it would iterate from newest to @@ -45,7 +48,7 @@ import Pos.Util.Chrono (NE, OldestFirst (..)) -- Though, usually in this method oldest header is LCA, so it can be -- optimized by traversing from older to newer. lcaWithMainChain - :: (HasConfiguration, MonadBlockDBRead m) + :: ( MonadBlockDBRead m ) => OldestFirst NE BlockHeader -> m (Maybe HeaderHash) lcaWithMainChain headers = lcaProceed Nothing $ @@ -60,6 +63,27 @@ lcaWithMainChain headers = ([], True) -> pure $ Just h (x:xs, True) -> lcaProceed (Just h) (x :| xs) +-- | Split the input list into those which are in the main chain (given by the +-- 'MonadBlockDBRead' constraint), and those which are not. Those in the +-- chain are given NewestFirst. +lcaWithMainChainSuffix + :: forall m . + (MonadBlockDBRead m) + => OldestFirst [] HeaderHash + -> m (NewestFirst [] HeaderHash, OldestFirst [] HeaderHash) +lcaWithMainChainSuffix headers = go [] (getOldestFirst headers) + where + go :: [HeaderHash] + -> [HeaderHash] + -> m (NewestFirst [] HeaderHash, OldestFirst [] HeaderHash) + -- Everything is in the chain. + go !acc [] = pure (NewestFirst acc, OldestFirst []) + go !acc (hh:rest) = do + inMain <- isBlockInMainChain hh + case inMain of + False -> pure (NewestFirst acc, OldestFirst (hh : rest)) + True -> go (hh:acc) rest + -- | Calculate chain quality using slot of the block which has depth = -- 'blocksCount' and another slot after that one for which we -- want to know chain quality. @@ -82,7 +106,7 @@ calcChainQualityM :: , MonadThrow m , WithLogger m , Fractional res - , HasConfiguration + , HasProtocolConstants ) => FlatSlotId -> m (Maybe res) @@ -108,7 +132,7 @@ calcChainQualityM newSlot = do -- slot is unknown. calcOverallChainQuality :: forall ctx m res. - (Fractional res, MonadSlots ctx m, MonadBlockDBRead m, HasConfiguration) + (Fractional res, MonadSlots ctx m, MonadBlockDBRead m) => m (Maybe res) calcOverallChainQuality = getCurrentSlotFlat >>= \case @@ -137,9 +161,9 @@ calcChainQualityFixedTime :: forall ctx m res. ( Fractional res , MonadSlots ctx m - , HasConfiguration , HasBlockConfiguration , HasSlogGState ctx + , HasProtocolConstants ) => m (Maybe res) calcChainQualityFixedTime = do @@ -161,7 +185,7 @@ calcChainQualityFixedTime = do calcChainQualityFixedTimeDo olderSlotId currentSlotId (OldestFirst lastSlots) = case findIndex (>= olderSlotId) lastSlots of Just firstNew - | firstNew > 0 || head lastSlots == Just olderSlotId -> + | firstNew > 0 || fmap fst (uncons lastSlots) == Just olderSlotId -> let blockCount = fromIntegral (length lastSlots - firstNew) in calcChainQuality blockCount olderSlotId currentSlotId -- All slots are less than 'olderSlotId', something is bad. diff --git a/block/src/Pos/Block/Logic/VAR.hs b/block/src/Pos/Block/Logic/VAR.hs index 49235f5f207..6a4c99c2846 100644 --- a/block/src/Pos/Block/Logic/VAR.hs +++ b/block/src/Pos/Block/Logic/VAR.hs @@ -29,20 +29,23 @@ import Pos.Block.Logic.Internal (BypassSecurityCheck (..), MonadBlockA applyBlocksUnsafe, normalizeMempool, rollbackBlocksUnsafe, toSscBlock, toTxpBlock, toUpdateBlock) +import Pos.Block.Lrc (LrcModeFull, lrcSingleShot) import Pos.Block.Slog (ShouldCallBListener (..), mustDataBeKnown, slogVerifyBlocks) import Pos.Block.Types (Blund, Undo (..)) import Pos.Core (Block, HeaderHash, epochIndexL, headerHashG, prevBlockL) +import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..), toNewestFirst, + toOldestFirst) +import Pos.Crypto (ProtocolMagic) import qualified Pos.DB.GState.Common as GS (getTip) import Pos.Delegation.Logic (dlgVerifyBlocks) -import Pos.Lrc.Worker (LrcModeFull, lrcSingleShot) +import Pos.Infra.Reporting (HasMisbehaviorMetrics) +import Pos.Txp.Configuration (HasTxpConfiguration) import Pos.Ssc.Logic (sscVerifyBlocks) import Pos.Txp.Settings (TxpGlobalSettings (TxpGlobalSettings, tgsVerifyBlocks)) import qualified Pos.Update.DB as GS (getAdoptedBV) import Pos.Update.Logic (usVerifyBlocks) import Pos.Update.Poll (PollModifier) import Pos.Util (neZipWith4, spanSafe, _neHead) -import Pos.Util.Chrono (NE, NewestFirst (..), OldestFirst (..), toNewestFirst, - toOldestFirst) import Pos.Util.Util (HasLens (..)) -- -- CHECK: @verifyBlocksLogic @@ -65,10 +68,13 @@ import Pos.Util.Util (HasLens (..)) -- 4. Return all undos. verifyBlocksPrefix :: forall ctx m. - (MonadBlockVerify ctx m) - => OldestFirst NE Block + ( HasTxpConfiguration + , MonadBlockVerify ctx m + ) + => ProtocolMagic + -> OldestFirst NE Block -> m (Either VerifyBlocksException (OldestFirst NE Undo, PollModifier)) -verifyBlocksPrefix blocks = runExceptT $ do +verifyBlocksPrefix pm blocks = runExceptT $ do -- This check (about tip) is here just in case, we actually check -- it before calling this function. tip <- lift GS.getTip @@ -84,15 +90,15 @@ verifyBlocksPrefix blocks = runExceptT $ do -- the internal consistency checks formerly done in the 'Bi' instance -- 'decode'. slogUndos <- withExceptT VerifyBlocksError $ - ExceptT $ slogVerifyBlocks blocks + ExceptT $ slogVerifyBlocks pm blocks _ <- withExceptT (VerifyBlocksError . pretty) $ - ExceptT $ sscVerifyBlocks (map toSscBlock blocks) + ExceptT $ sscVerifyBlocks pm (map toSscBlock blocks) TxpGlobalSettings {..} <- view (lensOf @TxpGlobalSettings) txUndo <- withExceptT (VerifyBlocksError . pretty) $ ExceptT $ tgsVerifyBlocks dataMustBeKnown $ map toTxpBlock blocks - pskUndo <- withExceptT VerifyBlocksError $ dlgVerifyBlocks blocks + pskUndo <- withExceptT VerifyBlocksError $ dlgVerifyBlocks pm blocks (pModifier, usUndos) <- withExceptT (VerifyBlocksError . pretty) $ - ExceptT $ usVerifyBlocks dataMustBeKnown (map toUpdateBlock blocks) + ExceptT $ usVerifyBlocks pm dataMustBeKnown (map toUpdateBlock blocks) -- Eventually we do a sanity check just in case and return the result. when (length txUndo /= length pskUndo) $ @@ -119,15 +125,22 @@ type BlockLrcMode ctx m = (MonadBlockApply ctx m, LrcModeFull ctx m) -- return the header hash of the new tip. It's up to the caller to log a -- warning that partial application has occurred. verifyAndApplyBlocks - :: forall ctx m. (BlockLrcMode ctx m, MonadMempoolNormalization ctx m) - => Bool -> OldestFirst NE Block -> m (Either ApplyBlocksException HeaderHash) -verifyAndApplyBlocks rollback blocks = runExceptT $ do + :: forall ctx m. + ( BlockLrcMode ctx m + , MonadMempoolNormalization ctx m + , HasMisbehaviorMetrics ctx + ) + => ProtocolMagic + -> Bool + -> OldestFirst NE Block + -> m (Either ApplyBlocksException HeaderHash) +verifyAndApplyBlocks pm rollback blocks = runExceptT $ do tip <- lift GS.getTip let assumedTip = blocks ^. _Wrapped . _neHead . prevBlockL when (tip /= assumedTip) $ throwError $ ApplyBlocksTipMismatch "verify and apply" tip assumedTip hh <- rollingVerifyAndApply [] (spanEpoch blocks) - lift $ normalizeMempool + lift $ normalizeMempool pm pure hh where -- Spans input into @(a, b)@ where @a@ is either a single genesis @@ -150,11 +163,11 @@ verifyAndApplyBlocks rollback blocks = runExceptT $ do applyAMAP e (OldestFirst []) True = throwError e applyAMAP _ (OldestFirst []) False = lift GS.getTip applyAMAP e (OldestFirst (block:xs)) nothingApplied = - lift (verifyBlocksPrefix (one block)) >>= \case + lift (verifyBlocksPrefix pm (one block)) >>= \case Left (ApplyBlocksVerifyFailure -> e') -> applyAMAP e' (OldestFirst []) nothingApplied Right (OldestFirst (undo :| []), pModifier) -> do - lift $ applyBlocksUnsafe (ShouldCallBListener True) (one (block, undo)) (Just pModifier) + lift $ applyBlocksUnsafe pm (ShouldCallBListener True) (one (block, undo)) (Just pModifier) applyAMAP e (OldestFirst xs) False Right _ -> error "verifyAndApplyBlocksInternal: applyAMAP: \ \verification of one block produced more than one undo" @@ -165,7 +178,7 @@ verifyAndApplyBlocks rollback blocks = runExceptT $ do -> ExceptT ApplyBlocksException m HeaderHash failWithRollback e toRollback = do logDebug "verifyAndapply failed, rolling back" - lift $ mapM_ rollbackBlocks toRollback + lift $ mapM_ (rollbackBlocks pm) toRollback throwError e -- This function tries to apply a new portion of blocks (prefix -- and suffix). It also has an aggregating parameter @blunds@ which is @@ -183,9 +196,9 @@ verifyAndApplyBlocks rollback blocks = runExceptT $ do let epochIndex = prefixHead ^. epochIndexL logDebug $ "Rolling: Calculating LRC if needed for epoch " <> pretty epochIndex - lift $ lrcSingleShot epochIndex + lift $ lrcSingleShot pm epochIndex logDebug "Rolling: verifying" - lift (verifyBlocksPrefix prefix) >>= \case + lift (verifyBlocksPrefix pm prefix) >>= \case Left (ApplyBlocksVerifyFailure -> failure) | rollback -> failWithRollback failure blunds | otherwise -> do @@ -197,7 +210,7 @@ verifyAndApplyBlocks rollback blocks = runExceptT $ do let newBlunds = OldestFirst $ getOldestFirst prefix `NE.zip` getOldestFirst undos logDebug "Rolling: Verification done, applying unsafe block" - lift $ applyBlocksUnsafe (ShouldCallBListener True) newBlunds (Just pModifier) + lift $ applyBlocksUnsafe pm (ShouldCallBListener True) newBlunds (Just pModifier) case getOldestFirst suffix of [] -> lift GS.getTip (genesis:xs) -> do @@ -211,19 +224,25 @@ verifyAndApplyBlocks rollback blocks = runExceptT $ do -- and ensured that chain is based on our tip. Blocks will be applied -- per-epoch, calculating lrc when needed if flag is set. applyBlocks - :: forall ctx m. - (BlockLrcMode ctx m) - => Bool -> Maybe PollModifier -> OldestFirst NE Blund -> m () -applyBlocks calculateLrc pModifier blunds = do + :: forall ctx m + . ( BlockLrcMode ctx m + , HasMisbehaviorMetrics ctx + ) + => ProtocolMagic + -> Bool + -> Maybe PollModifier + -> OldestFirst NE Blund + -> m () +applyBlocks pm calculateLrc pModifier blunds = do when (isLeft prefixHead && calculateLrc) $ -- Hopefully this lrc check is never triggered -- because -- caller most definitely should have computed lrc to verify -- the sequence beforehand. - lrcSingleShot (prefixHead ^. epochIndexL) - applyBlocksUnsafe (ShouldCallBListener True) prefix pModifier + lrcSingleShot pm (prefixHead ^. epochIndexL) + applyBlocksUnsafe pm (ShouldCallBListener True) prefix pModifier case getOldestFirst suffix of [] -> pass - (genesis:xs) -> applyBlocks calculateLrc pModifier (OldestFirst (genesis:|xs)) + (genesis:xs) -> applyBlocks pm calculateLrc pModifier (OldestFirst (genesis:|xs)) where prefixHead = prefix ^. _Wrapped . _neHead . _1 (prefix, suffix) = spanEpoch blunds @@ -237,28 +256,32 @@ applyBlocks calculateLrc pModifier blunds = do -- | Rollbacks blocks. Head must be the current tip. rollbackBlocks - :: (MonadBlockApply ctx m) - => NewestFirst NE Blund -> m () -rollbackBlocks blunds = do + :: (MonadBlockApply ctx m) => ProtocolMagic -> NewestFirst NE Blund -> m () +rollbackBlocks pm blunds = do tip <- GS.getTip let firstToRollback = blunds ^. _Wrapped . _neHead . _1 . headerHashG when (tip /= firstToRollback) $ throwM $ RollbackTipMismatch tip firstToRollback - rollbackBlocksUnsafe (BypassSecurityCheck False) (ShouldCallBListener True) blunds + rollbackBlocksUnsafe pm (BypassSecurityCheck False) (ShouldCallBListener True) blunds -- | Rollbacks some blocks and then applies some blocks. applyWithRollback - :: forall ctx m. - (BlockLrcMode ctx m, MonadMempoolNormalization ctx m) - => NewestFirst NE Blund -- ^ Blocks to rollbck + :: forall ctx m + . ( BlockLrcMode ctx m + , MonadMempoolNormalization ctx m + , HasMisbehaviorMetrics ctx + ) + => ProtocolMagic + -> NewestFirst NE Blund -- ^ Blocks to rollbck -> OldestFirst NE Block -- ^ Blocks to apply -> m (Either ApplyBlocksException HeaderHash) -applyWithRollback toRollback toApply = runExceptT $ do +applyWithRollback pm toRollback toApply = runExceptT $ do tip <- lift GS.getTip when (tip /= newestToRollback) $ throwError $ ApplyBlocksTipMismatch "applyWithRollback/rollback" tip newestToRollback let doRollback = rollbackBlocksUnsafe + pm (BypassSecurityCheck False) (ShouldCallBListener True) toRollback @@ -272,7 +295,7 @@ applyWithRollback toRollback toApply = runExceptT $ do where reApply = toOldestFirst toRollback applyBack :: m () - applyBack = applyBlocks False Nothing reApply + applyBack = applyBlocks pm False Nothing reApply expectedTipApply = toApply ^. _Wrapped . _neHead . prevBlockL newestToRollback = toRollback ^. _Wrapped . _neHead . _1 . headerHashG @@ -280,6 +303,6 @@ applyWithRollback toRollback toApply = runExceptT $ do applyBack $> Left (ApplyBlocksTipMismatch "applyWithRollback/apply" tip newestToRollback) onGoodRollback = - verifyAndApplyBlocks True toApply >>= \case + verifyAndApplyBlocks pm True toApply >>= \case Left err -> applyBack $> Left err Right tipHash -> pure (Right tipHash) diff --git a/block/src/Pos/Lrc/Worker.hs b/block/src/Pos/Block/Lrc.hs similarity index 75% rename from block/src/Pos/Lrc/Worker.hs rename to block/src/Pos/Block/Lrc.hs index a76ff29a838..ec9d36a487e 100644 --- a/block/src/Pos/Lrc/Worker.hs +++ b/block/src/Pos/Block/Lrc.hs @@ -5,53 +5,58 @@ -- reasons. -- And actually nowadays there are no workers here. -module Pos.Lrc.Worker +module Pos.Block.Lrc ( LrcModeFull , lrcSingleShot ) where -import Universum +import Universum hiding (id) import Control.Exception.Safe (bracketOnError) import Control.Lens (views) import Control.Monad.STM (retry) import Data.Coerce (coerce) -import Data.Conduit (runConduitRes, (.|)) +import Data.Conduit (ConduitT, runConduitRes, (.|)) import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS import Formatting (build, ords, sformat, (%)) import Mockable (forConcurrently) import qualified System.Metrics.Counter as Metrics import System.Wlog (logDebug, logInfo, logWarning) +import UnliftIO (MonadUnliftIO) import Pos.Block.Logic.Internal (BypassSecurityCheck (..), MonadBlockApply, applyBlocksUnsafe, rollbackBlocksUnsafe) import Pos.Block.Slog.Logic (ShouldCallBListener (..)) import Pos.Core (Coin, EpochIndex, EpochOrSlot (..), SharedSeed, StakeholderId, - blkSecurityParam, crucialSlot, epochIndexL, getEpochOrSlot) + blkSecurityParam, crucialSlot, epochIndexL, epochSlots, getEpochOrSlot) +import Pos.Core.Chrono (NE, NewestFirst (..), toOldestFirst) +import Pos.Crypto (ProtocolMagic) import qualified Pos.DB.Block.Load as DB +import Pos.DB.Class (MonadDBRead, MonadGState) import qualified Pos.DB.GState.Stakes as GS (getRealStake, getRealTotalStake) +import Pos.Delegation (getDelegators, isIssuerByAddressHash) import qualified Pos.GState.SanityCheck as DB (sanityCheckDB) +import Pos.Infra.Reporting.MemState (HasMisbehaviorMetrics (..), MisbehaviorMetrics (..)) +import Pos.Infra.Slotting (MonadSlots) +import Pos.Infra.Util.TimeLimit (logWarningWaitLinear) import Pos.Lrc.Consumer (LrcConsumer (..)) import Pos.Lrc.Consumers (allLrcConsumers) import Pos.Lrc.Context (LrcContext (lcLrcSync), LrcSyncData (..)) +import Pos.Lrc.Core (findDelegationStakes, findRichmenStakes) import Pos.Lrc.DB (IssuersStakes, getSeed, putEpoch, putIssuersStakes, putSeed) import qualified Pos.Lrc.DB as LrcDB (hasLeaders, putLeadersForEpoch) import Pos.Lrc.Error (LrcError (..)) import Pos.Lrc.Fts (followTheSatoshiM) -import Pos.Lrc.Logic (findAllRichmenMaybe) import Pos.Lrc.Mode (LrcMode) -import Pos.Reporting (reportMisbehaviour) -import Pos.Reporting.MemState (HasMisbehaviorMetrics (..), MisbehaviorMetrics (..)) -import Pos.Slotting (MonadSlots) +import Pos.Lrc.Types (RichmenStakes) import Pos.Ssc (MonadSscMem, noReportNoSecretsForEpoch1, sscCalculateSeed) import Pos.Ssc.Message (SscMessageConstraints) +import Pos.Txp.Configuration (HasTxpConfiguration) import qualified Pos.Txp.DB.Stakes as GS (stakeSource) import Pos.Update.DB (getCompetingBVStates) import Pos.Update.Poll.Types (BlockVersionState (..)) import Pos.Util (maybeThrow) -import Pos.Util.Chrono (NE, NewestFirst (..), toOldestFirst) -import Pos.Util.TimeLimit (logWarningWaitLinear) import Pos.Util.Util (HasLens (..)) @@ -61,21 +66,25 @@ import Pos.Util.Util (HasLens (..)) -- | 'LrcModeFull' contains all constraints necessary to launch LRC. type LrcModeFull ctx m = - ( LrcMode ctx m + ( HasTxpConfiguration + , LrcMode ctx m , MonadSscMem ctx m , MonadSlots ctx m , MonadBlockApply ctx m , MonadReader ctx m - , SscMessageConstraints m + , SscMessageConstraints ) -- | Run leaders and richmen computation for given epoch. If stable -- block for this epoch is not known, LrcError will be thrown. -- It assumes that 'StateLock' is taken already. lrcSingleShot - :: forall ctx m. (LrcModeFull ctx m) - => EpochIndex -> m () -lrcSingleShot epoch = do + :: forall ctx m + . (LrcModeFull ctx m, HasMisbehaviorMetrics ctx) + => ProtocolMagic + -> EpochIndex + -> m () +lrcSingleShot pm epoch = do lock <- views (lensOf @LrcContext) lcLrcSync logDebug $ sformat ("lrcSingleShot is trying to acquire LRC lock, the epoch is " @@ -101,7 +110,7 @@ lrcSingleShot epoch = do , expectedRichmenComp) when need $ do logInfo "LRC is starting actual computation" - lrcDo epoch filteredConsumers + lrcDo pm epoch filteredConsumers logInfo "LRC has finished actual computation" putEpoch epoch logInfo ("LRC has updated LRC DB" <> for_thEpochMsg) @@ -125,10 +134,15 @@ tryAcquireExclusiveLock epoch lock action = doAction _ = action >> releaseLock epoch lrcDo - :: forall ctx m. - (LrcModeFull ctx m) - => EpochIndex -> [LrcConsumer m] -> m () -lrcDo epoch consumers = do + :: forall ctx m + . ( LrcModeFull ctx m + , HasMisbehaviorMetrics ctx + ) + => ProtocolMagic + -> EpochIndex + -> [LrcConsumer m] + -> m () +lrcDo pm epoch consumers = do blundsUpToGenesis <- DB.loadBlundsFromTipWhile upToGenesis -- If there are blocks from 'epoch' it means that we somehow accepted them -- before running LRC for 'epoch'. It's very bad. @@ -148,18 +162,12 @@ lrcDo epoch consumers = do logInfo $ sformat ("Calculated seed for epoch "%build%" successfully") epoch return s - Left err -> do - let isCritical = True + Left _ -> do -- Critical error means that the system is in dangerous state. -- For now let's consider all errors critical, maybe we'll revise it later. - -- REPORT:MISBEHAVIOUR(T) Couldn't compute seed. unless (noReportNoSecretsForEpoch1 && epoch == 1) $ do whenJustM (view misbehaviorMetrics) $ liftIO . Metrics.inc . _mmSscFailures - reportMisbehaviour isCritical $ sformat - ("SSC couldn't compute seed: "%build%" for epoch "%build% - ", going to reuse seed for previous epoch") - err epoch getSeed (epoch - 1) >>= maybeThrow (CanNotReuseSeedForLrc (epoch - 1)) putSeed epoch seed @@ -176,7 +184,7 @@ lrcDo epoch consumers = do then coerce (nonEmpty @a) l else Nothing - applyBack blunds = applyBlocksUnsafe scb blunds Nothing + applyBack blunds = applyBlocksUnsafe pm scb blunds Nothing upToGenesis b = b ^. epochIndexL >= epoch whileAfterCrucial b = getEpochOrSlot b > crucial crucial = EpochOrSlot $ Right $ crucialSlot epoch @@ -191,7 +199,7 @@ lrcDo epoch consumers = do -- and outer viewers mustn't know about it. ShouldCallBListener False withBlocksRolledBack blunds = - bracket_ (rollbackBlocksUnsafe bsc scb blunds) + bracket_ (rollbackBlocksUnsafe pm bsc scb blunds) (applyBack (toOldestFirst blunds)) issuersComputationDo :: forall ctx m . LrcMode ctx m => EpochIndex -> m () @@ -209,8 +217,7 @@ issuersComputationDo epochId = do hm <$ (logWarning $ sformat ("Stake for issuer "%build% " not found") id) Just stake -> pure $ HM.insert id stake hm -leadersComputationDo :: - forall ctx m. LrcMode ctx m +leadersComputationDo :: LrcMode ctx m => EpochIndex -> SharedSeed -> m () @@ -218,9 +225,13 @@ leadersComputationDo epochId seed = unlessM (LrcDB.hasLeaders epochId) $ do totalStake <- GS.getRealTotalStake leaders <- - runConduitRes $ GS.stakeSource .| followTheSatoshiM seed totalStake + runConduitRes $ GS.stakeSource .| followTheSatoshiM epochSlots seed totalStake LrcDB.putLeadersForEpoch epochId leaders +-------------------------------------------------------------------------------- +-- Richmen +-------------------------------------------------------------------------------- + richmenComputationDo :: forall ctx m. LrcMode ctx m @@ -252,6 +263,53 @@ richmenComputationDo epochIdx consumers = unless (null consumers) $ do | null a = Nothing | otherwise = Just $ minimum a +type MonadDBReadFull m = (MonadDBRead m, MonadGState m, MonadUnliftIO m) + +-- Can it be improved using conduits? +-- | Find delegated richmen using precomputed usual richmen. +-- Do it using one pass by delegation DB. +findDelRichUsingPrecomp + :: forall m. + (MonadDBReadFull m) + => RichmenStakes -> Coin -> m RichmenStakes +findDelRichUsingPrecomp precomputed thr = do + (old, new) <- + runConduitRes $ + getDelegators .| + findDelegationStakes isIssuerByAddressHash GS.getRealStake thr + -- attention: order of new and precomputed is important + -- we want to use new stakes (computed from delegated) of precomputed richmen + pure (new `HM.union` (precomputed `HM.difference` (HS.toMap old))) + +-- | Find delegated richmen. +findDelegatedRichmen + :: (MonadDBReadFull m) + => Coin -> ConduitT (StakeholderId, Coin) Void m RichmenStakes +findDelegatedRichmen thr = do + st <- findRichmenStakes thr + lift $ findDelRichUsingPrecomp st thr + +-- | Function considers all variants of computation +-- and compute using one pass by stake DB and one pass by delegation DB. +findAllRichmenMaybe + :: forall m. + (MonadDBReadFull m) + => Maybe Coin -- ^ Eligibility threshold (optional) + -> Maybe Coin -- ^ Delegation threshold (optional) + -> ConduitT (StakeholderId, Coin) Void m (RichmenStakes, RichmenStakes) +findAllRichmenMaybe maybeT maybeTD + | Just t <- maybeT + , Just tD <- maybeTD = do + let mn = min t tD + richmenMin <- findRichmenStakes mn + let richmen = HM.filter (>= t) richmenMin + let precomputedD = HM.filter (>= tD) richmenMin + richmenD <- lift $ findDelRichUsingPrecomp precomputedD tD + pure (richmen, richmenD) + | Just t <- maybeT = (,mempty) <$> findRichmenStakes t + | Just tD <- maybeTD = (mempty,) <$> findDelegatedRichmen tD + | otherwise = pure (mempty, mempty) + ---------------------------------------------------------------------------- -- Worker ---------------------------------------------------------------------------- diff --git a/block/src/Pos/Block/Network.hs b/block/src/Pos/Block/Network.hs index 093aae34d24..df93010f8fc 100644 --- a/block/src/Pos/Block/Network.hs +++ b/block/src/Pos/Block/Network.hs @@ -1,3 +1,10 @@ -- | Re-export of Pos.Block.Network.* +module Pos.Block.Network + ( module Pos.Block.Network.Logic + , module Pos.Block.Network.Retrieval + , module Pos.Block.Network.Types + ) where -{-# OPTIONS_GHC -F -pgmF autoexporter #-} +import Pos.Block.Network.Logic +import Pos.Block.Network.Retrieval +import Pos.Block.Network.Types diff --git a/block/src/Pos/Block/Network/Logic.hs b/block/src/Pos/Block/Network/Logic.hs index 3d5826046d3..f5f74859c1d 100644 --- a/block/src/Pos/Block/Network/Logic.hs +++ b/block/src/Pos/Block/Network/Logic.hs @@ -8,9 +8,6 @@ module Pos.Block.Network.Logic ( BlockNetLogicException (..) , triggerRecovery - , requestTipOuts - , requestTip - , handleBlocks , handleUnsolicitedHeader @@ -19,52 +16,53 @@ module Pos.Block.Network.Logic import Universum import Control.Concurrent.STM (isFullTBQueue, readTVar, writeTBQueue, writeTVar) +import Control.Exception (IOException) import Control.Exception.Safe (Exception (..)) import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as M import qualified Data.Text.Buildable as B import Formatting (bprint, build, sformat, shown, stext, (%)) +import Mockable (forConcurrently) import Serokell.Util.Text (listJson) import qualified System.Metrics.Gauge as Metrics import System.Wlog (logDebug, logInfo, logWarning) import Pos.Binary.Txp () -import Pos.Block.BlockWorkMode (BlockInstancesConstraint, BlockWorkMode) -import Pos.Block.Configuration (criticalForkThreshold) +import Pos.Block.BlockWorkMode (BlockWorkMode) import Pos.Block.Error (ApplyBlocksException) import Pos.Block.Logic (ClassifyHeaderRes (..), classifyNewHeader, lcaWithMainChain, verifyAndApplyBlocks) import qualified Pos.Block.Logic as L -import Pos.Block.Network.Types (MsgGetHeaders (..), MsgHeaders (..)) import Pos.Block.RetrievalQueue (BlockRetrievalQueue, BlockRetrievalQueueTag, BlockRetrievalTask (..)) import Pos.Block.Types (Blund, LastKnownHeaderTag) -import Pos.Communication.Limits.Types (recvLimited) -import Pos.Communication.Protocol (ConversationActions (..), NodeId, OutSpecs, convH, - toOutSpecs) import Pos.Core (HasHeaderHash (..), HeaderHash, gbHeader, headerHashG, isMoreDifficult, prevBlockL) import Pos.Core.Block (Block, BlockHeader, blockHeader) -import Pos.Crypto (shortHashF) +import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..), _NewestFirst, + _OldestFirst) +import Pos.Crypto (ProtocolMagic, shortHashF) import qualified Pos.DB.Block.Load as DB -import Pos.Diffusion.Types (Diffusion) -import qualified Pos.Diffusion.Types as Diffusion (Diffusion (announceBlockHeader, requestTip)) import Pos.Exception (cardanoExceptionFromException, cardanoExceptionToException) -import Pos.Recovery.Info (recoveryInProgress) -import Pos.Reporting.MemState (HasMisbehaviorMetrics (..), MisbehaviorMetrics (..)) -import Pos.Reporting.Methods (reportMisbehaviour) -import Pos.StateLock (Priority (..), modifyStateLock) +import Pos.Infra.Communication.Protocol (NodeId) +import Pos.Infra.Diffusion.Types (Diffusion) +import qualified Pos.Infra.Diffusion.Types as Diffusion (Diffusion (announceBlockHeader, requestTip)) +import Pos.Infra.Recovery.Info (recoveryInProgress) +import Pos.Infra.Reporting.MemState (HasMisbehaviorMetrics (..), MisbehaviorMetrics (..)) +import Pos.Infra.StateLock (Priority (..), modifyStateLock) +import Pos.Infra.Util.JsonLog.Events (MemPoolModifyReason (..), jlAdoptedBlock) +import Pos.Infra.Util.TimeWarp (CanJsonLog (..)) import Pos.Util (buildListBounds, multilineBounds, _neLast) import Pos.Util.AssertMode (inAssertMode) -import Pos.Util.Chrono (NE, NewestFirst (..), OldestFirst (..), _NewestFirst, - _OldestFirst) -import Pos.Util.JsonLog (jlAdoptedBlock) -import Pos.Util.TimeWarp (CanJsonLog (..)) import Pos.Util.Util (lensOf) ---------------------------------------------------------------------------- -- Exceptions ---------------------------------------------------------------------------- +-- FIXME this same thing is defined in full diffusion layer. +-- Must finish the proper factoring. There should be no 'Block.Network' +-- in cardano-sl-block; it should just use the Diffusion and Logic interfaces. data BlockNetLogicException = DialogUnexpected Text -- ^ Node's response in any network/block related logic was @@ -96,55 +94,50 @@ instance Exception BlockNetLogicException where -- progress and 'ncRecoveryHeader' is full, we'll be requesting blocks anyway -- and until we're finished we shouldn't be asking for new blocks. triggerRecovery - :: BlockWorkMode ctx m - => Diffusion m -> m () -triggerRecovery diffusion = unlessM recoveryInProgress $ do + :: ( BlockWorkMode ctx m + ) + => ProtocolMagic -> Diffusion m -> m () +triggerRecovery pm diffusion = unlessM recoveryInProgress $ do logDebug "Recovery triggered, requesting tips from neighbors" - -- I know, it's not unsolicited. TODO rename. - void (Diffusion.requestTip diffusion $ handleUnsolicitedHeader) `catch` + -- The 'catch' here is for an exception when trying to enqueue the request. + -- In 'requestTipsAndProcess', IO exceptions are caught, for each + -- individual request per-peer. Those are not re-thrown. + void requestTipsAndProcess `catch` \(e :: SomeException) -> do logDebug ("Error happened in triggerRecovery: " <> show e) throwM e logDebug "Finished requesting tips for recovery" - -requestTipOuts :: BlockInstancesConstraint m => Proxy m -> OutSpecs -requestTipOuts _ = - toOutSpecs [ convH (Proxy :: Proxy MsgGetHeaders) - (Proxy :: Proxy MsgHeaders) ] - --- | Is used if we're recovering after offline and want to know what's --- current blockchain state. Sends "what's your current tip" request --- to everybody we know. -requestTip - :: BlockWorkMode ctx m - => NodeId - -> ConversationActions MsgGetHeaders MsgHeaders m - -> m () -requestTip nodeId conv = do - logDebug "Requesting tip..." - send conv (MsgGetHeaders [] Nothing) - whenJustM (recvLimited conv) handleTip where - handleTip (MsgHeaders (NewestFirst (tip:|[]))) = do - logDebug $ sformat ("Got tip "%shortHashF%", processing") (headerHash tip) - handleUnsolicitedHeader tip nodeId - handleTip t = - logWarning $ sformat ("requestTip: got unexpected response: "%shown) t + requestTipsAndProcess = do + requestsMap <- Diffusion.requestTip diffusion + forConcurrently (M.toList requestsMap) $ \it@(nodeId, _) -> waitAndProcessOne it `catch` + -- Catch and squelch IOExceptions so that one failed request to one + -- particlar peer does not stop the others. + \(e :: IOException) -> + logDebug $ sformat ("Error requesting tip from "%shown%": "%shown) nodeId e + waitAndProcessOne (nodeId, mbh) = do + -- 'mbh' is an 'm' term that returns when the header has been + -- downloaded. + bh <- mbh + -- I know, it's not unsolicited. TODO rename. + handleUnsolicitedHeader pm bh nodeId ---------------------------------------------------------------------------- -- Headers processing ---------------------------------------------------------------------------- handleUnsolicitedHeader - :: BlockWorkMode ctx m - => BlockHeader + :: ( BlockWorkMode ctx m + ) + => ProtocolMagic + -> BlockHeader -> NodeId -> m () -handleUnsolicitedHeader header nodeId = do +handleUnsolicitedHeader pm header nodeId = do logDebug $ sformat ("handleUnsolicitedHeader: single header was propagated, processing:\n" %build) header - classificationRes <- classifyNewHeader header + classificationRes <- classifyNewHeader pm header -- TODO: should we set 'To' hash to hash of header or leave it unlimited? case classificationRes of CHContinues -> do @@ -224,12 +217,15 @@ updateLastKnownHeader lastKnownH header = do -- | Carefully apply blocks that came from the network. handleBlocks - :: forall ctx m. BlockWorkMode ctx m - => NodeId + :: forall ctx m . + ( BlockWorkMode ctx m + , HasMisbehaviorMetrics ctx + ) + => ProtocolMagic -> OldestFirst NE Block -> Diffusion m -> m () -handleBlocks nodeId blocks diffusion = do +handleBlocks pm blocks diffusion = do logDebug "handleBlocks: processing" inAssertMode $ logInfo $ sformat ("Processing sequence of blocks: " % buildListBounds % "...") $ @@ -247,20 +243,23 @@ handleBlocks nodeId blocks diffusion = do logDebug $ sformat ("Handling block w/ LCA, which is "%shortHashF) lcaHash -- Head blund in result is the youngest one. toRollback <- DB.loadBlundsFromTipWhile $ \blk -> headerHash blk /= lcaHash - maybe (applyWithoutRollback diffusion blocks) - (applyWithRollback nodeId diffusion blocks lcaHash) + maybe (applyWithoutRollback pm diffusion blocks) + (applyWithRollback pm diffusion blocks lcaHash) (_NewestFirst nonEmpty toRollback) applyWithoutRollback :: forall ctx m. - BlockWorkMode ctx m - => Diffusion m + ( BlockWorkMode ctx m + , HasMisbehaviorMetrics ctx + ) + => ProtocolMagic + -> Diffusion m -> OldestFirst NE Block -> m () -applyWithoutRollback diffusion blocks = do +applyWithoutRollback pm diffusion blocks = do logInfo . sformat ("Trying to apply blocks w/o rollback. " % multilineBounds 6) . getOldestFirst . map (view blockHeader) $ blocks - modifyStateLock HighPriority "applyWithoutRollback" applyWithoutRollbackDo >>= \case + modifyStateLock HighPriority ApplyBlock applyWithoutRollbackDo >>= \case Left (pretty -> err) -> onFailedVerifyBlocks (getOldestFirst blocks) err Right newTip -> do @@ -286,25 +285,27 @@ applyWithoutRollback diffusion blocks = do :: HeaderHash -> m (HeaderHash, Either ApplyBlocksException HeaderHash) applyWithoutRollbackDo curTip = do logInfo "Verifying and applying blocks..." - res <- verifyAndApplyBlocks False blocks + res <- verifyAndApplyBlocks pm False blocks logInfo "Verifying and applying blocks done" let newTip = either (const curTip) identity res pure (newTip, res) applyWithRollback - :: BlockWorkMode ctx m - => NodeId + :: ( BlockWorkMode ctx m + , HasMisbehaviorMetrics ctx + ) + => ProtocolMagic -> Diffusion m -> OldestFirst NE Block -> HeaderHash -> NewestFirst NE Blund -> m () -applyWithRollback nodeId diffusion toApply lca toRollback = do +applyWithRollback pm diffusion toApply lca toRollback = do logInfo . sformat ("Trying to apply blocks w/o rollback. " % multilineBounds 6) . getOldestFirst . map (view blockHeader) $ toApply logInfo $ sformat ("Blocks to rollback "%listJson) toRollbackHashes - res <- modifyStateLock HighPriority "applyWithRollback" $ \curTip -> do - res <- L.applyWithRollback toRollback toApplyAfterLca + res <- modifyStateLock HighPriority ApplyBlockWithRollback $ \curTip -> do + res <- L.applyWithRollback pm toRollback toApplyAfterLca pure (either (const curTip) identity res, res) case res of Left (pretty -> err) -> @@ -320,23 +321,13 @@ applyWithRollback nodeId diffusion toApply lca toRollback = do relayBlock diffusion $ toApply ^. _OldestFirst . _neLast where toRollbackHashes = fmap headerHash toRollback - toApplyHashes = fmap headerHash toApply - reportF = - "Fork happened, data received from "%build% - ". Blocks rolled back: "%listJson% - ", blocks applied: "%listJson reportRollback = do let rollbackDepth = length toRollback - let isCritical = rollbackDepth >= criticalForkThreshold -- Commit rollback value to EKG whenJustM (view misbehaviorMetrics) $ liftIO . flip Metrics.set (fromIntegral rollbackDepth) . _mmRollbacks - -- REPORT:MISBEHAVIOUR(F/T) Blockchain fork occurred (depends on depth). - reportMisbehaviour isCritical $ - sformat reportF nodeId toRollbackHashes toApplyHashes - panicBrokenLca = error "applyWithRollback: nothing after LCA :<" toApplyAfterLca = OldestFirst $ diff --git a/block/src/Pos/Block/Network/Retrieval.hs b/block/src/Pos/Block/Network/Retrieval.hs index 47b601b5ed4..2be3d0ec3de 100644 --- a/block/src/Pos/Block/Network/Retrieval.hs +++ b/block/src/Pos/Block/Network/Retrieval.hs @@ -9,47 +9,36 @@ module Pos.Block.Network.Retrieval import Universum import Control.Concurrent.STM (putTMVar, swapTMVar, tryReadTBQueue, tryReadTMVar, - tryTakeTMVar) + tryTakeTMVar, readTBQueue, TBQueue) import Control.Exception.Safe (handleAny) import Control.Lens (to) import Control.Monad.STM (retry) import qualified Data.List.NonEmpty as NE +import Data.Time.Units (Second) import Formatting (build, int, sformat, (%)) import Mockable (delay) -import Serokell.Util (sec) +import qualified System.Metrics.Gauge as Gauge import System.Wlog (logDebug, logError, logInfo, logWarning) import Pos.Block.BlockWorkMode (BlockWorkMode) import Pos.Block.Logic (ClassifyHeaderRes (..), classifyNewHeader, getHeadersOlderExp) -import Pos.Block.Network.Logic (BlockNetLogicException (DialogUnexpected), handleBlocks, +import Pos.Block.Network.Logic (BlockNetLogicException (..), handleBlocks, triggerRecovery) -import Pos.Block.Network.Types (MsgBlock (..), MsgGetBlocks (..)) import Pos.Block.RetrievalQueue (BlockRetrievalQueueTag, BlockRetrievalTask (..)) import Pos.Block.Types (RecoveryHeaderTag) -import Pos.Communication.Protocol (NodeId, OutSpecs, convH, toOutSpecs) import Pos.Core (Block, HasHeaderHash (..), HeaderHash, difficultyL, isMoreDifficult) import Pos.Core.Block (BlockHeader) -import Pos.Crypto (shortHashF) +import Pos.Core.Chrono (NE, OldestFirst (..), _OldestFirst) +import Pos.Crypto (ProtocolMagic, shortHashF) import qualified Pos.DB.BlockIndex as DB -import Pos.Diffusion.Types (Diffusion) -import qualified Pos.Diffusion.Types as Diffusion (Diffusion (getBlocks)) -import Pos.Reporting (reportOrLogE, reportOrLogW) -import Pos.Util.Chrono (NE, OldestFirst (..), _OldestFirst) +import Pos.Infra.Communication.Protocol (NodeId) +import Pos.Infra.Diffusion.Types (Diffusion, StreamEntry (..)) +import qualified Pos.Infra.Diffusion.Types as Diffusion (Diffusion (getBlocks, streamBlocks)) +import Pos.Infra.Reporting (HasMisbehaviorMetrics, reportOrLogE, reportOrLogW) import Pos.Util.Util (HasLens (..)) -import Pos.Worker.Types (WorkerSpec, worker) - -retrievalWorker - :: forall ctx m. - (BlockWorkMode ctx m) - => (WorkerSpec m, OutSpecs) -retrievalWorker = worker outs retrievalWorkerImpl - where - outs = toOutSpecs [convH (Proxy :: Proxy MsgGetBlocks) - (Proxy :: Proxy MsgBlock) - ] -- I really don't like join -{-# ANN retrievalWorkerImpl ("HLint: ignore Use join" :: Text) #-} +{-# ANN retrievalWorker ("HLint: ignore Use join" :: Text) #-} -- | Worker that queries blocks. It has two jobs: -- @@ -61,11 +50,13 @@ retrievalWorker = worker outs retrievalWorkerImpl -- -- If both happen at the same time, 'BlockRetrievalQueue' takes precedence. -- -retrievalWorkerImpl +retrievalWorker :: forall ctx m. - (BlockWorkMode ctx m) - => Diffusion m -> m () -retrievalWorkerImpl diffusion = do + ( BlockWorkMode ctx m + , HasMisbehaviorMetrics ctx + ) + => ProtocolMagic -> Diffusion m -> m () +retrievalWorker pm diffusion = do logInfo "Starting retrievalWorker loop" mainLoop where @@ -115,9 +106,9 @@ retrievalWorkerImpl diffusion = do handleContinues nodeId header = do let hHash = headerHash header logDebug $ "handleContinues: " <> pretty hHash - classifyNewHeader header >>= \case + classifyNewHeader pm header >>= \case CHContinues -> - void $ getProcessBlocks diffusion nodeId header [hHash] + void $ getProcessBlocks pm diffusion nodeId (headerHash header) [hHash] res -> logDebug $ "processContHeader: expected header to " <> "be continuation, but it's " <> show res @@ -127,7 +118,7 @@ retrievalWorkerImpl diffusion = do -- enter recovery mode. handleAlternative nodeId header = do logDebug $ "handleAlternative: " <> pretty (headerHash header) - classifyNewHeader header >>= \case + classifyNewHeader pm header >>= \case CHInvalid _ -> logError "handleAlternative: invalid header got into retrievalWorker queue" CHUseless _ -> @@ -159,7 +150,7 @@ retrievalWorkerImpl diffusion = do reportOrLogW (sformat ("handleRecoveryE: error handling nodeId="%build%", header="%build%": ") nodeId (headerHash rHeader)) e - dropRecoveryHeaderAndRepeat diffusion nodeId + dropRecoveryHeaderAndRepeat pm diffusion nodeId -- Recovery handling. We assume that header in the recovery variable is -- appropriate and just query headers/blocks. @@ -173,7 +164,7 @@ retrievalWorkerImpl diffusion = do "already present in db" logDebug "handleRecovery: fetching blocks" checkpoints <- toList <$> getHeadersOlderExp Nothing - void $ getProcessBlocks diffusion nodeId rHeader checkpoints + void $ streamProcessBlocks pm diffusion nodeId (headerHash rHeader) checkpoints ---------------------------------------------------------------------------- -- Entering and exiting recovery mode @@ -259,16 +250,16 @@ dropRecoveryHeader nodeId = do -- | Drops the recovery header and, if it was successful, queries the tips. dropRecoveryHeaderAndRepeat - :: (BlockWorkMode ctx m) - => Diffusion m -> NodeId -> m () -dropRecoveryHeaderAndRepeat diffusion nodeId = do + :: BlockWorkMode ctx m => ProtocolMagic -> Diffusion m -> NodeId -> m () +dropRecoveryHeaderAndRepeat pm diffusion nodeId = do kicked <- dropRecoveryHeader nodeId when kicked $ attemptRestartRecovery where attemptRestartRecovery = do logDebug "Attempting to restart recovery" - delay $ sec 2 - handleAny handleRecoveryTriggerE $ triggerRecovery diffusion + -- FIXME why delay? Why 2 seconds? + delay (2 :: Second) + handleAny handleRecoveryTriggerE $ triggerRecovery pm diffusion logDebug "Attempting to restart recovery over" handleRecoveryTriggerE = -- REPORT:ERROR 'reportOrLogE' somewhere in block retrieval. @@ -279,26 +270,29 @@ dropRecoveryHeaderAndRepeat diffusion nodeId = do -- processed. Throws exception if something goes wrong. getProcessBlocks :: forall ctx m. - (BlockWorkMode ctx m) - => Diffusion m + ( BlockWorkMode ctx m + , HasMisbehaviorMetrics ctx + ) + => ProtocolMagic + -> Diffusion m -> NodeId - -> BlockHeader + -> HeaderHash -> [HeaderHash] -> m () -getProcessBlocks diffusion nodeId desired checkpoints = do +getProcessBlocks pm diffusion nodeId desired checkpoints = do result <- Diffusion.getBlocks diffusion nodeId desired checkpoints case OldestFirst <$> nonEmpty (getOldestFirst result) of Nothing -> do let msg = sformat ("getProcessBlocks: diffusion returned []"% " on request to fetch "%shortHashF%" from peer "%build) - (headerHash desired) nodeId + desired nodeId throwM $ DialogUnexpected msg Just (blocks :: OldestFirst NE Block) -> do recHeaderVar <- view (lensOf @RecoveryHeaderTag) logDebug $ sformat ("Retrieved "%int%" blocks") (blocks ^. _OldestFirst . to NE.length) - handleBlocks nodeId blocks diffusion + handleBlocks pm blocks diffusion -- If we've downloaded any block with bigger -- difficulty than ncRecoveryHeader, we're -- gracefully exiting recovery mode. @@ -315,3 +309,54 @@ getProcessBlocks diffusion nodeId desired checkpoints = do else pure False when exitedRecovery $ logInfo "Recovery mode exited gracefully on receiving block we needed" + +-- Attempts to catch up by streaming blocks from peer. +-- Will fall back to getProcessBlocks if streaming is disabled +-- or not supported by peer. +streamProcessBlocks + :: forall ctx m. + ( BlockWorkMode ctx m + , HasMisbehaviorMetrics ctx + ) + => ProtocolMagic + -> Diffusion m + -> NodeId + -> HeaderHash + -> [HeaderHash] + -> m () +streamProcessBlocks pm diffusion nodeId desired checkpoints = do + logInfo "streaming start" + r <- Diffusion.streamBlocks diffusion nodeId desired checkpoints (loop 0 []) + case r of + Nothing -> do + logInfo "streaming not supported, reverting to batch mode" + getProcessBlocks pm diffusion nodeId desired checkpoints + Just _ -> do + logInfo "streaming done" + return () + where + loop :: Word32 -> [Block] -> (Word32, Maybe Gauge.Gauge, TBQueue StreamEntry) -> m () + loop !n !blocks (streamWindow, wqgM, blockChan) = do + streamEntry <- atomically $ readTBQueue blockChan + case streamEntry of + StreamEnd -> addBlocks blocks + StreamBlock block -> do + let batchSize = min 64 streamWindow + let n' = n + 1 + when (n' `mod` 256 == 0) $ + logDebug $ sformat ("Read block "%shortHashF%" difficulty "%int) (headerHash block) + (block ^. difficultyL) + case wqgM of + Nothing -> pure () + Just wqg -> liftIO $ Gauge.dec wqg + + if n' `mod` batchSize == 0 + then do + addBlocks (block : blocks) + loop n' [] (streamWindow, wqgM, blockChan) + else + loop n' (block : blocks) (streamWindow, wqgM, blockChan) + + addBlocks [] = return () + addBlocks (block : blocks) = + handleBlocks pm (OldestFirst (NE.reverse $ block :| blocks)) diffusion diff --git a/block/src/Pos/Block/Network/Types.hs b/block/src/Pos/Block/Network/Types.hs index 729a77eef40..f64498d669b 100644 --- a/block/src/Pos/Block/Network/Types.hs +++ b/block/src/Pos/Block/Network/Types.hs @@ -5,6 +5,11 @@ module Pos.Block.Network.Types , MsgGetBlocks (..) , MsgHeaders (..) , MsgBlock (..) + , MsgSerializedBlock (..) + , MsgStream (..) + , MsgStreamStart (..) + , MsgStreamUpdate (..) + , MsgStreamBlock (..) ) where import qualified Data.Text.Buildable @@ -13,8 +18,9 @@ import Serokell.Util.Text (listJson) import Universum import Pos.Core (HeaderHash) -import Pos.Core.Block (Block, BlockHeader) -import Pos.Util.Chrono (NE, NewestFirst) +import Pos.Core.Block (Block, BlockHeader (..)) +import Pos.DB.Class (SerializedBlock) +import Pos.Core.Chrono (NE, NewestFirst (..)) -- | 'GetHeaders' message. Behaviour of the response depends on -- particular combination of 'mghFrom' and 'mghTo'. @@ -71,3 +77,30 @@ data MsgBlock = MsgBlock Block | MsgNoBlock Text deriving (Eq, Show, Generic) + +-- | 'SerializedBlock' message +data MsgSerializedBlock + = MsgSerializedBlock SerializedBlock + | MsgNoSerializedBlock Text + deriving (Generic) + +data MsgStream + = MsgStart MsgStreamStart + | MsgUpdate MsgStreamUpdate + deriving (Eq, Show, Generic) + +data MsgStreamStart = MsgStreamStart + { mssFrom :: ![HeaderHash] -- Oldest first checkpoints. + , mssTo :: !HeaderHash + , mssWindow :: !Word32 + } deriving (Generic, Show, Eq) + +data MsgStreamUpdate = MsgStreamUpdate + { msuWindow :: !Word32 + } deriving (Generic, Show, Eq) + +data MsgStreamBlock + = MsgStreamBlock Block + | MsgStreamNoBlock Text + | MsgStreamEnd + deriving (Eq, Show, Generic) diff --git a/block/src/Pos/Block/RetrievalQueue.hs b/block/src/Pos/Block/RetrievalQueue.hs index f40f19a60b4..47a1d8a2e7a 100644 --- a/block/src/Pos/Block/RetrievalQueue.hs +++ b/block/src/Pos/Block/RetrievalQueue.hs @@ -10,7 +10,7 @@ import Universum import Control.Concurrent.STM (TBQueue) import Pos.Core.Block (BlockHeader) -import Pos.Network.Types (NodeId) +import Pos.Infra.Network.Types (NodeId) -- | Task that is put in the block retrieval queue for the retrieval -- worker to perform. diff --git a/block/src/Pos/Block/Slog.hs b/block/src/Pos/Block/Slog.hs index d0e5beb754d..6083c967c6c 100644 --- a/block/src/Pos/Block/Slog.hs +++ b/block/src/Pos/Block/Slog.hs @@ -2,4 +2,12 @@ -- with all data not related directly to any other component, while -- another part of 'Pos.Block' is dedicated to whole blocks. -{-# OPTIONS_GHC -F -pgmF autoexporter #-} +module Pos.Block.Slog + ( module Pos.Block.Slog.Context + , module Pos.Block.Slog.Logic + , module Pos.Block.Slog.Types + ) where + +import Pos.Block.Slog.Context +import Pos.Block.Slog.Logic +import Pos.Block.Slog.Types diff --git a/block/src/Pos/Block/Slog/Context.hs b/block/src/Pos/Block/Slog/Context.hs index a751eb4a539..a3f988b203d 100644 --- a/block/src/Pos/Block/Slog/Context.hs +++ b/block/src/Pos/Block/Slog/Context.hs @@ -16,10 +16,10 @@ import qualified System.Metrics as Ekg import Pos.Block.Configuration (HasBlockConfiguration, fixedTimeCQSec) import Pos.Block.Slog.Types (HasSlogGState (..), LastBlkSlots, SlogContext (..), SlogGState (..), sgsLastBlkSlots) -import Pos.Core (HasConfiguration, blkSecurityParam) +import Pos.Core (blkSecurityParam) import Pos.DB.Class (MonadDBRead) import Pos.GState.BlockExtra (getLastSlots) -import Pos.Reporting (MetricMonitorState, mkMetricMonitorState) +import Pos.Infra.Reporting (MetricMonitorState, mkMetricMonitorState) import Pos.System.Metrics.Constants (withCardanoNamespace) -- | Make new 'SlogGState' using data from DB. @@ -30,7 +30,7 @@ mkSlogGState = do -- | Make new 'SlogContext' using data from DB. mkSlogContext :: - forall m. (MonadIO m, MonadDBRead m, HasConfiguration, HasBlockConfiguration) + forall m. (MonadIO m, MonadDBRead m, HasBlockConfiguration) => Ekg.Store -> m SlogContext mkSlogContext store = do diff --git a/block/src/Pos/Block/Slog/Logic.hs b/block/src/Pos/Block/Slog/Logic.hs index 0a6a203a492..90ba764e2d4 100644 --- a/block/src/Pos/Block/Slog/Logic.hs +++ b/block/src/Pos/Block/Slog/Logic.hs @@ -37,10 +37,12 @@ import Pos.Block.Logic.Integrity (verifyBlocks) import Pos.Block.Slog.Context (slogGetLastSlots, slogPutLastSlots) import Pos.Block.Slog.Types (HasSlogGState) import Pos.Block.Types (Blund, SlogUndo (..), Undo (..)) -import Pos.Core (BlockVersion (..), FlatSlotId, HasConfiguration, blkSecurityParam, - difficultyL, epochIndexL, flattenSlotId, headerHash, headerHashG, - prevBlockL) +import Pos.Core (BlockVersion (..), FlatSlotId, blkSecurityParam, difficultyL, + epochIndexL, flattenSlotId, headerHash, headerHashG, prevBlockL) import Pos.Core.Block (Block, genBlockLeaders, mainBlockSlot) +import Pos.Core.Chrono (NE, NewestFirst (getNewestFirst), OldestFirst (..), toOldestFirst, + _OldestFirst) +import Pos.Crypto (ProtocolMagic) import Pos.DB (SomeBatchOp (..)) import Pos.DB.Block (putBlunds) import qualified Pos.DB.BlockIndex as DB @@ -49,15 +51,13 @@ import qualified Pos.DB.GState.Common as GS (CommonOp (PutMaxSeenDifficulty, Put getMaxSeenDifficulty) import Pos.Exception (assertionFailed, reportFatalError) import qualified Pos.GState.BlockExtra as GS +import Pos.Infra.Slotting (MonadSlots (getCurrentSlot)) import Pos.Lrc.Context (HasLrcContext, lrcActionOnEpochReason) import qualified Pos.Lrc.DB as LrcDB -import Pos.Slotting (MonadSlots (getCurrentSlot)) import Pos.Update.Configuration (HasUpdateConfiguration, lastKnownBlockVersion) import qualified Pos.Update.DB as GS (getAdoptedBVFull) import Pos.Util (_neHead, _neLast) import Pos.Util.AssertMode (inAssertMode) -import Pos.Util.Chrono (NE, NewestFirst (getNewestFirst), OldestFirst (..), toOldestFirst, - _OldestFirst) ---------------------------------------------------------------------------- -- Helpers @@ -105,7 +105,6 @@ type MonadSlogBase ctx m = , MonadIO m , MonadDBRead m , WithLogger m - , HasConfiguration , HasUpdateConfiguration ) @@ -126,12 +125,11 @@ type MonadSlogVerify ctx m = -- 2. Call pure verification. If it fails, throw. -- 3. Compute 'SlogUndo's and return them. slogVerifyBlocks - :: forall ctx m. - ( MonadSlogVerify ctx m - ) - => OldestFirst NE Block + :: MonadSlogVerify ctx m + => ProtocolMagic + -> OldestFirst NE Block -> m (Either Text (OldestFirst NE SlogUndo)) -slogVerifyBlocks blocks = runExceptT $ do +slogVerifyBlocks pm blocks = runExceptT $ do curSlot <- getCurrentSlot (adoptedBV, adoptedBVD) <- lift GS.getAdoptedBVFull let dataMustBeKnown = mustDataBeKnown adoptedBV @@ -152,8 +150,10 @@ slogVerifyBlocks blocks = runExceptT $ do throwError "Genesis block leaders don't match with LRC-computed" _ -> pass -- Do pure block verification. + let blocksList :: OldestFirst [] Block + blocksList = OldestFirst (NE.toList (getOldestFirst blocks)) verResToMonadError formatAllErrors $ - verifyBlocks curSlot dataMustBeKnown adoptedBVD leaders blocks + verifyBlocks pm curSlot dataMustBeKnown adoptedBVD leaders blocksList -- Here we need to compute 'SlogUndo'. When we apply a block, -- we can remove one of the last slots stored in 'BlockExtra'. -- This removed slot must be put into 'SlogUndo'. @@ -212,7 +212,7 @@ newtype ShouldCallBListener = ShouldCallBListener Bool -- 5. Adding new forward links -- 6. Setting @inMainChain@ flags slogApplyBlocks - :: forall ctx m. (MonadSlogApply ctx m) + :: MonadSlogApply ctx m => ShouldCallBListener -> OldestFirst NE Blund -> m SomeBatchOp @@ -280,7 +280,7 @@ newtype BypassSecurityCheck = BypassSecurityCheck Bool -- 4. Removing forward links -- 5. Removing @inMainChain@ flags slogRollbackBlocks :: - forall ctx m. (MonadSlogApply ctx m) + MonadSlogApply ctx m => BypassSecurityCheck -- ^ is rollback for more than k blocks allowed? -> ShouldCallBListener -> NewestFirst NE Blund diff --git a/block/src/Pos/Block/Slog/Types.hs b/block/src/Pos/Block/Slog/Types.hs index d09b276ed40..e8a99d3dd89 100644 --- a/block/src/Pos/Block/Slog/Types.hs +++ b/block/src/Pos/Block/Slog/Types.hs @@ -20,10 +20,10 @@ import qualified Data.Text.Buildable import Formatting (bprint) import System.Metrics.Label (Label) -import Pos.Core (ChainDifficulty, EpochIndex, FlatSlotId, HasConfiguration, +import Pos.Core (ChainDifficulty, EpochIndex, FlatSlotId, HasProtocolConstants, LocalSlotIndex, slotIdF, unflattenSlotId) -import Pos.Reporting.Metrics (MetricMonitorState) -import Pos.Util.Chrono (OldestFirst (..)) +import Pos.Infra.Reporting.Metrics (MetricMonitorState) +import Pos.Core.Chrono (OldestFirst (..)) -- | This type contains 'FlatSlotId's of the blocks whose depth is -- less than 'blkSecurityParam'. 'FlatSlotId' is chosen in favor of @@ -90,7 +90,7 @@ newtype SlogUndo = SlogUndo { getSlogUndo :: Maybe FlatSlotId } deriving (Eq, Show, NFData, Generic) -instance HasConfiguration => Buildable SlogUndo where +instance HasProtocolConstants => Buildable SlogUndo where build (SlogUndo oldSlot) = "SlogUndo: " <> maybe "" (bprint slotIdF . unflattenSlotId) oldSlot diff --git a/block/src/Pos/Block/Types.hs b/block/src/Pos/Block/Types.hs index 17f4cef7bcd..decdc14cf68 100644 --- a/block/src/Pos/Block/Types.hs +++ b/block/src/Pos/Block/Types.hs @@ -4,7 +4,6 @@ module Pos.Block.Types ( SlogUndo (..) , Undo (..) , Blund - , SerializedBlund , LastKnownHeader , LastKnownHeaderTag @@ -22,13 +21,14 @@ import qualified Data.Text.Buildable import Formatting (bprint, build, (%)) import Serokell.Util.Text (listJson) +-- Bi BlockHeader +import Pos.Binary.Core () import Pos.Block.Slog.Types (SlogUndo (..)) -import Pos.Communication.Protocol (NodeId) import Pos.Core (HasConfiguration, HasDifficulty (..), HasHeaderHash (..)) import Pos.Core.Block (Block, BlockHeader) import Pos.Core.Txp (TxpUndo) -import Pos.DB.Class (SerializedUndo) import Pos.Delegation.Types (DlgUndo) +import Pos.Infra.Communication.Protocol (NodeId) import Pos.Update.Poll.Types (USUndo) import Pos.Util.Util (HasLens (..)) @@ -45,8 +45,6 @@ instance NFData Undo -- | Block and its Undo. type Blund = (Block, Undo) -type SerializedBlund = (Block, SerializedUndo) - instance HasConfiguration => Buildable Undo where build Undo{..} = bprint ("Undo:\n"% @@ -59,7 +57,7 @@ instance HasConfiguration => Buildable Undo where instance HasDifficulty Blund where difficultyL = _1 . difficultyL -instance HasHeaderHash Block => HasHeaderHash Blund where +instance HasHeaderHash Blund where headerHash = headerHash . fst -- | For a description of what these types mean, diff --git a/block/src/Pos/Block/Worker.hs b/block/src/Pos/Block/Worker.hs index 0da486d8581..6d0006908f8 100644 --- a/block/src/Pos/Block/Worker.hs +++ b/block/src/Pos/Block/Worker.hs @@ -11,10 +11,10 @@ import Universum import Control.Lens (ix) import qualified Data.List.NonEmpty as NE -import Data.Time.Units (Microsecond) +import Data.Time.Units (Microsecond, Second, fromMicroseconds) import Formatting (Format, bprint, build, fixed, int, now, sformat, shown, (%)) import Mockable (delay) -import Serokell.Util (enumerate, listJson, pairF, sec) +import Serokell.Util (enumerate, listJson, pairF) import qualified System.Metrics.Label as Label import System.Random (randomRIO) import System.Wlog (logDebug, logError, logInfo, logWarning) @@ -26,40 +26,38 @@ import Pos.Block.Configuration (HasBlockConfiguration, criticalCQ, cri import Pos.Block.Logic (calcChainQualityFixedTime, calcChainQualityM, calcOverallChainQuality, createGenesisBlockAndApply, createMainBlockAndApply) -import Pos.Block.Network.Logic (requestTipOuts, triggerRecovery) +import Pos.Block.Network.Logic (triggerRecovery) import Pos.Block.Network.Retrieval (retrievalWorker) import Pos.Block.Slog (scCQFixedMonitorState, scCQOverallMonitorState, scCQkMonitorState, scCrucialValuesLabel, scDifficultyMonitorState, scEpochMonitorState, scGlobalSlotMonitorState, scLocalSlotMonitorState, slogGetLastSlots) -import Pos.Communication.Protocol (OutSpecs) -import Pos.Core (BlockVersionData (..), ChainDifficulty, FlatSlotId, HasConfiguration, +import Pos.Core (BlockVersionData (..), ChainDifficulty, FlatSlotId, HasProtocolConstants, SlotId (..), Timestamp (Timestamp), addressHash, blkSecurityParam, difficultyL, epochOrSlotToSlot, epochSlots, flattenSlotId, gbHeader, getEpochOrSlot, getOurPublicKey, getSlotIndex, slotIdF, unflattenSlotId) -import Pos.Crypto (ProxySecretKey (pskDelegatePk)) +import Pos.Core.Chrono (OldestFirst (..)) +import Pos.Crypto (ProtocolMagic, ProxySecretKey (pskDelegatePk)) import Pos.DB (gsIsBootstrapEra) import qualified Pos.DB.BlockIndex as DB import Pos.Delegation.DB (getPskByIssuer) import Pos.Delegation.Logic (getDlgTransPsk) import Pos.Delegation.Types (ProxySKBlockInfo) -import Pos.Diffusion.Types (Diffusion) -import qualified Pos.Diffusion.Types as Diffusion (Diffusion (announceBlockHeader)) +import Pos.Infra.Diffusion.Types (Diffusion) +import qualified Pos.Infra.Diffusion.Types as Diffusion (Diffusion (announceBlockHeader)) +import Pos.Infra.Recovery.Info (getSyncStatus, getSyncStatusK, needTriggerRecovery, + recoveryCommGuard) +import Pos.Infra.Reporting (HasMisbehaviorMetrics, MetricMonitor (..), MetricMonitorState, + noReportMonitor, recordValue, reportOrLogE) +import Pos.Infra.Slotting (ActionTerminationPolicy (..), OnNewSlotParams (..), + currentTimeSlotting, defaultOnNewSlotParams, + getSlotStartEmpatically, onNewSlot) +import Pos.Infra.Util.JsonLog.Events (jlCreatedBlock) +import Pos.Infra.Util.LogSafe (logDebugS, logInfoS, logWarningS) +import Pos.Infra.Util.TimeLimit (logWarningSWaitLinear) +import Pos.Infra.Util.TimeWarp (CanJsonLog (..)) import qualified Pos.Lrc.DB as LrcDB (getLeadersForEpoch) -import Pos.Recovery.Info (getSyncStatus, getSyncStatusK, needTriggerRecovery, - recoveryCommGuard) -import Pos.Reporting (MetricMonitor (..), MetricMonitorState, noReportMonitor, - recordValue, reportOrLogE) -import Pos.Slotting (ActionTerminationPolicy (..), OnNewSlotParams (..), - currentTimeSlotting, defaultOnNewSlotParams, getSlotStartEmpatically) import Pos.Update.DB (getAdoptedBVData) -import Pos.Util (mconcatPair) -import Pos.Util.Chrono (OldestFirst (..)) -import Pos.Util.JsonLog (jlCreatedBlock) -import Pos.Util.LogSafe (logDebugS, logInfoS, logWarningS) -import Pos.Util.TimeLimit (logWarningSWaitLinear) -import Pos.Util.TimeWarp (CanJsonLog (..)) -import Pos.Worker.Types (Worker, WorkerSpec, onNewSlotWorker, worker) ---------------------------------------------------------------------------- -- All workers @@ -67,20 +65,22 @@ import Pos.Worker.Types (Worker, WorkerSpec, onNewSlotWorker, worker) -- | All workers specific to block processing. blkWorkers - :: BlockWorkMode ctx m - => ([WorkerSpec m], OutSpecs) -blkWorkers = - merge $ [ blkCreatorWorker - , informerWorker - , retrievalWorker - , recoveryTriggerWorker - ] - where - merge = mconcatPair . map (first pure) - -informerWorker :: BlockWorkMode ctx m => (WorkerSpec m, OutSpecs) + :: ( BlockWorkMode ctx m + , HasMisbehaviorMetrics ctx + ) + => ProtocolMagic -> [Diffusion m -> m ()] +blkWorkers pm = + [ blkCreatorWorker pm + , informerWorker + , retrievalWorker pm + , recoveryTriggerWorker pm + ] + +informerWorker + :: ( BlockWorkMode ctx m + ) => Diffusion m -> m () informerWorker = - onNewSlotWorker defaultOnNewSlotParams mempty $ \slotId _ -> + \_ -> onNewSlot defaultOnNewSlotParams $ \slotId -> recoveryCommGuard "onNewSlot worker, informerWorker" $ do tipHeader <- DB.getTipHeader -- Printe tip header @@ -101,11 +101,14 @@ informerWorker = -- Block creation worker ---------------------------------------------------------------------------- -blkCreatorWorker :: BlockWorkMode ctx m => (WorkerSpec m, OutSpecs) -blkCreatorWorker = - onNewSlotWorker onsp mempty $ \slotId diffusion -> +blkCreatorWorker + :: ( BlockWorkMode ctx m + , HasMisbehaviorMetrics ctx + ) => ProtocolMagic -> Diffusion m -> m () +blkCreatorWorker pm = + \diffusion -> onNewSlot onsp $ \slotId -> recoveryCommGuard "onNewSlot worker, blkCreatorWorker" $ - blockCreator slotId diffusion `catchAny` onBlockCreatorException + blockCreator pm slotId diffusion `catchAny` onBlockCreatorException where onBlockCreatorException = reportOrLogE "blockCreator failed: " onsp :: OnNewSlotParams @@ -114,12 +117,14 @@ blkCreatorWorker = {onspTerminationPolicy = NewSlotTerminationPolicy "block creator"} blockCreator - :: BlockWorkMode ctx m - => SlotId -> Diffusion m -> m () -blockCreator (slotId@SlotId {..}) diffusion = do + :: ( BlockWorkMode ctx m + , HasMisbehaviorMetrics ctx + ) + => ProtocolMagic -> SlotId -> Diffusion m -> m () +blockCreator pm (slotId@SlotId {..}) diffusion = do -- First of all we create genesis block if necessary. - mGenBlock <- createGenesisBlockAndApply siEpoch + mGenBlock <- createGenesisBlockAndApply pm siEpoch whenJust mGenBlock $ \createdBlk -> do logInfo $ sformat ("Created genesis block:\n" %build) createdBlk jsonLog $ jlCreatedBlock (Left createdBlk) @@ -171,18 +176,21 @@ blockCreator (slotId@SlotId {..}) diffusion = do "delegated by heavy psk: "%build) ourHeavyPsk | weAreLeader -> - onNewSlotWhenLeader slotId Nothing diffusion + onNewSlotWhenLeader pm slotId Nothing diffusion | heavyWeAreDelegate -> let pske = swap <$> dlgTransM - in onNewSlotWhenLeader slotId pske diffusion + in onNewSlotWhenLeader pm slotId pske diffusion | otherwise -> pass onNewSlotWhenLeader - :: BlockWorkMode ctx m - => SlotId + :: ( BlockWorkMode ctx m + ) + => ProtocolMagic + -> SlotId -> ProxySKBlockInfo - -> Worker m -onNewSlotWhenLeader slotId pske diffusion = do + -> Diffusion m + -> m () +onNewSlotWhenLeader pm slotId pske diffusion = do let logReason = sformat ("I have a right to create a block for the slot "%slotIdF%" ") slotId @@ -202,7 +210,7 @@ onNewSlotWhenLeader slotId pske diffusion = do where onNewSlotWhenLeaderDo = do logInfoS "It's time to create a block for current slot" - createdBlock <- createMainBlockAndApply slotId pske + createdBlock <- createMainBlockAndApply pm slotId pske either whenNotCreated whenCreated createdBlock logInfoS "onNewSlotWhenLeader: done" whenCreated createdBlk = do @@ -216,26 +224,22 @@ onNewSlotWhenLeader slotId pske diffusion = do -- Recovery trigger worker ---------------------------------------------------------------------------- -recoveryTriggerWorker :: - forall ctx m. (BlockWorkMode ctx m) - => (WorkerSpec m, OutSpecs) -recoveryTriggerWorker = - worker (requestTipOuts (Proxy :: Proxy m)) recoveryTriggerWorkerImpl - -recoveryTriggerWorkerImpl +recoveryTriggerWorker :: forall ctx m. - (BlockWorkMode ctx m) - => Diffusion m -> m () -recoveryTriggerWorkerImpl diffusion = do + ( BlockWorkMode ctx m + ) + => ProtocolMagic -> Diffusion m -> m () +recoveryTriggerWorker pm diffusion = do -- Initial heuristic delay is needed (the system takes some time -- to initialize). - delay $ sec 3 + -- TBD why 3 seconds? Why delay at all? Come on, we can do better. + delay (3 :: Second) repeatOnInterval $ do doTrigger <- needTriggerRecovery <$> getSyncStatusK when doTrigger $ do logInfo "Triggering recovery because we need it" - triggerRecovery diffusion + triggerRecovery pm diffusion -- Sometimes we want to trigger recovery just in case. Maybe -- we're just 5 slots late, but nobody wants to send us @@ -250,7 +254,7 @@ recoveryTriggerWorkerImpl diffusion = do logInfo "Checking if we need recovery as a safety measure" whenM (needTriggerRecovery <$> getSyncStatus 5) $ do logInfo "Triggering recovery as a safety measure" - triggerRecovery diffusion + triggerRecovery pm diffusion -- We don't want to ask for tips too frequently. -- E.g. there may be a tip processing mistake so that we @@ -258,14 +262,14 @@ recoveryTriggerWorkerImpl diffusion = do -- headers. Or it may happen that we will receive only -- useless broken tips for some reason (attack?). This -- will minimize risks and network load. - when (doTrigger || triggerSafety) $ delay $ sec 20 + when (doTrigger || triggerSafety) $ delay (20 :: Second) where repeatOnInterval action = void $ do - delay $ sec 1 + delay (1 :: Second) -- REPORT:ERROR 'reportOrLogE' in recovery trigger worker void $ action `catchAny` \e -> do reportOrLogE "recoveryTriggerWorker" e - delay $ sec 15 + delay (15 :: Second) repeatOnInterval action ---------------------------------------------------------------------------- @@ -281,7 +285,7 @@ recoveryTriggerWorkerImpl diffusion = do -- -- Apart from chain quality check we also record some generally useful values. metricWorker - :: forall ctx m. BlockWorkMode ctx m + :: BlockWorkMode ctx m => SlotId -> m () metricWorker curSlot = do OldestFirst lastSlots <- slogGetLastSlots @@ -354,7 +358,8 @@ reportCrucialValues = do ---------------------------------------------------------------------------- chainQualityChecker :: - forall ctx m. BlockWorkMode ctx m + ( BlockWorkMode ctx m + ) => SlotId -> FlatSlotId -> m () @@ -374,7 +379,7 @@ chainQualityChecker curSlot kThSlot = do -- Monitor for chain quality for last k blocks. cqkMetricMonitor :: - (HasBlockConfiguration, HasConfiguration) + ( HasBlockConfiguration, HasProtocolConstants ) => MetricMonitorState Double -> Bool -> MetricMonitor Double @@ -393,7 +398,7 @@ cqkMetricMonitor st isBootstrapEra = classifier :: Microsecond -> Maybe Double -> Double -> Maybe Bool classifier timePassed prevVal newVal -- report at most once per 400 sec, unless decreased - | not decreased && timePassed < sec 400 = Nothing + | not decreased && timePassed < fromMicroseconds 400000000 = Nothing | newVal < criticalThreshold = Just True | newVal < nonCriticalThreshold = Just False | otherwise = Nothing diff --git a/block/src/Pos/DB/Block.hs b/block/src/Pos/DB/Block.hs index 6cec7fb2832..ddf9098de85 100644 --- a/block/src/Pos/DB/Block.hs +++ b/block/src/Pos/DB/Block.hs @@ -31,7 +31,6 @@ module Pos.DB.Block , dbPutSerBlundsSumDefault ) where -import Nub (ordNub) import Universum import Control.Exception.Safe (handle) @@ -39,23 +38,23 @@ import Control.Lens (at) import qualified Data.ByteString as BS (hPut, readFile) import Data.Default (Default (def)) import Formatting (formatToString) -import System.Directory (createDirectoryIfMissing, removeFile) +import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile) import System.FilePath (()) import System.IO (IOMode (WriteMode), hClose, hFlush, openBinaryFile) import System.IO.Error (IOError, isDoesNotExistError) import Pos.Binary.Block.Types () -import Pos.Binary.Class (Bi, decodeFull', serialize') +import Pos.Binary.Class (decodeFull', serialize') import Pos.Binary.Core () import Pos.Block.BHelpers () -import Pos.Block.Types (Blund, SerializedBlund, SlogUndo (..), Undo (..)) -import Pos.Core (HasConfiguration, HeaderHash, headerHash) +import Pos.Block.Types (Blund, SlogUndo (..), Undo (..)) +import Pos.Core (HeaderHash, headerHash) import Pos.Core.Block (Block, GenesisBlock) import qualified Pos.Core.Block as CB import Pos.Crypto (hashHexF) import Pos.DB.BlockIndex (deleteHeaderIndex, putHeadersIndex) import Pos.DB.Class (MonadDB (..), MonadDBRead (..), Serialized (..), SerializedBlock, - SerializedUndo, getBlock, getDeserialized) + SerializedUndo, SerializedBlund, getBlock, getDeserialized) import Pos.DB.Error (DBError (..)) import Pos.DB.GState.Common (getTipSomething) import Pos.DB.Pure (DBPureVar, MonadPureDB, atomicModifyIORefPure, pureBlocksStorage) @@ -73,14 +72,23 @@ getUndo = getDeserialized dbGetSerUndo -- | Convenient wrapper which combines 'dbGetBlock' and 'dbGetUndo' to -- read 'Blund'. +-- +-- TODO Rewrite to use a single call getBlund :: MonadDBRead m => HeaderHash -> m (Maybe (Block, Undo)) getBlund x = runMaybeT $ (,) <$> MaybeT (getBlock x) <*> MaybeT (getUndo x) +-- | Store blunds into a single file. +-- +-- Notice that this uses an unusual encoding, in order to be able to fetch +-- either the block or the undo independently without re-encoding. putBlunds :: MonadDB m => NonEmpty Blund -> m () -putBlunds = dbPutSerBlunds . map (fmap (Serialized . serialize')) +putBlunds = dbPutSerBlunds + . map (\bu@(b,_) -> ( CB.getBlockHeader b + , Serialized . serialize' $ bimap serialize' serialize' bu) + ) -- | Get 'Block' corresponding to tip. getTipBlock :: MonadDBRead m => m Block @@ -92,40 +100,81 @@ getTipBlock = getTipSomething "block" getBlock -- Get serialization of a block with given hash from Block DB. getSerializedBlock - :: forall ctx m. (HasConfiguration, MonadRealDB ctx m) + :: forall ctx m. (MonadRealDB ctx m) => HeaderHash -> m (Maybe ByteString) -getSerializedBlock = blockDataPath >=> getRawData +getSerializedBlock hh = do + bsp <- flip getAllPaths hh . view blockDataDir <$> getNodeDBs + blundExists <- liftIO $ doesFileExist (bspBlund bsp) + if blundExists + then do + mbs <- getRawData $ bspBlund bsp + case mbs of + Nothing -> pure Nothing + Just ser -> eitherToThrow $ bimap DBMalformed (Just . fst) + $ decodeFull' @(ByteString, ByteString) ser + else fmap fst <$> consolidateBlund hh -- Get serialization of an undo data for block with given hash from Block DB. -getSerializedUndo :: (HasConfiguration, MonadRealDB ctx m) => HeaderHash -> m (Maybe ByteString) -getSerializedUndo = undoDataPath >=> getRawData - --- For every blund, put given block, its metadata and Undo data into --- Block DB. This function uses 'MonadRealDB' constraint which is too --- severe. Consider using 'dbPutBlund' instead. +getSerializedUndo :: MonadRealDB ctx m => HeaderHash -> m (Maybe ByteString) +getSerializedUndo hh = do + bsp <- flip getAllPaths hh . view blockDataDir <$> getNodeDBs + blundExists <- liftIO $ doesFileExist (bspBlund bsp) + if blundExists + then do + mbs <- getRawData $ bspBlund bsp + case mbs of + Nothing -> pure Nothing + Just ser -> eitherToThrow $ bimap DBMalformed (Just . snd) + $ decodeFull' @(ByteString, ByteString) ser + else fmap snd <$> consolidateBlund hh + +-- | Read independent block and undo data and consolidate them into a single +-- blund file. +consolidateBlund + :: MonadRealDB ctx m + => HeaderHash + -> m (Maybe (ByteString, ByteString)) +consolidateBlund hh = do + bsp <- flip getAllPaths hh . view blockDataDir <$> getNodeDBs + block <- getRawData $ bspBlock bsp + undo <- getRawData $ bspUndo bsp + case (,) <$> block <*> undo of + Just blund -> do + putRawData (bspBlund bsp) $ serialize' blund + liftIO . removeFile $ bspBlock bsp + liftIO . removeFile $ bspUndo bsp + return $ Just blund + Nothing -> return Nothing + + +-- For every blund, put given block, its metadata and Undo data into Block DB. +-- +-- TODO What does this comment mean? If the constraint isn't needed, why is it +-- here? The referenced 'dbPutBlund' function doesn't even exist. +-- +-- This function uses 'MonadRealDB' constraint which is too severe. +-- Consider using 'dbPutBlund' instead. putSerializedBlunds - :: (HasConfiguration, MonadRealDB ctx m, MonadDB m) - => NonEmpty SerializedBlund -> m () + :: (MonadRealDB ctx m, MonadDB m) + => NonEmpty (CB.BlockHeader, SerializedBlund) -> m () putSerializedBlunds (toList -> bs) = do bdd <- view blockDataDir <$> getNodeDBs - let allData = map (\(b,u) -> let (dP, bP, uP) = getAllPaths bdd (headerHash b) - in (dP,(b,u,bP,uP)) + let allData = map (\(bh,bu) -> let bsp = getAllPaths bdd (headerHash bh) + in (bspRoot bsp,(bu, bspBlund bsp)) ) bs forM_ (ordNub $ map fst allData) $ \dPath -> liftIO $ createDirectoryIfMissing False dPath - forM_ (map snd allData) $ \(blk,serUndo,bPath,uPath) -> do - putData bPath blk - putRawData uPath (unSerialized serUndo) - putHeadersIndex $ toList $ map (CB.getBlockHeader . fst) bs + forM_ (map snd allData) $ \(blund,buPath) -> do + putRawData buPath $ unSerialized blund + putHeadersIndex $ toList $ map fst bs deleteBlock :: (MonadRealDB ctx m, MonadDB m) => HeaderHash -> m () deleteBlock hh = do deleteHeaderIndex hh bdd <- view blockDataDir <$> getNodeDBs - let (_, bPath, uPath) = getAllPaths bdd hh - deleteData bPath - deleteData uPath + let bsp = getAllPaths bdd hh + mapM_ deleteData [bspBlock bsp, bspUndo bsp, bspBlund bsp] ---------------------------------------------------------------------------- -- Initialization @@ -135,7 +184,9 @@ prepareBlockDB :: MonadDB m => GenesisBlock -> m () prepareBlockDB blk = - dbPutSerBlunds $ one (Left blk, Serialized $ serialize' genesisUndo) + dbPutSerBlunds + $ one ( CB.getBlockHeader $ Left blk + , Serialized . serialize' $ bimap (serialize' @Block) serialize' (Left blk, genesisUndo)) where genesisUndo = Undo @@ -149,49 +200,40 @@ prepareBlockDB blk = -- Pure implementation ---------------------------------------------------------------------------- -decodeOrFailPureDB - :: HasConfiguration - => ByteString - -> Either Text (Block, Undo) -decodeOrFailPureDB = decodeFull' - -dbGetBlundPureDefault :: - (HasConfiguration, MonadPureDB ctx m) +dbGetSerBlockPureDefault + :: (MonadPureDB ctx m) => HeaderHash - -> m (Maybe (Block, Undo)) -dbGetBlundPureDefault h = do - (blund :: Maybe ByteString) <- + -> m (Maybe SerializedBlock) +dbGetSerBlockPureDefault h = do + (serblund :: Maybe ByteString) <- view (pureBlocksStorage . at h) <$> (view (lensOf @DBPureVar) >>= readIORef) - case decodeOrFailPureDB <$> blund of + case decodeFull' @(ByteString, ByteString) <$> serblund of Nothing -> pure Nothing Just (Left e) -> throwM (DBMalformed e) - Just (Right v) -> pure (Just v) - -dbGetSerBlockPureDefault - :: (HasConfiguration, MonadPureDB ctx m) - => HeaderHash - -> m (Maybe SerializedBlock) -dbGetSerBlockPureDefault h = (Serialized . serialize' . fst) <<$>> dbGetBlundPureDefault h + Just (Right v) -> pure . Just . Serialized $ fst v dbGetSerUndoPureDefault - :: forall ctx m. (HasConfiguration, MonadPureDB ctx m) + :: forall ctx m. (MonadPureDB ctx m) => HeaderHash -> m (Maybe SerializedUndo) -dbGetSerUndoPureDefault h = (Serialized . serialize' . snd) <<$>> dbGetBlundPureDefault h +dbGetSerUndoPureDefault h = do + (serblund :: Maybe ByteString) <- + view (pureBlocksStorage . at h) <$> (view (lensOf @DBPureVar) >>= readIORef) + case decodeFull' @(ByteString, ByteString) <$> serblund of + Nothing -> pure Nothing + Just (Left e) -> throwM (DBMalformed e) + Just (Right v) -> pure . Just . Serialized $ snd v dbPutSerBlundsPureDefault :: - forall ctx m. (HasConfiguration, MonadPureDB ctx m, MonadDB m) - => NonEmpty SerializedBlund + forall ctx m. (MonadPureDB ctx m, MonadDB m) + => NonEmpty (CB.BlockHeader, SerializedBlund) -> m () dbPutSerBlundsPureDefault (toList -> blunds) = do - forM_ blunds $ \(blk, serUndo) -> do - undo <- eitherToThrow $ first DBMalformed $ decodeFull' $ unSerialized serUndo - let blund :: Blund -- explicit signature is required - blund = (blk,undo) + forM_ blunds $ \(bh, serBlund) -> do (var :: DBPureVar) <- view (lensOf @DBPureVar) flip atomicModifyIORefPure var $ - (pureBlocksStorage . at (headerHash blk) .~ Just (serialize' blund)) - putHeadersIndex $ map (CB.getBlockHeader . fst) blunds + (pureBlocksStorage . at (headerHash bh) .~ Just (unSerialized serBlund)) + putHeadersIndex $ map fst blunds ---------------------------------------------------------------------------- -- Rocks implementation @@ -202,7 +244,6 @@ dbPutSerBlundsPureDefault (toList -> blunds) = do type BlockDBGenericEnv ctx m = ( MonadDBRead m , MonadRealDB ctx m - , HasConfiguration ) dbGetSerBlockRealDefault :: @@ -218,8 +259,8 @@ dbGetSerUndoRealDefault :: dbGetSerUndoRealDefault x = Serialized <<$>> getSerializedUndo x dbPutSerBlundsRealDefault :: - (HasConfiguration, MonadDB m, MonadRealDB ctx m) - => NonEmpty SerializedBlund + (MonadDB m, MonadRealDB ctx m) + => NonEmpty (CB.BlockHeader, SerializedBlund) -> m () dbPutSerBlundsRealDefault = putSerializedBlunds @@ -230,7 +271,6 @@ dbPutSerBlundsRealDefault = putSerializedBlunds type DBSumEnv ctx m = ( MonadDB m , MonadDBSum ctx m - , HasConfiguration ) dbGetSerBlockSumDefault @@ -246,7 +286,7 @@ dbGetSerUndoSumDefault hh = dbPutSerBlundsSumDefault :: forall ctx m. (DBSumEnv ctx m) - => NonEmpty SerializedBlund -> m () + => NonEmpty (CB.BlockHeader, SerializedBlund) -> m () dbPutSerBlundsSumDefault b = eitherDB (dbPutSerBlundsRealDefault b) (dbPutSerBlundsPureDefault b) @@ -262,9 +302,6 @@ getRawData = handle handler . fmap Just . liftIO . BS.readFile | isDoesNotExistError e = pure Nothing | otherwise = throwM e -putData :: (MonadIO m, Bi v) => FilePath -> v -> m () -putData fp = putRawData fp . serialize' - putRawData :: MonadIO m => FilePath -> ByteString -> m () putRawData fp v = liftIO $ bracket (openBinaryFile fp WriteMode) hClose $ \h -> @@ -277,21 +314,24 @@ deleteData fp = (liftIO $ removeFile fp) `catch` handler | isDoesNotExistError e = pure () | otherwise = throwM e -blockDataPath :: MonadRealDB ctx m => HeaderHash -> m FilePath -blockDataPath hh = do - bdd <- view blockDataDir <$> getNodeDBs - pure $ (view _2) $ getAllPaths bdd hh - -undoDataPath :: MonadRealDB ctx m => HeaderHash -> m FilePath -undoDataPath hh = do - bdd <- view blockDataDir <$> getNodeDBs - pure $ (view _3) $ getAllPaths bdd hh +-- | Paths at which we store the block data. +data BlockStoragePaths = BlockStoragePaths + { bspRoot :: FilePath + -- | Block data itself. + , bspBlock :: FilePath + -- | Undo information for a block. + , bspUndo :: FilePath + -- | Combined storage format. Either this or a combination of 'Block' and + -- 'Undo' files will be present. + , bspBlund :: FilePath + } -- | Pass blockDataDir path -getAllPaths :: FilePath -> HeaderHash -> (FilePath, FilePath, FilePath) -getAllPaths bdd hh = (dir,bl,un) +getAllPaths :: FilePath -> HeaderHash -> BlockStoragePaths +getAllPaths bdd hh = BlockStoragePaths dir bl un blund where (fn0, fn1) = splitAt 2 $ formatToString hashHexF hh dir = bdd fn0 bl = dir (fn1 <> ".block") un = dir (fn1 <> ".undo") + blund = dir (fn1 <> ".blund") diff --git a/block/src/Pos/DB/Block/Load.hs b/block/src/Pos/DB/Block/Load.hs index 0fb3d59afdf..4c4e6be7882 100644 --- a/block/src/Pos/DB/Block/Load.hs +++ b/block/src/Pos/DB/Block/Load.hs @@ -21,8 +21,8 @@ import Formatting (sformat, (%)) import Pos.Binary.Core () import Pos.Block.Types (Blund) -import Pos.Core (BlockCount, HasConfiguration, HasDifficulty (difficultyL), - HasPrevBlock (prevBlockL), HeaderHash) +import Pos.Core (BlockCount, HasDifficulty (difficultyL), + HasPrevBlock (prevBlockL), HeaderHash, HasGenesisHash) import Pos.Core.Block (Block, BlockHeader) import Pos.Core.Configuration (genesisHash) import Pos.Crypto (shortHashF) @@ -31,12 +31,11 @@ import Pos.DB.BlockIndex (getHeader) import Pos.DB.Class (MonadBlockDBRead, MonadDBRead, getBlock) import Pos.DB.Error (DBError (..)) import Pos.DB.GState.Common (getTip) -import Pos.Util.Chrono (NewestFirst (..)) +import Pos.Core.Chrono (NewestFirst (..)) import Pos.Util.Util (maybeThrow) type LoadHeadersMode m = - ( HasConfiguration - , MonadDBRead m + ( MonadDBRead m ) ---------------------------------------------------------------------------- @@ -45,7 +44,7 @@ type LoadHeadersMode m = loadDataWhile :: forall m a . - (Monad m, HasPrevBlock a, HasConfiguration) + (Monad m, HasPrevBlock a, HasGenesisHash) => (HeaderHash -> m a) -> (a -> Bool) -> HeaderHash @@ -66,7 +65,7 @@ loadDataWhile getter predicate start = NewestFirst <$> doIt [] start -- (newest one) is assumed to have depth 0. loadDataByDepth :: forall m a . - (Monad m, HasPrevBlock a, HasDifficulty a, HasConfiguration) + (Monad m, HasPrevBlock a, HasDifficulty a, HasGenesisHash) => (HeaderHash -> m a) -> (a -> Bool) -> BlockCount diff --git a/block/src/Pos/GState/BlockExtra.hs b/block/src/Pos/GState/BlockExtra.hs index 1e4d2d575cd..aec019c8138 100644 --- a/block/src/Pos/GState/BlockExtra.hs +++ b/block/src/Pos/GState/BlockExtra.hs @@ -15,26 +15,28 @@ module Pos.GState.BlockExtra , loadHeadersUpWhile , loadBlocksUpWhile , initGStateBlockExtra + , streamBlocks ) where -import Universum +import Universum hiding (init) import qualified Data.Text.Buildable import qualified Database.RocksDB as Rocks import Formatting (bprint, build, (%)) +import Pipes (Producer, yield) import Serokell.Util.Text (listJson) import Pos.Binary.Class (serialize') import Pos.Block.Slog.Types (LastBlkSlots, noLastBlkSlots) -import Pos.Core (FlatSlotId, HasConfiguration, HasHeaderHash, HeaderHash, genesisHash, - headerHash, slotIdF, unflattenSlotId) +import Pos.Core (FlatSlotId, HasHeaderHash, HeaderHash, genesisHash, HasProtocolConstants, + headerHash, slotIdF, unflattenSlotId, HasCoreConfiguration) import Pos.Core.Block (Block, BlockHeader) import Pos.Crypto (shortHashF) import Pos.DB (DBError (..), MonadDB, MonadDBRead (..), RocksBatchOp (..), dbSerializeValue, getHeader) -import Pos.DB.Class (MonadBlockDBRead, getBlock) +import Pos.DB.Class (MonadBlockDBRead, getBlock, SerializedBlock) import Pos.DB.GState.Common (gsGetBi, gsPutBi) -import Pos.Util.Chrono (OldestFirst (..)) +import Pos.Core.Chrono (OldestFirst (..)) import Pos.Util.Util (maybeThrow) ---------------------------------------------------------------------------- @@ -62,7 +64,7 @@ getLastSlots = gsGetBi lastSlotsKey -- | Retrieves first genesis block hash. -getFirstGenesisBlockHash :: (MonadDBRead m, MonadThrow m) => m HeaderHash +getFirstGenesisBlockHash :: MonadDBRead m => m HeaderHash getFirstGenesisBlockHash = resolveForwardLink (genesisHash :: HeaderHash) >>= maybeThrow (DBMalformed "Can't retrieve genesis block, maybe db is not initialized?") @@ -84,7 +86,7 @@ data BlockExtraOp -- ^ Updates list of slots for last blocks. deriving (Show) -instance HasConfiguration => Buildable BlockExtraOp where +instance HasProtocolConstants => Buildable BlockExtraOp where build (AddForwardLink from to) = bprint ("AddForwardLink from "%shortHashF%" to "%shortHashF) from to build (RemoveForwardLink from) = @@ -95,7 +97,7 @@ instance HasConfiguration => Buildable BlockExtraOp where bprint ("SetLastSlots: "%listJson) (map (bprint slotIdF . unflattenSlotId) slots) -instance HasConfiguration => RocksBatchOp BlockExtraOp where +instance HasCoreConfiguration => RocksBatchOp BlockExtraOp where toBatchOp (AddForwardLink from to) = [Rocks.Put (forwardLinkKey from) (dbSerializeValue to)] toBatchOp (RemoveForwardLink from) = @@ -111,6 +113,29 @@ instance HasConfiguration => RocksBatchOp BlockExtraOp where -- Loops on forward links ---------------------------------------------------------------------------- +-- | Creates a Producer for blocks from a given HeaderHash, exclusive: the +-- block for that hash is not produced, its child is the first thing produced. +streamBlocks + :: ( Monad m ) + => (HeaderHash -> m (Maybe SerializedBlock)) + -> (HeaderHash -> m (Maybe HeaderHash)) + -> HeaderHash + -> Producer SerializedBlock m () +streamBlocks loadBlock forwardLink base = do + mFirst <- lift $ forwardLink base + maybe (pure ()) loop mFirst + where + loop hhash = do + mb <- lift $ loadBlock hhash + case mb of + Nothing -> pure () + Just block -> do + yield block + mNext <- lift $ forwardLink hhash + case mNext of + Nothing -> pure () + Just hhash' -> loop hhash' + foldlUpWhileM :: forall a b m r . ( MonadDBRead m diff --git a/block/src/Pos/GState/SanityCheck.hs b/block/src/Pos/GState/SanityCheck.hs index 755cb0b5bc3..3f2416ea144 100644 --- a/block/src/Pos/GState/SanityCheck.hs +++ b/block/src/Pos/GState/SanityCheck.hs @@ -19,19 +19,16 @@ sanityCheckDB :: , WithLogger m , MonadDBRead m , MonadUnliftIO m - , MonadReader ctx m ) => m () sanityCheckDB = inAssertMode sanityCheckGStateDB -- | Check that GState DB is consistent. sanityCheckGStateDB :: - forall ctx m. + forall m. ( MonadDBRead m , MonadUnliftIO m - , MonadMask m , WithLogger m - , MonadReader ctx m ) => m () sanityCheckGStateDB = do diff --git a/block/src/Pos/Lrc/Consumers.hs b/block/src/Pos/Lrc/Consumers.hs deleted file mode 100644 index 4dfbb141493..00000000000 --- a/block/src/Pos/Lrc/Consumers.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE RankNTypes #-} - -module Pos.Lrc.Consumers - ( - allLrcConsumers - ) where - -import Pos.Delegation.Lrc (dlgLrcConsumer) -import Pos.Lrc.Consumer (LrcConsumer) -import Pos.Lrc.Mode (LrcMode) -import Pos.Ssc.Lrc (sscLrcConsumer) -import Pos.Ssc.Message (SscMessageConstraints) -import Pos.Update.Lrc (usLrcConsumer) - -allLrcConsumers - :: forall ctx m. (SscMessageConstraints m, LrcMode ctx m) - => [LrcConsumer m] -allLrcConsumers = [dlgLrcConsumer, usLrcConsumer, sscLrcConsumer] diff --git a/block/src/Pos/Lrc/DB/Richmen.hs b/block/src/Pos/Lrc/DB/Richmen.hs deleted file mode 100644 index a150bf81806..00000000000 --- a/block/src/Pos/Lrc/DB/Richmen.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeFamilies #-} - --- | Richmen part of LRC DB. - -module Pos.Lrc.DB.Richmen - ( - -- * Initialization - prepareLrcRichmen - - -- * Concrete instances - -- ** Ssc - , RCSsc - , tryGetSscRichmen - - -- ** US - , RCUs - , tryGetUSRichmen - - -- ** Delegation - , RCDlg - , tryGetDlgRichmen - - -- * Exported for tests - , richmenComponents - ) where - -import Universum - -import qualified Data.HashMap.Strict as HM - -import Pos.Binary.Core () -import Pos.Core (Coin, HasConfiguration, ProxySKHeavy, StakeholderId, addressHash, - gdHeavyDelegation, genesisData, unGenesisDelegation) -import Pos.Crypto (pskDelegatePk) -import Pos.DB.Class (MonadDB) -import Pos.Delegation.Lrc (RCDlg, tryGetDlgRichmen) -import Pos.Lrc.DB.RichmenBase (getRichmenP, putRichmenP) -import Pos.Lrc.Logic (RichmenType (..), findRichmenPure) -import Pos.Lrc.RichmenComponent (RichmenComponent (..), SomeRichmenComponent (..), - someRichmenComponent) -import Pos.Lrc.Types (FullRichmenData) -import Pos.Ssc.Lrc (RCSsc, tryGetSscRichmen) -import Pos.Txp.GenesisUtxo (genesisStakes) -import Pos.Update.Lrc (RCUs, tryGetUSRichmen) - ----------------------------------------------------------------------------- --- Initialization ----------------------------------------------------------------------------- - -prepareLrcRichmen :: - ( HasConfiguration - , MonadDB m - ) - => m () -prepareLrcRichmen = do - let genesisDistribution = HM.toList genesisStakes - genesisDelegation = unGenesisDelegation $ - gdHeavyDelegation genesisData - mapM_ (prepareLrcRichmenDo genesisDistribution genesisDelegation) - richmenComponents - where - prepareLrcRichmenDo distr deleg (SomeRichmenComponent proxy) = - whenNothingM_ (getRichmenP proxy 0) $ - putRichmenP proxy 0 (computeInitial distr deleg proxy) - -computeInitial - :: RichmenComponent c - => [(StakeholderId, Coin)] -- ^ Genesis distribution - -> HashMap StakeholderId ProxySKHeavy -- ^ Genesis delegation - -> Proxy c - -> FullRichmenData -computeInitial initialDistr initialDeleg proxy = - findRichmenPure - initialDistr - (rcInitialThreshold proxy) - richmenType - where - -- A reverse delegation map (keys = delegates, values = issuers). - -- Delegates must not be issuers so we can simply invert the map - -- without having to compute a transitive closure. - revDelegationMap = - HM.fromListWith (<>) $ - map (\(issuer, delegate) -> (delegate, one issuer)) $ - HM.toList $ map (addressHash . pskDelegatePk) initialDeleg - richmenType - | rcConsiderDelegated proxy = RTDelegation revDelegationMap - | otherwise = RTUsual - ----------------------------------------------------------------------------- --- Instances. They are here, because we want to have a DB schema in Pos.DB ----------------------------------------------------------------------------- - -richmenComponents :: HasConfiguration => [SomeRichmenComponent] -richmenComponents = - [ someRichmenComponent @RCSsc - , someRichmenComponent @RCUs - , someRichmenComponent @RCDlg - ] diff --git a/block/src/Pos/Lrc/Logic.hs b/block/src/Pos/Lrc/Logic.hs deleted file mode 100644 index 0ca5da09915..00000000000 --- a/block/src/Pos/Lrc/Logic.hs +++ /dev/null @@ -1,102 +0,0 @@ --- | Auxiliary functions for retrieval of richmen --- (with and without considering delegation) from the DB. - -module Pos.Lrc.Logic - ( findRichmenStakes - , findRichmenPure - , findAllRichmenMaybe - , findDelegatedRichmen - , RichmenType (..) - ) where - -import Universum - -import Data.Conduit (ConduitT, runConduitPure, runConduitRes, (.|)) -import qualified Data.Conduit.List as CL -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import UnliftIO (MonadUnliftIO) - -import Pos.Core (Coin, CoinPortion, StakeholderId, applyCoinPortionUp, sumCoins, - unsafeIntegerToCoin) -import Pos.DB.Class (MonadDBRead, MonadGState) -import Pos.DB.GState.Stakes (getRealStake) -import Pos.Delegation (getDelegators, isIssuerByAddressHash) -import Pos.Lrc.Core (findDelegationStakes, findRichmenStakes) -import Pos.Lrc.Types (FullRichmenData, RichmenStakes) - -type MonadDBReadFull m = (MonadDBRead m, MonadGState m, MonadUnliftIO m) - --- Can it be improved using conduits? --- | Find delegated richmen using precomputed usual richmen. --- Do it using one pass by delegation DB. -findDelRichUsingPrecomp - :: forall m. - (MonadDBReadFull m) - => RichmenStakes -> Coin -> m RichmenStakes -findDelRichUsingPrecomp precomputed thr = do - (old, new) <- - runConduitRes $ - getDelegators .| - findDelegationStakes isIssuerByAddressHash getRealStake thr - -- attention: order of new and precomputed is important - -- we want to use new stakes (computed from delegated) of precomputed richmen - pure (new `HM.union` (precomputed `HM.difference` (HS.toMap old))) - --- | Find delegated richmen. -findDelegatedRichmen - :: (MonadDBReadFull m) - => Coin -> ConduitT (StakeholderId, Coin) Void m RichmenStakes -findDelegatedRichmen thr = do - st <- findRichmenStakes thr - lift $ findDelRichUsingPrecomp st thr - --- | Function considers all variants of computation --- and compute using one pass by stake DB and one pass by delegation DB. -findAllRichmenMaybe - :: forall m. - (MonadDBReadFull m) - => Maybe Coin -- ^ Eligibility threshold (optional) - -> Maybe Coin -- ^ Delegation threshold (optional) - -> ConduitT (StakeholderId, Coin) Void m (RichmenStakes, RichmenStakes) -findAllRichmenMaybe maybeT maybeTD - | Just t <- maybeT - , Just tD <- maybeTD = do - let mn = min t tD - richmenMin <- findRichmenStakes mn - let richmen = HM.filter (>= t) richmenMin - let precomputedD = HM.filter (>= tD) richmenMin - richmenD <- lift $ findDelRichUsingPrecomp precomputedD tD - pure (richmen, richmenD) - | Just t <- maybeT = (,mempty) <$> findRichmenStakes t - | Just tD <- maybeTD = (mempty,) <$> findDelegatedRichmen tD - | otherwise = pure (mempty, mempty) - -data RichmenType - = RTUsual - -- | A map from delegates to issuers - | RTDelegation (HashMap StakeholderId (HashSet StakeholderId)) - --- | Pure version of 'findRichmen' which uses a list of stakeholders. -findRichmenPure :: [(StakeholderId, Coin)] - -> CoinPortion -- ^ Richman eligibility as % of total stake - -> RichmenType - -> FullRichmenData -findRichmenPure stakeDistribution threshold computeType - | RTDelegation delegationMap <- computeType = do - let issuers = mconcat $ HM.elems delegationMap - (old, new) = - runConduitPure $ - CL.sourceList (HM.toList delegationMap) .| - (findDelegationStakes - (pure . flip HS.member issuers) - (pure . flip HM.lookup stakeMap) thresholdCoin) - (total, new `HM.union` (usualRichmen `HM.difference` (HS.toMap old))) - | otherwise = (total, usualRichmen) - where - stakeMap = HM.fromList stakeDistribution - usualRichmen = - runConduitPure $ - CL.sourceList stakeDistribution .| findRichmenStakes thresholdCoin - total = unsafeIntegerToCoin $ sumCoins $ map snd stakeDistribution - thresholdCoin = applyCoinPortionUp threshold total diff --git a/block/test/LICENSE b/block/test/LICENSE new file mode 100644 index 00000000000..f7084dc7558 --- /dev/null +++ b/block/test/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2018 IOHK + +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 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. diff --git a/block/test/Setup.hs b/block/test/Setup.hs new file mode 100644 index 00000000000..9a994af677b --- /dev/null +++ b/block/test/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/block/src/Pos/Arbitrary/Block.hs b/block/test/Test/Pos/Block/Arbitrary.hs similarity index 66% rename from block/src/Pos/Arbitrary/Block.hs rename to block/test/Test/Pos/Block/Arbitrary.hs index d06b7bc207e..a9ee6bcec05 100644 --- a/block/src/Pos/Arbitrary/Block.hs +++ b/block/test/Test/Pos/Block/Arbitrary.hs @@ -1,8 +1,21 @@ -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -module Pos.Arbitrary.Block +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Test.Pos.Block.Arbitrary ( HeaderAndParams (..) , BlockHeaderList (..) + + , genMainBlockHeader + , genMainBlockBody + , genMainBlockBodyForSlot + , genMainBlock ) where import Universum @@ -14,22 +27,25 @@ import System.Random (Random, mkStdGen, randomR) import Test.QuickCheck (Arbitrary (..), Gen, choose, suchThat, vectorOf) import Test.QuickCheck.Arbitrary.Generic (genericArbitrary, genericShrink) -import Pos.Arbitrary.Delegation (genDlgPayload) -import Pos.Arbitrary.Ssc (SscPayloadDependsOnSlot (..)) -import Pos.Arbitrary.Txp () -import Pos.Arbitrary.Update () -import Pos.Binary.Class (Bi, Raw, biSize) -import qualified Pos.Block.Base as T +import Pos.Arbitrary.Ssc (SscPayloadDependsOnSlot (..), genSscPayload, + genSscPayloadForSlot) +import Pos.Arbitrary.Update (genUpdatePayload) +import Pos.Binary.Class (biSize) import qualified Pos.Block.Logic.Integrity as T -import Pos.Block.Slog.Types (SlogUndo) +import Pos.Block.Slog (SlogUndo) import Pos.Block.Types (Undo (..)) -import Pos.Core (HasConfiguration, epochSlots) +import Pos.Core (GenesisHash (..), HasGenesisHash, HasProtocolConstants, HeaderHash, + epochSlots, genesisHash) import qualified Pos.Core as Core import qualified Pos.Core.Block as T -import Pos.Core.Ssc (SscPayload, SscProof) -import Pos.Crypto (PublicKey, SecretKey, createPsk, hash, toPublic) +import Pos.Crypto (ProtocolMagic, PublicKey, SecretKey, createPsk, hash, toPublic) import Pos.Data.Attributes (areAttributesKnown) +import Test.Pos.Core.Arbitrary (genSlotId) +import Test.Pos.Crypto.Dummy (dummyProtocolMagic) +import Test.Pos.Delegation.Arbitrary (genDlgPayload) +import Test.Pos.Txp.Arbitrary (genTxPayload) + newtype BodyDependsOnSlot b = BodyDependsOnSlot { genBodyDepsOnSlot :: Core.SlotId -> Gen (T.Body b) } @@ -38,12 +54,11 @@ newtype BodyDependsOnSlot b = BodyDependsOnSlot -- Arbitrary instances for Blockchain related types ------------------------------------------------------------------------------------------ -instance HasConfiguration => Arbitrary T.BlockHeader where +instance HasProtocolConstants => Arbitrary T.BlockHeader where arbitrary = genericArbitrary shrink = genericShrink -instance (HasConfiguration, Arbitrary SscProof) => - Arbitrary T.BlockSignature where +instance HasProtocolConstants => Arbitrary T.BlockSignature where arbitrary = genericArbitrary shrink = genericShrink @@ -59,49 +74,62 @@ instance Arbitrary T.GenesisExtraBodyData where arbitrary = genericArbitrary shrink = genericShrink -instance HasConfiguration => Arbitrary T.GenesisBlockHeader where +instance Arbitrary T.GenesisBlockHeader where arbitrary = genericArbitrary shrink = genericShrink -instance Arbitrary (T.BodyProof T.GenesisBlockchain) where +instance Arbitrary T.GenesisProof where arbitrary = genericArbitrary shrink = genericShrink -instance Arbitrary (T.ConsensusData T.GenesisBlockchain) where +instance Arbitrary T.GenesisConsensusData where arbitrary = genericArbitrary shrink = genericShrink instance Arbitrary (BodyDependsOnSlot T.GenesisBlockchain) where arbitrary = pure $ BodyDependsOnSlot $ \_ -> arbitrary -instance Arbitrary (T.Body T.GenesisBlockchain) where +instance Arbitrary T.GenesisBody where arbitrary = genericArbitrary shrink = genericShrink -instance ( Arbitrary SscProof - , Arbitrary SscPayload - , HasConfiguration +instance ( HasProtocolConstants + , HasGenesisHash ) => Arbitrary T.GenesisBlock where - arbitrary = T.mkGenesisBlock <$> arbitrary <*> arbitrary <*> arbitrary + arbitrary = T.mkGenesisBlock dummyProtocolMagic + <$> (maybe (Left (GenesisHash genesisHash)) Right <$> arbitrary) + <*> arbitrary + <*> arbitrary shrink = genericShrink ------------------------------------------------------------------------------------------ -- MainBlockchain ------------------------------------------------------------------------------------------ -instance ( Arbitrary SscPayload - , Arbitrary SscProof - , Bi Raw - , HasConfiguration - ) => - Arbitrary T.MainBlockHeader where - arbitrary = - T.mkMainHeader <$> arbitrary <*> arbitrary <*> arbitrary <*> - -- TODO: do not hardcode Nothing - pure Nothing <*> - arbitrary <*> - arbitrary +-- | Generate a 'MainBlockHeader' given a parent hash, difficulty and body. +genMainBlockHeader + :: ProtocolMagic + -> Core.ProtocolConstants + -> HeaderHash + -> Core.ChainDifficulty + -> T.MainBody + -> Gen T.MainBlockHeader +genMainBlockHeader pm pc prevHash difficulty body = + T.mkMainHeaderExplicit pm <$> pure prevHash + <*> pure difficulty + <*> genSlotId pc + <*> arbitrary -- SecretKey + <*> pure Nothing + <*> pure body + <*> arbitrary + +instance HasProtocolConstants => Arbitrary T.MainBlockHeader where + arbitrary = do + prevHash <- arbitrary + difficulty <- arbitrary + body <- arbitrary + genMainBlockHeader dummyProtocolMagic Core.protocolConstants prevHash difficulty body shrink = genericShrink instance Arbitrary T.MainExtraHeaderData where @@ -112,8 +140,7 @@ instance Arbitrary T.MainExtraBodyData where arbitrary = genericArbitrary shrink = genericShrink -instance (HasConfiguration, Arbitrary SscProof) => - Arbitrary (T.BodyProof T.MainBlockchain) where +instance Arbitrary T.MainProof where arbitrary = genericArbitrary shrink T.MainProof {..} = [T.MainProof txp mpcp prxp updp @@ -121,12 +148,11 @@ instance (HasConfiguration, Arbitrary SscProof) => shrink (mpTxProof, mpMpcProof, mpProxySKsProof, mpUpdateProof) ] -instance (HasConfiguration, Arbitrary SscProof) => - Arbitrary (T.ConsensusData T.MainBlockchain) where +instance HasProtocolConstants => Arbitrary T.MainConsensusData where arbitrary = genericArbitrary shrink = genericShrink -instance (HasConfiguration, Arbitrary SscProof) => Arbitrary T.MainToSign where +instance (HasProtocolConstants) => Arbitrary T.MainToSign where arbitrary = genericArbitrary shrink = genericShrink @@ -145,17 +171,39 @@ instance (HasConfiguration, Arbitrary SscProof) => Arbitrary T.MainToSign where {-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-} -instance (HasConfiguration, Arbitrary SscPayloadDependsOnSlot) => +genMainBlockBody + :: ProtocolMagic + -> Core.EpochIndex -- ^ For the delegation payload. + -> Gen T.MainBody +genMainBlockBody pm epoch = + T.MainBody <$> genTxPayload pm + <*> genSscPayload pm + <*> genDlgPayload pm epoch + <*> genUpdatePayload pm + +genMainBlockBodyForSlot + :: ProtocolMagic + -> Core.ProtocolConstants + -> Core.SlotId + -> Gen T.MainBody +genMainBlockBodyForSlot pm pc slotId = do + txpPayload <- genTxPayload pm + sscPayload <- genSscPayloadForSlot pm pc slotId + dlgPayload <- genDlgPayload pm (Core.siEpoch slotId) + updPayload <- genUpdatePayload pm + pure $ T.MainBody txpPayload sscPayload dlgPayload updPayload + +instance HasProtocolConstants => Arbitrary (BodyDependsOnSlot T.MainBlockchain) where arbitrary = pure $ BodyDependsOnSlot $ \slotId -> do txPayload <- arbitrary generator <- genPayloadDependsOnSlot <$> arbitrary mpcData <- generator slotId - dlgPayload <- genDlgPayload $ Core.siEpoch slotId + dlgPayload <- genDlgPayload dummyProtocolMagic $ Core.siEpoch slotId mpcUpload <- arbitrary return $ T.MainBody txPayload mpcData dlgPayload mpcUpload -instance (HasConfiguration, Arbitrary SscPayload) => Arbitrary (T.Body T.MainBlockchain) where +instance Arbitrary T.MainBody where arbitrary = genericArbitrary shrink mb = [ T.MainBody txp sscp dlgp updp @@ -166,15 +214,37 @@ instance (HasConfiguration, Arbitrary SscPayload) => Arbitrary (T.Body T.MainBlo mb ^. T.mbUpdatePayload) ] -instance ( Arbitrary SscPayload - , Arbitrary SscProof - , Arbitrary SscPayloadDependsOnSlot - , HasConfiguration +-- | Generate a main block (slot is chosen arbitrarily). +-- You choose the previous header hash. +genMainBlock + :: ProtocolMagic + -> Core.ProtocolConstants + -> HeaderHash + -> Core.ChainDifficulty + -> Gen T.MainBlock +genMainBlock pm pc prevHash difficulty = do + slot <- genSlotId pc + body <- genMainBlockBodyForSlot pm pc slot + extraBodyData <- arbitrary + extraHeaderData <- T.MainExtraHeaderData + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> pure (hash extraBodyData) + header <- T.mkMainHeaderExplicit pm prevHash difficulty slot + <$> arbitrary + <*> pure Nothing + <*> pure body + <*> pure extraHeaderData + pure $ T.UnsafeGenericBlock header body extraBodyData + +instance ( HasProtocolConstants + , HasGenesisHash ) => Arbitrary T.MainBlock where arbitrary = do slot <- arbitrary - BodyDependsOnSlot {..} <- arbitrary + BodyDependsOnSlot {..} <- arbitrary :: Gen (BodyDependsOnSlot T.MainBlockchain) body <- genBodyDepsOnSlot slot extraBodyData <- arbitrary extraHeaderData <- T.MainExtraHeaderData @@ -183,14 +253,17 @@ instance ( Arbitrary SscPayload <*> arbitrary <*> pure (hash extraBodyData) header <- - T.mkMainHeader <$> arbitrary <*> pure slot <*> arbitrary <*> - pure Nothing <*> - pure body <*> - pure extraHeaderData + T.mkMainHeader dummyProtocolMagic + <$> (maybe (Left (GenesisHash genesisHash)) Right <$> arbitrary) + <*> pure slot + <*> arbitrary + <*> pure Nothing + <*> pure body + <*> pure extraHeaderData return $ T.UnsafeGenericBlock header body extraBodyData shrink = genericShrink -instance Buildable T.BlockHeader => Buildable (T.BlockHeader, PublicKey) where +instance Buildable (T.BlockHeader, PublicKey) where build (block, key) = bprint ( build%"\n"% @@ -201,7 +274,7 @@ newtype BlockHeaderList = BHL { getHeaderList :: ([T.BlockHeader], [PublicKey]) } deriving (Eq) -instance Buildable T.BlockHeader => Show BlockHeaderList where +instance Show BlockHeaderList where show = toString . unlines . map pretty . uncurry zip . getHeaderList -- | Generation of arbitrary, valid headerchain along with a list of leaders @@ -225,26 +298,32 @@ instance Buildable T.BlockHeader => Show BlockHeaderList where -- * if an epoch is `n` slots long, every `n+1`-th block will be of the -- genesis kind. recursiveHeaderGen - :: ( Arbitrary SscPayload - , HasConfiguration + :: ( HasProtocolConstants -- Can't remove this unfortunately.... + -- We first have to make generators for + -- other things which are parameterized on + -- the constants and magic etc. so we can use + -- them in here. ) - => Bool -- ^ Whether to create genesis block before creating main block for 0th slot + => GenesisHash + -> Bool -- ^ Whether to create genesis block before creating main block for 0th slot -> [Either SecretKey (SecretKey, SecretKey)] -> [Core.SlotId] -> [T.BlockHeader] -> Gen [T.BlockHeader] -recursiveHeaderGen genesis +recursiveHeaderGen gHash + genesis (eitherOfLeader : leaders) (Core.SlotId{..} : rest) blockchain | genesis && Core.getSlotIndex siSlot == 0 = do gBody <- arbitrary - let gHeader = T.BlockHeaderGenesis $ T.mkGenesisHeader (head blockchain) siEpoch gBody + let pHeader = maybe (Left gHash) Right ((fmap fst . uncons) blockchain) + gHeader = T.BlockHeaderGenesis $ T.mkGenesisHeader dummyProtocolMagic pHeader siEpoch gBody mHeader <- genMainHeader (Just gHeader) - recursiveHeaderGen True leaders rest (mHeader : gHeader : blockchain) + recursiveHeaderGen gHash True leaders rest (mHeader : gHeader : blockchain) | otherwise = do - curHeader <- genMainHeader (head blockchain) - recursiveHeaderGen True leaders rest (curHeader : blockchain) + curHeader <- genMainHeader ((fmap fst . uncons) blockchain) + recursiveHeaderGen gHash True leaders rest (curHeader : blockchain) where genMainHeader prevHeader = do body <- arbitrary @@ -257,13 +336,13 @@ recursiveHeaderGen genesis Left sk -> (sk, Nothing) Right (issuerSK, delegateSK) -> let delegatePK = toPublic delegateSK - proxy = ( createPsk issuerSK delegatePK (Core.HeavyDlgIndex siEpoch) + proxy = ( createPsk dummyProtocolMagic issuerSK delegatePK (Core.HeavyDlgIndex siEpoch) , toPublic issuerSK) in (delegateSK, Just proxy) pure $ T.BlockHeaderMain $ - T.mkMainHeader prevHeader slotId leader proxySK body extraHData -recursiveHeaderGen _ [] _ b = return b -recursiveHeaderGen _ _ [] b = return b + T.mkMainHeader dummyProtocolMagic (maybe (Left gHash) Right prevHeader) slotId leader proxySK body extraHData +recursiveHeaderGen _ _ [] _ b = return b +recursiveHeaderGen _ _ _ [] b = return b -- | Maximum start epoch in block header verification tests @@ -291,25 +370,24 @@ bhlEpochs = 2 -- -- Note that a leader is generated for each slot. -- (Not exactly a leader - see previous comment) -instance ( Arbitrary SscPayload - , HasConfiguration +instance ( HasProtocolConstants + , HasGenesisHash ) => Arbitrary BlockHeaderList where arbitrary = do incompleteEpochSize <- choose (1, epochSlots - 1) let slot = Core.SlotId 0 minBound - generateBHL True slot (epochSlots * bhlEpochs + incompleteEpochSize) + generateBHL (GenesisHash genesisHash) True slot (epochSlots * bhlEpochs + incompleteEpochSize) generateBHL - :: ( Arbitrary SscPayload - , HasConfiguration - ) - => Bool -- ^ Whether to create genesis block before creating main + :: HasProtocolConstants -- See comment in recursiveHeaderGen + => GenesisHash + -> Bool -- ^ Whether to create genesis block before creating main -- block for 0th slot -> Core.SlotId -- ^ Start slot -> Core.SlotCount -- ^ Slot count -> Gen BlockHeaderList -generateBHL createInitGenesis startSlot slotCount = BHL <$> do +generateBHL gHash createInitGenesis startSlot slotCount = BHL <$> do let correctLeaderGen :: Gen (Either SecretKey (SecretKey, SecretKey)) correctLeaderGen = -- We don't want to create blocks with self-signed psks @@ -320,9 +398,11 @@ generateBHL createInitGenesis startSlot slotCount = BHL <$> do let actualLeaders = map (toPublic . either identity (view _1)) leadersList slotIdsRange = take (fromIntegral slotCount) $ - map Core.unflattenSlotId [Core.flattenSlotId startSlot ..] + map Core.unflattenSlotId + [Core.flattenSlotId startSlot ..] (, actualLeaders) <$> recursiveHeaderGen + gHash createInitGenesis leadersList slotIdsRange @@ -341,13 +421,14 @@ newtype HeaderAndParams = HAndP -- already been done in the 'Arbitrary' instance of the 'BlockHeaderList' -- type, so it is used here and at most 3 blocks are taken from the generated -- list. -instance (Arbitrary SscPayload, HasConfiguration) => +instance (HasProtocolConstants, HasGenesisHash) => Arbitrary HeaderAndParams where arbitrary = do -- This integer is used as a seed to randomly choose a slot down below seed <- arbitrary :: Gen Int startSlot <- Core.SlotId <$> choose (0, bhlMaxStartingEpoch) <*> arbitrary - (headers, leaders) <- first reverse . getHeaderList <$> (generateBHL True startSlot =<< choose (1, 2)) + (headers, leaders) <- first reverse . getHeaderList <$> + (generateBHL (GenesisHash genesisHash) True startSlot =<< choose (1, 2)) let num = length headers -- 'skip' is the random number of headers that should be skipped in -- the header chain. This ensures different parts of it are chosen @@ -412,6 +493,6 @@ instance Arbitrary SlogUndo where arbitrary = genericArbitrary shrink = genericShrink -instance HasConfiguration => Arbitrary Undo where +instance HasProtocolConstants => Arbitrary Undo where arbitrary = genericArbitrary shrink = genericShrink diff --git a/block/test/Test/Pos/Block/Arbitrary/Generate.hs b/block/test/Test/Pos/Block/Arbitrary/Generate.hs new file mode 100644 index 00000000000..225b25103bc --- /dev/null +++ b/block/test/Test/Pos/Block/Arbitrary/Generate.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | Utility to generate a random block using an Arbitrary instance. + +module Test.Pos.Block.Arbitrary.Generate + ( generateMainBlock + , generateMainBlockWithConfiguration + ) where + +import Test.QuickCheck (arbitrary) +import qualified Test.QuickCheck.Gen as QC +import qualified Test.QuickCheck.Random as QC + +import Pos.Core (HasGenesisHash, HasProtocolConstants, MainBlock, ProtocolConstants, + ProtocolMagic) + +-- Also brings in the 'Arbitrary' instance for 'MainBlock'. +import Test.Pos.Block.Arbitrary (genMainBlock) + +-- | Use 'Arbitrary' instances to generate a 'MainBlock'. +-- These require magical configurations. +generateMainBlockWithConfiguration + :: ( HasProtocolConstants + , HasGenesisHash + ) + => Int -- ^ Seed for random generator. + -> Int -- ^ Size of the generated value (see QuickCheck docs). + -> MainBlock +generateMainBlockWithConfiguration genSeed = QC.unGen arbitrary qcGen + where + qcGen = QC.mkQCGen genSeed + +-- | Get some arbitrary (probably invalid) 'MainBlock'. The previous header +-- hash and difficulty, body, etc. are all chosen at random. +generateMainBlock + :: ( ) + => ProtocolMagic + -> ProtocolConstants + -> Int + -> Int + -> MainBlock +generateMainBlock pm pc genSeed = QC.unGen generator qcGen + where + qcGen = QC.mkQCGen genSeed + generator = do + prevHash <- arbitrary + difficulty <- arbitrary + genMainBlock pm pc prevHash difficulty diff --git a/block/test/Test/Pos/Block/Arbitrary/Message.hs b/block/test/Test/Pos/Block/Arbitrary/Message.hs new file mode 100644 index 00000000000..16b1af9e32e --- /dev/null +++ b/block/test/Test/Pos/Block/Arbitrary/Message.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Test.Pos.Block.Arbitrary.Message + ( + ) where + +import Test.QuickCheck (Arbitrary (..)) +import Test.QuickCheck.Arbitrary.Generic (genericArbitrary, genericShrink) + +import Pos.Arbitrary.Ssc () +import Pos.Arbitrary.Update () +import qualified Pos.Block.Network.Types as T +import Pos.Core (HasGenesisHash, HasProtocolConstants) + +import Test.Pos.Block.Arbitrary () +import Test.Pos.Core.Chrono () + +------------------------------------------------------------------------------------------ +-- Block network types +------------------------------------------------------------------------------------------ + +instance Arbitrary T.MsgGetHeaders where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary T.MsgGetBlocks where + arbitrary = genericArbitrary + shrink = genericShrink + +instance HasProtocolConstants => Arbitrary T.MsgHeaders where + arbitrary = genericArbitrary + shrink = genericShrink + +instance (HasProtocolConstants, HasGenesisHash) => Arbitrary T.MsgBlock where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary T.MsgStream where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary T.MsgStreamStart where + arbitrary = genericArbitrary + shrink = genericShrink + +instance Arbitrary T.MsgStreamUpdate where + arbitrary = genericArbitrary + shrink = genericShrink + +instance ( HasProtocolConstants + , HasGenesisHash + ) => + Arbitrary T.MsgStreamBlock where + arbitrary = genericArbitrary + shrink = genericShrink diff --git a/block/test/cardano-sl-block-test.cabal b/block/test/cardano-sl-block-test.cabal new file mode 100644 index 00000000000..1455313fd26 --- /dev/null +++ b/block/test/cardano-sl-block-test.cabal @@ -0,0 +1,54 @@ +name: cardano-sl-block-test +version: 1.3.0 +synopsis: Cardano SL - block processing (tests) +description: QuickCheck Arbitrary instances for Cardano SL block + processing. +license: MIT +license-file: LICENSE +author: IOHK +maintainer: IOHK +copyright: 2018 IOHK +category: Currency +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: + Test.Pos.Block.Arbitrary + Test.Pos.Block.Arbitrary.Message + Test.Pos.Block.Arbitrary.Generate + + build-depends: QuickCheck + , base + , bytestring + , cardano-sl-binary + , cardano-sl-block + , cardano-sl-core + , cardano-sl-core-test + , cardano-sl-crypto + , cardano-sl-crypto-test + , cardano-sl-db + , cardano-sl-delegation + , cardano-sl-delegation-test + , cardano-sl-infra + , cardano-sl-lrc + , cardano-sl-lrc-test + , cardano-sl-networking + , cardano-sl-ssc + , cardano-sl-txp + , cardano-sl-txp-test + , cardano-sl-update + , cardano-sl-util + , cardano-sl-util-test + , formatting + , generic-arbitrary + , quickcheck-instances + , random + , text + , text-format + , universum + + default-language: Haskell2010 + + ghc-options: -Wall + -O2 diff --git a/client/cardano-sl-client.cabal b/client/cardano-sl-client.cabal index 7711b5fcede..767b7064264 100644 --- a/client/cardano-sl-client.cabal +++ b/client/cardano-sl-client.cabal @@ -1,5 +1,5 @@ name: cardano-sl-client -version: 1.2.1 +version: 1.3.0 synopsis: Cardano SL client modules description: Cardano SL client modules license: MIT @@ -33,6 +33,7 @@ library , cardano-sl-crypto , cardano-sl-db , cardano-sl-infra + , cardano-sl-lrc , cardano-sl-networking , cardano-sl-txp , cardano-sl-update @@ -81,7 +82,6 @@ library default-language: Haskell2010 ghc-options: -Wall - -fno-warn-orphans -O2 build-tools: cpphs >= 1.19 @@ -98,19 +98,20 @@ test-suite cardano-client-test type: exitcode-stdio-1.0 - build-depends: + build-depends: base , bytestring , cardano-sl , cardano-sl-client , cardano-sl-core , cardano-sl-crypto + , cardano-sl-crypto-test , cardano-sl-db - , cardano-sl-infra , cardano-sl-ssc , cardano-sl-txp , cardano-sl-update , cardano-sl-util + , cardano-sl-util-test , containers , formatting , hspec @@ -123,7 +124,6 @@ test-suite cardano-client-test ghc-options: -threaded -rtsopts -Wall - -fno-warn-orphans -- linker speed up for linux if os(linux) diff --git a/client/src/Pos/Client/KeyStorage.hs b/client/src/Pos/Client/KeyStorage.hs index 0c12d46bdcf..23e15513142 100644 --- a/client/src/Pos/Client/KeyStorage.hs +++ b/client/src/Pos/Client/KeyStorage.hs @@ -29,7 +29,6 @@ import Control.Lens ((<%=), (<>~)) import Serokell.Util (modifyTVarS) import System.Wlog (WithLogger) -import Pos.Binary.Crypto () import Pos.Crypto (EncryptedSecretKey, PassPhrase, SecretKey, hash, runSecureRandom, safeKeyGen) import Pos.Util.UserSecret (HasUserSecret (..), UserSecret, peekUserSecret, usKeys, @@ -76,9 +75,7 @@ getPrimaryKey = view usPrimKey <$> getSecret newtype AllUserSecrets = AllUserSecrets { getAllUserSecrets :: [EncryptedSecretKey] - } deriving (ToList, Container) - -type instance Element AllUserSecrets = EncryptedSecretKey + } deriving (Container) getSecretKeys :: MonadKeysRead m => m AllUserSecrets getSecretKeys = AllUserSecrets . view usKeys <$> getSecret diff --git a/client/src/Pos/Client/Txp.hs b/client/src/Pos/Client/Txp.hs index 456ba49dc8d..714ebb71dbf 100644 --- a/client/src/Pos/Client/Txp.hs +++ b/client/src/Pos/Client/Txp.hs @@ -1,3 +1,16 @@ -- | Reexport of Pos.Client.Txp.* modules. -{-# OPTIONS_GHC -F -pgmF autoexporter #-} +module Pos.Client.Txp + ( module Pos.Client.Txp.Addresses + , module Pos.Client.Txp.Balances + , module Pos.Client.Txp.History + , module Pos.Client.Txp.Network + , module Pos.Client.Txp.Util + ) where + +import Pos.Client.Txp.Addresses +import Pos.Client.Txp.Balances +import Pos.Client.Txp.History +import Pos.Client.Txp.Network +import Pos.Client.Txp.Util + diff --git a/client/src/Pos/Client/Txp/History.hs b/client/src/Pos/Client/Txp/History.hs index 5b13ee5ff72..27cd375ba95 100644 --- a/client/src/Pos/Client/Txp/History.hs +++ b/client/src/Pos/Client/Txp/History.hs @@ -33,23 +33,24 @@ import Control.Monad.Trans (MonadTrans) import qualified Data.Map.Strict as M (fromList, insert) import qualified Data.Text.Buildable import Formatting (bprint, build, (%)) +import JsonLog (CanJsonLog (..)) import Mockable (CurrentTime, Mockable) import Serokell.Util.Text (listJson) import System.Wlog (WithLogger) -import Pos.Block.Base (genesisBlock0) -import Pos.Core (Address, ChainDifficulty, HasConfiguration, Timestamp (..), difficultyL, - headerHash) +import Pos.Core (Address, ChainDifficulty, GenesisHash (..), HasConfiguration, + Timestamp (..), difficultyL, epochSlots, genesisHash, headerHash) import Pos.Core.Block (Block, MainBlock, mainBlockSlot, mainBlockTxPayload) -import Pos.Crypto (WithHash (..), withHash) +import Pos.Core.Block.Constructors (genesisBlock0) +import Pos.Crypto (ProtocolMagic, WithHash (..), withHash) import Pos.DB (MonadDBRead, MonadGState) import Pos.DB.Block (getBlock) import qualified Pos.GState as GS -import Pos.KnownPeers (MonadFormatPeers (..)) -import Pos.Network.Types (HasNodeType) -import Pos.Reporting (HasReportingContext) -import Pos.Slotting (MonadSlots, getSlotStartPure, getSystemStartM) -import Pos.StateLock (StateLock, StateLockMetrics) +import Pos.Infra.Network.Types (HasNodeType) +import Pos.Infra.Slotting (MonadSlots, getSlotStartPure, getSystemStartM) +import Pos.Infra.StateLock (StateLock, StateLockMetrics) +import Pos.Infra.Util.JsonLog.Events (MemPoolModifyReason) +import Pos.Lrc.Genesis (genesisLeaders) import Pos.Txp (MempoolExt, MonadTxpLocal, MonadTxpMem, ToilVerFailure, Tx (..), TxAux (..), TxId, TxOut, TxOutAux (..), TxWitness, TxpError (..), UtxoLookup, UtxoM, UtxoModifier, applyTxToUtxo, buildUtxo, evalUtxoM, @@ -79,6 +80,15 @@ data TxHistoryEntry = THEntry , _thTimestamp :: !(Maybe Timestamp) } deriving (Show, Eq, Generic, Ord) +instance NFData TxHistoryEntry where + rnf tx = _thTxId tx + `deepseq` _thTx tx + `deepseq` _thDifficulty tx + `deepseq` _thInputAddrs tx + `deepseq` _thOutputAddrs tx + `deepseq` _thTimestamp tx + `deepseq` () + -- | Remained for compatibility _thInputAddrs :: TxHistoryEntry -> [Address] _thInputAddrs = map txOutAddress . _thInputs @@ -157,23 +167,27 @@ genesisUtxoLookup = utxoToLookup . unGenesisUtxo $ genesisUtxo -- | A class which have methods to get transaction history class (Monad m, HasConfiguration) => MonadTxHistory m where getBlockHistory - :: [Address] -> m (Map TxId TxHistoryEntry) + :: ProtocolMagic -> [Address] -> m (Map TxId TxHistoryEntry) getLocalHistory :: [Address] -> m (Map TxId TxHistoryEntry) - saveTx :: (TxId, TxAux) -> m () + saveTx :: ProtocolMagic -> (TxId, TxAux) -> m () default getBlockHistory :: (MonadTrans t, MonadTxHistory m', t m' ~ m) - => [Address] -> m (Map TxId TxHistoryEntry) - getBlockHistory = lift . getBlockHistory + => ProtocolMagic -> [Address] -> m (Map TxId TxHistoryEntry) + getBlockHistory pm = lift . getBlockHistory pm default getLocalHistory :: (MonadTrans t, MonadTxHistory m', t m' ~ m) => [Address] -> m (Map TxId TxHistoryEntry) getLocalHistory = lift . getLocalHistory - default saveTx :: (MonadTrans t, MonadTxHistory m', t m' ~ m) => (TxId, TxAux) -> m () - saveTx = lift . saveTx + default saveTx + :: (MonadTrans t, MonadTxHistory m', t m' ~ m) + => ProtocolMagic + -> (TxId, TxAux) + -> m () + saveTx pm = lift . saveTx pm instance {-# OVERLAPPABLE #-} (MonadTxHistory m, MonadTrans t, Monad (t m)) => @@ -189,18 +203,20 @@ type TxHistoryEnv ctx m = , MonadReader ctx m , MonadTxpMem (MempoolExt m) ctx m , HasLens' ctx StateLock - , HasLens' ctx StateLockMetrics - , HasReportingContext ctx + , HasLens' ctx (StateLockMetrics MemPoolModifyReason) , Mockable CurrentTime m - , MonadFormatPeers m , HasNodeType ctx + , CanJsonLog m ) getBlockHistoryDefault - :: forall ctx m. (HasConfiguration, TxHistoryEnv ctx m) - => [Address] -> m (Map TxId TxHistoryEntry) -getBlockHistoryDefault addrs = do - let bot = headerHash genesisBlock0 + :: forall ctx m + . (HasConfiguration, TxHistoryEnv ctx m) + => ProtocolMagic + -> [Address] + -> m (Map TxId TxHistoryEntry) +getBlockHistoryDefault pm addrs = do + let bot = headerHash (genesisBlock0 pm (GenesisHash genesisHash) (genesisLeaders epochSlots)) sd <- GS.getSlottingData systemStart <- getSystemStartM @@ -247,9 +263,9 @@ instance Exception SaveTxException where \case SaveTxToilFailure x -> toString (pretty x) -saveTxDefault :: TxHistoryEnv ctx m => (TxId, TxAux) -> m () -saveTxDefault txw = do - res <- txpProcessTx txw +saveTxDefault :: TxHistoryEnv ctx m => ProtocolMagic -> (TxId, TxAux) -> m () +saveTxDefault pm txw = do + res <- txpProcessTx pm txw eitherToThrow (first SaveTxToilFailure res) txHistoryListToMap :: [TxHistoryEntry] -> Map TxId TxHistoryEntry diff --git a/client/src/Pos/Client/Txp/Network.hs b/client/src/Pos/Client/Txp/Network.hs index 7f74115f86e..63319006ced 100644 --- a/client/src/Pos/Client/Txp/Network.hs +++ b/client/src/Pos/Client/Txp/Network.hs @@ -5,7 +5,6 @@ module Pos.Client.Txp.Network ( TxMode - , submitTx , prepareMTx , prepareRedemptionTx , submitTxRaw @@ -19,19 +18,18 @@ import Mockable (MonadMockable) import System.Wlog (logInfo) import Pos.Client.Txp.Addresses (MonadAddresses (..)) -import Pos.Client.Txp.Balances (MonadBalances (..), getOwnUtxo, getOwnUtxoForPk) +import Pos.Client.Txp.Balances (MonadBalances (..), getOwnUtxo) import Pos.Client.Txp.History (MonadTxHistory (..)) import Pos.Client.Txp.Util (InputSelectionPolicy, PendingAddresses (..), TxCreateMode, - TxError (..), createMTx, createRedemptionTx, createTx) + TxError (..), createMTx, createRedemptionTx) import Pos.Communication.Message () -import Pos.Communication.Protocol (OutSpecs) -import Pos.Communication.Specs (createOutSpecs) import Pos.Communication.Types (InvOrDataTK) import Pos.Core (Address, Coin, makeRedeemAddress, mkCoin, unsafeAddCoin) import Pos.Core.Txp (TxAux (..), TxId, TxOut (..), TxOutAux (..), txaF) -import Pos.Crypto (RedeemSecretKey, SafeSigner, hash, redeemToPublic, safeToPublic) -import Pos.DB.Class (MonadGState) -import Pos.Diffusion.Types (Diffusion (sendTx)) +import Pos.Crypto (ProtocolMagic, RedeemSecretKey, SafeSigner, hash, redeemToPublic) +import Pos.Infra.Communication.Protocol (OutSpecs) +import Pos.Infra.Communication.Specs (createOutSpecs) +import Pos.Infra.Diffusion.Types (Diffusion (sendTx)) import Pos.Txp.Network.Types (TxMsgContents (..)) import Pos.Util.Util (eitherToThrow) import Pos.WorkMode.Class (MinWorkMode) @@ -46,36 +44,29 @@ type TxMode m , TxCreateMode m ) -submitAndSave - :: TxMode m - => Diffusion m -> TxAux -> m Bool -submitAndSave diffusion txAux@TxAux {..} = do - let txId = hash taTx - accepted <- submitTxRaw diffusion txAux - saveTx (txId, txAux) - pure accepted - -- | Construct Tx using multiple secret keys and given list of desired outputs. prepareMTx :: TxMode m - => (Address -> Maybe SafeSigner) + => ProtocolMagic + -> (Address -> Maybe SafeSigner) -> PendingAddresses -> InputSelectionPolicy -> NonEmpty Address -> NonEmpty TxOutAux -> AddrData m -> m (TxAux, NonEmpty TxOut) -prepareMTx hdwSigners pendingAddrs inputSelectionPolicy addrs outputs addrData = do +prepareMTx pm hdwSigners pendingAddrs inputSelectionPolicy addrs outputs addrData = do utxo <- getOwnUtxos (toList addrs) - eitherToThrow =<< createMTx pendingAddrs inputSelectionPolicy utxo hdwSigners outputs addrData + eitherToThrow =<< createMTx pm pendingAddrs inputSelectionPolicy utxo hdwSigners outputs addrData -- | Construct redemption Tx using redemption secret key and a output address prepareRedemptionTx :: TxMode m - => RedeemSecretKey + => ProtocolMagic + -> RedeemSecretKey -> Address -> m (TxAux, Address, Coin) -prepareRedemptionTx rsk output = do +prepareRedemptionTx pm rsk output = do let redeemAddress = makeRedeemAddress $ redeemToPublic rsk utxo <- getOwnUtxo redeemAddress let addCoin c = unsafeAddCoin c . txOutValue . toaOut @@ -83,12 +74,12 @@ prepareRedemptionTx rsk output = do txOuts = one $ TxOutAux {toaOut = TxOut output redeemBalance} when (redeemBalance == mkCoin 0) $ throwM RedemptionDepleted - txAux <- eitherToThrow =<< createRedemptionTx utxo rsk txOuts + txAux <- eitherToThrow =<< createRedemptionTx pm utxo rsk txOuts pure (txAux, redeemAddress, redeemBalance) -- | Send the ready-to-use transaction submitTxRaw - :: (MinWorkMode m, MonadGState m) + :: (MinWorkMode m) => Diffusion m -> TxAux -> m Bool submitTxRaw diffusion txAux@TxAux {..} = do let txId = hash taTx @@ -98,19 +89,3 @@ submitTxRaw diffusion txAux@TxAux {..} = do sendTxOuts :: OutSpecs sendTxOuts = createOutSpecs (Proxy :: Proxy (InvOrDataTK TxId TxMsgContents)) - --- | Construct Tx using secret key and given list of desired outputs --- BE CAREFUL! Doesn't consider HD wallet addresses -submitTx - :: TxMode m - => Diffusion m - -> PendingAddresses - -> SafeSigner - -> NonEmpty TxOutAux - -> AddrData m - -> m (TxAux, NonEmpty TxOut) -submitTx diffusion pendingAddrs ss outputs addrData = do - let ourPk = safeToPublic ss - utxo <- getOwnUtxoForPk ourPk - txWSpendings <- eitherToThrow =<< createTx pendingAddrs utxo ss outputs addrData - txWSpendings <$ submitAndSave diffusion (fst txWSpendings) diff --git a/client/src/Pos/Client/Txp/Util.hs b/client/src/Pos/Client/Txp/Util.hs index 9069a2ecbb3..3255b6403c3 100644 --- a/client/src/Pos/Client/Txp/Util.hs +++ b/client/src/Pos/Client/Txp/Util.hs @@ -2,6 +2,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | Pure functions for operations with transactions module Pos.Client.Txp.Util @@ -39,7 +41,7 @@ module Pos.Client.Txp.Util , TxWithSpendings ) where -import Universum +import Universum hiding (keys, tail) import Control.Lens (makeLenses, (%=), (.=)) import Control.Monad.Except (ExceptT, MonadError (throwError), runExceptT) @@ -64,16 +66,16 @@ import Pos.Core (Address, Coin, StakeholderId, TxFeePolicy (..), TxSiz isRedeemAddress, mkCoin, sumCoins, txSizeLinearMinValue, unsafeIntegerToCoin, unsafeSubCoin) import Pos.Core.Configuration (HasConfiguration) -import Pos.Crypto (RedeemSecretKey, SafeSigner, SignTag (SignRedeemTx, SignTx), - deterministicKeyGen, fakeSigner, hash, redeemSign, redeemToPublic, - safeSign, safeToPublic) +import Pos.Crypto (ProtocolMagic, RedeemSecretKey, SafeSigner, + SignTag (SignRedeemTx, SignTx), deterministicKeyGen, fakeSigner, hash, + redeemSign, redeemToPublic, safeSign, safeToPublic) import Pos.Data.Attributes (mkAttributes) import Pos.DB (MonadGState, gsAdoptedBVData) +import Pos.Infra.Util.LogSafe (SecureLog, buildUnsecure) import Pos.Script (Script) import Pos.Script.Examples (multisigRedeemer, multisigValidator) import Pos.Txp (Tx (..), TxAux (..), TxFee (..), TxIn (..), TxInWitness (..), TxOut (..), TxOutAux (..), TxSigData (..), Utxo) -import Pos.Util.LogSafe (SecureLog, buildUnsecure) import Test.QuickCheck (Arbitrary (..), elements) type TxInputs = NonEmpty TxIn @@ -233,51 +235,67 @@ runTxCreator inputSelectionPolicy action = runExceptT $ do -- | Like 'makePubKeyTx', but allows usage of different signers makeMPubKeyTx - :: (HasConfiguration) - => (owner -> Either e SafeSigner) + :: ProtocolMagic + -> (owner -> Either e SafeSigner) -> TxOwnedInputs owner -> TxOutputs -> Either e TxAux -makeMPubKeyTx getSs = makeAbstractTx mkWit +makeMPubKeyTx pm getSs = makeAbstractTx mkWit where mkWit addr sigData = getSs addr <&> \ss -> PkWitness { twKey = safeToPublic ss - , twSig = safeSign SignTx ss sigData + , twSig = safeSign pm SignTx ss sigData } -- | More specific version of 'makeMPubKeyTx' for convenience makeMPubKeyTxAddrs - :: (HasConfiguration) - => (Address -> Either e SafeSigner) + :: ProtocolMagic + -> (Address -> Either e SafeSigner) -> TxOwnedInputs TxOut -> TxOutputs -> Either e TxAux -makeMPubKeyTxAddrs hdwSigners = makeMPubKeyTx getSigner +makeMPubKeyTxAddrs pm hdwSigners = makeMPubKeyTx pm getSigner where getSigner (TxOut addr _) = hdwSigners addr -- | Makes a transaction which use P2PKH addresses as a source -makePubKeyTx :: HasConfiguration => SafeSigner -> TxInputs -> TxOutputs -> TxAux -makePubKeyTx ss txInputs txOutputs = either absurd identity $ - makeMPubKeyTx (\_ -> Right ss) (map ((), ) txInputs) txOutputs - -makeMOfNTx :: HasConfiguration => Script -> [Maybe SafeSigner] -> TxInputs -> TxOutputs -> TxAux -makeMOfNTx validator sks txInputs txOutputs = either absurd identity $ +makePubKeyTx + :: ProtocolMagic + -> SafeSigner + -> TxInputs + -> TxOutputs + -> TxAux +makePubKeyTx pm ss txInputs txOutputs = either absurd identity $ + makeMPubKeyTx pm (\_ -> Right ss) (map ((), ) txInputs) txOutputs + +makeMOfNTx + :: ProtocolMagic + -> Script + -> [Maybe SafeSigner] + -> TxInputs + -> TxOutputs + -> TxAux +makeMOfNTx pm validator sks txInputs txOutputs = either absurd identity $ makeAbstractTx mkWit (map ((), ) txInputs) txOutputs where mkWit _ sigData = Right $ ScriptWitness { twValidator = validator - , twRedeemer = multisigRedeemer sigData sks + , twRedeemer = multisigRedeemer pm sigData sks } -makeRedemptionTx :: HasConfiguration => RedeemSecretKey -> TxInputs -> TxOutputs -> TxAux -makeRedemptionTx rsk txInputs txOutputs = either absurd identity $ +makeRedemptionTx + :: ProtocolMagic + -> RedeemSecretKey + -> TxInputs + -> TxOutputs + -> TxAux +makeRedemptionTx pm rsk txInputs txOutputs = either absurd identity $ makeAbstractTx mkWit (map ((), ) txInputs) txOutputs where rpk = redeemToPublic rsk mkWit _ sigData = Right $ RedeemWitness { twRedeemKey = rpk - , twRedeemSig = redeemSign SignRedeemTx rsk sigData + , twRedeemSig = redeemSign pm SignRedeemTx rsk sigData } -- | Helper for summing values of `TxOutAux`s @@ -344,7 +362,7 @@ plainInputPicker (PendingAddresses pendingAddrs) utxo _outputs moneyToSpent = if moneyLeft == mkCoin 0 then return inps else do - mNextOut <- head <$> use ipsAvailableOutputs + mNextOut <- fmap fst . uncons <$> use ipsAvailableOutputs case mNextOut of Nothing -> throwError $ NotEnoughMoney moneyLeft Just inp@(_, (TxOutAux (TxOut {..}))) -> do @@ -405,7 +423,7 @@ groupedInputPicker utxo outputs moneyToSpent = if moneyLeft == mkCoin 0 then return inps else do - mNextOutGroup <- head <$> use gipsAvailableOutputGroups + mNextOutGroup <- fmap fst . uncons <$> use gipsAvailableOutputGroups case mNextOutGroup of Nothing -> if disallowedMoney >= coinToInteger moneyLeft then throwError $ NotEnoughAllowedMoney moneyLeft @@ -488,55 +506,59 @@ mkOutputsWithRem addrData TxRaw {..} prepareInpsOuts :: TxCreateMode m - => PendingAddresses + => ProtocolMagic + -> PendingAddresses -> Utxo -> TxOutputs -> AddrData m -> TxCreator m (TxOwnedInputs TxOut, TxOutputs) -prepareInpsOuts pendingTx utxo outputs addrData = do - txRaw@TxRaw {..} <- prepareTxWithFee pendingTx utxo outputs +prepareInpsOuts pm pendingTx utxo outputs addrData = do + txRaw@TxRaw {..} <- prepareTxWithFee pm pendingTx utxo outputs outputsWithRem <- mkOutputsWithRem addrData txRaw pure (trInputs, outputsWithRem) createGenericTx :: TxCreateMode m - => PendingAddresses + => ProtocolMagic + -> PendingAddresses -> (TxOwnedInputs TxOut -> TxOutputs -> Either TxError TxAux) -> InputSelectionPolicy -> Utxo -> TxOutputs -> AddrData m -> m (Either TxError TxWithSpendings) -createGenericTx pendingTx creator inputSelectionPolicy utxo outputs addrData = +createGenericTx pm pendingTx creator inputSelectionPolicy utxo outputs addrData = runTxCreator inputSelectionPolicy $ do - (inps, outs) <- prepareInpsOuts pendingTx utxo outputs addrData + (inps, outs) <- prepareInpsOuts pm pendingTx utxo outputs addrData txAux <- either throwError return $ creator inps outs pure (txAux, map fst inps) createGenericTxSingle :: TxCreateMode m - => PendingAddresses + => ProtocolMagic + -> PendingAddresses -> (TxInputs -> TxOutputs -> Either TxError TxAux) -> InputSelectionPolicy -> Utxo -> TxOutputs -> AddrData m -> m (Either TxError TxWithSpendings) -createGenericTxSingle pendingTx creator = createGenericTx pendingTx (creator . map snd) +createGenericTxSingle pm pendingTx creator = createGenericTx pm pendingTx (creator . map snd) -- | Make a multi-transaction using given secret key and info for outputs. -- Currently used for HD wallets only, thus `HDAddressPayload` is required createMTx :: TxCreateMode m - => PendingAddresses + => ProtocolMagic + -> PendingAddresses -> InputSelectionPolicy -> Utxo -> (Address -> Maybe SafeSigner) -> TxOutputs -> AddrData m -> m (Either TxError TxWithSpendings) -createMTx pendingTx groupInputs utxo hdwSigners outputs addrData = - createGenericTx pendingTx (makeMPubKeyTxAddrs getSigner) +createMTx pm pendingTx groupInputs utxo hdwSigners outputs addrData = + createGenericTx pm pendingTx (makeMPubKeyTxAddrs pm getSigner) groupInputs utxo outputs addrData where getSigner address = @@ -547,46 +569,49 @@ createMTx pendingTx groupInputs utxo hdwSigners outputs addrData = -- outputs. createTx :: TxCreateMode m - => PendingAddresses + => ProtocolMagic + -> PendingAddresses -> Utxo -> SafeSigner -> TxOutputs -> AddrData m -> m (Either TxError TxWithSpendings) -createTx pendingTx utxo ss outputs addrData = - createGenericTxSingle pendingTx (\i o -> Right $ makePubKeyTx ss i o) - OptimizeForSecurity utxo outputs addrData +createTx pm pendingTx utxo ss outputs addrData = + createGenericTxSingle pm pendingTx (\i o -> Right $ makePubKeyTx pm ss i o) + OptimizeForHighThroughput utxo outputs addrData -- | Make a transaction, using M-of-N script as a source createMOfNTx :: TxCreateMode m - => PendingAddresses + => ProtocolMagic + -> PendingAddresses -> Utxo -> [(StakeholderId, Maybe SafeSigner)] -> TxOutputs -> AddrData m -> m (Either TxError TxWithSpendings) -createMOfNTx pendingTx utxo keys outputs addrData = - createGenericTxSingle pendingTx (\i o -> Right $ makeMOfNTx validator sks i o) +createMOfNTx pm pendingTx utxo keys outputs addrData = + createGenericTxSingle pm pendingTx (\i o -> Right $ makeMOfNTx pm validator sks i o) OptimizeForSecurity utxo outputs addrData where ids = map fst keys sks = map snd keys m = length $ filter isJust sks - validator = multisigValidator m ids + validator = multisigValidator pm m ids -- | Make a transaction for retrieving money from redemption address createRedemptionTx :: TxCreateMode m - => Utxo + => ProtocolMagic + -> Utxo -> RedeemSecretKey -> TxOutputs -> m (Either TxError TxAux) -createRedemptionTx utxo rsk outputs = +createRedemptionTx pm utxo rsk outputs = runTxCreator whetherGroupedInputs $ do TxRaw {..} <- prepareTxRaw mempty utxo outputs (TxFee $ mkCoin 0) let bareInputs = snd <$> trInputs - pure $ makeRedemptionTx rsk bareInputs trOutputs + pure $ makeRedemptionTx pm rsk bareInputs trOutputs where -- always spend redeem address fully whetherGroupedInputs = OptimizeForSecurity @@ -607,25 +632,27 @@ withLinearFeePolicy action = view tcdFeePolicy >>= \case action linearPolicy -- | Prepare transaction considering fees -prepareTxWithFee :: - (HasConfiguration, MonadAddresses m) - => PendingAddresses +prepareTxWithFee + :: MonadAddresses m + => ProtocolMagic + -> PendingAddresses -> Utxo -> TxOutputs -> TxCreator m TxRaw -prepareTxWithFee pendingTx utxo outputs = withLinearFeePolicy $ \linearPolicy -> - stabilizeTxFee pendingTx linearPolicy utxo outputs +prepareTxWithFee pm pendingTx utxo outputs = withLinearFeePolicy $ \linearPolicy -> + stabilizeTxFee pm pendingTx linearPolicy utxo outputs -- | Compute, how much fees we should pay to send money to given -- outputs computeTxFee - :: (HasConfiguration, MonadAddresses m) - => PendingAddresses + :: MonadAddresses m + => ProtocolMagic + -> PendingAddresses -> Utxo -> TxOutputs -> TxCreator m TxFee -computeTxFee pendingTx utxo outputs = do - TxRaw {..} <- prepareTxWithFee pendingTx utxo outputs +computeTxFee pm pendingTx utxo outputs = do + TxRaw {..} <- prepareTxWithFee pm pendingTx utxo outputs let outAmount = sumTxOutCoins trOutputs inAmount = sumCoins $ map (txOutValue . fst) trInputs remaining = coinToInteger trRemainingMoney @@ -676,13 +703,15 @@ computeTxFee pendingTx utxo outputs = do -- valid). -- To possibly find better solutions we iterate for several times more. stabilizeTxFee - :: forall m. (HasConfiguration, MonadAddresses m) - => PendingAddresses + :: forall m + . MonadAddresses m + => ProtocolMagic + -> PendingAddresses -> TxSizeLinear -> Utxo -> TxOutputs -> TxCreator m TxRaw -stabilizeTxFee pendingTx linearPolicy utxo outputs = do +stabilizeTxFee pm pendingTx linearPolicy utxo outputs = do minFee <- fixedToFee (txSizeLinearMinValue linearPolicy) mtx <- stabilizeTxFeeDo (False, firstStageAttempts) minFee case mtx of @@ -700,7 +729,7 @@ stabilizeTxFee pendingTx linearPolicy utxo outputs = do txRaw <- prepareTxRaw pendingTx utxo outputs expectedFee fakeChangeAddr <- lift . lift $ getFakeChangeAddress txMinFee <- txToLinearFee linearPolicy $ - createFakeTxFromRawTx fakeChangeAddr txRaw + createFakeTxFromRawTx pm fakeChangeAddr txRaw let txRawWithFee = S.Min $ S.Arg expectedFee txRaw let iterateDo step = stabilizeTxFeeDo step txMinFee @@ -723,8 +752,8 @@ txToLinearFee linearPolicy = -- | Function is used to calculate intermediate fee amounts -- when forming a transaction -createFakeTxFromRawTx :: HasConfiguration => Address -> TxRaw -> TxAux -createFakeTxFromRawTx fakeAddr TxRaw{..} = +createFakeTxFromRawTx :: ProtocolMagic -> Address -> TxRaw -> TxAux +createFakeTxFromRawTx pm fakeAddr TxRaw{..} = let fakeOutMB | trRemainingMoney == mkCoin 0 = Nothing | otherwise = @@ -739,6 +768,7 @@ createFakeTxFromRawTx fakeAddr TxRaw{..} = -- so we can use arbitrary signer. (_, fakeSK) = deterministicKeyGen "patakbardaqskovoroda228pva1488kk" in either absurd identity $ makeMPubKeyTxAddrs + pm (\_ -> Right $ fakeSigner fakeSK) trInputs txOutsWithRem diff --git a/client/src/Pos/Client/Update.hs b/client/src/Pos/Client/Update.hs index 37c954bce07..ea0fc467dca 100644 --- a/client/src/Pos/Client/Update.hs +++ b/client/src/Pos/Client/Update.hs @@ -1,3 +1,8 @@ -- | Reexport of Pos.Client.Update.* modules. -{-# OPTIONS_GHC -F -pgmF autoexporter #-} +module Pos.Client.Update + ( module Pos.Client.Update.Network + ) where + +import Pos.Client.Update.Network + diff --git a/client/src/Pos/Client/Update/Network.hs b/client/src/Pos/Client/Update/Network.hs index 4bf8b3791ae..4aef636f7c1 100644 --- a/client/src/Pos/Client/Update/Network.hs +++ b/client/src/Pos/Client/Update/Network.hs @@ -13,36 +13,35 @@ import Formatting (sformat, (%)) import System.Wlog (logInfo) import Pos.Communication.Message () -import Pos.Crypto (SafeSigner, hash, hashHexF) -import Pos.DB.Class (MonadGState) -import Pos.Diffusion.Types (Diffusion) -import qualified Pos.Diffusion.Types as Diffusion (Diffusion (sendUpdateProposal, sendVote)) +import Pos.Crypto (ProtocolMagic, SafeSigner, hash, hashHexF) +import Pos.Infra.Diffusion.Types (Diffusion) +import qualified Pos.Infra.Diffusion.Types as Diffusion (Diffusion (sendUpdateProposal, sendVote)) import Pos.Update (UpId, UpdateProposal, UpdateVote (..), mkUpdateVoteSafe) import Pos.WorkMode.Class (MinWorkMode) -- | Send UpdateVote to given addresses submitVote - :: (MinWorkMode m, MonadGState m) - => Diffusion m + :: Diffusion m -> UpdateVote -> m () submitVote diffusion = Diffusion.sendVote diffusion -- | Send UpdateProposal with one positive vote to given addresses submitUpdateProposal - :: (MinWorkMode m, MonadGState m) - => Diffusion m + :: (MinWorkMode m) + => ProtocolMagic + -> Diffusion m -> [SafeSigner] -> UpdateProposal -> m () -submitUpdateProposal diffusion ss prop = do +submitUpdateProposal pm diffusion ss prop = do let upid = hash prop - let votes = [mkUpdateVoteSafe signer upid True | signer <- ss] + let votes = [mkUpdateVoteSafe pm signer upid True | signer <- ss] sendUpdateProposal diffusion upid prop votes -- Send UpdateProposal to given address. sendUpdateProposal - :: (MinWorkMode m, MonadGState m) + :: (MinWorkMode m) => Diffusion m -> UpId -> UpdateProposal diff --git a/client/test/Test/Pos/Client/Txp/Mode.hs b/client/test/Test/Pos/Client/Txp/Mode.hs index e67d3d8f5f3..a3a090c40ff 100644 --- a/client/test/Test/Pos/Client/Txp/Mode.hs +++ b/client/test/Test/Pos/Client/Txp/Mode.hs @@ -1,5 +1,7 @@ {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | Execution mode for tx creation tests. module Test.Pos.Client.Txp.Mode @@ -16,7 +18,6 @@ import Test.QuickCheck (Testable (..), ioProperty) import Test.QuickCheck.Monadic (PropertyM, monadic) import Pos.Client.Txp.Addresses (MonadAddresses (..)) -import Pos.Client.Txp.Util (TxCreateMode) import Pos.Configuration (HasNodeConfiguration) import Pos.Core (Address, BlockVersionData, HasConfiguration, makePubKeyAddressBoot) import Pos.Core.Configuration (HasGenesisBlockVersionData, genesisBlockVersionData) @@ -43,16 +44,14 @@ type HasTxpConfigurations = type TxpTestMode = ReaderT BlockVersionData IO -instance HasTxpConfigurations => TxCreateMode TxpTestMode - ---------------------------------------------------------------------------- -- Boilerplate TxpTestMode instances ---------------------------------------------------------------------------- -instance HasTxpConfigurations => MonadGState TxpTestMode where +instance MonadGState TxpTestMode where gsAdoptedBVData = ask -instance HasTxpConfigurations => MonadAddresses TxpTestMode where +instance MonadAddresses TxpTestMode where type AddrData TxpTestMode = () getNewAddress _ = pure fakeAddressForMonadAddresses getFakeChangeAddress = pure fakeAddressForMonadAddresses @@ -80,10 +79,10 @@ type TxpTestProperty = PropertyM TxpTestMode -- Cannot write a general OVERLAPPABLE instance with MonadTrans since -- type families cannot be OVERLAPPABLE. -instance HasTxpConfigurations => MonadAddresses TxpTestProperty where +instance MonadAddresses TxpTestProperty where type AddrData TxpTestProperty = AddrData TxpTestMode getNewAddress = lift . getNewAddress getFakeChangeAddress = lift getFakeChangeAddress -instance HasTxpConfigurations => Testable (TxpTestProperty a) where +instance (HasTxpConfigurations, Testable a) => Testable (TxpTestProperty a) where property = monadic (ioProperty . flip runReaderT genesisBlockVersionData) diff --git a/client/test/Test/Pos/Client/Txp/UtilSpec.hs b/client/test/Test/Pos/Client/Txp/UtilSpec.hs index 1f508161fa0..cb270d0205b 100644 --- a/client/test/Test/Pos/Client/Txp/UtilSpec.hs +++ b/client/test/Test/Pos/Client/Txp/UtilSpec.hs @@ -31,20 +31,21 @@ import Pos.Crypto (RedeemSecretKey, SafeSigner, SecretKey, decodeHash, redeemToPublic, toPublic) import Pos.DB (gsAdoptedBVData) import Pos.Txp (Utxo) -import Pos.Util.QuickCheck.Arbitrary (nonrepeating) -import Pos.Util.QuickCheck.Property (stopProperty) import Pos.Util.Util (leftToPanic) -import Test.Pos.Configuration (withDefConfigurations) import Test.Pos.Client.Txp.Mode (HasTxpConfigurations, TxpTestMode, TxpTestProperty, withBVData) +import Test.Pos.Configuration (withDefConfigurations) +import Test.Pos.Crypto.Dummy (dummyProtocolMagic) +import Test.Pos.Util.QuickCheck.Arbitrary (nonrepeating) +import Test.Pos.Util.QuickCheck.Property (stopProperty) ---------------------------------------------------------------------------- -- Tests ---------------------------------------------------------------------------- spec :: Spec -spec = withDefConfigurations $ \_ -> +spec = withDefConfigurations $ \_ _ -> describe "Client.Txp.Util" $ do describe "createMTx" $ createMTxSpec @@ -112,10 +113,13 @@ testCreateMTx => CreateMTxParams -> TxpTestProperty (Either TxError (TxAux, NonEmpty TxOut)) testCreateMTx CreateMTxParams{..} = lift $ - createMTx mempty cmpInputSelectionPolicy cmpUtxo (getSignerFromList cmpSigners) + createMTx dummyProtocolMagic mempty cmpInputSelectionPolicy cmpUtxo (getSignerFromList cmpSigners) cmpOutputs cmpAddrData -createMTxWorksWhenWeAreRichSpec :: HasTxpConfigurations => InputSelectionPolicy -> TxpTestProperty () +createMTxWorksWhenWeAreRichSpec + :: HasTxpConfigurations + => InputSelectionPolicy + -> TxpTestProperty () createMTxWorksWhenWeAreRichSpec inputSelectionPolicy = forAllM gen $ \txParams@CreateMTxParams{..} -> do txOrError <- testCreateMTx txParams @@ -125,7 +129,10 @@ createMTxWorksWhenWeAreRichSpec inputSelectionPolicy = where gen = makeManyAddressesToManyParams inputSelectionPolicy 1 1000000 1 1 -stabilizationDoesNotFailSpec :: HasTxpConfigurations => InputSelectionPolicy -> TxpTestProperty () +stabilizationDoesNotFailSpec + :: HasTxpConfigurations + => InputSelectionPolicy + -> TxpTestProperty () stabilizationDoesNotFailSpec inputSelectionPolicy = do forAllM gen $ \txParams@CreateMTxParams{..} -> do txOrError <- testCreateMTx txParams @@ -136,7 +143,10 @@ stabilizationDoesNotFailSpec inputSelectionPolicy = do where gen = makeManyAddressesToManyParams inputSelectionPolicy 1 200000 1 1 -feeIsNonzeroSpec :: HasTxpConfigurations => InputSelectionPolicy -> TxpTestProperty () +feeIsNonzeroSpec + :: HasTxpConfigurations + => InputSelectionPolicy + -> TxpTestProperty () feeIsNonzeroSpec inputSelectionPolicy = do forAllM gen $ \txParams@CreateMTxParams{..} -> do txOrError <- testCreateMTx txParams @@ -149,7 +159,10 @@ feeIsNonzeroSpec inputSelectionPolicy = do where gen = makeManyAddressesToManyParams inputSelectionPolicy 1 100000 1 1 -manyUtxoTo1Spec :: HasTxpConfigurations => InputSelectionPolicy -> TxpTestProperty () +manyUtxoTo1Spec + :: HasTxpConfigurations + => InputSelectionPolicy + -> TxpTestProperty () manyUtxoTo1Spec inputSelectionPolicy = do forAllM gen $ \txParams@CreateMTxParams{..} -> do txOrError <- testCreateMTx txParams @@ -159,7 +172,10 @@ manyUtxoTo1Spec inputSelectionPolicy = do where gen = makeManyUtxoTo1Params inputSelectionPolicy 10 100000 1 -manyAddressesTo1Spec :: HasTxpConfigurations => InputSelectionPolicy -> TxpTestProperty () +manyAddressesTo1Spec + :: HasTxpConfigurations + => InputSelectionPolicy + -> TxpTestProperty () manyAddressesTo1Spec inputSelectionPolicy = do forAllM gen $ \txParams@CreateMTxParams{..} -> do txOrError <- testCreateMTx txParams @@ -169,7 +185,10 @@ manyAddressesTo1Spec inputSelectionPolicy = do where gen = makeManyAddressesToManyParams inputSelectionPolicy 10 100000 1 1 -manyAddressesToManySpec :: HasTxpConfigurations => InputSelectionPolicy -> TxpTestProperty () +manyAddressesToManySpec + :: HasTxpConfigurations + => InputSelectionPolicy + -> TxpTestProperty () manyAddressesToManySpec inputSelectionPolicy = do forAllM gen $ \txParams@CreateMTxParams{..} -> do txOrError <- testCreateMTx txParams @@ -182,7 +201,7 @@ manyAddressesToManySpec inputSelectionPolicy = do redemptionSpec :: HasTxpConfigurations => TxpTestProperty () redemptionSpec = do forAllM genParams $ \(CreateRedemptionTxParams {..}) -> do - txOrError <- createRedemptionTx crpUtxo crpRsk crpOutputs + txOrError <- createRedemptionTx dummyProtocolMagic crpUtxo crpRsk crpOutputs case txOrError of Left err -> stopProperty $ pretty err Right _ -> return () @@ -198,11 +217,14 @@ redemptionSpec = do pure CreateRedemptionTxParams {..} -txWithRedeemOutputFailsSpec :: HasTxpConfigurations => InputSelectionPolicy -> TxpTestProperty () +txWithRedeemOutputFailsSpec + :: HasTxpConfigurations + => InputSelectionPolicy + -> TxpTestProperty () txWithRedeemOutputFailsSpec inputSelectionPolicy = do forAllM genParams $ \(CreateMTxParams {..}) -> do txOrError <- - createMTx mempty cmpInputSelectionPolicy cmpUtxo + createMTx dummyProtocolMagic mempty cmpInputSelectionPolicy cmpUtxo (getSignerFromList cmpSigners) cmpOutputs cmpAddrData case txOrError of @@ -359,8 +381,7 @@ makeManyAddressesTo1Params inputSelectionPolicy numFrom amountEachFrom amountEac makeManyAddressesToManyParams inputSelectionPolicy numFrom amountEachFrom 1 amountEachTo ensureTxMakesSense - :: HasTxpConfigurations - => TxWithSpendings -> Utxo -> TxOutputs -> TxpTestProperty () + :: TxWithSpendings -> Utxo -> TxOutputs -> TxpTestProperty () ensureTxMakesSense (_, neTxOut) utxo _ = do unless (S.fromList txOutUsed `S.isSubsetOf` S.fromList txOutAvailable) $ stopProperty $ @@ -398,8 +419,7 @@ makeSigner :: SecretKey -> (SafeSigner, Address) makeSigner sk = (fakeSigner sk, secretKeyToAddress sk) withTxFeePolicy - :: HasTxpConfigurations - => Coeff -> Coeff -> TxpTestProperty () -> TxpTestProperty () + :: Coeff -> Coeff -> TxpTestProperty () -> TxpTestProperty () withTxFeePolicy a b action = do let policy = TxFeePolicyTxSizeLinear $ TxSizeLinear a b bvd <- gsAdoptedBVData diff --git a/core/Makefile b/core/Makefile new file mode 100644 index 00000000000..7cce17929c9 --- /dev/null +++ b/core/Makefile @@ -0,0 +1,14 @@ +help: ## Print documentation + @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | sort | awk 'BEGIN {FS = ":.*?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' + +ghcid: ## Run ghcid with the cardano-sl-core package + ghcid \ + --command "stack ghci cardano-sl-core --ghci-options=-fno-code" + +ghcid-test: ## Have ghcid run the test suite for the wallet-new-specs on successful recompile + ghcid \ + --command "stack ghci cardano-sl-core:lib cardano-sl-core:test:test --ghci-options=-fobject-code" \ + --test "main" + +.PHONY: ghcid ghcid-test help + diff --git a/core/Pos/Binary/Core.hs b/core/Pos/Binary/Core.hs deleted file mode 100644 index 07e7d3c1ed3..00000000000 --- a/core/Pos/Binary/Core.hs +++ /dev/null @@ -1,4 +0,0 @@ --- Pos.Binary.Core -{-# OPTIONS_GHC -F -pgmF autoexporter #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} diff --git a/core/Pos/Binary/Core/Address.hs b/core/Pos/Binary/Core/Address.hs deleted file mode 100644 index 212c0c7a9dd..00000000000 --- a/core/Pos/Binary/Core/Address.hs +++ /dev/null @@ -1,192 +0,0 @@ --- | Binary serialization of 'Address' and related types. - -module Pos.Binary.Core.Address (encodeAddr, encodeAddrCRC32) where - -import Universum -import Unsafe (unsafeFromJust) - -import Codec.CBOR.Encoding (Encoding) -import Control.Exception.Safe (Exception (displayException)) -import Control.Lens (_Left) -import qualified Data.ByteString.Lazy as LBS -import Data.Word (Word8) - -import Pos.Binary.Class (Bi (..), decodeCrcProtected, decodeListLenCanonical, - decodeUnknownCborDataItem, deserialize, encodeCrcProtected, - encodeListLen, encodeUnknownCborDataItem, enforceSize, - serialize) -import Pos.Binary.Core.Common () -import Pos.Binary.Core.Script () -import Pos.Binary.Crypto () -import Pos.Core.Common.Types (AddrAttributes (..), AddrSpendingData (..), - AddrStakeDistribution (..), AddrType (..), Address (..), - Address' (..), mkMultiKeyDistr) -import Pos.Data.Attributes (Attributes (..), decodeAttributes, encodeAttributes) -import Pos.Util.Util (cborError, toCborError) - ----------------------------------------------------------------------------- --- Helper types serialization ----------------------------------------------------------------------------- - --- Helper function to avoid writing `:: Word8`. -w8 :: Word8 -> Word8 -w8 = identity -{-# INLINE w8 #-} - -instance Bi AddrType where - encode = - encode @Word8 . \case - ATPubKey -> 0 - ATScript -> 1 - ATRedeem -> 2 - ATUnknown tag -> tag - decode = - decode @Word8 <&> \case - 0 -> ATPubKey - 1 -> ATScript - 2 -> ATRedeem - tag -> ATUnknown tag - -{- NOTE: Address spending data serialization -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -An address is serialized as a tuple consisting of: - -1. One-byte tag. -2. Data dependent on tag. - -If tag is 0, 1 or 2, the type of spending data is 'PubKeyASD', -'ScriptASD' or 'RedeemASD' respectively. - -If tag is greater than 2, the data is decoded as a plain 'ByteString'. - -This lets us have backwards compatibility. For instance, if a newer -version of CSL adds a new type of spending data with tag 3, then older -versions would deserialize it as follows: - - UnknownASD 3 --} - -instance Bi AddrSpendingData where - encode = - \case - PubKeyASD pk -> encode (w8 0, pk) - ScriptASD script -> encode (w8 1, script) - RedeemASD redeemPK -> encode (w8 2, redeemPK) - UnknownASD tag payload -> - -- `encodeListLen 2` is semantically equivalent to encode (x,y) - -- but we need to "unroll" it in order to apply CBOR's tag 24 to `payload`. - encodeListLen 2 <> encode tag <> encodeUnknownCborDataItem (LBS.fromStrict payload) - decode = do - enforceSize "AddrSpendingData" 2 - decode @Word8 >>= \case - 0 -> PubKeyASD <$> decode - 1 -> ScriptASD <$> decode - 2 -> RedeemASD <$> decode - tag -> UnknownASD tag <$> decodeUnknownCborDataItem - -instance Bi AddrStakeDistribution where - encode = - \case - BootstrapEraDistr -> encodeListLen 0 - SingleKeyDistr id -> encode (w8 0, id) - UnsafeMultiKeyDistr distr -> encode (w8 1, distr) - decode = - decodeListLenCanonical >>= \case - 0 -> pure BootstrapEraDistr - 2 -> - decode @Word8 >>= \case - 0 -> SingleKeyDistr <$> decode - 1 -> toCborError . (_Left %~ toText . displayException) . - mkMultiKeyDistr =<< decode - tag -> cborError $ - "decode @AddrStakeDistribution: unexpected tag " <> - pretty tag - len -> cborError $ - "decode @AddrStakeDistribution: unexpected length " <> pretty len - -{- NOTE: Address attributes serialization -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -'Attributes' are conceptually a map, where keys are numbers ('Word8'). - -For address there are two attributes: -• 0 — stake distribution, defaults to 'BootstrapEraDistr'; -• 1 — derivation path, defaults to 'Nothing'. - --} - -instance Bi (Attributes AddrAttributes) where - -- FIXME @avieth it was observed that for a 150kb block, this call to - -- encodeAttributes allocated 3.685mb - -- Try using serialize rather than serialize', to avoid the - -- toStrict call. - -- Also consider using a custom builder strategy; serialized attributes are - -- probably small, right? - encode attrs@(Attributes {attrData = AddrAttributes derivationPath stakeDistr}) = - encodeAttributes listWithIndices attrs - where - listWithIndices :: [(Word8, AddrAttributes -> LBS.ByteString)] - listWithIndices = - stakeDistributionListWithIndices <> derivationPathListWithIndices - stakeDistributionListWithIndices = - case stakeDistr of - BootstrapEraDistr -> [] - _ -> [(0, serialize . aaStakeDistribution)] - derivationPathListWithIndices = - case derivationPath of - Nothing -> [] - -- 'unsafeFromJust' is safe, because 'case' ensures - -- that derivation path is 'Just'. - Just _ -> - [(1, serialize . unsafeFromJust . aaPkDerivationPath)] - - decode = decodeAttributes initValue go - where - initValue = - AddrAttributes - { aaPkDerivationPath = Nothing - , aaStakeDistribution = BootstrapEraDistr - } - go n v acc = - case n of - 0 -> (\distr -> Just $ acc {aaStakeDistribution = distr } ) <$> deserialize v - 1 -> (\deriv -> Just $ acc {aaPkDerivationPath = Just deriv }) <$> deserialize v - _ -> pure Nothing - --- We don't need a special encoding for 'Address'', GND is what we want. -deriving instance Bi Address' - ----------------------------------------------------------------------------- --- Address serialization ----------------------------------------------------------------------------- - -{- NOTE: Address serialization -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -An address is serialized as a tuple consisting of: - -1. 'addrRoot'. -2. 'addrAttributes'. -3. 'addrType'. -4. CRC32 checksum. --} - --- Encodes the `Address` __without__ the CRC32. --- It's important to keep this function separated from the `encode` --- definition to avoid that `encode` would call `crc32` and --- the latter invoke `crc32Update`, which would then try to call `encode` --- indirectly once again, in an infinite loop. -encodeAddr :: Address -> Encoding -encodeAddr Address {..} = - encode addrRoot <> encode addrAttributes <> encode addrType - -encodeAddrCRC32 :: Address -> Encoding -encodeAddrCRC32 Address{..} = encodeCrcProtected (addrRoot, addrAttributes, addrType) - -instance Bi Address where - encode Address{..} = encodeCrcProtected (addrRoot, addrAttributes, addrType) - decode = do - (addrRoot, addrAttributes, addrType) <- decodeCrcProtected - let res = Address {..} - pure res diff --git a/core/Pos/Binary/Core/Update.hs b/core/Pos/Binary/Core/Update.hs deleted file mode 100644 index b77c03dc72d..00000000000 --- a/core/Pos/Binary/Core/Update.hs +++ /dev/null @@ -1,143 +0,0 @@ --- | Binary serialization of core Update types. - -module Pos.Binary.Core.Update - ( - ) where - -import Universum - -import Data.Time.Units (Millisecond) -import Serokell.Data.Memory.Units (Byte) - -import Pos.Binary.Class (Bi (..), Cons (..), Field (..), Raw, deriveSimpleBi, - deriveSimpleBiCxt, encodeListLen, enforceSize) -import Pos.Binary.Core.Common () -import Pos.Binary.Core.Fee () -import Pos.Binary.Core.Script () -import Pos.Core.Common (CoinPortion, ScriptVersion, TxFeePolicy) -import Pos.Core.Configuration (HasConfiguration) -import Pos.Core.Slotting.Types (EpochIndex, FlatSlotId) -import qualified Pos.Core.Update as U -import Pos.Core.Update.Types (BlockVersion, BlockVersionData (..), SoftforkRule (..), - SoftwareVersion) -import Pos.Crypto (Hash) - -instance Bi U.ApplicationName where - encode appName = encode (U.getApplicationName appName) - decode = U.ApplicationName <$> decode - -deriveSimpleBi ''U.BlockVersion [ - Cons 'U.BlockVersion [ - Field [| U.bvMajor :: Word16 |], - Field [| U.bvMinor :: Word16 |], - Field [| U.bvAlt :: Word8 |] - ]] - -deriveSimpleBi ''U.SoftwareVersion [ - Cons 'U.SoftwareVersion [ - Field [| U.svAppName :: U.ApplicationName |], - Field [| U.svNumber :: U.NumSoftwareVersion |] - ]] - -deriveSimpleBi ''SoftforkRule [ - Cons 'SoftforkRule [ - Field [| srInitThd :: CoinPortion |], - Field [| srMinThd :: CoinPortion |], - Field [| srThdDecrement :: CoinPortion |] - ]] - -deriveSimpleBi ''BlockVersionData [ - Cons 'BlockVersionData [ - Field [| bvdScriptVersion :: ScriptVersion |], - Field [| bvdSlotDuration :: Millisecond |], - Field [| bvdMaxBlockSize :: Byte |], - Field [| bvdMaxHeaderSize :: Byte |], - Field [| bvdMaxTxSize :: Byte |], - Field [| bvdMaxProposalSize :: Byte |], - Field [| bvdMpcThd :: CoinPortion |], - Field [| bvdHeavyDelThd :: CoinPortion |], - Field [| bvdUpdateVoteThd :: CoinPortion |], - Field [| bvdUpdateProposalThd :: CoinPortion |], - Field [| bvdUpdateImplicit :: FlatSlotId |], - Field [| bvdSoftforkRule :: SoftforkRule |], - Field [| bvdTxFeePolicy :: TxFeePolicy |], - Field [| bvdUnlockStakeEpoch :: EpochIndex |] - ]] - -deriveSimpleBi ''U.BlockVersionModifier [ - Cons 'U.BlockVersionModifier [ - Field [| U.bvmScriptVersion :: Maybe ScriptVersion |], - Field [| U.bvmSlotDuration :: Maybe Millisecond |], - Field [| U.bvmMaxBlockSize :: Maybe Byte |], - Field [| U.bvmMaxHeaderSize :: Maybe Byte |], - Field [| U.bvmMaxTxSize :: Maybe Byte |], - Field [| U.bvmMaxProposalSize :: Maybe Byte |], - Field [| U.bvmMpcThd :: Maybe CoinPortion |], - Field [| U.bvmHeavyDelThd :: Maybe CoinPortion |], - Field [| U.bvmUpdateVoteThd :: Maybe CoinPortion |], - Field [| U.bvmUpdateProposalThd :: Maybe CoinPortion |], - Field [| U.bvmUpdateImplicit :: Maybe FlatSlotId |], - Field [| U.bvmSoftforkRule :: Maybe SoftforkRule |], - Field [| U.bvmTxFeePolicy :: Maybe TxFeePolicy |], - Field [| U.bvmUnlockStakeEpoch :: Maybe EpochIndex |] - ]] - -instance Bi U.SystemTag where - encode = encode . U.getSystemTag - decode = U.SystemTag <$> decode - -deriveSimpleBi ''U.UpdateData [ - Cons 'U.UpdateData [ - Field [| U.udAppDiffHash :: Hash Raw |], - Field [| U.udPkgHash :: Hash Raw |], - Field [| U.udUpdaterHash :: Hash Raw |], - Field [| U.udMetadataHash :: Hash Raw |] - ]] - -deriveSimpleBi ''U.UpdateProposalToSign [ - Cons 'U.UpdateProposalToSign [ - Field [| U.upsBV :: BlockVersion |], - Field [| U.upsBVM :: U.BlockVersionModifier |], - Field [| U.upsSV :: SoftwareVersion |], - Field [| U.upsData :: HashMap U.SystemTag U.UpdateData |], - Field [| U.upsAttr :: U.UpAttributes |] - ]] - -instance HasConfiguration => Bi U.UpdateProposal where - encode up = encodeListLen 7 - <> encode (U.upBlockVersion up) - <> encode (U.upBlockVersionMod up) - <> encode (U.upSoftwareVersion up) - <> encode (U.upData up) - <> encode (U.upAttributes up) - <> encode (U.upFrom up) - <> encode (U.upSignature up) - decode = do - enforceSize "UpdateProposal" 7 - U.UnsafeUpdateProposal <$> decode - <*> decode - <*> decode - <*> decode - <*> decode - <*> decode - <*> decode - -instance HasConfiguration => Bi U.UpdateVote where - encode uv = encodeListLen 4 - <> encode (U.uvKey uv) - <> encode (U.uvProposalId uv) - <> encode (U.uvDecision uv) - <> encode (U.uvSignature uv) - decode = do - enforceSize "UpdateVote" 4 - uvKey <- decode - uvProposalId <- decode - uvDecision <- decode - uvSignature <- decode - pure U.UnsafeUpdateVote{..} - -deriveSimpleBiCxt [t|HasConfiguration|] ''U.UpdatePayload [ - Cons 'U.UpdatePayload [ - Field [| U.upProposal :: Maybe U.UpdateProposal |], - Field [| U.upVotes :: [U.UpdateVote] |] - ]] diff --git a/core/Pos/Core.hs b/core/Pos/Core.hs deleted file mode 100644 index 11c8067789a..00000000000 --- a/core/Pos/Core.hs +++ /dev/null @@ -1,4 +0,0 @@ --- Pos.Core -{-# OPTIONS_GHC -F -pgmF autoexporter #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} diff --git a/core/Pos/Core/Block.hs b/core/Pos/Core/Block.hs deleted file mode 100644 index 67ef877c226..00000000000 --- a/core/Pos/Core/Block.hs +++ /dev/null @@ -1,3 +0,0 @@ --- | Reexport module - -{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/core/Pos/Core/Block/Genesis.hs b/core/Pos/Core/Block/Genesis.hs deleted file mode 100644 index 38fbabf1be1..00000000000 --- a/core/Pos/Core/Block/Genesis.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF autoexporter #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} diff --git a/core/Pos/Core/Block/Genesis/Chain.hs b/core/Pos/Core/Block/Genesis/Chain.hs deleted file mode 100644 index e8ab9570a8b..00000000000 --- a/core/Pos/Core/Block/Genesis/Chain.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - --- | Definitions of the genesis blockchain ('Blockchain' class and related). - -module Pos.Core.Block.Genesis.Chain - ( BodyProof (..) - , ConsensusData (..) - , Body (..) - ) where - -import Universum - -import qualified Data.Text.Buildable as Buildable - -import Pos.Core.Block.Blockchain (Blockchain (..)) -import Pos.Core.Block.Genesis.Types (GenesisBlock, GenesisBlockchain, - GenesisExtraBodyData, GenesisExtraHeaderData) -import Pos.Core.Block.Union.Types (Block, BlockHeader) -import Pos.Core.Common (ChainDifficulty, SlotLeaders) -import Pos.Core.Slotting.Types (EpochIndex (..)) -import Pos.Crypto (Hash, hash) - -instance Blockchain GenesisBlockchain where - -- [CSL-199]: maybe we should use ADS. - -- | Proof of GenesisBody is just a hash of slot leaders list. - data BodyProof GenesisBlockchain = GenesisProof - !(Hash SlotLeaders) - deriving (Eq, Generic, Show) - data ConsensusData GenesisBlockchain = GenesisConsensusData - { -- | Index of the slot for which this genesis block is relevant. - _gcdEpoch :: !EpochIndex - , -- | Difficulty of the chain ending in this genesis block. - _gcdDifficulty :: !ChainDifficulty - } deriving (Generic, Show, Eq) - type BBlockHeader GenesisBlockchain = BlockHeader - type ExtraHeaderData GenesisBlockchain = GenesisExtraHeaderData - - -- | Body of genesis block consists of slot leaders for epoch - -- associated with this block. - data Body GenesisBlockchain = GenesisBody - { _gbLeaders :: !SlotLeaders - } deriving (Generic, Show, Eq) - - type ExtraBodyData GenesisBlockchain = GenesisExtraBodyData - type BBlock GenesisBlockchain = Block - - mkBodyProof = GenesisProof . hash . _gbLeaders - -instance Buildable (BodyProof GenesisBlockchain) where - build (GenesisProof h) = Buildable.build h - -instance NFData (BodyProof GenesisBlockchain) -instance NFData (ConsensusData GenesisBlockchain) -instance NFData (Body GenesisBlockchain) -instance NFData GenesisBlock diff --git a/core/Pos/Core/Block/Main.hs b/core/Pos/Core/Block/Main.hs deleted file mode 100644 index 38fbabf1be1..00000000000 --- a/core/Pos/Core/Block/Main.hs +++ /dev/null @@ -1,3 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF autoexporter #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} diff --git a/core/Pos/Core/Block/Main/Chain.hs b/core/Pos/Core/Block/Main/Chain.hs deleted file mode 100644 index 23abda37efe..00000000000 --- a/core/Pos/Core/Block/Main/Chain.hs +++ /dev/null @@ -1,98 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - --- | Definitions of the main blockchain ('Blockchain' class and related). - -module Pos.Core.Block.Main.Chain - ( BodyProof (..) - , ConsensusData (..) - , Body (..) - ) where - -import Universum - -import qualified Data.Text.Buildable -import Fmt (genericF) - -import Pos.Binary.Class (Bi) -import Pos.Binary.Core.Delegation () -import Pos.Binary.Core.Ssc () -import Pos.Binary.Core.Txp () -import Pos.Binary.Core.Update () -import Pos.Core.Block.Blockchain (Blockchain (..), GenericBlockHeader (..)) -import Pos.Core.Block.Main.Types (MainBlock, MainBlockchain, MainExtraBodyData, - MainExtraHeaderData, MainToSign (..)) -import Pos.Core.Block.Union.Types (Block, BlockHeader, BlockSignature (..)) -import Pos.Core.Class (IsMainHeader (..)) -import Pos.Core.Common (ChainDifficulty) -import Pos.Core.Configuration (HasConfiguration) -import Pos.Core.Delegation (DlgPayload) -import Pos.Core.Slotting.Types (SlotId (..)) -import Pos.Core.Ssc (SscPayload, SscProof, mkSscProof) -import Pos.Core.Txp (TxPayload, TxProof, mkTxProof) -import Pos.Core.Update (UpdatePayload, UpdateProof, mkUpdateProof) -import Pos.Crypto (Hash, PublicKey, hash) - -instance ( HasConfiguration - , Bi BlockHeader - , Bi (BodyProof MainBlockchain) - , IsMainHeader (GenericBlockHeader MainBlockchain)) => - Blockchain MainBlockchain where - - -- | Proof of everything contained in the payload. - data BodyProof MainBlockchain = MainProof - { mpTxProof :: !TxProof - , mpMpcProof :: !SscProof - , mpProxySKsProof :: !(Hash DlgPayload) - , mpUpdateProof :: !UpdateProof - } deriving (Eq, Show, Generic) - - data ConsensusData MainBlockchain = MainConsensusData - { -- | Id of the slot for which this block was generated. - _mcdSlot :: !SlotId - , -- | Public key of the slot leader. It's essential to have it here, - -- because FTS gives us only hash of public key (aka 'StakeholderId'). - _mcdLeaderKey :: !PublicKey - , -- | Difficulty of chain ending in this block. - _mcdDifficulty :: !ChainDifficulty - , -- | Signature given by slot leader. - _mcdSignature :: !BlockSignature - } deriving (Generic, Show, Eq) - - type BBlockHeader MainBlockchain = BlockHeader - type ExtraHeaderData MainBlockchain = MainExtraHeaderData - - -- | In our cryptocurrency, body consists of payloads of all block - -- components. - data Body MainBlockchain = MainBody - { -- | Txp payload. - _mbTxPayload :: !TxPayload - , -- | Ssc payload. - _mbSscPayload :: !SscPayload - , -- | Heavyweight delegation payload (no-ttl certificates). - _mbDlgPayload :: !DlgPayload - -- | Additional update information for the update system. - , _mbUpdatePayload :: !UpdatePayload - } deriving (Eq, Show, Generic, Typeable) - - type ExtraBodyData MainBlockchain = MainExtraBodyData - type BBlock MainBlockchain = Block - - mkBodyProof MainBody{..} = - MainProof - { mpTxProof = mkTxProof _mbTxPayload - , mpMpcProof = mkSscProof _mbSscPayload - , mpProxySKsProof = hash _mbDlgPayload - , mpUpdateProof = mkUpdateProof _mbUpdatePayload - } - -deriving instance Show MainToSign -deriving instance Eq MainToSign - -instance Buildable (BodyProof MainBlockchain) where - build = genericF - -instance NFData (BodyProof MainBlockchain) -instance NFData (ConsensusData MainBlockchain) -instance NFData (Body MainBlockchain) -instance NFData MainBlock diff --git a/core/Pos/Core/Block/Main/Types.hs b/core/Pos/Core/Block/Main/Types.hs deleted file mode 100644 index 145f3682421..00000000000 --- a/core/Pos/Core/Block/Main/Types.hs +++ /dev/null @@ -1,115 +0,0 @@ --- | Types defining the main blockchain. - -module Pos.Core.Block.Main.Types - ( MainBlockchain - , MainBlockHeader - , MainExtraBodyData (..) - , MainExtraHeaderData (..) - , BlockHeaderAttributes - , BlockBodyAttributes - , BlockSignature (..) - , MainToSign (..) - , MainBlock - ) where - -import Universum - -import qualified Data.Text.Buildable as Buildable -import Formatting (bprint, build, builder, (%)) - -import Pos.Binary.Crypto () -import Pos.Core.Block.Blockchain (Blockchain (..), GenericBlock (..), - GenericBlockHeader (..)) -import Pos.Core.Common (ChainDifficulty, HeaderHash) -import Pos.Core.Delegation (ProxySigHeavy, ProxySigLight) -import Pos.Core.Slotting.Types (SlotId (..)) -import Pos.Core.Update.Types (BlockVersion, SoftwareVersion) -import Pos.Crypto (Hash, Signature) -import Pos.Data.Attributes (Attributes, areAttributesKnown) - --- | Represents blockchain consisting of main blocks, i. e. blocks --- with actual payload (transactions, SSC, update system, etc.). -data MainBlockchain - --- | Data to be signed in main block. -data MainToSign - = MainToSign - { _msHeaderHash :: !HeaderHash -- ^ Hash of previous header - -- in the chain - , _msBodyProof :: !(BodyProof MainBlockchain) - , _msSlot :: !SlotId - , _msChainDiff :: !ChainDifficulty - , _msExtraHeader :: !MainExtraHeaderData - } deriving Generic - --- | Signature of the block. Can be either regular signature from the --- issuer or delegated signature having a constraint on epoch indices --- (it means the signature is valid only if block's slot id has epoch --- inside the constrained interval). -data BlockSignature - = BlockSignature (Signature MainToSign) - | BlockPSignatureLight (ProxySigLight MainToSign) - | BlockPSignatureHeavy (ProxySigHeavy MainToSign) - deriving (Show, Eq, Generic) - -instance NFData (BodyProof MainBlockchain) => NFData BlockSignature - -instance Buildable BlockSignature where - build (BlockSignature s) = bprint ("BlockSignature: "%build) s - build (BlockPSignatureLight s) = bprint ("BlockPSignatureLight: "%build) s - build (BlockPSignatureHeavy s) = bprint ("BlockPSignatureHeavy: "%build) s - --- | Represents main block body attributes: map from 1-byte integer to --- arbitrary-type value. To be used for extending block with new --- fields via softfork. -type BlockBodyAttributes = Attributes () - --- | Represents main block header attributes: map from 1-byte integer to --- arbitrary-type value. To be used for extending header with new --- fields via softfork. -type BlockHeaderAttributes = Attributes () - --- | Represents main block header extra data -data MainExtraHeaderData = MainExtraHeaderData - { -- | Version of block. - _mehBlockVersion :: !BlockVersion - , -- | Software version. - _mehSoftwareVersion :: !SoftwareVersion - , -- | Header attributes - _mehAttributes :: !BlockHeaderAttributes - , -- | Extra body data Hash - _mehEBDataProof :: !(Hash MainExtraBodyData) - } deriving (Eq, Show, Generic) - -instance NFData MainExtraHeaderData - -instance Buildable MainExtraHeaderData where - build MainExtraHeaderData {..} = - bprint ( " block: v"%build%"\n" - % " software: "%build%"\n" - % builder - ) - _mehBlockVersion - _mehSoftwareVersion - formattedExtra - where - formattedExtra - | areAttributesKnown _mehAttributes = mempty - | otherwise = bprint (" attributes: "%build%"\n") _mehAttributes - --- | Represents main block extra data -newtype MainExtraBodyData = MainExtraBodyData - { _mebAttributes :: BlockBodyAttributes - } deriving (Eq, Show, Generic, NFData) - -instance Buildable MainExtraBodyData where - build (MainExtraBodyData attrs) - | areAttributesKnown attrs = "no extra data" - | otherwise = bprint ("extra data has attributes: "%build) attrs - --- | Header of generic main block. -type MainBlockHeader = GenericBlockHeader MainBlockchain - --- | MainBlock is a block with transactions and MPC messages. It's the --- main part of our consensus algorithm. -type MainBlock = GenericBlock MainBlockchain diff --git a/core/Pos/Core/Block/Union.hs b/core/Pos/Core/Block/Union.hs deleted file mode 100644 index 27947fb88b8..00000000000 --- a/core/Pos/Core/Block/Union.hs +++ /dev/null @@ -1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/core/Pos/Core/Block/Union/Types.hs b/core/Pos/Core/Block/Union/Types.hs deleted file mode 100644 index b62cc8edfce..00000000000 --- a/core/Pos/Core/Block/Union/Types.hs +++ /dev/null @@ -1,68 +0,0 @@ --- | Union of blockchain types. - -module Pos.Core.Block.Union.Types - ( BlockHeader (BlockHeaderGenesis, BlockHeaderMain) - , _BlockHeaderGenesis - , _BlockHeaderMain - , choosingBlockHeader - , Block - , ComponentBlock (..) - - , blockHeaderHash - - , module Pos.Core.Block.Genesis.Types - , module Pos.Core.Block.Main.Types - ) where - -import Control.Lens (LensLike', makePrisms) -import Universum - -import Pos.Binary.Class (Bi) -import Pos.Core.Common (BlockHeader, HeaderHash) -import Pos.Crypto (unsafeHash) --- Re-exports -import Pos.Core.Block.Genesis.Types -import Pos.Core.Block.Main.Types -import Pos.Core.Class (IsGenesisHeader, IsMainHeader (..)) -import Pos.Util.Some (Some) - ----------------------------------------------------------------------------- --- GenesisBlock ∪ MainBlock ----------------------------------------------------------------------------- - --- | Either header of ordinary main block or genesis block. -data instance BlockHeader - = BlockHeaderGenesis GenesisBlockHeader - | BlockHeaderMain MainBlockHeader - -deriving instance Generic BlockHeader -deriving instance (Eq GenesisBlockHeader, Eq MainBlockHeader) => Eq BlockHeader -deriving instance (Show GenesisBlockHeader, Show MainBlockHeader) => Show BlockHeader - -makePrisms 'BlockHeaderGenesis - -choosingBlockHeader :: Functor f => - LensLike' f GenesisBlockHeader r - -> LensLike' f MainBlockHeader r - -> LensLike' f BlockHeader r -choosingBlockHeader onGenesis onMain f = \case - BlockHeaderGenesis bh -> BlockHeaderGenesis <$> onGenesis f bh - BlockHeaderMain bh -> BlockHeaderMain <$> onMain f bh - --- | Block. -type Block = Either GenesisBlock MainBlock - --- | Representation of 'Block' passed to a component. -data ComponentBlock payload = - ComponentBlockGenesis (Some IsGenesisHeader) - | ComponentBlockMain - { bcmHeader :: !(Some IsMainHeader) - , bcmPayload :: !payload } - --- | This function is required because type inference fails in attempts to --- hash only @Right@ or @Left@. --- --- Perhaps, it shouldn't be here, but I decided not to create a module --- for only this function. -blockHeaderHash :: Bi BlockHeader => BlockHeader -> HeaderHash -blockHeaderHash = unsafeHash diff --git a/core/Pos/Core/Class.hs b/core/Pos/Core/Class.hs deleted file mode 100644 index 60d113b5946..00000000000 --- a/core/Pos/Core/Class.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Pos.Core.Class - ( - -- * Classes for overloaded accessors - HasPrevBlock (..) - , HasDifficulty (..) - , isMoreDifficult - , HasBlockVersion (..) - , HasSoftwareVersion (..) - , HasHeaderHash (..) - , headerHashG - , HasEpochIndex (..) - , HasEpochOrSlot (..) - , epochOrSlotG - - -- * Classes for headers - , IsHeader - , IsGenesisHeader - , IsMainHeader (..) - ) where - -import Universum - -import Control.Lens (Getter, choosing, to) - -import Pos.Core.Common (ChainDifficulty, HeaderHash) -import Pos.Core.Slotting.Types (EpochIndex, EpochOrSlot (..), SlotId) -import Pos.Core.Update.Types (BlockVersion, SoftwareVersion) -import Pos.Crypto.Signing (PublicKey) -import Pos.Util.Some (Some, applySome, liftLensSome) - -#define SOME_LENS_CLASS(HAS, LENS, CL) \ - instance HAS (Some CL) where LENS = liftLensSome LENS -#define SOME_FUNC_CLASS(HAS, FUNC, CL) \ - instance HAS (Some CL) where FUNC = applySome FUNC - ----------------------------------------------------------------------------- --- Classes for overloaded accessors ----------------------------------------------------------------------------- - --- HasPrevBlock --- | Class for something that has previous block (lens to 'Hash' for this block). -class HasPrevBlock s where - prevBlockL :: Lens' s HeaderHash - -SOME_LENS_CLASS(HasPrevBlock, prevBlockL, HasPrevBlock) - -instance (HasPrevBlock s, HasPrevBlock s') => - HasPrevBlock (Either s s') where - prevBlockL = choosing prevBlockL prevBlockL - - --- Perhaps it is not the best instance. -instance {-# OVERLAPPABLE #-} HasPrevBlock s => HasPrevBlock (s, z) where - prevBlockL = _1 . prevBlockL - --- HasDifficulty -class HasDifficulty a where - difficultyL :: Lens' a ChainDifficulty - -SOME_LENS_CLASS(HasDifficulty, difficultyL, HasDifficulty) - -isMoreDifficult :: HasDifficulty a => a -> a -> Bool -a `isMoreDifficult` b = a ^. difficultyL > b ^. difficultyL - --- HasBlockVersion -class HasBlockVersion a where - blockVersionL :: Lens' a BlockVersion - -SOME_LENS_CLASS(HasBlockVersion, blockVersionL, HasBlockVersion) - --- HasSoftwareVersion -class HasSoftwareVersion a where - softwareVersionL :: Lens' a SoftwareVersion - -SOME_LENS_CLASS(HasSoftwareVersion, softwareVersionL, HasSoftwareVersion) - --- HasHeaderHash -class HasHeaderHash a where - headerHash :: a -> HeaderHash - -SOME_FUNC_CLASS(HasHeaderHash, headerHash, HasHeaderHash) - -instance HasHeaderHash HeaderHash where - headerHash = identity - -headerHashG :: HasHeaderHash a => Getter a HeaderHash -headerHashG = to headerHash - --- HasEpochIndex -class HasEpochIndex a where - epochIndexL :: Lens' a EpochIndex - -SOME_LENS_CLASS(HasEpochIndex, epochIndexL, HasEpochIndex) - -instance (HasEpochIndex a, HasEpochIndex b) => - HasEpochIndex (Either a b) where - epochIndexL = choosing epochIndexL epochIndexL - --- HasEpochOrSlot -class HasEpochOrSlot a where - getEpochOrSlot :: a -> EpochOrSlot - -SOME_FUNC_CLASS(HasEpochOrSlot, getEpochOrSlot, HasEpochOrSlot) - -epochOrSlotG :: HasEpochOrSlot a => Getter a EpochOrSlot -epochOrSlotG = to getEpochOrSlot - -instance HasEpochOrSlot EpochIndex where - getEpochOrSlot = EpochOrSlot . Left -instance HasEpochOrSlot SlotId where - getEpochOrSlot = EpochOrSlot . Right -instance HasEpochOrSlot EpochOrSlot where - getEpochOrSlot = identity -instance (HasEpochOrSlot a, HasEpochOrSlot b) => - HasEpochOrSlot (Either a b) where - getEpochOrSlot = either getEpochOrSlot getEpochOrSlot - ----------------------------------------------------------------------------- --- Classes for headers ----------------------------------------------------------------------------- - --- Add (..) to export list when IsHeader or IsGenesisHeader get any methods - -{- | A class that lets subpackages use some fields from headers without -depending on cardano-sl: - - * 'difficultyL' - * 'epochIndexL' - * 'epochOrSlotG' - * 'prevBlockL' - * 'headerHashG' --} -class ( HasDifficulty header - , HasEpochIndex header - , HasEpochOrSlot header - , HasPrevBlock header - , HasHeaderHash header) => - IsHeader header - -SOME_LENS_CLASS(HasDifficulty, difficultyL, IsHeader) -SOME_LENS_CLASS(HasEpochIndex, epochIndexL, IsHeader) -SOME_FUNC_CLASS(HasEpochOrSlot, getEpochOrSlot, IsHeader) -SOME_LENS_CLASS(HasPrevBlock, prevBlockL, IsHeader) -SOME_FUNC_CLASS(HasHeaderHash, headerHash, IsHeader) - -instance IsHeader (Some IsHeader) - --- | A class for genesis headers. -class IsHeader header => IsGenesisHeader header - -SOME_LENS_CLASS(HasDifficulty, difficultyL, IsGenesisHeader) -SOME_LENS_CLASS(HasEpochIndex, epochIndexL, IsGenesisHeader) -SOME_FUNC_CLASS(HasEpochOrSlot, getEpochOrSlot, IsGenesisHeader) -SOME_LENS_CLASS(HasPrevBlock, prevBlockL, IsGenesisHeader) -SOME_FUNC_CLASS(HasHeaderHash, headerHash, IsGenesisHeader) - -instance IsHeader (Some IsGenesisHeader) -instance IsGenesisHeader (Some IsGenesisHeader) - -{- | A class for main headers. In addition to 'IsHeader', provides: - - * 'headerSlotL' - * 'headerLeaderKeyL' - * 'blockVersionL' - * 'softwareVersionL' --} -class (IsHeader header - ,HasBlockVersion header - ,HasSoftwareVersion header) => - IsMainHeader header - where - -- | Id of the slot for which this block was generated. - headerSlotL :: Lens' header SlotId - -- | Public key of slot leader. - headerLeaderKeyL :: Lens' header PublicKey - -SOME_LENS_CLASS(HasDifficulty, difficultyL, IsMainHeader) -SOME_LENS_CLASS(HasEpochIndex, epochIndexL, IsMainHeader) -SOME_FUNC_CLASS(HasEpochOrSlot, getEpochOrSlot, IsMainHeader) -SOME_LENS_CLASS(HasPrevBlock, prevBlockL, IsMainHeader) -SOME_FUNC_CLASS(HasHeaderHash, headerHash, IsMainHeader) -SOME_LENS_CLASS(HasBlockVersion, blockVersionL, IsMainHeader) -SOME_LENS_CLASS(HasSoftwareVersion, softwareVersionL, IsMainHeader) - -instance IsHeader (Some IsMainHeader) -instance IsMainHeader (Some IsMainHeader) where - headerSlotL = liftLensSome headerSlotL - headerLeaderKeyL = liftLensSome headerLeaderKeyL diff --git a/core/Pos/Core/Common.hs b/core/Pos/Core/Common.hs deleted file mode 100644 index b48dcd7b3ac..00000000000 --- a/core/Pos/Core/Common.hs +++ /dev/null @@ -1,2 +0,0 @@ --- Pos.Core.Common -{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/core/Pos/Core/Common/Types.hs b/core/Pos/Core/Common/Types.hs deleted file mode 100644 index df5f62a3044..00000000000 --- a/core/Pos/Core/Common/Types.hs +++ /dev/null @@ -1,408 +0,0 @@ --- | Common core types essential for multiple components. - -module Pos.Core.Common.Types - ( - -- * Address and StakeholderId - AddressHash - , AddrSpendingData (..) - , AddrType (..) - , Address' (..) - , AddrAttributes (..) - , AddrStakeDistribution (..) - , MultiKeyDistrError (..) - , mkMultiKeyDistr - , Address (..) - - -- * Forward-declared BlockHeader - , BlockHeader - - -- * Stakeholders - , StakeholderId - , StakesMap - , StakesList - - -- * ChainDifficulty - , ChainDifficulty (..) - - -- * HeaderHash related types and functions - , HeaderHash - , headerHashF - - , SharedSeed (..) - , SlotLeaders - , slotLeadersF - - -- * Coin - , Coin (..) - , CoinPortion (..) - , mkCoin - , checkCoin - , coinF - , unsafeGetCoin - , coinPortionDenominator - , checkCoinPortion - , unsafeCoinPortionFromDouble - , maxCoinVal - - -- * Scripting - , Script(..) - , Script_v0 - , ScriptVersion - - -- * Newtypes - -- ** for amounts - , BlockCount(..) - ) where - -import Universum - -import Control.Exception.Safe (Exception (displayException)) -import Control.Lens (makePrisms) -import Control.Monad.Except (MonadError (throwError)) -import Crypto.Hash (Blake2b_224) -import qualified Data.ByteString as BS (pack, zipWith) -import qualified Data.ByteString.Char8 as BSC (pack) -import Data.Data (Data) -import Data.Hashable (Hashable (..)) -import qualified Data.Semigroup (Semigroup (..)) -import qualified Data.Text.Buildable as Buildable -import Formatting (Format, bprint, build, int, later, sformat, (%)) -import qualified PlutusCore.Program as PLCore -import Serokell.Util (enumerate, listChunkedJson, pairBuilder) -import Serokell.Util.Base16 (formatBase16) -import System.Random (Random (..)) - -import Pos.Core.Constants (sharedSeedLength) -import Pos.Crypto.Hashing (AbstractHash, Hash) -import Pos.Crypto.HD (HDAddressPayload) -import Pos.Crypto.Signing (PublicKey, RedeemPublicKey) -import Pos.Data.Attributes (Attributes) - ----------------------------------------------------------------------------- --- Address, StakeholderId ----------------------------------------------------------------------------- - --- | Hash used to identify address. -type AddressHash = AbstractHash Blake2b_224 - --- | Stakeholder identifier (stakeholders are identified by their public keys) -type StakeholderId = AddressHash PublicKey - --- | A mapping between stakeholders and they stakes. -type StakesMap = HashMap StakeholderId Coin - --- | Stakeholders and their stakes. -type StakesList = [(StakeholderId, Coin)] - --- | Data which is bound to an address and must be revealed in order --- to spend coins belonging to this address. -data AddrSpendingData - = PubKeyASD !PublicKey - -- ^ Funds can be spent by revealing a 'PublicKey' and providing a - -- valid signature. - | ScriptASD !Script - -- ^ Funds can be spent by revealing a 'Script' and providing a - -- redeemer 'Script'. - | RedeemASD !RedeemPublicKey - -- ^ Funds can be spent by revealing a 'RedeemPublicKey' and providing a - -- valid signature. - | UnknownASD !Word8 !ByteString - -- ^ Unknown type of spending data. It consists of a tag and - -- arbitrary 'ByteString'. It allows us to introduce a new type of - -- spending data via softfork. - deriving (Eq, Generic, Typeable, Show) - --- | Type of an address. It corresponds to constructors of --- 'AddrSpendingData'. It's separated, because 'Address' doesn't store --- 'AddrSpendingData', but we want to know its type. -data AddrType - = ATPubKey - | ATScript - | ATRedeem - | ATUnknown !Word8 - deriving (Eq, Ord, Generic, Typeable, Show) - --- | Stake distribution associated with an address. -data AddrStakeDistribution - = BootstrapEraDistr - -- ^ Stake distribution for bootstrap era. - | SingleKeyDistr !StakeholderId - -- ^ Stake distribution stating that all stake should go to the given stakeholder. - | UnsafeMultiKeyDistr !(Map StakeholderId CoinPortion) - -- ^ Stake distribution which gives stake to multiple - -- stakeholders. 'CoinPortion' is a portion of an output (output - -- has a value, portion of this value is stake). The constructor - -- is unsafe because there are some predicates which must hold: - -- - -- • the sum of portions must be @maxBound@ (basically 1); - -- • all portions must be positive; - -- • there must be at least 2 items, because if there is only one item, - -- 'SingleKeyDistr' can be used instead (which is smaller). - deriving (Eq, Ord, Show, Generic, Typeable) - -data MultiKeyDistrError - = MkdMapIsEmpty - | MkdMapIsSingleton - | MkdNegativePortion - | MkdSumNot1 - deriving (Show) - -instance Buildable MultiKeyDistrError where - build = mappend "mkMultiKeyDistr: " . \case - MkdMapIsEmpty -> "map is empty" - MkdMapIsSingleton -> "map's size is 1, use SingleKeyDistr" - MkdNegativePortion -> "all portions must be positive" - MkdSumNot1 -> "distributions' sum must be equal to 1" - -instance Exception MultiKeyDistrError where - displayException = toString . pretty - --- | Safe constructor of multi-key distribution. It checks invariants --- of this distribution and returns an error if something is violated. -mkMultiKeyDistr :: - MonadError MultiKeyDistrError m - => Map StakeholderId CoinPortion - -> m AddrStakeDistribution -mkMultiKeyDistr distrMap = UnsafeMultiKeyDistr distrMap <$ check - where - check = do - when (null distrMap) $ throwError MkdMapIsEmpty - when (length distrMap == 1) $ throwError MkdMapIsSingleton - unless (all ((> 0) . getCoinPortion) distrMap) $ - throwError MkdNegativePortion - let distrSum = sum $ map getCoinPortion distrMap - unless (distrSum == coinPortionDenominator) $ - throwError MkdSumNot1 - --- | Additional information stored along with address. It's intended --- to be put into 'Attributes' data type to make it extensible with --- softfork. -data AddrAttributes = AddrAttributes - { aaPkDerivationPath :: !(Maybe HDAddressPayload) - , aaStakeDistribution :: !AddrStakeDistribution - } deriving (Eq, Ord, Show, Generic, Typeable) - --- | Hash of this data is stored in 'Address'. This type exists mostly --- for internal usage. -newtype Address' = Address' - { unAddress' :: (AddrType, AddrSpendingData, Attributes AddrAttributes) - } deriving (Eq, Show, Generic, Typeable) - --- | 'Address' is where you can send coins. -data Address = Address - { addrRoot :: !(AddressHash Address') - -- ^ Root of imaginary pseudo Merkle tree stored in this address. - , addrAttributes :: !(Attributes AddrAttributes) - -- ^ Attributes associated with this address. - , addrType :: !AddrType - -- ^ The type of this address. Should correspond to - -- 'AddrSpendingData', but it can't be checked statically, because - -- spending data is hashed. - } deriving (Eq, Ord, Generic, Typeable, Show) - -instance NFData AddrType -instance NFData AddrSpendingData -instance NFData AddrAttributes -instance NFData AddrStakeDistribution -instance NFData Address - ----------------------------------------------------------------------------- --- ChainDifficulty ----------------------------------------------------------------------------- - --- | Chain difficulty represents necessary effort to generate a --- chain. In the simplest case it can be number of blocks in chain. -newtype ChainDifficulty = ChainDifficulty - { getChainDifficulty :: BlockCount - } deriving (Show, Eq, Ord, Num, Enum, Real, Integral, Generic, Buildable, Typeable, NFData) - ----------------------------------------------------------------------------- --- BlockHeader (forward-declaration) ----------------------------------------------------------------------------- - --- We use a data family instead of a data type solely to avoid a module --- cycle. Grep for @data instance BlockHeader@ to find the definition. --- --- | Forward-declaration of block headers. See the corresponding type instance --- for the actual definition. -data family BlockHeader - ----------------------------------------------------------------------------- --- HeaderHash ----------------------------------------------------------------------------- - --- | 'Hash' of block header. -type HeaderHash = Hash BlockHeader - --- | Specialized formatter for 'HeaderHash'. -headerHashF :: Format r (HeaderHash -> r) -headerHashF = build - ----------------------------------------------------------------------------- --- SSC. It means shared seed computation, btw ----------------------------------------------------------------------------- - --- | This is a shared seed used for follow-the-satoshi. This seed is --- randomly generated by each party and eventually they agree on the --- same value. -newtype SharedSeed = SharedSeed - { getSharedSeed :: ByteString - } deriving (Show, Eq, Ord, Generic, NFData, Typeable) - -instance Buildable SharedSeed where - build = formatBase16 . getSharedSeed - -instance Semigroup SharedSeed where - (<>) (SharedSeed a) (SharedSeed b) = - SharedSeed $ BS.pack (BS.zipWith xor a b) -- fast due to rewrite rules - -instance Monoid SharedSeed where - mempty = SharedSeed $ BSC.pack $ replicate sharedSeedLength '\NUL' - mappend = (Data.Semigroup.<>) - mconcat = foldl' mappend mempty - --- | 'NonEmpty' list of slot leaders. -type SlotLeaders = NonEmpty StakeholderId - --- | Pretty-printer for slot leaders. Note: it takes list (not --- 'NonEmpty' as an argument, because one can always convert @NonEmpty --- a@ to @[a]@, but it also may be convenient to use it with a simple --- list of slot leaders). --- --- Example: --- [ --- (0, 44283ce5), (1, 5f53e01e), (2, 44283ce5), (3, 1a1ff703), (4, 44283ce5), (5, 44283ce5), (6, 281e5ae9), (7, 1a1ff703) --- (8, 1a1ff703), (9, 5f53e01e), (10, 1a1ff703), (11, 44283ce5), (12, 44283ce5), (13, 5f53e01e), (14, 5f53e01e), (15, 5f53e01e) --- (16, 44283ce5), (17, 281e5ae9), (18, 281e5ae9), (19, 44283ce5) --- ] -slotLeadersF :: Format r ([StakeholderId] -> r) -slotLeadersF = - later $ bprint (listChunkedJson 8) . map pairBuilder . enumerate @Int - ----------------------------------------------------------------------------- --- Coin ----------------------------------------------------------------------------- - --- | Coin is the least possible unit of currency. -newtype Coin = Coin - { getCoin :: Word64 - } deriving (Show, Ord, Eq, Generic, Hashable, Data, NFData) - -instance Buildable Coin where - build (Coin n) = bprint (int%" coin(s)") n - -instance Bounded Coin where - minBound = Coin 0 - maxBound = Coin maxCoinVal - --- | Maximal possible value of 'Coin'. -maxCoinVal :: Word64 -maxCoinVal = 45000000000000000 - --- | Makes a 'Coin' but is _|_ if that coin exceeds 'maxCoinVal'. --- You can also use 'checkCoin' to do that check. -mkCoin :: Word64 -> Coin -mkCoin c = either error (const coin) (checkCoin coin) - where - coin = (Coin c) -{-# INLINE mkCoin #-} - -checkCoin :: MonadError Text m => Coin -> m () -checkCoin (Coin c) - | c <= maxCoinVal = pure () - | otherwise = throwError $ "Coin: " <> show c <> " is too large" - --- | Coin formatter which restricts type. -coinF :: Format r (Coin -> r) -coinF = build - --- | Unwraps 'Coin'. It's called “unsafe” so that people wouldn't use it --- willy-nilly if they want to sum coins or something. It's actually safe. -unsafeGetCoin :: Coin -> Word64 -unsafeGetCoin = getCoin -{-# INLINE unsafeGetCoin #-} - --- | CoinPortion is some portion of Coin; it is interpreted as a fraction --- with denominator of 'coinPortionDenominator'. The numerator must be in the --- interval of [0, coinPortionDenominator]. --- --- Usually 'CoinPortion' is used to determine some threshold expressed as --- portion of total stake. --- --- To multiply a coin portion by 'Coin', use 'applyCoinPortionDown' (when --- calculating number of coins) or 'applyCoinPortionUp' (when calculating a --- threshold). -newtype CoinPortion = CoinPortion - { getCoinPortion :: Word64 - } deriving (Show, Ord, Eq, Generic, Typeable, NFData, Hashable) - --- | Denominator used by 'CoinPortion'. -coinPortionDenominator :: Word64 -coinPortionDenominator = (10 :: Word64) ^ (15 :: Word64) - -instance Bounded CoinPortion where - minBound = CoinPortion 0 - maxBound = CoinPortion coinPortionDenominator - --- | Make 'CoinPortion' from 'Word64' checking whether it is not greater --- than 'coinPortionDenominator'. -checkCoinPortion - :: MonadError Text m - => CoinPortion -> m () -checkCoinPortion (CoinPortion x) - | x <= coinPortionDenominator = pure () - | otherwise = throwError err - where - err = - sformat - ("CoinPortion: value is greater than coinPortionDenominator: " - %int) x - --- | Make CoinPortion from Double. Caller must ensure that value is in --- [0..1]. Internally 'CoinPortion' stores 'Word64' which is divided by --- 'coinPortionDenominator' to get actual value. So some rounding may take --- place. -unsafeCoinPortionFromDouble :: Double -> CoinPortion -unsafeCoinPortionFromDouble x - | 0 <= x && x <= 1 = CoinPortion v - | otherwise = error "unsafeCoinPortionFromDouble: double not in [0, 1]" - where - v = round $ realToFrac coinPortionDenominator * x -{-# INLINE unsafeCoinPortionFromDouble #-} - ----------------------------------------------------------------------------- --- Script ----------------------------------------------------------------------------- - --- | Version of script -type ScriptVersion = Word16 - --- | A script for inclusion into a transaction. -data Script = Script - { scrVersion :: ScriptVersion -- ^ Version - , scrScript :: ByteString -- ^ Serialized script - } deriving (Eq, Show, Generic, Typeable) - -instance NFData Script -instance Hashable Script - -instance Buildable Script where - build Script{..} = bprint (" + + + + + + +|] + + +-- +-- The API +-- + +data DescriptionEnvironment = DescriptionEnvironment + { deErrorExample :: !T.Text + , deDefaultPerPage :: !T.Text + , deWalletErrorTable :: !T.Text + , deGitRevision :: !T.Text + , deSoftwareVersion :: !T.Text + , deMnemonicExample :: !T.Text + } + +api :: HasSwagger a + => (CompileTimeInfo, SoftwareVersion) + -> Proxy a + -> (DescriptionEnvironment -> T.Text) + -> Swagger +api (compileInfo, curSoftwareVersion) walletAPI mkDescription = toSwagger walletAPI + & info.title .~ "Cardano Wallet API" + & info.version .~ fromString (show curSoftwareVersion) + & host ?~ "127.0.0.1:8090" + & info.description ?~ (mkDescription $ DescriptionEnvironment + { deErrorExample = decodeUtf8 $ encodePretty Errors.WalletNotFound + , deMnemonicExample = T.intercalate ", " . map (surroundedBy "\"") . bpToList $ genExample + , deDefaultPerPage = fromString (show defaultPerPageEntries) + , deWalletErrorTable = errorsDescription + , deGitRevision = ctiGitRevision compileInfo + , deSoftwareVersion = fromString $ show curSoftwareVersion + }) + & info.license ?~ ("MIT" & url ?~ URL "https://raw.githubusercontent.com/input-output-hk/cardano-sl/develop/lib/LICENSE") diff --git a/wallet-new/server/Cardano/Wallet/API/V1/Swagger/Example.hs b/wallet-new/src/Cardano/Wallet/API/V1/Swagger/Example.hs similarity index 75% rename from wallet-new/server/Cardano/Wallet/API/V1/Swagger/Example.hs rename to wallet-new/src/Cardano/Wallet/API/V1/Swagger/Example.hs index de71d9efa74..3c0501c5d73 100644 --- a/wallet-new/server/Cardano/Wallet/API/V1/Swagger/Example.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Swagger/Example.hs @@ -2,19 +2,22 @@ module Cardano.Wallet.API.V1.Swagger.Example where import Universum +import Test.QuickCheck (Arbitrary (..), Gen, listOf1, oneof) + import Cardano.Wallet.API.Response import Cardano.Wallet.API.V1.Types import Cardano.Wallet.Orphans.Arbitrary () - +import Data.Default (Default (def)) +import Node (NodeId (..)) import Pos.Arbitrary.Wallet.Web.ClientTypes () import Pos.Client.Txp.Util (InputSelectionPolicy (..)) -import qualified Pos.Core.Common as Core -import qualified Pos.Crypto.Signing as Core import Pos.Util.BackupPhrase (BackupPhrase) import Pos.Wallet.Web.ClientTypes (CUpdateInfo) import Pos.Wallet.Web.Methods.Misc (WalletStateSnapshot (..)) -import Test.QuickCheck (Arbitrary (..), Gen, listOf1) +import qualified Data.Map.Strict as Map +import qualified Pos.Core.Common as Core +import qualified Pos.Crypto.Signing as Core class Arbitrary a => Example a where @@ -32,6 +35,10 @@ instance Example a => Example [a] where instance Example a => Example (Maybe a) where example = Just <$> example +-- NOTE: we don't want to see empty maps in our swagger doc :) +instance (Ord k, Example k, Example v) => Example (Map k v) where + example = Map.fromList <$> listOf1 ((,) <$> example <*> example) + instance Example (V1 Core.PassPhrase) instance Example (V1 Core.Coin) @@ -40,12 +47,31 @@ instance Example a => Example (WalletResponse a) where <*> pure SuccessStatus <*> example +-- | We have a specific 'Example' instance for @'V1' 'Address'@ because we want +-- to control the length of the examples. It is possible for the encoded length +-- to become huge, up to 1000+ bytes, if the 'UnsafeMultiKeyDistr' constructor +-- is used. We do not use this constructor, which keeps the address between +-- ~80-150 bytes long. +instance Example (V1 Address) where + example = fmap V1 . Core.makeAddress + <$> arbitrary + <*> arbitraryAttributes + where + arbitraryAttributes = + Core.AddrAttributes + <$> arbitrary + <*> oneof + [ pure Core.BootstrapEraDistr + , Core.SingleKeyDistr <$> arbitrary + ] + +instance Example BackupPhrase where + example = pure def + instance Example Address -instance Example (V1 Address) instance Example Metadata instance Example AccountIndex instance Example WalletId -instance Example BackupPhrase instance Example (V1 BackupPhrase) instance Example AssuranceLevel instance Example SyncPercentage @@ -68,6 +94,8 @@ instance Example TimeInfo instance Example AddressValidity instance Example NewAddress instance Example CUpdateInfo +instance Example SubscriptionStatus +instance Example NodeId instance Example InputSelectionPolicy where example = pure OptimizeForHighThroughput @@ -94,6 +122,7 @@ instance Example NodeInfo where <*> example -- NOTE: will produce `Just a` <*> example <*> example + <*> example instance Example PaymentSource where example = PaymentSource <$> example diff --git a/wallet-new/src/Cardano/Wallet/API/V1/Types.hs b/wallet-new/src/Cardano/Wallet/API/V1/Types.hs index 80e1043f442..6f7ac8de39d 100644 --- a/wallet-new/src/Cardano/Wallet/API/V1/Types.hs +++ b/wallet-new/src/Cardano/Wallet/API/V1/Types.hs @@ -37,6 +37,7 @@ module Cardano.Wallet.API.V1.Types ( , AddressValidity (..) -- * Accounts , Account (..) + , accountsHaveSameId , AccountIndex -- * Addresses , WalletAddress (..) @@ -70,6 +71,7 @@ module Cardano.Wallet.API.V1.Types ( , mkSyncPercentage , NodeInfo (..) , TimeInfo(..) + , SubscriptionStatus(..) -- * Some types for the API , CaptureWalletId , CaptureAccountId @@ -82,17 +84,20 @@ import Universum import Control.Lens (At, Index, IxValue, at, ix, makePrisms, to, (?~)) import Data.Aeson import Data.Aeson.TH as A -import Data.Aeson.Types (typeMismatch) +import Data.Aeson.Types (toJSONKeyText, typeMismatch) import qualified Data.Char as C -import Data.Swagger as S hiding (constructorTagModifier) +import Data.Swagger as S import Data.Swagger.Declare (Declare, look) import Data.Swagger.Internal.Schema (GToSchema) +import Data.Swagger.Internal.TypeShape (GenericHasSimpleShape, GenericShape) import Data.Text (Text, dropEnd, toLower) import qualified Data.Text as T import qualified Data.Text.Buildable import Data.Version (Version) import Formatting (bprint, build, fconst, int, sformat, (%)) import GHC.Generics (Generic, Rep) +import Network.Transport (EndPointAddress (..)) +import Node (NodeId (..)) import qualified Prelude import qualified Serokell.Aeson.Options as Serokell import Serokell.Util (listJson) @@ -114,19 +119,19 @@ import Pos.Wallet.Web.ClientTypes.Instances () import Cardano.Wallet.Util (showApiUtcTime) import qualified Data.ByteArray as ByteArray import qualified Data.ByteString as BS -import Data.Swagger.Internal.TypeShape (GenericHasSimpleShape, GenericShape) +import qualified Data.Map.Strict as Map import Pos.Aeson.Core () -import Pos.Arbitrary.Core () import qualified Pos.Client.Txp.Util as Core import Pos.Core (addressF) import qualified Pos.Core as Core import Pos.Crypto (decodeHash, hashHexF) import qualified Pos.Crypto.Signing as Core -import Pos.Util.LogSafe (BuildableSafeGen (..), SecureLog (..), buildSafe, buildSafeList, +import Pos.Infra.Diffusion.Subscription.Status (SubscriptionStatus (..)) +import Pos.Infra.Util.LogSafe (BuildableSafeGen (..), SecureLog (..), buildSafe, buildSafeList, buildSafeMaybe, deriveSafeBuildable, plainOrSecureF) import qualified Pos.Wallet.Web.State.Storage as OldStorage - +import Test.Pos.Core.Arbitrary () -- | Declare generic schema, while documenting properties -- For instance: @@ -234,6 +239,8 @@ instance Buildable a => Buildable (V1 a) where instance Buildable (SecureLog a) => Buildable (SecureLog (V1 a)) where build (SecureLog (V1 x)) = bprint build (SecureLog x) +instance (Buildable a, Buildable b) => Buildable (a, b) where + build (a, b) = bprint ("("%build%", "%build%")") a b -- -- Benign instances @@ -396,7 +403,7 @@ data AssuranceLevel = instance Arbitrary AssuranceLevel where arbitrary = elements [minBound .. maxBound] -deriveJSON Serokell.defaultOptions { constructorTagModifier = toString . toLower . dropEnd 9 . fromString +deriveJSON Serokell.defaultOptions { A.constructorTagModifier = toString . toLower . dropEnd 9 . fromString } ''AssuranceLevel instance ToSchema AssuranceLevel where @@ -418,6 +425,8 @@ deriveJSON Serokell.defaultOptions ''WalletId instance ToSchema WalletId where declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions +instance ToJSONKey WalletId + instance Arbitrary WalletId where arbitrary = let wid = "J7rQqaLLHBFPrgJXwpktaMB1B1kQBXAyc2uRSfRPzNVGiv6TdxBzkPNBUWysZZZdhFG9gRy3sQFfX5wfpLbi4XTFGFxTg" @@ -445,7 +454,7 @@ instance Arbitrary WalletOperation where arbitrary = elements [minBound .. maxBound] -- Drops the @Wallet@ suffix. -deriveJSON Serokell.defaultOptions { constructorTagModifier = reverse . drop 6 . reverse . map C.toLower +deriveJSON Serokell.defaultOptions { A.constructorTagModifier = reverse . drop 6 . reverse . map C.toLower } ''WalletOperation instance ToSchema WalletOperation where @@ -786,11 +795,7 @@ instance BuildableSafeGen Wallet where %" balance="%buildSafe sl %" }") walId - -- TODO(parsons.matt): remove this when we find out *why* this is - -- causing it to fail. - -- - -- https://iohk.myjetbrains.com/youtrack/issue/R120-4#comment=93-20855 - (T.filter C.isAscii walName) + walName walBalance instance Buildable [Wallet] where @@ -854,6 +859,12 @@ data Account = Account , accWalletId :: !WalletId } deriving (Show, Ord, Eq, Generic) +accountsHaveSameId :: Account -> Account -> Bool +accountsHaveSameId a b = + accWalletId a == accWalletId b + && + accIndex a == accIndex b + deriveJSON Serokell.defaultOptions ''Account instance ToSchema Account where @@ -1047,8 +1058,8 @@ instance BuildableSafeGen EstimatedFees where -- | Maps an 'Address' to some 'Coin's, and it's -- typically used to specify where to send money during a 'Payment'. data PaymentDistribution = PaymentDistribution { - pdAddress :: V1 (Core.Address) - , pdAmount :: V1 (Core.Coin) + pdAddress :: !(V1 Core.Address) + , pdAmount :: !(V1 Core.Coin) } deriving (Show, Ord, Eq, Generic) deriveJSON Serokell.defaultOptions ''PaymentDistribution @@ -1204,7 +1215,7 @@ instance Arbitrary TransactionType where arbitrary = elements [minBound .. maxBound] -- Drops the @Transaction@ suffix. -deriveJSON defaultOptions { constructorTagModifier = reverse . drop 11 . reverse . map C.toLower +deriveJSON defaultOptions { A.constructorTagModifier = reverse . drop 11 . reverse . map C.toLower } ''TransactionType instance ToSchema TransactionType where @@ -1236,7 +1247,7 @@ instance Arbitrary TransactionDirection where arbitrary = elements [minBound .. maxBound] -- Drops the @Transaction@ suffix. -deriveJSON defaultOptions { constructorTagModifier = reverse . drop 11 . reverse . map C.toLower +deriveJSON defaultOptions { A.constructorTagModifier = reverse . drop 11 . reverse . map C.toLower } ''TransactionDirection instance ToSchema TransactionDirection where @@ -1645,7 +1656,6 @@ instance Arbitrary TimeInfo where arbitrary = TimeInfo <$> arbitrary deriveSafeBuildable ''TimeInfo - instance BuildableSafeGen TimeInfo where buildSafeGen _ TimeInfo{..} = bprint ("{" %" differenceFromNtpServer="%build @@ -1654,12 +1664,64 @@ instance BuildableSafeGen TimeInfo where deriveJSON Serokell.defaultOptions ''TimeInfo + +availableSubscriptionStatus :: [SubscriptionStatus] +availableSubscriptionStatus = [Subscribed, Subscribing] + +deriveSafeBuildable ''SubscriptionStatus +instance BuildableSafeGen SubscriptionStatus where + buildSafeGen _ = \case + Subscribed -> "Subscribed" + Subscribing -> "Subscribing" + +deriveJSON Serokell.defaultOptions ''SubscriptionStatus + +instance Arbitrary SubscriptionStatus where + arbitrary = + elements availableSubscriptionStatus + +instance ToSchema SubscriptionStatus where + declareNamedSchema _ = do + let enum = toJSON <$> availableSubscriptionStatus + pure $ NamedSchema (Just "SubscriptionStatus") $ mempty + & type_ .~ SwaggerString + & enum_ ?~ enum + +instance FromJSONKey NodeId where + fromJSONKey = + FromJSONKeyText (NodeId . EndPointAddress . encodeUtf8) + +instance ToJSONKey NodeId where + toJSONKey = + toJSONKeyText (decodeUtf8 . getAddress) + where + getAddress (NodeId (EndPointAddress x)) = x + +instance ToSchema NodeId where + declareNamedSchema _ = pure $ NamedSchema (Just "NodeId") $ mempty + & type_ .~ SwaggerString + +instance Arbitrary NodeId where + arbitrary = do + ipv4 <- genIPv4 + port_ <- genPort + idx <- genIdx + return . toNodeId $ ipv4 <> ":" <> port_ <> ":" <> idx + where + toNodeId = NodeId . EndPointAddress . encodeUtf8 + showT = show :: Int -> Text + genIdx = showT <$> choose (0, 9) + genPort = showT <$> choose (1000, 8000) + genIPv4 = T.intercalate "." <$> replicateM 4 (showT <$> choose (0, 255)) + + -- | The @dynamic@ information for this node. data NodeInfo = NodeInfo { nfoSyncProgress :: !SyncPercentage , nfoBlockchainHeight :: !(Maybe BlockchainHeight) , nfoLocalBlockchainHeight :: !BlockchainHeight , nfoLocalTimeInformation :: !TimeInfo + , nfoSubscriptionStatus :: Map NodeId SubscriptionStatus } deriving (Show, Eq, Generic) deriveJSON Serokell.defaultOptions ''NodeInfo @@ -1671,6 +1733,7 @@ instance ToSchema NodeInfo where & ("blockchainHeight" --^ "If known, the current blockchain height, in number of blocks.") & ("localBlockchainHeight" --^ "Local blockchain height, in number of blocks.") & ("localTimeInformation" --^ "Information about the clock on this node.") + & ("subscriptionStatus" --^ "Is the node connected to the network?") ) instance Arbitrary NodeInfo where @@ -1678,6 +1741,7 @@ instance Arbitrary NodeInfo where <*> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary deriveSafeBuildable ''NodeInfo instance BuildableSafeGen NodeInfo where @@ -1686,11 +1750,13 @@ instance BuildableSafeGen NodeInfo where %" blockchainHeight="%build %" localBlockchainHeight="%build %" localTimeDifference="%build + %" subscriptionStatus="%listJson %" }") nfoSyncProgress nfoBlockchainHeight nfoLocalBlockchainHeight nfoLocalTimeInformation + (Map.toList nfoSubscriptionStatus) -- diff --git a/wallet-new/src/Cardano/Wallet/Client.hs b/wallet-new/src/Cardano/Wallet/Client.hs index fe8ac305520..915efcf270d 100644 --- a/wallet-new/src/Cardano/Wallet/Client.hs +++ b/wallet-new/src/Cardano/Wallet/Client.hs @@ -16,7 +16,10 @@ module Cardano.Wallet.Client , liftClient -- * The type of errors that the client might return , ClientError(..) + , V1Errors.WalletError(..) , ServantError(..) + , Response + , GenResponse(..) -- * Reexports , module Cardano.Wallet.API.V1.Types , module Cardano.Wallet.API.V1.Parameters @@ -31,7 +34,7 @@ module Cardano.Wallet.Client import Universum import Control.Exception (Exception (..)) -import Servant.Client (ServantError (..)) +import Servant.Client (Response, GenResponse (..), ServantError (..)) import Cardano.Wallet.API.Request.Filter import Cardano.Wallet.API.Request.Pagination @@ -118,30 +121,63 @@ data WalletClient m :: Resp m NodeInfo } deriving Generic -getAddressIndex :: WalletClient m -> Resp m [WalletAddress] -getAddressIndex wc = getAddressIndexPaginated wc Nothing Nothing +-- | Paginates through all request pages and concatenates the result. +-- +-- NOTE: this lazy variant might be inefficient. It is supposed to be used only in tests. Implement strict version if optimization is needed +-- TODO(akegalj): this can be paralelized like so (pseudo): +-- do +-- -- first page is fetched in sequence +-- page1 <- request (page 1) (Just maxPerPageEntries) +-- -- then rest of the pages is fetched in parallel +-- fromPage2 <- paralelMap (\p -> request p $ Just 50) [2..page1.wrMeta.metaTotalPages] +-- concatMap wrData $ page1:fromPage2 +-- +paginateAll :: Monad m => (Maybe Page -> Maybe PerPage -> Resp m [a]) -> Resp m [a] +paginateAll request = fmap fixMetadata <$> paginatePage 1 + where + fixMetadata WalletResponse{..} = + WalletResponse + { wrMeta = Metadata $ + PaginationMetadata + { metaTotalPages = 1 + , metaPage = Page 1 + , metaPerPage = PerPage $ length wrData + , metaTotalEntries = length wrData + } + , .. + } + paginatePage page = do + result <- request (Just $ Page page) (Just $ PerPage maxPerPageEntries) + case result of + Left _ -> pure result + Right resp -> + if null $ wrData resp + then pure result + else fmap (\d -> d { wrData = wrData resp <> wrData d }) <$> paginatePage (succ page) + +getAddressIndex :: Monad m => WalletClient m -> Resp m [WalletAddress] +getAddressIndex = paginateAll . getAddressIndexPaginated -getAccounts :: WalletClient m -> WalletId -> Resp m [Account] -getAccounts wc wi = getAccountIndexPaged wc wi Nothing Nothing +getAccounts :: Monad m => WalletClient m -> WalletId -> Resp m [Account] +getAccounts wc = paginateAll . getAccountIndexPaged wc getTransactionIndex - :: WalletClient m + :: Monad m + => WalletClient m -> Maybe WalletId -> Maybe AccountIndex -> Maybe (V1 Core.Address) - -> Maybe Page - -> Maybe PerPage -> Resp m [Transaction] -getTransactionIndex wc wid maid maddr mp mpp = - getTransactionIndexFilterSorts wc wid maid maddr mp mpp NoFilters NoSorts +getTransactionIndex wc wid maid maddr = + paginateAll $ \mp mpp -> getTransactionIndexFilterSorts wc wid maid maddr mp mpp NoFilters NoSorts getWalletIndexPaged :: WalletClient m -> Maybe Page -> Maybe PerPage -> Resp m [Wallet] getWalletIndexPaged wc mp mpp = getWalletIndexFilterSorts wc mp mpp NoFilters NoSorts -- | Retrieves only the first page of wallets, providing a default value to -- 'Page' and 'PerPage'. -getWallets :: WalletClient m -> Resp m [Wallet] -getWallets wc = getWalletIndexPaged wc Nothing Nothing +getWallets :: Monad m => WalletClient m -> Resp m [Wallet] +getWallets = paginateAll . getWalletIndexPaged -- | Run the given natural transformation over the 'WalletClient'. hoistClient :: (forall x. m x -> n x) -> WalletClient m -> WalletClient n @@ -194,8 +230,8 @@ liftClient = hoistClient liftIO -- | Calls 'getWalletIndexPaged' using the 'Default' values for 'Page' and -- 'PerPage'. -getWalletIndex :: WalletClient m -> Resp m [Wallet] -getWalletIndex wc = getWalletIndexPaged wc Nothing Nothing +getWalletIndex :: Monad m => WalletClient m -> Resp m [Wallet] +getWalletIndex = paginateAll . getWalletIndexPaged -- | A type alias shorthand for the response from the 'WalletClient'. type Resp m a = m (Either ClientError (WalletResponse a)) @@ -207,22 +243,22 @@ data ClientError -- might return. | ClientHttpError ServantError -- ^ We directly expose the 'ServantError' type as part of this - | UnknownError SomeException + | UnknownClientError SomeException -- ^ This constructor is used when the API client reports an error that -- isn't represented in either the 'ServantError' HTTP errors or the -- 'WalletError' for API errors. - deriving (Show) + deriving (Show, Generic) -- | General (and naive) equality instance. instance Eq ClientError where - (==) (ClientWalletError e1) (ClientWalletError e2) = e1 == e2 - (==) (ClientHttpError e1) (ClientHttpError e2) = e1 == e2 - (==) (UnknownError _ ) (UnknownError _ ) = True - (==) _ _ = False + ClientWalletError e1 == ClientWalletError e2 = e1 == e2 + ClientHttpError e1 == ClientHttpError e2 = e1 == e2 + UnknownClientError _ == UnknownClientError _ = True + _ == _ = False -- | General exception instance. instance Exception ClientError where - toException (ClientWalletError e) = toException e - toException (ClientHttpError e) = toException e - toException (UnknownError e) = toException e + toException (ClientWalletError e) = toException e + toException (ClientHttpError e) = toException e + toException (UnknownClientError e) = toException e diff --git a/wallet-new/src/Cardano/Wallet/Client/Http.hs b/wallet-new/src/Cardano/Wallet/Client/Http.hs index 58680d20985..8b65c30bcf3 100644 --- a/wallet-new/src/Cardano/Wallet/Client/Http.hs +++ b/wallet-new/src/Cardano/Wallet/Client/Http.hs @@ -1,19 +1,82 @@ +{-# LANGUAGE ScopedTypeVariables #-} + module Cardano.Wallet.Client.Http ( module Cardano.Wallet.Client.Http -- * Abstract Client export , module Cardano.Wallet.Client + -- * Servant Client Export + , module Servant.Client + -- * Helper to load X509 certificates and private key + , credentialLoadX509 + , newManager + , Manager ) where import Universum import Control.Lens (_Left) -import Network.HTTP.Client (Manager) +import Data.Aeson (decode) +import Data.ByteString (ByteString) +import Data.Default.Class (Default (..)) +import Data.X509 (CertificateChain, SignedCertificate) +import Data.X509.CertificateStore (makeCertificateStore) +import Network.Connection (TLSSettings (..)) +import Network.HTTP.Client (Manager, ManagerSettings, defaultManagerSettings, newManager) +import Network.HTTP.Client.TLS (mkManagerSettings) +import Network.TLS (ClientHooks (..), ClientParams (..), Credentials (..), + HostName, PrivKey, Shared (..), Supported (..), credentialLoadX509, + noSessionManager) +import Network.TLS.Extra.Cipher (ciphersuite_default) import Servant ((:<|>) (..), (:>)) -import Servant.Client (BaseUrl, ClientEnv (..), client, runClientM) +import Servant.Client (BaseUrl (..), ClientEnv (..), ClientM, Scheme (..), + ServantError (..), client, runClientM) import qualified Cardano.Wallet.API.V1 as V1 import Cardano.Wallet.Client + +type Port = ByteString + + +mkHttpManagerSettings :: ManagerSettings +mkHttpManagerSettings = + defaultManagerSettings + + +mkHttpsManagerSettings + :: (HostName, Port) -- ^ Target server hostname & port + -> [SignedCertificate] -- ^ CA certificate chain + -> (CertificateChain, PrivKey) -- ^ (Client certificate, Client key) + -> ManagerSettings +mkHttpsManagerSettings serverId caChain credentials = + mkManagerSettings tlsSettings sockSettings + where + sockSettings = Nothing + tlsSettings = TLSSettings clientParams + clientParams = ClientParams + { clientUseMaxFragmentLength = Nothing + , clientServerIdentification = serverId + , clientUseServerNameIndication = True + , clientWantSessionResume = Nothing + , clientShared = clientShared + , clientHooks = clientHooks + , clientSupported = clientSupported + , clientDebug = def + } + clientShared = Shared + { sharedCredentials = Credentials [credentials] + , sharedCAStore = makeCertificateStore caChain + , sharedSessionManager = noSessionManager + , sharedValidationCache = def + } + clientHooks = def + { onCertificateRequest = const . return . Just $ credentials + } + clientSupported = def + { supportedCiphers = ciphersuite_default + } + + -- | Given a 'BaseUrl' and an @http-client@ 'Manager', this returns -- a 'WalletClient' that operates in 'IO'. mkHttpClient @@ -69,9 +132,21 @@ mkHttpClient baseUrl manager = WalletClient } where + + -- Must give the type. GHC will not infer it to be polymorphic in 'a'. + run :: forall a . ClientM a -> IO (Either ClientError a) + run = fmap (over _Left parseJsendError) . (`runClientM` clientEnv) + unNoContent = map void - clientEnv = ClientEnv manager baseUrl - run = fmap (over _Left ClientHttpError) . (`runClientM` clientEnv) + cookieJar = Nothing + clientEnv = ClientEnv manager baseUrl cookieJar + parseJsendError servantErr = + case servantErr of + FailureResponse resp -> + case decode (responseBody resp) of + Just err -> ClientWalletError err + Nothing -> ClientHttpError servantErr + _ -> ClientHttpError servantErr getAddressIndexR :<|> postAddressR :<|> getAddressR diff --git a/wallet-new/src/Cardano/Wallet/Kernel.hs b/wallet-new/src/Cardano/Wallet/Kernel.hs index 96a00c45992..03405de5ad5 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel.hs @@ -9,21 +9,64 @@ module Cardano.Wallet.Kernel ( -- * Passive wallet PassiveWallet -- opaque + , WalletId + , accountUtxo + , accountTotalBalance + , applyBlock + , applyBlocks , bracketPassiveWallet + , createWalletHdRnd , init + , walletLogMessage + , walletPassive + , wallets -- * Active wallet , ActiveWallet -- opaque , bracketActiveWallet , newPending - , hasPending ) where -import Universum -import System.Wlog (Severity(..)) +import Universum hiding (State, init) -import Cardano.Wallet.Kernel.Diffusion (WalletDiffusion(..)) +import Control.Lens.TH +import Control.Concurrent.MVar (modifyMVar_, withMVar) +import qualified Data.Map.Strict as Map +import Data.Time.Clock.POSIX (getPOSIXTime) -import Pos.Core (TxAux) +import Formatting (sformat, build) + +import System.Wlog (Severity (..)) + +import Data.Acid (AcidState) +import Data.Acid.Memory (openMemoryState) +import Data.Acid.Advanced (query', update') + +import Cardano.Wallet.Kernel.Diffusion (WalletDiffusion (..)) +import Cardano.Wallet.Kernel.PrefilterTx (PrefilteredBlock (..) + , prefilterUtxo, prefilterBlock) +import Cardano.Wallet.Kernel.Types(WalletId (..), WalletESKs) + +import Cardano.Wallet.Kernel.DB.HdWallet +import Cardano.Wallet.Kernel.DB.Resolved (ResolvedBlock) +import Cardano.Wallet.Kernel.DB.AcidState (DB, defDB, dbHdWallets + , CreateHdWallet (..) + , ApplyBlock (..) + , NewPending (..) + , NewPendingError + , Snapshot (..)) +import Cardano.Wallet.Kernel.DB.BlockMeta (BlockMeta (..)) +import qualified Cardano.Wallet.Kernel.DB.HdWallet as HD +import qualified Cardano.Wallet.Kernel.DB.HdWallet.Create as HD +import Cardano.Wallet.Kernel.DB.HdWallet.Read (HdQueryErr) +import Cardano.Wallet.Kernel.DB.InDb +import qualified Cardano.Wallet.Kernel.DB.Spec.Read as Spec + + +import Pos.Core (Timestamp (..), TxAux (..), AddressHash, Coin) + +import Pos.Crypto (EncryptedSecretKey, PublicKey) +import Pos.Txp (Utxo) +import Pos.Core.Chrono (OldestFirst) {------------------------------------------------------------------------------- Passive wallet @@ -34,34 +77,145 @@ import Pos.Core (TxAux) -- A passive wallet can receive and process blocks, keeping track of state, -- but cannot send new transactions. -- --- TODO: This is just a placeholder for now, we'll want all kinds of state --- in here. data PassiveWallet = PassiveWallet { -- | Send log message - walletLogMessage :: Severity -> Text -> IO () + _walletLogMessage :: Severity -> Text -> IO () -- ^ Logger + , _walletESKs :: MVar WalletESKs -- ^ ESKs indexed by WalletId + , _wallets :: AcidState DB -- ^ Database handle } +makeLenses ''PassiveWallet + +{------------------------------------------------------------------------------- + Passive Wallet Resource Management +-------------------------------------------------------------------------------} + -- | Allocate wallet resources -- --- NOTE: See also 'init'. --- --- TODO: Here and elsewhere we'll want some constraints on this monad here, but +-- Here and elsewhere we'll want some constraints on this monad here, but -- it shouldn't be too specific. -bracketPassiveWallet :: MonadMask m +bracketPassiveWallet :: (MonadMask m, MonadIO m) => (Severity -> Text -> IO ()) -> (PassiveWallet -> m a) -> m a -bracketPassiveWallet walletLogMessage = - bracket - (return PassiveWallet{..}) - (\_ -> return ()) +bracketPassiveWallet _walletLogMessage f = + bracket (liftIO $ openMemoryState defDB) + (\_ -> return ()) + (\db -> + bracket + (liftIO $ initPassiveWallet _walletLogMessage db) + (\_ -> return ()) + f) + +{------------------------------------------------------------------------------- + Manage the WalletESKs Map +-------------------------------------------------------------------------------} + +-- | Insert an ESK, indexed by WalletId, to the WalletESK map +insertWalletESK :: PassiveWallet -> WalletId -> EncryptedSecretKey -> IO () +insertWalletESK pw wid esk + = modifyMVar_ (pw ^. walletESKs) (return . f) + where f = Map.insert wid esk + +withWalletESKs :: forall a. PassiveWallet -> (WalletESKs -> IO a) -> IO a +withWalletESKs pw = withMVar (pw ^. walletESKs) --- | Initialize the wallet +{------------------------------------------------------------------------------- + Wallet Initialisers +-------------------------------------------------------------------------------} + +-- | Initialise Passive Wallet with empty Wallets collection +initPassiveWallet :: (Severity -> Text -> IO ()) + -> AcidState DB + -> IO PassiveWallet +initPassiveWallet logMessage db = do + esks <- Universum.newMVar Map.empty + return $ PassiveWallet logMessage esks db + +-- | Initialize the Passive wallet (specified by the ESK) with the given Utxo -- -- This is separate from allocating the wallet resources, and will only be -- called when the node is initialized (when run in the node proper). init :: PassiveWallet -> IO () -init PassiveWallet{..} = do - walletLogMessage Info "Wallet kernel initialized" +init PassiveWallet{..} = _walletLogMessage Info "Passive Wallet kernel initialized" + +{------------------------------------------------------------------------------- + Wallet Creation +-------------------------------------------------------------------------------} + +-- | Creates an HD wallet with randomly generated addresses. +-- +-- Prefilters the Utxo before passing it to the Acidstate update. + +-- Adds an HdRoot and HdAccounts (which are discovered during prefiltering of utxo). +-- (In the case of empty utxo, no HdAccounts are created.) +-- May fail with CreateHdWalletError if the HdRootId already exists + +-- The ESK is indexed by WalletId and added to the WalletESK map. +createWalletHdRnd :: PassiveWallet + -> HD.WalletName + -> HasSpendingPassword + -> AssuranceLevel + -> (AddressHash PublicKey, EncryptedSecretKey) + -> Utxo + -> IO (Either HD.CreateHdRootError [HdAccountId]) +createWalletHdRnd pw@PassiveWallet{..} name spendingPassword assuranceLevel (pk,esk) utxo = do + created <- InDb <$> getCurrentTimestamp + let newRoot = HD.initHdRoot rootId name spendingPassword assuranceLevel created + + res <- update' _wallets $ CreateHdWallet newRoot utxoByAccount + either (return . Left) insertESK res + where + utxoByAccount = prefilterUtxo rootId esk utxo + accountIds = Map.keys utxoByAccount + + rootId = HD.HdRootId . InDb $ pk + walletId = WalletIdHdRnd rootId + + insertESK _arg = insertWalletESK pw walletId esk >> return (Right accountIds) + +-- (NOTE: we are abandoning the 'Mockable time' strategy of the Cardano code base) +getCurrentTimestamp :: IO Timestamp +getCurrentTimestamp = Timestamp . round . (* 1000000) <$> getPOSIXTime + +{------------------------------------------------------------------------------- + Passive Wallet API implementation +-------------------------------------------------------------------------------} + +-- | Prefilter the block for each esk in the `WalletESK` map. +-- Return a unified Map of accountId and prefiltered blocks (representing multiple ESKs) +-- TODO(@uroboros/ryan) optimisation: we are prefiltering the block n times for n keys, change this to be a single pass +prefilterBlock' :: PassiveWallet + -> ResolvedBlock + -> IO (Map HdAccountId PrefilteredBlock) +prefilterBlock' pw b = + withWalletESKs pw $ \esks -> + return + $ Map.unions + $ map prefilterBlock_ + $ Map.toList esks + where + prefilterBlock_ (wid,esk) = prefilterBlock wid esk b + +-- | Notify all the wallets in the PassiveWallet of a new block +applyBlock :: PassiveWallet + -> ResolvedBlock + -> IO () +applyBlock pw@PassiveWallet{..} b + = do + blocksByAccount <- prefilterBlock' pw b + -- TODO(@uroboros/ryan) do proper metadata initialisation (as part of CBR-239: Support history tracking and queries) + let blockMeta = BlockMeta . InDb $ Map.empty + + -- apply block to all Accounts in all Wallets + void $ update' _wallets $ ApplyBlock (blocksByAccount, blockMeta) + +-- | Apply multiple blocks, one at a time, to all wallets in the PassiveWallet +-- +-- TODO(@matt-noonan) this will be the responsibility of the worker thread (as part of CBR-243: Wallet restoration) +applyBlocks :: PassiveWallet + -> OldestFirst [] ResolvedBlock + -> IO () +applyBlocks = mapM_ . applyBlock {------------------------------------------------------------------------------- Active wallet @@ -90,12 +244,32 @@ bracketActiveWallet walletPassive walletDiffusion = (\_ -> return ()) -- | Submit a new pending transaction -newPending :: ActiveWallet -> TxAux -> IO () -newPending ActiveWallet{..} _tx = do - walletLogMessage Error "TODO: Cardano.Wallet.Kernel.newPending" - where - PassiveWallet{..} = walletPassive - --- | Return True if there are pending transactions -hasPending :: ActiveWallet -> IO Bool -hasPending _ = return False +-- +-- Will fail if the HdAccountId does not exist or if some inputs of the +-- new transaction are not available for spending. +newPending :: ActiveWallet -> HdAccountId -> TxAux -> IO (Either NewPendingError ()) +newPending ActiveWallet{..} accountId tx + = update' (walletPassive ^. wallets) $ NewPending accountId (InDb tx) + +{------------------------------------------------------------------------------- + Wallet Account read-only API +-------------------------------------------------------------------------------} + +walletQuery' :: forall e a. (Buildable e) + => PassiveWallet + -> HdQueryErr e a + -> IO a +walletQuery' pw qry= do + snapshot <- query' (pw ^. wallets) Snapshot + let res = qry (snapshot ^. dbHdWallets) + either err return res + where + err = error . sformat build + +accountUtxo :: PassiveWallet -> HdAccountId -> IO Utxo +accountUtxo pw accountId + = walletQuery' pw (Spec.queryAccountUtxo accountId) + +accountTotalBalance :: PassiveWallet -> HdAccountId -> IO Coin +accountTotalBalance pw accountId + = walletQuery' pw (Spec.queryAccountTotalBalance accountId) diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Actions.hs b/wallet-new/src/Cardano/Wallet/Kernel/Actions.hs new file mode 100644 index 00000000000..015854c5baf --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/Actions.hs @@ -0,0 +1,186 @@ +module Cardano.Wallet.Kernel.Actions + ( WalletAction(..) + , WalletActionInterp(..) + , forkWalletWorker + , walletWorker + , interp + , interpList + , WalletWorkerState + , isInitialState + , hasPendingFork + , isValidState + ) where + +import Control.Concurrent.Async (async, link) +import Control.Concurrent.Chan +import Control.Lens (makeLenses, (%=), (+=), (-=), (.=)) +import qualified Data.Text.Buildable +import Formatting (bprint, build, shown, (%)) +import Universum + +import Pos.Core.Chrono + +{------------------------------------------------------------------------------- + Workers and helpers for performing wallet state updates +-------------------------------------------------------------------------------} + +-- | Actions that can be invoked on a wallet, via a worker. +-- Workers may not respond directly to each action; for example, +-- a `RollbackBlocks` followed by several `ApplyBlocks` may be +-- batched into a single operation on the actual wallet. +data WalletAction b + = ApplyBlocks (OldestFirst NE b) + | RollbackBlocks (NewestFirst NE b) + | LogMessage Text + +-- | Interface abstraction for the wallet worker. +-- The caller provides these primitive wallet operations; +-- the worker uses these to invoke changes to the +-- underlying wallet. +data WalletActionInterp m b = WalletActionInterp + { applyBlocks :: OldestFirst NE b -> m () + , switchToFork :: Int -> OldestFirst [] b -> m () + , emit :: Text -> m () + } + +-- | Internal state of the wallet worker. +data WalletWorkerState b = WalletWorkerState + { _pendingRollbacks :: !Int + , _pendingBlocks :: !(NewestFirst [] b) + , _lengthPendingBlocks :: !Int + } + deriving Eq + +makeLenses ''WalletWorkerState + +-- A helper function for lifting a `WalletActionInterp` through a monad transformer. +lifted :: (Monad m, MonadTrans t) => WalletActionInterp m b -> WalletActionInterp (t m) b +lifted i = WalletActionInterp + { applyBlocks = lift . applyBlocks i + , switchToFork = \n bs -> lift (switchToFork i n bs) + , emit = lift . emit i + } + +-- | `interp` is the main interpreter for converting a wallet action to a concrete +-- transition on the wallet worker's state, perhaps combined with some effects on +-- the concrete wallet. +interp :: Monad m => WalletActionInterp m b -> WalletAction b -> StateT (WalletWorkerState b) m () +interp walletInterp action = do + + numPendingRollbacks <- use pendingRollbacks + numPendingBlocks <- use lengthPendingBlocks + + -- Respond to the incoming action + case action of + + -- If we are not in the midst of a rollback, just apply the blocks. + ApplyBlocks bs | numPendingRollbacks == 0 -> do + emit "applying some blocks (non-rollback)" + applyBlocks bs + + -- Otherwise, add the blocks to the pending list. If the resulting + -- list of pending blocks is longer than the number of pending rollbacks, + -- then perform a `switchToFork` operation on the wallet. + ApplyBlocks bs -> do + + -- Add the blocks + let bsList = toNewestFirst (OldestFirst (toList (getOldestFirst bs))) + pendingBlocks %= prependNewestFirst bsList + lengthPendingBlocks += length bs + + -- If we have seen more blocks than rollbacks, switch to the new fork. + when (numPendingBlocks + length bs > numPendingRollbacks) $ do + + pb <- toOldestFirst <$> use pendingBlocks + switchToFork numPendingRollbacks pb + + -- Reset state to "no fork in progress" + pendingRollbacks .= 0 + lengthPendingBlocks .= 0 + pendingBlocks .= NewestFirst [] + + -- If we are in the midst of a fork and have seen some new blocks, + -- roll back some of those blocks. If there are more rollbacks requested + -- than the number of new blocks, see the next case below. + RollbackBlocks bs | length bs <= numPendingBlocks -> do + lengthPendingBlocks -= length bs + pendingBlocks %= NewestFirst . drop (length bs) . getNewestFirst + + -- If we are in the midst of a fork and are asked to rollback more than + -- the number of new blocks seen so far, clear out the list of new + -- blocks and add any excess to the number of pending rollback operations. + RollbackBlocks bs -> do + pendingRollbacks += length bs - numPendingBlocks + lengthPendingBlocks .= 0 + pendingBlocks .= NewestFirst [] + + LogMessage txt -> emit txt + + where + WalletActionInterp{..} = lifted walletInterp + prependNewestFirst bs = \nf -> NewestFirst (getNewestFirst bs <> getNewestFirst nf) + +-- | Connect a wallet action interpreter to a channel of actions. +walletWorker :: Chan (WalletAction b) -> WalletActionInterp IO b -> IO () +walletWorker chan ops = do + emit ops "Starting wallet worker." + void $ (`evalStateT` initialWorkerState) $ forever $ + lift (readChan chan) >>= interp ops + emit ops "Finishing wallet worker." + +-- | Connect a wallet action interpreter to a stream of actions. +interpList :: Monad m => WalletActionInterp m b -> [WalletAction b] -> m (WalletWorkerState b) +interpList ops actions = execStateT (forM_ actions $ interp ops) initialWorkerState + +initialWorkerState :: WalletWorkerState b +initialWorkerState = WalletWorkerState + { _pendingRollbacks = 0 + , _pendingBlocks = NewestFirst [] + , _lengthPendingBlocks = 0 + } + +-- | Start up a wallet worker; the worker will respond to actions issued over the +-- returned channel. +forkWalletWorker :: (MonadIO m, MonadIO m') => WalletActionInterp IO b -> m (WalletAction b -> m' ()) +forkWalletWorker ops = liftIO $ do + c <- newChan + link =<< async (walletWorker c ops) + return (liftIO . writeChan c) + +-- | Check if this is the initial worker state. +isInitialState :: Eq b => WalletWorkerState b -> Bool +isInitialState = (== initialWorkerState) + +-- | Check that the state invariants all hold. +isValidState :: WalletWorkerState b -> Bool +isValidState WalletWorkerState{..} = + _pendingRollbacks >= 0 && + length (_pendingBlocks) == _lengthPendingBlocks && + _lengthPendingBlocks <= _pendingRollbacks + +-- | Check if this state represents a pending fork. +hasPendingFork :: WalletWorkerState b -> Bool +hasPendingFork WalletWorkerState{..} = _pendingRollbacks /= 0 + +instance Show b => Buildable (WalletWorkerState b) where + build WalletWorkerState{..} = bprint + ( "WalletWorkerState " + % "{ _pendingRollbacks: " % shown + % ", _pendingBlocks: " % shown + % ", _lengthPendingBlocks: " % shown + % " }" + ) + _pendingRollbacks + _pendingBlocks + _lengthPendingBlocks + +instance Show b => Buildable (WalletAction b) where + build wa = case wa of + ApplyBlocks bs -> bprint ("ApplyBlocks " % shown) bs + RollbackBlocks bs -> bprint ("RollbackBlocks " % shown) bs + LogMessage bs -> bprint ("LogMessage " % shown) bs + +instance Show b => Buildable [WalletAction b] where + build was = case was of + [] -> bprint "[]" + (x:xs) -> bprint (build % ":" % build) x xs diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/AcidState.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/AcidState.hs new file mode 100644 index 00000000000..39d6630e7df --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/AcidState.hs @@ -0,0 +1,285 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} -- to enable... deriveSafeCopy 1 'base ''EncryptedSecretKey +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Acid-state database for the wallet kernel +module Cardano.Wallet.Kernel.DB.AcidState ( + -- * Top-level database + DB(..) + , dbHdWallets + , defDB + -- * Acid-state operations + -- ** Snapshot + , Snapshot(..) + -- ** Spec mandated updates + , NewPending(..) + , ApplyBlock(..) + , SwitchToFork(..) + -- ** Updates on HD wallets + -- *** CREATE + , CreateHdWallet(..) + , CreateHdAddress(..) + -- *** UPDATE + , UpdateHdRootAssurance + , UpdateHdRootName(..) + , UpdateHdAccountName(..) + -- *** DELETE + , DeleteHdRoot(..) + , DeleteHdAccount(..) + -- * errors + , NewPendingError + ) where + +import Universum + +import Control.Lens.TH (makeLenses) + +import Data.Acid (Query, Update, makeAcidic) +import qualified Data.Map.Strict as Map +import Data.SafeCopy (base, deriveSafeCopy) + +import qualified Pos.Core as Core +import Pos.Core.Chrono (OldestFirst (..)) +import Pos.Txp (Utxo) + +import Cardano.Wallet.Kernel.PrefilterTx (AddrWithId, PrefilteredBlock (..), + PrefilteredUtxo) + +import Cardano.Wallet.Kernel.DB.BlockMeta +import Cardano.Wallet.Kernel.DB.HdWallet +import qualified Cardano.Wallet.Kernel.DB.HdWallet.Create as HD +import qualified Cardano.Wallet.Kernel.DB.HdWallet.Delete as HD +import qualified Cardano.Wallet.Kernel.DB.HdWallet.Update as HD +import Cardano.Wallet.Kernel.DB.InDb +import Cardano.Wallet.Kernel.DB.Spec +import qualified Cardano.Wallet.Kernel.DB.Spec.Update as Spec +import qualified Cardano.Wallet.Kernel.DB.Spec.Util as Spec +import Cardano.Wallet.Kernel.DB.Util.AcidState + +{------------------------------------------------------------------------------- + Top-level database +-------------------------------------------------------------------------------} + +-- | Full state of the wallet, with the exception of transaction metadata +-- +-- We store the different kinds of wallets in different maps for increased +-- type safety. Moreover, since we currently only have a single type of wallet, +-- trying to factor our common parts would be premature at this point. +-- +-- References: +-- +-- * The acid-state DB for the legacy wallet is defined in module +-- "Pos.Wallet.Web.State.Storage". +-- * V1 API defined in "Cardano.Wallet.API.V1.*" (in @src/@) +data DB = DB { + _dbHdWallets :: HdWallets + } + +makeLenses ''DB +deriveSafeCopy 1 'base ''DB + +-- | Default DB +defDB :: DB +defDB = DB initHdWallets + +{------------------------------------------------------------------------------- + Wrap wallet spec +-------------------------------------------------------------------------------} + +-- | Errors thrown by 'newPending' +data NewPendingError = + -- | Unknown account + NewPendingUnknown UnknownHdAccount + + -- | Some inputs are not in the wallet utxo + | NewPendingFailed Spec.NewPendingFailed + +deriveSafeCopy 1 'base ''NewPendingError + +newPending :: HdAccountId + -> InDb Core.TxAux + -> Update DB (Either NewPendingError ()) +newPending accountId tx = runUpdate' . zoom dbHdWallets $ + zoomHdAccountId NewPendingUnknown accountId $ + zoom hdAccountCheckpoints $ + mapUpdateErrors NewPendingFailed $ Spec.newPending tx + +-- | Apply prefiltered block (indexed by HdAccountId) to the matching accounts. +-- +-- The prefiltered block should be indexed by AccountId, with each prefiltered block +-- containing only inputs and outputs relevant to the account. Since HdAccountId embeds HdRootId, +-- it unambiguously places an Account in the Wallet/Account hierarchy. The AccountIds here could +-- therefor refer to an Account in /any/ Wallet (not only sibling accounts in a single wallet). + +-- NOTE: +-- * Calls to 'applyBlock' must be sequentialized by the caller +-- (although concurrent calls to 'applyBlock' cannot interfere with each +-- other, 'applyBlock' must be called in the right order.) +-- +-- * Since a block may reference wallet accounts that do not exist yet locally, +-- we need to create such 'missing' accounts. (An Account might not exist locally +-- if it was created on another node instance of this wallet). +-- +-- * For every address encountered in the block outputs, create an HdAddress if it +-- does not already exist. +-- +-- TODO(@uroboros/ryan) Move BlockMeta inside PrefilteredBlock (as part of CBR-239: Support history tracking and queries) +applyBlock :: (Map HdAccountId PrefilteredBlock, BlockMeta) -> Update DB () +applyBlock (blocksByAccount,meta) = runUpdateNoErrors $ zoom dbHdWallets $ + createPrefiltered + initUtxoAndAddrs + (\prefBlock -> zoom hdAccountCheckpoints $ + modify $ Spec.applyBlock (prefBlock,meta)) + blocksByAccount + where + -- Accounts are discovered during wallet creation (if the account was given + -- a balance in the genesis block) or otherwise, during ApplyBlock. For + -- accounts discovered during ApplyBlock, we can assume that there was no + -- genesis utxo, hence we use empty initial utxo for such new accounts. + initUtxoAndAddrs :: PrefilteredBlock -> (Utxo, [AddrWithId]) + initUtxoAndAddrs pb = (Map.empty, pfbAddrs pb) + +-- | Switch to a fork +-- +-- See comments about prefiltering for 'applyBlock'. +-- +-- TODO: We use a plain list here rather than 'OldestFirst' since the latter +-- does not have a 'SafeCopy' instance. +switchToFork :: Int + -> [(PrefilteredBlock, BlockMeta)] + -> Update DB () +switchToFork n blocks = runUpdateNoErrors $ + zoomAll (dbHdWallets . hdWalletsAccounts) $ + hdAccountCheckpoints %~ Spec.switchToFork n (OldestFirst blocks) + +{------------------------------------------------------------------------------- + Wallet creation +-------------------------------------------------------------------------------} + +-- | Create an HdWallet with HdRoot, possibly with HdAccounts and HdAddresses. +-- +-- Given prefiltered utxo's, by account, create an HdAccount for each account, +-- along with HdAddresses for all utxo outputs. +createHdWallet :: HdRoot + -> Map HdAccountId PrefilteredUtxo + -> Update DB (Either HD.CreateHdRootError ()) +createHdWallet newRoot utxoByAccount = runUpdate' . zoom dbHdWallets $ do + HD.createHdRoot newRoot + createPrefiltered + identity + (\_ -> return ()) -- we just want to create the accounts + utxoByAccount + +{------------------------------------------------------------------------------- + Internal auxiliary: apply a function to a prefiltered block/utxo +-------------------------------------------------------------------------------} + +-- | For each of the specified accounts, create them if they do not exist, +-- and apply the specified function. +createPrefiltered :: forall p e. + (p -> (Utxo, [AddrWithId])) + -- ^ Initial UTxO (when we are creating the account), + -- as well as set of addresses the account should have + -> (p -> Update' HdAccount e ()) + -- ^ Function to apply to the account + -> Map HdAccountId p -> Update' HdWallets e () +createPrefiltered initUtxoAndAddrs applyP accs = do + forM_ (Map.toList accs) $ \(accId, p) -> do + let utxo :: Utxo + addrs :: [AddrWithId] + (utxo, addrs) = initUtxoAndAddrs p + + -- apply the update to the account + zoomOrCreateHdAccount + assumeHdRootExists + (newAccount accId utxo) + accId + (applyP p) + + -- create addresses (if they don't exist) + forM_ addrs $ \(addressId, address) -> do + let newAddress :: HdAddress + newAddress = HD.initHdAddress addressId (InDb address) + + zoomOrCreateHdAddress + assumeHdAccountExists -- we created it above + newAddress + addressId + (return ()) + + where + newAccount :: HdAccountId -> Utxo -> HdAccount + newAccount accId' utxo' = HD.initHdAccount accId' (firstCheckpoint utxo') + + firstCheckpoint :: Utxo -> Checkpoint + firstCheckpoint utxo' = Checkpoint { + _checkpointUtxo = InDb utxo' + , _checkpointUtxoBalance = InDb $ Spec.balance utxo' + , _checkpointExpected = InDb Map.empty + , _checkpointPending = Pending . InDb $ Map.empty + -- TODO(@uroboros/ryan) proper BlockMeta initialisation (as part of CBR-239: Support history tracking and queries) + , _checkpointBlockMeta = BlockMeta . InDb $ Map.empty + } + +{------------------------------------------------------------------------------- + Wrap HD C(R)UD operations +-------------------------------------------------------------------------------} + +createHdRoot :: HdRoot -> Update DB (Either HD.CreateHdRootError ()) +createHdRoot hdRoot = runUpdate' . zoom dbHdWallets $ + HD.createHdRoot hdRoot + +createHdAddress :: HdAddress -> Update DB (Either HD.CreateHdAddressError ()) +createHdAddress hdAddress = runUpdate' . zoom dbHdWallets $ + HD.createHdAddress hdAddress + +updateHdRootAssurance :: HdRootId + -> AssuranceLevel + -> Update DB (Either UnknownHdRoot ()) +updateHdRootAssurance rootId assurance = runUpdate' . zoom dbHdWallets $ + HD.updateHdRootAssurance rootId assurance + +updateHdRootName :: HdRootId + -> WalletName + -> Update DB (Either UnknownHdRoot ()) +updateHdRootName rootId name = runUpdate' . zoom dbHdWallets $ + HD.updateHdRootName rootId name + +updateHdAccountName :: HdAccountId + -> AccountName + -> Update DB (Either UnknownHdAccount ()) +updateHdAccountName accId name = runUpdate' . zoom dbHdWallets $ + HD.updateHdAccountName accId name + +deleteHdRoot :: HdRootId -> Update DB () +deleteHdRoot rootId = runUpdateNoErrors . zoom dbHdWallets $ + HD.deleteHdRoot rootId + +deleteHdAccount :: HdAccountId -> Update DB (Either UnknownHdRoot ()) +deleteHdAccount accId = runUpdate' . zoom dbHdWallets $ + HD.deleteHdAccount accId + +{------------------------------------------------------------------------------- + Acid-state magic +-------------------------------------------------------------------------------} + +snapshot :: Query DB DB +snapshot = ask + +makeAcidic ''DB [ + -- Database snapshot + 'snapshot + -- Updates on the "spec state" + , 'newPending + , 'applyBlock + , 'switchToFork + -- Updates on HD wallets + , 'createHdRoot + , 'createHdAddress + , 'createHdWallet + , 'updateHdRootAssurance + , 'updateHdRootName + , 'updateHdAccountName + , 'deleteHdRoot + , 'deleteHdAccount + ] diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/BlockMeta.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/BlockMeta.hs new file mode 100644 index 00000000000..ca569113940 --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/BlockMeta.hs @@ -0,0 +1,42 @@ +-- | Block metadata conform the wallet specification +module Cardano.Wallet.Kernel.DB.BlockMeta ( + -- * Block metadata + BlockMeta(..) + -- ** Lenses + , blockMetaSlotId + ) where + +import Universum + +import Control.Lens.TH (makeLenses) +import qualified Data.Map.Strict as Map +import Data.SafeCopy (deriveSafeCopy, base) + +import qualified Pos.Core as Core + +import Cardano.Wallet.Kernel.DB.InDb + +{------------------------------------------------------------------------------- + Block metadata +-------------------------------------------------------------------------------} + +-- | Block metadata +data BlockMeta = BlockMeta { + -- | Slot each transaction got confirmed in + _blockMetaSlotId :: InDb (Map Core.TxId Core.SlotId) + } + +makeLenses ''BlockMeta +deriveSafeCopy 1 'base ''BlockMeta + +-- | Monoid instance to update 'BlockMeta' in 'applyBlock' (see wallet spec) +instance Monoid BlockMeta where + mempty = BlockMeta { + _blockMetaSlotId = InDb Map.empty + } + a `mappend` b = BlockMeta { + _blockMetaSlotId = combineUsing (liftA2 Map.union) _blockMetaSlotId + } + where + combineUsing :: (a -> a -> a) -> (BlockMeta -> a) -> a + combineUsing op f = f a `op` f b diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet.hs new file mode 100644 index 00000000000..a03a0e16e15 --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet.hs @@ -0,0 +1,462 @@ +-- | HD wallets +module Cardano.Wallet.Kernel.DB.HdWallet ( + -- * Supporting types + WalletName(..) + , AccountName(..) + , HdAccountIx(..) + , HdAddressIx(..) + , AssuranceLevel(..) + , HasSpendingPassword(..) + -- * HD wallet types proper + , HdWallets(..) + , HdRootId(..) + , HdAccountId(..) + , HdAddressId(..) + , HdRoot(..) + , HdAccount(..) + , HdAddress(..) + -- ** Initialiser + , initHdWallets + -- ** Lenses + , hdWalletsRoots + , hdWalletsAccounts + , hdWalletsAddresses + , hdAccountIdParent + , hdAccountIdIx + , hdAddressIdParent + , hdAddressIdIx + , hdRootId + , hdRootName + , hdRootHasPassword + , hdRootAssurance + , hdRootCreatedAt + , hdAccountId + , hdAccountName + , hdAccountCurrentCheckpoint + , hdAccountCheckpoints + , hdAddressId + , hdAddressAddress + , hdAddressIsUsed + , hdAddressIsChange + -- ** Composite lenses + , hdAccountRootId + , hdAddressRootId + , hdAddressAccountId + -- * Unknown identifiers + , UnknownHdRoot(..) + , UnknownHdAccount(..) + , UnknownHdAddress(..) + , embedUnknownHdRoot + , embedUnknownHdAccount + -- * Zoom to parts of the HD wallet + , zoomHdRootId + , zoomHdAccountId + , zoomHdAddressId + -- * Zoom variations that create on request + , zoomOrCreateHdRoot + , zoomOrCreateHdAccount + , zoomOrCreateHdAddress + , assumeHdRootExists + , assumeHdAccountExists + ) where + +import Universum + +import Control.Lens (at) +import Control.Lens.TH (makeLenses) +import qualified Data.IxSet.Typed as IxSet +import Data.SafeCopy (base, deriveSafeCopy) + +import qualified Data.Text.Buildable +import Formatting (bprint, (%), build) + +import qualified Pos.Core as Core +import qualified Pos.Crypto as Core + +import Cardano.Wallet.Kernel.DB.InDb +import Cardano.Wallet.Kernel.DB.Spec +import Cardano.Wallet.Kernel.DB.Util.AcidState +import Cardano.Wallet.Kernel.DB.Util.IxSet + +{------------------------------------------------------------------------------- + Supporting types +-------------------------------------------------------------------------------} + +-- | Wallet name +newtype WalletName = WalletName Text + +-- | Account name +newtype AccountName = AccountName Text + +-- | Account index +newtype HdAccountIx = HdAccountIx Word32 + deriving (Eq, Ord) + +-- | Address index +newtype HdAddressIx = HdAddressIx Word32 + deriving (Eq, Ord) + +-- | Wallet assurance level +-- +-- TODO: document what these levels mean (in particular, how it does translate +-- to the depth required before a transaction is marked as Persisted?) +data AssuranceLevel = + AssuranceLevelNormal + | AssuranceLevelStrict + +-- | Does this wallet have a spending password +data HasSpendingPassword = + -- | No spending password set + NoSpendingPassword + + -- | If there is a spending password, we record when it was last updated. + | HasSpendingPassword (InDb Core.Timestamp) + +deriveSafeCopy 1 'base ''WalletName +deriveSafeCopy 1 'base ''AccountName +deriveSafeCopy 1 'base ''HdAccountIx +deriveSafeCopy 1 'base ''HdAddressIx +deriveSafeCopy 1 'base ''AssuranceLevel +deriveSafeCopy 1 'base ''HasSpendingPassword + +{------------------------------------------------------------------------------- + HD wallets +-------------------------------------------------------------------------------} + +-- | HD wallet root ID +data HdRootId = HdRootId (InDb (Core.AddressHash Core.PublicKey)) + deriving (Eq, Ord) + +-- | HD wallet account ID +data HdAccountId = HdAccountId { + _hdAccountIdParent :: HdRootId + , _hdAccountIdIx :: HdAccountIx + } + deriving (Eq, Ord) + +-- | HD wallet address ID +data HdAddressId = HdAddressId { + _hdAddressIdParent :: HdAccountId + , _hdAddressIdIx :: HdAddressIx + } + deriving (Eq, Ord) + +-- | Root of a HD wallet +-- +-- The wallet has sequentially assigned account indices and randomly assigned +-- address indices. +-- +-- NOTE: We do not store the encrypted key of the wallet. +-- +-- TODO: synchronization state +data HdRoot = HdRoot { + -- | Wallet ID + _hdRootId :: HdRootId + + -- | Wallet name + , _hdRootName :: WalletName + + -- | Does this wallet have a spending password? + -- + -- NOTE: We do not store the spending password itself, but merely record + -- whether there is one. Updates to the spending password affect only the + -- external key storage, not the wallet DB proper. + , _hdRootHasPassword :: HasSpendingPassword + + -- | Assurance level + , _hdRootAssurance :: AssuranceLevel + + -- | When was this wallet created? + , _hdRootCreatedAt :: InDb Core.Timestamp + } + +-- | Account in a HD wallet +-- +-- Key derivation is cheap +data HdAccount = HdAccount { + -- | Account index + _hdAccountId :: HdAccountId + + -- | Account name + , _hdAccountName :: AccountName + + -- | State of the " wallet " as stipulated by the wallet specification + , _hdAccountCheckpoints :: NonEmpty Checkpoint + } + +-- | Address in an account of a HD wallet +data HdAddress = HdAddress { + -- | Address ID + _hdAddressId :: HdAddressId + + -- | The actual address + , _hdAddressAddress :: InDb Core.Address + + -- | Has this address been involved in a transaction? + -- + -- TODO: How is this determined? What is the definition? How is it set? + -- TODO: This will likely move to the 'BlockMeta' instead. + , _hdAddressIsUsed :: Bool + + -- | Was this address used as a change address? + -- + -- TODO: How is this derived when we do wallet recovery? + -- TODO: Do we need this at all? + , _hdAddressIsChange :: Bool + } + +makeLenses ''HdAccountId +makeLenses ''HdAddressId + +makeLenses ''HdRoot +makeLenses ''HdAccount +makeLenses ''HdAddress + +deriveSafeCopy 1 'base ''HdRootId +deriveSafeCopy 1 'base ''HdAccountId +deriveSafeCopy 1 'base ''HdAddressId + +deriveSafeCopy 1 'base ''HdRoot +deriveSafeCopy 1 'base ''HdAccount +deriveSafeCopy 1 'base ''HdAddress + +{------------------------------------------------------------------------------- + Derived lenses +-------------------------------------------------------------------------------} + +hdAccountRootId :: Lens' HdAccount HdRootId +hdAccountRootId = hdAccountId . hdAccountIdParent + +hdAddressAccountId :: Lens' HdAddress HdAccountId +hdAddressAccountId = hdAddressId . hdAddressIdParent + +hdAddressRootId :: Lens' HdAddress HdRootId +hdAddressRootId = hdAddressAccountId . hdAccountIdParent + +hdAccountCurrentCheckpoint :: Lens' HdAccount Checkpoint +hdAccountCurrentCheckpoint = hdAccountCheckpoints . currentCheckpoint + +{------------------------------------------------------------------------------- + Unknown identifiers +-------------------------------------------------------------------------------} + +-- | Unknown root +data UnknownHdRoot = + -- | Unknown root ID + UnknownHdRoot HdRootId + +-- | Unknown account +data UnknownHdAccount = + -- | Unknown root ID + UnknownHdAccountRoot HdRootId + + -- | Unknown account (implies the root is known) + | UnknownHdAccount HdAccountId + +-- | Unknown address +data UnknownHdAddress = + -- | Unknown root ID + UnknownHdAddressRoot HdRootId + + -- | Unknown account (implies the root is known) + | UnknownHdAddressAccount HdAccountId + + -- | Unknown address (implies the account is known) + | UnknownHdAddress HdAddressId + +embedUnknownHdRoot :: UnknownHdRoot -> UnknownHdAccount +embedUnknownHdRoot = go + where + go (UnknownHdRoot rootId) = UnknownHdAccountRoot rootId + +embedUnknownHdAccount :: UnknownHdAccount -> UnknownHdAddress +embedUnknownHdAccount = go + where + go (UnknownHdAccountRoot rootId) = UnknownHdAddressRoot rootId + go (UnknownHdAccount accountId) = UnknownHdAddressAccount accountId + +deriveSafeCopy 1 'base ''UnknownHdRoot +deriveSafeCopy 1 'base ''UnknownHdAddress +deriveSafeCopy 1 'base ''UnknownHdAccount + +{------------------------------------------------------------------------------- + IxSet instantiations +-------------------------------------------------------------------------------} + +instance HasPrimKey HdRoot where + type PrimKey HdRoot = HdRootId + primKey = _hdRootId + +instance HasPrimKey HdAccount where + type PrimKey HdAccount = HdAccountId + primKey = _hdAccountId + +instance HasPrimKey HdAddress where + type PrimKey HdAddress = HdAddressId + primKey = _hdAddressId + +type HdRootIxs = '[] +type HdAccountIxs = '[HdRootId] +type HdAddressIxs = '[HdRootId, HdAccountId, Core.Address] + +type instance IndicesOf HdRoot = HdRootIxs +type instance IndicesOf HdAccount = HdAccountIxs +type instance IndicesOf HdAddress = HdAddressIxs + +instance IxSet.Indexable (HdRootId ': HdRootIxs) + (OrdByPrimKey HdRoot) where + indices = ixList + +instance IxSet.Indexable (HdAccountId ': HdAccountIxs) + (OrdByPrimKey HdAccount) where + indices = ixList + (ixFun ((:[]) . view hdAccountRootId)) + +instance IxSet.Indexable (HdAddressId ': HdAddressIxs) + (OrdByPrimKey HdAddress) where + indices = ixList + (ixFun ((:[]) . view hdAddressRootId)) + (ixFun ((:[]) . view hdAddressAccountId)) + (ixFun ((:[]) . view (hdAddressAddress . fromDb))) + +{------------------------------------------------------------------------------- + Top-level HD wallet structure +-------------------------------------------------------------------------------} + +-- | All wallets, accounts and addresses in the HD wallets +-- +-- We use a flat "relational" structure rather than nested maps so that we can +-- go from address to wallet just as easily as the other way around. +data HdWallets = HdWallets { + _hdWalletsRoots :: IxSet HdRoot + , _hdWalletsAccounts :: IxSet HdAccount + , _hdWalletsAddresses :: IxSet HdAddress + } + +deriveSafeCopy 1 'base ''HdWallets +makeLenses ''HdWallets + +initHdWallets :: HdWallets +initHdWallets = HdWallets emptyIxSet emptyIxSet emptyIxSet + +{------------------------------------------------------------------------------- + Zoom to existing parts of a HD wallet +-------------------------------------------------------------------------------} + +zoomHdRootId :: forall e a. + (UnknownHdRoot -> e) + -> HdRootId + -> Update' HdRoot e a -> Update' HdWallets e a +zoomHdRootId embedErr rootId = + zoomDef err (hdWalletsRoots . at rootId) + where + err :: Update' HdWallets e a + err = throwError $ embedErr (UnknownHdRoot rootId) + +zoomHdAccountId :: forall e a. + (UnknownHdAccount -> e) + -> HdAccountId + -> Update' HdAccount e a -> Update' HdWallets e a +zoomHdAccountId embedErr accId = + zoomDef err (hdWalletsAccounts . at accId) + where + err :: Update' HdWallets e a + err = zoomHdRootId embedErr' (accId ^. hdAccountIdParent) $ + throwError $ embedErr (UnknownHdAccount accId) + + embedErr' :: UnknownHdRoot -> e + embedErr' = embedErr . embedUnknownHdRoot + +zoomHdAddressId :: forall e a. + (UnknownHdAddress -> e) + -> HdAddressId + -> Update' HdAddress e a -> Update' HdWallets e a +zoomHdAddressId embedErr addrId = + zoomDef err (hdWalletsAddresses . at addrId) + where + err :: Update' HdWallets e a + err = zoomHdAccountId embedErr' (addrId ^. hdAddressIdParent) $ + throwError $ embedErr (UnknownHdAddress addrId) + + embedErr' :: UnknownHdAccount -> e + embedErr' = embedErr . embedUnknownHdAccount + +{------------------------------------------------------------------------------- + Zoom to parts of the wallet, creating them if they don't exist +-------------------------------------------------------------------------------} + +-- | Variation on 'zoomHdRootId' that creates the 'HdRoot' if it doesn't exist +-- +-- Precondition: @newRoot ^. hdRootId == rootId@ +zoomOrCreateHdRoot :: HdRoot + -> HdRootId + -> Update' HdRoot e a + -> Update' HdWallets e a +zoomOrCreateHdRoot newRoot rootId upd = + zoomCreate newRoot (hdWalletsRoots . at rootId) $ upd + +-- | Variation on 'zoomHdAccountId' that creates the 'HdAccount' if it doesn't exist +-- +-- Precondition: @newAccount ^. hdAccountId == accountId@ +zoomOrCreateHdAccount :: (HdRootId -> Update' HdWallets e ()) + -> HdAccount + -> HdAccountId + -> Update' HdAccount e a + -> Update' HdWallets e a +zoomOrCreateHdAccount checkRootExists newAccount accId upd = do + checkRootExists $ accId ^. hdAccountIdParent + zoomCreate newAccount (hdWalletsAccounts . at accId) $ upd + +-- | Variation on 'zoomHdAddressId' that creates the 'HdAddress' if it doesn't exist +-- +-- Precondition: @newAddress ^. hdAddressId == AddressId@ +zoomOrCreateHdAddress :: (HdAccountId -> Update' HdWallets e ()) + -> HdAddress + -> HdAddressId + -> Update' HdAddress e a + -> Update' HdWallets e a +zoomOrCreateHdAddress checkAccountExists newAddress addrId upd = do + checkAccountExists $ addrId ^. hdAddressIdParent + zoomCreate newAddress (hdWalletsAddresses . at addrId) $ upd + +-- | Assume that the given HdRoot exists +-- +-- Helper function which can be used as an argument to 'zoomOrCreateHdAccount' +assumeHdRootExists :: HdRootId -> Update' HdWallets e () +assumeHdRootExists _id = return () + +-- | Assume that the given HdAccount exists +-- +-- Helper function which can be used as an argument to 'zoomOrCreateHdAddress' +assumeHdAccountExists :: HdAccountId -> Update' HdWallets e () +assumeHdAccountExists _id = return () + +{------------------------------------------------------------------------------- + Pretty printing +-------------------------------------------------------------------------------} + +instance Buildable HdRootId where + build (HdRootId keyInDb) + = bprint ("HdRootId: "%build) (_fromDb keyInDb) + +instance Buildable HdAccountIx where + build (HdAccountIx ix) + = bprint ("HdAccountIx: "%build) ix + +instance Buildable HdAccountId where + build (HdAccountId parentId accountIx) + = bprint ("HdAccountId: "%build%", "%build) parentId accountIx + +instance Buildable HdAddressIx where + build (HdAddressIx ix) + = bprint ("HdAddressIx: "%build) ix + +instance Buildable HdAddressId where + build (HdAddressId parentId addressIx) + = bprint ("HdAddressId: "%build%", "%build) parentId addressIx + +instance Buildable UnknownHdAccount where + build (UnknownHdAccountRoot rootId) + = bprint ("UnknownHdAccountRoot: "%build) rootId + build (UnknownHdAccount accountId) + = bprint ("UnknownHdAccount accountId: "%build) accountId diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet/Create.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet/Create.hs new file mode 100644 index 00000000000..c62c1761243 --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet/Create.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE RankNTypes #-} + +-- | CREATE operations on HD wallets +module Cardano.Wallet.Kernel.DB.HdWallet.Create ( + -- * Errors + CreateHdRootError(..) + , CreateHdAccountError(..) + , CreateHdAddressError(..) + -- * Functions + , createHdRoot + , createHdAccount + , createHdAddress + -- * Initial values + , initHdRoot + , initHdAccount + , initHdAddress + ) where + +import Universum + +import Control.Lens (at, (.=)) +import Data.SafeCopy (base, deriveSafeCopy) + +import qualified Data.Text.Buildable +import Formatting (bprint, (%), sformat, build) + +import qualified Pos.Core as Core + +import Cardano.Wallet.Kernel.DB.HdWallet +import Cardano.Wallet.Kernel.DB.InDb +import Cardano.Wallet.Kernel.DB.Spec +import Cardano.Wallet.Kernel.DB.Util.AcidState +import qualified Cardano.Wallet.Kernel.DB.Util.IxSet as IxSet + +{------------------------------------------------------------------------------- + Errors +-------------------------------------------------------------------------------} + +-- | Errors thrown by 'createHdWallet' +data CreateHdRootError = + -- | We already have a wallet with the specified ID + CreateHdRootExists HdRootId + +-- | Errors thrown by 'createHdAccount' +data CreateHdAccountError = + -- | The specified wallet could not be found + CreateHdAccountUnknownRoot UnknownHdRoot + + -- | Account already exists + | CreateHdAccountExists HdAccountId + +-- | Errors thrown by 'createHdAddress' +data CreateHdAddressError = + -- | Account not found + CreateHdAddressUnknown UnknownHdAccount + + -- | Address already used + | CreateHdAddressExists HdAddressId + +deriveSafeCopy 1 'base ''CreateHdRootError +deriveSafeCopy 1 'base ''CreateHdAccountError +deriveSafeCopy 1 'base ''CreateHdAddressError + +{------------------------------------------------------------------------------- + CREATE +-------------------------------------------------------------------------------} + +-- | Create a new wallet +createHdRoot :: HdRoot -> Update' HdWallets CreateHdRootError () +createHdRoot hdRoot = + zoom hdWalletsRoots $ do + exists <- gets $ IxSet.member rootId + when exists $ throwError $ CreateHdRootExists rootId + at rootId .= Just hdRoot + where + rootId = hdRoot ^. hdRootId + +-- | Create a new account +createHdAccount :: HdAccount -> Update' HdWallets CreateHdAccountError () +createHdAccount hdAccount = do + -- Check that the root ID exiwests + zoomHdRootId CreateHdAccountUnknownRoot rootId $ + return () + + zoom hdWalletsAccounts $ do + exists <- gets $ IxSet.member accountId + when exists $ throwError $ CreateHdAccountExists accountId + at accountId .= Just hdAccount + where + accountId = hdAccount ^. hdAccountId + rootId = accountId ^. hdAccountIdParent + +-- | Create a new address +createHdAddress :: HdAddress -> Update' HdWallets CreateHdAddressError () +createHdAddress hdAddress = do + -- Check that the account ID exists + zoomHdAccountId CreateHdAddressUnknown (addrId ^. hdAddressIdParent) $ + return () + -- Create the new address + zoom hdWalletsAddresses $ do + exists <- gets $ IxSet.member addrId + when exists $ throwError $ CreateHdAddressExists addrId + at addrId .= Just hdAddress + where + addrId = hdAddress ^. hdAddressId + +{------------------------------------------------------------------------------- + Initial values +-------------------------------------------------------------------------------} + +-- | New wallet +-- +-- The encrypted secret key of the wallet is assumed to be stored elsewhere in +-- some kind of secure key storage; here we ask for the hash of the public key +-- only (i.e., a 'HdRootId'). It is the responsibility of the caller to use the +-- 'BackupPhrase' and (optionally) the 'SpendingPassword' to create a new key +-- add it to the key storage. This is important, because these are secret +-- bits of information that should never end up in the DB log. +initHdRoot :: HdRootId + -> WalletName + -> HasSpendingPassword + -> AssuranceLevel + -> InDb Core.Timestamp + -> HdRoot +initHdRoot rootId name hasPass assurance created = HdRoot { + _hdRootId = rootId + , _hdRootName = name + , _hdRootHasPassword = hasPass + , _hdRootAssurance = assurance + , _hdRootCreatedAt = created + } + +-- | New account +-- +-- It is the responsibility of the caller to check the wallet's spending +-- password. +-- +-- TODO: If any key derivation is happening when creating accounts, should we +-- store a public key or an address or something? +initHdAccount :: HdAccountId + -> Checkpoint + -> HdAccount +initHdAccount accountId checkpoint = HdAccount { + _hdAccountId = accountId + , _hdAccountName = defName + , _hdAccountCheckpoints = checkpoint :| [] + } + where + defName = AccountName $ sformat ("Account: " % build) + (accountId ^. hdAccountIdIx) + +-- | New address in the specified account +-- +-- Since the DB does not contain the private key of the wallet, we cannot +-- do the actual address derivation here; this will be the responsibility of +-- the caller (which will require the use of the spending password, if +-- one exists). +-- +-- Similarly, it will be the responsibility of the caller to pick a random +-- address index, as we do not have access to a random number generator here. +initHdAddress :: HdAddressId + -> InDb Core.Address + -> HdAddress +initHdAddress addrId address = HdAddress { + _hdAddressId = addrId + , _hdAddressAddress = address + , _hdAddressIsUsed = error "TODO: _hdAddressIsUsed" + , _hdAddressIsChange = error "TODO: _hdAddressIsChange" + } + +{------------------------------------------------------------------------------- + Pretty printing +-------------------------------------------------------------------------------} + +instance Buildable CreateHdRootError where + build (CreateHdRootExists rootId) + = bprint ("CreateHdRootError::CreateHdRootExists "%build) rootId + +instance Buildable CreateHdAccountError where + build (CreateHdAccountUnknownRoot (UnknownHdRoot rootId)) + = bprint ("CreateHdAccountError::CreateHdAccountUnknownRoot "%build) rootId + build (CreateHdAccountExists accountId) + = bprint ("CreateHdAccountError::CreateHdAccountExists "%build) accountId + +instance Buildable CreateHdAddressError where + build (CreateHdAddressUnknown unknownRoot) + = bprint ("CreateHdAddressUnknown: "%build) unknownRoot + build (CreateHdAddressExists addressId) + = bprint ("CreateHdAddressExists: "%build) addressId diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet/Delete.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet/Delete.hs new file mode 100644 index 00000000000..c2a05ef57a5 --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet/Delete.hs @@ -0,0 +1,24 @@ +-- | DELETE operatiosn on HD wallets +module Cardano.Wallet.Kernel.DB.HdWallet.Delete ( + deleteHdRoot + , deleteHdAccount + ) where + +import Universum + +import Control.Lens (at, (.=)) + +import Cardano.Wallet.Kernel.DB.HdWallet +import Cardano.Wallet.Kernel.DB.Util.AcidState + +{------------------------------------------------------------------------------- + DELETE +-------------------------------------------------------------------------------} + +-- | Delete a wallet +deleteHdRoot :: HdRootId -> Update' HdWallets e () +deleteHdRoot rootId = zoom hdWalletsRoots $ at rootId .= Nothing + +-- | Delete an account +deleteHdAccount :: HdAccountId -> Update' HdWallets UnknownHdRoot () +deleteHdAccount accId = zoom hdWalletsAccounts $ at accId .= Nothing diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet/Read.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet/Read.hs new file mode 100644 index 00000000000..db9e4a3c5b2 --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet/Read.hs @@ -0,0 +1,154 @@ +-- | READ queries on the HD wallet +-- +-- NOTE: These are pure functions, which are intended to work on a snapshot +-- of the database. They are intended to support the V1 wallet API. +-- +-- TODO: We need to think about which layer will have the responsibility for +-- filtering and sorting. If we want the 'IxSet' stuff to be local to the +-- "Kernel.DB" namespace (which would be a good thing), then filtering and +-- sorting (and maybe even pagination) will need to happen here. +module Cardano.Wallet.Kernel.DB.HdWallet.Read ( + -- | * Infrastructure + HdQuery + , HdQueryErr + -- | * Derived balance + , hdRootBalance + , hdAccountBalance + -- | Accumulate all accounts/addresses + , readAllHdRoots + , readAllHdAccounts + , readAllHdAddresses + -- | All wallets/accounts/addresses + , readAccountsByRootId + , readAddressesByRootId + , readAddressesByAccountId + -- | Single wallets/accounts/addresses + , readHdRoot + , readHdAccount + , readHdAccountCurrentCheckpoint + , readHdAddress + ) where + +import Universum hiding (toList) + +import Control.Lens (at) +import Data.Foldable (toList) + +import Pos.Core (Coin, sumCoins) + +import Cardano.Wallet.Kernel.DB.HdWallet +import Cardano.Wallet.Kernel.DB.Spec +import Cardano.Wallet.Kernel.DB.Util.IxSet (IxSet) +import qualified Cardano.Wallet.Kernel.DB.Util.IxSet as IxSet + +{-# ANN module ("HLint: ignore Unnecessary hiding" :: Text) #-} + +{------------------------------------------------------------------------------- + Infrastructure +-------------------------------------------------------------------------------} + +-- | Query on a HD wallet +type HdQuery a = HdWallets -> a + +-- | Like 'HdQuery', but with the possibility of errors +type HdQueryErr e a = HdQuery (Either e a) + +-- | Like '(>>=)' for queries +using :: HdQueryErr e a -> (a -> HdQueryErr e b) -> HdQueryErr e b +using f g wallets = + case f wallets of + Left e -> Left e + Right a -> g a wallets + +-- | Variation on 'using' where the second query cannot throw errors +using' :: HdQueryErr e a -> (a -> HdQuery b) -> HdQueryErr e b +using' f g = using f ((Right .) . g) + +-- | Variation on 'using'' where the result of the first query is ignored +-- +-- Useful when the first query is merely a sanity check. +check :: HdQueryErr e a -> HdQuery b -> HdQueryErr e b +check f g = using' f (const g) + +{------------------------------------------------------------------------------- + Computed balances information +-------------------------------------------------------------------------------} + +hdRootBalance :: HdRootId -> HdQuery Integer +hdRootBalance rootId = sumCoins + . map hdAccountBalance + . Data.Foldable.toList + . IxSet.getEQ rootId + . view hdWalletsAccounts + +-- | Current balance of an account +hdAccountBalance :: HdAccount -> Coin +hdAccountBalance = view (hdAccountCheckpoints . currentUtxoBalance) + +{------------------------------------------------------------------------------- + Accumulate across wallets/accounts +-------------------------------------------------------------------------------} + +-- | Meta-information of /all wallets +readAllHdRoots :: HdQuery (IxSet HdRoot) +readAllHdRoots = view hdWalletsRoots + +-- | Meta-information of /all/ accounts +readAllHdAccounts :: HdQuery (IxSet HdAccount) +readAllHdAccounts = view hdWalletsAccounts + +-- | Meta-information and total balance of /all/ addresses +readAllHdAddresses :: HdQuery (IxSet HdAddress) +readAllHdAddresses = view hdWalletsAddresses + +{------------------------------------------------------------------------------- + Information about all wallets/accounts/addresses +-------------------------------------------------------------------------------} + +-- | All accounts in the given wallet +readAccountsByRootId :: HdRootId -> HdQueryErr UnknownHdRoot (IxSet HdAccount) +readAccountsByRootId rootId = + check (readHdRoot rootId) + $ IxSet.getEQ rootId . readAllHdAccounts + +-- | All addresses in the given wallet +readAddressesByRootId :: HdRootId -> HdQueryErr UnknownHdRoot (IxSet HdAddress) +readAddressesByRootId rootId = + check (readHdRoot rootId) + $ IxSet.getEQ rootId . readAllHdAddresses + +-- | All addresses in the given account +readAddressesByAccountId :: HdAccountId -> HdQueryErr UnknownHdAccount (IxSet HdAddress) +readAddressesByAccountId accId = + check (readHdAccount accId) + $ IxSet.getEQ accId . readAllHdAddresses + +{------------------------------------------------------------------------------- + Information about a single wallet/address/account +-------------------------------------------------------------------------------} + +-- | Look up the specified wallet +readHdRoot :: HdRootId -> HdQueryErr UnknownHdRoot HdRoot +readHdRoot rootId = aux . view (at rootId) . readAllHdRoots + where + aux :: Maybe a -> Either UnknownHdRoot a + aux = maybe (Left (UnknownHdRoot rootId)) Right + +-- | Look up the specified account +readHdAccount :: HdAccountId -> HdQueryErr UnknownHdAccount HdAccount +readHdAccount accId = aux . view (at accId) . readAllHdAccounts + where + aux :: Maybe a -> Either UnknownHdAccount a + aux = maybe (Left (UnknownHdAccount accId)) Right + +-- | Look up the specified account and return the current checkpoint +readHdAccountCurrentCheckpoint :: HdAccountId -> HdQueryErr UnknownHdAccount Checkpoint +readHdAccountCurrentCheckpoint accId db + = view hdAccountCurrentCheckpoint <$> readHdAccount accId db + +-- | Look up the specified address +readHdAddress :: HdAddressId -> HdQueryErr UnknownHdAddress HdAddress +readHdAddress addrId = aux . view (at addrId) . readAllHdAddresses + where + aux :: Maybe a -> Either UnknownHdAddress a + aux = maybe (Left (UnknownHdAddress addrId)) Right diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet/Update.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet/Update.hs new file mode 100644 index 00000000000..5b3f24de4d4 --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/HdWallet/Update.hs @@ -0,0 +1,38 @@ +-- | UPDATE operations on HD wallets +module Cardano.Wallet.Kernel.DB.HdWallet.Update ( + updateHdRootAssurance + , updateHdRootName + , updateHdAccountName + ) where + +import Universum + +import Control.Lens ((.=)) + +import Cardano.Wallet.Kernel.DB.HdWallet +import Cardano.Wallet.Kernel.DB.Util.AcidState + +{------------------------------------------------------------------------------- + UPDATE +-------------------------------------------------------------------------------} + +updateHdRootAssurance :: HdRootId + -> AssuranceLevel + -> Update' HdWallets UnknownHdRoot () +updateHdRootAssurance rootId assurance = + zoomHdRootId identity rootId $ + hdRootAssurance .= assurance + +updateHdRootName :: HdRootId + -> WalletName + -> Update' HdWallets UnknownHdRoot () +updateHdRootName rootId name = + zoomHdRootId identity rootId $ + hdRootName .= name + +updateHdAccountName :: HdAccountId + -> AccountName + -> Update' HdWallets UnknownHdAccount () +updateHdAccountName accId name = + zoomHdAccountId identity accId $ + hdAccountName .= name diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/InDb.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/InDb.hs new file mode 100644 index 00000000000..0c700a791fc --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/InDb.hs @@ -0,0 +1,75 @@ +module Cardano.Wallet.Kernel.DB.InDb ( + InDb(..) + , fromDb + ) where + +import Universum + +import Control.Lens.TH (makeLenses) +import Data.SafeCopy (SafeCopy (..)) + +import qualified Pos.Core as Core +import qualified Pos.Crypto as Core +import qualified Pos.Txp as Core + +{------------------------------------------------------------------------------- + Wrap core types so that we can make independent serialization decisions +-------------------------------------------------------------------------------} + +-- | Wrapped type (with potentially different 'SafeCopy' instance) +newtype InDb a = InDb { _fromDb :: a } + deriving (Eq, Ord) + +instance Functor InDb where + fmap f = InDb . f . _fromDb + +instance Applicative InDb where + pure = InDb + InDb f <*> InDb x = InDb (f x) + +makeLenses ''InDb + +{------------------------------------------------------------------------------- + Specific SafeCopy instances +-------------------------------------------------------------------------------} + +instance SafeCopy (InDb Core.Utxo) where + getCopy = error "TODO: getCopy for (InDb Core.Utxo)" + putCopy = error "TODO: putCopy for (InDb Core.Utxo)" + +-- TODO: This is really a UTxO again.. +instance SafeCopy (InDb (NonEmpty (Core.TxIn, Core.TxOutAux))) where + getCopy = error "TODO: getCopy for (InDb (NonEmpty (Core.TxIn, Core.TxOutAux)))" + putCopy = error "TODO: putCopy for (InDb (NonEmpty (Core.TxIn, Core.TxOutAux)))" + +instance SafeCopy (InDb Core.Timestamp) where + getCopy = error "TODO: getCopy for (InDb Core.Timestamp)" + putCopy = error "TODO: putCopy for (InDb Core.Timestamp)" + +instance SafeCopy (InDb Core.Address) where + getCopy = error "TODO: getCopy for (InDb Core.Address)" + putCopy = error "TODO: putCopy for (InDb Core.Address)" + +instance SafeCopy (InDb (Core.AddressHash Core.PublicKey)) where + getCopy = error "TODO: getCopy for (InDb (Core.AddressHash Core.PublicKey))" + putCopy = error "TODO: putCopy for (InDb (Core.AddressHash Core.PublicKey))" + +instance SafeCopy (InDb Core.Coin) where + getCopy = error "TODO: getCopy for (InDb Core.Coin)" + putCopy = error "TODO: putCopy for (InDb Core.Coin)" + +instance SafeCopy (InDb (Map Core.TxId Core.TxAux)) where + getCopy = error "TODO: getCopy for (InDb (Map Core.TxId Core.TxAux))" + putCopy = error "TODO: putCopy for (InDb (Map Core.TxId Core.TxAux))" + +instance SafeCopy (InDb Core.TxAux) where + getCopy = error "TODO: getCopy for (InDb Core.TxAux)" + putCopy = error "TODO: putCopy for (InDb Core.TxAux)" + +instance SafeCopy (InDb Core.TxIn) where + getCopy = error "TODO: getCopy for (InDb Core.TxIn)" + putCopy = error "TODO: putCopy for (InDb Core.TxIn)" + +instance SafeCopy (InDb (Map Core.TxId Core.SlotId)) where + getCopy = error "TODO: getCopy for (InDb (Map Core.TxId Core.SlotId))" + putCopy = error "TODO: putCopy for (InDb (Map Core.TxId Core.SlotId))" diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/Resolved.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/Resolved.hs new file mode 100644 index 00000000000..5b80d6fcc0a --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/Resolved.hs @@ -0,0 +1,87 @@ +-- | Resolved blocks and transactions +module Cardano.Wallet.Kernel.DB.Resolved ( + -- * Resolved blocks and transactions + ResolvedInput + , ResolvedTx(..) + , ResolvedBlock(..) + -- ** Lenses + , rtxInputs + , rtxOutputs + , rbTxs + ) where + +import Universum + +import Control.Lens.TH (makeLenses) +import qualified Data.Map as Map +import Data.SafeCopy (base, deriveSafeCopy) +import qualified Data.Text.Buildable +import Formatting (bprint, (%)) +import Serokell.Util (listJson, mapJson) + +import qualified Pos.Core as Core +import qualified Pos.Txp as Core + +import Cardano.Wallet.Kernel.DB.InDb + +{------------------------------------------------------------------------------- + Resolved blocks and transactions +-------------------------------------------------------------------------------} + +-- | Resolved input +-- +-- A transaction input @(h, i)@ points to the @i@th output of the transaction +-- with hash @h@, which is not particularly informative. The corresponding +-- 'ResolvedInput' is obtained by looking up what that output actually is. +type ResolvedInput = Core.TxOutAux + +-- | (Unsigned) transaction with inputs resolved +-- +-- NOTE: We cannot recover the original transaction from a 'ResolvedTx'. +-- Any information needed inside the wallet kernel must be explicitly +-- represented here. +data ResolvedTx = ResolvedTx { + -- | Transaction inputs + _rtxInputs :: InDb (NonEmpty (Core.TxIn, ResolvedInput)) + + -- | Transaction outputs + , _rtxOutputs :: InDb Core.Utxo + } + +-- | (Unsigned block) containing resolved transactions +-- +-- NOTE: We cannot recover the original block from a 'ResolvedBlock'. +-- Any information needed inside the wallet kernel must be explicitly +-- represented here. +data ResolvedBlock = ResolvedBlock { + -- | Transactions in the block + _rbTxs :: [ResolvedTx] + } + +makeLenses ''ResolvedTx +makeLenses ''ResolvedBlock + +deriveSafeCopy 1 'base ''ResolvedTx +deriveSafeCopy 1 'base ''ResolvedBlock + +{------------------------------------------------------------------------------- + Pretty-printing +-------------------------------------------------------------------------------} + +instance Buildable ResolvedTx where + build ResolvedTx{..} = bprint + ( "ResolvedTx " + % "{ inputs: " % mapJson + % ", outputs: " % mapJson + % "}" + ) + (Map.fromList (toList (_rtxInputs ^. fromDb))) + (_rtxOutputs ^. fromDb) + +instance Buildable ResolvedBlock where + build ResolvedBlock{..} = bprint + ( "ResolvedBlock " + % "{ txs: " % listJson + % "}" + ) + _rbTxs diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/Spec.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/Spec.hs new file mode 100644 index 00000000000..304673a4dc1 --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/Spec.hs @@ -0,0 +1,135 @@ +-- | Wallet state as mandated by the wallet specification +module Cardano.Wallet.Kernel.DB.Spec ( + -- * Wallet state as mandated by the spec + Pending(..) + , PendingTxs + , Balance + , Checkpoint(..) + , Checkpoints + , emptyPending + , singletonPending + , unionPending + , removePending + -- ** Lenses + , pendingTransactions + , checkpointUtxo + , checkpointUtxoBalance + , checkpointExpected + , checkpointPending + , checkpointBlockMeta + -- ** Lenses into the current checkpoint + , currentCheckpoint + , currentUtxo + , currentUtxoBalance + , currentExpected + , currentPending + , currentPendingTxs + , currentBlockMeta + ) where + +import Universum hiding (elems) + +import Control.Lens (to) +import Control.Lens.TH (makeLenses) +import qualified Data.Map.Strict as M +import Data.SafeCopy (base, deriveSafeCopy) +import Data.Text.Buildable (build) +import Formatting (bprint, (%)) +import Serokell.Util.Text (listJsonIndent) + +import qualified Pos.Core as Core +import qualified Pos.Txp as Core + +import Cardano.Wallet.Kernel.DB.BlockMeta +import Cardano.Wallet.Kernel.DB.InDb + +{------------------------------------------------------------------------------- + Wallet state as mandated by the spec +-------------------------------------------------------------------------------} + +type Balance = Integer + +type PendingTxs = Map Core.TxId Core.TxAux + +-- | Pending transactions +data Pending = Pending { + _pendingTransactions :: InDb PendingTxs + } deriving Eq + + +-- | Returns a new, empty 'Pending' set. +emptyPending :: Pending +emptyPending = Pending . InDb $ mempty + +-- | Returns a new, empty 'Pending' set. +singletonPending :: Core.TxId -> Core.TxAux -> Pending +singletonPending txId txAux = Pending . InDb $ M.singleton txId txAux + +-- | Computes the union between two 'Pending' sets. +unionPending :: Pending -> Pending -> Pending +unionPending (Pending new) (Pending old) = + Pending (M.union <$> new <*> old) + +-- | Computes the difference between two 'Pending' sets. +removePending :: Set Core.TxId -> Pending -> Pending +removePending ids (Pending (InDb old)) = Pending (InDb $ old `withoutKeys` ids) + where + withoutKeys :: Ord k => Map k a -> Set k -> Map k a + m `withoutKeys` s = m `M.difference` M.fromSet (const ()) s + +-- | Per-wallet state +-- +-- This is the same across all wallet types. +data Checkpoint = Checkpoint { + _checkpointUtxo :: InDb Core.Utxo + , _checkpointUtxoBalance :: InDb Core.Coin + , _checkpointExpected :: InDb Core.Utxo + , _checkpointPending :: Pending + , _checkpointBlockMeta :: BlockMeta + } + +-- | List of checkpoints +type Checkpoints = NonEmpty Checkpoint + +makeLenses ''Pending +makeLenses ''Checkpoint + +deriveSafeCopy 1 'base ''Pending +deriveSafeCopy 1 'base ''Checkpoint + +{------------------------------------------------------------------------------- + Lenses for accessing current checkpoint +-------------------------------------------------------------------------------} + +currentCheckpoint :: Lens' Checkpoints Checkpoint +currentCheckpoint = neHead + +currentUtxo :: Lens' Checkpoints Core.Utxo +currentUtxoBalance :: Lens' Checkpoints Core.Coin +currentExpected :: Lens' Checkpoints Core.Utxo +currentBlockMeta :: Lens' Checkpoints BlockMeta +currentPending :: Lens' Checkpoints Pending +currentPendingTxs :: Lens' Checkpoints PendingTxs + +currentUtxo = currentCheckpoint . checkpointUtxo . fromDb +currentUtxoBalance = currentCheckpoint . checkpointUtxoBalance . fromDb +currentExpected = currentCheckpoint . checkpointExpected . fromDb +currentBlockMeta = currentCheckpoint . checkpointBlockMeta +currentPending = currentCheckpoint . checkpointPending +currentPendingTxs = currentPending . pendingTransactions . fromDb + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +neHead :: Lens' (NonEmpty a) a +neHead f (x :| xs) = (:| xs) <$> f x + +{------------------------------------------------------------------------------- + Pretty-printing +-------------------------------------------------------------------------------} + +instance Buildable Pending where + build (Pending p) = + let elems = p ^. fromDb . to M.toList + in bprint ("Pending " % listJsonIndent 4) (map fst elems) diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/Spec/Read.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/Spec/Read.hs new file mode 100644 index 00000000000..259d8fe2d2e --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/Spec/Read.hs @@ -0,0 +1,107 @@ +-- | READ-only operations on the wallet-spec state +module Cardano.Wallet.Kernel.DB.Spec.Read ( + -- * Queries + queryAccountTotalBalance + , queryAccountUtxo + ) where + +import Universum + +import qualified Data.Map.Strict as Map + +import qualified Pos.Core as Core +import Pos.Core.Txp (TxOut (..), TxOutAux (..)) +import Pos.Txp (Utxo) + +import Cardano.Wallet.Kernel.DB.HdWallet +import qualified Cardano.Wallet.Kernel.DB.HdWallet.Read as HD +import Cardano.Wallet.Kernel.DB.InDb +import Cardano.Wallet.Kernel.DB.Spec +import Cardano.Wallet.Kernel.DB.Spec.Util + +import Cardano.Wallet.Kernel.DB.Util.IxSet (IxSet) +import qualified Cardano.Wallet.Kernel.DB.Util.IxSet as IxSet + +{------------------------------------------------------------------------------- + An address is considered "ours" if it belongs to the set of "our" addresses. + The following pure functions are given the set of "our" addresses to enable filtering. +-------------------------------------------------------------------------------} + +-- | If an Address is in the given set, it will occur exactly once or not at all +ourAddr :: IxSet HdAddress -> Core.Address -> Bool +ourAddr addrs addr = + 1 == IxSet.size (IxSet.getEQ addr addrs) + +-- | Determines whether the transaction output address is one of "ours" +ourTxOut :: IxSet HdAddress -> TxOutAux -> Bool +ourTxOut addrs tx + = ourAddr addrs (txOutAddress . toaOut $ tx) + +-- | Filters the given utxo by selecting only utxo outputs that are "ours" +ourUtxo :: IxSet HdAddress -> Utxo -> Utxo +ourUtxo addrs = Map.filter (ourTxOut addrs) + +{------------------------------------------------------------------------------- + Pure functions that support read-only operations on an account Checkpoint, as + defined in the Wallet Spec +-------------------------------------------------------------------------------} + +accountUtxo :: Checkpoint -> Utxo +accountUtxo = view (checkpointUtxo . fromDb) + +accountUtxoBalance :: Checkpoint -> Core.Coin +accountUtxoBalance = view (checkpointUtxoBalance . fromDb) + +accountPendingTxs :: Checkpoint -> PendingTxs +accountPendingTxs = view (checkpointPending . pendingTransactions . fromDb) + +-- | The Available Balance is the cached utxo balance minus any (pending) spent utxo +accountAvailableBalance :: Checkpoint -> Core.Coin +accountAvailableBalance c = + fromMaybe subCoinErr balance' + where + subCoinErr = error "Coin arithmetic error: subCoin utxoBalance balanceDelta" + + pendingIns = txIns (accountPendingTxs c) + spentUtxo = utxoRestrictToInputs (accountUtxo c) pendingIns + + balance' = Core.subCoin (accountUtxoBalance c) (balance spentUtxo) + +-- | Account Change refers to any pending outputs paid back into the +-- account (represented by the given checkpoint). +-- +-- NOTE: computing 'change' requires filtering "our" addresses +accountChange :: (Utxo -> Utxo) -> Checkpoint -> Utxo +accountChange ours + = ours . pendingUtxo . accountPendingTxs + +-- | The Account Total Balance is the 'available' balance plus any 'change' +-- +-- NOTE: computing 'total balance' requires filtering "our" addresses, which requires +-- the full set of addresses for this Account Checkpoint +accountTotalBalance :: IxSet HdAddress -> Checkpoint -> Core.Coin +accountTotalBalance addrs c + = add' availableBalance changeBalance + where + add' = Core.unsafeAddCoin + ourUtxo' = ourUtxo addrs + + availableBalance = accountAvailableBalance c + changeBalance = balance (accountChange ourUtxo' c) + +{------------------------------------------------------------------------------- + Public queries on an account, as defined in the Wallet Spec +-------------------------------------------------------------------------------} + +queryAccountTotalBalance :: HdAccountId -> HD.HdQueryErr UnknownHdAccount Core.Coin +queryAccountTotalBalance accountId db + = accountTotalBalance <$> ourAddrs <*> checkpoint + where + checkpoint = HD.readHdAccountCurrentCheckpoint accountId db + ourAddrs = HD.readAddressesByAccountId accountId db + +queryAccountUtxo :: HdAccountId -> HD.HdQueryErr UnknownHdAccount Utxo +queryAccountUtxo accountId db + = accountUtxo <$> checkpoint + where + checkpoint = HD.readHdAccountCurrentCheckpoint accountId db diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/Spec/Update.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/Spec/Update.hs new file mode 100644 index 00000000000..4c99b04dce9 --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/Spec/Update.hs @@ -0,0 +1,146 @@ +-- | UPDATE operations on the wallet-spec state +module Cardano.Wallet.Kernel.DB.Spec.Update ( + -- * Errors + NewPendingFailed(..) + -- * Updates + , newPending + , applyBlock + , switchToFork + ) where + +import Universum + +import Data.SafeCopy (base, deriveSafeCopy) + +import qualified Data.Set as Set +import qualified Data.Map.Strict as Map +import qualified Data.List.NonEmpty as NE + +import qualified Pos.Core as Core +import Pos.Core.Chrono (OldestFirst(..)) +import Pos.Crypto (hash) +import Pos.Txp (Utxo) + +import Cardano.Wallet.Kernel.PrefilterTx (PrefilteredBlock (..)) + +import Cardano.Wallet.Kernel.DB.BlockMeta +import Cardano.Wallet.Kernel.DB.InDb +import Cardano.Wallet.Kernel.DB.Spec +import Cardano.Wallet.Kernel.DB.Spec.Util +import Cardano.Wallet.Kernel.DB.Util.AcidState + +{------------------------------------------------------------------------------- + Errors +-------------------------------------------------------------------------------} + +-- | Errors thrown by 'newPending' +data NewPendingFailed = + -- | Some inputs are not in the wallet utxo + NewPendingInputsUnavailable (Set (InDb Core.TxIn)) + +deriveSafeCopy 1 'base ''NewPendingFailed + +{------------------------------------------------------------------------------- + Wallet spec mandated updates +-------------------------------------------------------------------------------} + +-- | Insert new pending transaction into the specified wallet +-- +-- NOTE: Transactions to be inserted must be fully constructed and signed; we do +-- not offer input selection at this layer. Instead, callers must get a snapshot +-- of the database, construct a transaction asynchronously, and then finally +-- submit the transaction. It is of course possible that the state of the +-- database has changed at this point, possibly making the generated transaction +-- invalid; 'newPending' therefore returns whether or not the transaction could +-- be inserted. If this fails, the process must be started again. This is +-- important for a number of reasons: +-- +-- * Input selection may be an expensive computation, and we don't want to +-- lock the database while input selection is ongoing. +-- * Transactions may be signed off-site (on a different machine or on a +-- a specialized hardware device). +-- * We do not actually have access to the key storage inside the DB layer +-- (and do not store private keys) so we cannot actually sign transactions. +newPending :: InDb Core.TxAux + -> Update' Checkpoints NewPendingFailed () +newPending tx = do + checkpoints <- get + let available' = available (checkpoints ^. currentUtxo) (checkpoints ^. currentPendingTxs) + if isValidPendingTx tx' available' + then + put (insertPending checkpoints) + else + inputUnavailableErr available' + + where + tx' = tx ^. fromDb + + insertPending :: Checkpoints -> Checkpoints + insertPending cs = cs & currentPendingTxs %~ Map.insert txId tx' + where txId = hash $ Core.taTx tx' + + inputUnavailableErr available_ = do + let unavailableInputs = txAuxInputSet tx' `Set.difference` utxoInputs available_ + throwError $ NewPendingInputsUnavailable (Set.map InDb unavailableInputs) + +-- | Apply the prefiltered block to the specified wallet +applyBlock :: (PrefilteredBlock, BlockMeta) + -> Checkpoints + -> Checkpoints +applyBlock (prefBlock, _bMeta) checkpoints + = Checkpoint { + _checkpointUtxo = InDb utxo'' + , _checkpointUtxoBalance = InDb balance'' + , _checkpointPending = Pending . InDb $ pending'' + , _checkpointExpected = InDb expected'' + , _checkpointBlockMeta = blockMeta'' + } NE.<| checkpoints + where + utxo' = checkpoints ^. currentUtxo + utxoBalance' = checkpoints ^. currentUtxoBalance + pending' = checkpoints ^. currentPendingTxs + + (utxo'', balance'') = updateUtxo prefBlock (utxo', utxoBalance') + pending'' = updatePending prefBlock pending' + -- TODO(@uroboros/ryan) applyBlock.updateExpected/updateBlockMeta + -- (as part of CBR-150 Extend pure data layer to support rollback) + expected'' = checkpoints ^. currentExpected + blockMeta'' = checkpoints ^. currentBlockMeta + +-- | Update (utxo,balance) with the given prefiltered block +updateUtxo :: PrefilteredBlock -> (Utxo, Core.Coin) -> (Utxo, Core.Coin) +updateUtxo PrefilteredBlock{..} (currentUtxo', currentBalance') + = (utxo', balance') + where + unionUtxo = Map.union pfbOutputs currentUtxo' + utxo' = utxoRemoveInputs unionUtxo pfbInputs + + unionUtxoRestricted = utxoRestrictToInputs unionUtxo pfbInputs + balanceDelta = balanceI pfbOutputs - balanceI unionUtxoRestricted + currentBalanceI = Core.coinToInteger currentBalance' + balance' = Core.unsafeIntegerToCoin $ currentBalanceI + balanceDelta + +-- | Update the pending transactions with the given prefiltered block +updatePending :: PrefilteredBlock -> PendingTxs -> PendingTxs +updatePending PrefilteredBlock{..} = + Map.filter (\t -> disjoint (txAuxInputSet t) pfbInputs) + +-- | Rollback +-- +-- This is an internal function only, and not exported. See 'switchToFork'. +rollback :: Checkpoints -> Checkpoints +rollback = error "rollback" + +-- | Switch to a fork +switchToFork :: Int -- ^ Number of blocks to rollback + -> OldestFirst [] (PrefilteredBlock, BlockMeta) -- ^ Blocks to apply + -> Checkpoints -> Checkpoints +switchToFork = \n bs -> applyBlocks (getOldestFirst bs) . rollbacks n + where + applyBlocks :: [(PrefilteredBlock, BlockMeta)] -> Checkpoints -> Checkpoints + applyBlocks [] = identity + applyBlocks (b:bs) = applyBlocks bs . applyBlock b + + rollbacks :: Int -> Checkpoints -> Checkpoints + rollbacks 0 = identity + rollbacks n = rollbacks (n - 1) . rollback diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/Spec/Util.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/Spec/Util.hs new file mode 100644 index 00000000000..f988e42ee85 --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/Spec/Util.hs @@ -0,0 +1,83 @@ +-- | UPDATE operations on the wallet-spec state +module Cardano.Wallet.Kernel.DB.Spec.Util ( + PendingTxs + , Balance + , available + , balance + , balanceI + , disjoint + , isValidPendingTx + , pendingUtxo + , txAuxInputSet + , txIns + , utxoInputs + , unionTxOuts + , utxoRemoveInputs + , utxoRestrictToInputs + ) where + +import Universum + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.List.NonEmpty as NE + +import qualified Pos.Core as Core + +import Pos.Txp (Utxo) +import Pos.Core.Txp (Tx (..), TxAux (..), TxIn (..), TxOut (..), TxOutAux (..)) + +import Cardano.Wallet.Kernel.DB.Spec +import Cardano.Wallet.Kernel.Types (txUtxo) + +utxoOutputs :: Utxo -> [TxOut] +utxoOutputs = map toaOut . Map.elems + +balanceI :: Utxo -> Balance +balanceI = Core.sumCoins . map txOutValue . utxoOutputs + +balance :: Utxo -> Core.Coin +balance utxo + = case Core.integerToCoin . balanceI $ utxo of + Left _ -> error "balance' integerToCoin failed" + Right c -> c + +unionTxOuts :: [Utxo] -> Utxo +unionTxOuts = Map.unions + +utxoInputs :: Utxo -> Set TxIn +utxoInputs = Map.keysSet + +txIns :: PendingTxs -> Set TxIn +txIns = Set.fromList . concatMap (NE.toList . _txInputs . taTx) . Map.elems + +txAuxInputSet :: TxAux -> Set TxIn +txAuxInputSet = Set.fromList . NE.toList . _txInputs . taTx + +withoutKeys :: Ord k => Map k a -> Set k -> Map k a +m `withoutKeys` s = m `Map.difference` Map.fromSet (const ()) s + +restrictKeys :: Ord k => Map k a -> Set k -> Map k a +m `restrictKeys` s = m `Map.intersection` Map.fromSet (const ()) s + +disjoint :: Ord a => Set a -> Set a -> Bool +disjoint a b = Set.null (a `Set.intersection` b) + +utxoRemoveInputs :: Utxo -> Set TxIn -> Utxo +utxoRemoveInputs = withoutKeys + +utxoRestrictToInputs :: Utxo -> Set TxIn -> Utxo +utxoRestrictToInputs = restrictKeys + +available :: Utxo -> PendingTxs -> Utxo +available utxo pending = utxoRemoveInputs utxo (txIns pending) + +pendingUtxo :: PendingTxs -> Utxo +pendingUtxo pending = unionTxOuts $ map (txUtxo . taTx) $ Map.elems pending + +isValidPendingTx :: TxAux -> Utxo -> Bool +isValidPendingTx tx availableUtxo + = txInputs `Set.isSubsetOf` availableInputs + where + txInputs = txAuxInputSet tx + availableInputs = utxoInputs availableUtxo diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/Sqlite.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/Sqlite.hs new file mode 100644 index 00000000000..d24d7343008 --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/Sqlite.hs @@ -0,0 +1,526 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- | Sqlite database for the 'TxMeta' portion of the wallet kernel. +module Cardano.Wallet.Kernel.DB.Sqlite ( + + -- * Resource creation and acquisition + newConnection + , closeMetaDB + + -- * Basic API + , putTxMeta + , getTxMeta + , getTxMetas + + -- * Unsafe functions + , unsafeMigrateMetaDB + ) where + +import qualified Prelude +import Universum + +import Database.Beam.Backend.SQL (FromBackendRow, HasSqlValueSyntax (..), + IsSql92DataTypeSyntax, varCharType) +import Database.Beam.Backend.SQL.SQL92 (Sql92OrderingExpressionSyntax, + Sql92SelectOrderingSyntax) +import Database.Beam.Query (HasSqlEqualityCheck, (==.)) +import qualified Database.Beam.Query as SQL +import qualified Database.Beam.Query.Internal as SQL +import Database.Beam.Schema (Beamable, Database, DatabaseSettings, PrimaryKey, Table) +import qualified Database.Beam.Schema as Beam +import Database.Beam.Sqlite.Connection (Sqlite, runBeamSqlite) +import Database.Beam.Sqlite.Syntax (SqliteCommandSyntax, SqliteDataTypeSyntax, + SqliteExpressionSyntax, SqliteSelectSyntax, + SqliteValueSyntax, fromSqliteCommand, + sqliteBigIntType, sqliteRenderSyntaxScript) +import qualified Database.SQLite.Simple as Sqlite +import Database.SQLite.Simple.FromField (FromField (..), returnError) +import qualified Database.SQLite.SimpleErrors as Sqlite +import qualified Database.SQLite.SimpleErrors.Types as Sqlite + +import Control.Exception (throwIO, toException) +import Control.Lens (Getter) +import qualified Data.Foldable as Foldable +import qualified Data.Map as M +import Data.Time.Units (fromMicroseconds, toMicroseconds) +import Database.Beam.Migrate (CheckedDatabaseSettings, DataType (..), Migration, + MigrationSteps, boolean, createTable, evaluateDatabase, + executeMigration, field, migrationStep, notNull, + runMigrationSteps, unCheckDatabase, unique) +import Formatting (sformat) +import GHC.Generics (Generic) + +import Cardano.Wallet.Kernel.DB.TxMeta.Types (Limit (..), Offset (..), SortCriteria (..), + SortDirection (..), Sorting (..)) +import qualified Cardano.Wallet.Kernel.DB.TxMeta.Types as Kernel +import qualified Pos.Core as Core +import Pos.Crypto.Hashing (decodeAbstractHash, hashHexF) + + +-- | A type modelling the underlying SQL database. +data MetaDB f = MetaDB { _mDbMeta :: f (Beam.TableEntity TxMetaT) + , _mDbInputs :: f (Beam.TableEntity TxInputT) + , _mDbOutputs :: f (Beam.TableEntity TxOutputT) + } deriving Generic + +instance Database Sqlite MetaDB + +{-- + +* Table 1: ~tx_metas~ +** Primary Index: ~tx_meta_id~ +** Secondary Indexes (for now): ~tx_meta_created_at~ + +| tx_meta_id | tx_meta_amount | tx_meta_created_at | tx_meta_is_local | tx_meta_is_outgoing | +|------------+----------------+--------------------+------------------+---------------------| +| Core.TxId | Core.Coin | Core.Timestamp | Bool | Bool | + +--} +data TxMetaT f = TxMeta { + _txMetaTableId :: Beam.Columnar f Core.TxId + , _txMetaTableAmount :: Beam.Columnar f Core.Coin + , _txMetaTableCreatedAt :: Beam.Columnar f Core.Timestamp + , _txMetaTableIsLocal :: Beam.Columnar f Bool + , _txMetaTableIsOutgoing :: Beam.Columnar f Bool + } deriving Generic + +type TxMeta = TxMetaT Identity + +deriving instance Eq TxMeta +deriving instance Show TxMeta + +-- | Creates a storage-specific 'TxMeta' out of a 'Kernel.TxMeta'. +mkTxMeta :: Kernel.TxMeta -> TxMeta +mkTxMeta txMeta = TxMeta { + _txMetaTableId = txMeta ^. Kernel.txMetaId + , _txMetaTableAmount = txMeta ^. Kernel.txMetaAmount + , _txMetaTableCreatedAt = txMeta ^. Kernel.txMetaCreationAt + , _txMetaTableIsLocal = txMeta ^. Kernel.txMetaIsLocal + , _txMetaTableIsOutgoing = txMeta ^. Kernel.txMetaIsOutgoing + } + +instance Beamable TxMetaT + +instance Table TxMetaT where + data PrimaryKey TxMetaT f = TxIdPrimKey (Beam.Columnar f Core.TxId) deriving Generic + primaryKey = TxIdPrimKey . _txMetaTableId + +instance Beamable (PrimaryKey TxMetaT) + +{-- + +* Table 2: ~tx_meta_inputs~ +** Primary Index: ~tx_meta_input_address~ +** Secondary Indexes: ~tx_meta_id~ + +| tx_meta_input_address | tx_meta_coin | tx_meta_id | +|-----------------------+--------------+------------| +| Core.Address | Core.Coin | Core.TxId | + +** Table 3: ~tx_meta_outputs~ +** Primary Index: ~tx_meta_output_address~ +** Secondary Indexes: ~tx_meta_id~ + +| tx_meta_output_address | tx_meta_coin | tx_meta_id | +|------------------------+--------------+------------| +| Core.Address | Core.Coin | Core.TxId | + +--} + +data TxCoinDistributionTableT f = TxCoinDistributionTable { + _txCoinDistributionTableAddress :: Beam.Columnar f Core.Address + , _txCoinDistributionTableCoin :: Beam.Columnar f Core.Coin + , _txCoinDistributionTxId :: Beam.PrimaryKey TxMetaT f + } deriving Generic + +type TxCoinDistributionTable = TxCoinDistributionTableT Identity + +instance Beamable TxCoinDistributionTableT + +-- | The inputs' table. +newtype TxInputT f = TxInput { + _getTxInput :: (TxCoinDistributionTableT f) + } deriving Generic + +type TxInput = TxInputT Identity + +instance Beamable TxInputT + +instance Table TxInputT where + data PrimaryKey TxInputT f = TxInputPrimKey (Beam.Columnar f Core.Address) (Beam.PrimaryKey TxMetaT f) deriving Generic + primaryKey (TxInput i) = TxInputPrimKey (_txCoinDistributionTableAddress i) (_txCoinDistributionTxId i) + +instance Beamable (PrimaryKey TxInputT) + +-- | Generalisation of 'mkInputs' and 'mkOutputs'. +mkCoinDistribution :: forall a. Kernel.TxMeta + -> (Getter Kernel.TxMeta (NonEmpty (Core.Address, Core.Coin))) + -> (TxCoinDistributionTable -> a) + -> NonEmpty a +mkCoinDistribution txMeta getter builder = + let distribution = txMeta ^. getter + txid = txMeta ^. Kernel.txMetaId + in fmap (mk txid) distribution + where + mk :: Core.TxId -> (Core.Address, Core.Coin) -> a + mk tid (addr, amount) = builder (TxCoinDistributionTable addr amount (TxIdPrimKey tid)) + +-- | Convenient constructor of a list of 'TxInput' from a 'Kernel.TxMeta'. +mkInputs :: Kernel.TxMeta -> NonEmpty TxInput +mkInputs txMeta = mkCoinDistribution txMeta Kernel.txMetaInputs TxInput + +-- | The outputs' table. +newtype TxOutputT f = TxOutput { + _getTxOutput :: (TxCoinDistributionTableT f) + } deriving Generic + +type TxOutput = TxOutputT Identity + +instance Beamable TxOutputT + +instance Table TxOutputT where + data PrimaryKey TxOutputT f = TxOutputPrimKey (Beam.Columnar f Core.Address) (Beam.PrimaryKey TxMetaT f) deriving Generic + primaryKey (TxOutput o) = TxOutputPrimKey (_txCoinDistributionTableAddress o) (_txCoinDistributionTxId o) + +instance Beamable (PrimaryKey TxOutputT) + +-- | Convenient constructor of a list of 'TxOutput from a 'Kernel.TxMeta'. +mkOutputs :: Kernel.TxMeta -> NonEmpty TxOutput +mkOutputs txMeta = mkCoinDistribution txMeta Kernel.txMetaOutputs TxOutput + + +-- Orphans & other boilerplate + +instance HasSqlValueSyntax SqliteValueSyntax Core.TxId where + sqlValueSyntax txid = sqlValueSyntax (sformat hashHexF txid) + +instance HasSqlValueSyntax SqliteValueSyntax Core.Coin where + sqlValueSyntax = sqlValueSyntax . Core.unsafeGetCoin + +-- NOTE(adn) As reported by our good lad Matt Parsons, 'Word64' has enough +-- precision to justify the downcast: +-- +-- >>> λ> import Data.Time +-- >>> λ> import Data.Time.Clock.POSIX +-- >>> λ> import Data.Word +-- >>> λ> :set -XNumDecimals +-- >>> λ> posixSecondsToUTCTime (fromIntegral ((maxBound :: Word64) `div` 1e6)) +-- 586524-01-19 08:01:49 UTC +-- +instance HasSqlValueSyntax SqliteValueSyntax Core.Timestamp where + sqlValueSyntax ts = sqlValueSyntax (fromIntegral @Integer @Word64 . toMicroseconds . Core.getTimestamp $ ts) + +instance HasSqlValueSyntax SqliteValueSyntax Core.Address where + sqlValueSyntax addr = sqlValueSyntax (sformat Core.addressF addr) + + +instance HasSqlEqualityCheck SqliteExpressionSyntax Core.TxId + +instance FromField Core.TxId where + fromField f = do + h <- decodeAbstractHash <$> fromField f + case h of + Left _ -> returnError Sqlite.ConversionFailed f "not a valid hex hash" + Right txid -> pure txid + +instance FromBackendRow Sqlite Core.TxId + +instance FromField Core.Coin where + fromField f = Core.Coin <$> fromField f + +instance FromBackendRow Sqlite Core.Coin + +instance FromField Core.Timestamp where + fromField f = Core.Timestamp . fromMicroseconds . toInteger @Word64 <$> fromField f + +instance FromBackendRow Sqlite Core.Timestamp + +instance FromField Core.Address where + fromField f = do + addr <- Core.decodeTextAddress <$> fromField f + case addr of + Left _ -> returnError Sqlite.ConversionFailed f "not a valid Address" + Right a -> pure a + +instance FromBackendRow Sqlite Core.Address + + +-- | Creates new 'DatabaseSettings' for the 'MetaDB', locking the backend to +-- be 'Sqlite'. +metaDB :: DatabaseSettings Sqlite MetaDB +metaDB = unCheckDatabase (evaluateDatabase migrateMetaDB) + +-- | 'DataType' declaration to convince @Beam@ treating 'Core.Address'(es) as +-- varchars of arbitrary length. +address :: DataType SqliteDataTypeSyntax Core.Address +address = DataType (varCharType Nothing Nothing) + +-- | 'DataType' declaration to convince @Beam@ treating 'Core.Timestamp'(s) as +-- SQLite BIG INTEGER. +timestamp :: DataType SqliteDataTypeSyntax Core.Timestamp +timestamp = DataType sqliteBigIntType + +-- | 'DataType' declaration to convince @Beam@ treating 'Core.TxId(s) as +-- varchars of arbitrary length. +txId :: IsSql92DataTypeSyntax syntax => DataType syntax Core.TxId +txId = DataType (varCharType Nothing Nothing) + +-- | 'DataType' declaration to convince @Beam@ treating 'Core.Coin(s) as +-- SQLite BIG INTEGER. +coin :: DataType SqliteDataTypeSyntax Core.Coin +coin = DataType sqliteBigIntType + +-- | Beam's 'Migration' to create a new 'MetaDB' Sqlite database. +initialMigration :: () -> Migration SqliteCommandSyntax (CheckedDatabaseSettings Sqlite MetaDB) +initialMigration () = do + MetaDB <$> createTable "tx_metas" + (TxMeta (field "meta_id" txId notNull unique) + (field "meta_amount" coin notNull) + (field "meta_created_at" timestamp notNull) + (field "meta_is_local" boolean notNull) + (field "meta_is_outgoing" boolean notNull)) + <*> createTable "tx_metas_inputs" + (TxInput (TxCoinDistributionTable (field "input_address" address notNull) + (field "input_coin" coin notNull) + (TxIdPrimKey (field "meta_id" txId notNull)) + )) + <*> createTable "tx_metas_outputs" + (TxOutput (TxCoinDistributionTable (field "output_address" address notNull) + (field "output_coin" coin notNull) + (TxIdPrimKey (field "meta_id" txId notNull)) + )) + +--- | The full list of migrations available for this 'MetaDB'. +-- For a more interesting migration, see: https://github.com/tathougies/beam/blob/d3baf0c77b76b008ad34901b47a818ea79439529/beam-postgres/examples/Pagila/Schema.hs#L17-L19 +migrateMetaDB :: MigrationSteps SqliteCommandSyntax () (CheckedDatabaseSettings Sqlite MetaDB) +migrateMetaDB = migrationStep "Initial migration" initialMigration + + +-- | Migrates the 'MetaDB', potentially mangling the input database. +-- TODO(adinapoli): Make it safe. +unsafeMigrateMetaDB :: Sqlite.Connection -> IO () +unsafeMigrateMetaDB conn = + void $ runMigrationSteps 0 Nothing migrateMetaDB (\_ _ -> executeMigration (Sqlite.execute_ conn . newSqlQuery)) + where + newSqlQuery :: SqliteCommandSyntax -> Sqlite.Query + newSqlQuery syntax = + let sqlFragment = sqliteRenderSyntaxScript . fromSqliteCommand $ syntax + in Sqlite.Query (decodeUtf8 sqlFragment) + +-- | Simply a conveniency wrapper to avoid 'Kernel.TxMeta' to explicitly +-- import Sqlite modules. +newConnection :: FilePath -> IO Sqlite.Connection +newConnection = Sqlite.open + +-- | Closes an open 'Connection' to the @Sqlite@ database stored in the +-- input 'MetaDBHandle'. +closeMetaDB :: Sqlite.Connection -> IO () +closeMetaDB = Sqlite.close + +-- | Inserts a new 'Kernel.TxMeta' in the database, given its opaque +-- 'MetaDBHandle'. +putTxMeta :: Sqlite.Connection -> Kernel.TxMeta -> IO () +putTxMeta conn txMeta = + let tMeta = mkTxMeta txMeta + inputs = mkInputs txMeta + outputs = mkOutputs txMeta + in do + res <- Sqlite.withTransaction conn $ Sqlite.runDBAction $ runBeamSqlite conn $ do + SQL.runInsert $ SQL.insert (_mDbMeta metaDB) $ SQL.insertValues [tMeta] + SQL.runInsert $ SQL.insert (_mDbInputs metaDB) $ SQL.insertValues (toList inputs) + SQL.runInsert $ SQL.insert (_mDbOutputs metaDB) $ SQL.insertValues (toList outputs) + case res of + Left e -> handleResponse e + Right () -> return () + where + -- Handle the 'SQLiteResponse', rethrowing the exception or turning + -- \"controlled failures\" (like the presence of a duplicated + -- transaction) in a no-op. + handleResponse :: Sqlite.SQLiteResponse -> IO () + handleResponse e = + let txid = txMeta ^. Kernel.txMetaId + in case e of + -- NOTE(adinapoli): It's probably possible to make this match the + -- Beam schema by using something like 'IsDatabaseEntity' from + -- 'Database.Beam.Schema.Tables', but we have a test to catch + -- regression in this area. + (Sqlite.SQLConstraintError Sqlite.Unique "tx_metas_inputs.input_address, tx_metas_inputs.meta_id") -> do + let err = Kernel.DuplicatedInputIn txid + throwIO $ Kernel.InvariantViolated err + + (Sqlite.SQLConstraintError Sqlite.Unique "tx_metas_outputs.output_address, tx_metas_outputs.meta_id") -> do + let err = Kernel.DuplicatedOutputIn txid + throwIO $ Kernel.InvariantViolated err + + (Sqlite.SQLConstraintError Sqlite.Unique "tx_metas.meta_id") -> do + -- Check if the 'TxMeta' already present is a @different@ + -- one, in which case this is a proper bug there is no + -- recover from. If the 'TxMeta' is the same, this is effectively + -- a no-op. + -- NOTE: We use a shallow equality check here because if the + -- input 'TxMeta' has the same inputs & outputs but in a different + -- order, the 'consistencyCheck' would yield 'False', when in + -- reality should be virtually considered the same 'TxMeta'. + consistencyCheck <- fmap (Kernel.isomorphicTo txMeta) <$> getTxMeta conn txid + case consistencyCheck of + Nothing -> + throwIO $ Kernel.InvariantViolated (Kernel.UndisputableLookupFailed "consistencyCheck" txid) + Just False -> + throwIO $ Kernel.InvariantViolated (Kernel.DuplicatedTransactionWithDifferentHash txid) + Just True -> + -- both "hashes" matched, this is genuinely the + -- same 'Tx' being inserted twice, probably as + -- part of a rollback. + return () + + _ -> throwIO $ Kernel.StorageFailure (toException e) + + +-- | Converts a database-fetched 'TxMeta' into a domain-specific 'Kernel.TxMeta'. +toTxMeta :: TxMeta -> NonEmpty TxInput -> NonEmpty TxOutput -> Kernel.TxMeta +toTxMeta txMeta inputs outputs = Kernel.TxMeta { + _txMetaId = _txMetaTableId txMeta + , _txMetaAmount = _txMetaTableAmount txMeta + , _txMetaInputs = fmap (reify . _getTxInput) inputs + , _txMetaOutputs = fmap (reify . _getTxOutput) outputs + , _txMetaCreationAt = _txMetaTableCreatedAt txMeta + , _txMetaIsLocal = _txMetaTableIsLocal txMeta + , _txMetaIsOutgoing = _txMetaTableIsOutgoing txMeta + } + where + -- | Reifies the input 'TxCoinDistributionTableT' into a tuple suitable + -- for a 'Kernel.TxMeta'. + reify :: TxCoinDistributionTable -> (Core.Address, Core.Coin) + reify coinDistr = (,) (_txCoinDistributionTableAddress coinDistr) + (_txCoinDistributionTableCoin coinDistr) + +-- | Fetches a 'Kernel.TxMeta' from the database, given its 'Core.TxId'. +getTxMeta :: Sqlite.Connection -> Core.TxId -> IO (Maybe Kernel.TxMeta) +getTxMeta conn txid = do + res <- Sqlite.runDBAction $ runBeamSqlite conn $ do + metas <- SQL.runSelectReturningList txMetaById + case metas of + [txMeta] -> do + inputs <- nonEmpty <$> SQL.runSelectReturningList getInputs + outputs <- nonEmpty <$> SQL.runSelectReturningList getOutputs + pure $ toTxMeta <$> Just txMeta <*> inputs <*> outputs + _ -> pure Nothing + case res of + Left e -> throwIO $ Kernel.StorageFailure (toException e) + Right r -> return r + where + txMetaById = SQL.lookup_ (_mDbMeta metaDB) (TxIdPrimKey txid) + getInputs = SQL.select $ do + coinDistr <- SQL.all_ (_mDbInputs metaDB) + SQL.guard_ ((_txCoinDistributionTxId . _getTxInput $ coinDistr) ==. (SQL.val_ $ TxIdPrimKey txid)) + pure coinDistr + getOutputs = SQL.select $ do + coinDistr <- SQL.all_ (_mDbOutputs metaDB) + SQL.guard_ ((_txCoinDistributionTxId . _getTxOutput $ coinDistr) ==. (SQL.val_ $ TxIdPrimKey txid)) + pure coinDistr + + +newtype OrdByCreationDate = OrdByCreationDate { _ordByCreationDate :: TxMeta } deriving (Show, Eq) + +instance Ord OrdByCreationDate where + compare a b = compare (_txMetaTableCreatedAt . _ordByCreationDate $ a) + (_txMetaTableCreatedAt . _ordByCreationDate $ b) + +getTxMetas :: Sqlite.Connection + -> Offset + -> Limit + -> Maybe Sorting + -> IO [Kernel.TxMeta] +getTxMetas conn (Offset offset) (Limit limit) mbSorting = do + res <- Sqlite.runDBAction $ runBeamSqlite conn $ do + metasWithInputs <- nonEmpty <$> SQL.runSelectReturningList paginatedInputs + metasWithOutputs <- nonEmpty <$> SQL.runSelectReturningList paginatedOutputs + return $ liftM2 (,) metasWithInputs metasWithOutputs + case res of + Left e -> throwIO $ Kernel.StorageFailure (toException e) + Right Nothing -> return [] + Right (Just (inputs, outputs)) -> + let mapWithInputs = transform inputs + mapWithOutputs = transform outputs + -- Do a final round of in-memory sorting after folding the + -- results. Note how this is unavoidable (without complicating + -- the implementation consistently) due to the fact we get + -- sorted data out of the DB but we need to post-process it to + -- construct a real 'Kernel.TxMeta'. + -- In practice, this is not as bad as it sounds: even though + -- the 'Limit' is basically unbounded as part of this function, + -- there exist a hard-limit as part of the wallet API, which would + -- ensure that the in-memory sorting will never be too expensive. + in return $ maybe identity (sortBy . toOrdering) mbSorting + $ Foldable.foldl' (toValidKernelTxMeta mapWithInputs) mempty (M.toList mapWithOutputs) + where + getTx selector = _txCoinDistributionTxId . selector + + metaQuery = case mbSorting of + Nothing -> SQL.all_ (_mDbMeta metaDB) + Just (Sorting SortByCreationAt dir) -> + SQL.orderBy_ (toBeamSortDirection dir . _txMetaTableCreatedAt) $ SQL.all_ (_mDbMeta metaDB) + Just (Sorting SortByAmount dir) -> + SQL.orderBy_ (toBeamSortDirection dir . _txMetaTableAmount) $ SQL.all_ (_mDbMeta metaDB) + + -- The following two queries are disjointed and both fetches, respectively, + -- a list of tuples of type @(TxMeta, TxInput)@ and @(TxMeta, TxOutput)@. + -- The rationale behind doing two separate queries is that there is no elegant + -- way to express a 3-table join without having 'Maybe's cropping up in the + -- Haskell result sets, and furthermore we would have to deal with duplicates. + -- Doing two separate queries is yes more I/O taxing, but spares us from doing + -- duplicate filtering on the Haskell side. + paginatedInputs = SQL.select $ do + meta <- SQL.limit_ limit (SQL.offset_ offset metaQuery) + inputs <- SQL.oneToMany_ (_mDbInputs metaDB) (getTx _getTxInput) meta + pure (meta, inputs) + + paginatedOutputs = SQL.select $ do + meta <- SQL.limit_ limit (SQL.offset_ offset metaQuery) + outputs <- SQL.oneToMany_ (_mDbOutputs metaDB) (getTx _getTxOutput) meta + pure (meta, outputs) + + -- | Groups the inputs or the outputs under the same 'TxMeta'. + transform :: NonEmpty (TxMeta, a) -> M.Map OrdByCreationDate (NonEmpty a) + transform = Foldable.foldl' updateFn M.empty + + updateFn :: M.Map OrdByCreationDate (NonEmpty a) + -> (TxMeta, a) + -> M.Map OrdByCreationDate (NonEmpty a) + updateFn acc (txMeta, new) = + M.insertWith (<>) (OrdByCreationDate txMeta) (new :| []) acc + + toValidKernelTxMeta :: M.Map OrdByCreationDate (NonEmpty TxInput) + -> [Kernel.TxMeta] + -> (OrdByCreationDate, NonEmpty TxOutput) + -> [Kernel.TxMeta] + toValidKernelTxMeta inputMap acc (OrdByCreationDate t, outputs) = + case M.lookup (OrdByCreationDate t) inputMap of + Nothing -> acc + Just inputs -> toTxMeta t inputs outputs : acc + +-- | Generates a Beam's AST fragment for use within a SQL query, to order +-- the results of a @SELECT@. +toBeamSortDirection :: SortDirection + -> SQL.QExpr (Sql92OrderingExpressionSyntax (Sql92SelectOrderingSyntax SqliteSelectSyntax)) s a + -> SQL.QOrd (Sql92SelectOrderingSyntax SqliteSelectSyntax) s a +toBeamSortDirection Ascending = SQL.asc_ +toBeamSortDirection Descending = SQL.desc_ + +-- | Generates a function suitable for 'sortBy' out of a 'Sorting'. +toOrdering :: Sorting -> (Kernel.TxMeta -> Kernel.TxMeta -> Ordering) +toOrdering (Sorting criteria dir) = + let comparator Ascending = compare + comparator Descending = flip compare + in case criteria of + SortByCreationAt -> + \t1 t2 -> (comparator dir) (t1 ^. Kernel.txMetaCreationAt) + (t2 ^. Kernel.txMetaCreationAt) + SortByAmount -> + \t1 t2 -> (comparator dir) (t1 ^. Kernel.txMetaAmount) + (t2 ^. Kernel.txMetaAmount) + diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/TxMeta.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/TxMeta.hs new file mode 100644 index 00000000000..11452ccda8d --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/TxMeta.hs @@ -0,0 +1,25 @@ +-- | Transaction metadata conform the wallet specification +module Cardano.Wallet.Kernel.DB.TxMeta ( + -- * Transaction metadata + module Types + + -- * Handy re-export to not leak our current choice of storage backend. + , openMetaDB + ) where + +import qualified Cardano.Wallet.Kernel.DB.Sqlite as ConcreteStorage +import Cardano.Wallet.Kernel.DB.TxMeta.Types as Types +import Universum + +-- Concrete instantiation of 'MetaDBHandle' + +openMetaDB :: FilePath -> IO MetaDBHandle +openMetaDB fp = do + conn <- ConcreteStorage.newConnection fp + return MetaDBHandle { + closeMetaDB = ConcreteStorage.closeMetaDB conn + , migrateMetaDB = ConcreteStorage.unsafeMigrateMetaDB conn + , getTxMeta = ConcreteStorage.getTxMeta conn + , putTxMeta = ConcreteStorage.putTxMeta conn + , getTxMetas = ConcreteStorage.getTxMetas conn + } diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/TxMeta/Types.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/TxMeta/Types.hs new file mode 100644 index 00000000000..b8014636183 --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/TxMeta/Types.hs @@ -0,0 +1,215 @@ +-- | Transaction metadata conform the wallet specification +module Cardano.Wallet.Kernel.DB.TxMeta.Types ( + -- * Transaction metadata + TxMeta(..) + -- ** Lenses + , txMetaId + , txMetaAmount + , txMetaInputs + , txMetaOutputs + , txMetaCreationAt + , txMetaIsLocal + , txMetaIsOutgoing + + -- * Transaction storage + , MetaDBHandle (..) + + -- * Filtering and sorting primitives + , Limit (..) + , Offset (..) + , Sorting (..) + , SortCriteria (..) + , SortDirection (..) + + -- * Domain-specific errors + , TxMetaStorageError (..) + , InvariantViolation (..) + + -- * Strict & lenient equalities + , exactlyEqualTo + , isomorphicTo + + -- * Internals useful for testing + , uniqueElements + ) where + +import Universum + +import Control.Lens.TH (makeLenses) +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Set as Set +import Data.Text.Buildable (build) +import Formatting (bprint, shown, (%)) +import qualified Formatting as F +import Pos.Crypto (shortHashF) +import Serokell.Util.Text (listJsonIndent, mapBuilder) +import Test.QuickCheck (Arbitrary (..), Gen, suchThat) + +import qualified Pos.Core as Core + +import Test.Pos.Core.Arbitrary () + +{------------------------------------------------------------------------------- + Transaction metadata +-------------------------------------------------------------------------------} + +-- | Transaction metadata + +-- +-- NOTE: This does /not/ live in the acid-state database (and consequently +-- does not need a 'SafeCopy' instance), because this will grow without bound. +data TxMeta = TxMeta { + -- | Transaction ID + _txMetaId :: Core.TxId + + -- | Total amount + -- + -- TODO: What does this mean? + , _txMetaAmount :: Core.Coin + + -- | Transaction inputs + , _txMetaInputs :: NonEmpty (Core.Address, Core.Coin) + + -- | Transaction outputs + , _txMetaOutputs :: NonEmpty (Core.Address, Core.Coin) + + -- | Transaction creation time + , _txMetaCreationAt :: Core.Timestamp + + -- | Is this a local transaction? + -- + -- A transaction is local when /all/ of its inputs and outputs are + -- to and from addresses owned by this wallet. + , _txMetaIsLocal :: Bool + + -- | Is this an outgoing transaction? + -- + -- A transaction is outgoing when it decreases the wallet's balance. + , _txMetaIsOutgoing :: Bool + } + +makeLenses ''TxMeta + +-- | Strict equality for two 'TxMeta': two 'TxMeta' are equal if they have +-- exactly the same data, and inputs & outputs needs to appear in exactly +-- the same order. +exactlyEqualTo :: TxMeta -> TxMeta -> Bool +exactlyEqualTo t1 t2 = + and [ t1 ^. txMetaId == t2 ^. txMetaId + , t1 ^. txMetaAmount == t2 ^. txMetaAmount + , t1 ^. txMetaInputs == t2 ^. txMetaInputs + , t1 ^. txMetaOutputs == t2 ^. txMetaOutputs + , t1 ^. txMetaCreationAt == t2 ^. txMetaCreationAt + , t1 ^. txMetaIsLocal == t2 ^. txMetaIsLocal + , t1 ^. txMetaIsOutgoing == t2 ^. txMetaIsOutgoing + ] + +-- | Lenient equality for two 'TxMeta': two 'TxMeta' are equal if they have +-- the same data, even if in different order. +-- NOTE: This check might be slightly expensive as it's logaritmic in the +-- number of inputs & outputs, as it requires sorting. +isomorphicTo :: TxMeta -> TxMeta -> Bool +isomorphicTo t1 t2 = + and [ t1 ^. txMetaId == t2 ^. txMetaId + , t1 ^. txMetaAmount == t2 ^. txMetaAmount + , NonEmpty.sort (t1 ^. txMetaInputs) == NonEmpty.sort (t2 ^. txMetaInputs) + , NonEmpty.sort (t1 ^. txMetaOutputs) == NonEmpty.sort (t2 ^. txMetaOutputs) + , t1 ^. txMetaCreationAt == t2 ^. txMetaCreationAt + , t1 ^. txMetaIsLocal == t2 ^. txMetaIsLocal + , t1 ^. txMetaIsOutgoing == t2 ^. txMetaIsOutgoing + ] + + +data InvariantViolation = + DuplicatedTransactionWithDifferentHash Core.TxId + -- ^ When attempting to insert a new 'MetaTx', the 'Core.TxId' + -- identifying this transaction was already present in the storage, + -- but when computing the 'Hash' of two 'TxMeta', these values were not + -- the same, meaning somebody is trying to re-insert the same 'Tx' in + -- the storage with different values (i.e. different inputs/outputs etc) + -- and this is effectively an invariant violation. + | DuplicatedInputIn Core.TxId + | DuplicatedOutputIn Core.TxId + | UndisputableLookupFailed Text Core.TxId + -- ^ When looking up a transaction which the storage claims to be + -- already present as a duplicate, such lookup failed. This is an + -- invariant violation because a 'TxMeta' storage is append-only, + -- therefore the data cannot possibly be evicted, and should be there + -- by definition (or we wouldn't get a duplicate collision in the + -- first place). + deriving Show + +-- | A domain-specific collection of things which might go wrong when +-- storing & retrieving 'TxMeta' from a persistent storage. +data TxMetaStorageError = + InvariantViolated InvariantViolation + -- ^ One of the invariant was violated. + | StorageFailure SomeException + -- ^ The underlying storage failed to fulfill the request. + deriving Show + +instance Exception TxMetaStorageError + +instance Buildable TxMetaStorageError where + build storageErr = bprint shown storageErr + +-- | Generates 'NonEmpty' collections which do not contain duplicates. +-- Limit the size to @size@ elements. +uniqueElements :: (Arbitrary a, Ord a) => Int -> Gen (NonEmpty a) +uniqueElements size = do + noDupes <- suchThat arbitrary (\s -> length s >= size) + let (e, es) = Set.deleteFindMax noDupes + return $ e :| List.take size (Set.toList es) + +instance Buildable TxMeta where + build txMeta = bprint (" id = "%shortHashF% + " amount = " % F.build % + " inputs = " % F.later mapBuilder % + " outputs = " % F.later mapBuilder % + " creationAt = " % F.build % + " isLocal = " % F.build % + " isOutgoing = " % F.build + ) (txMeta ^. txMetaId) + (txMeta ^. txMetaAmount) + (txMeta ^. txMetaInputs) + (txMeta ^. txMetaOutputs) + (txMeta ^. txMetaCreationAt) + (txMeta ^. txMetaIsLocal) + (txMeta ^. txMetaIsOutgoing) + +instance Buildable [TxMeta] where + build txMeta = bprint ("TxMetas: "%listJsonIndent 4) txMeta + + +-- | Basic filtering & sorting types. + +newtype Offset = Offset { getOffset :: Integer } + +newtype Limit = Limit { getLimit :: Integer } + +data SortDirection = + Ascending + | Descending + +data Sorting = Sorting { + sbCriteria :: SortCriteria + , sbDirection :: SortDirection + } + +data SortCriteria = + SortByCreationAt + -- ^ Sort by the creation time of this 'Kernel.TxMeta'. + | SortByAmount + -- ^ Sort the 'TxMeta' by the amount of money they hold. + +-- | An opaque handle to the underlying storage, which can be easily instantiated +-- to a more concrete implementation like a Sqlite database, or even a pure +-- K-V store. +data MetaDBHandle = MetaDBHandle { + closeMetaDB :: IO () + , migrateMetaDB :: IO () + , getTxMeta :: Core.TxId -> IO (Maybe TxMeta) + , putTxMeta :: TxMeta -> IO () + , getTxMetas :: Offset -> Limit -> Maybe Sorting -> IO [TxMeta] + } diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/Util/AcidState.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/Util/AcidState.hs new file mode 100644 index 00000000000..b39d4750cb3 --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/Util/AcidState.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE RankNTypes #-} + +-- | Some utilities for working with acid-state +module Cardano.Wallet.Kernel.DB.Util.AcidState ( + -- * Acid-state updates with support for errors + Update' + , runUpdate' + , runUpdateNoErrors + , mapUpdateErrors + -- * Zooming + , zoom + , zoomDef + , zoomCreate + , zoomAll + -- ** Convenience re-exports + , throwError + ) where + +import Universum + +import Control.Monad.Except +import Data.Acid (Update) + +import Cardano.Wallet.Kernel.DB.Util.IxSet (IxSet, Indexable) +import qualified Cardano.Wallet.Kernel.DB.Util.IxSet as IxSet + +{------------------------------------------------------------------------------- + Acid-state updates with support for errors (and zooming, see below) +-------------------------------------------------------------------------------} + +type Update' st e = StateT st (Except e) + +runUpdate' :: forall e st a. Update' st e a -> Update st (Either e a) +runUpdate' upd = do + st <- get + case upd' st of + Left e -> return (Left e) + Right (a, st') -> put st' >> return (Right a) + where + upd' :: st -> Either e (a, st) + upd' = runExcept . runStateT upd + +runUpdateNoErrors :: Update' st Void a -> Update st a +runUpdateNoErrors = fmap mustBeRight . runUpdate' + +mapUpdateErrors :: (e -> e') -> Update' st e a -> Update' st e' a +mapUpdateErrors f upd = StateT $ withExcept f . runStateT upd + +{------------------------------------------------------------------------------- + Zooming +-------------------------------------------------------------------------------} + +-- | Run an update on part of the state. +zoom :: Lens' st st' -> Update' st' e a -> Update' st e a +zoom l upd = StateT $ \large -> do + let update small' = large & l .~ small' + small = large ^. l + fmap update <$> runStateT upd small + +-- | Run an update on part of the state. +-- +-- If the specified part does not exist, run the default action. +zoomDef :: Update' st e a -- ^ Run when lens returns 'Nothing' + -> Lens' st (Maybe st') -- ^ Index the state + -> Update' st' e a -- ^ Action to run on the smaller state + -> Update' st e a +zoomDef def l upd = StateT $ \large -> do + let update small' = large & l .~ Just small' + mSmall = large ^. l + case mSmall of + Nothing -> runStateT def large + Just small -> fmap update <$> runStateT upd small + + +-- | Run an update on part of the state. +-- +-- If the specified part does not exist, use the default provided, +-- then only apply the update. +zoomCreate :: st' -- ^ Default state + -> Lens' st (Maybe st') -- ^ Index the state + -> Update' st' e a -- ^ Action to run on the smaller state + -> Update' st e a +zoomCreate def l upd = StateT $ \large -> do + let update small' = large & l .~ Just small' + small = fromMaybe def (large ^. l) + fmap update <$> runStateT upd small + +-- | Run an update on /all/ parts of the state. +-- +-- This is used for system initiated actions which should not fail (such as +-- 'applyBlock', which is why the action we run must be a pure function. +zoomAll :: Indexable st' + => Lens' st (IxSet st') -> (st' -> st') -> Update' st e () +zoomAll l upd = StateT $ \large -> do + let update ixset' = large & l .~ ixset' + ixset = large ^. l + return $ ((), update $ IxSet.omap upd ixset) + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +mustBeRight :: Either Void b -> b +mustBeRight (Left a) = absurd a +mustBeRight (Right b) = b diff --git a/wallet-new/src/Cardano/Wallet/Kernel/DB/Util/IxSet.hs b/wallet-new/src/Cardano/Wallet/Kernel/DB/Util/IxSet.hs new file mode 100644 index 00000000000..81f45d0cecc --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/DB/Util/IxSet.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RankNTypes #-} + +-- | Infrastructure for working with indexed sets +module Cardano.Wallet.Kernel.DB.Util.IxSet ( + -- * Primary keys + HasPrimKey(..) + , OrdByPrimKey -- opaque + -- * Wrapper around IxSet + , IndicesOf + , IxSet + , Indexable + -- * Building 'Indexable' instances + , ixFun + , ixList + -- * Queries + , getEQ + , member + , size + -- * Construction + , fromList + , omap + , otraverse + , emptyIxSet + ) where + +import Universum hiding (Foldable) + +import qualified Control.Lens as Lens +import Data.Coerce (coerce) +import Data.Foldable (Foldable (..)) +import qualified Data.IxSet.Typed as IxSet +import Data.SafeCopy (SafeCopy (..)) +import qualified Data.Set as Set +import qualified Data.Traversable + +{-# ANN module ("HLint: ignore Unnecessary hiding" :: Text) #-} + +{------------------------------------------------------------------------------- + Primary keys +-------------------------------------------------------------------------------} + +-- | Type equipped with a primary key +-- +-- The key assumption is that such types can be compared for equality and +-- sorted using their primary key only. +class Ord (PrimKey a) => HasPrimKey a where + type PrimKey a :: * + primKey :: a -> PrimKey a + +-- | Newtype wrapper around a type that uses the type's primary key for +-- equality and ordering comparisons. +-- +-- Unfortunately we cannot keep this type entirely internally, since we need +-- it in 'Indexable' instances. TODO: Is that fixable? +newtype OrdByPrimKey a = WrapOrdByPrimKey { unwrapOrdByPrimKey :: a } + +instance HasPrimKey a => Eq (OrdByPrimKey a) where + (==) = (==) `on` (primKey . unwrapOrdByPrimKey) + +instance HasPrimKey a => Ord (OrdByPrimKey a) where + compare = compare `on` (primKey . unwrapOrdByPrimKey) + +{------------------------------------------------------------------------------- + Wrap IxSet +-------------------------------------------------------------------------------} + +-- | Static set of indices per type +type family IndicesOf (a :: *) :: [*] + +-- | Wrapper around IxSet +-- +-- This is an 'IxSet' with a fixed set of indices ('IndicesOf') as well as +-- a primary key. +-- +-- NOTE: This module is intended as a replacement for an import of "Data.IxSet", +-- so we use the same names as "Data.IxSet" uses. +newtype IxSet a = WrapIxSet { + unwrapIxSet :: IxSet.IxSet (PrimKey a ': IndicesOf a) (OrdByPrimKey a) + } + +-- | Evidence that the specified indices are in fact available +type Indexable a = IxSet.Indexable (PrimKey a ': IndicesOf a) (OrdByPrimKey a) + +-- | Evidence that something is an index +type IsIndexOf ix a = IxSet.IsIndexOf ix (PrimKey a ': IndicesOf a) + +{------------------------------------------------------------------------------- + Safecopy +-------------------------------------------------------------------------------} + +instance SafeCopy a => SafeCopy (IxSet a) where + getCopy = error "getCopy for IxSet wrapper" + putCopy = error "putCopy for IxSet wrapper" + +{------------------------------------------------------------------------------- + Building 'Indexable' instances +-------------------------------------------------------------------------------} + +ixFun :: Ord ix => (a -> [ix]) -> IxSet.Ix ix (OrdByPrimKey a) +ixFun f = IxSet.ixFun (f . unwrapOrdByPrimKey) + +ixList :: ( HasPrimKey a + , IxSet.MkIxList ixs (PrimKey a : ixs) (OrdByPrimKey a) r + ) + => r +ixList = IxSet.ixList (ixFun ((:[]) . primKey)) + +{------------------------------------------------------------------------------- + Lens instances for the primary key +-------------------------------------------------------------------------------} + +type instance Lens.Index (IxSet a) = PrimKey a +type instance Lens.IxValue (IxSet a) = a + +instance (HasPrimKey a, Indexable a) => Lens.Ixed (IxSet a) where + ix pk f (WrapIxSet s) = + case IxSet.getOne (IxSet.getEQ pk s) of + Nothing -> pure $ WrapIxSet s + Just a -> upd <$> f (unwrapOrdByPrimKey a) + where + upd :: a -> IxSet a + upd a = WrapIxSet $ IxSet.updateIx pk (WrapOrdByPrimKey a) s + +instance (HasPrimKey a, Indexable a) => Lens.At (IxSet a) where + at pk f (WrapIxSet s) = + upd <$> f (unwrapOrdByPrimKey <$> IxSet.getOne (IxSet.getEQ pk s)) + where + upd :: Maybe a -> IxSet a + upd Nothing = WrapIxSet $ IxSet.deleteIx pk s + upd (Just a) = WrapIxSet $ IxSet.updateIx pk (WrapOrdByPrimKey a) s + +instance Foldable IxSet where + foldr f e = Data.Foldable.foldr f e . Data.Foldable.toList + +{------------------------------------------------------------------------------- + Queries +-------------------------------------------------------------------------------} + +getEQ :: (Indexable a, IsIndexOf ix a) => ix -> IxSet a -> IxSet a +getEQ ix = WrapIxSet . IxSet.getEQ ix . unwrapIxSet + +member :: (HasPrimKey a, Indexable a) => PrimKey a -> IxSet a -> Bool +member pk = isJust . view (Lens.at pk) + +size :: IxSet a -> Int +size = IxSet.size . unwrapIxSet + +{------------------------------------------------------------------------------- + Construction +-------------------------------------------------------------------------------} + +-- | Construct 'IxSet' from a list +fromList :: Indexable a => [a] -> IxSet a +fromList = WrapIxSet . IxSet.fromList . coerce + +-- | Monomorphic map over an 'IxSet' +-- +-- Since we assume that the primary keys never change, we do not need to +-- build the set itself. However, we do need to rebuild the indices. +omap :: forall a. Indexable a => (a -> a) -> IxSet a -> IxSet a +omap f = + WrapIxSet + . IxSet.fromSet + . Set.mapMonotonic (coerce f) + . IxSet.toSet + . unwrapIxSet + +-- | Monomorphic traversal over an 'IxSet' +-- +-- NOTE: This rebuilds the entire 'IxSet'. Potentially expensive. +otraverse :: (Applicative f, Indexable a) + => (a -> f a) -> IxSet a -> f (IxSet a) +otraverse f = fmap fromList . Data.Traversable.traverse f . Data.Foldable.toList + +emptyIxSet :: forall a. + Indexable a + => IxSet a +emptyIxSet = WrapIxSet IxSet.empty diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Diffusion.hs b/wallet-new/src/Cardano/Wallet/Kernel/Diffusion.hs index f98ea8a5889..77e6a4026e6 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/Diffusion.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/Diffusion.hs @@ -7,7 +7,7 @@ module Cardano.Wallet.Kernel.Diffusion ( import Universum import Pos.Core -import Pos.Diffusion.Types +import Pos.Infra.Diffusion.Types -- | Wallet diffusion layer -- diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Mode.hs b/wallet-new/src/Cardano/Wallet/Kernel/Mode.hs index 3ea4bf2dbd5..00c793a938e 100644 --- a/wallet-new/src/Cardano/Wallet/Kernel/Mode.hs +++ b/wallet-new/src/Cardano/Wallet/Kernel/Mode.hs @@ -9,36 +9,33 @@ module Cardano.Wallet.Kernel.Mode ) where import Control.Lens (makeLensesWith) -import qualified Control.Monad.Reader as Mtl -import System.Wlog import Universum import Mockable import Pos.Block.BListener import Pos.Block.Slog import Pos.Block.Types -import Pos.Communication import Pos.Context import Pos.Core +import Pos.Core.Chrono import Pos.DB import Pos.DB.Block import Pos.DB.DB -import Pos.KnownPeers +import Pos.Infra.Diffusion.Types (Diffusion, hoistDiffusion) +import Pos.Infra.Network.Types +import Pos.Infra.Reporting +import Pos.Infra.Shutdown +import Pos.Infra.Slotting +import Pos.Infra.Util.JsonLog.Events +import Pos.Infra.Util.TimeWarp (CanJsonLog (..)) import Pos.Launcher -import Pos.Network.Types -import Pos.Reporting -import Pos.Shutdown -import Pos.Slotting import Pos.Txp.Configuration import Pos.Txp.Logic import Pos.Txp.MemState import Pos.Util -import Pos.Util.Chrono -import Pos.Util.JsonLog -import Pos.Util.TimeWarp (CanJsonLog (..)) import Pos.WorkMode -import Cardano.Wallet.WalletLayer (PassiveWalletLayer) +import Cardano.Wallet.WalletLayer (PassiveWalletLayer (..), applyBlocks, rollbackBlocks) {------------------------------------------------------------------------------- The wallet context and monad @@ -72,9 +69,7 @@ walletApplyBlocks :: PassiveWalletLayer Production -> OldestFirst NE Blund -> WalletMode SomeBatchOp walletApplyBlocks _w _bs = do - -- TODO: Call into the wallet. This should be an asynchronous operation - -- because 'onApplyBlocks' gets called with the block lock held. - logError "walletApplyBlocks not implemented" + lift $ applyBlocks _w _bs -- We don't make any changes to the DB so we always return 'mempty'. return mempty @@ -87,9 +82,7 @@ walletRollbackBlocks :: PassiveWalletLayer Production -> NewestFirst NE Blund -> WalletMode SomeBatchOp walletRollbackBlocks _w _bs = do - -- TODO: Call into the wallet. This should be an asynchronous operation - -- because 'onRollbackBlocks' gets called with the block lock held. - logError "walletRollbackBlocks not implemented" + lift $ rollbackBlocks _w _bs -- We don't make any changes to the DB so we always return 'mempty'. return mempty @@ -103,30 +96,14 @@ instance MonadBListener WalletMode where -------------------------------------------------------------------------------} runWalletMode :: forall a. (HasConfigurations, HasCompileInfo) - => NodeResources () + => ProtocolMagic + -> NodeResources () -> PassiveWalletLayer Production - -> (ActionSpec WalletMode a, OutSpecs) + -> (Diffusion WalletMode -> WalletMode a) -> Production a -runWalletMode nr wallet (action, outSpecs) = - elimRealMode nr serverRealMode - where - NodeContext{..} = nrContext nr - - ekgNodeMetrics = - EkgNodeMetrics - (nrEkgStore nr) - (runProduction . elimRealMode nr . walletModeToRealMode wallet) - - serverWalletMode :: WalletMode a - serverWalletMode = runServer - (runProduction . elimRealMode nr . walletModeToRealMode wallet) - ncNodeParams - ekgNodeMetrics - outSpecs - action - - serverRealMode :: RealMode EmptyMempoolExt a - serverRealMode = walletModeToRealMode wallet serverWalletMode +runWalletMode pm nr wallet action = + Production $ runRealMode pm nr $ \diffusion -> + walletModeToRealMode wallet (action (hoistDiffusion realModeToWalletMode (walletModeToRealMode wallet) diffusion)) walletModeToRealMode :: forall a. PassiveWalletLayer Production -> WalletMode a -> RealMode () a walletModeToRealMode wallet ma = do @@ -137,6 +114,10 @@ walletModeToRealMode wallet ma = do } lift $ runReaderT ma env +realModeToWalletMode :: RealMode () a -> WalletMode a +realModeToWalletMode rm = ask >>= \ctx -> + lift (runReaderT rm (wcRealModeContext ctx)) + {------------------------------------------------------------------------------- 'WalletContext' instances @@ -153,8 +134,12 @@ instance HasSlottingVar WalletContext where instance HasPrimaryKey WalletContext where primaryKey = wcRealModeContext_L . primaryKey -instance HasReportingContext WalletContext where - reportingContext = wcRealModeContext_L . reportingContext +instance MonadReporting WalletMode where + report ct = ask >>= \ctx -> + liftIO (runReporter (rmcReporter (wcRealModeContext ctx)) ct) + +instance HasMisbehaviorMetrics WalletContext where + misbehaviorMetrics = wcRealModeContext_L . misbehaviorMetrics instance HasSlogGState WalletContext where slogGState = wcRealModeContext_L . slogGState @@ -208,16 +193,10 @@ instance ( HasConfiguration instance HasConfiguration => MonadGState WalletMode where gsAdoptedBVData = gsAdoptedBVDataDefault -instance HasConfiguration => HasAdoptedBlockVersionData WalletMode where - adoptedBVData = gsAdoptedBVData - -instance MonadFormatPeers WalletMode where - formatKnownPeers f = Mtl.withReaderT wcRealModeContext $ formatKnownPeers f - instance {-# OVERLAPPING #-} CanJsonLog WalletMode where jsonLog = jsonLogDefault -instance (HasConfiguration, HasTxpConfiguration, HasCompileInfo) +instance (HasConfiguration, HasTxpConfiguration) => MonadTxpLocal WalletMode where txpNormalize = txNormalize txpProcessTx = txProcessTransaction diff --git a/wallet-new/src/Cardano/Wallet/Kernel/PrefilterTx.hs b/wallet-new/src/Cardano/Wallet/Kernel/PrefilterTx.hs new file mode 100644 index 00000000000..f9ee32044ac --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/PrefilterTx.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +module Cardano.Wallet.Kernel.PrefilterTx + ( PrefilteredBlock(..) + , PrefilteredUtxo + , AddrWithId + , prefilterBlock + , prefilterUtxo + ) where + +import Universum + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text.Buildable +import Formatting (bprint, (%)) +import Serokell.Util (listJson, mapJson) + +import Data.SafeCopy (base, deriveSafeCopy) + +import Pos.Core (Address (..)) +import Pos.Core.Txp (TxIn (..), TxOut (..), TxOutAux (..)) +import Pos.Crypto (EncryptedSecretKey) +import Pos.Txp.Toil.Types (Utxo) +import Pos.Wallet.Web.Tracking.Decrypt (WalletDecrCredentials, eskToWalletDecrCredentials, + selectOwnAddresses) +import Pos.Wallet.Web.State.Storage (WAddressMeta (..)) + +import Cardano.Wallet.Kernel.Types(WalletId (..)) +import Cardano.Wallet.Kernel.DB.HdWallet +import Cardano.Wallet.Kernel.DB.InDb (fromDb) +import Cardano.Wallet.Kernel.DB.Resolved (ResolvedBlock, ResolvedInput, ResolvedTx, rbTxs, rtxInputs, + rtxOutputs) + +{------------------------------------------------------------------------------- + Pre-filter Tx Inputs and Outputs to those that belong to the given Wallet. ++-------------------------------------------------------------------------------} + +-- | Extended Utxo with each output paired with an HdAddressId, required for +-- discovering new Addresses during prefiltering +type UtxoWithAddrId = Map TxIn (TxOutAux,HdAddressId) + +-- | Address extended with an HdAddressId, which embeds information that places +-- the Address in the context of the Wallet/Accounts/Addresses hierarchy. +type AddrWithId = (HdAddressId,Address) + +-- | Utxo along with all (extended) addresses ocurring in the Utxo +type PrefilteredUtxo = (Utxo,[AddrWithId]) + +-- | Prefiltered block +-- +-- A prefiltered block is a block that contains only inputs and outputs from +-- the block that are relevant to the wallet. +data PrefilteredBlock = PrefilteredBlock { + -- | Relevant inputs + pfbInputs :: Set TxIn + + -- | Relevant outputs + , pfbOutputs :: Utxo + + -- | all output addresses present in the Utxo + , pfbAddrs :: [AddrWithId] + } + +deriveSafeCopy 1 'base ''PrefilteredBlock + +type WalletKey = (WalletId, WalletDecrCredentials) + +toPrefilteredUtxo :: UtxoWithAddrId -> PrefilteredUtxo +toPrefilteredUtxo utxoWithAddrs = (Map.fromList utxo', addrs') + where + toUtxo (txIn,(txOutAux,_)) = (txIn,txOutAux) + toAddrs (_ ,(txOutAux,addressId)) = (addressId, txOutAddress . toaOut $ txOutAux) + + utxoWithAddrs' = Map.toList utxoWithAddrs + utxo' = map toUtxo utxoWithAddrs' + addrs' = map toAddrs utxoWithAddrs' + +-- | Prefilter the transactions of a resolved block for the given wallet. +-- +-- Returns prefiltered blocks indexed by HdAccountId. +prefilterBlock :: WalletId + -> EncryptedSecretKey + -> ResolvedBlock + -> Map HdAccountId PrefilteredBlock +prefilterBlock wid esk block + = Map.fromList $ map mkPrefBlock (Set.toList accountIds) + where + mkPrefBlock accId' + = (accId', PrefilteredBlock inps' outs' addrs') + where + byAccountId accId'' def dict = fromMaybe def $ Map.lookup accId'' dict + + inps' = byAccountId accId' Set.empty inpAll + (outs', addrs') = toPrefilteredUtxo (byAccountId accId' Map.empty outAll) + + wdc :: WalletDecrCredentials + wdc = eskToWalletDecrCredentials esk + wKey = (wid, wdc) + + inps :: [Map HdAccountId (Set TxIn)] + outs :: [Map HdAccountId UtxoWithAddrId] + (inps, outs) = unzip $ map (prefilterTx wKey) (block ^. rbTxs) + + inpAll :: Map HdAccountId (Set TxIn) + outAll :: Map HdAccountId UtxoWithAddrId + inpAll = Map.unionsWith Set.union inps + outAll = Map.unionsWith Map.union outs + + accountIds = Map.keysSet inpAll `Set.union` Map.keysSet outAll + +-- | Prefilter the inputs and outputs of a resolved transaction +prefilterTx :: WalletKey + -> ResolvedTx + -> (Map HdAccountId (Set TxIn), Map HdAccountId UtxoWithAddrId) +prefilterTx wKey tx = ( + prefilterInputs wKey (toList (tx ^. rtxInputs . fromDb)) + , prefilterUtxo' wKey (tx ^. rtxOutputs . fromDb) + ) + +-- | Prefilter inputs of a transaction +prefilterInputs :: WalletKey + -> [(TxIn, ResolvedInput)] + -> Map HdAccountId (Set TxIn) +prefilterInputs wKey inps + = Map.fromListWith Set.union + $ map f + $ prefilterResolvedTxPairs wKey inps + where + f (addressId, (txIn, _txOut)) = (addressId ^. hdAddressIdParent, Set.singleton txIn) + +-- | Prefilter utxo using wallet key +prefilterUtxo' :: WalletKey -> Utxo -> Map HdAccountId UtxoWithAddrId +prefilterUtxo' wid utxo + = Map.fromListWith Map.union + $ map f + $ prefilterResolvedTxPairs wid (Map.toList utxo) + where + f (addressId, (txIn, txOut)) = (addressId ^. hdAddressIdParent, + Map.singleton txIn (txOut, addressId)) + +-- | Prefilter utxo using walletId and esk +prefilterUtxo :: HdRootId -> EncryptedSecretKey -> Utxo -> Map HdAccountId PrefilteredUtxo +prefilterUtxo rootId esk utxo = map toPrefilteredUtxo (prefilterUtxo' wKey utxo) + where + wKey = (WalletIdHdRnd rootId, eskToWalletDecrCredentials esk) + +-- | Prefilter resolved transaction pairs +prefilterResolvedTxPairs :: WalletKey + -> [(TxIn, TxOutAux)] + -> [(HdAddressId, (TxIn, TxOutAux))] +prefilterResolvedTxPairs wid xs = map f $ prefilter wid selectAddr xs + where + f ((txIn, txOut), addressId) = (addressId, (txIn, txOut)) + selectAddr = txOutAddress . toaOut . snd + +-- | Filter items for addresses that were derived from the given WalletKey. +-- Returns the matching HdAddressId, which embeds the parent HdAccountId +-- discovered for the matching item. +-- +-- TODO(@uroboros/ryan) `selectOwnAddresses` calls `decryptAddress`, which extracts +-- the AccountId from the Tx Attributes. This is not sufficient since it +-- doesn't actually _verify_ that the Tx belongs to the AccountId. +-- We need to add verification (see `deriveLvl2KeyPair`). +prefilter :: WalletKey + -> (a -> Address) -- ^ address getter + -> [a] -- ^ list to filter + -> [(a, HdAddressId)] -- ^ matching items +prefilter (wid,wdc) selectAddr rtxs + = map f $ selectOwnAddresses wdc selectAddr rtxs + where f (addr,meta) = (addr, toAddressId wid meta) + + toAddressId :: WalletId -> WAddressMeta -> HdAddressId + toAddressId (WalletIdHdRnd rootId) meta' = addressId + where + accountIx = HdAccountIx (_wamAccountIndex meta') + accountId = HdAccountId rootId accountIx + + addressIx = HdAddressIx (_wamAddressIndex meta') + addressId = HdAddressId accountId addressIx + +{------------------------------------------------------------------------------- + Pretty-printing +-------------------------------------------------------------------------------} + +instance Buildable PrefilteredBlock where + build PrefilteredBlock{..} = bprint + ( "PrefilteredBlock " + % "{ inputs: " % listJson + % ", outputs: " % mapJson + % "}" + ) + (Set.toList pfbInputs) + pfbOutputs diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Submission.hs b/wallet-new/src/Cardano/Wallet/Kernel/Submission.hs new file mode 100644 index 00000000000..19c6c93ceb0 --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/Submission.hs @@ -0,0 +1,583 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +-- We are exporting Lens' 'Getters', which has a redundant constraint on +-- \"contravariant\". +{-# OPTIONS_GHC -Wno-redundant-constraints #-} +module Cardano.Wallet.Kernel.Submission ( + -- * Public API + newWalletSubmission + , addPending + , remPending + , tick + , scheduledFor + , tickSlot + + -- * Types and lenses + , Evicted + , ResubmissionFunction + , Schedule (..) + , ScheduleEvents (..) + , ScheduleSend (..) + , NextEvent (..) + , seToSend + , seToConfirm + , ScheduleEvictIfNotConfirmed (..) + , SchedulingError (..) + , Slot (..) + , SubmissionCount (..) + , WalletSubmission (..) + , WalletSubmissionState (..) + , MaxRetries + , mapSlot + , wsResubmissionFunction + , getCurrentSlot + , localPendingSet + , getSchedule + + -- * Internal useful function + , addToSchedule + , prependEvents + + -- * Resubmitting things to the network + , defaultResubmitFunction + + -- * Retry policies + , constantRetry + , exponentialBackoff + ) where + +import Universum hiding (elems) + +import Control.Lens (Getter, to) +import Control.Lens.TH +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as M +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text.Buildable (build) +import Formatting (bprint, sformat, (%)) +import qualified Formatting as F +import Pos.Crypto.Hashing (WithHash (..)) +import Pos.Txp.Topsort (topsortTxs) +import qualified Prelude +import Serokell.Util.Text (listJsonIndent, mapBuilder, pairF) +import Test.QuickCheck + +import Cardano.Wallet.Kernel.DB.InDb (fromDb) +import Cardano.Wallet.Kernel.DB.Spec (Pending (..), emptyPending, pendingTransactions, + removePending, unionPending) +import qualified Pos.Core as Core + +-- | Wallet Submission Layer +-- +-- This module implements section 10 of the Wallet spec, +-- namely 'Transaction Submission'. +-- +data WalletSubmission m = WalletSubmission { + _wsResubmissionFunction :: ResubmissionFunction m + -- ^ What is called 'rho' in the spec, a 'ResubmissionFunction' capable + -- of retransmitting and rescheduling transactions. + , _wsState :: WalletSubmissionState + -- ^ The internal (private) state of this layer. We do not export lenses + -- to modify it, as that should be done only via this layer's public API. + -- What we export are some 'Getter's to some interesting bits of the state, + -- like the local 'Pending' set or the current slot. + } + +instance Buildable (WalletSubmission m) where + build ws = bprint ("WalletSubmission { rho = , state = " % F.build % " }") (_wsState ws) + +-- | The wallet internal state. Some useful invariant to check (possibly +-- via QuickCheck properties): +-- * Whatever we evict, it should not be in the pending set. +-- * Ff something is pending, it should also be in the schedule. +-- If this gets violated, some transaction might get stuck in the nursery forever. +-- * With a retry policy with MaxRetries == N there shouldn't be an entry in +-- the schedule with a SubmissionCount >= N +-- +data WalletSubmissionState = WalletSubmissionState { + _wssPendingSet :: Pending + , _wssSchedule :: Schedule + , _wssCurrentSlot :: !Slot + } + +instance Buildable WalletSubmissionState where + build wss = bprint ("{ pendingSet = " % F.build % + ", scheduler = " % F.build % + ", slot = " % F.build % + " } " + ) (_wssPendingSet wss) (_wssSchedule wss) (getSlot $ _wssCurrentSlot wss) + +-- | A 'Schedule' of events. +data Schedule = Schedule { + _ssScheduled :: IntMap ScheduleEvents + -- ^ Despite modelled as in 'IntMap' it has to be intended + -- as a mapping between 'Slot' and the list of transactions due that slot. + -- The loss of precision in the cast is not a problem, and can be handled + -- gracefully (crf. 'Slot' documentation). + -- We do not store transactions directly but a richer type called 'ScheduleEvents', + -- which partition the event space into items scheduled to be sent and + -- items which needs to be checked for confirmation. + , _ssUnsentNursery :: [ScheduleSend] + -- ^ A list of unsent transactions which couldn't be sent due to dependency + -- over transactions scheduled in some other slot. Practical example: Let + -- @A@ be a transaction scheduled for slot @N + 3@ and let @B@ be a transaction + -- @which depends on A@ scheduled for slot @N@. If we were to send @B@ we + -- would make a mistake, as it cannot be adopted before @A@ does. The solution + -- is to capture this event in 'tickSlot', and putting @B@ into the + -- nursery up until it can be sent. + -- @N.B@ It should be the wallet's responsibility (not the submission layer's) + -- to make sure that when it gives up on a transaction @A@, it also gives + -- up on all transactions @Bs@ that depend on @A@. + } + +-- | A type representing an item (in this context, a transaction) scheduled +-- to be regularly sent in a given slot (computed by a given 'RetryPolicy'). +data ScheduleSend = ScheduleSend Core.TxId Core.TxAux SubmissionCount deriving Eq + +-- | A type representing an item (in this context, a transaction @ID@) which +-- needs to be checked against the blockchain for inclusion. In other terms, +-- we need to confirm that indeed the transaction identified by the given 'TxId' has +-- been adopted, i.e. it's not in the local pending set anymore. +newtype ScheduleEvictIfNotConfirmed = ScheduleEvictIfNotConfirmed Core.TxId deriving Eq + +-- | All the events we can schedule for a given 'Slot', partitioned into +-- 'ScheduleSend' and 'ScheduleEvictIfNotConfirmed'. +data ScheduleEvents = ScheduleEvents { + _seToSend :: [ScheduleSend] + -- ^ A list of transactions which we need to send. + , _seToConfirm :: [ScheduleEvictIfNotConfirmed] + -- ^ A list of transactions which we need to check if they have been + -- confirmed (i.e. adopted) by the blockchain. + } + +instance Semigroup ScheduleEvents where + (ScheduleEvents s1 c1) <> (ScheduleEvents s2 c2) = + ScheduleEvents (s1 <> s2) (c1 <> c2) + +instance Buildable ScheduleSend where + build (ScheduleSend txId _ s) = bprint ("ScheduleSend " % pairF) (txId, s) + +instance Buildable [ScheduleSend] where + build s = bprint (listJsonIndent 4) s + +instance Buildable ScheduleEvictIfNotConfirmed where + build (ScheduleEvictIfNotConfirmed txId) = bprint ("ScheduleEvictIfNotConfirmed " % F.build) txId + +instance Buildable [ScheduleEvictIfNotConfirmed] where + build s = bprint (listJsonIndent 4) s + +instance Buildable ScheduleEvents where + build (ScheduleEvents ss sc) = + bprint ("ScheduleEvents { toCheck = " % F.build % + ", toConfirm = " % F.build % + "}") ss sc + +-- | Our \"opaque\" concept of 'Slot', which might or might not line up with +-- the 'Core.FlatSlotId' of the blockchain. +-- Modelled as an 'Word', but we cast it to an 'Int' to tap into the performance +-- of things like 'IntMap's, and enough to keep a ticker running for a good while. +-- Remember this is not the lifetime of the blockchain: it has more to do with +-- the lifetime of the wallet, as it will reset to 0 each time we restart it (the entire +-- 'WalletSubmission' is ephimeral and not persisted on disk). +-- +-- The acute reader might ask why we are casting to 'Int' and what is the +-- implication of a possible overflow: in practice, none, as in case we overflow +-- the 'Int' positive capacity we will effectively treat this as a \"circular buffer\", +-- storing the elements for slots @(maxBound :: Int) + 1@ in negative positions. +newtype Slot = Slot { getSlot :: Word } deriving (Eq, Ord, Show) + +instance Buildable Slot where + build (Slot s) = bprint ("Slot " % F.build) s + +-- | Casts this 'Slot' to an 'Int'. +castSlot :: Slot -> Int +castSlot (Slot w) = fromIntegral w + +-- | Adds two 'Slot's together. +addSlot :: Slot -> Slot -> Slot +addSlot (Slot w1) (Slot w2) = Slot (w1 + w2) + +-- | Apply a function from 'Word' to 'Word' to the given 'Slot'. +mapSlot :: (Word -> Word) -> Slot -> Slot +mapSlot f (Slot w) = Slot (f w) + +-- | How many times we have tried to submit the given transaction. +-- When this value reaches the 'maxRetries' value, the transcation will be +-- removed from the local pending set. +-- Note that when the @Core@ layer will introduce the concept of \"Time to +-- Live\" for transactions, we will be able to remove the 'maxRetries' value +-- and simply use the @TTL@ to judge whether or not we should retry. +newtype SubmissionCount = SubmissionCount { getSubmissionCount :: Int } deriving Eq + +instance Buildable SubmissionCount where + build (SubmissionCount s) = bprint F.build s + +-- | The 'Evicted' set represents the transactions which needs to be +-- pruned from the local (and wallet) 'Pending' set. +type Evicted = Set Core.TxId + +-- | A 'ResubmissionFunction' (@rho@ in the spec), parametrised by an +-- arbitrary @m@. +type ResubmissionFunction m = Slot + -- ^ The current slot. Handy to pass to this + -- function to reschedule transactions to some + -- other 'Slot' + N. + -> [ScheduleSend] + -- ^ Transactions which are due to be sent this 'Slot'. + -> Schedule + -- ^ The original 'Schedule'. + -> m Schedule + -- ^ The new 'Schedule'. + +makeLenses ''ScheduleEvents +makeLensesFor [("_ssScheduled", "ssScheduled")] ''Schedule +makeLenses ''WalletSubmission +makeLenses ''WalletSubmissionState + +instance Buildable Schedule where + build (Schedule ss nursery) = + let elems = IntMap.toList ss + in bprint ("Schedule { scheduled = " % (F.later mapBuilder) % + " , nursery = " % (listJsonIndent 4) + ) elems nursery + +instance Arbitrary SubmissionCount where + arbitrary = SubmissionCount <$> choose (0, 255) + +-- +-- +-- Public API, as written in the spec or mandated by real-world necessities. +-- +-- + +-- | Creates a new 'WalletSubmission' layer from a 'ResubmissionFunction'. +-- The created 'WalletSubmission' will start at 'Slot' 0 with an empty +-- 'Schedule'. +newWalletSubmission :: ResubmissionFunction m -> WalletSubmission m +newWalletSubmission resubmissionFunction = WalletSubmission { + _wsResubmissionFunction = resubmissionFunction + , _wsState = newEmptyState + } + where + newEmptyState :: WalletSubmissionState + newEmptyState = WalletSubmissionState { + _wssPendingSet = emptyPending + , _wssCurrentSlot = Slot 0 + , _wssSchedule = Schedule IntMap.empty mempty + } + +-- | A getter to the local pending set stored in this 'WalletSubmission'. +localPendingSet :: Getter (WalletSubmission m) Pending +localPendingSet = wsState . wssPendingSet + +-- | Gets the current 'Slot'. +getCurrentSlot :: Getter (WalletSubmission m) Slot +getCurrentSlot = wsState . wssCurrentSlot + +-- | Gets the current 'Schedule'. +getSchedule :: Getter (WalletSubmission m) Schedule +getSchedule = wsState . wssSchedule + +-- | Informs the 'WalletSubmission' layer about new 'Pending' transactions. +addPending :: Pending -> WalletSubmission m -> WalletSubmission m +addPending newPending ws = + let ws' = ws & over (wsState . wssPendingSet) (unionPending newPending) + in schedulePending newPending ws' + +-- | Removes the input set of 'Core.TxId' from the local 'WalletSubmission' pending set. +remPending :: Set Core.TxId -> WalletSubmission m -> WalletSubmission m +remPending ids ws = ws & over (wsState . wssPendingSet) (removePending ids) + +-- | A \"tick\" of the scheduler. +-- Returns the set transactions which needs to be droppped by the system as +-- they likely exceeded the submission count and they have no chance to be +-- adopted in a block. +-- @N.B.@ The returned 'WalletSubmission' comes with an already-pruned +-- local 'Pending' set, so it's not necessary to call 'remPending' afterwards. +tick :: Monad m + => (forall a. SchedulingError -> m a) + -- ^ A callback to handle any potential error arising internally. + -> WalletSubmission m + -- ^ The current 'WalletSubmission'. + -> m (Evicted, WalletSubmission m) + -- ^ The set of transactions upper layers will need to drop, together + -- with the new 'WalletSubmission'. +tick onError ws = do + let wss = ws ^. wsState + currentSlot = wss ^. wssCurrentSlot + rho = _wsResubmissionFunction ws + pendingSet = ws ^. wsState . wssPendingSet . pendingTransactions . fromDb + case tickSlot currentSlot ws of + Left e -> onError e + Right (toSend, toConfirm, newSchedule) -> do + schedule' <- rho currentSlot toSend newSchedule + let evicted = evictedThisSlot toConfirm pendingSet + let newState = ws & wsState . wssSchedule .~ schedule' + & wsState . wssCurrentSlot %~ mapSlot succ + return (evicted, remPending evicted newState) + where + evictedThisSlot :: [ScheduleEvictIfNotConfirmed] + -> M.Map Core.TxId Core.TxAux + -> Evicted + evictedThisSlot toConfirm p = + List.foldl' (checkConfirmed p) Set.empty toConfirm + + checkConfirmed :: M.Map Core.TxId Core.TxAux -> Evicted -> ScheduleEvictIfNotConfirmed -> Evicted + checkConfirmed pending acc (ScheduleEvictIfNotConfirmed txId) = + case M.lookup txId pending of + Just _ -> Set.insert txId acc + Nothing -> acc + +data SchedulingError = + LoopDetected Pending + -- ^ The transactions in this 'Pending' set forms a cycle and they + -- couldn't be top-sorted. + +instance Exception SchedulingError + +-- | Instance required for 'Exception'. Giving this one a proper 'Show' instance +-- (via deriving instance or otherwise) would imply a Show instance for 'Pending'. +-- However, when dealing with data types which includes sensible data (like in +-- this case, transactions) it's usually better to sacrify ghci-readiness in +-- favour of a bit more anonymity. +instance Show SchedulingError where + show (LoopDetected pending) = toString $ sformat ("LoopDetected " % F.build) pending + +-- +-- +-- Private API, used only internally or in tests. +-- +-- + +-- | Convenient \"list-destructuring-style\" data accessor which returns +-- the next events scheduled for the input 'Slot' as well as the \"tail\" of the +-- 'Schedule'. +-- It doesn't perform any sophisticated logic on the actual events which will +-- be eventually sent, nor tries to update the nursery. That is performed +-- specifically by the 'tickSlot' function. +scheduledFor :: Slot -> Schedule -> (ScheduleEvents, Schedule) +scheduledFor currentSlot s@(Schedule schedule nursery) = + case IntMap.lookup (castSlot currentSlot) schedule of + Nothing -> (ScheduleEvents mempty mempty, s) + Just candidates -> + (candidates, Schedule (IntMap.delete (castSlot currentSlot) schedule) nursery) + +-- | Returns a set of 'Pending' transactions which are due in the given +-- 'Slot', together with the ones which needs to be checked for eviction and +-- the new 'Schedule'. +-- This is the workhorse of the entire layer, as it's its responsibility +-- to look at the input 'Schedule' and determine which transactions are due to +-- be send this 'Slot' and which needs to go into the nursery. It does so by +-- topologically sorting all the potential candidates (i.e. transactions still +-- in the 'Pending' set) and then trying to establish which of them are \"independent\" +-- from future transactions, i.e they can be send in the given 'Slot' without being +-- rejected by neighbours node as they have a direct depedency on some other +-- transaction yet to be schedule/sent. +tickSlot :: Slot + -- ^ The current 'Slot'. + -> WalletSubmission m + -- ^ The 'WalletSubmissionState'. + -> Either SchedulingError ([ScheduleSend], [ScheduleEvictIfNotConfirmed], Schedule) + -- ^ An error if no schedule can be produced, or all the scheduled + -- transactions together with the new, updated 'Schedule'. +tickSlot currentSlot ws = + let (allEvents, schedule) = scheduledFor currentSlot (ws ^. wsState . wssSchedule) + scheduledCandidates = filterNotConfirmed (allEvents ^. seToSend <> nursery schedule) + localPending = ws ^. wsState . wssPendingSet + topSorted = topsortTxs toTx scheduledCandidates + in case topSorted of + Nothing -> Left (LoopDetected localPending) + Just sorted -> + let (send, cannotSend) = partitionSendable localPending sorted + newSchedule = schedule { _ssUnsentNursery = cannotSend } + in Right (send, allEvents ^. seToConfirm, newSchedule) + where + nursery :: Schedule -> [ScheduleSend] + nursery (Schedule _ n) = n + + toTx :: ScheduleSend -> WithHash Core.Tx + toTx (ScheduleSend txId txAux _) = WithHash (Core.taTx txAux) txId + + pendingTxs :: M.Map Core.TxId Core.TxAux + pendingTxs = ws ^. localPendingSet . pendingTransactions . fromDb + + -- Filter the transactions not appearing in the local pending set + -- anymore, as they have been adopted by the blockchain and we should + -- stop resubmitting them. + filterNotConfirmed :: [ScheduleSend] -> [ScheduleSend] + filterNotConfirmed = + filter (\(ScheduleSend txId _ _) -> isJust (M.lookup txId pendingTxs)) + +-- | Similar to 'Data.List.partition', but partitions the input 'ScheduleSend' +-- list into events which can be sent this 'Slot', and other which needs to +-- end up in the nursery as they are depedent on future transactions. +partitionSendable :: Pending + -- ^ The local 'Pending' set. + -> [ScheduleSend] + -- ^ A @topologically sorted@ list of transactions scheduled + -- for being sent. + -> ([ScheduleSend], [ScheduleSend]) +partitionSendable (view (pendingTransactions . fromDb) -> pending) xs = + go xs ((Set.empty, mempty), mempty) + where + go :: [ScheduleSend] + -> ((Set Core.TxId, [ScheduleSend]), [ScheduleSend]) + -> ([ScheduleSend], [ScheduleSend]) + go [] acc = bimap (reverse . snd) reverse acc + go (l : ls) ((accCanSendIds, accCanSend), accCannotSend) = + case dependsOnFutureTx accCanSendIds l of + True -> go ls ((accCanSendIds, accCanSend), l : accCannotSend) + False -> go ls ((Set.insert (getTxId l) accCanSendIds, l : accCanSend), accCannotSend) + + -- | A 'ScheduleEvent' is @not@ independent and should not be sent + -- over the wire if any of the inputs it consumes are mentioned in + -- the 'Pending' set. + dependsOnFutureTx :: Set Core.TxId -> ScheduleSend -> Bool + dependsOnFutureTx canSendIds (ScheduleSend _ txAux _) = + let inputs = List.foldl' updateFn mempty $ (Core.taTx txAux) ^. Core.txInputs . to NonEmpty.toList + in any (\tid -> isJust (M.lookup tid pending) && not (tid `Set.member` canSendIds)) inputs + + getTxId :: ScheduleSend -> Core.TxId + getTxId (ScheduleSend txId _ _) = txId + + updateFn :: [Core.TxId] -> Core.TxIn -> [Core.TxId] + updateFn !acc (Core.TxInUnknown _ _) = acc + updateFn !acc (Core.TxInUtxo txHash _) = txHash : acc + +-- | Extends the 'Schedule' with an extra set of [ScheduleSend] and +-- [ScheduleEvictIfNotConfirmed]. Useful to force dispatching in tests or simply as +-- an internal helper for the resubmission functions. +-- @N.B@ This is defined and exported as part of this module as it requires +-- internal knowledge of the internal state of the 'WalletSubmission'. +addToSchedule :: WalletSubmission m + -> Slot + -> [ScheduleSend] + -> [ScheduleEvictIfNotConfirmed] + -> WalletSubmission m +addToSchedule ws slot toSend toConfirm = + ws & over (wsState . wssSchedule . ssScheduled) prepend + where + prepend :: IntMap ScheduleEvents -> IntMap ScheduleEvents + prepend = prependEvents slot (ScheduleEvents toSend toConfirm) + +-- | Schedule the full list of pending transactions. +-- The transactions will be scheduled immediately in the next 'Slot'. +schedulePending :: Pending + -> WalletSubmission m + -> WalletSubmission m +schedulePending pending ws = + let currentSlot = ws ^. wsState . wssCurrentSlot + in addToSchedule ws (mapSlot succ currentSlot) toSend mempty + where + toEntry :: (Core.TxId, Core.TxAux) -> ScheduleSend + toEntry (txId, txAux) = ScheduleSend txId txAux (SubmissionCount 0) + + toSend :: [ScheduleSend] + toSend = + map toEntry (pending ^. pendingTransactions . fromDb . to M.toList) + +-- +-- +-- Ready-to-use 'ResubmissionFunction's. +-- +-- + +-- | A 'RetryPolicy' is simply a function which instruct the 'Schedule' when +-- to attempt resubmitting the given 'ScheduleEvent' item. It yields the +-- 'NextEvent' planned for a given 'Schedule'. +type RetryPolicy = SubmissionCount -> Slot -> NextEvent + +-- | The next event a resubmission function will have to deal with. +data NextEvent = SendIn !Slot + -- ^ Schedule the event to happen at this 'Slot'. + | CheckConfirmedIn !Slot + -- ^ Check the transaction \"has made it\" in the given + -- 'Slot', i.e. is not in the local 'Pending' set. If it is, + -- it needs to be evicted. + deriving (Show, Eq) + +-- Internal combinators used to limit the number of retries of a 'RetryPolicy' +-- to an upper bound of 'MaxRetries' attempts. +-- We don't want to throw an error in case we end up a case where +-- getSubmissionCount submissionCount > maxRetries, because different +-- ResubmissionFunctions can be configured with different 'RetryPolicy'es, and +-- those can have a more stringent limit on a policy applied at until a given +-- moment, so it's still possible to have elements in the schedule with a +-- 'SubmissionCount' larger than the 'MaxRetries', and calling the 'retryPolicy' +-- would cause an error. Having a lenient @otherwise@ case solves this. +limited :: MaxRetries -> (Slot -> Slot) -> RetryPolicy +limited maxRetries updateSlot submissionCount currentSlot + | getSubmissionCount submissionCount < maxRetries = SendIn (updateSlot currentSlot) + | otherwise = CheckConfirmedIn (updateSlot currentSlot) + +type Exponent = Double +type MaxRetries = Int + +-- +-- Stock retry policies inspired by the 'retry' package. +-- + +-- | Very simple policy which merely retries to resubmit the very next 'Slot', +-- up until 'MaxRetries' attempts. +constantRetry :: Int + -- ^ The number of 'Slot's to \"skip\" every time we retry + -> MaxRetries + -> RetryPolicy +constantRetry n maxRetries = limited maxRetries (addSlot (Slot $ max 0 $ fromIntegral n)) + +-- | An exponential backoff policy, parametric over a maximum number of +-- 'MaxRetries' and an 'Exponent' for the backoff. +exponentialBackoff :: MaxRetries -> Exponent -> RetryPolicy +exponentialBackoff maxRetries exponent submissionCount currentSlot = + let (delta :: Word) = fromIntegral ((floor (exponent ^^ (getSubmissionCount submissionCount))) :: Int) + in limited maxRetries (mapSlot ((+) delta)) submissionCount currentSlot + + +-- | A very customisable resubmitter which can be configured with different +-- retry policies. +defaultResubmitFunction :: forall m. Monad m + => ([Core.TxAux] -> m ()) + -> RetryPolicy + -> ResubmissionFunction m +defaultResubmitFunction send retryPolicy currentSlot scheduled oldSchedule = do + -- We do not care about the result of 'send', our job + -- is only to make sure we retrasmit the given transaction. + -- It will be the blockchain to tell us (via adjustment to + -- the local 'Pending' set) whether or not the transaction + -- has been adopted. Users can tweak any concurrency behaviour by + -- tucking such behaviour in the 'send' function itself. + send (map (\(ScheduleSend _ txAux _) -> txAux) scheduled) + pure (List.foldl' updateFn oldSchedule scheduled) + where + updateFn :: Schedule -> ScheduleSend -> Schedule + updateFn (Schedule s nursery) (ScheduleSend txId txAux submissionCount) = + let submissionCount' = incSubmissionCount submissionCount succ + (targetSlot, newEvent) = case retryPolicy submissionCount' currentSlot of + SendIn newSlot -> + (newSlot, ScheduleEvents [ScheduleSend txId txAux submissionCount'] mempty) + CheckConfirmedIn newSlot -> + (newSlot, ScheduleEvents mempty [ScheduleEvictIfNotConfirmed txId]) + in Schedule (prependEvents targetSlot newEvent s) nursery + +-- | Prepends all the input 'ScheduleEvents' (i.e. the 'ScheduleSend', and +-- 'ScheduleEvictIfNotConfirmed' contained within) at the beginning of each respective +-- collection. +prependEvents :: Slot + -> ScheduleEvents + -> IntMap ScheduleEvents + -> IntMap ScheduleEvents +prependEvents targetSlot events old = + IntMap.alter alterFn (castSlot targetSlot) old + where + alterFn :: Maybe ScheduleEvents -> Maybe ScheduleEvents + alterFn Nothing = Just events + alterFn (Just oldEvents) = Just (events <> oldEvents) + +-- | Increments the 'SubmissionCount' by the supplied function. +incSubmissionCount :: SubmissionCount -> (Int -> Int) -> SubmissionCount +incSubmissionCount (SubmissionCount count) f = SubmissionCount (f count) diff --git a/wallet-new/src/Cardano/Wallet/Kernel/Types.hs b/wallet-new/src/Cardano/Wallet/Kernel/Types.hs new file mode 100644 index 00000000000..882a75bf2eb --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/Kernel/Types.hs @@ -0,0 +1,176 @@ +module Cardano.Wallet.Kernel.Types ( + -- * Input resolution + -- ** Raw types + ResolvedTxInputs + , ResolvedBlockInputs + , RawResolvedTx(..) + , invRawResolvedTx + , mkRawResolvedTx + , RawResolvedBlock(..) + , invRawResolvedBlock + , mkRawResolvedBlock + -- ** Abstract Wallet/AccountIds + , WalletId (..) + , WalletESKs + , accountToWalletId + -- ** From raw to derived types + , fromRawResolvedTx + , fromRawResolvedBlock + , txUtxo + ) where + +import Universum + +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import Data.Word (Word32) + +import Pos.Core (MainBlock, Tx, TxAux (..), TxIn (..), TxOut, TxOutAux (..), gbBody, + mbTxs, mbWitnesses, txInputs, txOutputs) +import Pos.Crypto.Hashing (hash) +import Pos.Crypto (EncryptedSecretKey) +import Pos.Txp (Utxo) +import Serokell.Util (enumerate) + +import qualified Cardano.Wallet.Kernel.DB.HdWallet as HD +import Cardano.Wallet.Kernel.DB.InDb +import Cardano.Wallet.Kernel.DB.Resolved + +{------------------------------------------------------------------------------- + Abstract WalletId and AccountId +-------------------------------------------------------------------------------} + +-- | Wallet Id +-- +-- A Wallet Id can take several forms, the simplest of which is a hash +-- of the Wallet public key +data WalletId = + -- | HD wallet with randomly generated addresses + WalletIdHdRnd HD.HdRootId + + {- potential future kinds of wallet IDs: + -- | HD wallet with sequentially generated addresses + | WalletIdHdSeq ... + + -- | External wallet (all crypto done off-site, like hardware wallets) + | WalletIdExt ... + -} + + deriving (Eq, Ord) + +-- | Map of Wallet Master keys indexed by WalletId +-- +-- TODO: We may need to rethink having this in-memory +-- ESK should _not_ end up in the wallet's acid-state log +type WalletESKs = Map WalletId EncryptedSecretKey + +accountToWalletId :: HD.HdAccountId -> WalletId +accountToWalletId accountId + = WalletIdHdRnd $ accountId ^. HD.hdAccountIdParent + +{------------------------------------------------------------------------------- + Input resolution: raw types +-------------------------------------------------------------------------------} + +-- | All resolved inputs of a transaction +type ResolvedTxInputs = NonEmpty ResolvedInput + +-- | All resolved inputs of a block +type ResolvedBlockInputs = [ResolvedTxInputs] + +-- | Signed transaction along with its resolved inputs +-- +-- Constructor is marked as unsafe because the caller should make sure that +-- invariant 'invRawResolvedTx' holds. +data RawResolvedTx = UnsafeRawResolvedTx { + rawResolvedTx :: TxAux + , rawResolvedTxInputs :: ResolvedTxInputs + } + +-- | Invariant for 'RawResolvedTx' +-- +-- > number of inputs @==@ number of resolved inputs +invRawResolvedTx :: TxAux -> ResolvedTxInputs -> Bool +invRawResolvedTx txAux ins = length (taTx txAux ^. txInputs) == length ins + +-- | Smart constructor for 'RawResolvedTx' that checks the invariant +mkRawResolvedTx :: TxAux -> ResolvedTxInputs -> RawResolvedTx +mkRawResolvedTx txAux ins = + if invRawResolvedTx txAux ins + then UnsafeRawResolvedTx txAux ins + else error "mkRawResolvedTx: invariant violation" + +-- | Signed block along with its resolved inputs +-- +-- Constructor is marked unsafe because the caller should make sure that +-- invariant 'invRawResolvedBlock' holds. +data RawResolvedBlock = UnsafeRawResolvedBlock { + rawResolvedBlock :: MainBlock + , rawResolvedBlockInputs :: ResolvedBlockInputs + } + +-- | Invariant for 'RawResolvedBlock' +-- +-- > number of transactions @==@ number of resolved transaction inputs +-- +-- Moreover, 'invRawResolvedTx' should hold for each transaction. +invRawResolvedBlock :: MainBlock -> ResolvedBlockInputs -> Bool +invRawResolvedBlock block ins = + length txs == length ins + && all (uncurry invRawResolvedTx) (zip txs ins) + where + txs :: [TxAux] + txs = getBlockTxs block + +-- | Smart constructor for 'RawResolvedBlock' that checks the invariant +mkRawResolvedBlock :: MainBlock -> ResolvedBlockInputs -> RawResolvedBlock +mkRawResolvedBlock block ins = + if invRawResolvedBlock block ins + then UnsafeRawResolvedBlock block ins + else error "mkRawResolvedBlock: invariant violation" + +{------------------------------------------------------------------------------- + Construct derived types from raw types +-------------------------------------------------------------------------------} + +fromRawResolvedTx :: RawResolvedTx -> ResolvedTx +fromRawResolvedTx rtx = ResolvedTx { + _rtxInputs = InDb $ NE.zip inps (rawResolvedTxInputs rtx) + , _rtxOutputs = InDb $ txUtxo tx + } + where + tx :: Tx + tx = taTx (rawResolvedTx rtx) + + inps :: NonEmpty TxIn + inps = tx ^. txInputs + +txUtxo :: Tx -> Utxo +txUtxo tx = Map.fromList $ + map (toTxInOut tx) (outs tx) + +outs :: Tx -> [(Word32, TxOut)] +outs tx = enumerate $ toList $ tx ^. txOutputs + +toTxInOut :: Tx -> (Word32, TxOut) -> (TxIn, TxOutAux) +toTxInOut tx (idx, out) = (TxInUtxo (hash tx) idx, TxOutAux out) + +fromRawResolvedBlock :: RawResolvedBlock -> ResolvedBlock +fromRawResolvedBlock rb = ResolvedBlock { + _rbTxs = zipWith aux (getBlockTxs (rawResolvedBlock rb)) + (rawResolvedBlockInputs rb) + } + where + -- Justification for the use of the unsafe constructor: + -- The invariant for 'RawResolvedBlock' guarantees the invariant for the + -- individual transactions. + aux :: TxAux -> ResolvedTxInputs -> ResolvedTx + aux txAux ins = fromRawResolvedTx $ UnsafeRawResolvedTx txAux ins + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +getBlockTxs :: MainBlock -> [TxAux] +getBlockTxs b = zipWith TxAux (b ^. gbBody ^. mbTxs) + (b ^. gbBody ^. mbWitnesses) diff --git a/wallet-new/server/Cardano/Wallet/LegacyServer.hs b/wallet-new/src/Cardano/Wallet/LegacyServer.hs similarity index 57% rename from wallet-new/server/Cardano/Wallet/LegacyServer.hs rename to wallet-new/src/Cardano/Wallet/LegacyServer.hs index 7127e490010..41a1d1d0014 100644 --- a/wallet-new/server/Cardano/Wallet/LegacyServer.hs +++ b/wallet-new/src/Cardano/Wallet/LegacyServer.hs @@ -4,7 +4,7 @@ module Cardano.Wallet.LegacyServer where import Universum import Cardano.Wallet.API -import Cardano.Wallet.API.V1.Migration as Migration +import Cardano.Wallet.API.V1.Migration (HasCompileInfo, HasConfigurations) import qualified Cardano.Wallet.API.Development.LegacyHandlers as Dev import qualified Cardano.Wallet.API.V0.Handlers as V0 @@ -14,7 +14,8 @@ import qualified Cardano.Wallet.API.V1.Swagger as Swagger import Cardano.Wallet.Server.CLI (RunMode (..)) import Ntp.Client (NtpStatus) -import Pos.Diffusion.Types (Diffusion (..)) +import Pos.Crypto (ProtocolMagic) +import Pos.Infra.Diffusion.Types (Diffusion (..)) import Pos.Update.Configuration (curSoftwareVersion) import Pos.Util.CompileInfo (compileInfo) import Pos.Wallet.Web.Mode (WalletWebMode) @@ -23,27 +24,44 @@ import Servant -- | This function has the tricky task of plumbing different versions of the API, -- with potentially different monadic stacks into a uniform @Server@ we can use -- with Servant. -walletServer :: (Migration.HasConfigurations, Migration.HasCompileInfo) +walletServer :: (HasConfigurations, HasCompileInfo) => (forall a. WalletWebMode a -> Handler a) + -> ProtocolMagic -> Diffusion WalletWebMode -> TVar NtpStatus -> Server WalletAPI -walletServer natV0 diffusion ntpStatus = v0DocHandler :<|> v1DocHandler :<|> v0Handler :<|> v1Handler +walletServer natV0 pm diffusion ntpStatus = v0Handler :<|> v1Handler + where + v0Handler = V0.handlers natV0 pm diffusion ntpStatus + v1Handler = V1.handlers natV0 pm diffusion ntpStatus + + +walletDevServer + :: (HasConfigurations, HasCompileInfo) + => (forall a. WalletWebMode a -> Handler a) + -> ProtocolMagic + -> Diffusion WalletWebMode + -> TVar NtpStatus + -> RunMode + -> Server WalletDevAPI +walletDevServer natV0 pm diffusion ntpStatus runMode = devHandler :<|> walletHandler + where + devHandler = Dev.handlers natV0 runMode + walletHandler = walletServer natV0 pm diffusion ntpStatus + + +walletDocServer + :: (HasConfigurations, HasCompileInfo) + => Server WalletDocAPI +walletDocServer = v0DocHandler :<|> v1DocHandler where v0DocHandler = swaggerSchemaUIServer (Swagger.api (compileInfo, curSoftwareVersion) v0API Swagger.highLevelShortDescription) - v0Handler = V0.handlers natV0 diffusion ntpStatus v1DocHandler = swaggerSchemaUIServer (Swagger.api (compileInfo, curSoftwareVersion) v1API Swagger.highLevelDescription) - v1Handler = V1.handlers natV0 diffusion ntpStatus -walletDevServer :: (Migration.HasConfigurations, Migration.HasCompileInfo) - => (forall a. WalletWebMode a -> Handler a) - -> Diffusion WalletWebMode - -> TVar NtpStatus - -> RunMode - -> Server WalletDevAPI -walletDevServer natV0 diffusion ntpStatus runMode = devDocHandler :<|> devHandler :<|> walletHandler +walletDevDocServer + :: (HasConfigurations, HasCompileInfo) + => Server WalletDevDocAPI +walletDevDocServer = devDocHandler :<|> walletDocServer where devDocHandler = swaggerSchemaUIServer (Swagger.api (compileInfo, curSoftwareVersion) devAPI Swagger.highLevelShortDescription) - devHandler = Dev.handlers natV0 runMode - walletHandler = walletServer natV0 diffusion ntpStatus diff --git a/wallet-new/src/Cardano/Wallet/Orphans/Aeson.hs b/wallet-new/src/Cardano/Wallet/Orphans/Aeson.hs index 009639ffc54..82311178cf8 100644 --- a/wallet-new/src/Cardano/Wallet/Orphans/Aeson.hs +++ b/wallet-new/src/Cardano/Wallet/Orphans/Aeson.hs @@ -1,6 +1,7 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + {- | Aeson Orphans. |-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Cardano.Wallet.Orphans.Aeson where import Data.Aeson (ToJSON (..)) @@ -8,4 +9,3 @@ import Pos.Wallet.Web.ClientTypes.Types (CFilePath (..)) instance ToJSON CFilePath where toJSON (CFilePath c) = toJSON c - diff --git a/wallet-new/server/Cardano/Wallet/Server.hs b/wallet-new/src/Cardano/Wallet/Server.hs similarity index 71% rename from wallet-new/server/Cardano/Wallet/Server.hs rename to wallet-new/src/Cardano/Wallet/Server.hs index 9dbd305c06f..67669105863 100644 --- a/wallet-new/server/Cardano/Wallet/Server.hs +++ b/wallet-new/src/Cardano/Wallet/Server.hs @@ -1,6 +1,8 @@ module Cardano.Wallet.Server ( walletServer , walletDevServer + , walletDocServer + , walletDevDocServer ) where import Servant @@ -20,28 +22,33 @@ import Pos.Util.CompileInfo (HasCompileInfo, compileInfo) -- -- NOTE: Unlike the legacy server, the handlers will not run in a special -- Cardano monad because they just interfact with the Wallet object. -walletServer :: forall m. (HasCompileInfo, HasUpdateConfiguration) - => ActiveWalletLayer m +walletServer :: ActiveWalletLayer m -> Server WalletAPI -walletServer w = v0DocHandler :<|> v1DocHandler :<|> v0Handler :<|> v1Handler +walletServer w = v0Handler :<|> v1Handler where -- TODO: Not sure if we want to support the V0 API with the new wallet. -- For now I'm assuming we're not going to. -- -- TODO: It'd be nicer to not throw an exception here, but servant doesn't -- make this very easy at the moment. - v0DocHandler = error "V0 API no longer supported" - v0Handler = v0DocHandler - v1DocHandler = swaggerSchemaUIServer (Swagger.api (compileInfo, curSoftwareVersion) v1API Swagger.highLevelDescription) + v0Handler = error "V0 API no longer supported" v1Handler = V1.handlers w - -walletDevServer :: forall m. (HasCompileInfo, HasUpdateConfiguration) - => ActiveWalletLayer m - -> RunMode - -> Server WalletDevAPI -walletDevServer w runMode = devDocHandler :<|> devHandler :<|> walletHandler +walletDevServer :: ActiveWalletLayer m + -> RunMode + -> Server WalletDevAPI +walletDevServer w runMode = devHandler :<|> walletHandler where - devDocHandler = swaggerSchemaUIServer (Swagger.api (compileInfo, curSoftwareVersion) devAPI Swagger.highLevelShortDescription) devHandler = Dev.handlers runMode walletHandler = walletServer w + +walletDocServer :: (HasCompileInfo, HasUpdateConfiguration) => Server WalletDocAPI +walletDocServer = v0DocHandler :<|> v1DocHandler + where + v0DocHandler = error "V0 API no longer supported" + v1DocHandler = swaggerSchemaUIServer (Swagger.api (compileInfo, curSoftwareVersion) v1API Swagger.highLevelDescription) + +walletDevDocServer :: (HasCompileInfo, HasUpdateConfiguration) => Server WalletDevDocAPI +walletDevDocServer = devDocHandler :<|> walletDocServer + where + devDocHandler = swaggerSchemaUIServer (Swagger.api (compileInfo, curSoftwareVersion) devAPI Swagger.highLevelShortDescription) diff --git a/wallet-new/server/Cardano/Wallet/Server/CLI.hs b/wallet-new/src/Cardano/Wallet/Server/CLI.hs similarity index 91% rename from wallet-new/server/Cardano/Wallet/Server/CLI.hs rename to wallet-new/src/Cardano/Wallet/Server/CLI.hs index baf9c40b6cd..337aec0ad42 100644 --- a/wallet-new/server/Cardano/Wallet/Server/CLI.hs +++ b/wallet-new/src/Cardano/Wallet/Server/CLI.hs @@ -13,8 +13,8 @@ import Options.Applicative (Parser, auto, execParser, footerDoc, fullD import Paths_cardano_sl (version) import Pos.Client.CLI (CommonNodeArgs (..)) import qualified Pos.Client.CLI as CLI +import Pos.Infra.Util.TimeWarp (NetworkAddress, localhost) import Pos.Util.CompileInfo (CompileTimeInfo (..), HasCompileInfo, compileInfo) -import Pos.Util.TimeWarp (NetworkAddress, localhost) import Pos.Web (TlsParams (..)) @@ -24,12 +24,13 @@ import Pos.Web (TlsParams (..)) data WalletStartupOptions = WalletStartupOptions { wsoNodeArgs :: !CommonNodeArgs , wsoWalletBackendParams :: !ChooseWalletBackend - } + } deriving Show -- | TODO: Once we get rid of the legacy wallet, remove this. data ChooseWalletBackend = WalletLegacy !WalletBackendParams | WalletNew !NewWalletBackendParams + deriving Show -- | DB-specific options. data WalletDBOptions = WalletDBOptions { @@ -53,6 +54,8 @@ data WalletBackendParams = WalletBackendParams -- ^ The TLS parameters. , walletAddress :: !NetworkAddress -- ^ The wallet address. + , walletDocAddress :: !NetworkAddress + -- ^ The wallet documentation address. , walletRunMode :: !RunMode -- ^ The mode this node is running in. , walletDbOptions :: !WalletDBOptions @@ -126,6 +129,7 @@ walletBackendParamsParser = WalletBackendParams <$> enableMonitoringApiParser <*> monitoringApiPortParser <*> tlsParamsParser <*> addressParser + <*> docAddressParser <*> runModeParser <*> dbOptionsParser where @@ -140,6 +144,9 @@ walletBackendParamsParser = WalletBackendParams <$> enableMonitoringApiParser addressParser :: Parser NetworkAddress addressParser = CLI.walletAddressOption $ Just (localhost, 8090) + docAddressParser :: Parser NetworkAddress + docAddressParser = CLI.docAddressOption $ Just (localhost, 8091) + runModeParser :: Parser RunMode runModeParser = (\debugMode -> if debugMode then DebugMode else ProductionMode) <$> switch (long "wallet-debug" <> @@ -151,9 +158,10 @@ tlsParamsParser :: Parser (Maybe TlsParams) tlsParamsParser = constructTlsParams <$> certPathParser <*> keyPathParser <*> caPathParser + <*> (not <$> noClientAuthParser) <*> disabledParser where - constructTlsParams tpCertPath tpKeyPath tpCaPath disabled = + constructTlsParams tpCertPath tpKeyPath tpCaPath tpClientAuth disabled = guard (not disabled) $> TlsParams{..} certPathParser :: Parser FilePath @@ -180,12 +188,20 @@ tlsParamsParser = constructTlsParams <$> certPathParser <> value "scripts/tls-files/ca.crt" ) + noClientAuthParser :: Parser Bool + noClientAuthParser = switch $ + long "no-client-auth" <> + help "Disable TLS client verification. If turned on, \ + \no client certificate is required to talk to \ + \the API." + disabledParser :: Parser Bool disabledParser = switch $ long "no-tls" <> help "Disable tls. If set, 'tlscert', 'tlskey' \ \and 'tlsca' options are ignored" + -- | The parser for the @WalletDBOptions@. dbOptionsParser :: Parser WalletDBOptions dbOptionsParser = WalletDBOptions <$> dbPathParser diff --git a/wallet-new/server/Cardano/Wallet/Server/Plugins.hs b/wallet-new/src/Cardano/Wallet/Server/Plugins.hs similarity index 67% rename from wallet-new/server/Cardano/Wallet/Server/Plugins.hs rename to wallet-new/src/Cardano/Wallet/Server/Plugins.hs index 4da4d33dfd1..7ce3f00f9d6 100644 --- a/wallet-new/server/Cardano/Wallet/Server/Plugins.hs +++ b/wallet-new/src/Cardano/Wallet/Server/Plugins.hs @@ -2,7 +2,9 @@ A @Plugin@ is essentially a set of actions which will be run in a particular monad, at some point in time. -} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} + module Cardano.Wallet.Server.Plugins ( Plugin , syncWalletWorker @@ -10,6 +12,7 @@ module Cardano.Wallet.Server.Plugins ( , conversation , legacyWalletBackend , walletBackend + , walletDocumentation , resubmitterPlugin , notifierPlugin ) where @@ -39,74 +42,101 @@ import Network.Wai.Handler.Warp (defaultSettings, setOnExceptionRespon import Network.Wai.Middleware.Cors (cors, corsMethods, corsRequestHeaders, simpleCorsResourcePolicy, simpleMethods) import Ntp.Client (NtpStatus) -import Pos.Diffusion.Types (Diffusion (..)) +import Pos.Infra.Diffusion.Types (Diffusion (..)) import Pos.Wallet.Web (cleanupAcidStatePeriodically) import Pos.Wallet.Web.Pending.Worker (startPendingTxsResubmitter) import qualified Pos.Wallet.Web.Server.Runner as V0 import Pos.Wallet.Web.Sockets (getWalletWebSockets, upgradeApplicationWS) import qualified Servant -import System.Wlog (logInfo, modifyLoggerName) +import System.Wlog (logInfo, modifyLoggerName, usingLoggerName) -import Pos.Communication (OutSpecs) -import Pos.Communication.Util (ActionSpec (..)) import Pos.Context (HasNodeContext) +import Pos.Crypto (ProtocolMagic) import Pos.Util (lensOf) +import Cardano.NodeIPC (startNodeJsIPC) import Pos.Configuration (walletProductionApi, walletTxCreationDisabled) +import Pos.Infra.Shutdown.Class (HasShutdownContext (shutdownContext)) import Pos.Launcher.Configuration (HasConfigurations) import Pos.Util.CompileInfo (HasCompileInfo) import Pos.Wallet.Web.Mode (WalletWebMode) -import Pos.Wallet.Web.Server.Launcher (walletServeImpl, walletServerOuts) +import Pos.Wallet.Web.Server.Launcher (walletDocumentationImpl, walletServeImpl) import Pos.Wallet.Web.State (askWalletDB) import Pos.Wallet.Web.Tracking.Sync (processSyncRequest) import Pos.Wallet.Web.Tracking.Types (SyncQueue) import Pos.Web (serveWeb) -import Pos.Worker.Types (WorkerSpec, worker) import Pos.WorkMode (WorkMode) -- A @Plugin@ running in the monad @m@. -type Plugin m = ([WorkerSpec m], OutSpecs) +type Plugin m = [Diffusion m -> m ()] -- | A @Plugin@ to periodically compact & snapshot the acid-state database. -acidCleanupWorker :: HasConfigurations - => WalletBackendParams +acidCleanupWorker :: WalletBackendParams -> Plugin WalletWebMode -acidCleanupWorker WalletBackendParams{..} = - first one $ worker mempty $ const $ +acidCleanupWorker WalletBackendParams{..} = pure $ const $ modifyLoggerName (const "acidcleanup") $ askWalletDB >>= \db -> cleanupAcidStatePeriodically db (walletAcidInterval walletDbOptions) -- | The @Plugin@ which defines part of the conversation protocol for this node. -conversation :: (HasConfigurations, HasCompileInfo) => WalletBackendParams -> Plugin WalletWebMode -conversation wArgs = (, mempty) $ map (ActionSpec . const) (pluginsMonitoringApi wArgs) +conversation :: HasConfigurations => WalletBackendParams -> Plugin WalletWebMode +conversation wArgs = map const (pluginsMonitoringApi wArgs) where - pluginsMonitoringApi :: (WorkMode ctx m , HasNodeContext ctx , HasConfigurations, HasCompileInfo) + pluginsMonitoringApi :: (WorkMode ctx m , HasNodeContext ctx) => WalletBackendParams -> [m ()] pluginsMonitoringApi WalletBackendParams {..} | enableMonitoringApi = [serveWeb monitoringApiPort walletTLSParams] | otherwise = [] +walletDocumentation + :: (HasConfigurations, HasCompileInfo) + => WalletBackendParams + -> Plugin WalletWebMode +walletDocumentation WalletBackendParams {..} = pure $ \_ -> + walletDocumentationImpl + application + walletDocAddress + tls + (Just defaultSettings) + Nothing + where + application :: WalletWebMode Application + application = do + let app = + if isDebugMode walletRunMode then + Servant.serve API.walletDevDocAPI LegacyServer.walletDevDocServer + else + Servant.serve API.walletDocAPI LegacyServer.walletDocServer + return $ withMiddleware walletRunMode app + + tls = + if isDebugMode walletRunMode then Nothing else walletTLSParams + -- | A @Plugin@ to start the wallet backend API. legacyWalletBackend :: (HasConfigurations, HasCompileInfo) - => WalletBackendParams + => ProtocolMagic + -> WalletBackendParams -> TVar NtpStatus -> Plugin WalletWebMode -legacyWalletBackend WalletBackendParams {..} ntpStatus = - first one $ worker walletServerOuts $ \diffusion -> do - modifyLoggerName (const "legacyServantBackend") $ do - logInfo $ sformat ("Production mode for API: "%build) - walletProductionApi - logInfo $ sformat ("Transaction submission disabled: "%build) - walletTxCreationDisabled - - walletServeImpl - (getApplication diffusion) - walletAddress - -- Disable TLS if in debug mode. - (if isDebugMode walletRunMode then Nothing else walletTLSParams) - (Just $ setOnExceptionResponse exceptionHandler defaultSettings) +legacyWalletBackend pm WalletBackendParams {..} ntpStatus = pure $ \diffusion -> do + modifyLoggerName (const "legacyServantBackend") $ do + logInfo $ sformat ("Production mode for API: "%build) + walletProductionApi + logInfo $ sformat ("Transaction submission disabled: "%build) + walletTxCreationDisabled + + ctx <- view shutdownContext + let + portCallback :: Word16 -> IO () + portCallback port = usingLoggerName "NodeIPC" $ flip runReaderT ctx $ startNodeJsIPC port + walletServeImpl + (getApplication diffusion) + walletAddress + -- Disable TLS if in debug mode. + (if isDebugMode walletRunMode then Nothing else walletTLSParams) + (Just $ setOnExceptionResponse exceptionHandler defaultSettings) + (Just portCallback) where -- Gets the Wai `Application` to run. getApplication :: Diffusion WalletWebMode -> WalletWebMode Application @@ -116,9 +146,19 @@ legacyWalletBackend WalletBackendParams {..} ntpStatus = ctx <- V0.walletWebModeContext let app = upgradeApplicationWS wsConn $ if isDebugMode walletRunMode then - Servant.serve API.walletDevAPI $ LegacyServer.walletDevServer (V0.convertHandler ctx) diffusion ntpStatus walletRunMode + Servant.serve API.walletDevAPI $ LegacyServer.walletDevServer + (V0.convertHandler ctx) + pm + diffusion + ntpStatus + walletRunMode else - Servant.serve API.walletAPI $ LegacyServer.walletServer (V0.convertHandler ctx) diffusion ntpStatus + Servant.serve API.walletAPI $ LegacyServer.walletServer + (V0.convertHandler ctx) + pm + diffusion + ntpStatus + return $ withMiddleware walletRunMode app exceptionHandler :: SomeException -> Response @@ -158,21 +198,24 @@ legacyWalletBackend WalletBackendParams {..} ntpStatus = -- | A 'Plugin' to start the wallet REST server -- -- TODO: no web socket support in the new wallet for now -walletBackend :: (HasConfigurations, HasCompileInfo) - => NewWalletBackendParams +walletBackend :: NewWalletBackendParams -> PassiveWalletLayer Production -> Plugin Kernel.WalletMode -walletBackend (NewWalletBackendParams WalletBackendParams{..}) passive = - first one $ worker walletServerOuts $ \diffusion -> do - env <- ask - let diffusion' = Kernel.fromDiffusion (lower env) diffusion - bracketKernelActiveWallet passive diffusion' $ \active -> - walletServeImpl - (getApplication active) - walletAddress - -- Disable TLS if in debug modeit . - (if isDebugMode walletRunMode then Nothing else walletTLSParams) - Nothing +walletBackend (NewWalletBackendParams WalletBackendParams{..}) passive = pure $ \diffusion -> do + env <- ask + let diffusion' = Kernel.fromDiffusion (lower env) diffusion + bracketKernelActiveWallet passive diffusion' $ \active -> do + ctx <- view shutdownContext + let + portCallback :: Word16 -> IO () + portCallback port = usingLoggerName "NodeIPC" $ flip runReaderT ctx $ startNodeJsIPC port + walletServeImpl + (getApplication active) + walletAddress + -- Disable TLS if in debug modeit . + (if isDebugMode walletRunMode then Nothing else walletTLSParams) + Nothing + (Just portCallback) where getApplication :: ActiveWalletLayer Production -> Kernel.WalletMode Application getApplication active = do @@ -187,18 +230,17 @@ walletBackend (NewWalletBackendParams WalletBackendParams{..}) passive = lower env = runProduction . (`runReaderT` env) -- | A @Plugin@ to resubmit pending transactions. -resubmitterPlugin :: (HasConfigurations, HasCompileInfo) => Plugin WalletWebMode -resubmitterPlugin = ([ActionSpec $ \diffusion -> askWalletDB >>= \db -> - startPendingTxsResubmitter db (sendTx diffusion)], mempty) +resubmitterPlugin :: HasConfigurations => ProtocolMagic -> Plugin WalletWebMode +resubmitterPlugin pm = [\diffusion -> askWalletDB >>= \db -> + startPendingTxsResubmitter pm db (sendTx diffusion)] -- | A @Plugin@ to notify frontend via websockets. -notifierPlugin :: (HasConfigurations, HasCompileInfo) => Plugin WalletWebMode -notifierPlugin = ([ActionSpec $ const V0.notifierPlugin], mempty) +notifierPlugin :: HasConfigurations => Plugin WalletWebMode +notifierPlugin = [const V0.notifierPlugin] -- | The @Plugin@ responsible for the restoration & syncing of a wallet. syncWalletWorker :: HasConfigurations => Plugin WalletWebMode -syncWalletWorker = - first one $ worker mempty $ const $ +syncWalletWorker = pure $ const $ modifyLoggerName (const "syncWalletWorker") $ (view (lensOf @SyncQueue) >>= processSyncRequest) @@ -217,4 +259,3 @@ corsMiddleware = cors (const $ Just policy) { corsRequestHeaders = ["Content-Type"] , corsMethods = "PUT" : simpleMethods } - diff --git a/wallet-new/src/Cardano/Wallet/Util.hs b/wallet-new/src/Cardano/Wallet/Util.hs index fd86563b81c..6fb54107dc7 100644 --- a/wallet-new/src/Cardano/Wallet/Util.hs +++ b/wallet-new/src/Cardano/Wallet/Util.hs @@ -1,4 +1,3 @@ - -- | Module for small utility functions. module Cardano.Wallet.Util ( -- * String manipulation diff --git a/wallet-new/src/Cardano/Wallet/WalletLayer.hs b/wallet-new/src/Cardano/Wallet/WalletLayer.hs index e2c44109fbb..b7d235f7c9d 100644 --- a/wallet-new/src/Cardano/Wallet/WalletLayer.hs +++ b/wallet-new/src/Cardano/Wallet/WalletLayer.hs @@ -22,22 +22,20 @@ import Cardano.Wallet.Kernel.Diffusion (WalletDiffusion (..)) import qualified Cardano.Wallet.WalletLayer.Kernel as Kernel import qualified Cardano.Wallet.WalletLayer.Legacy as Legacy import qualified Cardano.Wallet.WalletLayer.QuickCheck as QuickCheck -import Cardano.Wallet.WalletLayer.Types (ActiveWalletLayer (..), PassiveWalletLayer (..)) - -import Pos.Wallet.Web.State.State (WalletDbReader) +import Cardano.Wallet.WalletLayer.Types (ActiveWalletLayer (..), PassiveWalletLayer (..), + applyBlocks, rollbackBlocks) ------------------------------------------------------------ -- Kernel ------------------------------------------------------------ - bracketKernelPassiveWallet - :: forall m n a. (MonadMask n, Monad m) + :: forall m n a. (MonadIO m, MonadIO n, MonadMask n) => (Severity -> Text -> IO ()) -> (PassiveWalletLayer m -> n a) -> n a bracketKernelPassiveWallet = Kernel.bracketPassiveWallet bracketKernelActiveWallet - :: forall m n a. (MonadMask n, Monad m) + :: forall m n a. (MonadIO n, MonadMask n) => PassiveWalletLayer m -> WalletDiffusion -> (ActiveWalletLayer m -> n a) -> n a bracketKernelActiveWallet = Kernel.bracketActiveWallet @@ -46,12 +44,12 @@ bracketKernelActiveWallet = Kernel.bracketActiveWallet ------------------------------------------------------------ bracketLegacyPassiveWallet - :: forall ctx m n a. (MonadMask n, WalletDbReader ctx m, MonadIO m, MonadThrow m) + :: forall ctx m n a. (MonadMask n, Legacy.MonadLegacyWallet ctx m) => (PassiveWalletLayer m -> n a) -> n a bracketLegacyPassiveWallet = Legacy.bracketPassiveWallet bracketLegacyActiveWallet - :: forall ctx m n a. (MonadMask n, WalletDbReader ctx m, MonadIO m, MonadThrow m) + :: forall m n a. (MonadMask n) => PassiveWalletLayer m -> WalletDiffusion -> (ActiveWalletLayer m -> n a) -> n a bracketLegacyActiveWallet = Legacy.bracketActiveWallet @@ -65,7 +63,6 @@ bracketQuickCheckPassiveWallet bracketQuickCheckPassiveWallet = QuickCheck.bracketPassiveWallet bracketQuickCheckActiveWallet - :: forall m n a. (MonadMask n, MonadIO m) + :: forall m n a. (MonadMask n) => PassiveWalletLayer m -> WalletDiffusion -> (ActiveWalletLayer m -> n a) -> n a bracketQuickCheckActiveWallet = QuickCheck.bracketActiveWallet - diff --git a/wallet-new/src/Cardano/Wallet/WalletLayer/Error.hs b/wallet-new/src/Cardano/Wallet/WalletLayer/Error.hs new file mode 100644 index 00000000000..8d0e58faf14 --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/WalletLayer/Error.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DeriveGeneric #-} + +-- | Types describing runtime errors related to +-- wallet layers. It should be a common interface for +-- all the errors popping up from the @WalletLayer@. + +module Cardano.Wallet.WalletLayer.Error + ( WalletLayerError (..) + ) where + +import Universum + +import qualified Data.Text.Buildable +import Formatting (bprint, stext, (%)) + +import Cardano.Wallet.API.V1.Types (AccountIndex, WalletId) + + +data WalletLayerError + = WalletNotFound WalletId + | AccountNotFound WalletId AccountIndex + | AddressNotFound WalletId AccountIndex + -- FIXME(akegalj): https://iohk.myjetbrains.com/youtrack/issue/CSL-2496 + | WalletAlreadyExists + deriving (Show, Eq, Generic) + +instance Exception WalletLayerError + +instance Buildable WalletLayerError where + build (WalletNotFound wId ) = bprint ("Wallet not found. Wallet id ("%stext%").") (show wId) + build (AccountNotFound wId accIx) = bprint ("Account not found. Wallet id ("%stext%"), accound index ("%stext%").") (show wId) (show accIx) + build (AddressNotFound wId accIx) = bprint ("Address not found. Wallet id ("%stext%"), accound index ("%stext%").") (show wId) (show accIx) + build WalletAlreadyExists = bprint ("Can't create or restore a wallet. The wallet already exists.") diff --git a/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel.hs b/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel.hs index ae3c816c842..75f026ebb83 100644 --- a/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel.hs +++ b/wallet-new/src/Cardano/Wallet/WalletLayer/Kernel.hs @@ -7,39 +7,103 @@ module Cardano.Wallet.WalletLayer.Kernel import Universum -import System.Wlog (Severity) +import Data.Maybe (fromJust) +import System.Wlog (Severity(Debug)) -import Cardano.Wallet.WalletLayer.Types (ActiveWalletLayer (..), PassiveWalletLayer (..)) +import Pos.Block.Types (Blund, Undo (..)) import qualified Cardano.Wallet.Kernel as Kernel +import qualified Cardano.Wallet.Kernel.DB.HdWallet as HD +import Cardano.Wallet.Kernel.DB.Resolved (ResolvedBlock) import Cardano.Wallet.Kernel.Diffusion (WalletDiffusion (..)) +import Cardano.Wallet.Kernel.Types (RawResolvedBlock (..), fromRawResolvedBlock) +import Cardano.Wallet.WalletLayer.Types (ActiveWalletLayer (..), PassiveWalletLayer (..)) + +import Pos.Core.Chrono (OldestFirst (..)) + +import qualified Cardano.Wallet.Kernel.Actions as Actions +import qualified Data.Map.Strict as Map +import Pos.Util.BackupPhrase +import Pos.Crypto.Signing -- | Initialize the passive wallet. -- The passive wallet cannot send new transactions. bracketPassiveWallet - :: forall m n a. (MonadMask m, Monad n) + :: forall m n a. (MonadIO n, MonadIO m, MonadMask m) => (Severity -> Text -> IO ()) -> (PassiveWalletLayer n -> m a) -> m a -bracketPassiveWallet logFunction = - bracket - (Kernel.bracketPassiveWallet logFunction passiveWalletLayer) - (\_ -> return ()) +bracketPassiveWallet logFunction f = + Kernel.bracketPassiveWallet logFunction $ \w -> do + + -- Create the wallet worker and its communication endpoint `invoke`. + invoke <- Actions.forkWalletWorker $ Actions.WalletActionInterp + { Actions.applyBlocks = \blunds -> + Kernel.applyBlocks w $ + OldestFirst (mapMaybe blundToResolvedBlock (toList (getOldestFirst blunds))) + , Actions.switchToFork = \_ _ -> logFunction Debug "" + , Actions.emit = logFunction Debug + } + + -- TODO (temporary): build a sample wallet from a backup phrase + _ <- liftIO $ do + let backup = BackupPhrase + { bpToList = ["squirrel", "material", "silly", "twice", + "direct", "slush", "pistol", "razor", + "become", "junk", "kingdom", "flee" ] + } + Right (esk, _keyPair) = safeKeysFromPhrase emptyPassphrase backup + pk = error "TODO: need `AddressHash PublicKey` along with ESK to create a wallet" + + Kernel.createWalletHdRnd w walletName spendingPassword assuranceLevel (pk, esk) Map.empty + + f (passiveWalletLayer w invoke) + where + -- TODO consider defaults + walletName = HD.WalletName "(new wallet)" + spendingPassword = HD.NoSpendingPassword + assuranceLevel = HD.AssuranceLevelNormal + -- | TODO(ks): Currently not implemented! - passiveWalletLayer _wallet = - pure $ PassiveWalletLayer - { pwlGetWalletIds = error "Not implemented!" + passiveWalletLayer _wallet invoke = + PassiveWalletLayer + { _pwlCreateWallet = error "Not implemented!" + , _pwlGetWalletIds = error "Not implemented!" + , _pwlGetWallet = error "Not implemented!" + , _pwlUpdateWallet = error "Not implemented!" + , _pwlDeleteWallet = error "Not implemented!" + + , _pwlCreateAccount = error "Not implemented!" + , _pwlGetAccounts = error "Not implemented!" + , _pwlGetAccount = error "Not implemented!" + , _pwlUpdateAccount = error "Not implemented!" + , _pwlDeleteAccount = error "Not implemented!" + + , _pwlGetAddresses = error "Not implemented!" + + , _pwlApplyBlocks = invoke . Actions.ApplyBlocks + , _pwlRollbackBlocks = invoke . Actions.RollbackBlocks } + -- The use of the unsafe constructor 'UnsafeRawResolvedBlock' is justified + -- by the invariants established in the 'Blund'. + blundToResolvedBlock :: Blund -> Maybe ResolvedBlock + blundToResolvedBlock (b,u) + = rightToJust b <&> \mainBlock -> + fromRawResolvedBlock + $ UnsafeRawResolvedBlock mainBlock spentOutputs' + where + spentOutputs' = map (map fromJust) $ undoTx u + rightToJust = either (const Nothing) Just + -- | Initialize the active wallet. -- The active wallet is allowed all. bracketActiveWallet - :: forall m n a. (MonadMask m, Monad n) + :: forall m n a. (MonadIO m, MonadMask m) => PassiveWalletLayer n -> WalletDiffusion -> (ActiveWalletLayer n -> m a) -> m a -bracketActiveWallet walletPassiveLayer walletDiffusion = +bracketActiveWallet walletPassiveLayer _walletDiffusion = bracket (return ActiveWalletLayer{..}) (\_ -> return ()) - diff --git a/wallet-new/src/Cardano/Wallet/WalletLayer/Legacy.hs b/wallet-new/src/Cardano/Wallet/WalletLayer/Legacy.hs index 42cee5e5819..edf9f3537a1 100644 --- a/wallet-new/src/Cardano/Wallet/WalletLayer/Legacy.hs +++ b/wallet-new/src/Cardano/Wallet/WalletLayer/Legacy.hs @@ -1,43 +1,268 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ScopedTypeVariables #-} module Cardano.Wallet.WalletLayer.Legacy - ( bracketPassiveWallet + ( MonadLegacyWallet + , bracketPassiveWallet , bracketActiveWallet ) where import Universum +import Control.Monad.Catch (catchAll) +import Control.Monad.IO.Unlift (MonadUnliftIO) +import Data.Coerce (coerce) + +import Cardano.Wallet.WalletLayer.Error (WalletLayerError (..)) import Cardano.Wallet.WalletLayer.Types (ActiveWalletLayer (..), PassiveWalletLayer (..)) import Cardano.Wallet.Kernel.Diffusion (WalletDiffusion (..)) - import Cardano.Wallet.API.V1.Migration (migrate) -import Pos.Wallet.Web.State.State (WalletDbReader, askWalletSnapshot, getWalletAddresses) +import Cardano.Wallet.API.V1.Migration.Types () +import Cardano.Wallet.API.V1.Types (Account, AccountIndex, AccountUpdate, Address, + NewAccount (..), NewWallet (..), V1 (..), Wallet, + WalletId, WalletOperation (..), WalletUpdate) + +import Pos.Client.KeyStorage (MonadKeys) +import Pos.Core (ChainDifficulty) +import Pos.Crypto (PassPhrase) + +import Pos.Util (HasLens', maybeThrow) +import Pos.Wallet.Web.Account (GenSeed (..)) +import Pos.Wallet.Web.ClientTypes.Types (CWallet (..), CWalletInit (..), CWalletMeta (..)) +import qualified Pos.Wallet.Web.Error.Types as V0 +import Pos.Wallet.Web.Methods.Logic (MonadWalletLogicRead) +import qualified Pos.Wallet.Web.Methods.Logic as V0 +import Pos.Wallet.Web.Methods.Restore (newWallet, restoreWalletFromSeed) +import Pos.Wallet.Web.State.State (WalletDbReader, askWalletDB, askWalletSnapshot, + getWalletAddresses, setWalletMeta) +import Pos.Wallet.Web.State.Storage (getWalletInfo) +import Pos.Wallet.Web.Tracking.Types (SyncQueue) + +import Pos.Core.Chrono (NE, OldestFirst (..), NewestFirst (..)) +import Pos.Block.Types (Blund) + + +-- | Let's unify all the requirements for the legacy wallet. +type MonadLegacyWallet ctx m = + ( WalletDbReader ctx m + , HasLens' ctx SyncQueue + , MonadUnliftIO m + , MonadIO m + , MonadThrow m + , MonadWalletLogicRead ctx m + , MonadKeys m + ) -- | Initialize the passive wallet. -- The passive wallet cannot send new transactions. bracketPassiveWallet - :: forall ctx m n a. (MonadMask m, WalletDbReader ctx n, MonadIO n, MonadThrow n) - => (PassiveWalletLayer n -> m a) -> m a + :: forall ctx m n a. (MonadMask n, MonadLegacyWallet ctx m) + => (PassiveWalletLayer m -> n a) -> n a bracketPassiveWallet = bracket (pure passiveWalletLayer) (\_ -> return ()) where - passiveWalletLayer :: PassiveWalletLayer n + passiveWalletLayer :: PassiveWalletLayer m passiveWalletLayer = PassiveWalletLayer - { pwlGetWalletIds = askWalletSnapshot >>= \ws -> migrate $ getWalletAddresses ws + { _pwlCreateWallet = pwlCreateWallet + , _pwlGetWalletIds = pwlGetWalletIds + , _pwlGetWallet = pwlGetWallet + , _pwlUpdateWallet = pwlUpdateWallet + , _pwlDeleteWallet = pwlDeleteWallet + + , _pwlCreateAccount = pwlCreateAccount + , _pwlGetAccounts = pwlGetAccounts + , _pwlGetAccount = pwlGetAccount + , _pwlUpdateAccount = pwlUpdateAccount + , _pwlDeleteAccount = pwlDeleteAccount + + , _pwlGetAddresses = pwlGetAddresses + + , _pwlApplyBlocks = pwlApplyBlocks + , _pwlRollbackBlocks = pwlRollbackBlocks } + -- | Initialize the active wallet. -- The active wallet is allowed all. bracketActiveWallet - :: forall ctx m n a. (MonadMask m, WalletDbReader ctx n, MonadIO n, MonadThrow n) - => PassiveWalletLayer n + :: forall m n a. (MonadMask n) + => PassiveWalletLayer m -> WalletDiffusion - -> (ActiveWalletLayer n -> m a) -> m a -bracketActiveWallet walletPassiveLayer walletDiffusion = + -> (ActiveWalletLayer m -> n a) -> n a +bracketActiveWallet walletPassiveLayer _walletDiffusion = bracket (return ActiveWalletLayer{..}) (\_ -> return ()) +------------------------------------------------------------ +-- Wallet +------------------------------------------------------------ + +pwlCreateWallet + :: forall ctx m. (MonadLegacyWallet ctx m) + => NewWallet + -> m Wallet +pwlCreateWallet NewWallet{..} = do + + let spendingPassword = fromMaybe mempty $ coerce newwalSpendingPassword + let backupPhrase = coerce newwalBackupPhrase + + initMeta <- CWalletMeta <$> pure newwalName + <*> migrate newwalAssuranceLevel + <*> pure 0 + + let walletInit = CWalletInit initMeta backupPhrase + + wallet <- newWalletHandler newwalOperation spendingPassword walletInit + `catch` rethrowDuplicateMnemonic + wId <- migrate $ cwId wallet + + -- Get wallet or throw if missing. + maybeThrow (WalletNotFound wId) =<< pwlGetWallet wId + where + -- | We have two functions which are very similar. + newWalletHandler :: WalletOperation -> PassPhrase -> CWalletInit -> m CWallet + newWalletHandler CreateWallet = newWallet + newWalletHandler RestoreWallet = restoreWalletFromSeed + -- NOTE: this is temporary solution until we get rid of V0 error handling and/or we lift error handling into types: + -- https://github.com/input-output-hk/cardano-sl/pull/2811#discussion_r183469153 + -- https://github.com/input-output-hk/cardano-sl/pull/2811#discussion_r183472103 + rethrowDuplicateMnemonic (e :: V0.WalletError) = + case e of + V0.RequestError "Wallet with that mnemonics already exists" -> throwM WalletAlreadyExists + _ -> throwM e + + +pwlGetWalletIds + :: forall ctx m. (MonadLegacyWallet ctx m) + => m [WalletId] +pwlGetWalletIds = do + ws <- askWalletSnapshot + migrate $ getWalletAddresses ws + +pwlGetWallet + :: forall ctx m. (MonadLegacyWallet ctx m) + => WalletId + -> m (Maybe Wallet) +pwlGetWallet wId = do + ws <- askWalletSnapshot + + cWId <- migrate wId + wallet <- V0.getWallet cWId + + pure $ do + walletInfo <- getWalletInfo cWId ws + migrate (wallet, walletInfo, Nothing @ChainDifficulty) + +--instance Migrate (V0.CWallet, OldStorage.WalletInfo, Maybe Core.ChainDifficulty) V1.Wallet where + +pwlUpdateWallet + :: forall ctx m. (MonadLegacyWallet ctx m) + => WalletId + -> WalletUpdate + -> m Wallet +pwlUpdateWallet wId wUpdate = do + walletDB <- askWalletDB + + cWId <- migrate wId + cWMeta <- migrate wUpdate + + -- Update the data + setWalletMeta walletDB cWId cWMeta + + -- Get wallet or throw if missing. + maybeThrow (WalletNotFound wId) =<< pwlGetWallet wId + +-- | Seems silly, but we do need some sort of feedback from +-- the DB. +pwlDeleteWallet + :: forall ctx m. (MonadLegacyWallet ctx m) + => WalletId + -> m Bool +pwlDeleteWallet wId = do + cWId <- migrate wId + -- TODO(ks): It would be better to catch specific @Exception@. + -- Maybe @try@? + catchAll (const True <$> V0.deleteWallet cWId) (const . pure $ False) + +------------------------------------------------------------ +-- Account +------------------------------------------------------------ + +pwlCreateAccount + :: forall ctx m. (MonadLegacyWallet ctx m) + => WalletId + -> NewAccount + -> m Account +pwlCreateAccount wId newAcc@NewAccount{..} = do + + let spendingPassword = fromMaybe mempty . fmap coerce $ naccSpendingPassword + + accInit <- migrate (wId, newAcc) + cAccount <- V0.newAccount RandomSeed spendingPassword accInit + + migrate cAccount + +pwlGetAccounts + :: forall ctx m. (MonadLegacyWallet ctx m) + => WalletId + -> m [Account] +pwlGetAccounts wId = do + cWId <- migrate wId + cAccounts <- V0.getAccounts $ Just cWId + migrate cAccounts + +pwlGetAccount + :: forall ctx m. (MonadLegacyWallet ctx m) + => WalletId + -> AccountIndex + -> m (Maybe Account) +pwlGetAccount wId aId = do + accId <- migrate (wId, aId) + account <- V0.getAccount accId + Just <$> migrate account + +pwlUpdateAccount + :: forall ctx m. (MonadLegacyWallet ctx m) + => WalletId + -> AccountIndex + -> AccountUpdate + -> m Account +pwlUpdateAccount wId accIdx accUpdate = do + newAccId <- migrate (wId, accIdx) + accMeta <- migrate accUpdate + cAccount <- V0.updateAccount newAccId accMeta + migrate cAccount + +pwlDeleteAccount + :: forall ctx m. (MonadLegacyWallet ctx m) + => WalletId + -> AccountIndex + -> m Bool +pwlDeleteAccount wId accIdx = do + accId <- migrate (wId, accIdx) + catchAll (const True <$> V0.deleteAccount accId) (const . pure $ False) + +------------------------------------------------------------ +-- Address +------------------------------------------------------------ + +pwlGetAddresses :: WalletId -> m [Address] +pwlGetAddresses = error "Not implemented!" + +------------------------------------------------------------ +-- Apply Block +------------------------------------------------------------ + +pwlApplyBlocks :: OldestFirst NE Blund -> m () +pwlApplyBlocks = error "Not implemented!" + +------------------------------------------------------------ +-- Rollback Block +------------------------------------------------------------ + +pwlRollbackBlocks :: NewestFirst NE Blund -> m () +pwlRollbackBlocks = error "Not implemented!" diff --git a/wallet-new/src/Cardano/Wallet/WalletLayer/QuickCheck.hs b/wallet-new/src/Cardano/Wallet/WalletLayer/QuickCheck.hs index 8640567f258..ebf4d19c464 100644 --- a/wallet-new/src/Cardano/Wallet/WalletLayer/QuickCheck.hs +++ b/wallet-new/src/Cardano/Wallet/WalletLayer/QuickCheck.hs @@ -25,22 +25,36 @@ bracketPassiveWallet = where passiveWalletLayer :: PassiveWalletLayer n passiveWalletLayer = PassiveWalletLayer - { pwlGetWalletIds = liftedGen - } + { _pwlCreateWallet = \_ -> liftedGen + , _pwlGetWalletIds = liftedGen + , _pwlGetWallet = \_ -> liftedGen + , _pwlUpdateWallet = \_ _ -> liftedGen + , _pwlDeleteWallet = \_ -> liftedGen + + , _pwlCreateAccount = \_ _ -> liftedGen + , _pwlGetAccounts = \_ -> liftedGen + , _pwlGetAccount = \_ _ -> liftedGen + , _pwlUpdateAccount = \_ _ _ -> liftedGen + , _pwlDeleteAccount = \_ _ -> liftedGen + + , _pwlGetAddresses = \_ -> liftedGen + + , _pwlApplyBlocks = \_ -> liftedGen + , _pwlRollbackBlocks = \_ -> liftedGen + } -- | A utility function. - liftedGen :: forall b. (MonadIO n, Arbitrary b) => n b + liftedGen :: forall b. (Arbitrary b) => n b liftedGen = liftIO . generate $ arbitrary -- | Initialize the active wallet. -- The active wallet is allowed all. bracketActiveWallet - :: forall m n a. (MonadMask m, MonadIO n) + :: forall m n a. (MonadMask m) => PassiveWalletLayer n -> WalletDiffusion -> (ActiveWalletLayer n -> m a) -> m a -bracketActiveWallet walletPassiveLayer walletDiffusion = +bracketActiveWallet walletPassiveLayer _walletDiffusion = bracket (return ActiveWalletLayer{..}) (\_ -> return ()) - diff --git a/wallet-new/src/Cardano/Wallet/WalletLayer/README.md b/wallet-new/src/Cardano/Wallet/WalletLayer/README.md new file mode 100644 index 00000000000..393a40b5b8c --- /dev/null +++ b/wallet-new/src/Cardano/Wallet/WalletLayer/README.md @@ -0,0 +1,62 @@ +# Wallet layer + +This module here is an abstraction layer which would allow us to mock responses from the wallet +and that would fit into the current work with the new data layer. + +Important: + +- We feel that the right insertion point for this is at the + boundary between each servant handlers (& the BListener interface) and the + persistence layer. Therefore, more than a `WalletDBLayer` we are calling + this a "WalletLayer"; + +- The new data layer already introduced the concepts of `PassiveWallet` (a + wallet which does not have a `DiffusionLayer` available, so it + cannot send transactions) and an `ActiveWallet` (which already has) so it + makes sense to piggyback on those. + +The plan is to modify the current (opaque) implementation of a `PassiveWallet` +with an interface similar to the following: + +```haskell +data PassiveWalletLayer m = PassiveWalletLayer { + applyBlock :: ... + , rollbackBlock :: ... + , getAddresses :: WalletId -> m [WalletAddress] + , ... +} + +data ActiveWalletLayer m = ActiveWalletLayer { + passiveLayer :: PassiveWalletLayer m + , pay :: Payment -> m () + ... +} +``` + +Mind that we still need a `DiffusionLayer` to send transactions to the network, +so a subset of the wallet operations will live in the `ActiveWalletLayer` data type +rather than in the `PassiveWalletLayer` (as an example the `pay` operation +is provided with a possible type signature). + +Being parametrised over an `m` means pure mocks can run in `Identity` +and other usage can allow for `IO` or any other monad. This means that, +practically-speaking, a servant handler would look like this: + +```haskell +getAddresses :: ActiveWalletLayer -> ServantT ... +getAddresses awl = do + let pwl = getPassiveLayer awl + lift <$> getAddresses pwl +``` + +For the "new" Handlers we need to explicitly pass the `ActiveWalletLayer` +around due to the initialisation of the diffusion layer, which happens after +we setup the monadic context. For the `LegacyHandlers`, I _think_ this data +layer is available earlier, and so we could embed the active wallet directly +into the monad, and don't need to pass it as an explicit argument to the servant handlers. + +In practical terms, this means we will end up with three _concrete_ implementations of `PassiveWalletLayer`: +- Legacy - one for the _old_ data layer (which is currently what's being used for both V0 & V1) +- Kernel - the one for the _new_ data layer +- QuickCheck - the one for mocking purposes + diff --git a/wallet-new/src/Cardano/Wallet/WalletLayer/Types.hs b/wallet-new/src/Cardano/Wallet/WalletLayer/Types.hs index 8fa587dc830..5b02a476a24 100644 --- a/wallet-new/src/Cardano/Wallet/WalletLayer/Types.hs +++ b/wallet-new/src/Cardano/Wallet/WalletLayer/Types.hs @@ -1,26 +1,114 @@ module Cardano.Wallet.WalletLayer.Types ( PassiveWalletLayer (..) , ActiveWalletLayer (..) + -- * Getters + , createWallet + , getWalletIds + , getWallet + , updateWallet + , deleteWallet + + , createAccount + , getAccounts + , getAccount + , updateAccount + , deleteAccount + + , getAddresses + , applyBlocks + , rollbackBlocks ) where -import Universum () +import Universum + +import Control.Lens (makeLenses) -import Cardano.Wallet.API.V1.Types (WalletId) +import Cardano.Wallet.API.V1.Types (Account, AccountIndex, AccountUpdate, Address, + NewAccount, NewWallet, Wallet, WalletId, WalletUpdate) -import Cardano.Wallet.Kernel.Diffusion (WalletDiffusion (..)) +import Pos.Core.Chrono (NE, OldestFirst (..), NewestFirst (..)) +import Pos.Block.Types (Blund) +------------------------------------------------------------ +-- Passive wallet layer +------------------------------------------------------------ -- | The passive wallet (data) layer. See @PassiveWallet@. data PassiveWalletLayer m = PassiveWalletLayer - { pwlGetWalletIds :: m [WalletId] + { + -- * wallets + _pwlCreateWallet :: NewWallet -> m Wallet + , _pwlGetWalletIds :: m [WalletId] + , _pwlGetWallet :: WalletId -> m (Maybe Wallet) + , _pwlUpdateWallet :: WalletId -> WalletUpdate -> m Wallet + , _pwlDeleteWallet :: WalletId -> m Bool + -- * accounts + , _pwlCreateAccount :: WalletId -> NewAccount -> m Account + , _pwlGetAccounts :: WalletId -> m [Account] + , _pwlGetAccount :: WalletId -> AccountIndex -> m (Maybe Account) + , _pwlUpdateAccount :: WalletId -> AccountIndex -> AccountUpdate -> m Account + , _pwlDeleteAccount :: WalletId -> AccountIndex -> m Bool + -- * addresses + , _pwlGetAddresses :: WalletId -> m [Address] + -- * core API + , _pwlApplyBlocks :: OldestFirst NE Blund -> m () + , _pwlRollbackBlocks :: NewestFirst NE Blund -> m () } +makeLenses ''PassiveWalletLayer + +------------------------------------------------------------ +-- Passive wallet layer getters +------------------------------------------------------------ + +createWallet :: forall m. PassiveWalletLayer m -> NewWallet -> m Wallet +createWallet pwl = pwl ^. pwlCreateWallet + +getWalletIds :: forall m. PassiveWalletLayer m -> m [WalletId] +getWalletIds pwl = pwl ^. pwlGetWalletIds + +getWallet :: forall m. PassiveWalletLayer m -> WalletId -> m (Maybe Wallet) +getWallet pwl = pwl ^. pwlGetWallet + +updateWallet :: forall m. PassiveWalletLayer m -> WalletId -> WalletUpdate -> m Wallet +updateWallet pwl = pwl ^. pwlUpdateWallet + +deleteWallet :: forall m. PassiveWalletLayer m -> WalletId -> m Bool +deleteWallet pwl = pwl ^. pwlDeleteWallet + + +createAccount :: forall m. PassiveWalletLayer m -> WalletId -> NewAccount -> m Account +createAccount pwl = pwl ^. pwlCreateAccount + +getAccounts :: forall m. PassiveWalletLayer m -> WalletId -> m [Account] +getAccounts pwl = pwl ^. pwlGetAccounts + +getAccount :: forall m. PassiveWalletLayer m -> WalletId -> AccountIndex -> m (Maybe Account) +getAccount pwl = pwl ^. pwlGetAccount + +updateAccount :: forall m. PassiveWalletLayer m -> WalletId -> AccountIndex -> AccountUpdate -> m Account +updateAccount pwl = pwl ^. pwlUpdateAccount + +deleteAccount :: forall m. PassiveWalletLayer m -> WalletId -> AccountIndex -> m Bool +deleteAccount pwl = pwl ^. pwlDeleteAccount + + +getAddresses :: forall m. PassiveWalletLayer m -> WalletId -> m [Address] +getAddresses pwl = pwl ^. pwlGetAddresses + + +applyBlocks :: forall m. PassiveWalletLayer m -> OldestFirst NE Blund -> m () +applyBlocks pwl = pwl ^. pwlApplyBlocks + +rollbackBlocks :: forall m. PassiveWalletLayer m -> NewestFirst NE Blund -> m () +rollbackBlocks pwl = pwl ^. pwlRollbackBlocks + +------------------------------------------------------------ +-- Active wallet layer +------------------------------------------------------------ + -- An active wallet layer. See @ActiveWallet@. data ActiveWalletLayer m = ActiveWalletLayer { -- | The underlying passive wallet layer walletPassiveLayer :: PassiveWalletLayer m - - -- | The wallet diffusion layer - , walletDiffusion :: WalletDiffusion } - diff --git a/wallet-new/test/APISpec.hs b/wallet-new/test/APISpec.hs index ec929c7d227..b5553829691 100644 --- a/wallet-new/test/APISpec.hs +++ b/wallet-new/test/APISpec.hs @@ -1,179 +1,63 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NumDecimals #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module APISpec where +module APISpec (spec) where import Universum -import qualified Control.Concurrent.STM as STM -import Data.Default (def) -import Network.HTTP.Client hiding (Proxy) -import Network.HTTP.Types -import Ntp.Client (withoutNtpClient) -import qualified Pos.Diffusion.Types as D -import Pos.Util.CompileInfo (withCompileInfo) -import Pos.Wallet.WalletMode (WalletMempoolExt) -import Pos.Wallet.Web.Mode (WalletWebModeContext (..)) -import Pos.Wallet.Web.Sockets (ConnectionsVar) -import Pos.Wallet.Web.State (WalletDB) -import Pos.Wallet.Web.Tracking.Types (SyncQueue) -import Pos.WorkMode (RealModeContext (..)) -import Serokell.AcidState.ExtendedState +import qualified Data.ByteString as BS +import qualified Data.List as List +import qualified Data.Text.Encoding as Text import Servant -import Servant.QuickCheck -import Servant.QuickCheck.Internal +import System.Directory (getCurrentDirectory, listDirectory, makeAbsolute, + setCurrentDirectory) import Test.Hspec -import Test.Pos.Configuration (withDefConfigurations) -import Test.QuickCheck -import Test.QuickCheck.Instances () -import Cardano.Wallet.API.Request -import Cardano.Wallet.API.Types -import qualified Cardano.Wallet.API.V1 as V0 import qualified Cardano.Wallet.API.V1 as V1 -import qualified Cardano.Wallet.API.V1.LegacyHandlers as V0 -import qualified Cardano.Wallet.API.V1.LegacyHandlers as V1 -import qualified Cardano.Wallet.API.V1.Migration as Migration -import Cardano.Wallet.API.V1.Parameters -import Cardano.Wallet.API.V1.Types () - --- --- Instances to allow use of `servant-quickcheck`. --- - -instance HasGenRequest (apiType a :> sub) => - HasGenRequest (WithDefaultApiArg apiType a :> sub) where - genRequest _ = genRequest (Proxy @(apiType a :> sub)) - -instance HasGenRequest (argA a :> argB a :> sub) => - HasGenRequest (AlternativeApiArg argA argB a :> sub) where - genRequest _ = genRequest (Proxy @(argA a :> argB a :> sub)) - --- NOTE(adinapoli): This can be improved to produce proper filtering & sorting --- queries. -instance HasGenRequest sub => HasGenRequest (SortBy syms res :> sub) where - genRequest _ = genRequest (Proxy @sub) - -instance HasGenRequest sub => HasGenRequest (FilterBy syms res :> sub) where - genRequest _ = genRequest (Proxy @sub) - -instance HasGenRequest sub => HasGenRequest (Tags tags :> sub) where - genRequest _ = genRequest (Proxy :: Proxy sub) - -instance HasGenRequest (sub :: *) => HasGenRequest (WalletRequestParams :> sub) where - genRequest _ = genRequest (Proxy @(WithWalletRequestParams sub)) - --- --- RESTful-abiding predicates --- - --- | Checks that every DELETE request should return a 204 NoContent. -deleteReqShouldReturn204 :: RequestPredicate -deleteReqShouldReturn204 = RequestPredicate $ \req mgr -> - if (method req == methodDelete) - then do - resp <- httpLbs req mgr - let status = responseStatus resp - when (statusIsSuccessful status && status /= status204) $ - throwM $ PredicateFailure "deleteReqShouldReturn204" (Just req) resp - return [resp] - else return [] - --- | Checks that every PUT request is idempotent. Calling an endpoint with a PUT --- twice should return the same result. -putIdempotency :: RequestPredicate -putIdempotency = RequestPredicate $ \req mgr -> - if (method req == methodPut) - then do - resp1 <- httpLbs req mgr - resp2 <- httpLbs req mgr - let body1 = responseBody resp1 - let body2 = responseBody resp2 - when (body1 /= body2) $ - throwM $ PredicateFailure "putIdempotency" (Just req) resp1 - return [resp1, resp2] - else return [] - --- | Checks that every request which is not a 204 No Content --- does not have an empty body, but it always returns something. -noEmptyBody :: RequestPredicate -noEmptyBody = RequestPredicate $ \req mgr -> do - resp <- httpLbs req mgr - let body = responseBody resp - let status = responseStatus resp - when (status /= status204 && body == mempty) $ - throwM $ PredicateFailure "noEmptyBody" (Just req) resp - return [resp] - --- | All the predicates we want to enforce in our API. -predicates :: Predicates -predicates = not500 - <%> deleteReqShouldReturn204 - <%> putIdempotency - <%> noEmptyBody - <%> mempty - --- | "Lowers" V0 Handlers from our domain-specific monad to a @Servant@ 'Handler'. -v0Server :: ( Migration.HasConfigurations - , Migration.HasCompileInfo - ) => D.Diffusion Migration.MonadV1 -> IO (Server V0.API) -v0Server diffusion = do - -- TODO(adinapoli): If the monadic stack ends up diverging between V0 and V1, - -- it's obviously incorrect using 'testV1Context' here. - ctx <- testV1Context - withoutNtpClient $ \ntpStatus -> - return (V0.handlers (Migration.v1MonadNat ctx) diffusion ntpStatus) - --- | "Lowers" V1 Handlers from our domain-specific monad to a @Servant@ 'Handler'. -v1Server :: ( Migration.HasConfigurations - , Migration.HasCompileInfo - ) => D.Diffusion Migration.MonadV1 -> IO (Server V1.API) -v1Server diffusion = do - ctx <- testV1Context - withoutNtpClient $ \ntpStatus -> - return (V1.handlers (Migration.v1MonadNat ctx) diffusion ntpStatus) - --- | Returns a test 'V1Context' which can be used for the API specs. --- Such context will use an in-memory database. -testV1Context :: Migration.HasConfiguration => IO Migration.V1Context -testV1Context = - WalletWebModeContext <$> testStorage - <*> testConnectionsVar - <*> testSyncQueue - <*> testRealModeContext - where - testStorage :: IO WalletDB - testStorage = openMemoryExtendedState def - - testConnectionsVar :: IO ConnectionsVar - testConnectionsVar = STM.newTVarIO def - - testSyncQueue :: IO SyncQueue - testSyncQueue = STM.newTQueueIO - - -- For some categories of tests we won't hit the 'RealModeContext', so that's safe - -- for now to leave it unimplemented. - testRealModeContext :: IO (RealModeContext WalletMempoolExt) - testRealModeContext = return (error "testRealModeContext is currently unimplemented") -- Our API apparently is returning JSON Arrays which is considered bad practice as very old -- browsers can be hacked: https://haacked.com/archive/2009/06/25/json-hijacking.aspx/ -- The general consensus, after discussing this with the team, is that we can be moderately safe. +-- stack test cardano-sl-wallet-new --fast --test-arguments '-m "Servant API Properties"' spec :: Spec -spec = withCompileInfo def $ do - withDefConfigurations $ \_ -> do - xdescribe "Servant API Properties" $ do - it "V0 API follows best practices & is RESTful abiding" $ do - ddl <- D.dummyDiffusionLayer - withServantServer (Proxy @V0.API) (v0Server (D.diffusion ddl)) $ \burl -> - serverSatisfies (Proxy @V0.API) burl stdArgs predicates - it "V1 API follows best practices & is RESTful abiding" $ do - ddl <- D.dummyDiffusionLayer - withServantServer (Proxy @V1.API) (v1Server (D.diffusion ddl)) $ \burl -> - serverSatisfies (Proxy @V1.API) burl stdArgs predicates +spec = do + describe "Servant Layout" $ around_ withTestDirectory $ do + let layoutPath = "./test/golden/api-layout.txt" + newLayoutPath = layoutPath <> ".new" + it "has not changed" $ do + oldLayout <- BS.readFile layoutPath `catch` \(_err :: SomeException) -> pure "" + when (oldLayout /= serverLayout) $ do + BS.writeFile newLayoutPath serverLayout + expectationFailure $ List.unlines + [ "The API layout has changed!!! The new layout has been written to:" + , " " <> newLayoutPath + , "If this was intentional and correct, move the new layout path to:" + , " " <> layoutPath + , "Command:" + , " mv " <> newLayoutPath <> " " <> layoutPath + ] + +-- | This is a hack that sets the CWD to the correct directory to access +-- golden tests. `stack` will run tests at the top level of the git +-- project, while `cabal` and the Nix CI will run tests at the `wallet-new` +-- directory. This function ensures that we are in the `wallet-new` +-- directory for the execution of this test. +withTestDirectory :: IO () -> IO () +withTestDirectory action = void . runMaybeT $ do + dir <- lift getCurrentDirectory + entries <- lift $ listDirectory dir + guard ("cardano-sl-wallet-new.cabal" `notElem` entries) + guard ("wallet-new" `elem` entries) + lift $ do + bracket_ (setCurrentDirectory =<< makeAbsolute "wallet-new") + (setCurrentDirectory dir) + action + +serverLayout :: ByteString +serverLayout = Text.encodeUtf8 (layout (Proxy @V1.API)) diff --git a/wallet-new/test/DevelopmentSpec.hs b/wallet-new/test/DevelopmentSpec.hs index 1dce8161901..1093c030b80 100644 --- a/wallet-new/test/DevelopmentSpec.hs +++ b/wallet-new/test/DevelopmentSpec.hs @@ -1,33 +1,31 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- Spec for testing `development` endpoints -module DevelopmentSpec where +module DevelopmentSpec (spec) where import Universum -import Data.Default (def) import Pos.Client.KeyStorage (addSecretKey, getSecretKeysPlain) -import Pos.Util.BackupPhrase (BackupPhrase (..), safeKeysFromPhrase) -import Pos.Util.CompileInfo (HasCompileInfo, withCompileInfo) import Pos.Launcher (HasConfigurations) -import Pos.Util.QuickCheck.Property (assertProperty) +import Pos.Util.BackupPhrase (BackupPhrase (..), safeKeysFromPhrase) +import Test.Pos.Util.QuickCheck.Property (assertProperty) -import Test.Pos.Wallet.Web.Mode (walletPropertySpec) import Test.Hspec (Spec, describe) import Test.Hspec.QuickCheck (modifyMaxSuccess) import Test.Pos.Configuration (withDefConfigurations) +import Test.Pos.Wallet.Web.Mode (walletPropertySpec) import Cardano.Wallet.API.Development.LegacyHandlers (deleteSecretKeys) import Cardano.Wallet.Server.CLI (RunMode (..)) @@ -37,12 +35,11 @@ import Servant spec :: Spec spec = - withCompileInfo def $ - withDefConfigurations $ \_ -> + withDefConfigurations $ \_ _ -> describe "development endpoint" $ describe "secret-keys" $ modifyMaxSuccess (const 10) deleteAllSecretKeysSpec -deleteAllSecretKeysSpec :: (HasCompileInfo, HasConfigurations) => Spec +deleteAllSecretKeysSpec :: (HasConfigurations) => Spec deleteAllSecretKeysSpec = do -- TODO: Use an arbitrary instance of `BackupPhrase` if available let phrase = BackupPhrase [ "truly", "enact", "setup", "session" diff --git a/wallet-new/test/MarshallingSpec.hs b/wallet-new/test/MarshallingSpec.hs index 4fe69bf4a75..fa87e6ccd66 100644 --- a/wallet-new/test/MarshallingSpec.hs +++ b/wallet-new/test/MarshallingSpec.hs @@ -1,4 +1,4 @@ -module MarshallingSpec where +module MarshallingSpec (spec) where import Universum diff --git a/wallet-new/test/RequestSpec.hs b/wallet-new/test/RequestSpec.hs index 849c68569cc..93b68877d48 100644 --- a/wallet-new/test/RequestSpec.hs +++ b/wallet-new/test/RequestSpec.hs @@ -1,4 +1,4 @@ -module RequestSpec where +module RequestSpec (spec) where import Universum diff --git a/wallet-new/test/Spec.hs b/wallet-new/test/Spec.hs index bc29ed8f303..9ce1f467b87 100644 --- a/wallet-new/test/Spec.hs +++ b/wallet-new/test/Spec.hs @@ -1,13 +1,22 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Main where import Universum +import Data.Typeable (typeRep) +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck + +import Cardano.Wallet.API.V1.Types + import qualified APISpec as API import qualified DevelopmentSpec as Dev import qualified MarshallingSpec as Marshalling import qualified RequestSpec as ReqSpec import qualified SwaggerSpec as Swagger -import Test.Hspec import qualified WalletHandlersSpec as WalletHandlers -- | Tests whether or not some instances (JSON, Bi, etc) roundtrips. @@ -18,4 +27,16 @@ main = hspec $ do API.spec Swagger.spec ReqSpec.spec + + eqProps @WalletAddress + eqProps @Address + eqProps @Wallet + eqProps @Transaction + WalletHandlers.spec + +eqProps :: forall a. (Typeable a, Eq a, Arbitrary a, Show a) => Spec +eqProps = do + describe ("Equality for " ++ show (typeRep (Proxy @a))) $ do + prop "should be reflexive" $ \(x :: a) -> + x === x diff --git a/wallet-new/test/SwaggerSpec.hs b/wallet-new/test/SwaggerSpec.hs index d39f9b02669..16d65db440a 100644 --- a/wallet-new/test/SwaggerSpec.hs +++ b/wallet-new/test/SwaggerSpec.hs @@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE UndecidableInstances #-} -module SwaggerSpec where +module SwaggerSpec (spec) where import Universum diff --git a/wallet-new/test/WalletHandlersSpec.hs b/wallet-new/test/WalletHandlersSpec.hs index 5af130d442c..1b8abb41a76 100644 --- a/wallet-new/test/WalletHandlersSpec.hs +++ b/wallet-new/test/WalletHandlersSpec.hs @@ -1,4 +1,4 @@ -module WalletHandlersSpec where +module WalletHandlersSpec (spec) where import Universum @@ -6,7 +6,6 @@ import Test.Hspec import qualified Cardano.Wallet.API.V1.LegacyHandlers.Wallets as V1 import qualified Pos.Core as Core -import Pos.Crypto (ProtocolMagic (..)) import qualified Pos.Wallet.Web.ClientTypes.Types as V0 newSyncProgress :: Word64 -> Word64 -> V0.SyncProgress @@ -25,7 +24,6 @@ pc = Core.ProtocolConstants { Core.pcK = 10 , Core.pcVssMaxTTL = maxBound , Core.pcVssMinTTL = minBound - , Core.pcProtocolMagic = ProtocolMagic 10 } spec :: Spec diff --git a/wallet-new/test/golden/api-layout.txt b/wallet-new/test/golden/api-layout.txt new file mode 100644 index 00000000000..9a3a6147d84 --- /dev/null +++ b/wallet-new/test/golden/api-layout.txt @@ -0,0 +1,48 @@ +/ +├─ addresses/ +│ ├─• +│ ┆ +│ ├─• +│ ┆ +│ ┆ +│ └─ / +│ └─• +├─ node-info/ +│ └─• +├─ node-settings/ +│ └─• +├─ transactions/ +│ ├─ fees/ +│ │ └─• +│ ├─• +│ ┆ +│ └─• +└─ wallets/ + ├─• + ┆ + ├─• + ┆ + ┆ + ├─ / + │ ├─ password/ + │ │ └─• + │ ├─• + │ ┆ + │ ├─• + │ ┆ + │ └─• + ┆ + └─ / + └─ accounts/ + ├─ / + │ ├─• + │ ┆ + │ └─• + ┆ + ├─• + ┆ + ├─• + ┆ + ┆ + └─ / + └─• diff --git a/wallet-new/test/unit/Test/Infrastructure/Generator.hs b/wallet-new/test/unit/Test/Infrastructure/Generator.hs new file mode 100644 index 00000000000..3f2f492a91b --- /dev/null +++ b/wallet-new/test/unit/Test/Infrastructure/Generator.hs @@ -0,0 +1,188 @@ +module Test.Infrastructure.Generator ( + -- * Generator model and corresponding generators + GeneratorModel(..) + , genChainUsingModel + , genInductiveUsingModel + -- * Specific models + -- ** Simple model + , simpleModel + -- ** Cardano + , cardanoModel + , estimateCardanoFee + , estimateSize + ) where + +import Universum + +import qualified Data.Set as Set +import Test.QuickCheck + +import UTxO.Context +import UTxO.DSL +import UTxO.Generator +import Wallet.Inductive +import Wallet.Inductive.Generator + +import Pos.Core ( TxSizeLinear, calculateTxSizeLinear ) +import Serokell.Data.Memory.Units (Byte, fromBytes) + +{------------------------------------------------------------------------------- + Generator model +-------------------------------------------------------------------------------} + +-- | 'Chain' and 'Inductive' generator model +-- +-- The generators are polymorphic in the types of addresses we have, and need +-- various parameters. Here we introduce a simple model from which we can +-- derive all of these arguments. See 'simpleModel' and 'cardanoModel'. +data GeneratorModel h a = GeneratorModel { + -- | Bootstrap transaction + gmBoot :: Transaction h a + + -- | Addresses to work with + -- + -- These will be the addresses we can transfers funds from and to + , gmAllAddresses :: [a] + + -- | Which subset of 'gmAllAddresses' can we choose from for @ours@? + , gmPotentialOurs :: a -> Bool + + -- | Maximum number of addresses to use for @ours@ + , gmMaxNumOurs :: Int + + -- | Estimate fees + , gmEstimateFee :: Int -> [Value] -> Value + } + +genChainUsingModel :: (Hash h a, Ord a) => GeneratorModel h a -> Gen (Chain h a) +genChainUsingModel GeneratorModel{..} = + evalStateT (genChain params) initState + where + params = defChainParams gmEstimateFee gmAllAddresses + initUtxo = utxoRestrictToAddr (`elem` gmAllAddresses) $ trUtxo gmBoot + initState = initTrState initUtxo 1 + +genInductiveUsingModel :: (Hash h a, Ord a) + => GeneratorModel h a -> Gen (Inductive h a) +genInductiveUsingModel GeneratorModel{..} = do + numOurs <- choose (1, min (length potentialOurs) gmMaxNumOurs) + addrs' <- shuffle potentialOurs + let ours = Set.fromList (take numOurs addrs') + events <- evalStateT (genWalletEvents (params ours)) initState + return Inductive { + inductiveBoot = gmBoot + , inductiveOurs = ours + , inductiveEvents = events + } + where + potentialOurs = filter gmPotentialOurs gmAllAddresses + params ours = defEventsParams gmEstimateFee gmAllAddresses ours initUtxo + initUtxo = utxoRestrictToAddr (`elem` gmAllAddresses) $ trUtxo gmBoot + initState = initEventsGlobalState 1 + +{------------------------------------------------------------------------------- + Simple model +-------------------------------------------------------------------------------} + +-- | Simplified generator model +-- +-- Small values, simple addresses, and no fees +simpleModel :: GeneratorModel GivenHash Char +simpleModel = GeneratorModel { + gmAllAddresses = addrs + , gmPotentialOurs = \_ -> True + , gmEstimateFee = \_ _ -> 0 + , gmMaxNumOurs = 3 + , gmBoot = Transaction { + trFresh = fromIntegral (length addrs) * initBal + , trIns = Set.empty + , trOuts = [Output a initBal | a <- addrs] + , trFee = 0 + , trHash = 0 + , trExtra = ["Simple bootstrap"] + } + } + where + addrs :: [Char] + addrs = ['a' .. 'g'] + + initBal :: Value + initBal = 10000 + +{------------------------------------------------------------------------------- + Cardano model +-------------------------------------------------------------------------------} + +-- | The Cardano itself (given the bootstrap transaction). +-- +-- This is a model that results in something that we can translate to Cardano, +-- but since it deals with the " real world " it has all kinds of different +-- actors, large values, etc., and so is a bit difficult to debug when +-- looking at values manually. +cardanoModel :: TxSizeLinear + -> Transaction GivenHash Addr -> GeneratorModel GivenHash Addr +cardanoModel linearFeePolicy boot = GeneratorModel { + gmBoot = boot + , gmAllAddresses = filter (not . isAvvmAddr) $ addrsInBoot boot + , gmPotentialOurs = \_ -> True + , gmEstimateFee = estimateCardanoFee linearFeePolicy + , gmMaxNumOurs = 5 + } + +{-| Estimate the size of a transaction, in bytes. + + The magic numbers appearing in the formula have the following origins: + + 5 = 1 + 2 + 2, where 1 = tag for Tx type, and 2 each to delimit the + TxIn and TxOut lists. + + 42 = 2 + 1 + 34 + 5, where 2 = tag for TxIn ctor, 1 = tag for pair, + 34 = size of encoded Blake2b_256 Tx hash, 5 = max size of encoded + CRC32 (range is 1..5 bytes, average size is just under 5 bytes). + + 11 = 2 + 2 + 2 + 5, where the 2s are: tag for TxOut ctor, tag for Address + ctor, and delimiters for encoded address. 5 = max size of CRC32. + + 32 = 1 + 30 + 1, where the first 1 is a tag for a tuple length, the + second 1 is the encoded address type. 30 = size of Blake2b_224 + hash of Address'. +-} +estimateSize :: Int -- ^ Average size of @Attributes AddrAttributes@. + -> Int -- ^ Size of transaction's @Attributes ()@. + -> Int -- ^ Number of inputs to the transaction. + -> [Value] -- ^ Coin value of each output to the transaction. + -> Byte -- ^ Estimated size of the resulting transaction. +estimateSize saa sta ins outs + = fromBytes . fromIntegral $ + 5 + + 42 * ins + + (11 + listSize (32 + (fromIntegral saa))) * length outs + + sum (map intSize outs) + + fromIntegral sta + where + intSize s = + if | s <= 0x17 -> 1 + | s <= 0xff -> 2 + | s <= 0xffff -> 3 + | s <= 0xffffffff -> 5 + | otherwise -> 9 + + listSize s = s + intSize s + +-- | Estimate the fee for a transaction that has @ins@ inputs +-- and @length outs@ outputs. The @outs@ lists holds the coin value +-- of each output. +-- +-- NOTE: The average size of @Attributes AddrAttributes@ and +-- the transaction attributes @Attributes ()@ are both hard-coded +-- here with some (hopefully) realistic values. +estimateCardanoFee :: TxSizeLinear -> Int -> [Value] -> Value +estimateCardanoFee linearFeePolicy ins outs + = round (calculateTxSizeLinear linearFeePolicy (estimateSize 128 16 ins outs)) + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +addrsInBoot :: Transaction GivenHash a -> [a] +addrsInBoot = map outAddr . trOuts diff --git a/wallet-new/test/unit/Test/Infrastructure/Genesis.hs b/wallet-new/test/unit/Test/Infrastructure/Genesis.hs new file mode 100644 index 00000000000..1d8c458ec21 --- /dev/null +++ b/wallet-new/test/unit/Test/Infrastructure/Genesis.hs @@ -0,0 +1,62 @@ +module Test.Infrastructure.Genesis ( + GenesisValues(..) + , genesisValues + ) where + +import Universum + +import qualified Data.List (head) + +import UTxO.Context +import UTxO.DSL + +import Pos.Core (TxSizeLinear) +import Test.Infrastructure.Generator (estimateCardanoFee) + +{------------------------------------------------------------------------------- + Convenient access to some values in the Cardano genesis block +-------------------------------------------------------------------------------} + +-- | Convenient access to some values in the Cardano genesis block +data GenesisValues h = GenesisValues { + -- | Initial balance of rich actor 0 + initR0 :: Value + + -- | Address of rich actor 0 + , r0 :: Addr + + -- | Address of rich actor 1 + , r1 :: Addr + + -- | Address of rich actor 2 + , r2 :: Addr + + -- | Hash of the bootstrap transaction + , hashBoot :: h (Transaction h Addr) + + -- | Fee policy + , txFee :: Int -> [Value] -> Value + } + +-- | Compute genesis values from the bootstrap transaction +genesisValues :: (Hash h Addr) => TxSizeLinear -> Transaction h Addr -> GenesisValues h +genesisValues txSizeLinear boot@Transaction{..} = GenesisValues{..} + where + initR0 = unsafeHead [val | Output a val <- trOuts, a == r0] + + --11137499999752500 + + r0 = Addr (IxRich 0) 0 + r1 = Addr (IxRich 1) 0 + r2 = Addr (IxRich 2) 0 + + hashBoot = hash boot + + txFee = estimateCardanoFee txSizeLinear + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +unsafeHead :: [a] -> a +unsafeHead = Data.List.head diff --git a/wallet-new/test/unit/Test/Spec/Kernel.hs b/wallet-new/test/unit/Test/Spec/Kernel.hs new file mode 100644 index 00000000000..6ab500adbdc --- /dev/null +++ b/wallet-new/test/unit/Test/Spec/Kernel.hs @@ -0,0 +1,86 @@ +module Test.Spec.Kernel ( + spec + ) where + +import Universum + +import qualified Data.Set as Set + +import qualified Cardano.Wallet.Kernel as Kernel +import qualified Cardano.Wallet.Kernel.Diffusion as Kernel +import Pos.Core (Coeff (..), TxSizeLinear (..)) + +import Test.Infrastructure.Generator +import Util.Buildable.Hspec +import Util.Buildable.QuickCheck +import UTxO.Bootstrap +import UTxO.Context +import UTxO.Crypto +import UTxO.DSL +import UTxO.Translate +import Wallet.Abstract +import Wallet.Inductive +import Wallet.Inductive.Cardano + +import qualified Wallet.Basic as Base + +{------------------------------------------------------------------------------- + Compare the wallet kernel with the pure model +-------------------------------------------------------------------------------} + +spec :: Spec +spec = + it "Compare wallet kernel to pure model" $ + forAll (genInductiveUsingModel model) $ \ind -> do + -- TODO: remove once we have support for rollback in the kernel + let indDontRoll = uptoFirstRollback ind + bracketActiveWallet $ \activeWallet -> do + checkEquivalent activeWallet indDontRoll + where + transCtxt = runTranslateNoErrors ask + boot = bootstrapTransaction transCtxt + model = (cardanoModel linearFeePolicy boot) { + gmMaxNumOurs = 1 + , gmPotentialOurs = isPoorAddr + } + linearFeePolicy = TxSizeLinear (Coeff 155381) (Coeff 43.946) + + checkEquivalent :: forall h. Hash h Addr + => Kernel.ActiveWallet + -> Inductive h Addr + -> Expectation + checkEquivalent activeWallet ind = do + shouldReturnValidated $ runTranslateT $ do + equivalentT activeWallet (encKpHash ekp, encKpEnc ekp) (mkWallet (== addr)) ind + where + [addr] = Set.toList $ inductiveOurs ind + AddrInfo{..} = resolveAddr addr transCtxt + Just ekp = addrInfoMasterKey + + -- TODO: We should move to the full model instead of the base model + mkWallet :: Hash h Addr => Ours Addr -> Transaction h Addr -> Wallet h Addr + mkWallet = walletBoot Base.walletEmpty + +{------------------------------------------------------------------------------- + Wallet resource management +-------------------------------------------------------------------------------} + +-- | Initialize passive wallet in a manner suitable for the unit tests +bracketPassiveWallet :: (Kernel.PassiveWallet -> IO a) -> IO a +bracketPassiveWallet = Kernel.bracketPassiveWallet logMessage + where + -- TODO: Decide what to do with logging + logMessage _sev txt = print txt + +-- | Initialize active wallet in a manner suitable for generator-based testing +bracketActiveWallet :: (Kernel.ActiveWallet -> IO a) -> IO a +bracketActiveWallet test = + bracketPassiveWallet $ \passive -> + Kernel.bracketActiveWallet passive diffusion $ \active -> + test active + +-- TODO: Decide what we want to do with submitted transactions +diffusion :: Kernel.WalletDiffusion +diffusion = Kernel.WalletDiffusion { + walletSendTx = \_tx -> return False + } diff --git a/wallet-new/test/unit/Test/Spec/Models.hs b/wallet-new/test/unit/Test/Spec/Models.hs new file mode 100644 index 00000000000..5ab0715e6c4 --- /dev/null +++ b/wallet-new/test/unit/Test/Spec/Models.hs @@ -0,0 +1,103 @@ +module Test.Spec.Models ( + spec + ) where + +import Universum + +import qualified Data.Set as Set + +import Test.Infrastructure.Generator +import Util.Buildable.Hspec +import Util.Buildable.QuickCheck +import UTxO.Bootstrap +import UTxO.DSL +import UTxO.Translate +import Wallet.Abstract +import Wallet.Inductive +import Wallet.Inductive.Invariants +import Wallet.Inductive.Validation + +import qualified Wallet.Basic as Base +import qualified Wallet.Incremental as Incr +import qualified Wallet.Prefiltered as Pref +import qualified Wallet.Rollback.Basic as Roll +import qualified Wallet.Rollback.Full as Full + +import Pos.Core (Coeff (..), TxSizeLinear (..)) + +{------------------------------------------------------------------------------- + Pure wallet tests +-------------------------------------------------------------------------------} + +-- | Test the pure wallet models +spec :: Spec +spec = do + describe "Test pure wallets" $ do + it "Using simple model" $ + forAll (genInductiveUsingModel simpleModel) $ testPureWalletWith + it "Using Cardano model" $ + forAll (genInductiveUsingModel (cardanoModel linearFeePolicy boot)) $ testPureWalletWith + where + transCtxt = runTranslateNoErrors ask + boot = bootstrapTransaction transCtxt + linearFeePolicy = TxSizeLinear (Coeff 155381) (Coeff 43.946) + +testPureWalletWith :: forall h a. (Hash h a, Ord a, Buildable a) + => Inductive h a -> Property +testPureWalletWith indWithRoll = conjoin [ + -- sanity check on the test + shouldBeValidated (void (inductiveIsValid indWithRoll)) + + -- check that the invariants hold in each model + , checkInvariants NoRollback "base" indDontRoll baseEmpty + , checkInvariants NoRollback "incr" indDontRoll incrEmpty + , checkInvariants NoRollback "pref" indDontRoll prefEmpty + , checkInvariants BasicRollback "roll" indWithRoll rollEmpty + , checkInvariants FullRollback "full" indWithRoll fullEmpty + + -- check equivalence between the models (no rollbacks) + , checkEquivalent "base/incr" indDontRoll baseEmpty incrEmpty + , checkEquivalent "base/pref" indDontRoll baseEmpty prefEmpty + , checkEquivalent "base/roll" indDontRoll baseEmpty rollEmpty + , checkEquivalent "base/full" indDontRoll baseEmpty fullEmpty + + -- check equivalence between models (with rollbacks) + , checkEquivalent "roll/full" indWithRoll rollEmpty fullEmpty + ] + where + -- Prefix of the 'Inductive' without any rollbacks + indDontRoll :: Inductive h a + indDontRoll = uptoFirstRollback indWithRoll + + checkInvariants :: ApplicableInvariants + -> Text + -> Inductive h a + -> (Set a -> Transaction h a -> Wallet h a) + -> Expectation + checkInvariants applicableInvariants label ind@Inductive{..} w = + shouldBeValidated $ + walletInvariants applicableInvariants label (w inductiveOurs) ind + + checkEquivalent :: Text + -> Inductive h a + -> (Set a -> Transaction h a -> Wallet h a) + -> (Set a -> Transaction h a -> Wallet h a) + -> Expectation + checkEquivalent label ind@Inductive{..} w w' = + shouldBeValidated $ + walletEquivalent label (w inductiveOurs) (w' inductiveOurs) ind + + oursFromSet :: Set a -> Ours a + oursFromSet = flip Set.member + + baseEmpty :: Set a -> Transaction h a -> Wallet h a + incrEmpty :: Set a -> Transaction h a -> Wallet h a + prefEmpty :: Set a -> Transaction h a -> Wallet h a + rollEmpty :: Set a -> Transaction h a -> Wallet h a + fullEmpty :: Set a -> Transaction h a -> Wallet h a + + baseEmpty = walletBoot Base.walletEmpty . oursFromSet + incrEmpty = walletBoot Incr.walletEmpty . oursFromSet + prefEmpty = walletBoot Pref.walletEmpty . oursFromSet + rollEmpty = walletBoot Roll.walletEmpty . oursFromSet + fullEmpty = walletBoot Full.walletEmpty . oursFromSet diff --git a/wallet-new/test/unit/Test/Spec/Submission.hs b/wallet-new/test/unit/Test/Spec/Submission.hs new file mode 100644 index 00000000000..5f7dc30d99b --- /dev/null +++ b/wallet-new/test/unit/Test/Spec/Submission.hs @@ -0,0 +1,403 @@ +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Test.Spec.Submission ( + spec + , dependentTransactions + ) where + +import Universum hiding (elems) + +import Cardano.Wallet.Kernel.DB.InDb (fromDb) +import Cardano.Wallet.Kernel.DB.Spec (Pending (..), emptyPending, pendingTransactions, + removePending) +import Cardano.Wallet.Kernel.Submission +import Control.Exception (toException) +import Control.Lens (to) +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S +import Data.Text.Buildable (build) +import qualified Data.Vector as V +import Formatting (bprint, (%)) +import qualified Formatting as F +import qualified Pos.Core as Core +import Pos.Crypto.Hashing (hash) +import Pos.Data.Attributes (Attributes (..), UnparsedFields (..)) +import Serokell.Util.Text (listJsonIndent) +import qualified Test.Pos.Txp.Arbitrary as Core + +import Test.QuickCheck (Gen, Property, arbitrary, choose, conjoin, forAll, listOf, + shuffle, vectorOf, (===)) +import Test.QuickCheck.Property (counterexample, exception, property) +import Util (disjoint) +import Util.Buildable (ShowThroughBuild (..)) +import Util.Buildable.Hspec + +{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-} + +{------------------------------------------------------------------------------- + QuickCheck core-based generators, which cannot be placed in the normal + modules without having `wallet-new` depends from `cardano-sl-txp-test`. +-------------------------------------------------------------------------------} + +genPending :: Core.ProtocolMagic -> Gen Pending +genPending pMagic = do + elems <- listOf (do tx <- Core.genTx + wit <- (V.fromList <$> listOf (Core.genTxInWitness pMagic)) + aux <- Core.TxAux <$> pure tx <*> pure wit + pure (hash tx, aux) + ) + return $ emptyPending & over pendingTransactions (fmap (M.union (M.fromList elems))) + +-- Generates a random schedule by picking a slot >= of the input one but +-- within a 'slot + 10' range, as really generating schedulers which generates +-- things too far away in the future is not very useful for testing, if not +-- testing that a scheduler will never reschedule something which cannot be +-- reached. +genSchedule :: MaxRetries -> Pending -> Slot -> Gen Schedule +genSchedule maxRetries pending (Slot lowerBound) = do + let pendingTxs = pending ^. pendingTransactions . fromDb . to M.toList + slots <- vectorOf (length pendingTxs) (fmap Slot (choose (lowerBound, lowerBound + 10))) + retries <- vectorOf (length pendingTxs) (choose (0, maxRetries)) + let events = List.foldl' updateFn mempty (zip3 slots pendingTxs retries) + return $ Schedule events mempty + where + updateFn acc (slot, (txId, txAux), retries) = + let s = ScheduleSend txId txAux (SubmissionCount retries) + e = ScheduleEvents [s] mempty + in prependEvents slot e acc + +genWalletSubmissionState :: MaxRetries -> Gen WalletSubmissionState +genWalletSubmissionState maxRetries = do + pending <- genPending (Core.ProtocolMagic 0) + slot <- pure (Slot 0) -- Make the layer always start from 0, to make running the specs predictable. + scheduler <- genSchedule maxRetries pending slot + return $ WalletSubmissionState pending scheduler slot + +genWalletSubmission :: MaxRetries + -> ResubmissionFunction m + -> Gen (WalletSubmission m) +genWalletSubmission maxRetries rho = + WalletSubmission <$> pure rho <*> genWalletSubmissionState maxRetries + +{------------------------------------------------------------------------------- + Submission layer tests +-------------------------------------------------------------------------------} + +instance (Buildable a, Buildable b) => Buildable (a,b) where + build (a,b) = bprint ("(" % F.build % "," % F.build % ")") a b + +instance Buildable [LabelledTxAux] where + build xs = bprint (listJsonIndent 4) xs + +instance (Buildable a) => Buildable (S.Set a) where + build xs = bprint (listJsonIndent 4) (S.toList xs) + +constantResubmit :: ResubmissionFunction Identity +constantResubmit = giveUpAfter 255 + +giveUpAfter :: Int -> ResubmissionFunction Identity +giveUpAfter retries currentSlot scheduled oldScheduler = + let send _ = return () + rPolicy = constantRetry 1 retries + in defaultResubmitFunction send rPolicy currentSlot scheduled oldScheduler + +-- | Checks whether or not the second input is fully contained within the first. +shouldContainPending :: Pending -> Pending -> Bool +shouldContainPending p1 p2 = + let pending1 = p1 ^. pendingTransactions . fromDb + pending2 = p2 ^. pendingTransactions . fromDb + in pending2 `M.isSubmapOf` pending1 + +-- | Checks that @any@ of the input transactions (in the pending set) appears +-- in the local pending set of the given 'WalletSubmission'. +doesNotContainPending :: Pending -> WalletSubmission m -> Bool +doesNotContainPending p ws = + let pending = p ^. pendingTransactions . fromDb + localPending = ws ^. localPendingSet . pendingTransactions . fromDb + in M.intersection localPending pending == mempty + +tick' :: WalletSubmission Identity -> (Evicted, WalletSubmission Identity) +tick' ws = runIdentity $ tick (error "tick failed") ws + +toTxIdSet :: Pending -> Set Core.TxId +toTxIdSet p = S.fromList $ map fst (p ^. pendingTransactions . fromDb . to M.toList) + +pendingFromTxs :: [Core.TxAux] -> Pending +pendingFromTxs txs = + let entries = map (\t -> (hash (Core.taTx t), t)) txs + in emptyPending & (pendingTransactions . fromDb) .~ (M.fromList entries) + +data LabelledTxAux = LabelledTxAux { + labelledTxLabel :: String + , labelledTxAux :: Core.TxAux + } + +instance Buildable LabelledTxAux where + build labelled = + let tx = Core.taTx (labelledTxAux labelled) + in bprint (F.shown % " [" % F.build % "] -> " % listJsonIndent 4) (labelledTxLabel labelled) (hash tx) (inputsOf tx) + where + inputsOf :: Core.Tx -> [Core.TxIn] + inputsOf tx = NonEmpty.toList (Core._txInputs tx) + +-- Generates 4 transactions A, B, C, D such that +-- D -> C -> B -> A (C depends on B which depends on A) +dependentTransactions :: Gen (LabelledTxAux, LabelledTxAux, LabelledTxAux, LabelledTxAux) +dependentTransactions = do + let emptyAttributes = Attributes () (UnparsedFields mempty) + inputForA <- (Core.TxInUtxo <$> arbitrary <*> arbitrary) + outputForA <- (Core.TxOut <$> arbitrary <*> arbitrary) + outputForB <- (Core.TxOut <$> arbitrary <*> arbitrary) + outputForC <- (Core.TxOut <$> arbitrary <*> arbitrary) + outputForD <- (Core.TxOut <$> arbitrary <*> arbitrary) + [a,b,c,d] <- vectorOf 4 (Core.genTxAux (Core.ProtocolMagic 0)) + let a' = a { Core.taTx = (Core.taTx a) { + Core._txInputs = inputForA :| mempty + , Core._txOutputs = outputForA :| mempty + , Core._txAttributes = emptyAttributes + } + } + let b' = b { Core.taTx = (Core.taTx b) { + Core._txInputs = Core.TxInUtxo (hash (Core.taTx a')) 0 :| mempty + , Core._txOutputs = outputForB :| mempty + , Core._txAttributes = emptyAttributes + } + } + let c' = c { Core.taTx = (Core.taTx c) { + Core._txInputs = Core.TxInUtxo (hash (Core.taTx b')) 0 :| mempty + , Core._txOutputs = outputForC :| mempty + , Core._txAttributes = emptyAttributes + } + } + let d' = d { Core.taTx = (Core.taTx d) { + Core._txInputs = Core.TxInUtxo (hash (Core.taTx c')) 0 :| mempty + , Core._txOutputs = outputForD :| mempty + , Core._txAttributes = emptyAttributes + } + } + return ( LabelledTxAux "B" b' + , LabelledTxAux "C" c' + , LabelledTxAux "A" a' + , LabelledTxAux "D" d' + ) + +--- +--- Pure generators, running in Identity +--- +genPureWalletSubmission :: Gen (ShowThroughBuild (WalletSubmission Identity)) +genPureWalletSubmission = STB <$> genWalletSubmission 255 constantResubmit + +genPurePair :: Gen (ShowThroughBuild (WalletSubmission Identity, Pending)) +genPurePair = do + STB layer <- genPureWalletSubmission + pending <- genPending (Core.ProtocolMagic 0) + let pending' = removePending (toTxIdSet $ layer ^. localPendingSet) pending + pure $ STB (layer, pending') + +class ToTxIds a where + toTxIds :: a -> [Core.TxId] + +instance ToTxIds Core.TxAux where + toTxIds tx = [hash (Core.taTx tx)] + +instance ToTxIds LabelledTxAux where + toTxIds (LabelledTxAux _ txAux) = toTxIds txAux + +instance ToTxIds a => ToTxIds [a] where + toTxIds = mconcat . map toTxIds + +instance ToTxIds Pending where + toTxIds p = map fst . M.toList $ p ^. pendingTransactions . fromDb + +instance ToTxIds ScheduleSend where + toTxIds (ScheduleSend txId _ _) = [txId] + +failIf :: (Buildable a, Buildable b) => String -> (a -> b -> Bool) -> a -> b -> Property +failIf label f x y = + counterexample (show (STB x) ++ interpret res ++ show (STB y)) res + where + res = f x y + interpret True = " failIf succeeded " + interpret False = " " <> label <> " " + +isSubsetOf :: (Buildable a, Ord a) => S.Set a -> S.Set a -> Property +isSubsetOf = failIf "not infix of" S.isSubsetOf + +includeEvent :: String -> ScheduleEvents -> LabelledTxAux -> Property +includeEvent label se tx = + failIf (label <> ": doesn't include event") + (\t s -> hash (Core.taTx (labelledTxAux t)) `List.elem` toTxIds (s ^. seToSend)) tx se + +includeEvents :: String -> ScheduleEvents -> [LabelledTxAux] -> Property +includeEvents label se txs = failIf (label <> ": not includes all of") checkEvent se txs + where + checkEvent :: ScheduleEvents -> [LabelledTxAux] -> Bool + checkEvent (ScheduleEvents toSend _) = + all (\t -> hash (Core.taTx (labelledTxAux t)) `List.elem` toTxIds toSend) + +mustNotIncludeEvents :: String -> ScheduleEvents -> [LabelledTxAux] -> Property +mustNotIncludeEvents label se txs = failIf (label <> ": does include one of") checkEvent se txs + where + checkEvent :: ScheduleEvents -> [LabelledTxAux] -> Bool + checkEvent (ScheduleEvents toSend _) = + all (\t -> not $ hash (Core.taTx (labelledTxAux t)) `List.elem` toTxIds toSend) + +spec :: Spec +spec = do + describe "Test wallet submission layer" $ do + + it "supports addition of pending transactions" $ + forAll genPurePair $ \(unSTB -> (submission, toAdd)) -> + let currentSlot = submission ^. getCurrentSlot + submission' = addPending toAdd submission + schedule = submission' ^. getSchedule + ((ScheduleEvents toSend _),_) = scheduledFor (mapSlot succ currentSlot) schedule + in conjoin [ + failIf "localPending set not updated" shouldContainPending (submission' ^. localPendingSet) toAdd + -- Check that all the added transactions are scheduled for the next slot + , failIf "not infix of" S.isSubsetOf (toTxIdSet toAdd) (S.fromList $ toTxIds toSend) + ] + + it "supports deletion of pending transactions" $ + forAll genPurePair $ \(unSTB -> (submission, toRemove)) -> + doesNotContainPending toRemove $ remPending (toTxIdSet toRemove) submission + + it "remPending . addPending = id" $ + forAll genPurePair $ \(unSTB -> (submission, pending)) -> + let originallyPending = submission ^. localPendingSet + currentlyPending = view localPendingSet (remPending (toTxIdSet pending) (addPending pending submission)) + in failIf "the two pending set are not equal" (==) originallyPending currentlyPending + + it "increases its internal slot after ticking" $ do + forAll genPureWalletSubmission $ \(unSTB -> submission) -> + let slotNow = submission ^. getCurrentSlot + (_, ws') = tick' submission + in failIf "internal slot didn't increase" (==) (ws' ^. getCurrentSlot) (mapSlot succ slotNow) + + it "constantRetry works predictably" $ do + let policy = constantRetry 1 5 + conjoin [ + policy (SubmissionCount 0) (Slot 0) === SendIn (Slot 1) + , policy (SubmissionCount 1) (Slot 1) === SendIn (Slot 2) + , policy (SubmissionCount 2) (Slot 2) === SendIn (Slot 3) + , policy (SubmissionCount 3) (Slot 3) === SendIn (Slot 4) + , policy (SubmissionCount 4) (Slot 4) === SendIn (Slot 5) + , policy (SubmissionCount 5) (Slot 5) === CheckConfirmedIn (Slot 6) + ] + + it "limit retries correctly" $ do + forAll genPurePair $ \(unSTB -> (ws, pending)) -> + let ws' = (addPending pending ws) & wsResubmissionFunction .~ giveUpAfter 3 + (evicted1, ws1) = tick' ws' + (evicted2, ws2) = tick' ws1 + (evicted3, ws3) = tick' ws2 + (evicted4, ws4) = tick' ws3 + (evicted5, ws5) = tick' ws4 + (evicted6, _) = tick' ws5 + in conjoin [ + failIf "evicted1 includes any of pending" (\e p -> disjoint (toTxIdSet p) e) evicted1 pending + , failIf "evicted2 includes any of pending" (\e p -> disjoint (toTxIdSet p) e) evicted2 pending + , failIf "evicted3 includes any of pending" (\e p -> disjoint (toTxIdSet p) e) evicted3 pending + , failIf "evicted4 includes any of pending" (\e p -> disjoint (toTxIdSet p) e) evicted4 pending + , failIf "evicted5 doesn't contain all pending" (\e p -> (toTxIdSet p) `S.isSubsetOf` e) evicted5 pending + , failIf "evicted6 contains something from evicted5" (\e6 e5 -> disjoint e5 e6) evicted6 evicted5 + ] + + describe "tickSlot" $ do + -- Given A,B,C,D where D `dependsOn` C `dependsOn` B `dependsOn` A, + -- check that if these 4 are all scheduled within the same slot, they + -- are all scheduled for submission. + it "Given D->C->B->A all in the same slot, they are all sent" $ do + let generator = do (b,c,a,d) <- dependentTransactions + ws <- addPending (pendingFromTxs (map labelledTxAux [a,b,c,d])) . unSTB <$> genPureWalletSubmission + txs <- shuffle [b,c,a,d] + return $ STB (ws, txs) + forAll generator $ \(unSTB -> (submission, txs)) -> + let currentSlot = submission ^. getCurrentSlot + schedule = submission ^. getSchedule + nxtSlot = mapSlot succ currentSlot + scheduledEvents = fst (scheduledFor nxtSlot schedule) + -- Tick directly the next slot, as 'addPending' schedules + -- everything for @currentSlot + 1@. + result = tickSlot nxtSlot submission + in case result of + Left err -> property $ exception "tickSlot found a loop" (toException err) + Right (toSend, _, _) -> conjoin [ + includeEvents "[a,b,c,d] not scheduled" scheduledEvents txs + , S.fromList (toTxIds txs) `isSubsetOf` S.fromList (toTxIds toSend) + ] + + -- Given A,B,C,D where D `dependsOn` C `dependsOn` B `dependsOn` A, + -- if [A,B,C] are scheduled on slot 2 and [D] on slot 1, we shouldn't + -- send anything. + it "Given D->C->B->A, if C,B,A are in the future, D is not sent this slot" $ do + let generator = do (b,c,a,d) <- dependentTransactions + ws <- addPending (pendingFromTxs (map labelledTxAux [a,b,c])) . unSTB <$> genPureWalletSubmission + return $ STB (addPending (pendingFromTxs (map labelledTxAux [d])) (snd $ tick' ws), d) + forAll generator $ \(unSTB -> (submission, d)) -> + let currentSlot = submission ^. getCurrentSlot + schedule = submission ^. getSchedule + nxtSlot = mapSlot succ currentSlot + scheduledEvents = fst (scheduledFor nxtSlot schedule) + -- Tick directly the next slot, as 'addPending' schedules + -- everything for @currentSlot + 1@. + result = tickSlot nxtSlot submission + in case result of + Left err -> property $ exception "tickSlot found a loop" (toException err) + Right (toSend, _, _) -> conjoin [ + includeEvent "d scheduled" scheduledEvents d + , failIf "is subset of" + (\x y -> not $ S.isSubsetOf x y) + (S.fromList (toTxIds [d])) + (S.fromList (toTxIds toSend)) + ] + + -- Given A,B,C,D where D `dependsOn` C `dependsOn` B `dependsOn` A, if: + -- * [A,B] are scheduled on slot 1 + -- * [D] is scheduled on slot 2 + -- * [C] is scheduled on slot 3 + -- Then during slot 1 we would send both [A,B], on slot 2 we won't send + -- anything and finally on slot 3 we would send [C,D]. + it "Given D->C->B->A, can send [A,B] now, [D,C] in the future" $ do + let generator :: Gen (ShowThroughBuild (WalletSubmission Identity, [LabelledTxAux])) + generator = do (b,c,a,d) <- dependentTransactions + ws <- addPending (pendingFromTxs (map labelledTxAux [a,b])) . unSTB <$> genPureWalletSubmission + let (_, ws') = tick' ws + let ws'' = addPending (pendingFromTxs (map labelledTxAux [d])) ws' + return $ STB (ws'', [a,b,c,d]) + + forAll generator $ \(unSTB -> (submission1, [a,b,c,d])) -> + let slot1 = submission1 ^. getCurrentSlot + Right (scheduledInSlot1, confirmed1, _) = tickSlot slot1 submission1 + + -- Let's assume that @A@ and @B@ finally are adopted, + -- and the wallet calls 'remPending' on them. + modifyPending = addPending (pendingFromTxs (map labelledTxAux [c])) + . remPending (toTxIdSet (pendingFromTxs (map labelledTxAux [a,b]))) + (_, submission2) = fmap modifyPending (tick' submission1) + + -- We are in slot 2 now. During slot 2, @D@ is scheduled and + -- we add @C@ to be sent during slot 3. However, due to + -- the fact @D@ is depedent on @C@, the scheduler shouldn't + -- schedule @D@, this slot, which will end up in the + -- nursery. + slot2 = submission2 ^. getCurrentSlot + Right (scheduledInSlot2, confirmed2, _) = tickSlot slot2 submission2 + (_, submission3) = tick' submission2 + + -- Finally, during slot 3, both @C@ and @D@ are sent. + + slot3 = submission3 ^. getCurrentSlot + Right (scheduledInSlot3, confirmed3, _) = tickSlot slot3 submission3 + + in conjoin [ + slot1 === Slot 1 + , slot2 === Slot 2 + , slot3 === Slot 3 + , includeEvents "[a,b] scheduled slot 1" (ScheduleEvents scheduledInSlot1 confirmed1) [a,b] + , mustNotIncludeEvents "none of [a,b,c,d] was scheduled" (ScheduleEvents scheduledInSlot2 confirmed2) [a,b,c,d] + , includeEvents "[c,d] scheduled slot 3" (ScheduleEvents scheduledInSlot3 confirmed3) [c,d] + ] diff --git a/wallet-new/test/unit/Test/Spec/Translation.hs b/wallet-new/test/unit/Test/Spec/Translation.hs new file mode 100644 index 00000000000..150b72df172 --- /dev/null +++ b/wallet-new/test/unit/Test/Spec/Translation.hs @@ -0,0 +1,340 @@ +module Test.Spec.Translation ( + spec + ) where + +import Universum + +import qualified Data.Set as Set +import qualified Data.Text.Buildable +import Formatting (bprint, build, shown, (%)) +import Pos.Core.Chrono +import Serokell.Util (mapJson) +import Test.Hspec.QuickCheck + +import qualified Pos.Block.Error as Cardano +import qualified Pos.Txp.Toil as Cardano +import Pos.Core (Coeff (..), TxSizeLinear (..), getCoin) + +import Test.Infrastructure.Generator +import Test.Infrastructure.Genesis +import Util.Buildable.Hspec +import Util.Buildable.QuickCheck +import Util.Validated +import UTxO.Bootstrap +import UTxO.Context +import UTxO.DSL +import UTxO.Interpreter +import UTxO.Translate + +{------------------------------------------------------------------------------- + UTxO->Cardano translation tests +-------------------------------------------------------------------------------} + +spec :: Spec +spec = do + describe "Translation sanity checks" $ do + it "can construct and verify empty block" $ + intAndVerifyPure linearFeePolicy emptyBlock `shouldSatisfy` expectValid + + it "can construct and verify block with one transaction" $ + intAndVerifyPure linearFeePolicy oneTrans `shouldSatisfy` expectValid + + it "can construct and verify example 1 from the UTxO paper" $ + intAndVerifyPure linearFeePolicy example1 `shouldSatisfy` expectValid + + it "can reject overspending" $ + intAndVerifyPure linearFeePolicy overspend `shouldSatisfy` expectInvalid + + it "can reject double spending" $ + intAndVerifyPure linearFeePolicy doublespend `shouldSatisfy` expectInvalid + + describe "Translation QuickCheck tests" $ do + prop "can translate randomly generated chains" $ + forAll + (intAndVerifyGen (genChainUsingModel . cardanoModel linearFeePolicy)) + expectValid + + where + + linearFeePolicy = TxSizeLinear (Coeff 155381) (Coeff 43.946) + +{------------------------------------------------------------------------------- + Example hand-constructed chains +-------------------------------------------------------------------------------} + +emptyBlock :: GenesisValues h -> Chain h a +emptyBlock _ = OldestFirst [OldestFirst []] + +oneTrans :: Hash h Addr => GenesisValues h -> Chain h Addr +oneTrans GenesisValues{..} = OldestFirst [OldestFirst [t1]] + where + fee1 = overestimate txFee 1 2 + t1 = Transaction { + trFresh = 0 + , trFee = fee1 + , trHash = 1 + , trIns = Set.fromList [ Input hashBoot 0 ] -- rich 0 + , trOuts = [ Output r1 1000 + , Output r0 (initR0 - 1000 - fee1) + ] + , trExtra = ["t1"] + } + +-- | Try to transfer from R0 to R1, but leaving R0's balance the same +overspend :: Hash h Addr => GenesisValues h -> Chain h Addr +overspend GenesisValues{..} = OldestFirst [OldestFirst [t1]] + where + fee1 = overestimate txFee 1 2 + t1 = Transaction { + trFresh = 0 + , trFee = fee1 + , trHash = 1 + , trIns = Set.fromList [ Input hashBoot 0 ] -- rich 0 + , trOuts = [ Output r1 1000 + , Output r0 initR0 + ] + , trExtra = ["t1"] + } + +-- | Try to transfer to R1 and R2 using the same output +doublespend :: Hash h Addr => GenesisValues h -> Chain h Addr +doublespend GenesisValues{..} = OldestFirst [OldestFirst [t1, t2]] + where + fee1 = overestimate txFee 1 2 + t1 = Transaction { + trFresh = 0 + , trFee = fee1 + , trHash = 1 + , trIns = Set.fromList [ Input hashBoot 0 ] -- rich 0 + , trOuts = [ Output r1 1000 + , Output r0 (initR0 - 1000 - fee1) + ] + , trExtra = ["t1"] + } + + fee2 = overestimate txFee 1 2 + t2 = Transaction { + trFresh = 0 + , trFee = fee2 + , trHash = 2 + , trIns = Set.fromList [ Input hashBoot 0 ] -- rich 0 + , trOuts = [ Output r2 1000 + , Output r0 (initR0 - 1000 - fee2) + ] + , trExtra = ["t2"] + } + +-- | Translation of example 1 of the paper, adjusted to allow for fees +-- +-- Transaction t1 in the example creates new coins, and transaction t2 +-- tranfers this to an ordinary address. In other words, t1 and t2 +-- corresponds to the bootstrap transactions. +-- +-- Transaction t3 then transfers part of R0's balance to R1, returning the +-- rest to back to R0; and t4 transfers the remainder of R0's balance to +-- R2. +-- +-- Transaction 5 in example 1 is a transaction /from/ the treasury /to/ an +-- ordinary address. This currently has no equivalent in Cardano, so we omit +-- it. +example1 :: Hash h Addr => GenesisValues h -> Chain h Addr +example1 GenesisValues{..} = OldestFirst [OldestFirst [t3, t4]] + where + fee3 = overestimate txFee 1 2 + t3 = Transaction { + trFresh = 0 + , trFee = fee3 + , trHash = 3 + , trIns = Set.fromList [ Input hashBoot 0 ] -- rich 0 + , trOuts = [ Output r1 1000 + , Output r0 (initR0 - 1000 - fee3) + ] + , trExtra = ["t3"] + } + + fee4 = overestimate txFee 1 1 + t4 = Transaction { + trFresh = 0 + , trFee = fee4 + , trHash = 4 + , trIns = Set.fromList [ Input (hash t3) 1 ] + , trOuts = [ Output r2 (initR0 - 1000 - fee3 - fee4) ] + , trExtra = ["t4"] + } + +-- | Over-estimate the total fee, by assuming the resulting transaction is +-- as large as possible for the given number of inputs and outputs. +overestimate :: (Int -> [Value] -> Value) -> Int -> Int -> Value +overestimate getFee ins outs = getFee ins (replicate outs (getCoin maxBound)) + +{------------------------------------------------------------------------------- + Verify chain +-------------------------------------------------------------------------------} + +intAndVerifyPure :: TxSizeLinear + -> (GenesisValues GivenHash -> Chain GivenHash Addr) + -> ValidationResult GivenHash Addr +intAndVerifyPure txSizeLinear pc = runIdentity $ intAndVerify (Identity . pc . genesisValues txSizeLinear) + +-- | Specialization of 'intAndVerify' to 'Gen' +intAndVerifyGen :: (Transaction GivenHash Addr -> Gen (Chain GivenHash Addr)) + -> Gen (ValidationResult GivenHash Addr) +intAndVerifyGen = intAndVerify + +-- | Specialization of 'intAndVerifyChain' to 'GivenHash' +intAndVerify :: Monad m + => (Transaction GivenHash Addr -> m (Chain GivenHash Addr)) + -> m (ValidationResult GivenHash Addr) +intAndVerify = intAndVerifyChain + +-- | Interpret and verify a chain. +intAndVerifyChain :: (Hash h Addr, Monad m) + => (Transaction h Addr -> m (Chain h Addr)) + -> m (ValidationResult h Addr) +intAndVerifyChain pc = runTranslateT $ do + boot <- asks bootstrapTransaction + chain <- lift $ pc boot + let ledger = chainToLedger boot chain + dslIsValid = ledgerIsValid ledger + dslUtxo = ledgerUtxo ledger + intResult <- catchTranslateErrors $ runIntBoot' boot $ int chain + case intResult of + Left e -> + case dslIsValid of + Valid () -> return $ Disagreement ledger (UnexpectedError e) + Invalid _ e' -> return $ ExpectedInvalid' e' e + Right (chain', ctxt) -> do + let chain'' = fromMaybe (error "intAndVerify: Nothing") + $ nonEmptyOldestFirst + $ map Right chain' + isCardanoValid <- verifyBlocksPrefix chain'' + case (dslIsValid, isCardanoValid) of + (Invalid _ e' , Invalid _ e) -> return $ ExpectedInvalid e' e + (Invalid _ e' , Valid _) -> return $ Disagreement ledger (UnexpectedValid e') + (Valid () , Invalid _ e) -> return $ Disagreement ledger (UnexpectedInvalid e) + (Valid () , Valid (_undo, finalUtxo)) -> do + (finalUtxo', _) <- runIntT' ctxt $ int dslUtxo + if finalUtxo == finalUtxo' + then return $ ExpectedValid + else return $ Disagreement ledger UnexpectedUtxo { + utxoDsl = dslUtxo + , utxoCardano = finalUtxo + , utxoInt = finalUtxo' + } + +{------------------------------------------------------------------------------- + Chain verification test result +-------------------------------------------------------------------------------} + +data ValidationResult h a = + -- | We expected the chain to be valid; DSL and Cardano both agree + ExpectedValid + + -- | We expected the chain to be invalid; DSL and Cardano both agree + | ExpectedInvalid { + validationErrorDsl :: Text + , validationErrorCardano :: Cardano.VerifyBlocksException + } + + -- | Variation on 'ExpectedInvalid', where we cannot even /construct/ + -- the Cardano chain, much less validate it. + | ExpectedInvalid' { + validationErrorDsl :: Text + , validationErrorInt :: IntException + } + + -- | Disagreement between the DSL and Cardano + -- + -- This indicates a bug. Of course, the bug could be in any number of + -- places: + -- + -- * Our translatiom from the DSL to Cardano is wrong + -- * There is a bug in the DSL definitions + -- * There is a bug in the Cardano implementation + -- + -- We record the error message from Cardano, if Cardano thought the chain + -- was invalid, as well as the ledger that causes the problem. + | Disagreement { + validationLedger :: Ledger h a + , validationDisagreement :: Disagreement h a + } + +-- | Disagreement between Cardano and the DSL +-- +-- We consider something to be "unexpectedly foo" when Cardano says it's +-- " foo " but the DSL says it's " not foo "; the DSL is the spec, after all +-- (of course that doesn't mean that it cannot contain bugs :). +data Disagreement h a = + -- | Cardano reported the chain as invalid, but the DSL reported it as + -- valid. We record the error message from Cardano. + UnexpectedInvalid Cardano.VerifyBlocksException + + -- | Cardano reported an error during chain translation, but the DSL + -- reported it as valid. + | UnexpectedError IntException + + -- | Cardano reported the chain as valid, but the DSL reported it as + -- invalid. + | UnexpectedValid Text + + -- | Both Cardano and the DSL reported the chain as valid, but they computed + -- a different UTxO + | UnexpectedUtxo { + utxoDsl :: Utxo h a + , utxoCardano :: Cardano.Utxo + , utxoInt :: Cardano.Utxo + } + +expectValid :: ValidationResult h a -> Bool +expectValid ExpectedValid = True +expectValid _otherwise = False + +expectInvalid :: ValidationResult h a -> Bool +expectInvalid (ExpectedInvalid _ _) = True +expectInvalid _otherwise = False + +{------------------------------------------------------------------------------- + Pretty-printing +-------------------------------------------------------------------------------} + +instance (Hash h a, Buildable a) => Buildable (ValidationResult h a) where + build ExpectedValid = "ExpectedValid" + build ExpectedInvalid{..} = bprint + ( "ExpectedInvalid" + % ", errorDsl: " % build + % ", errorCardano: " % build + % "}" + ) + validationErrorDsl + validationErrorCardano + build ExpectedInvalid'{..} = bprint + ( "ExpectedInvalid'" + % ", errorDsl: " % build + % ", errorInt: " % build + % "}" + ) + validationErrorDsl + validationErrorInt + build Disagreement{..} = bprint + ( "Disagreement " + % "{ ledger: " % build + % ", disagreement: " % build + % "}" + ) + validationLedger + validationDisagreement + +instance (Hash h a, Buildable a) => Buildable (Disagreement h a) where + build (UnexpectedInvalid e) = bprint ("UnexpectedInvalid " % build) e + build (UnexpectedError e) = bprint ("UnexpectedError " % shown) e + build (UnexpectedValid e) = bprint ("UnexpectedValid " % shown) e + build UnexpectedUtxo{..} = bprint + ( "UnexpectedUtxo" + % "{ dsl: " % build + % ", cardano: " % mapJson + % ", int: " % mapJson + % "}" + ) + utxoDsl + utxoCardano + utxoInt diff --git a/wallet-new/test/unit/Test/Spec/WalletWorker.hs b/wallet-new/test/unit/Test/Spec/WalletWorker.hs new file mode 100644 index 00000000000..12293494d25 --- /dev/null +++ b/wallet-new/test/unit/Test/Spec/WalletWorker.hs @@ -0,0 +1,134 @@ +module Test.Spec.WalletWorker ( + spec + ) where + +import Universum + +import qualified Data.Text.Buildable +import Formatting (bprint, shown, (%)) +import Pos.Core.Chrono +import Test.QuickCheck (arbitrary, frequency, listOf, suchThat) + +import Util.Buildable.Hspec +import Util.Buildable.QuickCheck + +import qualified Cardano.Wallet.Kernel.Actions as Actions + +-- declares Arbitrary instance for Text +import Test.QuickCheck.Instances () + +{------------------------------------------------------------------------------- + Wallet worker state machine tests +-------------------------------------------------------------------------------} + +spec :: Spec +spec = do + describe "Test wallet worker state machine" $ do + + it "Starts in a valid initial state with no effect on the wallet" $ do + let StackResult{..} = runStackWorker [] $ Stack [1..10] + srState `shouldSatisfy` Actions.isValidState + srState `shouldSatisfy` Actions.isInitialState + srStack `shouldBe` Stack [1..10] + + it "State invariants are not violated" $ forAll (listOf someAction) $ + \actions -> Actions.isValidState (srState $ runStackWorker actions $ Stack [1..5]) + + it "Applies blocks immediately from its initial state" $ do + let actions = [ Actions.ApplyBlocks (OldestFirst $ 1:|[2,3]) ] + StackResult{..} = runStackWorker actions $ Stack [] + srStack `shouldBe` Stack [3,2,1] + + it "Applies blocks in the correct order" $ do + let actions = [ Actions.ApplyBlocks $ OldestFirst $ 1:|[2,3] + , Actions.ApplyBlocks $ OldestFirst $ 4:|[5,6] ] + StackResult{..} = runStackWorker actions $ Stack [] + srStack `shouldBe` Stack [6,5,4,3,2,1] + + it "Can switch to a new fork" $ do + let actions = [ Actions.ApplyBlocks $ OldestFirst $ 1:|[2,3] + , Actions.RollbackBlocks $ NewestFirst $ 3:|[2] + , Actions.ApplyBlocks $ OldestFirst $ 4:|[5,6] ] + StackResult{..} = runStackWorker actions $ Stack [] + srState `shouldSatisfy` (not . Actions.hasPendingFork) + srStack `shouldBe` Stack [6,5,4,1] + + it "Can switch to a new fork by combining actions" $ do + let actions = [ Actions.ApplyBlocks $ OldestFirst $ 1:|[2,3] + , Actions.RollbackBlocks $ NewestFirst $ 3:|[2] + , Actions.ApplyBlocks $ OldestFirst $ 4:|[] + , Actions.ApplyBlocks $ OldestFirst $ 5:|[6] ] + StackResult{..} = runStackWorker actions $ Stack [] + srState `shouldSatisfy` (not . Actions.hasPendingFork) + srStack `shouldBe` Stack [6,5,4,1] + + it "Behaves like the simple stack model, when there is no pending fork" $ do + let stk0 = Stack [1..100] + run = (`runStackWorker` stk0) + doesNotResultInFork = not . Actions.hasPendingFork . srState . run + forAll (listOf someAction `suchThat` doesNotResultInFork) $ + \actions -> do + let StackResult{..} = run actions + expectedStack = execState (mapM actionToStackOp actions) stk0 + srStack `shouldBe` expectedStack + + where + runStackWorker :: [Actions.WalletAction Int] -> Stack -> StackResult + runStackWorker actions stk0 = + let (s, stk) = runState (Actions.interpList stackOps actions) stk0 + in StackResult { srState = s, srStack = stk } + + -- Bias the actions slightly towards increasing the blockchain size + someAction :: Gen (Actions.WalletAction Int) + someAction = frequency [ (10, (Actions.ApplyBlocks . OldestFirst) <$> arbitrary) + , (7, (Actions.RollbackBlocks . NewestFirst) <$> arbitrary) + , (1, Actions.LogMessage <$> arbitrary) + ] + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +data StackResult = StackResult + { srState :: Actions.WalletWorkerState Int + , srStack :: Stack + } + +stackOps :: Actions.WalletActionInterp (State Stack) Int +stackOps = Actions.WalletActionInterp + { Actions.applyBlocks = mapM_ push + , Actions.switchToFork = \n bs -> do + replicateM_ n pop + mapM_ push bs + , Actions.emit = const (return ()) + } + where + push = interpStackOp . Push + pop = interpStackOp Pop + +data StackOp = Push Int | Pop +newtype Stack = Stack [Int] + deriving (Eq, Show) + +interpStackOp :: StackOp -> State Stack () +interpStackOp op = modify $ \stk -> + case (op, stk) of + (Push x, Stack xs) -> Stack (x:xs) + (Pop, Stack (_:xs)) -> Stack xs + (Pop, Stack []) -> Stack [] + +actionToStackOp :: Actions.WalletAction Int -> State Stack () +actionToStackOp = \case + Actions.ApplyBlocks bs -> mapM_ push bs + Actions.RollbackBlocks bs -> mapM_ (const pop) bs + Actions.LogMessage _ -> return () + where + push = interpStackOp . Push + pop = interpStackOp Pop + +{------------------------------------------------------------------------------- + Pretty-printing +-------------------------------------------------------------------------------} + +instance Buildable Stack where + build (Stack stk) = bprint ("Stack " % shown) stk diff --git a/wallet-new/test/unit/TxMetaStorageSpecs.hs b/wallet-new/test/unit/TxMetaStorageSpecs.hs new file mode 100644 index 00000000000..25916e738c1 --- /dev/null +++ b/wallet-new/test/unit/TxMetaStorageSpecs.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE RankNTypes #-} +module TxMetaStorageSpecs (txMetaStorageSpecs) where + +import Universum + +import Cardano.Wallet.Kernel.DB.TxMeta +import Control.Exception.Safe (bracket) +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Set as Set +import Data.Text.Buildable (build) +import qualified Prelude + +import qualified Pos.Core as Core + +import Formatting (bprint) +import Serokell.Util.Text (listJsonIndent, pairF) +import Test.Hspec (shouldThrow) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (Arbitrary, Gen, arbitrary, forAll, vectorOf) +import Test.QuickCheck.Monadic (assert, monadicIO, pick, run) +import Util.Buildable (ShowThroughBuild (..)) +import Util.Buildable.Hspec + + + +chunksOf :: Int -> [e] -> [[e]] +chunksOf i ls = map (take i) (buildCons (splitter ls)) + where + splitter :: [e] -> ([e] -> a -> a) -> a -> a + splitter [] _ n = n + splitter l c n = l `c` splitter (drop i l) c n + + buildCons :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] + buildCons g = g (:) [] + + +-- | Handy combinator which yields a fresh database to work with on each spec. +withTemporaryDb :: forall m a. (MonadIO m, MonadMask m) => (MetaDBHandle -> m a) -> m a +withTemporaryDb action = bracket acquire release action + where + acquire :: m MetaDBHandle + acquire = liftIO $ do + db <- openMetaDB ":memory:" + migrateMetaDB db + return db + + release :: MetaDBHandle -> m () + release = liftIO . closeMetaDB + + +-- | Generates two 'TxMeta' which are @almost@ identical, if not in the +-- arrangement of their inputs & outputs. +genSimilarTxMetas :: Gen (ShowThroughBuild TxMeta, ShowThroughBuild TxMeta) +genSimilarTxMetas = do + inputs <- uniqueElements 5 + outputs <- uniqueElements 5 + blueprint <- unSTB <$> genMeta + let t1 = blueprint & over txMetaInputs (const inputs) + . over txMetaOutputs (const outputs) + let t2 = blueprint & over txMetaInputs (const (NonEmpty.reverse inputs)) + . over txMetaOutputs (const (NonEmpty.reverse outputs)) + return (STB t1, STB t2) + +-- | Synthetic @newtype@ used to generate unique inputs and outputs as part of +-- 'genMetas'. The reason why it is necessary is because the stock implementation +-- of 'Eq' for '(Core.Address, Core.Coin)' would of course declare two tuples +-- equal if their elements are. +-- However, this is too \"strong\" for our 'uniqueElements' generator, which +-- would consider these two unique: +-- +-- ("123", 10) +-- ("123", 0) +-- +-- This would of course break our persistent storage, because inserting "123" +-- twice would trigger the primary key uniqueness violation. +newtype TxEntry = TxEntry { getTxEntry :: (Core.Address, Core.Coin) } + +instance Eq TxEntry where + (TxEntry (a1, _)) == (TxEntry (a2, _)) = a1 == a2 + +-- | This is a totally bonkers 'Ord' instance (as it doesn't really make sense +-- to order anything by an 'Address' value, but it's necessary for the sake +-- of the input and output generation. In particular, writing the following +-- will introduce a bug later on: +-- +-- instance Ord TxEntry where +-- compare (TxEntry (_, c1)) (TxEntry (_, c2)) = compare c1 c2 +-- +-- This will speed up the tests considerably, but it comes with a fatal flaw: +-- later on, once generating unique inputs & outputs as part of 'uniqueElements', +-- we rely on a 'Set' (and thus an 'Ord' instance) to generate unique elements. +-- But the instance above will 'compare' the two 'Coin' values and in turn +-- piggyback on equality for Coins, essentially trashing the invariant we +-- describe above as the entire @raison d'etre@ for the 'TxEntry' type. +instance Ord TxEntry where + compare (TxEntry (a1, _)) (TxEntry (a2, _)) = compare a1 a2 + +instance Arbitrary TxEntry where + arbitrary = TxEntry <$> arbitrary + +instance Buildable TxEntry where + build (TxEntry b) = bprint pairF b + +instance Buildable (Int, TxEntry) where + build b = bprint pairF b + +instance Buildable [TxEntry] where + build = bprint (listJsonIndent 4) + +-- | Handy generator which make sure we are generating 'TxMeta' which all +-- have distinct inputs and outptus. +genMetas :: Int -> Gen [ShowThroughBuild TxMeta] +genMetas size = do + metas <- map unSTB <$> vectorOf size genMeta + inputs <- chunksOf 3 . toList <$> uniqueElements (length metas * 3) + outputs <- chunksOf 3 . toList <$> uniqueElements (length metas * 3) + return $ map (STB . mkTx) (Prelude.zip3 metas inputs outputs) + + where + mkTx :: (TxMeta, [TxEntry], [TxEntry]) + -> TxMeta + mkTx (tMeta, i, o) = + case liftM2 (,) (nonEmpty . map getTxEntry $ i) (nonEmpty . map getTxEntry $ o) of + Nothing -> error "mkTx: the impossible happened, invariant violated." + Just (inputs, outputs) -> + tMeta & over txMetaInputs (const inputs) + . over txMetaOutputs (const outputs) + +-- | Generator for an arbitrary 'TxMeta' which uses 'TxEntry' underneath to +-- generate the inputs and the outputs. +genMeta :: Gen (ShowThroughBuild TxMeta) +genMeta = do + meta <- TxMeta <$> arbitrary + <*> arbitrary + <*> (fmap getTxEntry <$> uniqueElements 10) + <*> (fmap getTxEntry <$> uniqueElements 10) + <*> arbitrary + <*> arbitrary + <*> arbitrary + pure (STB meta) + +newtype TxMetaWrapper = TxMetaWrapper (ShowThroughBuild TxMeta) deriving Show + +instance Arbitrary TxMetaWrapper where + arbitrary = TxMetaWrapper <$> genMeta + +-- | Handy wrapper to be able to compare things with the 'isomorphicTo' +-- combinator, which ignores the different order of the inputs & outputs. +data DeepEqual = DeepEqual TxMeta + +instance Eq DeepEqual where + (DeepEqual t1) == (DeepEqual t2) = t1 `exactlyEqualTo` t2 + +instance Buildable DeepEqual where + build (DeepEqual t) = build t + +data Isomorphic = Isomorphic TxMeta + +instance Eq Isomorphic where + (Isomorphic t1) == (Isomorphic t2) = t1 `isomorphicTo` t2 + +instance Buildable Isomorphic where + build (Isomorphic t) = build t + +instance Buildable [Isomorphic] where + build ts = bprint (listJsonIndent 4) ts + +sortByAmount :: SortDirection -> [Isomorphic] -> [Isomorphic] +sortByAmount direction = sortBy sortFn + where + withDir Ascending = identity + withDir Descending = flip + + sortFn (Isomorphic a) (Isomorphic b) = + (withDir direction compare) (a ^. txMetaAmount) (b ^. txMetaAmount) + +sortByCreationAt :: SortDirection -> [Isomorphic] -> [Isomorphic] +sortByCreationAt direction = sortBy sortFn + where + withDir Ascending = identity + withDir Descending = flip + + sortFn (Isomorphic a) (Isomorphic b) = + (withDir direction compare) (a ^. txMetaCreationAt) (b ^. txMetaCreationAt) + + +hasDupes :: Ord a => [a] -> Bool +hasDupes xs = length (Set.fromList xs) /= List.length xs + +-- | Specs which tests the persistent storage and API provided by 'TxMeta'. +txMetaStorageSpecs :: Spec +txMetaStorageSpecs = do + describe "uniqueElements generator" $ do + it "generates unique inputs" $ monadicIO $ do + (inputs :: NonEmpty (ShowThroughBuild TxEntry)) <- pick (uniqueElements 30) + assert (not $ hasDupes . map unSTB . toList $ inputs) + + describe "TxMeta equality" $ do + prop "should be reflexive" $ \(TxMetaWrapper blueprint) -> do + unSTB blueprint `exactlyEqualTo` unSTB (blueprint :: ShowThroughBuild TxMeta) + + it "should be strict when needed" + $ forAll genSimilarTxMetas + $ \(STB t1, STB t2) -> not (t1 `exactlyEqualTo` t2) + + it "isomorphicTo is more lenient" + $ forAll genSimilarTxMetas + $ \(STB t1, STB t2) -> t1 `isomorphicTo` t2 + + describe "TxMeta storage" $ do + + it "can store a TxMeta and retrieve it back" $ monadicIO $ do + testMetaSTB <- pick genMeta + run $ withTemporaryDb $ \hdl -> do + let testMeta = unSTB testMetaSTB + void $ putTxMeta hdl testMeta + mbTx <- getTxMeta hdl (testMeta ^. txMetaId) + fmap DeepEqual mbTx `shouldBe` Just (DeepEqual testMeta) + + it "yields Nothing when calling getTxMeta, if a TxMeta is not there" $ monadicIO $ do + testMetaSTB <- pick genMeta + run $ withTemporaryDb $ \hdl -> do + let testMeta = unSTB testMetaSTB + mbTx <- getTxMeta hdl (testMeta ^. txMetaId) + fmap DeepEqual mbTx `shouldBe` Nothing + + it "inserting the same tx twice is a no-op" $ monadicIO $ do + testMetaSTB <- pick genMeta + run $ withTemporaryDb $ \hdl -> do + let testMeta = unSTB testMetaSTB + + putTxMeta hdl testMeta `shouldReturn` () + putTxMeta hdl testMeta `shouldReturn` () + + it "inserting two tx with the same tx, but different content is an error" $ monadicIO $ do + testMetaSTB <- pick genMeta + run $ withTemporaryDb $ \hdl -> do + let meta1 = unSTB testMetaSTB + let meta2 = set txMetaIsOutgoing (not $ meta1 ^. txMetaIsOutgoing) meta1 + + putTxMeta hdl meta1 `shouldReturn` () + putTxMeta hdl meta2 `shouldThrow` + (\(InvariantViolated (DuplicatedTransactionWithDifferentHash _)) -> True) + + it "inserting multiple txs and later retrieving all of them works" $ monadicIO $ do + testMetasSTB <- pick (genMetas 5) + run $ withTemporaryDb $ \hdl -> do + let metas = map unSTB testMetasSTB + forM_ metas (putTxMeta hdl) + result <- getTxMetas hdl (Offset 0) (Limit 100) Nothing + map Isomorphic result `shouldMatchList` map Isomorphic metas + + it "pagination correctly limit the results" $ monadicIO $ do + testMetasSTB <- pick (genMetas 10) + run $ withTemporaryDb $ \hdl -> do + let metas = map unSTB testMetasSTB + forM_ metas (putTxMeta hdl) + result <- getTxMetas hdl (Offset 0) (Limit 5) Nothing + length result `shouldBe` 5 + + it "pagination correctly sorts (ascending) the results" $ monadicIO $ do + testMetasSTB <- pick (genMetas 5) + run $ withTemporaryDb $ \hdl -> do + let metas = map unSTB testMetasSTB + forM_ metas (putTxMeta hdl) + result <- (getTxMetas hdl) (Offset 0) (Limit 10) (Just $ Sorting SortByAmount Ascending) + map Isomorphic result `shouldBe` sortByAmount Ascending (map Isomorphic metas) + + it "pagination correctly sorts (descending) the results" $ monadicIO $ do + testMetasSTB <- pick (genMetas 5) + run $ withTemporaryDb $ \hdl -> do + let metas = map unSTB testMetasSTB + forM_ metas (putTxMeta hdl) + result <- (getTxMetas hdl) (Offset 0) (Limit 10) (Just $ Sorting SortByCreationAt Descending) + map Isomorphic result `shouldBe` sortByCreationAt Descending (map Isomorphic metas) diff --git a/wallet-new/test/unit/UTxO/BlockGen.hs b/wallet-new/test/unit/UTxO/BlockGen.hs deleted file mode 100644 index 39b74c671e5..00000000000 --- a/wallet-new/test/unit/UTxO/BlockGen.hs +++ /dev/null @@ -1,221 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} - -module UTxO.BlockGen - ( genValidBlockchain - , divvyUp - , selectDestinations' - ) where - -import Universum hiding (use) - -import Control.Lens hiding (elements) -import Data.List.NonEmpty (NonEmpty (..)) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Pos.Util.Chrono -import Test.QuickCheck - -import Util.DepIndep -import UTxO.Context -import UTxO.DSL -import UTxO.PreChain - --- | Blockchain Generator Monad --- --- When generating transactions, we need to keep track of addresses, --- balances, and transaction IDs so that we can create valid future --- transactions without wasting time searching and validating. -newtype BlockGen h a - = BlockGen - { unBlockGen :: StateT (BlockGenCtx h) Gen a - } deriving (Functor, Applicative, Monad, MonadState (BlockGenCtx h)) - --- | The context and settings for generating arbitrary blockchains. -data BlockGenCtx h - = BlockGenCtx - { _bgcCurrentUtxo :: !(Utxo h Addr) - -- ^ The mapping of current addresses and their current account values. - , _bgcFreshHash :: !Int - -- ^ A fresh hash value for each new transaction. - , _bgcInputPartiesUpperLimit :: !Int - -- ^ The upper limit on the number of parties that may be selected as - -- inputs to a transaction - } - -makeLenses ''BlockGenCtx - -genValidBlockchain :: Hash h Addr => PreChain h Gen () -genValidBlockchain = toPreChain newChain - -toPreChain - :: Hash h Addr - => BlockGen h [[Value -> Transaction h Addr]] - -> PreChain h Gen () -toPreChain = toPreChainWith identity - -toPreChainWith - :: Hash h Addr - => (BlockGenCtx h -> BlockGenCtx h) - -> BlockGen h [[Value -> Transaction h Addr]] - -> PreChain h Gen () -toPreChainWith settings bg = DepIndep $ \boot -> do - ks <- runBlockGenWith settings boot bg - return $ \fees -> (markOldestFirst (zipFees ks fees), ()) - where - markOldestFirst = OldestFirst . fmap OldestFirst - --- | Given an initial bootstrap 'Transaction' and a function to customize --- the other settings in the 'BlockGenCtx', this function will initialize --- the generator and run the action provided. -runBlockGenWith - :: Hash h Addr - => (BlockGenCtx h -> BlockGenCtx h) - -> Transaction h Addr - -> BlockGen h a - -> Gen a -runBlockGenWith settings boot m = - evalStateT (unBlockGen m) (settings (initializeCtx boot)) - --- | Create an initial context from the boot transaction. -initializeCtx :: Hash h Addr => Transaction h Addr -> BlockGenCtx h -initializeCtx boot = BlockGenCtx {..} - where - _bgcCurrentUtxo = trUtxo boot - _bgcFreshHash = 1 - _bgcInputPartiesUpperLimit = 1 - --- | Lift a 'Gen' action into the 'BlockGen' monad. -liftGen :: Gen a -> BlockGen h a -liftGen = BlockGen . lift - --- | Provide a fresh hash value for a transaction. -freshHash :: BlockGen h Int -freshHash = do - i <- use bgcFreshHash - bgcFreshHash += 1 - pure i - -bgcNonAvvmUtxo :: Getter (BlockGenCtx h) (Utxo h Addr) -bgcNonAvvmUtxo = - bgcCurrentUtxo . to (utxoRestrictToAddr (not . isAvvmAddr)) - -selectSomeInputs :: Hash h Addr => BlockGen h (NonEmpty (Input h Addr, Output Addr)) -selectSomeInputs = do - utxoMap <- uses bgcNonAvvmUtxo utxoToMap - upperLimit <- use bgcInputPartiesUpperLimit - input1 <- liftGen $ elements (Map.toList utxoMap) - -- it seems likely that we'll want to weight the frequency of - -- just-one-input more heavily than lots-of-inputs - n <- liftGen . frequency $ zip - [upperLimit, upperLimit-1 .. 0] - (map pure [0 .. upperLimit]) - otherInputs <- loop (Map.delete (fst input1) utxoMap) n - pure (input1 :| otherInputs) - where - loop utxo n - | n <= 0 = pure [] - | otherwise = do - inp <- liftGen $ elements (Map.toList utxo) - rest <- loop (Map.delete (fst inp) utxo) (n - 1) - pure (inp : rest) - -selectDestinations :: Hash h Addr => Set (Input h Addr) -> BlockGen h (NonEmpty Addr) -selectDestinations notThese = - liftGen . selectDestinations' notThese =<< use bgcCurrentUtxo - -selectDestinations' - :: Hash h Addr - => Set (Input h Addr) - -> Utxo h Addr - -> Gen (NonEmpty Addr) -selectDestinations' notThese = - fmap pure . elements - . map (outAddr . snd) . utxoToList - . utxoRestrictToAddr (not . isAvvmAddr) - . utxoRemoveInputs notThese - --- | Create a fresh transaction that depends on the fee provided to it. -newTransaction :: (HasCallStack, Hash h Addr) - => BlockGen h (Value -> Transaction h Addr) -newTransaction = do - inputs'outputs <- selectSomeInputs - destinations <- selectDestinations (foldMap Set.singleton (map fst inputs'outputs)) - hash' <- freshHash - - let txn = divvyUp hash' inputs'outputs destinations - - -- We don't know the fee yet, but /do/ need to make it possible to - -- generate different kinds of transactions (i.e., different kinds of - -- monadic effects) depending on the UTxO. This means that we must be - -- conversative here. - bgcCurrentUtxo %= utxoApply (withEstimatedFee txn) - pure txn - --- | Given a set of inputs, tagged with their output values, and a set of output --- addresses, construct a transaction by dividing the sum total of the inputs --- evenly over the output addresses. -divvyUp - :: (HasCallStack, Hash h Addr) - => Int - -> NonEmpty (Input h Addr, Output Addr) - -> NonEmpty Addr - -> Value - -> Transaction h Addr -divvyUp h inputs'outputs destinations fee = tx - where - tx = Transaction { - trFresh = 0 - , trFee = fee - , trHash = h - , trIns = inputs - , trOuts = outputs - , trExtra = [] - } - inputs = foldMap (Set.singleton . fst) inputs'outputs - destLen = fromIntegral (length destinations) - -- if we don't know what the fee is yet (eg a 0), then we want to use - -- the max fee for safety's sake - totalValue = sum (map (outVal . snd) inputs'outputs) - `safeSubtract` if fee == 0 then estimateFee tx else fee - valPerOutput = totalValue `div` destLen - outputs = toList (map (\addr -> Output addr valPerOutput) destinations) - --- | 'Value' is an alias for 'Word64', which underflows. This detects --- underflow and returns @0@ for underflowing values. -safeSubtract :: Value -> Value -> Value -safeSubtract x y - | z > x = 0 - | otherwise = z - where - z = x - y - --- | Conversatively estimate the fee for this transaction --- --- Result may be larger than the minimum fee, but not smaller. --- TODO: Right now this does not take the transaction structure into account. --- We should come up with a more precise model here. -estimateFee :: Transaction h a -> Value -estimateFee _ = maxFee - where - maxFee = 180000 - -withEstimatedFee :: (Value -> Transaction h a) -> Transaction h a -withEstimatedFee tx = let tx0 = tx 0 in tx0 { trFee = estimateFee tx0 } - -newBlock :: Hash h Addr => BlockGen h [Value -> Transaction h Addr] -newBlock = do - txnCount <- liftGen $ choose (1, 10) - replicateM txnCount newTransaction - -newChain :: Hash h Addr => BlockGen h [[Value -> Transaction h Addr]] -newChain = do - blockCount <- liftGen $ choose (10, 50) - replicateM blockCount newBlock - -zipFees - :: [[Value -> Transaction h Addr]] - -> ([[Value]] -> [[Transaction h Addr]]) -zipFees = zipWith (zipWith ($)) diff --git a/wallet-new/test/unit/UTxO/Context.hs b/wallet-new/test/unit/UTxO/Context.hs index 0af4b7d3a9d..7ba97399179 100644 --- a/wallet-new/test/unit/UTxO/Context.hs +++ b/wallet-new/test/unit/UTxO/Context.hs @@ -16,7 +16,10 @@ module UTxO.Context ( , ActorIx(..) , AddrIx , Addr(..) + , maxAddrSize , isAvvmAddr + , isPoorAddr + , AddrInfo(..) , AddrMap(..) , initAddrMap -- * Our custom context @@ -41,7 +44,6 @@ import Serokell.Util (listJson, mapJson, pairF) import Serokell.Util.Base16 (base16F) import Universum -import Pos.Block.Base import Pos.Core import Pos.Crypto import Pos.Lrc.Genesis @@ -73,12 +75,12 @@ data CardanoContext = CardanoContext { , ccHash0 :: HeaderHash } -initCardanoContext :: HasConfiguration => CardanoContext -initCardanoContext = CardanoContext{..} +initCardanoContext :: HasConfiguration => ProtocolMagic -> CardanoContext +initCardanoContext pm = CardanoContext{..} where - ccLeaders = genesisLeaders + ccLeaders = genesisLeaders epochSlots ccStakes = genesisStakes - ccBlock0 = genesisBlock0 + ccBlock0 = genesisBlock0 pm (GenesisHash genesisHash) ccLeaders ccData = genesisData ccUtxo = unGenesisUtxo genesisUtxo ccSecrets = fromMaybe (error "initCardanoContext: secrets unavailable") $ @@ -348,7 +350,13 @@ initActors CardanoContext{..} = Actors{..} -------------------------------------------------------------------------------} -- | Index the actors by number -data ActorIx = IxRich Int | IxPoor Int | IxAvvm Int +data ActorIx + = IxRich Int + | IxPoor Int + | IxAvvm Int + -- ^ AVVM refers to the special accounts set up at the start of the Cardano + -- blockchain that could then be redeemed from, once, for an initial balance. + -- They can never receive a deposit. deriving (Show, Eq, Ord) -- | Address index of a regular actor @@ -364,16 +372,44 @@ data Addr = Addr { } deriving (Show, Eq, Ord) --- | Returns true if the 'addrActorIx' is the 'IxAvvm' constructor. +-- | The maximum size in bytes of the serialized Cardano form of these addresses +-- +-- This is needed for fee estimation. +maxAddrSize :: Int +maxAddrSize = error "TODO: maxAddrSize: not defined!" + +-- | Returns true if this is the address of an AVVM account isAvvmAddr :: Addr -> Bool isAvvmAddr addr = case addrActorIx addr of IxAvvm _ -> True _ -> False +-- | Returns true if this is the address of a poor actor +isPoorAddr :: Addr -> Bool +isPoorAddr addr = + case addrActorIx addr of + IxPoor _ -> True + _ -> False + +-- | Information about the translation of a DSL address +data AddrInfo = AddrInfo { + -- | The master key for the actor owning this address (for HD addresses) + addrInfoMasterKey :: Maybe EncKeyPair + + -- | The key for this particular address + , addrInfoAddrKey :: SomeKeyPair + + -- | The Cardano address + , addrInfoCardano :: Address + } + -- | Mapping between our addresses and Cardano addresses data AddrMap = AddrMap { - addrMap :: Map Addr (SomeKeyPair, Address) + -- | Map from the DSL address to 'AddrInfo' + addrMap :: Map Addr AddrInfo + + -- | Reverse map from Cardano addresses to DSL addresses , addrRevMap :: Map Address Addr } @@ -381,37 +417,49 @@ data AddrMap = AddrMap { initAddrMap :: Actors -> AddrMap initAddrMap Actors{..} = AddrMap{ addrMap = Map.fromList mkMap - , addrRevMap = Map.fromList $ map (swap . second snd) mkMap + , addrRevMap = Map.fromList $ map (swap . second addrInfoCardano) mkMap } where - mkMap :: [(Addr, (SomeKeyPair, Address))] + mkMap :: [(Addr, AddrInfo)] mkMap = concat [ zipWith mkRich [0..] (Map.elems actorsRich) , concat $ zipWith mkPoor [0..] (Map.elems actorsPoor) , zipWith mkAvvm [0..] (Map.elems actorsAvvm) ] - mkRich :: Int -> Rich -> (Addr, (SomeKeyPair, Address)) + mkRich :: Int -> Rich -> (Addr, AddrInfo) mkRich actorIx Rich{..} = ( Addr (IxRich actorIx) 0 - , (KeyPairRegular richKey, richAddr) + , AddrInfo { + addrInfoMasterKey = Nothing + , addrInfoAddrKey = KeyPairRegular richKey + , addrInfoCardano = richAddr + } ) - mkPoor :: Int -> Poor -> [(Addr, (SomeKeyPair, Address))] + mkPoor :: Int -> Poor -> [(Addr, AddrInfo)] mkPoor actorIx Poor{..} = zipWith poorRawAddr [0..] poorAddrs where poorRawAddr :: Int -> (EncKeyPair, Address) - -> (Addr, (SomeKeyPair, Address)) + -> (Addr, AddrInfo) poorRawAddr addrIx (ekp, addr) = ( Addr (IxPoor actorIx) addrIx - , (KeyPairEncrypted ekp, addr) + , AddrInfo { + addrInfoMasterKey = Just poorKey + , addrInfoAddrKey = KeyPairEncrypted ekp + , addrInfoCardano = addr + } ) - mkAvvm :: Int -> Avvm -> (Addr, (SomeKeyPair, Address)) + mkAvvm :: Int -> Avvm -> (Addr, AddrInfo) mkAvvm actorIx Avvm{..} = ( Addr (IxAvvm actorIx) 0 - , (KeyPairRedeem avvmKey, avvmAddr) + , AddrInfo { + addrInfoMasterKey = Nothing + , addrInfoAddrKey = KeyPairRedeem avvmKey + , addrInfoCardano = avvmAddr + } ) {------------------------------------------------------------------------------- @@ -437,7 +485,7 @@ initContext tcCardano = TransCtxt{..} Derived information -------------------------------------------------------------------------------} -resolveAddr :: Addr -> TransCtxt -> (SomeKeyPair, Address) +resolveAddr :: Addr -> TransCtxt -> AddrInfo resolveAddr addr TransCtxt{..} = fromMaybe (error $ sformat ("resolveAddr: " % build % " not found") addr) @@ -572,11 +620,13 @@ instance Buildable CardanoContext where % "{ leaders: " % listJson % ", stakes: " % listJson % ", balances: " % listJson + % ", utxo: " % mapJson % "}" ) ccLeaders (map (bprint pairF) (HM.toList ccStakes)) (map (bprint pairF) ccBalances) + ccUtxo instance Buildable AddrMap where build AddrMap{..} = bprint diff --git a/wallet-new/test/unit/UTxO/DSL.hs b/wallet-new/test/unit/UTxO/DSL.hs index e90c1a69cee..3b737ae0bad 100644 --- a/wallet-new/test/unit/UTxO/DSL.hs +++ b/wallet-new/test/unit/UTxO/DSL.hs @@ -42,6 +42,8 @@ module UTxO.DSL ( -- * Hash , Hash(..) , GivenHash(..) + , IdentityAsHash + , givenHash , findHash , findHash' -- * Additional @@ -65,14 +67,14 @@ module UTxO.DSL ( , utxoAddressForInput -- ** Chain , Block - , Blocks - , Chain(..) + , Chain , chainToLedger , utxoApplyBlock ) where import Control.Exception (throw) import Control.Monad.Except (MonadError (..)) +import Data.Foldable (Foldable (..), foldr, sum) import Data.List (tail) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -80,10 +82,12 @@ import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Text.Buildable import Formatting (bprint, build, sformat, (%)) -import Pos.Util.Chrono +import Pos.Core.Chrono + (NewestFirst(NewestFirst), + OldestFirst(getOldestFirst)) import Prelude (Show (..)) import Serokell.Util (listJson, mapJson) -import Universum +import Universum hiding (Foldable, tail, toList, foldr, sum) import Util import Util.Validated @@ -132,9 +136,6 @@ data Transaction h a = Transaction { -- ^ Free-form comments, used for debugging } -deriving instance (Hash h a, Eq a) => Eq (Transaction h a) -deriving instance (Hash h a, Ord a) => Ord (Transaction h a) - -- | The inputs as a list -- -- Useful in various calculations @@ -205,7 +206,7 @@ trIsAcceptable t l = sequence_ [ inp -- | The effect this transaction has on the balance of an address -trBalance :: forall h a. (Hash h a, Eq a, Buildable a) +trBalance :: forall h a. (Hash h a, Eq a) => Address a -> Transaction h a -> Ledger h a -> Value trBalance a t l = received - spent where @@ -261,22 +262,38 @@ data Output a = Output { Inputs -------------------------------------------------------------------------------} -data Input h a = Input { - inpTrans :: h (Transaction h a) +data Input h a = Input + { inpTrans :: h (Transaction h a) + -- ^ The hash of the 'Transaction' where the 'Output' that this 'Input' + -- spends is found. , inpIndex :: Index + -- ^ Index to a particular 'Output' among the 'trOut' outputs in + -- the 'Transaction' idenfified by 'inpTrans'. Said 'Output' is the one + -- that this 'Input' is spending. } deriving instance Hash h a => Eq (Input h a) deriving instance Hash h a => Ord (Input h a) +-- | Obtain the 'Transaction' to which 'Input' refers. +-- +-- Returns 'Nothing' if the 'Transaction' is missing from the 'Ledger'. inpTransaction :: Hash h a => Input h a -> Ledger h a -> Maybe (Transaction h a) inpTransaction = findHash . inpTrans +-- | Obtain the 'Output' that the given 'Input' spent. +-- +-- Returns 'Nothing' if the 'Transaction' to which this 'Input' refers is +-- missing from the 'Ledger'. inpSpentOutput :: Hash h a => Input h a -> Ledger h a -> Maybe (Output a) inpSpentOutput i l = do t <- inpTransaction i l trOuts t `at` fromIntegral (inpIndex i) +-- | Obtain the 'Value' in the 'Output' spent by the given 'Input'. +-- +-- Returns 'Nothing' if the 'Transaction' to which this 'Input' refers is +-- missing from the 'Ledger'. inpVal :: Hash h a => Input h a -> Ledger h a -> Maybe Value inpVal i l = outVal <$> inpSpentOutput i l @@ -285,18 +302,18 @@ inpVal i l = outVal <$> inpSpentOutput i l transaction is known and the input index is correct -------------------------------------------------------------------------------} -inpTransaction' :: (Hash h a, Buildable a) +inpTransaction' :: (Hash h a) => Input h a -> Ledger h a -> Transaction h a inpTransaction' = findHash' . inpTrans -inpSpentOutput' :: (Hash h a, Buildable a, HasCallStack) +inpSpentOutput' :: (Hash h a, HasCallStack) => Input h a -> Ledger h a -> Output a inpSpentOutput' i l = fromJust err $ trOuts (inpTransaction' i l) `at` fromIntegral (inpIndex i) where err = sformat ("Input index out of bounds: " % build) i -inpVal' :: (Hash h a, Buildable a) => Input h a -> Ledger h a -> Value +inpVal' :: (Hash h a) => Input h a -> Ledger h a -> Value inpVal' i = outVal . inpSpentOutput' i {------------------------------------------------------------------------------- @@ -335,7 +352,7 @@ ledgerTails :: Ledger h a -> [(Transaction h a, Ledger h a)] ledgerTails (Ledger (NewestFirst l)) = zipWith (\t ts -> (t, Ledger (NewestFirst ts))) l (tail (tails l)) -ledgerBalance :: forall h a. (Hash h a, Eq a, Buildable a) +ledgerBalance :: forall h a. (Hash h a, Eq a) => Address a -> Ledger h a -> Value ledgerBalance a l = sum $ map (uncurry (trBalance a)) (ledgerTails l) @@ -396,7 +413,7 @@ findHash :: Hash h a findHash h l = find (\t -> hash t == h) (ledgerToNewestFirst l) -- | Variation on 'findHash', assumes hash refers to existing transaction -findHash' :: (Hash h a, Buildable a, HasCallStack) +findHash' :: (Hash h a, HasCallStack) => h (Transaction h a) -> Ledger h a -> Transaction h a findHash' h l = fromJust err (findHash h l) where @@ -497,14 +514,14 @@ utxoRemoveInputs inps (Utxo utxo) = Utxo (utxo `withoutKeys` inps) Additional: chain -------------------------------------------------------------------------------} -type Block h a = OldestFirst [] (Transaction h a) -type Blocks h a = OldestFirst [] (Block h a) +-- | Block of transactions +type Block h a = OldestFirst [] (Transaction h a) -- | A chain -- -- A chain is just a series of blocks, here modelled simply as the transactions -- they contain, since the rest of the block information can then be inferred. -data Chain h a = Chain { chainBlocks :: Blocks h a } +type Chain h a = OldestFirst [] (Block h a) chainToLedger :: Transaction h a -> Chain h a -> Ledger h a chainToLedger boot = Ledger @@ -512,7 +529,6 @@ chainToLedger boot = Ledger . reverse . (boot :) . concatMap toList . toList - . chainBlocks -- | Compute the UTxO after a block has been applied -- @@ -523,23 +539,50 @@ utxoApplyBlock :: forall h a. Hash h a => Block h a -> Utxo h a -> Utxo h a utxoApplyBlock = go . getOldestFirst where go :: [Transaction h a] -> Utxo h a -> Utxo h a - go [] = identity - go (t:ts) = go ts . utxoApply t + go [] u = u + go (t:ts) u = go ts (utxoApply t u) {------------------------------------------------------------------------------- Instantiating the hash to the identity - - NOTE: A lot of definitions in the DSL rely on comparing 'Input's. When using - 'Identity' as the " hash ", comparing 'Input's implies comparing their - 'Transactions', and hence the cost of comparing two inputs grows linearly - with their position in the chain. -------------------------------------------------------------------------------} -instance (Ord a, Buildable a) => Hash Identity a where - hash = Identity - -instance (Ord a, Buildable a) => Buildable (Identity (Transaction Identity a)) where - build (Identity t) = bprint build t +-- | Instantiate the hash to identity function +-- +-- NOTE: A lot of definitions in the DSL rely on comparing 'Input's. When using +-- 'Identity' as the " hash ", comparing 'Input's implies comparing their +-- 'Transactions', and hence the cost of comparing two inputs grows linearly +-- with their position in the chain. +newtype IdentityAsHash a = IdentityAsHash a + +-- | We define 'Eq' for @IdentityAsHash (Transaction h a)@ instead of +-- for @Transaction h a@ directly, as we normally don't want to compare +-- transactions, but rather transaction hashes. +instance (Hash h a, Eq a) => Eq (IdentityAsHash (Transaction h a)) where + IdentityAsHash tx1 == IdentityAsHash tx2 = and [ + trHash tx1 == trHash tx2 -- comparing given hash usually suffices + , trFresh tx1 == trFresh tx2 + , trIns tx1 == trIns tx2 + , trOuts tx1 == trOuts tx2 + , trFee tx1 == trFee tx2 + , trExtra tx1 == trExtra tx2 + ] + +-- | See comments for 'Eq' instance. +instance (Hash h a, Ord a) => Ord (IdentityAsHash (Transaction h a)) where + compare (IdentityAsHash tx1) (IdentityAsHash tx2) = mconcat [ + compare (trHash tx1) (trHash tx2) -- comparing given hash usually suffices + , compare (trFresh tx1) (trFresh tx2) + , compare (trIns tx1) (trIns tx2) + , compare (trOuts tx1) (trOuts tx2) + , compare (trFee tx1) (trFee tx2) + , compare (trExtra tx1) (trExtra tx2) + ] + +instance (Ord a, Buildable a) => Hash IdentityAsHash a where + hash = IdentityAsHash + +instance (Ord a, Buildable a) => Buildable (IdentityAsHash (Transaction IdentityAsHash a)) where + build (IdentityAsHash t) = bprint build t {------------------------------------------------------------------------------- Use the specified hash instead @@ -554,6 +597,10 @@ instance Buildable (GivenHash a) where instance Hash GivenHash a where hash = GivenHash . trHash +-- | The given hash is independent from any actual hash function +givenHash :: Transaction h a -> GivenHash (Transaction h a) +givenHash = GivenHash . trHash + {------------------------------------------------------------------------------- Pretty-printing -------------------------------------------------------------------------------} @@ -573,7 +620,7 @@ instance Buildable a => Buildable (Output a) where outAddr outVal -instance (Buildable a, Hash h a) => Buildable (Input h a) where +instance Hash h a => Buildable (Input h a) where build Input{..} = bprint ( "Input" % "{ trans: " % build @@ -588,7 +635,7 @@ instance (Buildable a, Hash h a) => Buildable (Transaction h a) where ( "Transaction" % "{ fresh: " % build % ", ins: " % listJson - % ", outs: " % listJson + % ", outs: " % mapJson % ", fee: " % build % ", hash: " % build % ", extra: " % listJson @@ -596,18 +643,22 @@ instance (Buildable a, Hash h a) => Buildable (Transaction h a) where ) trFresh trIns - trOuts + (Map.fromList (zip outputIndices trOuts)) trFee trHash trExtra + where + -- The output is easier to read when we see actual indices for outputs + outputIndices :: [Int] + outputIndices = [0..] instance (Buildable a, Hash h a) => Buildable (Chain h a) where - build Chain{..} = bprint + build blocks = bprint ( "Chain" % "{ blocks: " % listJson % "}" ) - chainBlocks + blocks instance ( Buildable a, Hash h a, Foldable f) => Buildable (NewestFirst f (Transaction h a)) where build ts = bprint ("NewestFirst " % listJson) (toList ts) diff --git a/wallet-new/test/unit/UTxO/Generator.hs b/wallet-new/test/unit/UTxO/Generator.hs new file mode 100644 index 00000000000..20ac57063b8 --- /dev/null +++ b/wallet-new/test/unit/UTxO/Generator.hs @@ -0,0 +1,348 @@ +{-# LANGUAGE TemplateHaskell #-} + +module UTxO.Generator ( + -- * Inputs + -- ** State + GenInpState(..) + , gisUtxo + , initInpState + -- ** Generator + , RemoveUsedInputs(..) + , GenInput + , genInput + -- * Outputs + -- ** Parameters + , GenOutParams(..) + , defOutParams + -- ** State + , GenOutState(..) + , gosAvailable + , initOutState + -- ** Generator + , GenOutput + , genOutput + -- * Transactions + -- ** Parameters + , GenTrParams(..) + , defTrParams + -- ** State + , GenTrState(..) + , gtsInpState + , gtsNextHash + , initTrState + -- ** Generator + , GenTransaction + , MakeOutputsAvailable(..) + , genTransaction + -- * Chains + -- ** Params + , GenChainParams(..) + , defChainParams + -- ** Generator + , genChain + -- * Auxiliary + , replicateAtMostM + ) where + +import Universum + +import Control.Lens (zoom, (%=), (.=), (<<+=)) +import Control.Lens.TH (makeLenses) +import qualified Data.Set as Set +import Pos.Core (maxCoinVal) +import Pos.Core.Chrono +import Test.QuickCheck + +import UTxO.DSL + +{------------------------------------------------------------------------------- + Generate transaction inputs +-------------------------------------------------------------------------------} + +-- | State needed for input generation +data GenInpState h a = GenInpState { + -- | Available UTxO + _gisUtxo :: Utxo h a + } + +makeLenses ''GenInpState + +-- | Initial 'GenInpState' +initInpState :: Utxo h a -> GenInpState h a +initInpState utxo = GenInpState { + _gisUtxo = utxo + } + +-- | Input generator +type GenInput h a = StateT (GenInpState h a) Gen + +-- | Should we remove used inputs? +data RemoveUsedInputs = RemoveUsedInputs | DontRemoveUsedInputs + +-- | Try to generate an input +-- +-- Returns nothing if the utxo is empty. +genInput :: Hash h a + => RemoveUsedInputs + -> Set (Input h a) -- Inputs to avoid + -> GenInput h a (Maybe (Input h a, Output a)) +genInput removeUsedInputs notThese = do + utxo <- utxoRemoveInputs notThese <$> use gisUtxo + if utxoNull utxo + then return Nothing + else do + (inp, out) <- lift $ elements (utxoToList utxo) + + case removeUsedInputs of + DontRemoveUsedInputs -> return () + RemoveUsedInputs -> gisUtxo .= utxoRemoveInputs (Set.singleton inp) utxo + + return $ Just (inp, out) + +-- | Generate up to @n@ distinct inputs +genDistinctInputs :: forall h a. Hash h a + => RemoveUsedInputs + -> Set (Input h a) -- Inputs to avoid + -> Int + -> GenInput h a [(Input h a, Output a)] +genDistinctInputs removeUsedInputs = go + where + go :: Set (Input h a) -> Int -> GenInput h a [(Input h a, Output a)] + go _ 0 = return [] + go notThese n = do + mInp <- genInput removeUsedInputs notThese + case mInp of + Nothing -> + return [] + Just (inp, out) -> + -- Removing used inputs or not, don't select same input twice + ((inp, out) :) <$> go (Set.insert inp notThese) (n - 1) + +{------------------------------------------------------------------------------- + Generate transaction outputs +-------------------------------------------------------------------------------} + +-- | Parameters for output generation +data GenOutParams a = GenOutParams { + -- | Addresses we can generate outputs to + gopAddresses :: [a] + } + +-- | Default 'GenOutParams' +defOutParams :: [a] -- ^ Addresses we can generate outputs to + -> GenOutParams a +defOutParams addresses = GenOutParams { + gopAddresses = addresses + } + +-- | State needed for output generation +data GenOutState = GenOutState { + -- | Value left + _gosAvailable :: Value + } + +makeLenses ''GenOutState + +-- | Initial 'GenOutState' +initOutState :: Value -> GenOutState +initOutState available = GenOutState { + _gosAvailable = available + } + +-- | Output generator +type GenOutput = StateT GenOutState Gen + +-- | Try to generate transaction output +-- +-- Returns nothing if there is no balance left. +genOutput :: GenOutParams a -> GenOutput (Maybe (Output a)) +genOutput GenOutParams{..} = do + available <- use gosAvailable + if available == 0 + then return Nothing + else do + addr <- lift $ elements gopAddresses + val <- lift $ choose (1, min available maxCoinVal) + gosAvailable .= available - val + return $ Just (Output addr val) + +{------------------------------------------------------------------------------- + Generate transaction +-------------------------------------------------------------------------------} + +-- | Parameters for transaction generation +data GenTrParams a = GenTrParams { + -- | Maximum number of inputs + -- + -- Generation is biased towards smaller values + gtpMaxNumInputs :: Int + + -- | Maximum number of outputs + -- + -- Generation does a uniform draw. + , gtpMaxNumOutputs :: Int + + -- | Fee model + -- + -- Provide fee given number of inputs and outputs + , gtpEstimateFee :: Int -> [Value] -> Value + + -- | Output parameters + , gtpOutParams :: GenOutParams a + } + +-- | Default 'GenTrParams' +defTrParams :: (Int -> [Value] -> Value) -- ^ Fee model + -> [a] -- ^ Addresses we can generate outputs to + -> GenTrParams a +defTrParams feeModel addresses = GenTrParams { + gtpMaxNumInputs = 3 + , gtpMaxNumOutputs = 3 + , gtpEstimateFee = feeModel + , gtpOutParams = defOutParams addresses + } + +-- | Should the outputs of the transaction be made available in the +-- input generation state? +data MakeOutputsAvailable = + -- | Yes, make outputs available + -- + -- This means that the next generation can refer to outputs of the + -- previous generated transaction. + MakeOutputsAvailable + + -- | No, don't make output available + -- + -- Use to generate independent transactions. + | DontMakeOutputsAvailable + +-- | State needed for transaction generation +data GenTrState h a = GenTrState { + -- | State needed to generate inputs + _gtsInpState :: GenInpState h a + + -- | Next hash + , _gtsNextHash :: Int + } + +makeLenses ''GenTrState + +-- | Initial 'GenTrState' +initTrState :: Utxo h a -- ^ Initial UTxO + -> Int -- ^ First available hash + -> GenTrState h a +initTrState utxo nextHash = GenTrState { + _gtsInpState = initInpState utxo + , _gtsNextHash = nextHash + } + +-- | Transaction generator +type GenTransaction h a = StateT (GenTrState h a) Gen + +-- | Try to generate a transaction +-- +-- Fails if no inputs were available. +genTransaction :: Hash h a + => GenTrParams a + -> RemoveUsedInputs + -> MakeOutputsAvailable + -> Set (Input h a) -- ^ Inputs to avoid + -> GenTransaction h a (Maybe (Transaction h a)) +genTransaction GenTrParams{..} removeUsedInputs makeOutputsAvailable notThese = do + numInputs <- lift $ chooseNumInputs + inputs <- zoom gtsInpState $ + genDistinctInputs removeUsedInputs notThese numInputs + + if null inputs + then return Nothing + else do + nextHash <- gtsNextHash <<+= 1 + numOutputs <- lift $ choose (1, gtpMaxNumOutputs) + + let inValue = sum (map (outVal . snd) inputs) + gos = initOutState inValue + + (outputs, gos') <- lift $ (`runStateT` gos) $ + replicateAtMostM numOutputs $ genOutput gtpOutParams + + let fee = gtpEstimateFee numInputs (map outVal outputs) + + if inValue <= fee || gos' ^. gosAvailable < fee + then return Nothing + else do + + let tr = Transaction { + trFresh = 0 + , trIns = Set.fromList (map fst inputs) + , trOuts = outputs + , trFee = fee + , trHash = nextHash + , trExtra = [] + } + + case makeOutputsAvailable of + DontMakeOutputsAvailable -> return () + MakeOutputsAvailable -> zoom gtsInpState $ + (gisUtxo %= utxoUnion (trUtxo tr)) + + return $ Just tr + where + -- Bias towards fewer inputs + chooseNumInputs :: Gen Int + chooseNumInputs = frequency $ zip [gtpMaxNumInputs, gtpMaxNumInputs-1 ..] + (map pure [1 .. gtpMaxNumInputs]) + +{------------------------------------------------------------------------------- + Chains +-------------------------------------------------------------------------------} + +data GenChainParams a = GenChainParams { + -- | Maximum number of transactions per block + gcpMaxBlockSize :: Int + + -- | Maximum number of blocks + , gcpMaxChainLength :: Int + + -- | Transaction parameters + , gcpTrParams :: GenTrParams a + } + +-- | Default 'GenChainParams' +defChainParams :: (Int -> [Value] -> Value) -- ^ Fee model + -> [a] -- ^ Address we can generate outputs for + -> GenChainParams a +defChainParams feeModel addresses = GenChainParams { + gcpMaxBlockSize = 20 + , gcpMaxChainLength = 10 + , gcpTrParams = defTrParams feeModel addresses + } + +-- | Generate an arbitrary chain +-- +-- The chain will have at least one block, but blocks may be empty. +genChain :: forall h a. Hash h a + => GenChainParams a -> GenTransaction h a (Chain h a) +genChain GenChainParams{..} = goChain + where + goChain :: GenTransaction h a (Chain h a) + goChain = OldestFirst <$> do + chainLength <- lift $ choose (1, gcpMaxChainLength) + replicateM chainLength goBlock + + goBlock :: GenTransaction h a (Block h a) + goBlock = OldestFirst <$> do + blockSize <- lift $ choose (0, gcpMaxBlockSize) + replicateAtMostM blockSize $ + genTransaction gcpTrParams RemoveUsedInputs MakeOutputsAvailable Set.empty + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +replicateAtMostM :: Monad m => Int -> m (Maybe a) -> m [a] +replicateAtMostM 0 _ = return [] +replicateAtMostM n f = do + ma <- f + case ma of + Just a -> (a :) <$> replicateAtMostM (n - 1) f + Nothing -> return [] diff --git a/wallet-new/test/unit/UTxO/Interpreter.hs b/wallet-new/test/unit/UTxO/Interpreter.hs index 96877e9e3d7..2b88162fdbb 100644 --- a/wallet-new/test/unit/UTxO/Interpreter.hs +++ b/wallet-new/test/unit/UTxO/Interpreter.hs @@ -8,30 +8,40 @@ module UTxO.Interpreter ( IntException(..) -- * Interpretation context , IntCtxt -- opaque + , initIntCtxt -- * Interpretation monad , IntT , runIntT + , runIntT' , runIntBoot + , runIntBoot' + , liftTranslate + , liftTranslateInt -- * Interpreter proper , Interpret(..) ) where +import Universum hiding (id) + +import Control.Arrow ((&&&)) import Data.Default (def) import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import qualified Data.Text.Buildable import Formatting (bprint, shown) import Prelude (Show (..)) -import Universum + +import Cardano.Wallet.Kernel.DB.Resolved +import Cardano.Wallet.Kernel.Types import Pos.Block.Logic import Pos.Client.Txp import Pos.Core +import Pos.Core.Chrono import Pos.Crypto import Pos.Ssc (defaultSscPayload) import Pos.Txp.Toil import Pos.Update -import Pos.Util.Chrono import UTxO.Bootstrap import UTxO.Context @@ -64,23 +74,41 @@ instance Buildable IntException where -------------------------------------------------------------------------------} -- | Interpretation context --- --- We need the ledger to resolve hashes, as well as the translation from --- DSL hashes to Cardano hashes. data IntCtxt h = IntCtxt { - icLedger :: DSL.Ledger h Addr - , icHashes :: Map (h (DSL.Transaction h Addr)) TxId + -- | Ledger we have interpreted so far + -- + -- This is needed to resolve DSL hashes to DSL transactions. + icLedger :: DSL.Ledger h Addr + + -- | Mapping from DSL hashes to Cardano hashes + , icHashes :: Map (h (DSL.Transaction h Addr)) TxId + + -- | Slot number for the next block to be translated + , icNextSlot :: SlotId + + -- | The header of the last block we translated + -- + -- In other words, the " previous " pointer for the next block to be + -- translated. + -- + -- Will be initialized to the header of the genesis block. + , icPrevBlock :: BlockHeader } -- | Initial interpretation context -- -- NOTE: In Cardano there is no equivalent of the boot transaction and hence -- no hash of the boot transaction. -initIntCtxt :: DSL.Transaction h Addr -> IntCtxt h -initIntCtxt boot = IntCtxt { - icLedger = DSL.ledgerSingleton boot - , icHashes = Map.empty - } +initIntCtxt :: Monad m => DSL.Transaction h Addr -> TranslateT IntException m (IntCtxt h) +initIntCtxt boot = do + firstSlot <- mapTranslateErrors IntExMkSlot $ translateFirstSlot + genesis <- BlockHeaderGenesis <$> translateGenesisHeader + return $ IntCtxt { + icLedger = DSL.ledgerSingleton boot + , icHashes = Map.empty + , icNextSlot = firstSlot + , icPrevBlock = genesis + } {------------------------------------------------------------------------------- The interpretation monad @@ -90,63 +118,103 @@ initIntCtxt boot = IntCtxt { -------------------------------------------------------------------------------} -- | Interpretation monad -newtype IntT h m a = IntT { - unIntT :: StateT (IntCtxt h) (TranslateT IntException m) a +newtype IntT h e m a = IntT { + unIntT :: StateT (IntCtxt h) (TranslateT (Either IntException e) m) a } deriving ( Functor , Applicative , Monad , MonadReader TransCtxt , MonadState (IntCtxt h) - , MonadError IntException + , MonadError (Either IntException e) ) --- | Unwrap the IntM monad stack (internal function) -unIntT' :: IntCtxt h -> IntT h m a -> TranslateT IntException m (a, IntCtxt h) -unIntT' ic ma = runStateT (unIntT ma) ic - -- | Run the interpreter monad -runIntT :: (Interpret h a, Monad m) - => IntCtxt h - -> a - -> TranslateT IntException m (Interpreted a, IntCtxt h) -runIntT ic = unIntT' ic . int +runIntT :: IntCtxt h + -> IntT h e m a + -> TranslateT (Either IntException e) m (a, IntCtxt h) +runIntT ic ma = runStateT (unIntT ma) ic + +-- | Variation on 'runIntT' when we can /only/ have interpretation exceptions +runIntT' :: Functor m + => IntCtxt h + -> IntT h Void m a + -> TranslateT IntException m (a, IntCtxt h) +runIntT' ic = mapTranslateErrors mustBeLeft . runIntT ic -- | Run the interpreter monad, given only the boot transaction -runIntBoot :: (Interpret h a, Monad m) +runIntBoot :: Monad m => DSL.Transaction h Addr - -> a - -> TranslateT IntException m (Interpreted a, IntCtxt h) -runIntBoot = runIntT . initIntCtxt + -> IntT h e m a + -> TranslateT (Either IntException e) m (a, IntCtxt h) +runIntBoot boot ma = do + ic <- mapTranslateErrors Left $ initIntCtxt boot + runIntT ic ma + +-- | Variation on 'runIntBoot' when we can /only/ have interpretation exceptions +runIntBoot' :: Monad m + => DSL.Transaction h Addr + -> IntT h Void m a + -> TranslateT IntException m (a, IntCtxt h) +runIntBoot' boot = mapTranslateErrors mustBeLeft . runIntBoot boot {------------------------------------------------------------------------------- Internal monad functions -------------------------------------------------------------------------------} liftTranslate :: Monad m - => (e -> IntException) - -> ((HasConfiguration, HasUpdateConfiguration) => TranslateT e m a) - -> IntT h m a -liftTranslate f ta = IntT $ lift $ mapTranslateErrors f $ withConfig $ ta + => ( (HasConfiguration, HasUpdateConfiguration) + => TranslateT e m a) + -> IntT h e m a +liftTranslate ta = IntT $ lift $ mapTranslateErrors Right $ withConfig $ ta + +-- | Variation on @liftTranslate@ for translation functions that actually +-- may throw 'IntException's +liftTranslateInt :: Monad m + => ( (HasConfiguration, HasUpdateConfiguration) + => TranslateT IntException m a) + -> IntT h e m a +liftTranslateInt ta = IntT $ lift $ mapTranslateErrors Left $ withConfig $ ta -- | Add transaction into the context -push :: forall h m. (DSL.Hash h Addr, Monad m) - => (DSL.Transaction h Addr, TxId) -> IntT h m () -push (t, id) = modify aux +pushTx :: forall h e m. (DSL.Hash h Addr, Monad m) + => (DSL.Transaction h Addr, TxId) -> IntT h e m () +pushTx (t, id) = modify aux where aux :: IntCtxt h -> IntCtxt h aux ic = IntCtxt { - icLedger = DSL.ledgerAdd t (icLedger ic) - , icHashes = Map.insert (DSL.hash t) id (icHashes ic) + icLedger = DSL.ledgerAdd t (icLedger ic) + , icHashes = Map.insert (DSL.hash t) id (icHashes ic) + , icNextSlot = icNextSlot ic + , icPrevBlock = icPrevBlock ic } -intHash :: Monad m - => DSL.Hash h Addr => h (DSL.Transaction h Addr) -> IntT h m TxId +-- | Add a block into the context +-- +-- This sets the " previous block " header and increases the next slot number. +pushBlock :: forall h e m. Monad m => MainBlock -> IntT h e m () +pushBlock block = do + s <- get + s' <- liftTranslateInt $ aux s + put s' + where + aux :: IntCtxt h -> TranslateT IntException m (IntCtxt h) + aux ic = mapTranslateErrors IntExMkSlot $ do + nextSlot' <- translateNextSlot (icNextSlot ic) + return IntCtxt { + icLedger = icLedger ic + , icHashes = icHashes ic + , icNextSlot = nextSlot' + , icPrevBlock = BlockHeaderMain $ block ^. gbHeader + } + +intHash :: (Monad m, DSL.Hash h Addr) + => h (DSL.Transaction h Addr) -> IntT h e m TxId intHash h = do mId <- Map.lookup h . icHashes <$> get case mId of Just id -> return id - Nothing -> throwError $ IntUnknownHash (pretty h) + Nothing -> throwError . Left $ IntUnknownHash (pretty h) {------------------------------------------------------------------------------- Lift some DSL operations that require a ledger to operations that @@ -154,11 +222,11 @@ intHash h = do -------------------------------------------------------------------------------} findHash' :: (DSL.Hash h Addr, Monad m) - => h (DSL.Transaction h Addr) -> IntT h m (DSL.Transaction h Addr) + => h (DSL.Transaction h Addr) -> IntT h e m (DSL.Transaction h Addr) findHash' h = (DSL.findHash' h . icLedger) <$> get inpSpentOutput' :: (DSL.Hash h Addr, Monad m) - => DSL.Input h Addr -> IntT h m (DSL.Output Addr) + => DSL.Input h Addr -> IntT h e m (DSL.Output Addr) inpSpentOutput' inp = (DSL.inpSpentOutput' inp . icLedger) <$> get {------------------------------------------------------------------------------- @@ -173,89 +241,86 @@ inpSpentOutput' inp = (DSL.inpSpentOutput' inp . icLedger) <$> get class Interpret h a where type Interpreted a :: * - int :: (HasCallStack, Monad m) - => a -> IntT h m (Interpreted a) + int :: (Monad m) + => a -> IntT h e m (Interpreted a) {------------------------------------------------------------------------------- Instances that read, but not update, the state -------------------------------------------------------------------------------} +instance Interpret h DSL.Value where + type Interpreted DSL.Value = Coin + + int :: (Monad m) => DSL.Value -> IntT h e m Coin + int = return . mkCoin + instance Interpret h Addr where - type Interpreted Addr = (SomeKeyPair, Address) + type Interpreted Addr = AddrInfo - int :: (HasCallStack, Monad m) - => Addr -> IntT h m (SomeKeyPair, Address) + int :: (Monad m) => Addr -> IntT h e m AddrInfo int = asks . resolveAddr instance DSL.Hash h Addr => Interpret h (DSL.Input h Addr) where - type Interpreted (DSL.Input h Addr) = TxOwnedInput SomeKeyPair + type Interpreted (DSL.Input h Addr) = (TxOwnedInput SomeKeyPair, ResolvedInput) - int :: (HasCallStack, Monad m) - => DSL.Input h Addr -> IntT h m (TxOwnedInput SomeKeyPair) + int :: (Monad m) + => DSL.Input h Addr -> IntT h e m (TxOwnedInput SomeKeyPair, ResolvedInput) int inp@DSL.Input{..} = do -- We figure out who must sign the input by looking at the output - spentOutput <- inpSpentOutput' inp - isBootstrap <- isBootstrapTransaction <$> findHash' inpTrans + spentOutput <- inpSpentOutput' inp + resolvedInput <- int spentOutput + isBootstrap <- isBootstrapTransaction <$> findHash' inpTrans if isBootstrap then do - (ownerKey, ownerAddr) <- int $ DSL.outAddr spentOutput + AddrInfo{..} <- int $ DSL.outAddr spentOutput -- See explanation at 'bootstrapTransaction' - return ( - ownerKey + return (( + addrInfoAddrKey , TxInUtxo { - txInHash = unsafeHash ownerAddr + txInHash = unsafeHash addrInfoCardano , txInIndex = 0 } - ) + ), resolvedInput) else do - (ownerKey, _) <- int $ DSL.outAddr spentOutput - inpTrans' <- intHash $ inpTrans - return ( - ownerKey + AddrInfo{..} <- int $ DSL.outAddr spentOutput + inpTrans' <- intHash $ inpTrans + return (( + addrInfoAddrKey , TxInUtxo { txInHash = inpTrans' , txInIndex = inpIndex } - ) + ), resolvedInput) instance Interpret h (DSL.Output Addr) where type Interpreted (DSL.Output Addr) = TxOutAux - int :: (HasCallStack, Monad m) - => DSL.Output Addr -> IntT h m TxOutAux + int :: (Monad m) + => DSL.Output Addr -> IntT h e m TxOutAux int DSL.Output{..} = do - (_, outAddr') <- int outAddr + AddrInfo{..} <- int outAddr + outVal' <- int outVal return TxOutAux { toaOut = TxOut { - txOutAddress = outAddr' - , txOutValue = mkCoin outVal + txOutAddress = addrInfoCardano + , txOutValue = outVal' } } --- | Interpretation of transactions -instance DSL.Hash h Addr => Interpret h (DSL.Transaction h Addr) where - type Interpreted (DSL.Transaction h Addr) = TxAux +instance DSL.Hash h Addr => Interpret h (DSL.Utxo h Addr) where + type Interpreted (DSL.Utxo h Addr) = Utxo - int :: (HasCallStack, Monad m) - => DSL.Transaction h Addr -> IntT h m TxAux - int t = do - trIns' <- mapM int $ DSL.trIns' t - trOuts' <- mapM int $ DSL.trOuts t - liftTranslate IntExClassifyInputs $ case classifyInputs trIns' of - Left err -> - throwError err - Right (InputsRegular trIns'') -> withConfig $ - return . either absurd identity $ - makeMPubKeyTx - (Right . FakeSigner . regKpSec) - (NE.fromList trIns'') - (NE.fromList trOuts') - Right (InputsRedeem (kp, inp)) -> withConfig $ return $ - makeRedemptionTx - (redKpSec kp) - (NE.fromList [inp]) - (NE.fromList trOuts') + int :: forall e m. (Monad m) + => DSL.Utxo h Addr -> IntT h e m Utxo + int = fmap Map.fromList . mapM aux . DSL.utxoToList + where + aux :: (DSL.Input h Addr, DSL.Output Addr) + -> IntT h e m (TxIn, TxOutAux) + aux (inp, out) = do + ((_key, inp'), _) <- int inp + out' <- int out + return (inp', out') {------------------------------------------------------------------------------- Instances that change the state @@ -265,94 +330,105 @@ instance DSL.Hash h Addr => Interpret h (DSL.Transaction h Addr) where context of whatever is interpreted next. -------------------------------------------------------------------------------} +-- | Interpretation of transactions +instance DSL.Hash h Addr => Interpret h (DSL.Transaction h Addr) where + type Interpreted (DSL.Transaction h Addr) = RawResolvedTx + + int :: forall e m. (Monad m) + => DSL.Transaction h Addr -> IntT h e m RawResolvedTx + int t = do + (trIns', resolvedInputs) <- unzip <$> mapM int (DSL.trIns' t) + trOuts' <- mapM int (DSL.trOuts t) + txAux <- liftTranslateInt $ mkTx trIns' trOuts' + pushTx (t, hash (taTx txAux)) + return $ mkRawResolvedTx txAux (NE.fromList resolvedInputs) + where + mkTx :: [TxOwnedInput SomeKeyPair] + -> [TxOutAux] + -> TranslateT IntException m TxAux + mkTx inps outs = mapTranslateErrors IntExClassifyInputs $ + case classifyInputs inps of + Left err -> + throwError err + Right (InputsRegular inps') -> withProtocolMagic $ \pm -> withConfig $ + return . either absurd identity $ + makeMPubKeyTx + pm + (Right . FakeSigner . regKpSec) + (NE.fromList inps') + (NE.fromList outs) + Right (InputsRedeem (kp, inp)) -> withProtocolMagic $ \pm -> withConfig $ + return $ + makeRedemptionTx + pm + (redKpSec kp) + (NE.fromList [inp]) + (NE.fromList outs) + -- | Interpretation of a list of transactions, oldest first -- -- Each transaction becomes part of the context for the next. instance DSL.Hash h Addr => Interpret h (DSL.Block h Addr) where - type Interpreted (DSL.Block h Addr) = OldestFirst [] TxAux - - int :: forall m. (HasCallStack, Monad m) - => DSL.Block h Addr -> IntT h m (OldestFirst [] TxAux) - int = fmap OldestFirst . go . toList + type Interpreted (DSL.Block h Addr) = RawResolvedBlock + + int :: forall e m. (Monad m) + => DSL.Block h Addr -> IntT h e m RawResolvedBlock + int (OldestFirst txs) = do + (txs', resolvedTxInputs) <- unpack <$> mapM int txs + prev <- gets icPrevBlock + slot <- gets icNextSlot + block <- liftTranslateInt $ mkBlock prev slot txs' + pushBlock block + return $ mkRawResolvedBlock block resolvedTxInputs where - go :: [DSL.Transaction h Addr] -> IntT h m [TxAux] - go [] = return [] - go (t:ts) = do - t' <- int t - push (t, hash (taTx t')) - (t' :) <$> go ts - --- | Interpretation of a list of list of transactions (basically a chain) -instance DSL.Hash h Addr => Interpret h (DSL.Blocks h Addr) where - type Interpreted (DSL.Blocks h Addr) = OldestFirst [] (OldestFirst [] TxAux) - - int :: (HasCallStack, Monad m) - => DSL.Blocks h Addr -> IntT h m (OldestFirst [] (OldestFirst [] TxAux)) - int = mapM int - --- TODO: Here and elsewhere we assume we stay within a single epoch -instance DSL.Hash h Addr => Interpret h (DSL.Chain h Addr) where - type Interpreted (DSL.Chain h Addr) = OldestFirst [] Block + unpack :: [RawResolvedTx] -> ([TxAux], [ResolvedTxInputs]) + unpack = unzip . map (rawResolvedTx &&& rawResolvedTxInputs) - int :: forall m. (HasCallStack, Monad m) - => DSL.Chain h Addr -> IntT h m (OldestFirst [] Block) - int DSL.Chain{..} = do - tss <- int chainBlocks - OldestFirst <$> mkBlocks Nothing 0 (toList (map toList tss)) - where - mkBlocks :: Maybe MainBlock -> Word16 -> [[TxAux]] -> IntT h m [Block] - mkBlocks _ _ [] = return [] - mkBlocks prev slot (ts:tss) = do - lsi <- liftTranslate IntExMkSlot $ mkLocalSlotIndex slot - let slotId = SlotId (EpochIndex 0) lsi - block <- mkBlock prev slotId ts - (Right block :) <$> mkBlocks (Just block) (slot + 1) tss - - mkBlock :: Maybe MainBlock -> SlotId -> [TxAux] -> IntT h m MainBlock - mkBlock mPrev slotId ts = do - -- empty delegation payload - dlgPayload <- liftTranslate IntExMkDlg $ pure (UnsafeDlgPayload []) + mkBlock :: BlockHeader + -> SlotId + -> [TxAux] + -> TranslateT IntException m MainBlock + mkBlock prev slotId ts = mapTranslateErrors IntExCreateBlock $ do + -- TODO: empty delegation payload + let dlgPayload = UnsafeDlgPayload [] -- empty update payload let updPayload = def - -- previous block header - -- if none specified, use genesis block - prev <- - case mPrev of - Just prev -> (BlockHeaderMain . view gbHeader) <$> return prev - Nothing -> (BlockHeaderGenesis . view gbHeader) <$> asks (ccBlock0 . tcCardano) - -- figure out who needs to sign the block BlockSignInfo{..} <- asks $ blockSignInfoForSlot slotId - liftTranslate IntExCreateBlock $ - createMainBlockPure - blockSizeLimit - prev - (Just (bsiPSK, bsiLeader)) - slotId - bsiKey - (RawPayload - (toList ts) - (defaultSscPayload (siSlot slotId)) -- TODO - dlgPayload - updPayload - ) + withProtocolMagic $ \pm -> + withConfig $ + createMainBlockPure + pm + blockSizeLimit + prev + (Just (bsiPSK, bsiLeader)) + slotId + bsiKey + (RawPayload + (toList ts) + (defaultSscPayload (siSlot slotId)) -- TODO + dlgPayload + updPayload + ) -- TODO: Get this value from somewhere rather than hardcoding it blockSizeLimit = 2 * 1024 * 1024 -- 2 MB -instance DSL.Hash h Addr => Interpret h (DSL.Utxo h Addr) where - type Interpreted (DSL.Utxo h Addr) = Utxo +instance DSL.Hash h Addr => Interpret h (DSL.Chain h Addr) where + type Interpreted (DSL.Chain h Addr) = OldestFirst [] MainBlock - int :: forall m. (HasCallStack, Monad m) - => DSL.Utxo h Addr -> IntT h m Utxo - int = fmap Map.fromList . mapM aux . DSL.utxoToList - where - aux :: (DSL.Input h Addr, DSL.Output Addr) - -> IntT h m (TxIn, TxOutAux) - aux (inp, out) = do - (_key, inp') <- int inp - out' <- int out - return (inp', out') + int :: forall e m. (Monad m) + => DSL.Chain h Addr -> IntT h e m (OldestFirst [] MainBlock) + int (OldestFirst blocks) = OldestFirst <$> + mapM (fmap rawResolvedBlock . int) blocks + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +mustBeLeft :: Either a Void -> a +mustBeLeft (Left a) = a +mustBeLeft (Right b) = absurd b diff --git a/wallet-new/test/unit/UTxO/PreChain.hs b/wallet-new/test/unit/UTxO/PreChain.hs deleted file mode 100644 index 520bb320e27..00000000000 --- a/wallet-new/test/unit/UTxO/PreChain.hs +++ /dev/null @@ -1,156 +0,0 @@ -{-# LANGUAGE TupleSections #-} - --- | Fee calculation --- --- See also --- --- * Module "Pos.Core.Common.Fee" --- * Function 'Pos.Client.Txp.Util.stabilizeTxFee' -module UTxO.PreChain ( - PreChain - , preChain - , FromPreChain(..) - , fromPreChain - ) where - -import Universum - -import Pos.Client.Txp -import Pos.Core -import Pos.Txp.Toil -import Pos.Util.Chrono - -import Util.DepIndep -import UTxO.Bootstrap -import UTxO.Context -import UTxO.DSL -import UTxO.Interpreter -import UTxO.Translate - -{------------------------------------------------------------------------------- - Chain with some information still missing --------------------------------------------------------------------------------} - --- | A chain with "holes" for the bootstrap transaction and the fees --- --- We use the 'DepIndep' monad transformer here to make sure that the --- effects can depend on the bootstrap transaction, but not on the fees. --- This is important. Suppose we used --- --- > Transaction h Addr -> [[Fee]] -> m (Blocks h Addr) --- --- instead: we'd have to execute the action that generates the blocks --- /twice/ (once before we know the fees, and once again after we computed --- the fees), and the second time around we may in fact generate a very --- different chain (think @m@ = QuickCheck 'Gen', for instance) -- which --- would then require very different fees. No good. If we did --- --- > m (Transaction h Addr -> [[Fee]] -> Blocks h Addr) --- --- instead, then (thinking @m@ = 'Gen' again) we could not generate different --- chains for different bootstrap transactions, which would also be no good. --- --- It is still the responsibility of the 'PreChain' author to make sure that the --- structure of the blockchain does not depend on the fees that are passed. -type PreChain h m a = DepIndep (Transaction h Addr) [[Fee]] m (Blocks h Addr, a) - -preChain :: Functor m - => (Transaction h Addr -> m ([[Fee]] -> Blocks h Addr)) - -> PreChain h m () -preChain = fmap (, ()) . DepIndep - --- | Result of translating a 'PreChain' --- --- See 'fromPreChain' -data FromPreChain h a = FromPreChain { - -- | The boot transaction that was used in the translation - fpcBoot :: Transaction h Addr - - -- | The resulting chain (i.e., list of list of transactions) - -- This does /not/ include the bootstrap transaction. - , fpcChain :: Chain h Addr - - -- | The resulting ledger (i.e., flat list of transactions) - -- This /does/ include the bootstrap transaction . - , fpcLedger :: Ledger h Addr - - -- | Any additional information that was included in the 'PreChain'. - , fpcExtra :: a - } - -fromPreChain :: (Hash h Addr, Monad m) - => PreChain h m a -> TranslateT IntException m (FromPreChain h a) -fromPreChain pc = do - fpcBoot <- asks bootstrapTransaction - (txs, fpcExtra) <- calcFees fpcBoot =<< lift (runDepIndep pc fpcBoot) - let fpcChain = Chain txs -- doesn't include the boot transactions - fpcLedger = chainToLedger fpcBoot fpcChain - return FromPreChain{..} - -{------------------------------------------------------------------------------- - Fee calculation --------------------------------------------------------------------------------} - -type Fee = Value - --- | Calculate fees for a bunch of transactions --- --- Transaction fee calculation is a bit awkward. --- --- First, when we want to construct a number of transactions, then it may not be --- sufficient to only know the fee for each transaction locally. For example, if --- we want to transfer X from A to B, and then the remainder of A's balance to --- C, we need to transactions with outputs --- --- > [ X from A to B, balanceA - X - fee1 from A back to A ] --- > [ balanceA - X - fee1 - fee2 from A to C ] --- --- where we need to know the fee of the first transaction in order to create --- the second. --- --- Second, in order to be able to even know what the fee of a transaction is, --- we need to /construct/ the transaction since the fee depends on the --- transaction size. --- --- So, what we do is we first construct all transactions assuming the fee is 0. --- We then calculate the fees, and finally construct the transactions again --- with their proper fees. --- --- The function constructing the transactions from the fees must satisfy --- two conditions: --- --- * The transactions returned cannot depend on the fees! Basically, the --- transactions should regard these fees as uninspectable. If this condition --- is not met the fees calculated will be incorrect. (Possibly we might --- be able to address this at the type level with some PHOAS like --- representation.) --- --- * The function can assume that the list fees it is given contains a fee --- for each transaction, in order, but it the list may be longer. The reason --- is that initially we cannot even know how many transactions the function --- returns, and hence we just provide an infinite list of zeroes. --- (We could address this at the type level by using vectors.) --- --- TODO: We should check that the fees of the constructed transactions match the --- fees we calculuated. This ought to be true at the moment, but may break when --- the size of the fee might change the size of the the transaction. -calcFees :: forall h m x. (Hash h Addr, Monad m) - => Transaction h Addr - -> ([[Fee]] -> (Blocks h Addr, x)) - -> TranslateT IntException m (Blocks h Addr, x) -calcFees boot f = do - TxFeePolicyTxSizeLinear policy <- bvdTxFeePolicy <$> gsAdoptedBVData - let txToLinearFee' :: TxAux -> TranslateT IntException m Value - txToLinearFee' = mapTranslateErrors IntExTx - . fmap feeValue - . txToLinearFee policy - - (txs, _) <- runIntBoot boot $ fst (f (repeat (repeat 0))) - fees <- mapM (mapM txToLinearFee') txs - return $ f (unmarkOldestFirst fees) - where - unmarkOldestFirst :: OldestFirst [] (OldestFirst [] a) -> [[a]] - unmarkOldestFirst = map toList . toList - - feeValue :: TxFee -> Value - feeValue (TxFee fee) = unsafeGetCoin fee diff --git a/wallet-new/test/unit/UTxO/Translate.hs b/wallet-new/test/unit/UTxO/Translate.hs index 16b9d1d1ce8..a1ccc14fc29 100644 --- a/wallet-new/test/unit/UTxO/Translate.hs +++ b/wallet-new/test/unit/UTxO/Translate.hs @@ -7,8 +7,14 @@ module UTxO.Translate ( , runTranslate , runTranslateNoErrors , withConfig + , withProtocolMagic , mapTranslateErrors , catchTranslateErrors + , catchSomeTranslateErrors + -- * Convenience wrappers + , translateFirstSlot + , translateNextSlot + , translateGenesisHeader -- * Interface to the verifier , verify , verifyBlocksPrefix @@ -25,10 +31,11 @@ import Universum import Pos.Block.Error import Pos.Block.Types import Pos.Core +import Pos.Core.Chrono +import Pos.Crypto (ProtocolMagic) import Pos.DB.Class (MonadGState (..)) import Pos.Txp.Toil import Pos.Update -import Pos.Util.Chrono import Util.Validated import UTxO.Context @@ -53,9 +60,10 @@ import Test.Pos.Configuration (withDefConfiguration, withDefUpdateConf -------------------------------------------------------------------------------} data TranslateEnv = TranslateEnv { - teContext :: TransCtxt - , teConfig :: Dict HasConfiguration - , teUpdate :: Dict HasUpdateConfiguration + teContext :: TransCtxt + , teProtocolMagic :: ProtocolMagic + , teConfig :: Dict HasConfiguration + , teUpdate :: Dict HasUpdateConfiguration } newtype TranslateT e m a = TranslateT { @@ -65,6 +73,7 @@ newtype TranslateT e m a = TranslateT { , Applicative , Monad , MonadError e + , MonadIO ) instance MonadTrans (TranslateT e) where @@ -88,13 +97,14 @@ instance Monad m => MonadGState (TranslateT e m) where -- pure exceptions. runTranslateT :: Monad m => Exception e => TranslateT e m a -> m a runTranslateT (TranslateT ta) = - withDefConfiguration $ + withDefConfiguration $ \pm -> withDefUpdateConfiguration $ let env :: TranslateEnv env = TranslateEnv { - teContext = initContext initCardanoContext - , teConfig = Dict - , teUpdate = Dict + teContext = initContext (initCardanoContext pm) + , teProtocolMagic = pm + , teConfig = Dict + , teUpdate = Dict } in do ma <- runReaderT (runExceptT ta) env case ma of @@ -118,6 +128,11 @@ withConfig f = do Dict <- TranslateT $ asks teUpdate f +-- | Pull the ProtocolMagic from the TranslateEnv +withProtocolMagic + :: Monad m => (ProtocolMagic -> TranslateT e m a) -> TranslateT e m a +withProtocolMagic = (TranslateT (asks teProtocolMagic) >>=) + -- | Map errors mapTranslateErrors :: Functor m => (e -> e') -> TranslateT e m a -> TranslateT e' m a @@ -129,6 +144,38 @@ catchTranslateErrors :: Functor m catchTranslateErrors (TranslateT (ExceptT (ReaderT ma))) = TranslateT $ ExceptT $ ReaderT $ \env -> fmap Right (ma env) +catchSomeTranslateErrors :: Monad m + => TranslateT (Either e e') m a + -> TranslateT e m (Either e' a) +catchSomeTranslateErrors act = do + ma <- catchTranslateErrors act + case ma of + Left (Left e) -> throwError e + Left (Right e') -> return $ Left e' + Right a -> return $ Right a + +{------------------------------------------------------------------------------- + Convenience wrappers +-------------------------------------------------------------------------------} + +-- | Slot ID of the first block +translateFirstSlot :: Monad m => TranslateT Text m SlotId +translateFirstSlot = withConfig $ do + SlotId 0 <$> mkLocalSlotIndex 0 + +-- | Increment slot ID +-- +-- TODO: Surely a function like this must already exist somewhere? +translateNextSlot :: Monad m => SlotId -> TranslateT Text m SlotId +translateNextSlot (SlotId epoch lsi) = withConfig $ + case addLocalSlotIndex 1 lsi of + Just lsi' -> return $ SlotId epoch lsi' + Nothing -> SlotId (epoch + 1) <$> mkLocalSlotIndex 0 + +-- | Genesis block header +translateGenesisHeader :: Monad m => TranslateT e m GenesisBlockHeader +translateGenesisHeader = view gbHeader <$> asks (ccBlock0 . tcCardano) + {------------------------------------------------------------------------------- Interface to the verifier -------------------------------------------------------------------------------} @@ -150,9 +197,11 @@ verifyBlocksPrefix blocks = do CardanoContext{..} <- asks tcCardano let tip = ccHash0 currentSlot = Nothing - verify $ Verify.verifyBlocksPrefix - tip - currentSlot - ccLeaders -- TODO: May not be necessary to pass this if we start from genesis - (OldestFirst []) -- TODO: LastBlkSlots. Unsure about the required value or its effect - blocks + withProtocolMagic $ \pm -> + verify $ Verify.verifyBlocksPrefix + pm + tip + currentSlot + ccLeaders -- TODO: May not be necessary to pass this if we start from genesis + (OldestFirst []) -- TODO: LastBlkSlots. Unsure about the required value or its effect + blocks diff --git a/wallet-new/test/unit/UTxO/Verify.hs b/wallet-new/test/unit/UTxO/Verify.hs index fc425a1b7c2..84cbf68c3ae 100644 --- a/wallet-new/test/unit/UTxO/Verify.hs +++ b/wallet-new/test/unit/UTxO/Verify.hs @@ -27,12 +27,12 @@ import Pos.Block.Logic.Integrity (verifyBlocks) import Pos.Block.Slog hiding (slogVerifyBlocks) import Pos.Block.Types import Pos.Core +import Pos.Core.Chrono import Pos.DB.Class (MonadGState (..)) import Pos.Delegation (DlgUndo (..)) import Pos.Txp hiding (tgsVerifyBlocks) import Pos.Update.Poll import Pos.Util (neZipWith4) -import Pos.Util.Chrono import Pos.Util.Lens import qualified Pos.Util.Modifier as MM import Serokell.Util.Verify @@ -224,13 +224,14 @@ mapVerifyErrors f (Verify ma) = Verify $ mapStateT (withExceptT f) ma -- so I skipped it for now. verifyBlocksPrefix :: HasConfiguration - => HeaderHash -- ^ Expected tip + => ProtocolMagic + -> HeaderHash -- ^ Expected tip -> Maybe SlotId -- ^ Current slot -> SlotLeaders -- ^ Slot leaders for this epoch -> LastBlkSlots -- ^ Last block slots -> OldestFirst NE Block -> Verify VerifyBlocksException (OldestFirst NE Undo) -verifyBlocksPrefix tip curSlot leaders lastSlots blocks = do +verifyBlocksPrefix pm tip curSlot leaders lastSlots blocks = do when (tip /= blocks ^. _Wrapped . _neHead . prevBlockL) $ throwError $ VerifyBlocksError "the first block isn't based on the tip" @@ -238,7 +239,7 @@ verifyBlocksPrefix tip curSlot leaders lastSlots blocks = do -- Verify block envelope slogUndos <- mapVerifyErrors VerifyBlocksError $ - slogVerifyBlocks curSlot leaders lastSlots blocks + slogVerifyBlocks pm curSlot leaders lastSlots blocks -- We skip SSC verification {- @@ -248,7 +249,7 @@ verifyBlocksPrefix tip curSlot leaders lastSlots blocks = do -- Verify transactions txUndo <- mapVerifyErrors (VerifyBlocksError . pretty) $ - tgsVerifyBlocks $ map toTxpBlock blocks + tgsVerifyBlocks pm $ map toTxpBlock blocks -- Skip delegation verification {- @@ -293,12 +294,13 @@ verifyBlocksPrefix tip curSlot leaders lastSlots blocks = do -- * Use hard-coded 'dataMustBeKnown' (instead of deriving this from 'adoptedBV') slogVerifyBlocks :: HasConfiguration - => Maybe SlotId -- ^ Current slot + => ProtocolMagic + -> Maybe SlotId -- ^ Current slot -> SlotLeaders -- ^ Slot leaders for this epoch -> LastBlkSlots -- ^ Last block slots -> OldestFirst NE Block -> Verify Text (OldestFirst NE SlogUndo) -slogVerifyBlocks curSlot leaders lastSlots blocks = do +slogVerifyBlocks pm curSlot leaders lastSlots blocks = do adoptedBVD <- gsAdoptedBVData -- We take head here, because blocks are in oldest first order and @@ -309,8 +311,9 @@ slogVerifyBlocks curSlot leaders lastSlots blocks = do when (block ^. genBlockLeaders /= leaders) $ throwError "Genesis block leaders don't match with LRC-computed" _ -> pass + let blocksList = OldestFirst (toList (getOldestFirst blocks)) verResToMonadError formatAllErrors $ - verifyBlocks curSlot dataMustBeKnown adoptedBVD leaders blocks + verifyBlocks pm curSlot dataMustBeKnown adoptedBVD leaders blocksList -- Here we need to compute 'SlogUndo'. When we add apply a block, -- we can remove one of the last slots stored in @@ -351,14 +354,14 @@ slogVerifyBlocks curSlot leaders lastSlots blocks = do -- * Does everything in a pure monad. -- I don't fully grasp the consequences of this. tgsVerifyBlocks - :: HasConfiguration - => OldestFirst NE TxpBlock + :: ProtocolMagic + -> OldestFirst NE TxpBlock -> Verify ToilVerFailure (OldestFirst NE TxpUndo) -tgsVerifyBlocks newChain = do +tgsVerifyBlocks pm newChain = do bvd <- gsAdoptedBVData let epoch = NE.last (getOldestFirst newChain) ^. epochIndexL let verifyPure :: [TxAux] -> Verify ToilVerFailure TxpUndo - verifyPure = nat . verifyToil bvd epoch dataMustBeKnown + verifyPure = nat . verifyToil pm bvd mempty epoch dataMustBeKnown mapM (verifyPure . convertPayload) newChain where convertPayload :: TxpBlock -> [TxAux] diff --git a/wallet-new/test/unit/Util.hs b/wallet-new/test/unit/Util.hs index 48ab88455b3..c5f6b69ebd6 100644 --- a/wallet-new/test/unit/Util.hs +++ b/wallet-new/test/unit/Util.hs @@ -5,12 +5,16 @@ module Util ( , disjoint , withoutKeys , restrictKeys + -- * Dealing with OldestFirst/NewestFirst + , liftOldestFirst + , liftNewestFirst ) where import Universum import qualified Data.Map as Map import qualified Data.Set as Set +import Pos.Core.Chrono {------------------------------------------------------------------------------- Lists @@ -37,3 +41,13 @@ m `withoutKeys` s = m `Map.difference` Map.fromSet (const ()) s restrictKeys :: Ord k => Map k a -> Set k -> Map k a m `restrictKeys` s = m `Map.intersection` Map.fromSet (const ()) s + +{------------------------------------------------------------------------------- + Dealing with OldestFirst/NewestFirst +-------------------------------------------------------------------------------} + +liftOldestFirst :: (f a -> f a) -> OldestFirst f a -> OldestFirst f a +liftOldestFirst f = OldestFirst . f . getOldestFirst + +liftNewestFirst :: (f a -> f a) -> NewestFirst f a -> NewestFirst f a +liftNewestFirst f = NewestFirst . f . getNewestFirst diff --git a/wallet-new/test/unit/Util/Buildable.hs b/wallet-new/test/unit/Util/Buildable.hs index 19e2a0896aa..bf0628f3c27 100644 --- a/wallet-new/test/unit/Util/Buildable.hs +++ b/wallet-new/test/unit/Util/Buildable.hs @@ -5,10 +5,14 @@ module Util.Buildable ( import Formatting (build, sformat) import Prelude (Show (..)) +import Test.QuickCheck (Arbitrary (..)) import Universum newtype ShowThroughBuild a = STB { unSTB :: a } - deriving (Eq) + deriving (Eq, Ord) instance Buildable a => Show (ShowThroughBuild a) where show = toString . sformat build . unSTB + +instance Arbitrary a => Arbitrary (ShowThroughBuild a) where + arbitrary = STB <$> arbitrary diff --git a/wallet-new/test/unit/Util/Buildable/Hspec.hs b/wallet-new/test/unit/Util/Buildable/Hspec.hs index 530b05b20c8..494be76c7ff 100644 --- a/wallet-new/test/unit/Util/Buildable/Hspec.hs +++ b/wallet-new/test/unit/Util/Buildable/Hspec.hs @@ -8,9 +8,11 @@ module Util.Buildable.Hspec ( , shouldBe , shouldNotBe , shouldReturn + , shouldMatchList -- * Working with Validated , valid , shouldBeValidated + , shouldReturnValidated -- * Re-exports , H.Expectation , H.Spec @@ -32,7 +34,7 @@ import Util.Validated Wrappers around Test.HSpec.Expectations -------------------------------------------------------------------------------} -infix 1 `shouldSatisfy`, `shouldBe`, `shouldReturn` +infix 1 `shouldSatisfy`, `shouldBe`, `shouldReturn`, `shouldMatchList` shouldSatisfy :: (HasCallStack, Buildable a) => a -> (a -> Bool) -> H.Expectation @@ -50,6 +52,10 @@ shouldReturn :: (HasCallStack, Buildable a, Eq a) => IO a -> a -> H.Expectation shouldReturn act a = H.shouldReturn (STB <$> act) (STB a) +shouldMatchList :: (HasCallStack, Buildable a, Eq a) + => [a] -> [a] -> H.Expectation +shouldMatchList a b = H.shouldMatchList (map STB a) (map STB b) + {------------------------------------------------------------------------------- Wrappers around Validated -------------------------------------------------------------------------------} @@ -58,6 +64,10 @@ valid :: (HasCallStack, Buildable e, Buildable a) => String -> Validated e a -> H.Spec valid s = H.it s . shouldBeValidated -shouldBeValidated :: (Buildable e, Buildable a) +shouldBeValidated :: (HasCallStack, Buildable e, Buildable a) => Validated e a -> H.Expectation shouldBeValidated ma = shouldSatisfy ma isValidated + +shouldReturnValidated :: (HasCallStack, Buildable a, Buildable e) + => IO (Validated e a) -> IO () +shouldReturnValidated act = shouldBeValidated =<< act diff --git a/wallet-new/test/unit/Util/Buildable/QuickCheck.hs b/wallet-new/test/unit/Util/Buildable/QuickCheck.hs index 5bd9bfee071..5a5b4ade5d1 100644 --- a/wallet-new/test/unit/Util/Buildable/QuickCheck.hs +++ b/wallet-new/test/unit/Util/Buildable/QuickCheck.hs @@ -6,6 +6,7 @@ module Util.Buildable.QuickCheck ( -- * Wrappers forAll -- * Re-exports + , QC.Property , QC.Gen , QC.conjoin , QC.choose diff --git a/wallet-new/test/unit/Util/DepIndep.hs b/wallet-new/test/unit/Util/DepIndep.hs deleted file mode 100644 index 240fcbbe4be..00000000000 --- a/wallet-new/test/unit/Util/DepIndep.hs +++ /dev/null @@ -1,96 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Util.DepIndep ( - DepIndep(..) - , liftIndep - -- ** Convenience re-exports - , hoist - ) where - -import Universum -import Control.Monad.Morph - -{------------------------------------------------------------------------------- - DepIndep monad --------------------------------------------------------------------------------} - --- | Variation on the reader monad transformer using /two/ environments, --- where the effects of the underlying monad can depend on the first but not --- the second environment. In other words, when --- --- > act :: DepIndep d i m a --- --- then --- --- > runDepIndep act d --- --- returns a pure function which can be executed without incurring more effects. --- --- This restriction means that @DepIndep d i m@ is /not/ a monad. --- --- See --- for another example of this kind of "independence restriction". -data DepIndep d i m a = DepIndep { runDepIndep :: d -> m (i -> a) } - -instance Functor f => Functor (DepIndep d i f) where - fmap f (DepIndep g) = DepIndep (fmap (f .) . g) - -instance Applicative f => Applicative (DepIndep d i f) where - pure x = DepIndep (\_ -> pure (\_ -> x)) - DepIndep f <*> DepIndep g = DepIndep (\d -> aux <$> f d <*> g d) - where - aux :: (i -> a -> b) -> (i -> a) -> (i -> b) - aux f' g' i = f' i (g' i) - --- | Lift a monadic action that returns a pure function using the --- " independent " part of the environment (named this way because the monadic --- effects cannot depend on this environment). -liftIndep :: m (i -> a) -> DepIndep d i m a -liftIndep act = DepIndep (\_ -> act) - --- | The 'MonadTrans' instance is dubious. Yes, we can lift operations from --- the "base monad" into 'DepIndep', /but/ 'DepIndep' is /not/ a monad. --- Not sure if we should define it or not. -instance MonadTrans (DepIndep d i) where - lift act = liftIndep (const <$> act) - -instance MFunctor (DepIndep d i) where - hoist k (DepIndep f) = DepIndep (k . f) - -{------------------------------------------------------------------------------- - Proof that DepIndep cannot be a monad --------------------------------------------------------------------------------} - --- First, note the difference between 'Applicative' and 'Monad'. --- In 'Applicative', we can compose effects but the effects cannot depend on --- values, they must be statically known: -type Ap f = forall a b. f (a -> b) -> f a -> f b - --- By contrast, in a 'Monad' the effects can depend on the arguments: -type Bind m = forall a b. m a -> (a -> m b) -> m b - --- Now, suppose that we had a magical transform that translated a function --- in which the effects depend on the argument to one in which the effects --- are determined beforehand: -type Transform m = forall a b. (a -> m b) -> m (a -> b) - --- Then every 'Applicative' would also be a 'Monad': -_applicativeToMonad :: Transform m -> Ap m -> Bind m -_applicativeToMonad t a x f = a (t f) x - --- Now, suppose that we did have a definition of '(>>=)' for 'DepIndep' --- (for arbitrary types of environments): -type BindDepIndep m = forall d i. Bind (DepIndep d i m) - --- Then we could lift functions of type @d -> i -> m a@ into @DepIndep d i m@: -transformDepIndep :: Applicative m - => BindDepIndep m -> (d -> i -> m a) -> DepIndep d i m a -transformDepIndep b f = - liftIndep (pure identity) `b` \i -> - DepIndep (\d -> const <$> f d i) - --- Which means we could construct the magical transform that turns every --- Applicative into a Monad: -_magic :: Applicative m => BindDepIndep m -> Transform m -_magic s f = runDepIndep (transformDepIndep s (\() -> f)) () diff --git a/wallet-new/test/unit/Util/Validated.hs b/wallet-new/test/unit/Util/Validated.hs index db613ddcced..d11ef2257a3 100644 --- a/wallet-new/test/unit/Util/Validated.hs +++ b/wallet-new/test/unit/Util/Validated.hs @@ -8,6 +8,7 @@ module Util.Validated ( , validatedToEither , isValidated , addErrorDetail + , validatedMapErrors -- * Convenience re-exports , MonadError(..) ) where @@ -60,3 +61,7 @@ instance (Buildable e, Buildable a) => Buildable (Validated e a) where isValidated :: Validated e a -> Bool isValidated (Invalid _ _) = False isValidated (Valid _) = True + +validatedMapErrors :: (e -> e') -> Validated e a -> Validated e' a +validatedMapErrors f (Invalid ds e) = Invalid ds (f e) +validatedMapErrors _ (Valid a) = Valid a diff --git a/wallet-new/test/unit/Wallet/Abstract.hs b/wallet-new/test/unit/Wallet/Abstract.hs index ae5d4f865cf..583465dfc38 100644 --- a/wallet-new/test/unit/Wallet/Abstract.hs +++ b/wallet-new/test/unit/Wallet/Abstract.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Abstract definition of a wallet @@ -15,20 +10,6 @@ module Wallet.Abstract ( , mkDefaultWallet , walletBoot , applyBlocks - -- * Inductive wallet definition - , Inductive(..) - , interpret - -- ** Invariants - , Invariant - , invariant - -- ** Testing - , walletInvariants - , walletEquivalent - -- ** Generation - -- $generation - , InductiveWithOurs(..) - , genFromBlockchain - , genFromBlockchainPickingAccounts -- * Auxiliary operations , balance , txIns @@ -38,86 +19,83 @@ module Wallet.Abstract ( , utxoRestrictToOurs ) where +import Universum + import qualified Data.Foldable as Fold import qualified Data.Map as Map import qualified Data.Set as Set -import Universum - -import qualified Data.IntMap as IntMap -import qualified Data.List as List import qualified Data.Text.Buildable -import Formatting (bprint, build, sformat, (%)) -import Pos.Util.Chrono -import Pos.Util.QuickCheck.Arbitrary (sublistN) -import Serokell.Util (listJson) -import Test.QuickCheck +import Formatting (bprint) +import Pos.Core.Chrono +import Serokell.Util (mapJson) import Util -import Util.Validated -import UTxO.BlockGen (divvyUp, selectDestinations') -import UTxO.Context -import UTxO.Crypto import UTxO.DSL -import UTxO.PreChain {------------------------------------------------------------------------------- Wallet type class -------------------------------------------------------------------------------} -- | Check if an address is ours -type Ours a = a -> Maybe SomeKeyPair +type Ours a = a -> Bool -- | Pending transactions -type Pending h a = Set (Transaction h a) +type Pending h a = Map (h (Transaction h a)) (Transaction h a) -- | Abstract wallet interface data Wallet h a = Wallet { -- MAIN API -- | Return the total balance of the wallet (see 'available') - totalBalance :: Value + totalBalance :: Value -- | Return the available balance of the wallet (see 'total') , availableBalance :: Value -- | Notify the wallet of a new block - , applyBlock :: Block h a -> Wallet h a + , applyBlock :: Block h a -> Wallet h a -- | Submit a new transaction to be included in the blockchain - , newPending :: Transaction h a -> Maybe (Wallet h a) + , newPending :: Transaction h a -> Maybe (Wallet h a) -- | Rollback - , rollback :: Wallet h a + , rollback :: Wallet h a -- AUXILIARY API -- | Current set of pending transactions - , pending :: Pending h a + , pending :: Pending h a -- | Wallet's current UTxO (ignoring pending transactions) - , utxo :: Utxo h a + , utxo :: Utxo h a + + -- | Wallet's expected UTxO (if supported) + , expectedUtxo :: Utxo h a -- | Addresses that belong to the wallet - , ours :: Ours a + , ours :: Ours a -- | Change from the pending transactions - , change :: Utxo h a + , change :: Utxo h a -- | Available UTxO -- -- This is the UTxO with the inputs spent by the pending transactions -- removed. - , available :: Utxo h a + , available :: Utxo h a -- | Total UTxO -- -- This is the available UTxO where we add back the change from the -- pending transactions. - , total :: Utxo h a + , total :: Utxo h a + + -- | Internal state for debugging purposes + , dumpState :: Text } -- | Apply multiple blocks -applyBlocks :: Wallet h a -> Blocks h a -> Wallet h a +applyBlocks :: Wallet h a -> Chain h a -> Wallet h a applyBlocks w0 bs = foldl' applyBlock w0 bs -- | Type of a wallet constructor @@ -131,14 +109,22 @@ type WalletConstr h a st = (st -> Wallet h a) -> (st -> Wallet h a) -- This does not pick any particular implementation, but provides some -- default implementations of some of the wallet methods in terms of the -- other methods. -mkDefaultWallet :: (Hash h a, Ord a) - => Lens' st (Pending h a) -> WalletConstr h a st +mkDefaultWallet + :: forall h a st. (Hash h a, Buildable st) + => Lens' st (Pending h a) + -> WalletConstr h a st mkDefaultWallet l self st = Wallet { -- Dealing with pending pending = st ^. l , newPending = \tx -> do - guard $ trIns tx `Set.isSubsetOf` utxoDomain (available this) - return $ self (st & l %~ Set.insert tx) + -- Here we check that the inputs to the given transaction are a + -- subset of the available unspent transaction outputs that aren't + -- part of a currently pending transaction. + let x = trIns tx :: Set (Input h a) + y = utxoDomain (available this) :: Set (Input h a) + case x `Set.isSubsetOf` y of + True -> Just $ self (st & l %~ Map.insert (hash tx) tx) + False -> Nothing -- UTxOs , available = utxoRemoveInputs (txIns (pending this)) (utxo this) , change = utxoRestrictToOurs (ours this) (txOuts (pending this)) @@ -146,11 +132,14 @@ mkDefaultWallet l self st = Wallet { -- Balance , availableBalance = balance $ available this , totalBalance = balance $ total this + -- Debugging + , dumpState = pretty st -- Functions without a default - , utxo = error "mkDefaultWallet: no default for utxo" - , ours = error "mkDefaultWallet: no default for ours" - , applyBlock = error "mkDefaultWallet: no default for applyBlock" - , rollback = error "mkDefaultWallet: no default for rollback" + , utxo = error "mkDefaultWallet: no default for utxo" + , expectedUtxo = error "mkDefaultWallet: no default for expectedUtxo" + , ours = error "mkDefaultWallet: no default for ours" + , applyBlock = error "mkDefaultWallet: no default for applyBlock" + , rollback = error "mkDefaultWallet: no default for rollback" } where this = self st @@ -160,325 +149,6 @@ walletBoot :: (Ours a -> Wallet h a) -- ^ Wallet constructor -> Ours a -> Transaction h a -> Wallet h a walletBoot mkWallet p boot = applyBlock (mkWallet p) (OldestFirst [boot]) -{------------------------------------------------------------------------------- - Inductive wallet definition --------------------------------------------------------------------------------} - --- | Inductive definition of a wallet -data Inductive h a = - -- | Start the wallet, given the bootstrap transaction - WalletBoot (Transaction h a) - - -- | Inform the wallet of a new block added to the blockchain - | ApplyBlock (Inductive h a) (Block h a) - - -- | Submit a new transaction to the wallet to be included in the blockchain - | NewPending (Inductive h a) (Transaction h a) - deriving Eq - --- | Interpreter for 'Inductive' --- --- Given (one or more) wallet constructors, evaluate an 'Inductive' wallet, --- checking the given property at each step. --- --- Note: we expect the 'Inductive' to be valid (valid blockchain, valid --- calls to 'newPending', etc.). This is meant to check properties of the --- /wallet/, not the wallet input. -interpret :: forall h a err. - (Inductive h a -> InvalidInput h a -> err) - -- ^ Inject invalid input err. We provide the value of the - -- 'Inductive' at the point of the error. - -> (Transaction h a -> [Wallet h a]) - -- ^ Wallet constructors - -> (Inductive h a -> [Wallet h a] -> Validated err ()) - -- ^ Predicate to check. The predicate is passed the 'Inductive' - -- at the point of the error, for better error messages. - -> Inductive h a - -- ^ 'Inductive' value to interpret - -> Validated err [Wallet h a] -interpret invalidInput mkWallets p = fmap snd . go - where - go :: Inductive h a -> Validated err (Ledger h a, [Wallet h a]) - go ind@(WalletBoot t) = do - ws <- verify ind (mkWallets t) - return (ledgerSingleton t, ws) - go ind@(ApplyBlock w b) = do - (l, ws) <- go w - ws' <- verify ind $ map (`applyBlock` b) ws - return (ledgerAdds (toNewestFirst b) l, ws') - go ind@(NewPending w t) = do - (l, ws) <- go w - ws' <- verify ind =<< mapM (verifyNew ind l t) ws - return (l, ws') - - verify :: Inductive h a -> [Wallet h a] -> Validated err [Wallet h a] - verify ind ws = p ind ws >> return ws - - -- Verify the input - -- If this fails, we provide the /entire/ 'Inductive' value so that it's - -- easier to track down what happened. - verifyNew :: Inductive h a -- ^ Inductive value at this point - -> Ledger h a -- ^ Ledger so far (for error messages) - -> Transaction h a -> Wallet h a -> Validated err (Wallet h a) - verifyNew ind l tx w = - case newPending w tx of - Just w' -> return w' - Nothing -> throwError . invalidInput ind - $ InvalidPending tx (utxo w) (pending w) l - -{------------------------------------------------------------------------------- - Invariants --------------------------------------------------------------------------------} - --- | Wallet invariant --- --- A wallet invariant is a property that is preserved by the fundamental --- wallet operations, as defined by the 'IsWallet' type class and the --- definition of 'Inductive'. --- --- In order to evaluate the inductive definition we need the empty wallet --- to be passed as a starting point. -type Invariant h a = Inductive h a -> Validated (InvariantViolation h a) () - --- | Lift a property of flat wallet values to an invariant over the wallet ops -invariant :: forall h a. - Text -- ^ Name of the invariant - -> (Transaction h a -> Wallet h a) -- ^ Construct empty wallet - -> (Wallet h a -> Maybe InvariantViolationEvidence) -- ^ Property - -> Invariant h a -invariant name e p = void . interpret notChecked ((:[]) . e) p' - where - notChecked :: Inductive h a - -> InvalidInput h a - -> InvariantViolation h a - notChecked ind reason = InvariantNotChecked { - invariantNotCheckedName = name - , invariantNotCheckedReason = reason - , invariantNotCheckedInductive = ind - } - - violation :: Inductive h a - -> InvariantViolationEvidence - -> InvariantViolation h a - violation ind ev = InvariantViolation { - invariantViolationName = name - , invariantViolationEvidence = ev - , invariantViolationInductive = ind - } - - p' :: Inductive h a - -> [Wallet h a] - -> Validated (InvariantViolation h a) () - p' ind [w] = case p w of - Nothing -> return () - Just ev -> throwError (violation ind ev) - p' _ _ = error "impossible" - --- | Invariant violation -data InvariantViolation h a = - -- | Invariance violation - InvariantViolation { - -- | Name of the invariant - invariantViolationName :: Text - - -- | Evidence that the invariant was violated - , invariantViolationEvidence :: InvariantViolationEvidence - - -- | The 'Inductive' value at the point of the error - , invariantViolationInductive :: Inductive h a - } - - -- | The invariant was not checked because the input was invalid - | InvariantNotChecked { - -- | Name of the invariant - invariantNotCheckedName :: Text - - -- | Why did we not check the invariant - , invariantNotCheckedReason :: InvalidInput h a - - -- | The 'Inductive' value at the point of the error - , invariantNotCheckedInductive :: Inductive h a - } - --- | We were unable to check the invariant because the input was invalid --- --- This indicates a bug in the generator (or in the hand-written 'Inductive'), --- so we try to provide sufficient information to track that down. -data InvalidInput h a = - InvalidPending { - -- | The submitted transaction that was invalid - invalidPendingTransaction :: Transaction h a - - -- | The UTxO of the wallet at the time of submission - , invalidPendingWalletUtxo :: Utxo h a - - -- | The pending set of the wallet at time of submission - , invalidPendingWalletPending :: Pending h a - - -- | The ledger seen so far at the time of submission - , invalidPendingLedger :: Ledger h a - } - -{------------------------------------------------------------------------------- - Evidence that an invariant was violated - - Rather than just whether or not that the invariant is maintained, we try - to produce an informative error message when the invariant is /not/ - maintained so that we can debug what's going on. --------------------------------------------------------------------------------} - --- | Evidence that the invariance was violated -data InvariantViolationEvidence = - forall a. Buildable a => - NotEqual (Text, a) (Text, a) - | forall a. (Buildable a, Ord a) => - NotSubsetOf (Text, Set a) (Text, Set a) - | forall a. (Buildable a) => - NotAllSatisfy (Text, a -> Bool) (Text, [a]) - | forall a. (Buildable a, Ord a) => - NotDisjoint (Text, Set a) (Text, Set a) - -checkEqual :: (Buildable a, Eq a) - => (Text, a) -> (Text, a) -> Maybe InvariantViolationEvidence -checkEqual (labelX, x) (labelY, y) = - if x == y - then Nothing - else Just $ NotEqual (labelX, x) (labelY, y) - -checkSubsetOf :: (Buildable a, Ord a) - => (Text, Set a) -> (Text, Set a) -> Maybe InvariantViolationEvidence -checkSubsetOf (labelXs, xs) (labelYs, ys) = - if xs `Set.isSubsetOf` ys - then Nothing - else Just $ NotSubsetOf (labelXs, xs) (labelYs, ys) - -checkAllSatisfy :: Buildable a - => (Text, a -> Bool) -> (Text, [a]) -> Maybe InvariantViolationEvidence -checkAllSatisfy (labelP, p) (labelXs, xs) = - if all p xs - then Nothing - else Just $ NotAllSatisfy (labelP, p) (labelXs, xs) - -checkDisjoint :: (Buildable a, Ord a) - => (Text, Set a) -> (Text, Set a) -> Maybe InvariantViolationEvidence -checkDisjoint (labelXs, xs) (labelYs, ys) = - if disjoint xs ys - then Nothing - else Just $ NotDisjoint (labelXs, xs) (labelYs, ys) - -{------------------------------------------------------------------------------- - Specific invariants --------------------------------------------------------------------------------} - --- | Wallet invariant, parameterized by a function to construct the wallet -type WalletInv h a = (Hash h a, Buildable a, Eq a) - => Text -> (Transaction h a -> Wallet h a) -> Invariant h a - -walletInvariants :: WalletInv h a -walletInvariants l e w = sequence_ [ - pendingInUtxo l e w - , utxoIsOurs l e w - , changeNotAvailable l e w - , changeNotInUtxo l e w - , changeAvailable l e w - , balanceChangeAvailable l e w - ] - -pendingInUtxo :: WalletInv h a -pendingInUtxo l e = invariant (l <> "/pendingInUtxo") e $ \w -> - checkSubsetOf ("txIns (pending w)", - txIns (pending w)) - ("utxoDomain (utxo w)", - utxoDomain (utxo w)) - -utxoIsOurs :: WalletInv h a -utxoIsOurs l e = invariant (l <> "/utxoIsOurs") e $ \w -> - checkAllSatisfy ("isOurs", - isJust . ours w . outAddr) - ("utxoRange (utxo w)", - utxoRange (utxo w)) - -changeNotAvailable :: WalletInv h a -changeNotAvailable l e = invariant (l <> "/changeNotAvailable") e $ \w -> - checkDisjoint ("utxoDomain (change w)", - utxoDomain (change w)) - ("utxoDomain (available w)", - utxoDomain (available w)) - -changeNotInUtxo :: WalletInv h a -changeNotInUtxo l e = invariant (l <> "/changeNotInUtxo") e $ \w -> - checkDisjoint ("utxoDomain (change w)", - utxoDomain (change w)) - ("utxoDomain (utxo w)", - utxoDomain (utxo w)) - -changeAvailable :: WalletInv h a -changeAvailable l e = invariant (l <> "/changeAvailable") e $ \w -> - checkEqual ("change w `utxoUnion` available w" , - change w `utxoUnion` available w) - ("total w", - total w) - -balanceChangeAvailable :: WalletInv h a -balanceChangeAvailable l e = invariant (l <> "/balanceChangeAvailable") e $ \w -> - checkEqual ("balance (change w) + balance (available w)", - balance (change w) + balance (available w)) - ("balance (total w)", - balance (total w)) - -{------------------------------------------------------------------------------- - Compare different wallet implementations --------------------------------------------------------------------------------} - -walletEquivalent :: forall h a. (Hash h a, Eq a, Buildable a) - => Text - -> (Transaction h a -> Wallet h a) - -> (Transaction h a -> Wallet h a) - -> Invariant h a -walletEquivalent lbl e e' = void . - interpret notChecked (\boot -> [e boot, e' boot]) p - where - notChecked :: Inductive h a - -> InvalidInput h a - -> InvariantViolation h a - notChecked ind reason = InvariantNotChecked { - invariantNotCheckedName = lbl - , invariantNotCheckedReason = reason - , invariantNotCheckedInductive = ind - } - - violation :: Inductive h a - -> InvariantViolationEvidence - -> InvariantViolation h a - violation ind ev = InvariantViolation { - invariantViolationName = lbl - , invariantViolationEvidence = ev - , invariantViolationInductive = ind - } - - p :: Inductive h a - -> [Wallet h a] - -> Validated (InvariantViolation h a) () - p ind [w, w'] = sequence_ [ - cmp "pending" pending - , cmp "utxo" utxo - , cmp "availableBalance" availableBalance - , cmp "totalBalance" totalBalance - , cmp "available" available - , cmp "change" change - , cmp "total" total - ] - where - cmp :: (Eq b, Buildable b) - => Text - -> (Wallet h a -> b) - -> Validated (InvariantViolation h a) () - cmp fld f = - case checkEqual (fld <> " w", f w) (fld <> " w'", f w') of - Nothing -> return () - Just ev -> throwError $ violation ind ev - p _ _ = error "impossible" - {------------------------------------------------------------------------------- Auxiliary operations -------------------------------------------------------------------------------} @@ -501,514 +171,14 @@ updateUtxo p b = remSpent . addNew remSpent = utxoRemoveInputs (txIns b) updatePending :: forall h a. Hash h a => Block h a -> Pending h a -> Pending h a -updatePending b = Set.filter $ \t -> disjoint (trIns t) (txIns b) +updatePending b = Map.filter $ \t -> disjoint (trIns t) (txIns b) utxoRestrictToOurs :: Ours a -> Utxo h a -> Utxo h a -utxoRestrictToOurs p = utxoRestrictToAddr (isJust . p) - -{------------------------------------------------------------------------------- - Generation --------------------------------------------------------------------------------} - --- $generation --- --- The 'Inductive' data type describes a potential history of a wallet's --- view of an existing blockchain. This means that there are many possible --- 'Inductive's for any given blockchain -- any set of addresses can belong --- to the 'Inductive' that the wallet is for, and there are many possible --- sequences of actions that adequately describe the view of the --- blockchain. - --- | A monad for generating inductive chains. -newtype InductiveGen h a - = InductiveGen - { unInductiveGen :: ReaderT (InductiveCtx h) Gen a - } deriving (Functor, Applicative, Monad, MonadReader (InductiveCtx h)) - -runInductiveGen :: FromPreChain h () -> InductiveGen h a -> Gen a -runInductiveGen fpc ig = runReaderT (unInductiveGen ig) (initializeCtx fpc) - -data InductiveCtx h - = InductiveCtx - { icFromPreChain :: !(FromPreChain h ()) - } - -initializeCtx :: FromPreChain h () -> InductiveCtx h -initializeCtx fpc = InductiveCtx{..} - where - icFromPreChain = fpc - -getFromPreChain :: InductiveGen h (FromPreChain h ()) -getFromPreChain = asks icFromPreChain - -getBootstrap :: InductiveGen h (Transaction h Addr) -getBootstrap = fpcBoot <$> getFromPreChain - -getBlockchain :: InductiveGen h (Chain h Addr) -getBlockchain = fpcChain <$> getFromPreChain - -getLedger :: InductiveGen h (Ledger h Addr) -getLedger = fpcLedger <$> getFromPreChain - -getBootTransaction :: InductiveGen h (Transaction h Addr) -getBootTransaction = fpcBoot <$> getFromPreChain - --- | The 'Inductive' data type is isomorphic to a linked list of this --- 'Action' type. It is more convenient to operate on this type, as it can --- vary the sequence representation and reuse sequence functions. -data Action h a - = ApplyBlock' (Block h a) - | NewPending' (Transaction h a) - --- | Smart constructor that adds the callstack to the transaction's comments --- (Useful for finding out where transactions are coming from) -newPending' :: HasCallStack => [Text] -> Transaction h a -> Action h a -newPending' extra t = NewPending' (t { trExtra = trExtra t ++ extra }) - --- | Convert a container of 'Action's into an 'Inductive' wallet, --- given the bootstrap transaction. -toInductive :: (Hash h a, Buildable a) => Transaction h a -> [Action h a] -> Inductive h a -toInductive boot = foldl' k (WalletBoot boot) - where - k acc (ApplyBlock' a) = ApplyBlock acc a - k acc (NewPending' a) = NewPending acc a - --- | Given a 'Set' of addresses that will represent the addresses that --- belong to the generated 'Inductive' wallet and the 'FromPreChain' value --- that contains the relevant blockchain, this will be able to generate --- arbitrary views into the blockchain. -genFromBlockchain - :: Hash h Addr - => Set Addr - -> FromPreChain h () - -> Gen (Inductive h Addr) -genFromBlockchain addrs fpc = - runInductiveGen fpc (genInductiveFor addrs) - --- | Pair an 'Inductive' wallet definition with the set of addresses owned -data InductiveWithOurs h a = InductiveWithOurs { - inductiveWalletOurs :: Set a - , inductiveWalletDef :: Inductive h a - } - --- | Selects a random subset of addresses to be considered from the --- blockchain in the amount given. -genFromBlockchainPickingAccounts - :: Hash h Addr - => Int - -> FromPreChain h () - -> Gen (InductiveWithOurs h Addr) -genFromBlockchainPickingAccounts i fpc = do - let allAddrs = toList (ledgerAddresses (fpcLedger fpc)) - eligibleAddrs = filter (not . isAvvmAddr) allAddrs - - if null eligibleAddrs then - error - $ sformat - ( "No eligible addresses!\n\n" - % "All addresses: " % build - ) (intercalate ", " (map show allAddrs)) - else pure () - - addrs <- Set.fromList <$> sublistN i eligibleAddrs - - if null addrs then - error - $ sformat - ( "No addresses!\n\n" - % "All addresses: " % build - ) (intercalate ", " (map show allAddrs)) - else pure () - - InductiveWithOurs addrs <$> genFromBlockchain addrs fpc - -genInductiveFor :: Hash h Addr => Set Addr -> InductiveGen h (Inductive h Addr) -genInductiveFor addrs = do - boot <- getBootstrap - chain <- getBlockchain - intersperseTransactions boot addrs (chainToApplyBlocks chain) - --- | The first step in converting a 'Chain into an 'Inductive' wallet is --- to sequence the existing blocks using 'ApplyBlock' constructors. -chainToApplyBlocks :: Chain h a -> [Action h a] -chainToApplyBlocks = toList . map ApplyBlock' . chainBlocks - --- | Once we've created our initial @['Action' h 'Addr']@, we want to --- insert some 'Transaction's in appropriate locations in the list. There --- are some properties that the inserted events must satisfy: --- --- * The transaction must be after all of the blocks that confirm inputs to --- the transaction. --- * The transaction must be before the block that confirms it, if any --- blocks confirm it. It is not necessary that the transaction gets --- confirmed eventually! --- --- See Note [Intersperse] -intersperseTransactions - :: Hash h Addr - => Transaction h Addr -- ^ Bootstrap transaction - -> Set Addr -- ^ " Our " addresses - -> [Action h Addr] -- ^ Initial actions (the blocks in the chain) - -> InductiveGen h (Inductive h Addr) -intersperseTransactions boot addrs actions = do - chain <- getBlockchain - ledger <- getLedger - let ourTxns = findOurTransactions addrs ledger chain - let allTxnCount = length ourTxns - - -- we weight the frequency distribution such that most of the - -- transactions will be represented by this wallet. this can be - -- changed or made configurable later. - -- - -- also, weirdly, sometimes there aren't any transactions on any of the - -- addresses that belong to us. that seems like an edge case. - txnToDisperseCount <- if allTxnCount == 0 - then pure 0 - else liftGen - . frequency - . zip [1 .. allTxnCount] - . map pure - $ [1 .. allTxnCount] - - txnsToDisperse <- liftGen $ sublistN txnToDisperseCount ourTxns - - - let txnsWithRange = - mapMaybe - (\(i, t) -> (,,) t i <$> transactionFullyConfirmedAt addrs t chain ledger) - txnsToDisperse - - let chooseBlock t lo hi i = - (t { trExtra = sformat ("Inserted at " - % build - % " <= " - % build - % " < " - % build - ) lo i hi : trExtra t }, i) - txnsWithIndex <- fmap catMaybes $ - forM txnsWithRange $ \(t, hi, lo) -> - if hi > lo then - Just . chooseBlock t lo hi <$> liftGen (choose (lo, hi - 1)) - else - -- cannot create a pending transaction from a transaction that uses - -- inputs from the very same block in which it gets confirmed - return Nothing - - let append = flip (<>) - spent = Set.unions $ map (trIns . fst) txnsWithIndex - confirmed = - foldr - (\(t, i) -> IntMap.insertWith append i [newPending' [] t]) - (dissect actions) - txnsWithIndex - - unconfirmed <- synthesizeTransactions addrs spent - - return $ toInductive boot - . conssect - $ IntMap.unionWith (<>) confirmed unconfirmed - --- | Generate transactions that will never be confirmed --- --- We take as argument the set of inputs already spent by transactions that --- /will/ be confirmed, so that we don't create an 'Inductive' wallet with --- double spending. -synthesizeTransactions - :: forall h. Hash h Addr - => Set Addr -- ^ Addresses owned by the wallet - -> Set (Input h Addr) -- ^ Inputs already spent - -> InductiveGen h (IntMap [Action h Addr]) -synthesizeTransactions addrs alreadySpent = do - boot <- getBootTransaction - blocks <- toList . chainBlocks <$> getBlockchain - liftGen $ go IntMap.empty (trUtxo boot) alreadySpent 0 blocks - where - -- NOTE: We maintain a UTxO as we process the blocks. There are (at least) - -- two alternatives here: - -- - -- * Depend on a wallet implementation to keep track both of the utxo and - -- of the set of pending transactions. That would make the tests - -- kind of circular though (using the wallet to test the wallet); - -- better to keep the two independent. - -- * We could reuse the UTxOs that we compute while we compute the chain. - -- This is certainly a possibility, /but/ there is a downside there: - -- those UTxOs are approximate only, as we don't have any fees. - -- The chain as we have it here has proper fee values. - -- (Having said that, we still don't have proper fee values for the - -- transactions we generate here.) - go :: IntMap [Action h Addr] -- Accumulator - -> Utxo h Addr -- Current utxo - -> Set (Input h Addr) -- All inputs already spent - -> Int -- Index of the next block - -> [Block h Addr] -- Chain yet to process - -> Gen (IntMap [Action h Addr]) - go acc _ _ _ [] = - -- We could create some pending transactions after the very last block, - -- but we don't - return acc - go acc utxoBefore spent ix (b:bs) = do - pct <- choose (0, 100 :: Int) - if pct >= 5 || utxoNull utxoAvail - then go acc utxoAfter spent (ix + 1) bs - else do - (i, o) <- elements $ utxoToList utxoAvail - dests <- selectDestinations' Set.empty utxoAfter - let txn = divvyUp newHash (pure (i, o)) dests 0 - act = newPending' ["never confirmed"] txn - go (IntMap.insert ix [act] acc) - utxoAfter - (Set.insert i spent) - (ix + 1) - bs - where - utxoAfter = utxoApplyBlock b utxoBefore - utxoAvail = oursNotSpent spent utxoAfter - newHash = (-1) - ix -- negative hashes not used elsewhere - - oursNotSpent :: Set (Input h Addr) -> Utxo h Addr -> Utxo h Addr - oursNotSpent spent = utxoRemoveInputs spent - . utxoRestrictToAddr (`Set.member` addrs) - --- | Construct an 'IntMap' consisting of the index of the element in the --- input list pointing to a singleton list of the element the original --- list. -dissect :: [a] -> IntMap [a] -dissect = IntMap.fromList . zip [0..] . map pure - --- | Reverse the operation of 'dissect'. Given an 'IntMap' originally --- representing the original index in the list pointing to the list of new --- items at that starting index, collapse that into a single list of --- elements. -conssect :: IntMap [a] -> [a] -conssect = concatMap snd . IntMap.toList - --- | Given a 'Set' of addresses and a 'Chain', this function returns a list --- of the transactions with *inputs* belonging to any of the addresses and --- the index of the block that the transaction is confirmed in. -findOurTransactions - :: (Hash h a, Ord a) - => Set a - -> Ledger h a - -> Chain h a - -> [(Int, Transaction h a)] -findOurTransactions addrs ledger = - concatMap k . zip [0..] . toList . chainBlocks - where - k (i, block) = - map ((,) i) - . filter (all p . trIns) - $ toList block - p = fromMaybe False - . fmap (\o -> outAddr o `Set.member` addrs) - . (`inpSpentOutput` ledger) - --- | This function identifies the index of the block that the input was --- received in the ledger, marking the point at which it may be inserted as --- a 'NewPending' transaction. -blockReceivedIndex :: Hash h Addr => Input h Addr -> Chain h Addr -> Maybe Int -blockReceivedIndex i = - List.findIndex (any ((inpTrans i ==) . hash)) . toList . chainBlocks - --- | For each 'Input' in the 'Transaction' that belongs to one of the --- 'Addr'esses in the 'Set' provided, find the index of the block in the --- 'Chain' that confirms that 'Input'. Take the maximum index and return --- that -- that is the earliest this transaction may appear as a pending --- transaction. -transactionFullyConfirmedAt - :: Hash h Addr - => Set Addr - -> Transaction h Addr - -> Chain h Addr - -> Ledger h Addr - -> Maybe Int -transactionFullyConfirmedAt addrs txn chain ledger = - let inps = Set.filter inputInAddrs (trIns txn) - inputInAddrs i = - case inpSpentOutput i ledger of - Just o -> outAddr o `Set.member` addrs - Nothing -> False - indexes = Set.map (\i -> blockReceivedIndex i chain) inps - in foldl' max Nothing indexes - -liftGen :: Gen a -> InductiveGen h a -liftGen = InductiveGen . lift - -{- Note [Intersperse] -~~~~~~~~~~~~~~~~~~~~~ -Given a list of blocks - -> [ applyBlock_0, applyBlock_1, applyBlock_2, applyBlock_3, applyBlock_4 ] - -we construct an 'IntMap' out of them where the index in the intmap is the -original index of that block in the chain: - -> { 0 -> [applyBlock_0] -> , 1 -> [applyBlock_1] -> , 2 -> [applyBlock_2] -> , 3 -> [applyBlock_3] -> , 4 -> [applyBlock_4] -> } - -Then, when we select an index between @lo@ (the latest block to confirm an input -in the transaction) and @hi@ (the index of the block that confirms the -transaction itself), we can 'insertWith' at that index. Suppose we have a -transaction @t@ where the input was provided in block 1 and is confirmed in -block 3. That means we can have @NewPending t@ inserted into either index 1 or -2: - -> { 0 -> [applyBlock_0] -> , 1 -> [applyBlock_1] <> [newPending t] = [applyBlock_1, newPending t] -> , 2 -> [applyBlock_2] -> , 3 -> [applyBlock_3] -> , 4 -> [applyBlock_4] -> } - -or - -> { 0 -> [applyBlock_0] -> , 1 -> [applyBlock_1] -> , 2 -> [applyBlock_2] <> [newPending t] = [applyBlock_2, newPending t] -> , 3 -> [applyBlock_3] -> , 4 -> [applyBlock_4] -> } - -Then, when we finally go to 'conssec' the @IntMap [Action h a]@ back into a -@[Action h a]@, we get: - -> [ applyBlock_0 -> , applyBlock_1 -> , applyBlock_2, newPending t -> , applyBlock_3 -> , applyBlock_4 -> ] - -TODO: This means that currently we never insert pending transactions before -the first block. --} +utxoRestrictToOurs = utxoRestrictToAddr {------------------------------------------------------------------------------- Pretty-printing -------------------------------------------------------------------------------} instance (Hash h a, Buildable a) => Buildable (Pending h a) where - build = bprint listJson . Set.toList - -instance (Hash h a, Buildable a) => Buildable (InvalidInput h a) where - build InvalidPending{..} = bprint - ( "InvalidPending " - % "{ transaction: " % build - % ", walletUtxo: " % build - % ", walletPending: " % build - % ", ledger: " % build - % "}" - ) - invalidPendingTransaction - invalidPendingWalletUtxo - invalidPendingWalletPending - invalidPendingLedger - -instance (Hash h a, Buildable a) => Buildable (InvariantViolation h a) where - build InvariantViolation{..} = bprint - ( "InvariantViolation " - % "{ name: " % build - % ", evidence: " % build - % ", inductive: " % build - % "}" - ) - invariantViolationName - invariantViolationEvidence - invariantViolationInductive - build (InvariantNotChecked{..}) = bprint - ( "InvariantNotChecked " - % "{ name: " % build - % ", reason: " % build - % ", inductive: " % build - % "}" - ) - invariantNotCheckedName - invariantNotCheckedReason - invariantNotCheckedInductive - -instance Buildable InvariantViolationEvidence where - build (NotEqual (labelX, x) (labelY, y)) = bprint - ( "NotEqual " - % "{ " % build % ": " % build - % ", " % build % ": " % build - % "}" - ) - labelX - x - labelY - y - build (NotSubsetOf (labelXs, xs) (labelYs, ys)) = bprint - ( "NotSubsetOf " - % "{ " % build % ": " % listJson - % ", " % build % ": " % listJson - % ", " % build % ": " % listJson - % "}" - ) - labelXs - (Set.toList xs) - labelYs - (Set.toList ys) - (labelXs <> " \\\\ " <> labelYs) - (Set.toList $ xs Set.\\ ys) - build (NotAllSatisfy (labelP, p) (labelXs, xs)) = bprint - ( "NotAllSatisfy " - % "{ " % build % ": " % build - % ", " % build % ": " % listJson - % ", " % build % ": " % listJson - % "}" - ) - ("pred" :: Text) - labelP - labelXs - xs - ("filter (not . " <> labelP <> ")") - (filter (not . p) xs) - build (NotDisjoint (labelXs, xs) (labelYs, ys)) = bprint - ( "NotSubsetOf " - % "{ " % build % ": " % listJson - % ", " % build % ": " % listJson - % ", " % build % ": " % listJson - % "}" - ) - labelXs - (Set.toList xs) - labelYs - (Set.toList ys) - (labelXs <> " `intersection` " <> labelYs) - (Set.toList $ xs `Set.intersection` ys) - --- | We output the inductive in the order that things are applied; something like --- --- > { "boot": --- > , "block": --- > , "new": --- > , "block": --- > .. --- > } -instance (Hash h a, Buildable a) => Buildable (Inductive h a) where - build ind = bprint (build % "}") (go ind) - where - go (WalletBoot t) = bprint ( "{ boot: " % build) t - go (ApplyBlock n b) = bprint (build % ", block: " % build) (go n) b - go (NewPending n t) = bprint (build % ", new: " % build) (go n) t - -instance (Hash h a, Buildable a) => Buildable (Action h a) where - build (ApplyBlock' b) = bprint ("ApplyBlock' " % build) b - build (NewPending' t) = bprint ("NewPending' " % build) t - -instance (Hash h a, Buildable a) => Buildable [Action h a] where - build = bprint listJson - -instance (Hash h a, Buildable a) => Buildable (InductiveWithOurs h a) where - build InductiveWithOurs{..} = bprint - ( "InductiveWithOurs" - % "{ ours: " % listJson - % ", def: " % build - % "}" - ) - inductiveWalletOurs - inductiveWalletDef + build = bprint mapJson diff --git a/wallet-new/test/unit/Wallet/Basic.hs b/wallet-new/test/unit/Wallet/Basic.hs index 19b1a97b01d..64839324568 100644 --- a/wallet-new/test/unit/Wallet/Basic.hs +++ b/wallet-new/test/unit/Wallet/Basic.hs @@ -19,7 +19,9 @@ module Wallet.Basic ( import Universum hiding (State) import Control.Lens.TH -import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.Text.Buildable +import Formatting (bprint, build, (%)) import UTxO.DSL import Wallet.Abstract @@ -38,14 +40,14 @@ makeLenses ''State initState :: State h a initState = State { _stateUtxo = utxoEmpty - , _statePending = Set.empty + , _statePending = Map.empty } {------------------------------------------------------------------------------- Construction -------------------------------------------------------------------------------} -mkWallet :: (Hash h a, Ord a) +mkWallet :: (Hash h a, Buildable st) => Ours a -> Lens' st (State h a) -> WalletConstr h a st mkWallet ours l self st = (mkDefaultWallet (l . statePending) self st) { utxo = st ^. l . stateUtxo @@ -53,7 +55,7 @@ mkWallet ours l self st = (mkDefaultWallet (l . statePending) self st) { , applyBlock = \b -> self (st & l %~ applyBlock' ours b) } -walletEmpty :: (Hash h a, Ord a) => Ours a -> Wallet h a +walletEmpty :: (Hash h a, Buildable a) => Ours a -> Wallet h a walletEmpty ours = fix (mkWallet ours identity) initState {------------------------------------------------------------------------------- @@ -66,3 +68,17 @@ applyBlock' ours b State{..} = State { _stateUtxo = updateUtxo ours b _stateUtxo , _statePending = updatePending b _statePending } + +{------------------------------------------------------------------------------- + Pretty-printing +-------------------------------------------------------------------------------} + +instance (Hash h a, Buildable a) => Buildable (State h a) where + build State{..} = bprint + ( "State" + % "{ utxo: " % build + % ", pending: " % build + % "}" + ) + _stateUtxo + _statePending diff --git a/wallet-new/test/unit/Wallet/Incremental.hs b/wallet-new/test/unit/Wallet/Incremental.hs index 54fdb740b87..bc50162bc7b 100644 --- a/wallet-new/test/unit/Wallet/Incremental.hs +++ b/wallet-new/test/unit/Wallet/Incremental.hs @@ -22,7 +22,9 @@ module Wallet.Incremental ( import Universum hiding (State) import Control.Lens.TH -import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.Text.Buildable +import Formatting (bprint, build, (%)) import Util import UTxO.DSL @@ -59,7 +61,7 @@ initState = State { Construction -------------------------------------------------------------------------------} -mkWallet :: (Hash h a, Ord a) +mkWallet :: (Hash h a, Buildable st) => Ours a -> Lens' st (State h a) -> WalletConstr h a st mkWallet ours l self st = (Basic.mkWallet ours (l . stateBasic) self st) { applyBlock = \b -> @@ -73,7 +75,7 @@ mkWallet ours l self st = (Basic.mkWallet ours (l . stateBasic) self st) { where this = self st -walletEmpty :: (Hash h a, Ord a) => Ours a -> Wallet h a +walletEmpty :: (Hash h a, Buildable a) => Ours a -> Wallet h a walletEmpty ours = fix (mkWallet ours identity) initState {------------------------------------------------------------------------------- @@ -91,7 +93,7 @@ applyBlock' (ins, outs) State{..} = State{ , _stateUtxoBalance = balance' } where - pending' = Set.filter (\t -> disjoint (trIns t) ins) _statePending + pending' = Map.filter (\t -> disjoint (trIns t) ins) _statePending utxoNew = outs unionNew = _stateUtxo `utxoUnion` utxoNew utxoRem = utxoRestrictToInputs ins unionNew @@ -99,3 +101,17 @@ applyBlock' (ins, outs) State{..} = State{ balance' = _stateUtxoBalance + balance utxoNew - balance utxoRem Basic.State{..} = _stateBasic + +{------------------------------------------------------------------------------- + Pretty-printing +-------------------------------------------------------------------------------} + +instance (Hash h a, Buildable a) => Buildable (State h a) where + build State{..} = bprint + ( "State" + % "{ basic: " % build + % ", utxoBalance: " % build + % "}" + ) + _stateBasic + _stateUtxoBalance diff --git a/wallet-new/test/unit/Wallet/Inductive.hs b/wallet-new/test/unit/Wallet/Inductive.hs new file mode 100644 index 00000000000..e333060a85a --- /dev/null +++ b/wallet-new/test/unit/Wallet/Inductive.hs @@ -0,0 +1,86 @@ +module Wallet.Inductive ( + -- * Wallet events + WalletEvent(..) + , walletEventIsRollback + -- * Inductive wallets + , Inductive(..) + , uptoFirstRollback + ) where + +import Universum + +import qualified Data.Set as Set +import qualified Data.Text.Buildable +import Formatting (bprint, build, (%)) +import Pos.Core.Chrono +import Serokell.Util (listJson) + +import Util +import UTxO.DSL + +{------------------------------------------------------------------------------- + Wallet events +-------------------------------------------------------------------------------} + +-- | Wallet event +data WalletEvent h a = + -- | Inform the wallet of a new block added to the blockchain + ApplyBlock (Block h a) + + -- | Submit a new transaction to the wallet to be included in the blockchain + | NewPending (Transaction h a) + + -- | Roll back the last block added to the blockchain + | Rollback + +walletEventIsRollback :: WalletEvent h a -> Bool +walletEventIsRollback Rollback = True +walletEventIsRollback _ = False + +{------------------------------------------------------------------------------- + Inductive wallets +-------------------------------------------------------------------------------} + +-- | Inductive definition of a wallet +data Inductive h a = Inductive { + -- | Bootstrap transaction + inductiveBoot :: Transaction h a + + -- | Addresses that belong to the wallet + , inductiveOurs :: Set a + + -- | Wallet events + , inductiveEvents :: OldestFirst [] (WalletEvent h a) + } + +-- | The prefix of the 'Inductive' that doesn't include any rollbacks +uptoFirstRollback :: Inductive h a -> Inductive h a +uptoFirstRollback i@Inductive{..} = i { + inductiveEvents = liftOldestFirst (takeWhile notRollback) inductiveEvents + } + where + notRollback = not . walletEventIsRollback + +{------------------------------------------------------------------------------- + Pretty-printing +-------------------------------------------------------------------------------} + +instance (Hash h a, Buildable a) => Buildable (OldestFirst [] (WalletEvent h a)) where + build = bprint listJson . getOldestFirst + +instance (Hash h a, Buildable a) => Buildable (WalletEvent h a) where + build (ApplyBlock b) = bprint ("ApplyBlock " % build) b + build (NewPending t) = bprint ("NewPending " % build) t + build Rollback = bprint "Rollback" + +instance (Hash h a, Buildable a) => Buildable (Inductive h a) where + build Inductive{..} = bprint + ( "Inductive" + % "{ boot: " % build + % ", ours: " % listJson + % ", events: " % build + % "}" + ) + inductiveBoot + (Set.toList inductiveOurs) + inductiveEvents diff --git a/wallet-new/test/unit/Wallet/Inductive/Cardano.hs b/wallet-new/test/unit/Wallet/Inductive/Cardano.hs new file mode 100644 index 00000000000..5fbe39c8e5f --- /dev/null +++ b/wallet-new/test/unit/Wallet/Inductive/Cardano.hs @@ -0,0 +1,336 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE UndecidableInstances #-} + +module Wallet.Inductive.Cardano ( + -- * Cardano interpreter for the inductive wallet + EventCallbacks(..) + , interpretT + -- * Equivalence check + , EquivalenceViolation(..) + , EquivalenceViolationEvidence(..) + , equivalentT + ) where + +import Universum + +import qualified Cardano.Wallet.Kernel as Kernel +import Cardano.Wallet.Kernel.Types +import qualified Data.Text.Buildable +import qualified Data.List as List +import Formatting (bprint, build, (%)) + +import Pos.Txp (Utxo, formatUtxo) +import Pos.Core (HasConfiguration, AddressHash) +import Pos.Crypto (EncryptedSecretKey, PublicKey) +import Pos.Core.Chrono + +import qualified Cardano.Wallet.Kernel.DB.HdWallet as HD + +import Util +import Util.Validated +import UTxO.Context (Addr) +import UTxO.DSL (Hash) +import qualified UTxO.DSL as DSL +import UTxO.Interpreter +import UTxO.Translate +import Wallet.Abstract +import Wallet.Inductive + +{------------------------------------------------------------------------------- + Interpreter for the wallet using the translated Cardano types +-------------------------------------------------------------------------------} + +-- | Callbacks used in 'interpretT' +-- +-- We do not run the callback in the 'IntT' monad so that we maintain +-- control over the interpretation context. +data EventCallbacks h m = EventCallbacks { + -- | Initialize the wallet + -- + -- The callback is given the translated UTxO of the bootstrap + -- transaction (we cannot give it the translated transaction because + -- we cannot translate the bootstrap transaction). + walletBootT :: HasConfiguration => InductiveCtxt h -> Utxo -> m HD.HdAccountId + + -- | Apply a block + , walletApplyBlockT :: HasConfiguration => InductiveCtxt h -> HD.HdAccountId -> RawResolvedBlock -> m () + + -- | Insert new pending transaction + , walletNewPendingT :: InductiveCtxt h -> HD.HdAccountId -> RawResolvedTx -> m () + + -- | Rollback + -- + -- TODO: Do we want to call 'switch' here? If so, we need some of the logic + -- from the wallet worker thread to collapse multiple rollbacks and + -- apply blocks into a single call to switch + , walletRollbackT :: InductiveCtxt h -> HD.HdAccountId -> m () + } + +-- | The context in which a function of 'EventCallbacks' gets called +data InductiveCtxt h = InductiveCtxt { + -- | The events that led to this point + inductiveCtxtEvents :: OldestFirst [] (WalletEvent h Addr) + + -- | The 'IntCtxt' suitable for translation derived values + -- (such as UTxOs) + , inductiveCtxtInt :: IntCtxt h + + -- | The pure wallet value at this point + , inductiveCtxtWallet :: Wallet h Addr + } + +-- | Interpreter for inductive wallets using the translated Cardano types +interpretT :: forall h e m. (Monad m, Hash h Addr) + => (DSL.Transaction h Addr -> Wallet h Addr) + -> EventCallbacks h (TranslateT e m) + -> Inductive h Addr + -> TranslateT (Either IntException e) m (Wallet h Addr, IntCtxt h) +interpretT mkWallet EventCallbacks{..} Inductive{..} = + goBoot inductiveBoot + where + goBoot :: DSL.Transaction h Addr + -> TranslateT (Either IntException e) m (Wallet h Addr, IntCtxt h) + goBoot boot = do + let w' = mkWallet boot + initCtxt <- mapTranslateErrors Left $ initIntCtxt boot + runIntT initCtxt $ do + let history = NewestFirst [] + utxo' <- int (utxo w') -- translating UTxO does not change the state + let ctxt = InductiveCtxt (toOldestFirst history) initCtxt w' + accountId <- liftTranslate $ walletBootT ctxt utxo' + goEvents accountId history w' (getOldestFirst inductiveEvents) + + goEvents :: HD.HdAccountId + -> NewestFirst [] (WalletEvent h Addr) + -> Wallet h Addr + -> [WalletEvent h Addr] + -> IntT h e m (Wallet h Addr) + goEvents accountId = go + where + go :: NewestFirst [] (WalletEvent h Addr) + -> Wallet h Addr + -> [WalletEvent h Addr] + -> IntT h e m (Wallet h Addr) + go _ w [] = + return w + go history w (ApplyBlock b:es) = do + let history' = liftNewestFirst (ApplyBlock b :) history + w' = applyBlock w b + b' <- int b + ic <- get + let ctxt = InductiveCtxt (toOldestFirst history') ic w' + liftTranslate $ walletApplyBlockT ctxt accountId b' + go history' w' es + go history w (NewPending t:es) = do + let history' = liftNewestFirst (NewPending t :) history + (Just w') = newPending w t + t' <- int t + ic <- get + let ctxt = InductiveCtxt (toOldestFirst history') ic w' + liftTranslate $ walletNewPendingT ctxt accountId t' + go history' w' es + go history w (Rollback:es) = do + let history' = liftNewestFirst (Rollback :) history + w' = rollback w + ic <- get + let ctxt = InductiveCtxt (toOldestFirst history') ic w' + liftTranslate $ walletRollbackT ctxt accountId + go history' w' es + +{------------------------------------------------------------------------------- + Equivalence check between the real implementation and (a) pure wallet +-------------------------------------------------------------------------------} + +equivalentT :: forall h m. (Hash h Addr, MonadIO m) + => Kernel.ActiveWallet + -> (AddressHash PublicKey, EncryptedSecretKey) + -> (DSL.Transaction h Addr -> Wallet h Addr) + -> Inductive h Addr + -> TranslateT IntException m (Validated (EquivalenceViolation h) ()) +equivalentT activeWallet (pk,esk) = \mkWallet w -> + fmap (void . validatedFromEither) + $ catchSomeTranslateErrors + $ interpretT mkWallet EventCallbacks{..} w + where + passiveWallet = Kernel.walletPassive activeWallet + + walletBootT :: InductiveCtxt h + -> Utxo + -> TranslateT (EquivalenceViolation h) m HD.HdAccountId + walletBootT ctxt utxo = do + res <- liftIO $ Kernel.createWalletHdRnd passiveWallet walletName + spendingPassword assuranceLevel + (pk,esk) utxo + + either createWalletErr (checkWalletAccountState ctxt) res + + where + walletName = HD.WalletName "(test wallet)" + spendingPassword = HD.NoSpendingPassword + assuranceLevel = HD.AssuranceLevelNormal + + createWalletErr _ = error "ERROR: could not create the HdWallet" + + checkWalletAccountState ctxt' accountIds' = do + let accountId' = pickSingletonAccountId accountIds' + checkWalletState ctxt' accountId' + return accountId' + + -- Since the DSL Wallet does not model Account, a DSL Wallet is expressed + -- as a Cardano Wallet with exactly one Account. + -- Here, we safely extract the AccountId. + pickSingletonAccountId :: [HD.HdAccountId] -> HD.HdAccountId + pickSingletonAccountId accountIds' = + case length accountIds' of + 1 -> List.head accountIds' + 0 -> error "ERROR: no accountIds generated for the given Utxo" + _ -> error "ERROR: multiple AccountIds, only one expected" + + walletApplyBlockT :: InductiveCtxt h + -> HD.HdAccountId + -> RawResolvedBlock + -> TranslateT (EquivalenceViolation h) m () + walletApplyBlockT ctxt accountId block = do + liftIO $ Kernel.applyBlock passiveWallet (fromRawResolvedBlock block) + checkWalletState ctxt accountId + + walletNewPendingT :: InductiveCtxt h + -> HD.HdAccountId + -> RawResolvedTx + -> TranslateT (EquivalenceViolation h) m () + walletNewPendingT ctxt accountId tx = do + _ <- liftIO $ Kernel.newPending activeWallet accountId (rawResolvedTx tx) + checkWalletState ctxt accountId + + walletRollbackT :: InductiveCtxt h + -> HD.HdAccountId + -> TranslateT (EquivalenceViolation h) m () + walletRollbackT _ _ = error "walletRollbackT: TODO" + + checkWalletState :: InductiveCtxt h + -> HD.HdAccountId + -> TranslateT (EquivalenceViolation h) m () + checkWalletState ctxt@InductiveCtxt{..} accountId = do + cmp "utxo" utxo (`Kernel.accountUtxo` accountId) + cmp "totalBalance" totalBalance (`Kernel.accountTotalBalance` accountId) + -- TODO: check other properties + where + cmp :: ( Interpret h a + , Eq (Interpreted a) + , Buildable a + , Buildable (Interpreted a) + ) + => Text + -> (Wallet h Addr -> a) + -> (Kernel.PassiveWallet -> IO (Interpreted a)) + -> TranslateT (EquivalenceViolation h) m () + cmp fld f g = do + let dsl = f inductiveCtxtWallet + translated <- toCardano ctxt fld dsl + kernel <- liftIO $ g passiveWallet + + unless (translated == kernel) $ + throwError EquivalenceViolation { + equivalenceViolationName = fld + , equivalenceViolationEvents = inductiveCtxtEvents + , equivalenceViolationEvidence = NotEquivalent { + notEquivalentDsl = dsl + , notEquivalentTranslated = translated + , notEquivalentKernel = kernel + } + } + + toCardano :: Interpret h a + => InductiveCtxt h + -> Text + -> a -> TranslateT (EquivalenceViolation h) m (Interpreted a) + toCardano InductiveCtxt{..} fld a = do + ma' <- catchTranslateErrors $ runIntT' inductiveCtxtInt $ int a + case ma' of + Left err -> throwError EquivalenceNotChecked { + equivalenceNotCheckedName = fld + , equivalenceNotCheckedReason = err + , equivalenceNotCheckedEvents = inductiveCtxtEvents + } + Right (a', _ic') -> + return a' + +data EquivalenceViolation h = + -- | Cardano wallet and pure wallet are not equivalent + EquivalenceViolation { + -- | The property we were checking + equivalenceViolationName :: Text + + -- | Evidence (what was not the same?) + , equivalenceViolationEvidence :: EquivalenceViolationEvidence + + -- | The events that led to the error + , equivalenceViolationEvents :: OldestFirst [] (WalletEvent h Addr) + } + + -- | We got an unexpected interpretation exception + -- + -- This indicates a bug in the tesing infrastructure. + | EquivalenceNotChecked { + -- | The property we were checking + equivalenceNotCheckedName :: Text + + -- | Why did we not check the equivalence + , equivalenceNotCheckedReason :: IntException + + -- | The events that led to the error + , equivalenceNotCheckedEvents :: OldestFirst [] (WalletEvent h Addr) + } + +data EquivalenceViolationEvidence = + forall a. (Buildable a, Buildable (Interpreted a)) => NotEquivalent { + notEquivalentDsl :: a + , notEquivalentTranslated :: Interpreted a + , notEquivalentKernel :: Interpreted a + } + +{------------------------------------------------------------------------------- + Pretty-printing +-------------------------------------------------------------------------------} + +instance Hash h Addr => Buildable (EquivalenceViolation h) where + build EquivalenceViolation{..} = bprint + ( "EquivalenceViolation " + % "{ name: " % build + % ", evidence: " % build + % ", events: " % build + % "}" + ) + equivalenceViolationName + equivalenceViolationEvidence + equivalenceViolationEvents + build EquivalenceNotChecked{..} = bprint + ( "EquivalenceNotChecked " + % "{ name: " % build + % ", reason: " % build + % ", events: " % build + % "}" + ) + equivalenceNotCheckedName + equivalenceNotCheckedReason + equivalenceNotCheckedEvents + +instance Buildable EquivalenceViolationEvidence where + build NotEquivalent{..} = bprint + ( "NotEquivalent " + % "{ notEquivalentDsl: " % build + % ", notEquivalentTranslated: " % build + % ", notEquivalentKernel: " % build + % "}" + ) + notEquivalentDsl + notEquivalentTranslated + notEquivalentKernel + +{------------------------------------------------------------------------------- + Orphans (TODO: avoid) +-------------------------------------------------------------------------------} + +instance Buildable Utxo where + build = formatUtxo diff --git a/wallet-new/test/unit/Wallet/Inductive/Generator.hs b/wallet-new/test/unit/Wallet/Inductive/Generator.hs new file mode 100644 index 00000000000..654609bb7f0 --- /dev/null +++ b/wallet-new/test/unit/Wallet/Inductive/Generator.hs @@ -0,0 +1,442 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +module Wallet.Inductive.Generator ( + -- * Wallet event tree + -- ** Parameters + GenEventsParams(..) + , defEventsParams + -- ** State + , GenEventsGlobalState(..) + , gegsNextHash + , gegsPending + , initEventsGlobalState + -- ** Generator + , GenEvents + , genEventTree + -- * Wallet events + , genWalletEvents + ) where + +import Universum + +import Control.Lens (Iso', alongside, iso, zoom, (%=), (+=)) +import Control.Lens.TH (makeLenses) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Tree +import Pos.Core.Chrono +import Test.QuickCheck + +import Util +import UTxO.DSL +import UTxO.Generator +import Wallet.Inductive + +{------------------------------------------------------------------------------- + Wallet event tree +-------------------------------------------------------------------------------} + +-- | Probability (value between 0 and 1) +type Probability = Double + +-- | Set of transactions, indexed by their given hash +-- +-- We can do this because we will use globally unique hashes +type Transactions h a = Map (GivenHash (Transaction h a)) (Transaction h a) + +-- | Parameters for wallet event tree generation +data GenEventsParams h a = GenEventsParams { + -- | Transaction parameters + -- + -- NOTE: Right now we use a single set of transaction parameters both + -- for generating system transactions and for generating wallet + -- transactions. We may want to split that. + gepTrParams :: GenTrParams a + + -- | The set of addresses that belong the wallet + , gepOurs :: Set a + + -- | Initial UTxO + , gepInitUtxo :: Utxo h a + + -- | Probability of generating a pending transaction + , gepPendingProb :: Probability + + -- | Maximum number of transactions in a block + , gepMaxBlockSize :: Int + + -- | Probability that any given transaction in the shared pool will + -- be included in the next block (see also '_gelsNextBlock') + , gepSharedCommitProb :: Probability + + -- | Probability that pending transactions are included in the next block + , gepPendingCommitProb :: Probability + + -- | Frequencies of branching factors + -- + -- For example, @[50, 45, 3, 2]% means that + -- + -- - Each branch has a probability of 50% of being terminated + -- - With probability 45% we have a branching factor of 1 + -- (i.e., continue linearly) + -- - With probability 3% and 2% we branch into 2 and 3 twines. + -- + -- Note that we terminate a branch only if it is longer than the previous + -- (so that we never switch to a shorter fork). This means that the first + -- possiblity (branch termination) may not apply; in that case, the + -- probabilities of a branching factor of 1, 2 and 3 in this example + -- become 90%, 6% and 4%, respectively (note that these numbers are + -- /frequencies/, not probabilities). + , gepBranchingFrequencies :: [Int] + + -- | Maximum number of forks + -- + -- This puts a bound on how many forks we create (and tehrefore on the + -- size of the tree) independent from the branching frequencies + -- ('gepBranchingFrequencies'). + , gepMaxNumForks :: Int + } + +defEventsParams :: (Int -> [Value] -> Value) -- ^ Fee model + -> [a] -- ^ Addresses we can generate outputs to + -> Set a -- ^ Addresses that belong to the wallet + -> Utxo h a -- ^ Initial UTxO + -> GenEventsParams h a +defEventsParams feeModel + addresses + ours + utxo + = GenEventsParams { + gepTrParams = defTrParams feeModel addresses + , gepOurs = ours + , gepInitUtxo = utxo + , gepPendingProb = 0.2 + , gepMaxBlockSize = 10 + , gepSharedCommitProb = 0.8 + , gepPendingCommitProb = 0.8 + , gepBranchingFrequencies = [50, 45, 3, 2] + , gepMaxNumForks = 5 + } + +-- | The global state +-- +-- " Global " here refers to " not local to a branch " +data GenEventsGlobalState h a = GenEventsGlobalState { + -- | We store the hash in the global state so that we generally + -- globally unique hashes. This makes debugging a bit easier. + _gegsNextHash :: Int + + -- | Total set of transactions /ever/ submitted by the wallet + -- + -- We add new transactions into this set when the wallet, but never + -- remove from them, and this set is uneffected by rollback + -- (hence it lives in the global state). This models the fact that + -- transactions once submitted into the system "stay out there". + , _gegsPending :: Transactions h a + + -- | Maximum height of any path through the tree generated so far + , _gegsMaxLength :: Int + + -- | Number of forks created so far + , _gegsNumForks :: Int + } + +-- | Branch local state +data GenEventsLocalState h a = GenEventsLocalState { + -- | System input state + -- + -- Used for generating transactions that can use the entire UTxO + _gelsSystemInpState :: GenInpState h a + + -- | Wallet input state + -- + -- Used for generating transactions that can only use the wallet's UTxO + , _gelsWalletInpState :: GenInpState h a + + -- | Transactions we can chose from for the next block we generate + -- + -- Since we want a high degree of overlap between the sets of transactions + -- across the twines of a fork, at each branch point we generate a set + -- of transactions that we can then choose from in the separate branches. + -- + -- In order to make it possible to do a random selection from this set, + -- we make sure that these transactions are mutually independent. + , _gelsNextBlock :: Transactions h a + + -- | Length of the current branch + , _gelsLength :: Int + } + +makeLenses ''GenEventsGlobalState +makeLenses ''GenEventsLocalState + +-- | Initial 'GenEventsGlobalState' +initEventsGlobalState :: Int -- ^ First available hash + -> GenEventsGlobalState h a +initEventsGlobalState nextHash = GenEventsGlobalState { + _gegsNextHash = nextHash + , _gegsPending = Map.empty + , _gegsMaxLength = 0 + , _gegsNumForks = 0 + } + +-- | Lens to the system UTxO +gelsSystemUtxo :: Lens' (GenEventsLocalState h a) (Utxo h a) +gelsSystemUtxo = gelsSystemInpState . gisUtxo + +-- | Lens to the wallet UTxO +gelsWalletUTxO :: Lens' (GenEventsLocalState h a) (Utxo h a) +gelsWalletUTxO = gelsWalletInpState . gisUtxo + +-- | Combine local and global state +type GenEventsState h a = (GenEventsLocalState h a, GenEventsGlobalState h a) + +-- | Events generator +type GenEvents h a = StateT (GenEventsGlobalState h a) Gen + +-- | Branch generator +type GenBranch h a = StateT (GenEventsState h a) Gen + +-- | Branch seeds generator +-- +-- This is the signature that 'unfoldTreeM' requires. +type GenSeeds h a x = GenEventsLocalState h a -> GenEvents h a (x, [GenEventsLocalState h a]) + +-- | Lift actions that require the combined state +withCombinedState :: GenEventsLocalState h a + -> GenBranch h a x -> GenEvents h a (x, GenEventsLocalState h a) +withCombinedState ls act = StateT $ fmap reassoc . runStateT act . (ls,) + where + reassoc :: (a, (b, c)) -> ((a, b), c) + reassoc (a, (b, c)) = ((a, b), c) + +-- | Variation on 'withCombinedState' with no additional return value +withCombinedState_ :: GenEventsLocalState h a + -> GenBranch h a () -> GenEvents h a (GenEventsLocalState h a) +withCombinedState_ ls = fmap snd . withCombinedState ls + +-- | Split the transaction generation state into the local and global components +splitTrState :: Iso' (GenInpState h a, Int) (GenTrState h a) +splitTrState = iso (uncurry GenTrState) (\(GenTrState x y) -> (x, y)) + +-- | State for generating system transactions +gesSystemTrState :: Lens' (GenEventsState h a) (GenTrState h a) +gesSystemTrState = (gelsSystemInpState `alongside` gegsNextHash) . splitTrState + +-- | State for generating wallet transactions +gesWalletTrState :: Lens' (GenEventsState h a) (GenTrState h a) +gesWalletTrState = (gelsWalletInpState `alongside` gegsNextHash) . splitTrState + +-- | Generate event tree +-- +-- NOTE: Rollbacks are implicit in the tree structure. +genEventTree :: forall h a. (Hash h a, Ord a) + => GenEventsParams h a + -> GenEvents h a (Tree (WalletEvent h a)) +genEventTree GenEventsParams{..} = + unfoldTreeM buildTree initLocalState + where + buildTree :: GenSeeds h a (WalletEvent h a) + buildTree ls = do + shouldSubmitPending <- lift $ toss gepPendingProb + if shouldSubmitPending + then submitPending ls + else generateBlock ls + + -- Try to submit a new pending transaction + -- + -- If this fails (if the wallet has no inputs available), we just repeat + -- the random choice in 'buildTree'. + submitPending :: GenSeeds h a (WalletEvent h a) + submitPending ls = do + pending <- use gegsPending + (mTr, ls') <- withCombinedState ls $ zoom gesWalletTrState $ + -- Pending transactions don't affect the UTxO, but should not use + -- inputs already used by other pending transactions + genTransaction + gepTrParams + DontRemoveUsedInputs + DontMakeOutputsAvailable + (Set.unions $ map trIns $ Map.elems pending) + case mTr of + Nothing -> buildTree ls' + Just tr -> do gegsPending %= Map.insert (givenHash tr) tr + return (NewPending tr, [ls']) + + -- Generate a block + generateBlock :: GenSeeds h a (WalletEvent h a) + generateBlock ls = do + -- Create the block itself + (ev, ls') <- withCombinedState ls $ do + blockSize <- lift $ choose (0, gepMaxBlockSize) + + -- First, we choose some pending transactions to commit + availablePending <- Map.toList <$> use (_2 . gegsPending) + (_pendingHashes, committedPending) <- + unzip <$> commitSome gepPendingCommitProb + (take blockSize availablePending) + let remaining = blockSize - length committedPending + + -- Next, we choose some transactions from the shared pool + availableShared <- Map.toList <$> use (_1 . gelsNextBlock) + (sharedHashes, committedShared) <- + unzip <$> commitSome gepSharedCommitProb + (take remaining availableShared) + (_1 . gelsNextBlock) %= (`withoutKeys` Set.fromList sharedHashes) + let remaining' = remaining - length committedShared + + -- Finally, we create some transactions specific to this block + -- + -- For these final transactions, we make the outputs of the + -- already selected transactions available, so that the block does + -- not only consist of independent transactions. This means we now + -- also need to pick an ordering. + alreadyCommitted <- lift $ shuffle $ committedPending ++ committedShared + let newUtxo = utxoUnions $ map trUtxo alreadyCommitted + (_1 . gelsSystemUtxo) %= utxoUnion newUtxo + committedRest <- zoom gesSystemTrState $ + replicateAtMostM remaining' $ + genTransaction + gepTrParams + RemoveUsedInputs + MakeOutputsAvailable + Set.empty + + -- Increase length of current branch + (_1 . gelsLength) += 1 + + -- Apply the block to the wallet's UTxO + let block = OldestFirst (alreadyCommitted ++ committedRest) + (_1 . gelsWalletUTxO) %= updateWalletUtxo block + + return $ ApplyBlock block + + -- Generate some transactions to be included in the next block + ls'' <- withCombinedState_ ls' $ do + stillAvailable <- Map.size <$> use (_1 . gelsNextBlock) + newAvailable <- zoom gesSystemTrState $ + replicateAtMostM (gepMaxBlockSize - stillAvailable) $ do + genTransaction + gepTrParams + RemoveUsedInputs + DontMakeOutputsAvailable + Set.empty + let newAvailable' = map (\tr -> (givenHash tr, tr)) newAvailable + _1 . gelsNextBlock %= Map.union (Map.fromList newAvailable') + + -- Finally, decide how to branch + -- + -- A branching factor of 0 means that we terminate this branch at this + -- point, a branching factor of 1 is just a linear continuation, and + -- a higher branching factor is a proper fork. + -- + -- We can terminate this branch at this point only if we have exceeded + -- the maximum height seen so far, guaranteeing that each next + -- path through the tree is longer than the previous. This is necessary, + -- because we only ever switch to a fork when the new fork is longer + -- than the current + let ourLength = ls'' ^. gelsLength + maxLength <- use gegsMaxLength + numForks <- use gegsNumForks + let allowedTerminate, allowedFork :: Bool + allowedTerminate = ourLength > maxLength + allowedFork = numForks < gepMaxNumForks + + -- Is a particular branching factor applicable? + applicable :: (Int, Int) -> Bool + applicable (_freq, 0) = allowedTerminate + applicable (_freq, 1) = True + applicable (_freq, _) = allowedFork + + -- Applicable branching frequencies + freqs :: [(Int, Int)] + freqs = filter applicable $ zip gepBranchingFrequencies [0 ..] + + branchingFactor <- lift $ frequency $ map (second pure) freqs + + gegsMaxLength %= max ourLength + gegsNumForks += if branchingFactor > 1 then 1 else 0 + + return (ev, replicate branchingFactor ls'') + + -- Commit some of the given transactions + commitSome :: Probability + -> [(GivenHash (Transaction h a), Transaction h a)] + -> GenBranch h a [(GivenHash (Transaction h a), Transaction h a)] + commitSome p trs = do + fmap catMaybes <$> forM trs $ \(h, tr) -> do + shouldCommit <- lift $ toss p + canCommit <- (`checkCanCommit` tr) <$> use (_1 . gelsSystemUtxo) + if not (shouldCommit && canCommit) + then return Nothing + else do (_1 . gelsSystemUtxo) %= utxoRemoveInputs (trIns tr) + return $ Just (h, tr) + + -- Check if all inputs are available in the given UTxO + checkCanCommit :: Utxo h a -> Transaction h a -> Bool + checkCanCommit u = all (`Set.member` utxoDomain u) . Set.toList . trIns + + -- Update the wallet's UTxO + updateWalletUtxo :: Block h a -> Utxo h a -> Utxo h a + updateWalletUtxo b = utxoRestrictToAddr ours . utxoApplyBlock b + + -- Addresses owned by the wallet + ours :: a -> Bool + ours = (`Set.member` gepOurs) + + -- Initial local state at the root of the tree + initLocalState :: GenEventsLocalState h a + initLocalState = GenEventsLocalState { + _gelsSystemInpState = initInpState initSystemUtxo + , _gelsWalletInpState = initInpState initWalletUtxo + , _gelsNextBlock = Map.empty + , _gelsLength = 0 + } + where + initSystemUtxo = gepInitUtxo + initWalletUtxo = utxoRestrictToAddr ours gepInitUtxo + +{------------------------------------------------------------------------------- + Generate wallet events +-------------------------------------------------------------------------------} + +genWalletEvents :: forall h a. (Hash h a, Ord a) + => GenEventsParams h a + -> GenEvents h a (OldestFirst [] (WalletEvent h a)) +genWalletEvents = fmap linearise . genEventTree + +-- | Linearise a tree of events to a list of events +linearise :: Tree (WalletEvent h a) -> OldestFirst [] (WalletEvent h a) +linearise = OldestFirst . stripRollbacks . go + where + -- Preorder traversal, matching each @ApplyBlock@ with a @Rollback@. + go :: Tree (WalletEvent h a) -> [WalletEvent h a] + go (Node (NewPending t) branches) = + -- We never split on 'NewPending' + let [branch] = branches in NewPending t : go branch + go (Node (ApplyBlock b) branches) = concat [ + [ApplyBlock b] + , concatMap go branches + , [Rollback] + ] + go (Node Rollback _branches) = + error "linearise: unexpected Rollback" + + -- each time we go back up the tree, we generate rollbacks; but we don't + -- want to do that for the very last branch. + stripRollbacks :: [WalletEvent h a] -> [WalletEvent h a] + stripRollbacks = reverse . dropWhile walletEventIsRollback . reverse + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +-- | Weighted coin toss +-- +-- @toss p@ throws a p-weighted coin and returns whether it came up heads. +-- @toss 0@ will always return @False@, @toss 1@ will always return @True@. +toss :: Probability -> Gen Bool +toss 0 = return False +toss 1 = return True +toss p = (< p) <$> choose (0, 1) diff --git a/wallet-new/test/unit/Wallet/Inductive/Interpreter.hs b/wallet-new/test/unit/Wallet/Inductive/Interpreter.hs new file mode 100644 index 00000000000..b3eaaa12acd --- /dev/null +++ b/wallet-new/test/unit/Wallet/Inductive/Interpreter.hs @@ -0,0 +1,163 @@ +module Wallet.Inductive.Interpreter ( + -- * History + History(..) + , HistoryD + , fromHistoryD + , historyD + , snocHistoryD + -- * Interpreter proper + , interpret + , InvalidInput(..) + ) where + +import Universum + +import qualified Data.Text.Buildable +import Formatting (bprint, build, (%)) +import Pos.Core.Chrono +import Serokell.Util (listJson) + +import Util.Validated +import UTxO.DSL +import Wallet.Abstract +import Wallet.Inductive + +{------------------------------------------------------------------------------- + History +-------------------------------------------------------------------------------} + +-- | History of interpretation +-- +-- This is very useful for debugging +data History h a = History { + -- | Wallet internal states + historyState :: [Text] + + -- | Continuation of the history (if any) + , historyStep :: Maybe (WalletEvent h a, History h a) + } + +-- | "Difference history" +type HistoryD h a = Maybe (WalletEvent h a, History h a) -> History h a + +fromHistoryD :: HistoryD h a -> History h a +fromHistoryD = ($ Nothing) + +historyD :: [Wallet h a] -> HistoryD h a +historyD = History . map dumpState + +-- | Append an action to a history +snocHistoryD :: HistoryD h a -- ^ Previous history + -> WalletEvent h a -- ^ Event to append + -> [Wallet h a] -- ^ Wallet states after the event + -> HistoryD h a +snocHistoryD k ev ws h = k $ Just (ev, historyD ws h) + +{------------------------------------------------------------------------------- + Interpreter +-------------------------------------------------------------------------------} + +-- | Interpreter for 'Inductive' +-- +-- Given (one or more) wallet constructors, evaluate an 'Inductive' wallet, +-- checking the given property at each step. +-- +-- Note: we expect the 'Inductive' to be valid (valid blockchain, valid +-- calls to 'newPending', etc.). This is meant to check properties of the +-- /wallet/, not the wallet input. See 'isInductiveValid'. +interpret :: forall h a err. + (History h a -> InvalidInput h a -> err) + -- ^ Inject invalid input err. + -- We provide the events that lead to the error. + -> (Transaction h a -> [Wallet h a]) + -- ^ Wallet constructors + -> (History h a -> [Wallet h a] -> Validated err ()) + -- ^ Predicate to check. The predicate is passed the events leading + -- to this point, for better error messages. + -> Inductive h a + -- ^ 'Inductive' value to interpret + -> Validated err [Wallet h a] +interpret invalidInput mkWallets p Inductive{..} = + goBoot inductiveBoot + where + goBoot :: Transaction h a -> Validated err [Wallet h a] + goBoot boot = do + let acc' = mkWallets boot + history' = historyD acc' + verify history' acc' + goEvents history' acc' (getOldestFirst inductiveEvents) + + goEvents :: HistoryD h a -- history + -> [Wallet h a] -- accumulator + -> [WalletEvent h a] -- events to process + -> Validated err [Wallet h a] + goEvents _ acc [] = + return acc + goEvents history acc (ApplyBlock b:es) = do + let acc' = map (`applyBlock` b) acc + history' = snocHistoryD history (ApplyBlock b) acc' + verify history' acc' + goEvents history' acc' es + goEvents history acc (NewPending t:es) = do + acc' <- mapM (newPending' history t) acc + let history' = snocHistoryD history (NewPending t) acc' + verify history' acc' + goEvents history' acc' es + goEvents history acc (Rollback:es) = do + let acc' = map rollback acc + history' = snocHistoryD history Rollback acc' + verify history' acc' + goEvents history' acc' es + + verify :: HistoryD h a + -> [Wallet h a] -> Validated err () + verify history ws = p (fromHistoryD history) ws + + newPending' :: HistoryD h a + -> Transaction h a + -> Wallet h a -> Validated err (Wallet h a) + newPending' history tx w = + case newPending w tx of + Just w' -> return w' + Nothing -> throwError . invalidInput (fromHistoryD history) + $ InvalidPending tx (utxo w) (pending w) + +-- | We were unable to check the invariant because the input was invalid +-- +-- This indicates a bug in the generator (or in the hand-written 'Inductive'), +-- so we try to provide sufficient information to track that down. +data InvalidInput h a = + InvalidPending { + -- | The submitted transaction that was invalid + invalidPendingTransaction :: Transaction h a + + -- | The UTxO of the wallet at the time of submission + , invalidPendingWalletUtxo :: Utxo h a + + -- | The pending set of the wallet at time of submission + , invalidPendingWalletPending :: Pending h a + } + +{------------------------------------------------------------------------------- + Pretty-printing +-------------------------------------------------------------------------------} + +instance (Hash h a, Buildable a) => Buildable (InvalidInput h a) where + build InvalidPending{..} = bprint + ( "InvalidPending " + % "{ transaction: " % build + % ", walletUtxo: " % build + % ", walletPending: " % build + % "}" + ) + invalidPendingTransaction + invalidPendingWalletUtxo + invalidPendingWalletPending + +instance (Hash h a, Buildable a) => Buildable (History h a) where + build = bprint ("{" % build) . go + where + go (History s n) = bprint ("state: " % listJson % build) s (go' n) + + go' Nothing = "}" + go' (Just (e, h)) = bprint (", action: " % build % ", " % build) e (go h) diff --git a/wallet-new/test/unit/Wallet/Inductive/Invariants.hs b/wallet-new/test/unit/Wallet/Inductive/Invariants.hs new file mode 100644 index 00000000000..bceee9aebe9 --- /dev/null +++ b/wallet-new/test/unit/Wallet/Inductive/Invariants.hs @@ -0,0 +1,404 @@ +{-# LANGUAGE ExistentialQuantification #-} + +module Wallet.Inductive.Invariants ( + -- * Invariants + Invariant + , invariant + -- * Failures + , InvariantViolation(..) + , InvariantViolationEvidence(..) + -- * Specific invariants + , WalletInv + , ApplicableInvariants(..) + , walletInvariants + -- * Equivalence + , walletEquivalent + ) where + +import Universum + +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text.Buildable +import Formatting (bprint, build, (%)) +import Serokell.Util (listJson) + +import Util +import Util.Validated +import UTxO.DSL +import Wallet.Abstract +import Wallet.Inductive +import Wallet.Inductive.Interpreter + +{------------------------------------------------------------------------------- + Invariants +-------------------------------------------------------------------------------} + +-- | Wallet invariant +-- +-- A wallet invariant is a property that is preserved by the fundamental +-- wallet operations, as defined by the 'IsWallet' type class and the +-- definition of 'Inductive'. +-- +-- In order to evaluate the inductive definition we need the empty wallet +-- to be passed as a starting point. +type Invariant h a = Inductive h a -> Validated (InvariantViolation h a) () + +-- | Lift a property of flat wallet values to an invariant over the wallet ops +invariant :: forall h a. + Text -- ^ Name of the invariant + -> (Transaction h a -> Wallet h a) -- ^ Construct empty wallet + -> (Wallet h a -> Maybe InvariantViolationEvidence) -- ^ Property + -> Invariant h a +invariant name e p = void . interpret notChecked ((:[]) . e) p' + where + notChecked :: History h a + -> InvalidInput h a + -> InvariantViolation h a + notChecked history reason = InvariantNotChecked { + invariantNotCheckedName = name + , invariantNotCheckedReason = reason + , invariantNotCheckedEvents = history + } + + violation :: History h a + -> InvariantViolationEvidence + -> InvariantViolation h a + violation history ev = InvariantViolation { + invariantViolationName = name + , invariantViolationEvidence = ev + , invariantViolationEvents = history + } + + p' :: History h a + -> [Wallet h a] + -> Validated (InvariantViolation h a) () + p' history [w] = case p w of + Nothing -> return () + Just ev -> throwError (violation history ev) + p' _ _ = error "impossible" + +-- | Invariant violation +data InvariantViolation h a = + -- | Invariance violation + InvariantViolation { + -- | Name of the invariant + invariantViolationName :: Text + + -- | Evidence that the invariant was violated + , invariantViolationEvidence :: InvariantViolationEvidence + + -- | The evens that led to the error + , invariantViolationEvents :: History h a + } + + -- | The invariant was not checked because the input was invalid + | InvariantNotChecked { + -- | Name of the invariant + invariantNotCheckedName :: Text + + -- | Why did we not check the invariant + , invariantNotCheckedReason :: InvalidInput h a + + -- | The events that led to the error + , invariantNotCheckedEvents :: History h a + } + +{------------------------------------------------------------------------------- + Evidence that an invariant was violated + + Rather than just whether or not that the invariant is maintained, we try + to produce an informative error message when the invariant is /not/ + maintained so that we can debug what's going on. +-------------------------------------------------------------------------------} + +-- | Evidence that the invariance was violated +data InvariantViolationEvidence = + forall a. Buildable a => + NotEqual (Text, a) (Text, a) + | forall a. (Buildable a, Ord a) => + NotSubsetOf (Text, Set a) (Text, Set a) + | forall a. (Buildable a) => + NotAllSatisfy (Text, a -> Bool) (Text, [a]) + | forall a. (Buildable a, Ord a) => + NotDisjoint (Text, Set a) (Text, Set a) + +checkEqual :: (Buildable a, Eq a) + => (Text, a) -> (Text, a) -> Maybe InvariantViolationEvidence +checkEqual = checkEqualUsing identity + +checkEqualUsing :: (Buildable a, Eq b) + => (a -> b) -> (Text, a) -> (Text, a) -> Maybe InvariantViolationEvidence +checkEqualUsing f (labelX, x) (labelY, y) = + if f x == f y + then Nothing + else Just $ NotEqual (labelX, x) (labelY, y) + +checkSubsetOf :: (Buildable a, Ord a) + => (Text, Set a) -> (Text, Set a) -> Maybe InvariantViolationEvidence +checkSubsetOf (labelXs, xs) (labelYs, ys) = + if xs `Set.isSubsetOf` ys + then Nothing + else Just $ NotSubsetOf (labelXs, xs) (labelYs, ys) + +checkAllSatisfy :: Buildable a + => (Text, a -> Bool) -> (Text, [a]) -> Maybe InvariantViolationEvidence +checkAllSatisfy (labelP, p) (labelXs, xs) = + if all p xs + then Nothing + else Just $ NotAllSatisfy (labelP, p) (labelXs, xs) + +checkDisjoint :: (Buildable a, Ord a) + => (Text, Set a) -> (Text, Set a) -> Maybe InvariantViolationEvidence +checkDisjoint (labelXs, xs) (labelYs, ys) = + if disjoint xs ys + then Nothing + else Just $ NotDisjoint (labelXs, xs) (labelYs, ys) + +{------------------------------------------------------------------------------- + Specific invariants +-------------------------------------------------------------------------------} + +-- | Wallet invariant, parameterized by a function to construct the wallet +type WalletInv h a = Text -> (Transaction h a -> Wallet h a) -> Invariant h a + +-- | Which invariants are applicable to this wallet? +data ApplicableInvariants = + -- | There are no rollbacks in the system + NoRollback + + -- | We have rollbacks, but we are working in the basic model + | BasicRollback + + -- | We are working in the full model (including support for expected UTxO) + | FullRollback + +walletInvariants :: (Hash h a, Buildable a, Eq a) => ApplicableInvariants -> WalletInv h a +walletInvariants applicableInvariants l e w = do + -- Invariants applicable in all models + sequence_ [ + utxoIsOurs l e w + , changeNotAvailable l e w + , changeNotInUtxo l e w + , changeAvailable l e w + , balanceChangeAvailable l e w + , pendingInputsDisjoint l e w + ] + + case applicableInvariants of + -- Invariants that only hold when there are no rollbacks + NoRollback -> sequence_ [ + pendingInUtxo l e w + ] + + BasicRollback -> sequence_ [ + ] + + FullRollback -> sequence_ [ + utxoExpectedDisjoint l e w + , expectedUtxoIsOurs l e w + , pendingInUtxoOrExpected l e w + ] + +pendingInUtxo :: Hash h a => WalletInv h a +pendingInUtxo l e = invariant (l <> "/pendingInUtxo") e $ \w -> + checkSubsetOf ("txIns (pending w)", + txIns (pending w)) + ("utxoDomain (utxo w)", + utxoDomain (utxo w)) + +utxoIsOurs :: Buildable a => WalletInv h a +utxoIsOurs l e = invariant (l <> "/utxoIsOurs") e $ \w -> + checkAllSatisfy ("isOurs", + ours w . outAddr) + ("utxoRange (utxo w)", + utxoRange (utxo w)) + +changeNotAvailable :: Hash h a => WalletInv h a +changeNotAvailable l e = invariant (l <> "/changeNotAvailable") e $ \w -> + checkDisjoint ("utxoDomain (change w)", + utxoDomain (change w)) + ("utxoDomain (available w)", + utxoDomain (available w)) + +changeNotInUtxo :: Hash h a => WalletInv h a +changeNotInUtxo l e = invariant (l <> "/changeNotInUtxo") e $ \w -> + checkDisjoint ("utxoDomain (change w)", + utxoDomain (change w)) + ("utxoDomain (utxo w)", + utxoDomain (utxo w)) + +changeAvailable :: (Hash h a, Buildable a, Eq a) => WalletInv h a +changeAvailable l e = invariant (l <> "/changeAvailable") e $ \w -> + checkEqual ("change w `utxoUnion` available w" , + change w `utxoUnion` available w) + ("total w", + total w) + +balanceChangeAvailable :: WalletInv h a +balanceChangeAvailable l e = invariant (l <> "/balanceChangeAvailable") e $ \w -> + checkEqual ("balance (change w) + balance (available w)", + balance (change w) + balance (available w)) + ("balance (total w)", + balance (total w)) + +pendingInputsDisjoint :: Hash h a => WalletInv h a +pendingInputsDisjoint l e = invariant (l <> "/pendingInputsDisjoint") e $ \w -> + asum [ checkDisjoint ("trIns " <> pretty h1, trIns tx1) + ("trIns " <> pretty h2, trIns tx2) + | (h1, tx1) <- Map.toList $ pending w + , (h2, tx2) <- Map.toList $ pending w + , h1 /= h2 + ] + +utxoExpectedDisjoint :: Hash h a => WalletInv h a +utxoExpectedDisjoint l e = invariant (l <> "/utxoExpectedDisjoint") e $ \w -> + checkDisjoint ("utxoDomain (utxo w)", + utxoDomain (utxo w)) + ("utxoDomain (expectedUtxo w)", + utxoDomain (expectedUtxo w)) + +expectedUtxoIsOurs :: Buildable a => WalletInv h a +expectedUtxoIsOurs l e = invariant (l <> "/expectedUtxoIsOurs") e $ \w -> + checkAllSatisfy ("isOurs", + ours w . outAddr) + ("utxoRange (expectedUtxo w)", + utxoRange (expectedUtxo w)) + +pendingInUtxoOrExpected :: Hash h a => WalletInv h a +pendingInUtxoOrExpected l e = invariant (l <> "/pendingInUtxoOrExpected") e $ \w -> + checkSubsetOf ("txIns (pending w)", + txIns (pending w)) + ("utxoDomain (utxo w) `Set.union` utxoDomain (expectedUtxo w)", + utxoDomain (utxo w) `Set.union` utxoDomain (expectedUtxo w)) + +{------------------------------------------------------------------------------- + Compare different wallet implementations +-------------------------------------------------------------------------------} + +walletEquivalent :: forall h a. (Hash h a, Eq a, Buildable a) + => Text + -> (Transaction h a -> Wallet h a) + -> (Transaction h a -> Wallet h a) + -> Invariant h a +walletEquivalent lbl e e' = void . + interpret notChecked (\boot -> [e boot, e' boot]) p + where + notChecked :: History h a + -> InvalidInput h a + -> InvariantViolation h a + notChecked history reason = InvariantNotChecked { + invariantNotCheckedName = lbl + , invariantNotCheckedReason = reason + , invariantNotCheckedEvents = history + } + + violation :: History h a + -> InvariantViolationEvidence + -> InvariantViolation h a + violation history ev = InvariantViolation { + invariantViolationName = lbl + , invariantViolationEvidence = ev + , invariantViolationEvents = history + } + + p :: History h a + -> [Wallet h a] + -> Validated (InvariantViolation h a) () + p history [w, w'] = sequence_ [ + cmp "pending" pending Map.keys + , cmp "utxo" utxo identity + , cmp "availableBalance" availableBalance identity + , cmp "totalBalance" totalBalance identity + , cmp "available" available identity + , cmp "change" change identity + , cmp "total" total identity + ] + where + cmp :: (Buildable b, Eq c) + => Text -- label + -> (Wallet h a -> b) -- field to compare + -> (b -> c) -- what part of the field to compare + -> Validated (InvariantViolation h a) () + cmp fld f g = + case checkEqualUsing g (fld <> " w", f w) (fld <> " w'", f w') of + Nothing -> return () + Just ev -> throwError $ violation history ev + p _ _ = error "impossible" + +{------------------------------------------------------------------------------- + Pretty-printing +-------------------------------------------------------------------------------} + +instance (Hash h a, Buildable a) => Buildable (InvariantViolation h a) where + build InvariantViolation{..} = bprint + ( "InvariantViolation " + % "{ name: " % build + % ", evidence: " % build + % ", events: " % build + % "}" + ) + invariantViolationName + invariantViolationEvidence + invariantViolationEvents + build (InvariantNotChecked{..}) = bprint + ( "InvariantNotChecked " + % "{ name: " % build + % ", reason: " % build + % ", events: " % build + % "}" + ) + invariantNotCheckedName + invariantNotCheckedReason + invariantNotCheckedEvents + +instance Buildable InvariantViolationEvidence where + build (NotEqual (labelX, x) (labelY, y)) = bprint + ( "NotEqual " + % "{ " % build % ": " % build + % ", " % build % ": " % build + % "}" + ) + labelX + x + labelY + y + build (NotSubsetOf (labelXs, xs) (labelYs, ys)) = bprint + ( "NotSubsetOf " + % "{ " % build % ": " % listJson + % ", " % build % ": " % listJson + % ", " % build % ": " % listJson + % "}" + ) + labelXs + (Set.toList xs) + labelYs + (Set.toList ys) + (labelXs <> " \\\\ " <> labelYs) + (Set.toList $ xs Set.\\ ys) + build (NotAllSatisfy (labelP, p) (labelXs, xs)) = bprint + ( "NotAllSatisfy " + % "{ " % build % ": " % build + % ", " % build % ": " % listJson + % ", " % build % ": " % listJson + % "}" + ) + ("pred" :: Text) + labelP + labelXs + xs + ("filter (not . " <> labelP <> ")") + (filter (not . p) xs) + build (NotDisjoint (labelXs, xs) (labelYs, ys)) = bprint + ( "NotSubsetOf " + % "{ " % build % ": " % listJson + % ", " % build % ": " % listJson + % ", " % build % ": " % listJson + % "}" + ) + labelXs + (Set.toList xs) + labelYs + (Set.toList ys) + (labelXs <> " `intersection` " <> labelYs) + (Set.toList $ xs `Set.intersection` ys) diff --git a/wallet-new/test/unit/Wallet/Inductive/Validation.hs b/wallet-new/test/unit/Wallet/Inductive/Validation.hs new file mode 100644 index 00000000000..308023570ab --- /dev/null +++ b/wallet-new/test/unit/Wallet/Inductive/Validation.hs @@ -0,0 +1,244 @@ +module Wallet.Inductive.Validation ( + ValidatedInductive(..) + , InductiveValidationError(..) + , inductiveIsValid + ) where + +import Universum + +import qualified Data.List as List +import qualified Data.Set as Set +import qualified Data.Text.Buildable +import Formatting (bprint, build, (%)) +import Pos.Core.Chrono + +import Util +import Util.Validated +import UTxO.DSL +import Wallet.Inductive + +{------------------------------------------------------------------------------- + Successful validation result +-------------------------------------------------------------------------------} + +-- | Result of validating an inductive wallet +data ValidatedInductive h a = ValidatedInductive { + -- | Bootstrap transaction used + viBoot :: Transaction h a + + -- | Final ledger (including bootstrap) + , viLedger :: Ledger h a + + -- | Validated events + , viEvents :: NewestFirst [] (WalletEvent h a) + + -- | Final chain (split into blocks, not including bootstrap) + , viChain :: NewestFirst [] (Block h a) + + -- | UTxO after each block + , viUtxos :: NewestFirst NonEmpty (Utxo h a) + } + +{------------------------------------------------------------------------------- + Validation errors +-------------------------------------------------------------------------------} + +data InductiveValidationError h a = + -- | Bootstrap transaction is invalid + InductiveInvalidBoot { + -- | The bootstrap transaction + inductiveInvalidBoot :: Transaction h a + + -- | The error message + , inductiveInvalidError :: Text + } + + -- | Invalid transaction in the given block + | InductiveInvalidApplyBlock { + -- | The events leading up to the error + inductiveInvalidEvents :: OldestFirst [] (WalletEvent h a) + + -- | The transactions in the block we successfully validated + , inductiveInvalidBlockPrefix :: OldestFirst [] (Transaction h a) + + -- | The transaction that was invalid + , inductiveInvalidTransaction :: Transaction h a + + -- | The error message + , inductiveInvalidError :: Text + } + + -- | A 'NewPending' call was invalid because the input was already spent + | InductiveInvalidNewPendingAlreadySpent { + -- | The events leading up to the error + inductiveInvalidEvents :: OldestFirst [] (WalletEvent h a) + + -- | The transaction that was invalid + , inductiveInvalidTransaction :: Transaction h a + + -- | The specific input that was not valid + , inductiveInvalidInput :: Input h a + } + + -- | A 'NewPending' call was invalid because the input was not @ours@ + | InductiveInvalidNewPendingNotOurs { + -- | The events leading up to the error + inductiveInvalidEvents :: OldestFirst [] (WalletEvent h a) + + -- | The transaction that was invalid + , inductiveInvalidTransaction :: Transaction h a + + -- | The specific input that was not valid + , inductiveInvalidInput :: Input h a + + -- | The address this input belonged to + , inductiveInvalidAddress :: a + } + +{------------------------------------------------------------------------------- + Validation proper +-------------------------------------------------------------------------------} + +-- | Lift ledger validity to 'Inductive' +inductiveIsValid :: forall h a. (Hash h a, Buildable a, Ord a) + => Inductive h a + -> Validated (InductiveValidationError h a) (ValidatedInductive h a) +inductiveIsValid Inductive{..} = do + goBoot inductiveBoot + where + goBoot :: Transaction h a + -> Validated (InductiveValidationError h a) (ValidatedInductive h a) + goBoot boot = do + let ledger = ledgerEmpty + validatedMapErrors (InductiveInvalidBoot boot) $ + trIsAcceptable boot ledger + goEvents (getOldestFirst inductiveEvents) ValidatedInductive { + viBoot = boot + , viLedger = ledgerAdd boot ledger + , viEvents = NewestFirst [] + , viChain = NewestFirst [] + , viUtxos = NewestFirst (trUtxo boot :| []) + } + + goEvents :: [WalletEvent h a] + -> ValidatedInductive h a -- accumulator + -> Validated (InductiveValidationError h a) (ValidatedInductive h a) + goEvents [] acc = + return acc + goEvents (ApplyBlock b:es) ValidatedInductive{..} = do + ledger' <- goBlock (toOldestFirst viEvents) (OldestFirst []) viLedger b + goEvents es ValidatedInductive { + viBoot = viBoot + , viLedger = ledger' + , viEvents = liftNewestFirst (ApplyBlock b :) viEvents + , viChain = liftNewestFirst ( b :) viChain + , viUtxos = newCheckpoint b viUtxos + } + goEvents (Rollback:es) ValidatedInductive{..} = do + let chain' = liftNewestFirst List.tail viChain + goEvents es ValidatedInductive { + viBoot = viBoot + , viLedger = revChainToLedger chain' + , viEvents = liftNewestFirst (Rollback :) viEvents + , viChain = chain' + , viUtxos = prevCheckpoint viUtxos + } + goEvents (NewPending t:es) vi@ValidatedInductive{..} = do + let utxo = let NewestFirst (u :| _) = viUtxos in u + inputs = Set.toList (trIns t) + resolved = map (`utxoAddressForInput` utxo) inputs + forM_ (zip inputs resolved) $ \(input, mAddr) -> + case mAddr of + Nothing -> + throwError InductiveInvalidNewPendingAlreadySpent { + inductiveInvalidEvents = toOldestFirst viEvents + , inductiveInvalidTransaction = t + , inductiveInvalidInput = input + } + Just addr -> + unless (addr `Set.member` inductiveOurs) $ + throwError InductiveInvalidNewPendingNotOurs { + inductiveInvalidEvents = toOldestFirst viEvents + , inductiveInvalidTransaction = t + , inductiveInvalidInput = input + , inductiveInvalidAddress = addr + } + goEvents es vi + + goBlock :: OldestFirst [] (WalletEvent h a) -- Events leading to this point (for err msgs) + -> Block h a -- Prefix of the block already validated (for err msgs) + -> Ledger h a -- Ledger so far + -> Block h a -- Suffix of the block yet to validate + -> Validated (InductiveValidationError h a) (Ledger h a) + goBlock events = go + where + go _ ledger (OldestFirst []) = + return ledger + go (OldestFirst done) ledger (OldestFirst (t:todo)) = do + validatedMapErrors (InductiveInvalidApplyBlock events (OldestFirst done) t) $ + trIsAcceptable t ledger + go (OldestFirst (done ++ [t])) (ledgerAdd t ledger) (OldestFirst todo) + + revChainToLedger :: NewestFirst [] (Block h a) -> Ledger h a + revChainToLedger = Ledger + . NewestFirst + . (inductiveBoot :) + . concatMap toList . toList + + newCheckpoint :: Block h a + -> NewestFirst NonEmpty (Utxo h a) + -> NewestFirst NonEmpty (Utxo h a) + newCheckpoint b = liftNewestFirst $ \(u :| us) -> + utxoApplyBlock b u :| (u:us) + + prevCheckpoint :: NewestFirst NonEmpty (Utxo h a) + -> NewestFirst NonEmpty (Utxo h a) + prevCheckpoint = liftNewestFirst $ \(_u :| (u':us)) + -> u' :| us + +{------------------------------------------------------------------------------- + Pretty-printing +-------------------------------------------------------------------------------} + +instance (Hash h a, Buildable a) => Buildable (InductiveValidationError h a) where + build InductiveInvalidBoot{..} = bprint + ( "InductiveInvalidBoot" + % "{ boot: " % build + % ", error: " % build + % "}" + ) + inductiveInvalidBoot + inductiveInvalidError + build InductiveInvalidApplyBlock{..} = bprint + ( "InductiveInvalidApplyBlock" + % "{ events: " % build + % ", blockPrefix: " % build + % ", transaction: " % build + % ", error: " % build + % "}") + inductiveInvalidEvents + inductiveInvalidBlockPrefix + inductiveInvalidTransaction + inductiveInvalidError + build InductiveInvalidNewPendingAlreadySpent{..} = bprint + ( "InductiveInvalidNewPendingAlreadySpent" + % "{ events: " % build + % ", transaction: " % build + % ", input: " % build + % "}" + ) + inductiveInvalidEvents + inductiveInvalidTransaction + inductiveInvalidInput + build InductiveInvalidNewPendingNotOurs{..} = bprint + ( "InductiveInvalidNewPendingNotOurs" + % "{ events: " % build + % ", transaction: " % build + % ", input: " % build + % ", address: " % build + % "}" + ) + inductiveInvalidEvents + inductiveInvalidTransaction + inductiveInvalidInput + inductiveInvalidAddress diff --git a/wallet-new/test/unit/Wallet/Prefiltered.hs b/wallet-new/test/unit/Wallet/Prefiltered.hs index e81869ac8a8..570667f2373 100644 --- a/wallet-new/test/unit/Wallet/Prefiltered.hs +++ b/wallet-new/test/unit/Wallet/Prefiltered.hs @@ -25,7 +25,7 @@ import qualified Wallet.Incremental as Incr Construction -------------------------------------------------------------------------------} -mkWallet :: (Hash h a, Ord a) +mkWallet :: (Hash h a, Buildable st) => Ours a -> Lens' st (Incr.State h a) -> WalletConstr h a st mkWallet ours l self st = (Incr.mkWallet ours l self st) { applyBlock = \b -> @@ -37,5 +37,5 @@ mkWallet ours l self st = (Incr.mkWallet ours l self st) { where this = self st -walletEmpty :: (Hash h a, Ord a) => Ours a -> Wallet h a +walletEmpty :: (Hash h a, Buildable a) => Ours a -> Wallet h a walletEmpty ours = fix (mkWallet ours identity) Incr.initState diff --git a/wallet-new/test/unit/Wallet/Rollback/Basic.hs b/wallet-new/test/unit/Wallet/Rollback/Basic.hs index 45467f49946..f9ee59de135 100644 --- a/wallet-new/test/unit/Wallet/Rollback/Basic.hs +++ b/wallet-new/test/unit/Wallet/Rollback/Basic.hs @@ -15,7 +15,10 @@ module Wallet.Rollback.Basic ( import Universum hiding (State) import Control.Lens.TH -import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.Text.Buildable +import Formatting (bprint, build, (%)) +import Serokell.Util (listJson) import UTxO.DSL import Wallet.Abstract @@ -42,7 +45,7 @@ initState = State { Implementation -------------------------------------------------------------------------------} -mkWallet :: (Hash h a, Ord a) +mkWallet :: (Hash h a, Buildable st) => Ours a -> Lens' st (State h a) -> WalletConstr h a st mkWallet ours l self st = (Basic.mkWallet ours (l . stateCurrent) self st) { applyBlock = \b -> self (st & l %~ applyBlock' ours b) @@ -54,7 +57,7 @@ mkWallet ours l self st = (Basic.mkWallet ours (l . stateCurrent) self st) { where this = self st -walletEmpty :: (Hash h a, Ord a) => Ours a -> Wallet h a +walletEmpty :: (Hash h a, Buildable a) => Ours a -> Wallet h a walletEmpty ours = fix (mkWallet ours identity) initState {------------------------------------------------------------------------------- @@ -68,15 +71,29 @@ applyBlock' ours b State{..} = State{ , _stateCheckpoints = _stateCurrent : _stateCheckpoints } -rollback' :: (Hash h a, Ord a) => State h a -> State h a +rollback' :: (Hash h a) => State h a -> State h a rollback' State{ _stateCheckpoints = [] } = error "rollback': no checkpoints" rollback' State{ _stateCheckpoints = prev : checkpoints' , _stateCurrent = curr } = State{ _stateCurrent = Basic.State{ _stateUtxo = prev ^. Basic.stateUtxo - , _statePending = (curr ^. Basic.statePending) `Set.union` + , _statePending = (curr ^. Basic.statePending) `Map.union` (prev ^. Basic.statePending) } , _stateCheckpoints = checkpoints' } + +{------------------------------------------------------------------------------- + Pretty-printing +-------------------------------------------------------------------------------} + +instance (Hash h a, Buildable a) => Buildable (State h a) where + build State{..} = bprint + ( "State" + % "{ current: " % build + % ", checkpoints: " % listJson + % "}" + ) + _stateCurrent + _stateCheckpoints diff --git a/wallet-new/test/unit/Wallet/Rollback/Full.hs b/wallet-new/test/unit/Wallet/Rollback/Full.hs index 04fde1141c5..f12c50746f6 100644 --- a/wallet-new/test/unit/Wallet/Rollback/Full.hs +++ b/wallet-new/test/unit/Wallet/Rollback/Full.hs @@ -22,11 +22,15 @@ module Wallet.Rollback.Full ( import Universum hiding (State) import Control.Lens.TH +import qualified Data.Map as Map import qualified Data.Set as Set +import qualified Data.Text.Buildable +import Formatting (bprint, build, (%)) +import Serokell.Util (listJson) import UTxO.DSL import Wallet.Abstract -import qualified Wallet.Basic as Basic +import qualified Wallet.Basic as Basic import qualified Wallet.Incremental as Incr {------------------------------------------------------------------------------- @@ -71,7 +75,7 @@ initState = State { Construction -------------------------------------------------------------------------------} -mkWallet :: (Hash h a, Ord a) +mkWallet :: (Hash h a, Buildable st) => Ours a -> Lens' st (State h a) -> WalletConstr h a st mkWallet ours l self st = (Incr.mkWallet ours (l . stateIncr) self st) { applyBlock = \b -> @@ -83,11 +87,15 @@ mkWallet ours l self st = (Incr.mkWallet ours (l . stateIncr) self st) { filtered = txIns b `Set.intersection` utxoDomain filterUtxo in self (st & l %~ applyBlock' (filtered, utxoPlus)) , rollback = self (st & l %~ rollback') + , change = utxoRemoveInputs (txIns (pending this)) + $ utxoRestrictToOurs ours + $ txOuts (pending this) + , expectedUtxo = st ^. l . stateCurrent . checkpointExpected } where this = self st -walletEmpty :: (Hash h a, Ord a) => Ours a -> Wallet h a +walletEmpty :: (Hash h a, Buildable a) => Ours a -> Wallet h a walletEmpty ours = fix (mkWallet ours identity) initState {------------------------------------------------------------------------------- @@ -99,8 +107,8 @@ applyBlock' :: Hash h a -> State h a -> State h a applyBlock' (ins, outs) State{..} = State{ _stateCurrent = Checkpoint { - _checkpointIncr = Incr.applyBlock' (ins, outs) _checkpointIncr - , _checkpointExpected = utxoRemoveInputs ins _checkpointExpected + _checkpointIncr = Incr.applyBlock' (ins, outs) _checkpointIncr + , _checkpointExpected = utxoRemoveInputs (utxoDomain outs) _checkpointExpected } , _stateCheckpoints = _stateCurrent : _stateCheckpoints } @@ -108,7 +116,7 @@ applyBlock' (ins, outs) State{..} = State{ Checkpoint{..} = _stateCurrent Incr.State{..} = _checkpointIncr -rollback' :: (Hash h a, Ord a) => State h a -> State h a +rollback' :: Hash h a => State h a -> State h a rollback' State{ _stateCheckpoints = [] } = error "rollback': no checkpoints" rollback' State{ _stateCheckpoints = prev : checkpoints' , _stateCurrent = curr @@ -117,7 +125,7 @@ rollback' State{ _stateCheckpoints = prev : checkpoints' _checkpointIncr = Incr.State { _stateBasic = Basic.State { _stateUtxo = prev ^. checkpointUtxo - , _statePending = (curr ^. checkpointPending) `Set.union` + , _statePending = (curr ^. checkpointPending) `Map.union` (prev ^. checkpointPending) } , _stateUtxoBalance = prev ^. checkpointUtxoBalance @@ -131,3 +139,27 @@ rollback' State{ _stateCheckpoints = prev : checkpoints' } , _stateCheckpoints = checkpoints' } + +{------------------------------------------------------------------------------- + Pretty-printing +-------------------------------------------------------------------------------} + +instance (Hash h a, Buildable a) => Buildable (Checkpoint h a) where + build Checkpoint{..} = bprint + ( "Checkpoint" + % "{ incr: " % build + % ", expected: " % build + % "}" + ) + _checkpointIncr + _checkpointExpected + +instance (Hash h a, Buildable a) => Buildable (State h a) where + build State{..} = bprint + ( "State" + % "{ current: " % build + % ", checkpoints: " % listJson + % "}" + ) + _stateCurrent + _stateCheckpoints diff --git a/wallet-new/test/unit/WalletUnitTest.hs b/wallet-new/test/unit/WalletUnitTest.hs index 10bd3bbae0e..edb134b8a23 100644 --- a/wallet-new/test/unit/WalletUnitTest.hs +++ b/wallet-new/test/unit/WalletUnitTest.hs @@ -1,41 +1,22 @@ -{-# LANGUAGE TupleSections #-} - -- | Wallet unit tests --- --- TODO: Take advantage of https://github.com/input-output-hk/cardano-sl/pull/2296 ? module Main (main) where -import qualified Data.Set as Set -import qualified Data.Text.Buildable -import Formatting (bprint, build, sformat, shown, (%)) -import Serokell.Util (mapJson) -import Test.Hspec.QuickCheck import Universum -import qualified Pos.Block.Error as Cardano -import qualified Pos.Txp.Toil as Cardano -import Pos.Util.Chrono - -import qualified Cardano.Wallet.Kernel as Kernel -import qualified Cardano.Wallet.Kernel.Diffusion as Kernel +import Formatting (build, sformat) +import Test.Hspec (Spec, describe, hspec) -import UTxO.BlockGen -import UTxO.Bootstrap -import UTxO.Context -import UTxO.DSL -import UTxO.Interpreter -import UTxO.PreChain -import UTxO.Translate +import UTxO.Bootstrap (bootstrapTransaction) +import UTxO.Context (Addr, TransCtxt) +import UTxO.DSL (GivenHash, Transaction) +import UTxO.Translate (runTranslateNoErrors, withConfig) -import Util.Buildable.Hspec -import Util.Buildable.QuickCheck -import Util.Validated -import Wallet.Abstract -import qualified Wallet.Basic as Base -import qualified Wallet.Incremental as Incr -import qualified Wallet.Prefiltered as Pref -import qualified Wallet.Rollback.Basic as Roll -import qualified Wallet.Rollback.Full as Full +import qualified Test.Spec.Kernel +import qualified Test.Spec.Models +import qualified Test.Spec.Submission +import qualified Test.Spec.Translation +import qualified Test.Spec.WalletWorker +import TxMetaStorageSpecs (txMetaStorageSpecs) {------------------------------------------------------------------------------- Main test driver @@ -44,7 +25,7 @@ import qualified Wallet.Rollback.Full as Full main :: IO () main = do -- _showContext - hspec tests + runTranslateNoErrors $ withConfig $ return $ hspec tests -- | Debugging: show the translation context _showContext :: IO () @@ -62,439 +43,9 @@ _showContext = do tests :: Spec tests = describe "Wallet unit tests" $ do - testTranslation - testPureWallet - testPassiveWallet - testActiveWallet - -{------------------------------------------------------------------------------- - UTxO->Cardano translation tests --------------------------------------------------------------------------------} - -testTranslation :: Spec -testTranslation = do - describe "Translation sanity checks" $ do - it "can construct and verify empty block" $ - intAndVerifyPure emptyBlock `shouldSatisfy` expectValid - - it "can construct and verify block with one transaction" $ - intAndVerifyPure oneTrans `shouldSatisfy` expectValid - - it "can construct and verify example 1 from the UTxO paper" $ - intAndVerifyPure example1 `shouldSatisfy` expectValid - - it "can reject overspending" $ - intAndVerifyPure overspend `shouldSatisfy` expectInvalid - - it "can reject double spending" $ - intAndVerifyPure doublespend `shouldSatisfy` expectInvalid - - describe "Translation QuickCheck tests" $ do - prop "can translate randomly generated chains" $ - forAll - (intAndVerifyGen genValidBlockchain) - expectValid - -{------------------------------------------------------------------------------- - Pure wallet tests --------------------------------------------------------------------------------} - -testPureWallet :: Spec -testPureWallet = do - it "Test pure wallets" $ - forAll genInductive $ \ind -> conjoin [ - checkInvariants "base" ind baseEmpty - , checkInvariants "incr" ind incrEmpty - , checkInvariants "pref" ind prefEmpty - , checkInvariants "roll" ind rollEmpty - , checkInvariants "full" ind fullEmpty - , checkEquivalent "base/incr" ind baseEmpty incrEmpty - , checkEquivalent "base/pref" ind baseEmpty prefEmpty - , checkEquivalent "base/roll" ind baseEmpty rollEmpty - , checkEquivalent "base/full" ind baseEmpty fullEmpty - ] - - it "Sanity check rollback" $ do - let FromPreChain{..} = runTranslate $ fromPreChain oneTrans - - ours :: Ours Addr - ours = oursFromSet $ Set.singleton r1 - - w0, w1 :: Wallet GivenHash Addr - w0 = walletBoot Full.walletEmpty ours fpcBoot - w1 = applyBlocks w0 (chainBlocks fpcChain) - w2 = rollback w1 - - shouldNotBe (utxo w0) (utxo w1) - shouldBe (utxo w0) (utxo w2) - where - transCtxt = runTranslateNoErrors ask - - genInductive :: Hash h Addr => Gen (InductiveWithOurs h Addr) - genInductive = do - fpc <- runTranslateT $ fromPreChain genValidBlockchain - n <- choose - ( 1 - , length . filter (not . isAvvmAddr) . toList - . ledgerAddresses $ fpcLedger fpc - ) - genFromBlockchainPickingAccounts n fpc - - checkInvariants :: (Hash h a, Eq a, Buildable a) - => Text - -> InductiveWithOurs h a - -> (Set a -> Transaction h a -> Wallet h a) - -> Expectation - checkInvariants label (InductiveWithOurs addrs ind) w = - shouldBeValidated $ - walletInvariants label (w addrs) ind - - checkEquivalent :: (Hash h a, Eq a, Buildable a) - => Text - -> InductiveWithOurs h a - -> (Set a -> Transaction h a -> Wallet h a) - -> (Set a -> Transaction h a -> Wallet h a) - -> Expectation - checkEquivalent label (InductiveWithOurs addrs ind) w w' = - shouldBeValidated $ - walletEquivalent label (w addrs) (w' addrs) ind - - oursFromSet :: Set Addr -> Ours Addr - oursFromSet addrs addr = do - guard (Set.member addr addrs) - return $ fst (resolveAddr addr transCtxt) - - baseEmpty :: Set Addr -> Transaction GivenHash Addr -> Wallet GivenHash Addr - incrEmpty :: Set Addr -> Transaction GivenHash Addr -> Wallet GivenHash Addr - prefEmpty :: Set Addr -> Transaction GivenHash Addr -> Wallet GivenHash Addr - rollEmpty :: Set Addr -> Transaction GivenHash Addr -> Wallet GivenHash Addr - fullEmpty :: Set Addr -> Transaction GivenHash Addr -> Wallet GivenHash Addr - - baseEmpty = walletBoot Base.walletEmpty . oursFromSet - incrEmpty = walletBoot Incr.walletEmpty . oursFromSet - prefEmpty = walletBoot Pref.walletEmpty . oursFromSet - rollEmpty = walletBoot Roll.walletEmpty . oursFromSet - fullEmpty = walletBoot Full.walletEmpty . oursFromSet - -{------------------------------------------------------------------------------- - Passive wallet tests --------------------------------------------------------------------------------} - -testPassiveWallet :: Spec -testPassiveWallet = around bracketPassiveWallet $ - describe "Passive wallet sanity checks" $ do - it "can be initialized" $ \w -> - Kernel.init w - --- | Initialize passive wallet in a manner suitable for the unit tests -bracketPassiveWallet :: (Kernel.PassiveWallet -> IO a) -> IO a -bracketPassiveWallet = Kernel.bracketPassiveWallet logMessage - where - -- TODO: Decide what to do with logging - logMessage _sev _txt = return () - -{------------------------------------------------------------------------------- - Active wallet tests --------------------------------------------------------------------------------} - -testActiveWallet :: Spec -testActiveWallet = around bracketWallet $ - describe "Active wallet sanity checks" $ do - it "initially has no pending transactions" $ \w -> - Kernel.hasPending w `shouldReturn` False - --- | Initialize active wallet in a manner suitable for unit testing -bracketWallet :: (Kernel.ActiveWallet -> IO a) -> IO a -bracketWallet test = - bracketPassiveWallet $ \passive -> - Kernel.bracketActiveWallet passive diffusion $ \active -> - test active - where - -- TODO: Decide what we want to do with submitted transactions - diffusion :: Kernel.WalletDiffusion - diffusion = Kernel.WalletDiffusion { - walletSendTx = \_tx -> return False - } - -{------------------------------------------------------------------------------- - Example hand-constructed chains --------------------------------------------------------------------------------} - -emptyBlock :: Hash h Addr => PreChain h Identity () -emptyBlock = preChain $ \_boot -> return $ \_fees -> - OldestFirst [OldestFirst []] - -oneTrans :: Hash h Addr => PreChain h Identity () -oneTrans = preChain $ \boot -> return $ \((fee : _) : _) -> - let t1 = Transaction { - trFresh = 0 - , trFee = fee - , trHash = 1 - , trIns = Set.fromList [ Input (hash boot) 0 ] -- rich 0 - , trOuts = [ Output r1 1000 - , Output r0 (initR0 - 1000 - fee) - ] - , trExtra = ["t1"] - } - in OldestFirst [OldestFirst [t1]] - --- Try to transfer from R0 to R1, but leaving R0's balance the same -overspend :: Hash h Addr => PreChain h Identity () -overspend = preChain $ \boot -> return $ \((fee : _) : _) -> - let t1 = Transaction { - trFresh = 0 - , trFee = fee - , trHash = 1 - , trIns = Set.fromList [ Input (hash boot) 0 ] -- rich 0 - , trOuts = [ Output r1 1000 - , Output r0 initR0 - ] - , trExtra = ["t1"] - } - in OldestFirst [OldestFirst [t1]] - --- Try to transfer to R1 and R2 using the same output --- TODO: in principle this example /ought/ to work without any kind of --- outputs at all; but in practice this breaks stuff because now we have --- two identical transactions which would therefore get identical IDs? -doublespend :: Hash h Addr => PreChain h Identity () -doublespend = preChain $ \boot -> return $ \((fee1 : fee2 : _) : _) -> - let t1 = Transaction { - trFresh = 0 - , trFee = fee1 - , trHash = 1 - , trIns = Set.fromList [ Input (hash boot) 0 ] -- rich 0 - , trOuts = [ Output r1 1000 - , Output r0 (initR0 - 1000 - fee1) - ] - , trExtra = ["t1"] - } - t2 = Transaction { - trFresh = 0 - , trFee = fee2 - , trHash = 2 - , trIns = Set.fromList [ Input (hash boot) 0 ] -- rich 0 - , trOuts = [ Output r2 1000 - , Output r0 (initR0 - 1000 - fee2) - ] - , trExtra = ["t2"] - } - in OldestFirst [OldestFirst [t1, t2]] - --- Translation of example 1 of the paper, adjusted to allow for fees --- --- Transaction t1 in the example creates new coins, and transaction t2 --- tranfers this to an ordinary address. In other words, t1 and t2 --- corresponds to the bootstrap transactions. --- --- Transaction t3 then transfers part of R0's balance to R1, returning the --- rest to back to R0; and t4 transfers the remainder of R0's balance to --- R2. --- --- Transaction 5 in example 1 is a transaction /from/ the treasury /to/ an --- ordinary address. This currently has no equivalent in Cardano, so we omit --- it. -example1 :: Hash h Addr => PreChain h Identity () -example1 = preChain $ \boot -> return $ \((fee3 : fee4 : _) : _) -> - let t3 = Transaction { - trFresh = 0 - , trFee = fee3 - , trHash = 3 - , trIns = Set.fromList [ Input (hash boot) 0 ] -- rich 0 - , trOuts = [ Output r1 1000 - , Output r0 (initR0 - 1000 - fee3) - ] - , trExtra = ["t3"] - } - t4 = Transaction { - trFresh = 0 - , trFee = fee4 - , trHash = 4 - , trIns = Set.fromList [ Input (hash t3) 1 ] - , trOuts = [ Output r2 (initR0 - 1000 - fee3 - fee4) ] - , trExtra = ["t4"] - } - in OldestFirst [OldestFirst [t3, t4]] - -{------------------------------------------------------------------------------- - Some initial values - - TODO: These come from the genesis block. We shouldn't hardcode them - in the tests but rather derive them from the bootstrap transaction. --------------------------------------------------------------------------------} - -initR0 :: Value -initR0 = 11137499999752500 - -r0, r1, r2 :: Addr -r0 = Addr (IxRich 0) 0 -r1 = Addr (IxRich 1) 0 -r2 = Addr (IxRich 2) 0 - -{------------------------------------------------------------------------------- - Verify chain --------------------------------------------------------------------------------} - -intAndVerifyPure :: PreChain GivenHash Identity a - -> ValidationResult GivenHash Addr -intAndVerifyPure = runIdentity . intAndVerify - -intAndVerifyGen :: PreChain GivenHash Gen a - -> Gen (ValidationResult GivenHash Addr) -intAndVerifyGen = intAndVerify - --- | Interpret and verify a chain, given the bootstrap transactions -intAndVerify :: (Hash h Addr, Monad m) - => PreChain h m a -> m (ValidationResult h Addr) -intAndVerify = intAndVerifyChain - --- | Interpret and verify a chain, given the bootstrap transactions. Also --- returns the 'FromPreChain' value, which contains the blockchain, ledger, --- boot transaction, etc. -intAndVerifyChain :: (Hash h Addr, Monad m) - => PreChain h m a - -> m (ValidationResult h Addr) -intAndVerifyChain pc = runTranslateT $ do - FromPreChain{..} <- fromPreChain pc - let dslIsValid = ledgerIsValid fpcLedger - dslUtxo = ledgerUtxo fpcLedger - intResult <- catchTranslateErrors $ runIntBoot fpcBoot fpcChain - case intResult of - Left e -> - case dslIsValid of - Valid () -> return $ Disagreement fpcLedger (UnexpectedError e) - Invalid _ e' -> return $ ExpectedInvalid' e' e - Right (chain', ctxt) -> do - let chain'' = fromMaybe (error "intAndVerify: Nothing") - $ nonEmptyOldestFirst chain' - isCardanoValid <- verifyBlocksPrefix chain'' - case (dslIsValid, isCardanoValid) of - (Invalid _ e' , Invalid _ e) -> return $ ExpectedInvalid e' e - (Invalid _ e' , Valid _) -> return $ Disagreement fpcLedger (UnexpectedValid e') - (Valid () , Invalid _ e) -> return $ Disagreement fpcLedger (UnexpectedInvalid e) - (Valid () , Valid (_undo, finalUtxo)) -> do - (finalUtxo', _) <- runIntT ctxt dslUtxo - if finalUtxo == finalUtxo' - then return $ ExpectedValid - else return $ Disagreement fpcLedger UnexpectedUtxo { - utxoDsl = dslUtxo - , utxoCardano = finalUtxo - , utxoInt = finalUtxo' - } - -{------------------------------------------------------------------------------- - Chain verification test result --------------------------------------------------------------------------------} - -data ValidationResult h a = - -- | We expected the chain to be valid; DSL and Cardano both agree - ExpectedValid - - -- | We expected the chain to be invalid; DSL and Cardano both agree - | ExpectedInvalid { - validationErrorDsl :: Text - , validationErrorCardano :: Cardano.VerifyBlocksException - } - - -- | Variation on 'ExpectedInvalid', where we cannot even /construct/ - -- the Cardano chain, much less validate it. - | ExpectedInvalid' { - validationErrorDsl :: Text - , validationErrorInt :: IntException - } - - -- | Disagreement between the DSL and Cardano - -- - -- This indicates a bug. Of course, the bug could be in any number of - -- places: - -- - -- * Our translatiom from the DSL to Cardano is wrong - -- * There is a bug in the DSL definitions - -- * There is a bug in the Cardano implementation - -- - -- We record the error message from Cardano, if Cardano thought the chain - -- was invalid, as well as the ledger that causes the problem. - | Disagreement { - validationLedger :: Ledger h a - , validationDisagreement :: Disagreement h a - } - --- | Disagreement between Cardano and the DSL --- --- We consider something to be "unexpectedly foo" when Cardano says it's --- " foo " but the DSL says it's " not foo "; the DSL is the spec, after all --- (of course that doesn't mean that it cannot contain bugs :). -data Disagreement h a = - -- | Cardano reported the chain as invalid, but the DSL reported it as - -- valid. We record the error message from Cardano. - UnexpectedInvalid Cardano.VerifyBlocksException - - -- | Cardano reported an error during chain translation, but the DSL - -- reported it as valid. - | UnexpectedError IntException - - -- | Cardano reported the chain as valid, but the DSL reported it as - -- invalid. - | UnexpectedValid Text - - -- | Both Cardano and the DSL reported the chain as valid, but they computed - -- a different UTxO - | UnexpectedUtxo { - utxoDsl :: Utxo h a - , utxoCardano :: Cardano.Utxo - , utxoInt :: Cardano.Utxo - } - -expectValid :: ValidationResult h a -> Bool -expectValid ExpectedValid = True -expectValid _otherwise = False - -expectInvalid :: ValidationResult h a -> Bool -expectInvalid (ExpectedInvalid _ _) = True -expectInvalid _otherwise = False - -{------------------------------------------------------------------------------- - Pretty-printing --------------------------------------------------------------------------------} - -instance (Hash h a, Buildable a) => Buildable (ValidationResult h a) where - build ExpectedValid = "ExpectedValid" - build ExpectedInvalid{..} = bprint - ( "ExpectedInvalid" - % ", errorDsl: " % build - % ", errorCardano: " % build - % "}" - ) - validationErrorDsl - validationErrorCardano - build ExpectedInvalid'{..} = bprint - ( "ExpectedInvalid'" - % ", errorDsl: " % build - % ", errorInt: " % build - % "}" - ) - validationErrorDsl - validationErrorInt - build Disagreement{..} = bprint - ( "Disagreement " - % "{ ledger: " % build - % ", disagreement: " % build - % "}" - ) - validationLedger - validationDisagreement - -instance (Hash h a, Buildable a) => Buildable (Disagreement h a) where - build (UnexpectedInvalid e) = bprint ("UnexpectedInvalid " % build) e - build (UnexpectedError e) = bprint ("UnexpectedError " % shown) e - build (UnexpectedValid e) = bprint ("UnexpectedValid " % shown) e - build UnexpectedUtxo{..} = bprint - ( "UnexpectedUtxo" - % "{ dsl: " % build - % ", cardano: " % mapJson - % ", int: " % mapJson - % "}" - ) - utxoDsl - utxoCardano - utxoInt + Test.Spec.Translation.spec + Test.Spec.Models.spec + Test.Spec.Kernel.spec + Test.Spec.WalletWorker.spec + Test.Spec.Submission.spec + txMetaStorageSpecs diff --git a/wallet/cardano-sl-wallet.cabal b/wallet/cardano-sl-wallet.cabal index 457383d5a84..03ba57e5b5c 100644 --- a/wallet/cardano-sl-wallet.cabal +++ b/wallet/cardano-sl-wallet.cabal @@ -1,5 +1,5 @@ name: cardano-sl-wallet -version: 1.2.1 +version: 1.3.0 synopsis: Cardano SL - wallet description: Cardano SL - wallet license: MIT @@ -123,6 +123,7 @@ library , cardano-sl-generator , cardano-sl-db , cardano-sl-infra + , cardano-sl-lrc , cardano-sl-ssc , cardano-sl-txp , cardano-sl-networking @@ -133,6 +134,7 @@ library , data-default , directory , dlist + , ekg-core , ether , exceptions , filepath @@ -144,6 +146,7 @@ library , memory , monad-control , mtl + , node-ipc , quickcheck-instances , random , reflection @@ -177,8 +180,8 @@ library default-language: Haskell2010 ghc-options: -Wall - -fno-warn-orphans -O2 + -fwarn-redundant-constraints default-extensions: DeriveDataTypeable DeriveGeneric @@ -216,6 +219,9 @@ test-suite cardano-wallet-test -- Standard module with some magic Spec + -- Basic QC checks + Test.Pos.Util.MnemonicsSpec + -- Basic mocks and instances Test.Pos.Wallet.Web.Mode Test.Pos.Wallet.Web.Util @@ -235,11 +241,14 @@ test-suite cardano-wallet-test build-depends: MonadRandom , QuickCheck , base + , bytestring , cardano-sl , cardano-sl-block , cardano-sl-client , cardano-sl-core + , cardano-sl-core-test , cardano-sl-crypto + , cardano-sl-crypto-test , cardano-sl-db , cardano-sl-delegation , cardano-sl-generator @@ -248,11 +257,15 @@ test-suite cardano-wallet-test , cardano-sl-networking , cardano-sl-ssc , cardano-sl-txp + , cardano-sl-txp-test , cardano-sl-update , cardano-sl-util + , cardano-sl-util-test , cardano-sl-wallet , containers , data-default + , deepseq + , ekg-core , ether , formatting , hspec @@ -273,7 +286,6 @@ test-suite cardano-wallet-test ghc-options: -threaded -rtsopts -Wall - -fno-warn-orphans -- linker speed up for linux if os(linux) diff --git a/wallet/dist/cabal-config-flags b/wallet/dist/cabal-config-flags deleted file mode 100644 index 2d23034d377..00000000000 Binary files a/wallet/dist/cabal-config-flags and /dev/null differ diff --git a/wallet/node/Main.hs b/wallet/node/Main.hs deleted file mode 100644 index 7834d64e365..00000000000 --- a/wallet/node/Main.hs +++ /dev/null @@ -1,182 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -module Main - ( main - ) where - -import Universum - -import Control.Concurrent.STM (newTBQueueIO) -import Data.Maybe (fromJust) -import Formatting (build, sformat, (%)) -import Mockable (Production, runProduction) -import System.Wlog (LoggerName, logInfo, modifyLoggerName) - -import Ntp.Client (NtpStatus, withNtpClient) - -import Pos.Binary () -import Pos.Client.CLI (CommonNodeArgs (..), NodeArgs (..), getNodeParams) -import qualified Pos.Client.CLI as CLI -import Pos.Communication (OutSpecs) -import Pos.Communication.Util (ActionSpec (..)) -import Pos.Configuration (walletProductionApi, walletTxCreationDisabled) -import Pos.Context (HasNodeContext) -import Pos.DB.DB (initNodeDBs) -import Pos.Diffusion.Types (Diffusion (..)) -import Pos.Launcher (ConfigurationOptions (..), HasConfigurations, NodeParams (..), - NodeResources (..), bracketNodeResources, loggerBracket, runNode, - withConfigurations) -import Pos.Ntp.Configuration (NtpConfiguration, ntpClientSettings) -import Pos.Ssc.Types (SscParams) -import Pos.Txp (txpGlobalSettings) -import Pos.Util (lensOf, logException) -import Pos.Util.CompileInfo (HasCompileInfo, retrieveCompileTimeInfo, withCompileInfo) -import Pos.Util.UserSecret (usVss) -import Pos.Wallet.Web (AddrCIdHashes (..), WalletWebMode, bracketWalletWS, - bracketWalletWebDB, getSKById, notifierPlugin, runWRealMode, - startPendingTxsResubmitter, walletServeWebFull, walletServerOuts) -import Pos.Wallet.Web.State (askWalletDB, askWalletSnapshot, cleanupAcidStatePeriodically, - flushWalletStorage, getWalletAddresses) -import Pos.Wallet.Web.Tracking.Decrypt (eskToWalletDecrCredentials) -import Pos.Wallet.Web.Tracking.Sync (processSyncRequest, syncWallet) -import Pos.Wallet.Web.Tracking.Types (SyncQueue) -import Pos.Web (serveWeb) -import Pos.Worker.Types (WorkerSpec, worker) -import Pos.WorkMode (WorkMode) - -import NodeOptions (WalletArgs (..), WalletNodeArgs (..), getWalletNodeOptions) - -loggerName :: LoggerName -loggerName = "node" - ----------------------------------------------------------------------------- --- Main action ----------------------------------------------------------------------------- - -actionWithWallet :: - ( HasConfigurations - , HasCompileInfo - ) - => SscParams - -> NodeParams - -> NtpConfiguration - -> WalletArgs - -> Production () -actionWithWallet sscParams nodeParams ntpConfig wArgs@WalletArgs {..} = do - logInfo "Running `actionWithWallet'" - bracketWalletWebDB walletDbPath walletRebuildDb $ \db -> - bracketWalletWS $ \conn -> - bracketNodeResources nodeParams sscParams - txpGlobalSettings - initNodeDBs $ \nr@NodeResources {..} -> do - ntpStatus <- withNtpClient (ntpClientSettings ntpConfig) - ref <- newIORef mempty - syncRequestsQueue <- liftIO $ newTBQueueIO 50 - runWRealMode - db - conn - (AddrCIdHashes ref) - syncRequestsQueue - nr - (mainAction ntpStatus nr) - where - mainAction ntpStatus = runNodeWithInit ntpStatus $ do - when (walletFlushDb) $ do - putText "Flushing wallet db..." - askWalletDB >>= flushWalletStorage - putText "Resyncing wallets with blockchain..." - syncWallets - runNodeWithInit ntpStatus init nr = - let (ActionSpec f, outs) = runNode nr (allPlugins ntpStatus) - in (ActionSpec $ \s -> init >> f s, outs) - convPlugins = (, mempty) . map (\act -> ActionSpec $ \_ -> act) - syncWallets :: WalletWebMode () - syncWallets = do - ws <- askWalletSnapshot - sks <- mapM getSKById (getWalletAddresses ws) - forM_ sks (syncWallet . eskToWalletDecrCredentials) - resubmitterPlugins = ([ActionSpec $ \diffusion -> askWalletDB >>= - \db -> startPendingTxsResubmitter db (sendTx diffusion)], mempty) - notifierPlugins = ([ActionSpec $ \_ -> notifierPlugin], mempty) - allPlugins :: HasConfigurations => TVar NtpStatus -> ([WorkerSpec WalletWebMode], OutSpecs) - allPlugins ntpStatus = - mconcat [ convPlugins (plugins wArgs) - , walletProd wArgs ntpStatus - , acidCleanupWorker wArgs - , syncWalletWorker - , resubmitterPlugins - , notifierPlugins - ] - -syncWalletWorker :: HasConfigurations => ([WorkerSpec WalletWebMode], OutSpecs) -syncWalletWorker = - first one $ worker mempty $ const $ - modifyLoggerName (const "syncWalletWorker") $ - (view (lensOf @SyncQueue) >>= processSyncRequest) - -acidCleanupWorker :: HasConfigurations => WalletArgs -> ([WorkerSpec WalletWebMode], OutSpecs) -acidCleanupWorker WalletArgs{..} = - first one $ worker mempty $ const $ - modifyLoggerName (const "acidcleanup") $ - (askWalletDB >>= \db -> cleanupAcidStatePeriodically db walletAcidInterval) - -walletProd :: - ( HasConfigurations - , HasCompileInfo - ) - => WalletArgs - -> TVar NtpStatus - -> ([WorkerSpec WalletWebMode], OutSpecs) -walletProd WalletArgs {..} ntpStatus = first one $ worker walletServerOuts $ \diffusion -> do - logInfo $ sformat ("Production mode for API: "%build) - walletProductionApi - logInfo $ sformat ("Transaction submission disabled: "%build) - walletTxCreationDisabled - walletServeWebFull - diffusion - ntpStatus - walletDebug - walletAddress - (Just walletTLSParams) - -plugins :: - ( WorkMode ctx m - , HasNodeContext ctx - , HasConfigurations - , HasCompileInfo - ) => WalletArgs -> [m ()] -plugins WalletArgs {..} - | enableWeb = [serveWeb webPort (Just walletTLSParams)] - | otherwise = [] - -action :: HasCompileInfo => WalletNodeArgs -> Production () -action ntpConfig (WalletNodeArgs (cArgs@CommonNodeArgs{..}) (wArgs@WalletArgs{..})) = - withConfigurations conf $ \ntpConfig -> do - CLI.printInfoOnStart cArgs - logInfo $ "Wallet is enabled!" - currentParams <- getNodeParams loggerName cArgs nodeArgs - - let vssSK = fromJust $ npUserSecret currentParams ^. usVss - let sscParams = CLI.gtSscParams cArgs vssSK (npBehaviorConfig currentParams) - - actionWithWallet sscParams currentParams ntpConfig wArgs - where - nodeArgs :: NodeArgs - nodeArgs = NodeArgs { behaviorConfigPath = Nothing } - - conf :: ConfigurationOptions - conf = CLI.configurationOptions $ CLI.commonArgs cArgs - - -main :: IO () -main = withCompileInfo $(retrieveCompileTimeInfo) $ do - args <- getWalletNodeOptions - let loggingParams = CLI.loggingParams loggerName (wnaCommonNodeArgs args) - loggerBracket loggingParams . logException "node" . runProduction $ do - logInfo "[Attention] Software is built with wallet part" - action args diff --git a/wallet/node/NodeOptions.hs b/wallet/node/NodeOptions.hs deleted file mode 100644 index d3375a50815..00000000000 --- a/wallet/node/NodeOptions.hs +++ /dev/null @@ -1,117 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE QuasiQuotes #-} - --- | Command line options of wallet node. - -module NodeOptions - ( WalletNodeArgs (..) - , WalletArgs (..) - , getWalletNodeOptions - ) where - -import Universum - -import Data.Time.Units (Minute) -import Data.Version (showVersion) -import Options.Applicative (Parser, auto, execParser, footerDoc, fullDesc, header, help, - helper, info, infoOption, long, metavar, option, progDesc, - strOption, switch, value) -import qualified Options.Applicative as Opt - -import Paths_cardano_sl (version) -import Pos.Client.CLI (CommonNodeArgs (..)) -import qualified Pos.Client.CLI as CLI -import Pos.Util.CompileInfo (CompileTimeInfo (..), HasCompileInfo, compileInfo) -import Pos.Util.TimeWarp (NetworkAddress, localhost) -import Pos.Web.Types (TlsParams (..)) - -data WalletNodeArgs = WalletNodeArgs - { wnaCommonNodeArgs :: !CommonNodeArgs - , wnaWalletArgs :: !WalletArgs - } deriving Show - -data WalletArgs = WalletArgs - { enableWeb :: !Bool - , webPort :: !Word16 - , walletTLSParams :: !TlsParams - , walletAddress :: !NetworkAddress - , walletDbPath :: !FilePath - , walletRebuildDb :: !Bool - , walletAcidInterval :: !Minute - , walletDebug :: !Bool - , walletFlushDb :: !Bool - } deriving Show - -walletArgsParser :: Parser WalletNodeArgs -walletArgsParser = do - commonNodeArgs <- CLI.commonNodeArgsParser - enableWeb <- switch $ - long "web" <> - help "Activate web API (it’s not linked with a wallet web API)." - webPort <- - CLI.webPortOption 8080 "Port for web API." - walletTLSParams <- tlsParamsOption - walletAddress <- CLI.walletAddressOption $ Just (localhost, 8090) - walletDbPath <- strOption $ - long "wallet-db-path" <> - help "Path to the wallet's database." <> - value "wallet-db" - walletRebuildDb <- switch $ - long "wallet-rebuild-db" <> - help "If wallet's database already exists, discard its contents \ - \and create a new one from scratch." - walletAcidInterval <- fmap fromInteger $ option auto $ - long "wallet-acid-cleanup-interval" <> - help "Interval on which to execute wallet cleanup action (create checkpoint \ - \and archive and cleanup archive partially)" <> - metavar "MINUTES" <> - value (12 * 60) - walletDebug <- switch $ - long "wallet-debug" <> - help "Run wallet with debug params (e.g. include \ - \all the genesis keys in the set of secret keys)." - walletFlushDb <- switch $ - long "flush-wallet-db" <> - help "Flushes all blockchain-recoverable data from DB \ - \(everything excluding wallets/accounts/addresses, metadata)" - - pure $ WalletNodeArgs commonNodeArgs WalletArgs{..} - -getWalletNodeOptions :: HasCompileInfo => IO WalletNodeArgs -getWalletNodeOptions = execParser programInfo - where - programInfo = info (helper <*> versionOption <*> walletArgsParser) $ - fullDesc <> progDesc "Cardano SL main server node w/ wallet." - <> header "Cardano SL node." - <> footerDoc CLI.usageExample - - versionOption = infoOption - ("cardano-node-" <> showVersion version <> - ", git revision " <> toString (ctiGitRevision compileInfo)) - (long "version" <> help "Show version.") - -tlsParamsOption :: Opt.Parser TlsParams -tlsParamsOption = do - tpCertPath <- - Opt.strOption $ - CLI.templateParser - "tlscert" - "FILEPATH" - "Path to file with TLS certificate" - <> Opt.value "./scripts/tls-files/server.crt" - tpKeyPath <- - Opt.strOption $ - CLI.templateParser - "tlskey" - "FILEPATH" - "Path to file with TLS key" - <> Opt.value "./scripts/tls-files/server.key" - tpCaPath <- - Opt.strOption $ - CLI.templateParser - "tlsca" - "FILEPATH" - "Path to file with TLS certificate authority" - <> Opt.value "./scripts/tls-files/ca.crt" - return TlsParams{..} diff --git a/wallet/src/Pos/Arbitrary/Wallet/Web/ClientTypes.hs b/wallet/src/Pos/Arbitrary/Wallet/Web/ClientTypes.hs index dd3451aa334..5b39d183df4 100644 --- a/wallet/src/Pos/Arbitrary/Wallet/Web/ClientTypes.hs +++ b/wallet/src/Pos/Arbitrary/Wallet/Web/ClientTypes.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | Arbitrary instances for client types module Pos.Arbitrary.Wallet.Web.ClientTypes @@ -7,10 +9,10 @@ module Pos.Arbitrary.Wallet.Web.ClientTypes import Universum import qualified Data.ByteString.Char8 as B8 +import Pos.Wallet.Web.ClientTypes.Types (CHash (..), CId (..), CWAddressMeta (..)) +import Pos.Wallet.Web.State (WAddressMeta (..)) import qualified Serokell.Util.Base64 as B64 import Test.QuickCheck (Arbitrary (..), vectorOf) -import Pos.Wallet.Web.State (WAddressMeta(..)) -import Pos.Wallet.Web.ClientTypes.Types (CHash (..), CId (..), CWAddressMeta (..)) instance Arbitrary CHash where arbitrary = CHash . B64.encode . B8.pack <$> vectorOf 64 arbitrary diff --git a/wallet/src/Pos/Util/BackupPhrase.hs b/wallet/src/Pos/Util/BackupPhrase.hs index c68264c84ac..2b954721626 100644 --- a/wallet/src/Pos/Util/BackupPhrase.hs +++ b/wallet/src/Pos/Util/BackupPhrase.hs @@ -13,6 +13,7 @@ import Universum import Crypto.Hash (Blake2b_256) import qualified Data.ByteString as BS +import Data.Default (Default (def)) import Data.Text.Buildable (Buildable (..)) import Test.QuickCheck (Arbitrary (..), Gen, genericShrink, vectorOf) import Test.QuickCheck.Instances () @@ -21,25 +22,66 @@ import Pos.Binary (Bi (..), serialize') import Pos.Crypto (AbstractHash, EncryptedSecretKey, PassPhrase, SecretKey, VssKeyPair, deterministicKeyGen, deterministicVssKeyGen, safeDeterministicKeyGen, unsafeAbstractHash) -import Pos.Util.LogSafe (SecureLog) -import Pos.Util.Mnemonics (fromMnemonic, toMnemonic) +import Pos.Infra.Util.LogSafe (SecureLog) +import Pos.Util.Mnemonics (defMnemonic, fromMnemonic, toMnemonic) -- | Datatype to contain a valid backup phrase newtype BackupPhrase = BackupPhrase { bpToList :: [Text] } deriving (Eq, Generic) + +-- | To use everytime we need to show an example of a Mnemonic. This particular +-- mnemonic is rejected to prevent users from using it on a real wallet. +instance Default BackupPhrase where + def = + BackupPhrase (words defMnemonic) + +-- | A datatype representing word counts you'd have in +-- a +-- mnemonic passphrase. +data MnemonicWordCount + = Nine + | Twelve + | Fifteen + | Eighteen + | Twentyone + | Twentyfour + deriving (Eq, Show) + +wordCountToInt :: MnemonicWordCount -> Int +wordCountToInt wc = case wc of + Nine -> 9 + Twelve -> 12 + Fifteen -> 15 + Eighteen -> 18 + Twentyone -> 21 + Twentyfour -> 24 + +checksumLength :: MnemonicWordCount -> Int +checksumLength wc = case wc of + Nine -> 3 + Twelve -> 4 + Fifteen -> 5 + Eighteen -> 6 + Twentyone -> 7 + Twentyfour -> 8 + +byteCount :: MnemonicWordCount -> Int +byteCount wc = wordCountToInt wc + checksumLength wc + instance Arbitrary BackupPhrase where arbitrary = do - em <- arbitraryMnemonic 16 + em <- arbitraryMnemonic Twelve case em of Left _ -> arbitrary Right a -> pure a shrink = genericShrink -arbitraryMnemonic :: Int -> Gen (Either Text BackupPhrase) -arbitraryMnemonic len = do - eitherMnemonic <- toMnemonic . BS.pack <$> vectorOf len arbitrary +-- | Generate an arbitrary mnemonic with the given number of words. +arbitraryMnemonic :: MnemonicWordCount -> Gen (Either Text BackupPhrase) +arbitraryMnemonic wordCount = do + eitherMnemonic <- toMnemonic . BS.pack <$> vectorOf (byteCount wordCount) arbitrary pure . first toText $ BackupPhrase . words <$> eitherMnemonic -- | Number of words in backup phrase diff --git a/wallet/src/Pos/Util/Mnemonics.hs b/wallet/src/Pos/Util/Mnemonics.hs index ec5f9b7b144..b723e8d6c99 100644 --- a/wallet/src/Pos/Util/Mnemonics.hs +++ b/wallet/src/Pos/Util/Mnemonics.hs @@ -7,6 +7,7 @@ module Pos.Util.Mnemonics -- * Data types Entropy , Mnemonic + , defMnemonic , Seed -- * Entropy encoding and decoding @@ -46,10 +47,18 @@ integerToBS i f 0 = Nothing f x = Just (fromInteger x :: Word8, x `shiftR` 8) +-- | A default mnemonic that can be advertised as an example. Rejected by +-- fromMnemonic. +defMnemonic :: Mnemonic +defMnemonic = + "squirrel material silly twice direct slush pistol razor become junk kingdom flee" + -- | Provide intial entropy as a 'ByteString' of length multiple of 4 bytes. -- Output a mnemonic sentence. toMnemonic :: Entropy -> Either String Mnemonic toMnemonic ent = do + when (length ent <= 0) $ + Left "toMnemonic: entropy must be a non-zero sequence of bytes" when (remainder /= 0) $ Left "toMnemonic: entropy must be a multiple of 4 bytes" when (cs_len > 16) $ @@ -67,6 +76,10 @@ toMnemonic ent = do -- mnemonic. fromMnemonic :: Mnemonic -> Either String Entropy fromMnemonic ms = do + when (ms == defMnemonic) $ + Left "fromMnemonic: forbidden mnemonic: an example mnemonic has been submitted. Please generate a fresh and private mnemonic from a trusted source." + when (word_count <= 0) $ + Left "fromMnemonic: empty mnemonic is not allowed" when (isJust $ find (not . isAscii) ms) $ Left "fromMnemonic: non-ASCII characters not supported" when (word_count > 48) $ diff --git a/wallet/src/Pos/Wallet/Aeson/ClientTypes.hs b/wallet/src/Pos/Wallet/Aeson/ClientTypes.hs index 0c02ecfe00c..e9fd51d0941 100644 --- a/wallet/src/Pos/Wallet/Aeson/ClientTypes.hs +++ b/wallet/src/Pos/Wallet/Aeson/ClientTypes.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Pos.Wallet.Aeson.ClientTypes ( ) where @@ -13,6 +15,7 @@ import Servant.API.ContentTypes (NoContent (..)) import Pos.Client.Txp.Util (InputSelectionPolicy (..)) import Pos.Util.BackupPhrase (BackupPhrase) +import Pos.Util.Util (aesonError) import Pos.Wallet.Web.ClientTypes (Addr, ApiVersion (..), CAccount, CAccountId, CAccountInit, CAccountMeta, CAddress, CCoin, CFilePath (..), CHash, CId, CInitialized, @@ -23,7 +26,6 @@ import Pos.Wallet.Web.ClientTypes (Addr, ApiVersion (..), CAccount, CA NewBatchPayment (..), SyncProgress, Wal) import Pos.Wallet.Web.Error (WalletError) import Pos.Wallet.Web.Sockets.Types (NotifyEvent) -import Pos.Util.Util (aesonError) deriveJSON defaultOptions ''CAccountId deriveJSON defaultOptions ''CWAddressMeta diff --git a/wallet/src/Pos/Wallet/Aeson/Storage.hs b/wallet/src/Pos/Wallet/Aeson/Storage.hs index 58c5ebba321..ce9aae8aa06 100644 --- a/wallet/src/Pos/Wallet/Aeson/Storage.hs +++ b/wallet/src/Pos/Wallet/Aeson/Storage.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | These instances are used for `test/printDB` method. -- Only for debugging and testing purposes. @@ -13,7 +15,6 @@ import Data.Aeson.TH (defaultOptions, deriveJSON) import Data.Aeson.Types (toJSONKeyText) import qualified Data.Text as T -import Pos.Aeson.Crypto () import Pos.Aeson.Txp () import Pos.Client.Txp.History (TxHistoryEntry) import Pos.Util.Util (toAesonError) @@ -21,8 +22,8 @@ import Pos.Util.Util (toAesonError) import Pos.Wallet.Aeson.ClientTypes () import Pos.Wallet.Web.ClientTypes (AccountId (..), CHash (..), CId (..), CTxId (..)) import Pos.Wallet.Web.Pending.Types (PendingTx, PtxCondition, PtxSubmitTiming) -import Pos.Wallet.Web.State.Storage (AccountInfo, AddressInfo, WAddressMeta, - RestorationBlockDepth, SyncStatistics, SyncThroughput, +import Pos.Wallet.Web.State.Storage (AccountInfo, AddressInfo, RestorationBlockDepth, + SyncStatistics, SyncThroughput, WAddressMeta, WalletInfo, WalletStorage, WalletSyncState) instance FromJSON (CId a) => FromJSONKey (CId a) where diff --git a/wallet/src/Pos/Wallet/Aeson/WalletBackup.hs b/wallet/src/Pos/Wallet/Aeson/WalletBackup.hs index 09504140b0d..211ba34c3b1 100644 --- a/wallet/src/Pos/Wallet/Aeson/WalletBackup.hs +++ b/wallet/src/Pos/Wallet/Aeson/WalletBackup.hs @@ -1,5 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Pos.Wallet.Aeson.WalletBackup ( ) where diff --git a/wallet/src/Pos/Wallet/Redirect.hs b/wallet/src/Pos/Wallet/Redirect.hs index a8504dca09b..b8901bfc06f 100644 --- a/wallet/src/Pos/Wallet/Redirect.hs +++ b/wallet/src/Pos/Wallet/Redirect.hs @@ -19,7 +19,7 @@ module Pos.Wallet.Redirect , txpNormalizeWebWallet ) where -import Universum +import Universum hiding (id) import Control.Lens (views) import qualified Data.HashMap.Strict as HM @@ -31,12 +31,12 @@ import qualified Pos.Context as PC import Pos.Core (ChainDifficulty, HasConfiguration, Timestamp, Tx, TxAux (..), TxId, TxUndo, difficultyL, getCurrentTimestamp) import Pos.Core.Block (BlockHeader) -import Pos.Crypto (WithHash (..)) +import Pos.Crypto (ProtocolMagic, WithHash (..)) import qualified Pos.DB.BlockIndex as DB import Pos.DB.Class (MonadDBRead) import qualified Pos.DB.GState.Common as GS -import Pos.Shutdown (HasShutdownContext, triggerShutdown) -import Pos.Slotting (MonadSlots (..), getNextEpochSlotDuration) +import Pos.Infra.Shutdown (HasShutdownContext, triggerShutdown) +import Pos.Infra.Slotting (MonadSlots (..), getNextEpochSlotDuration) import Pos.Txp (MempoolExt, MonadTxpLocal (..), ToilVerFailure, TxpLocalWorkMode, TxpProcessTransactionMode, getLocalUndos, txNormalize, txProcessTransaction, withTxpLocalData) @@ -131,10 +131,10 @@ txpProcessTxWebWallet , AccountMode ctx m , WS.WalletDbReader ctx m ) - => (TxId, TxAux) -> m (Either ToilVerFailure ()) -txpProcessTxWebWallet tx@(txId, txAux) = do + => ProtocolMagic -> (TxId, TxAux) -> m (Either ToilVerFailure ()) +txpProcessTxWebWallet pm tx@(txId, txAux) = do db <- WS.askWalletDB - txProcessTransaction tx >>= traverse (const $ addTxToWallets db) + txProcessTransaction pm tx >>= traverse (const $ addTxToWallets db) where addTxToWallets :: WS.WalletDB -> m () addTxToWallets db = do @@ -155,5 +155,9 @@ txpProcessTxWebWallet tx@(txId, txAux) = do wdc <- eskToWalletDecrCredentials <$> getSKById wId pure (wId, buildTHEntryExtra wdc txWithUndo (Nothing, Just ts)) -txpNormalizeWebWallet :: (TxpLocalWorkMode ctx m, MempoolExt m ~ ()) => m () +txpNormalizeWebWallet + :: ( TxpLocalWorkMode ctx m + , MempoolExt m ~ () + ) + => ProtocolMagic -> m () txpNormalizeWebWallet = txNormalize diff --git a/wallet/src/Pos/Wallet/WalletMode.hs b/wallet/src/Pos/Wallet/WalletMode.hs index f2b1bbca835..860a5706547 100644 --- a/wallet/src/Pos/Wallet/WalletMode.hs +++ b/wallet/src/Pos/Wallet/WalletMode.hs @@ -19,8 +19,8 @@ import Pos.Client.KeyStorage (MonadKeys) import Pos.Client.Txp.History (MonadTxHistory (..)) import Pos.Client.Txp.Network (TxMode) import Pos.Core (ChainDifficulty) +import Pos.Infra.Util.TimeWarp (CanJsonLog) import Pos.Update (ConfirmedProposalState (..)) -import Pos.Util.TimeWarp (CanJsonLog) import Pos.WorkMode (EmptyMempoolExt) class Monad m => MonadBlockchainInfo m where diff --git a/wallet/src/Pos/Wallet/Web.hs b/wallet/src/Pos/Wallet/Web.hs index 8df105055a5..4a9f7f3373e 100644 --- a/wallet/src/Pos/Wallet/Web.hs +++ b/wallet/src/Pos/Wallet/Web.hs @@ -1,5 +1,36 @@ -- | Web part of wallet. - -{-# OPTIONS_GHC -F -pgmF autoexporter #-} {-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -Wno-dodgy-exports #-} + +module Pos.Wallet.Web + ( module Pos.Wallet.Web.Tracking + , module Pos.Wallet.Web.Swagger + , module Pos.Wallet.Web.State + , module Pos.Wallet.Web.Sockets + , module Pos.Wallet.Web.Server + , module Pos.Wallet.Web.Pending + , module Pos.Wallet.Web.Mode + , module Pos.Wallet.Web.Methods + , module Pos.Wallet.Web.Error + , module Pos.Wallet.Web.ClientTypes + , module Pos.Wallet.Web.Backup + , module Pos.Wallet.Web.Assurance + , module Pos.Wallet.Web.Api + , module Pos.Wallet.Web.Account + ) where + +import Pos.Wallet.Web.Util +import Pos.Wallet.Web.Tracking +import Pos.Wallet.Web.Swagger +import Pos.Wallet.Web.State +import Pos.Wallet.Web.Sockets +import Pos.Wallet.Web.Server +import Pos.Wallet.Web.Pending +import Pos.Wallet.Web.Mode +import Pos.Wallet.Web.Methods +import Pos.Wallet.Web.Error +import Pos.Wallet.Web.ClientTypes +import Pos.Wallet.Web.Backup +import Pos.Wallet.Web.Assurance +import Pos.Wallet.Web.Api +import Pos.Wallet.Web.Account \ No newline at end of file diff --git a/wallet/src/Pos/Wallet/Web/ClientTypes/Instances.hs b/wallet/src/Pos/Wallet/Web/ClientTypes/Instances.hs index d30944ae85a..d41dfb8e045 100644 --- a/wallet/src/Pos/Wallet/Web/ClientTypes/Instances.hs +++ b/wallet/src/Pos/Wallet/Web/ClientTypes/Instances.hs @@ -1,5 +1,7 @@ {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | Instances for client types module Pos.Wallet.Web.ClientTypes.Instances () where @@ -16,7 +18,8 @@ import qualified Serokell.Util.Base16 as Base16 import Servant.API (FromHttpApiData (..), ToHttpApiData (..)) import Servant.Multipart (FromMultipart (..), Mem, lookupFile, lookupInput) -import Pos.Core (Address, Coin(..), coinToInteger, decodeTextAddress, checkCoin, mkCoin, unsafeGetCoin) +import Pos.Core (Address, Coin (..), checkCoin, coinToInteger, decodeTextAddress, mkCoin, + unsafeGetCoin) import Pos.Core.Txp (TxId) import Pos.Crypto (PassPhrase, decodeHash, hashHexF, passphraseLength) import Pos.Util.Servant (FromCType (..), HasTruncateLogPolicy (..), OriginType, diff --git a/wallet/src/Pos/Wallet/Web/ClientTypes/Types.hs b/wallet/src/Pos/Wallet/Web/ClientTypes/Types.hs index 99cb775d773..821e9c975d8 100644 --- a/wallet/src/Pos/Wallet/Web/ClientTypes/Types.hs +++ b/wallet/src/Pos/Wallet/Web/ClientTypes/Types.hs @@ -1,5 +1,7 @@ {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | Types representing client (wallet) requests on wallet API. module Pos.Wallet.Web.ClientTypes.Types ( SyncProgress (..) @@ -80,9 +82,10 @@ import Servant.Multipart (FileData, Mem) import Pos.Client.Txp.Util (InputSelectionPolicy) import Pos.Core (BlockVersion, ChainDifficulty, Coin, ScriptVersion, SoftwareVersion, unsafeGetCoin) +import Pos.Infra.Util.LogSafe (BuildableSafeGen (..), SecureLog (..), + buildUnsecure, deriveSafeBuildable, + secretOnlyF, secureListF) import Pos.Util.BackupPhrase (BackupPhrase) -import Pos.Util.LogSafe (BuildableSafeGen (..), SecureLog (..), buildUnsecure, - deriveSafeBuildable, secretOnlyF, secureListF) import Pos.Util.Servant (HasTruncateLogPolicy, WithTruncatedLog (..)) data SyncProgress = SyncProgress @@ -107,7 +110,7 @@ instance Default SyncProgress where -- | Client hash newtype CHash = CHash Text - deriving (Show, Eq, Ord, Generic, Buildable) + deriving (Show, Eq, Ord, Generic, Buildable, NFData) instance Hashable CHash where hashWithSalt s (CHash h) = hashWithSalt s h @@ -115,7 +118,7 @@ instance Hashable CHash where -- | Client address -- @w@ is phantom type and stands for type of item this id belongs to. newtype CId w = CId CHash - deriving (Show, Eq, Ord, Generic, Hashable, Buildable) + deriving (Show, Eq, Ord, Generic, Hashable, Buildable, NFData) instance Buildable (SecureLog $ CId w) where build _ = "" @@ -130,7 +133,7 @@ data Addr = Addr -- | Client transaction id newtype CTxId = CTxId CHash - deriving (Show, Eq, Generic, Hashable, Buildable) + deriving (Show, Eq, Generic, Hashable, Buildable, NFData) instance Buildable (SecureLog CTxId) where build _ = "" @@ -152,7 +155,7 @@ instance Buildable (SecureLog CAccountId) where newtype CCoin = CCoin { getCCoin :: Text - } deriving (Show, Eq, Generic, Buildable) + } deriving (Show, Eq, Generic, Buildable, NFData) mkCCoin :: Coin -> CCoin mkCCoin = CCoin . show . unsafeGetCoin @@ -171,6 +174,8 @@ data AccountId = AccountId aiIndex :: Word32 } deriving (Eq, Ord, Show, Generic, Typeable) +instance NFData AccountId + instance Hashable AccountId instance Buildable AccountId where @@ -210,6 +215,8 @@ data CWalletAssurance | CWANormal deriving (Show, Eq, Enum, Bounded, Generic) +instance NFData CWalletAssurance + instance Buildable CWalletAssurance where build = bprint shown @@ -225,6 +232,8 @@ data CWalletMeta = CWalletMeta -- ticket> for more information. } deriving (Show, Eq, Generic) +instance NFData CWalletMeta + instance Buildable CWalletMeta where build CWalletMeta{..} = bprint ("("%build%"/"%build%")") @@ -242,6 +251,8 @@ data CAccountMeta = CAccountMeta { caName :: !Text } deriving (Eq, Show, Generic) +instance NFData CAccountMeta + instance Buildable CAccountMeta where -- can't log for now, names are dangerous build CAccountMeta{..} = "" @@ -402,10 +413,9 @@ type CPwHash = Text -- or Base64 or something else -- | Client profile (CP) -- all data of client are "meta data" - that is not provided by Cardano -- (Flow type: accountType) --- TODO: Newtype? -data CProfile = CProfile +newtype CProfile = CProfile { cpLocale :: Text - } deriving (Eq, Show, Generic, Typeable) + } deriving (Eq, Show, Generic, Typeable, NFData) instance Buildable CProfile where build CProfile{..} = @@ -428,6 +438,8 @@ data CTxMeta = CTxMeta { ctmDate :: POSIXTime } deriving (Eq, Show, Generic) +instance NFData CTxMeta + instance Buildable CTxMeta where build CTxMeta{..} = bprint ("{ date="%build%" }") ctmDate @@ -536,6 +548,8 @@ data CUpdateInfo = CUpdateInfo , cuiNegativeStake :: !CCoin } deriving (Eq, Show, Generic, Typeable) +instance NFData CUpdateInfo + instance Buildable CUpdateInfo where build CUpdateInfo{..} = bprint ("{ softver="%build diff --git a/wallet/src/Pos/Wallet/Web/Error.hs b/wallet/src/Pos/Wallet/Web/Error.hs index 27947fb88b8..4e85519ab37 100644 --- a/wallet/src/Pos/Wallet/Web/Error.hs +++ b/wallet/src/Pos/Wallet/Web/Error.hs @@ -1 +1,7 @@ -{-# OPTIONS_GHC -F -pgmF autoexporter #-} +module Pos.Wallet.Web.Error + ( module Pos.Wallet.Web.Error.Types + , module Pos.Wallet.Web.Error.Util + ) where + +import Pos.Wallet.Web.Error.Types +import Pos.Wallet.Web.Error.Util diff --git a/wallet/src/Pos/Wallet/Web/Methods.hs b/wallet/src/Pos/Wallet/Web/Methods.hs index 4fe7551798c..378e5f5acf8 100644 --- a/wallet/src/Pos/Wallet/Web/Methods.hs +++ b/wallet/src/Pos/Wallet/Web/Methods.hs @@ -1,4 +1,27 @@ -- | Wallet endpoints implementation -{-# OPTIONS_GHC -F -pgmF autoexporter #-} +module Pos.Wallet.Web.Methods + ( module Pos.Wallet.Web.Methods.Backup + , module Pos.Wallet.Web.Methods.History + , module Pos.Wallet.Web.Methods.Info + , module Pos.Wallet.Web.Methods.Logic + , module Pos.Wallet.Web.Methods.Misc + , module Pos.Wallet.Web.Methods.Payment + , module Pos.Wallet.Web.Methods.Redeem + , module Pos.Wallet.Web.Methods.Reporting + , module Pos.Wallet.Web.Methods.Restore + , module Pos.Wallet.Web.Methods.Txp + ) where + +import Pos.Wallet.Web.Methods.Backup +import Pos.Wallet.Web.Methods.History +import Pos.Wallet.Web.Methods.Info +import Pos.Wallet.Web.Methods.Logic +import Pos.Wallet.Web.Methods.Misc +import Pos.Wallet.Web.Methods.Payment +import Pos.Wallet.Web.Methods.Redeem +import Pos.Wallet.Web.Methods.Reporting +import Pos.Wallet.Web.Methods.Restore +import Pos.Wallet.Web.Methods.Txp + diff --git a/wallet/src/Pos/Wallet/Web/Methods/History.hs b/wallet/src/Pos/Wallet/Web/Methods/History.hs index 5465338396f..2867e0d40ab 100644 --- a/wallet/src/Pos/Wallet/Web/Methods/History.hs +++ b/wallet/src/Pos/Wallet/Web/Methods/History.hs @@ -25,9 +25,9 @@ import Serokell.Util (listChunkedJson, listJsonIndent) import System.Wlog (WithLogger, logDebug) import Pos.Client.Txp.History (MonadTxHistory, TxHistoryEntry (..), txHistoryListToMap) -import Pos.Core (Address, ChainDifficulty, HasConfiguration, timestampToPosix) +import Pos.Core (Address, ChainDifficulty, timestampToPosix) import Pos.Core.Txp (TxId) -import Pos.Util.LogSafe (logInfoSP, secureListF) +import Pos.Infra.Util.LogSafe (logInfoSP, secureListF) import Pos.Util.Servant (encodeCType) import Pos.Util.Util (eitherToThrow) import Pos.Wallet.WalletMode (MonadBlockchainInfo (..), getLocalHistory) @@ -180,7 +180,7 @@ getHistoryLimited mCWalId mAccId mAddrId mSkip mLimit = do "Please do not specify both walletId and accountId at the same time" addHistoryTxMeta - :: (MonadIO m, HasConfiguration) + :: (MonadIO m) => WalletDB -> CId Wal -> TxHistoryEntry @@ -192,7 +192,7 @@ addHistoryTxMeta db cWalId txhe = do -- This functions is helper to do @addHistoryTx@ for -- all txs from mempool as one Acidic transaction. addHistoryTxsMeta - :: (MonadIO m, HasConfiguration) + :: (MonadIO m) => WalletDB -> CId Wal -> Map TxId TxHistoryEntry diff --git a/wallet/src/Pos/Wallet/Web/Methods/Logic.hs b/wallet/src/Pos/Wallet/Web/Methods/Logic.hs index 526d9acbd75..695818f079f 100644 --- a/wallet/src/Pos/Wallet/Web/Methods/Logic.hs +++ b/wallet/src/Pos/Wallet/Web/Methods/Logic.hs @@ -46,7 +46,7 @@ import Pos.Client.KeyStorage (MonadKeys (..), MonadKeysRead, addSecret import Pos.Core (Address, Coin, mkCoin, sumCoins, unsafeIntegerToCoin) import Pos.Core.Configuration (HasConfiguration) import Pos.Crypto (PassPhrase, changeEncPassphrase, checkPassMatches, emptyPassphrase) -import Pos.Slotting (MonadSlots) +import Pos.Infra.Slotting (MonadSlots) import Pos.Txp (GenericTxpLocalData, MonadTxpMem, TxAux, TxId, UndoMap, applyUtxoModToAddrCoinMap, getLocalTxs, getLocalUndos, withTxpLocalData) import Pos.Util (maybeThrow) diff --git a/wallet/src/Pos/Wallet/Web/Methods/Misc.hs b/wallet/src/Pos/Wallet/Web/Methods/Misc.hs index a10ebd2de20..9ed51c259d2 100644 --- a/wallet/src/Pos/Wallet/Web/Methods/Misc.hs +++ b/wallet/src/Pos/Wallet/Web/Methods/Misc.hs @@ -34,10 +34,10 @@ import Universum import Data.Aeson (encode) import Data.Aeson.TH (defaultOptions, deriveJSON) import qualified Data.Text.Buildable -import Data.Time.Units (toMicroseconds) +import Data.Time.Units (Second, toMicroseconds) import Formatting (bprint, build, sformat, (%)) import Mockable (Delay, LowLevelAsync, Mockables, async, delay) -import Serokell.Util (listJson, sec) +import Serokell.Util (listJson) import Servant.API.ContentTypes (MimeRender (..), NoContent (..), OctetStream) import System.Wlog (WithLogger) @@ -47,12 +47,12 @@ import Pos.Client.KeyStorage (MonadKeys (..), deleteAllSecretKeys) import Pos.Configuration (HasNodeConfiguration) import Pos.Core (HasConfiguration, SlotId, SoftwareVersion (..)) import Pos.Crypto (hashHexF) -import Pos.Shutdown (HasShutdownContext, triggerShutdown) -import Pos.Slotting (MonadSlots, getCurrentSlotBlocking) +import Pos.Infra.Shutdown (HasShutdownContext, triggerShutdown) +import Pos.Infra.Slotting (MonadSlots, getCurrentSlotBlocking) +import Pos.Infra.Util.LogSafe (logInfoUnsafeP) import Pos.Txp (TxId, TxIn, TxOut) import Pos.Update.Configuration (HasUpdateConfiguration, curSoftwareVersion) import Pos.Util (maybeThrow) -import Pos.Util.LogSafe (logInfoUnsafeP) import Pos.Util.Servant (HasTruncateLogPolicy (..)) import Pos.Wallet.Aeson.ClientTypes () import Pos.Wallet.Aeson.Storage () @@ -77,7 +77,7 @@ import Pos.Wallet.Web.Util (decodeCTypeOrFail, testOnlyEndpoint) getUserProfile :: (WalletDbReader ctx m, MonadIO m) => m CProfile getUserProfile = getProfile <$> askWalletSnapshot -updateUserProfile :: (HasConfiguration, WalletDbReader ctx m, MonadIO m) +updateUserProfile :: (WalletDbReader ctx m, MonadIO m) => CProfile -> m CProfile updateUserProfile profile = do @@ -119,12 +119,11 @@ nextUpdate = do noUpdates = RequestError "No updates available" -- | Postpone next update after restart -postponeUpdate :: (MonadIO m, HasConfiguration, WalletDbReader ctx m) => m NoContent +postponeUpdate :: (MonadIO m, WalletDbReader ctx m) => m NoContent postponeUpdate = askWalletDB >>= removeNextUpdate >> return NoContent -- | Delete next update info and restart immediately applyUpdate :: ( MonadIO m - , HasConfiguration , WalletDbReader ctx m , MonadUpdates m ) @@ -139,15 +138,14 @@ applyUpdate = askWalletDB >>= removeNextUpdate -- | Triggers shutdown in a short interval after called. Delay is -- needed in order for http request to succeed. requestShutdown :: - ( HasConfiguration - , MonadIO m + ( MonadIO m , MonadReader ctx m , WithLogger m , HasShutdownContext ctx , Mockables m [Delay, LowLevelAsync] ) => m NoContent -requestShutdown = NoContent <$ async (delay (sec 1) >> triggerShutdown) +requestShutdown = NoContent <$ async (delay (1 :: Second) >> triggerShutdown) ---------------------------------------------------------------------------- -- Sync progress @@ -184,7 +182,7 @@ localTimeDifference ntpStatus = diff <$> readTVarIO ntpStatus ---------------------------------------------------------------------------- testResetAll :: - ( HasConfiguration, HasNodeConfiguration, MonadIO m + ( HasNodeConfiguration, MonadIO m , MonadThrow m, WalletDbReader ctx m, MonadKeys m) => m NoContent testResetAll = do @@ -253,8 +251,7 @@ instance HasTruncateLogPolicy PendingTxsSummary where truncateLogPolicy = identity cancelAllApplyingPtxs - :: ( HasConfiguration - , HasNodeConfiguration + :: ( HasNodeConfiguration , MonadIO m , MonadThrow m , WalletDbReader ctx m @@ -265,8 +262,7 @@ cancelAllApplyingPtxs = do testOnlyEndpoint $ NoContent <$ cancelApplyingPtxs db cancelOneApplyingPtx :: - ( HasConfiguration - , HasNodeConfiguration + ( HasNodeConfiguration , MonadThrow m , WalletDbReader ctx m , MonadIO m diff --git a/wallet/src/Pos/Wallet/Web/Methods/Payment.hs b/wallet/src/Pos/Wallet/Web/Methods/Payment.hs index 4e8813fc52e..2c91da629b3 100644 --- a/wallet/src/Pos/Wallet/Web/Methods/Payment.hs +++ b/wallet/src/Pos/Wallet/Web/Methods/Payment.hs @@ -31,8 +31,8 @@ import Pos.Configuration (walletTxCreationDisabled) import Pos.Core (Address, Coin, HasConfiguration, TxAux (..), TxOut (..), getCurrentTimestamp) import Pos.Core.Txp (_txOutputs) -import Pos.Crypto (PassPhrase, SafeSigner, ShouldCheckPassphrase (..), checkPassMatches, - hash, withSafeSignerUnsafe) +import Pos.Crypto (PassPhrase, ProtocolMagic, SafeSigner, ShouldCheckPassphrase (..), + checkPassMatches, hash, withSafeSignerUnsafe) import Pos.DB (MonadGState) import Pos.Txp (TxFee (..), Utxo) import Pos.Util (eitherToThrow, maybeThrow) @@ -58,20 +58,22 @@ import Pos.Wallet.Web.Util (decodeCTypeOrFail, getAccountAddrsOrThrow, newPayment :: MonadWalletTxFull ctx m - => (TxAux -> m Bool) + => ProtocolMagic + -> (TxAux -> m Bool) -> PassPhrase -> AccountId -> CId Addr -> Coin -> InputSelectionPolicy -> m CTx -newPayment submitTx passphrase srcAccount dstAddress coin policy = +newPayment pm submitTx passphrase srcAccount dstAddress coin policy = -- This is done for two reasons: -- 1. In order not to overflow relay. -- 2. To let other things (e. g. block processing) happen if -- `newPayment`s are done continuously. notFasterThan (6 :: Second) $ do sendMoney + pm submitTx passphrase (AccountMoneySource srcAccount) @@ -80,14 +82,16 @@ newPayment submitTx passphrase srcAccount dstAddress coin policy = newPaymentBatch :: MonadWalletTxFull ctx m - => (TxAux -> m Bool) + => ProtocolMagic + -> (TxAux -> m Bool) -> PassPhrase -> NewBatchPayment -> m CTx -newPaymentBatch submitTx passphrase NewBatchPayment {..} = do +newPaymentBatch pm submitTx passphrase NewBatchPayment {..} = do src <- decodeCTypeOrFail npbFrom notFasterThan (6 :: Second) $ do sendMoney + pm submitTx passphrase (AccountMoneySource src) @@ -106,18 +110,19 @@ type MonadFees ctx m = getTxFee :: MonadFees ctx m - => AccountId + => ProtocolMagic + -> AccountId -> CId Addr -> Coin -> InputSelectionPolicy -> m CCoin -getTxFee srcAccount dstAccount coin policy = do +getTxFee pm srcAccount dstAccount coin policy = do ws <- askWalletSnapshot let pendingAddrs = getPendingAddresses ws policy utxo <- getMoneySourceUtxo ws (AccountMoneySource srcAccount) outputs <- coinDistrToOutputs $ one (dstAccount, coin) TxFee fee <- rewrapTxError "Cannot compute transaction fee" $ - eitherToThrow =<< runTxCreator policy (computeTxFee pendingAddrs utxo outputs) + eitherToThrow =<< runTxCreator policy (computeTxFee pm pendingAddrs utxo outputs) pure $ encodeCType fee data MoneySource @@ -143,7 +148,7 @@ getSomeMoneySourceAccount _ (AddressMoneySource addrId) = return $ addrId ^. wamAccount getSomeMoneySourceAccount _ (AccountMoneySource accId) = return accId getSomeMoneySourceAccount ws (WalletMoneySource wid) = do - wAddr <- maybeThrow noWallets (head (getWalletAccountIds ws wid)) + wAddr <- maybeThrow noWallets ((fmap fst . uncons) (getWalletAccountIds ws wid)) getSomeMoneySourceAccount ws (AccountMoneySource wAddr) where noWallets = InternalError "Wallet has no accounts" @@ -164,13 +169,14 @@ getMoneySourceUtxo ws = sendMoney :: (MonadWalletTxFull ctx m) - => (TxAux -> m Bool) + => ProtocolMagic + -> (TxAux -> m Bool) -> PassPhrase -> MoneySource -> NonEmpty (CId Addr, Coin) -> InputSelectionPolicy -> m CTx -sendMoney submitTx passphrase moneySource dstDistr policy = do +sendMoney pm submitTx passphrase moneySource dstDistr policy = do db <- askWalletDB ws <- getWalletSnapshot db when walletTxCreationDisabled $ @@ -210,7 +216,7 @@ sendMoney submitTx passphrase moneySource dstDistr policy = do let pendingAddrs = getPendingAddresses ws policy th <- rewrapTxError "Cannot send transaction" $ do (txAux, inpTxOuts') <- - prepareMTx getSigner pendingAddrs policy srcAddrs outputs (relatedAccount, passphrase) + prepareMTx pm getSigner pendingAddrs policy srcAddrs outputs (relatedAccount, passphrase) ts <- Just <$> getCurrentTimestamp let tx = taTx txAux @@ -221,7 +227,7 @@ sendMoney submitTx passphrase moneySource dstDistr policy = do th = THEntry txHash tx Nothing inpTxOuts dstAddrs ts ptx <- mkPendingTx ws srcWallet txHash txAux th - th <$ submitAndSaveNewPtx db submitTx ptx + th <$ submitAndSaveNewPtx pm db submitTx ptx -- We add TxHistoryEntry's meta created by us in advance -- to make TxHistoryEntry in CTx consistent with entry in history. diff --git a/wallet/src/Pos/Wallet/Web/Methods/Redeem.hs b/wallet/src/Pos/Wallet/Web/Methods/Redeem.hs index af942014ad5..f3d197e14ff 100644 --- a/wallet/src/Pos/Wallet/Web/Methods/Redeem.hs +++ b/wallet/src/Pos/Wallet/Web/Methods/Redeem.hs @@ -15,7 +15,7 @@ import qualified Serokell.Util.Base64 as B64 import Pos.Client.Txp.History (TxHistoryEntry (..)) import Pos.Client.Txp.Network (prepareRedemptionTx) import Pos.Core (TxAux (..), TxOut (..), getCurrentTimestamp) -import Pos.Crypto (PassPhrase, aesDecrypt, deriveAesKeyBS, hash, +import Pos.Crypto (PassPhrase, ProtocolMagic, aesDecrypt, deriveAesKeyBS, hash, redeemDeterministicKeyGen) import Pos.Util (maybeThrow) import Pos.Util.BackupPhrase (toSeed) @@ -34,12 +34,12 @@ import Pos.Wallet.Web.Util (decodeCTypeOrFail, getWalletAddrsDetector) redeemAda :: MonadWalletTxFull ctx m - => (TxAux -> m Bool) -> PassPhrase -> CWalletRedeem -> m CTx -redeemAda submitTx passphrase CWalletRedeem {..} = do + => ProtocolMagic -> (TxAux -> m Bool) -> PassPhrase -> CWalletRedeem -> m CTx +redeemAda pm submitTx passphrase CWalletRedeem {..} = do seedBs <- maybe invalidBase64 pure -- NOTE: this is just safety measure $ rightToMaybe (B64.decode crSeed) <|> rightToMaybe (B64.decodeUrl crSeed) - redeemAdaInternal submitTx passphrase crWalletId seedBs + redeemAdaInternal pm submitTx passphrase crWalletId seedBs where invalidBase64 = throwM . RequestError $ "Seed is invalid base64(url) string: " <> crSeed @@ -49,18 +49,19 @@ redeemAda submitTx passphrase CWalletRedeem {..} = do -- * https://github.com/input-output-hk/postvend-app/blob/master/src/CertGen.hs#L160 redeemAdaPaperVend :: MonadWalletTxFull ctx m - => (TxAux -> m Bool) + => ProtocolMagic + -> (TxAux -> m Bool) -> PassPhrase -> CPaperVendWalletRedeem -> m CTx -redeemAdaPaperVend submitTx passphrase CPaperVendWalletRedeem {..} = do +redeemAdaPaperVend pm submitTx passphrase CPaperVendWalletRedeem {..} = do seedEncBs <- maybe invalidBase58 pure $ decodeBase58 bitcoinAlphabet $ encodeUtf8 pvSeed aesKey <- either invalidMnemonic pure $ deriveAesKeyBS <$> toSeed pvBackupPhrase seedDecBs <- either decryptionFailed pure $ aesDecrypt seedEncBs aesKey - redeemAdaInternal submitTx passphrase pvWalletId seedDecBs + redeemAdaInternal pm submitTx passphrase pvWalletId seedDecBs where invalidBase58 = throwM . RequestError $ "Seed is invalid base58 string: " <> pvSeed @@ -71,12 +72,13 @@ redeemAdaPaperVend submitTx passphrase CPaperVendWalletRedeem {..} = do redeemAdaInternal :: MonadWalletTxFull ctx m - => (TxAux -> m Bool) + => ProtocolMagic + -> (TxAux -> m Bool) -> PassPhrase -> CAccountId -> ByteString -> m CTx -redeemAdaInternal submitTx passphrase cAccId seedBs = do +redeemAdaInternal pm submitTx passphrase cAccId seedBs = do (_, redeemSK) <- maybeThrow (RequestError "Seed is not 32-byte long") $ redeemDeterministicKeyGen seedBs accId <- decodeCTypeOrFail cAccId @@ -89,7 +91,7 @@ redeemAdaInternal submitTx passphrase cAccId seedBs = do ws <- getWalletSnapshot db th <- rewrapTxError "Cannot send redemption transaction" $ do (txAux, redeemAddress, redeemBalance) <- - prepareRedemptionTx redeemSK dstAddr + prepareRedemptionTx pm redeemSK dstAddr ts <- Just <$> getCurrentTimestamp let tx = taTx txAux @@ -99,7 +101,7 @@ redeemAdaInternal submitTx passphrase cAccId seedBs = do dstWallet = aiWId accId ptx <- mkPendingTx ws dstWallet txHash txAux th - th <$ submitAndSaveNewPtx db submitTx ptx + th <$ submitAndSaveNewPtx pm db submitTx ptx -- add redemption transaction to the history of new wallet let cWalId = aiWId accId diff --git a/wallet/src/Pos/Wallet/Web/Methods/Reporting.hs b/wallet/src/Pos/Wallet/Web/Methods/Reporting.hs index 1150f328dc6..1b122010d59 100644 --- a/wallet/src/Pos/Wallet/Web/Methods/Reporting.hs +++ b/wallet/src/Pos/Wallet/Web/Methods/Reporting.hs @@ -8,12 +8,12 @@ module Pos.Wallet.Web.Methods.Reporting import Universum -import Pos.Reporting.Methods (MonadReporting, reportInfo) +import Pos.Infra.Reporting.Methods (MonadReporting, reportInfo) import Pos.Wallet.Web.ClientTypes (CInitialized) import Servant.API.ContentTypes (NoContent (..)) -- REPORT:INFO Time to initialize Daedalus info (from start to main screen, from start to network connection established) -reportingInitialized :: MonadReporting ctx m => CInitialized -> m NoContent +reportingInitialized :: (Monad m, MonadReporting m) => CInitialized -> m NoContent reportingInitialized cinit = do - reportInfo False (show cinit) + reportInfo (show cinit) return NoContent diff --git a/wallet/src/Pos/Wallet/Web/Methods/Restore.hs b/wallet/src/Pos/Wallet/Web/Methods/Restore.hs index 88eb7437b08..d7362299a4c 100644 --- a/wallet/src/Pos/Wallet/Web/Methods/Restore.hs +++ b/wallet/src/Pos/Wallet/Web/Methods/Restore.hs @@ -27,7 +27,7 @@ import Pos.Client.KeyStorage (addSecretKey) import Pos.Core.Configuration (genesisSecretsPoor) import Pos.Core.Genesis (poorSecretToEncKey) import Pos.Crypto (EncryptedSecretKey, PassPhrase, emptyPassphrase, firstHardened) -import Pos.StateLock (Priority (..), withStateLockNoMetrics) +import Pos.Infra.StateLock (Priority (..), withStateLockNoMetrics) import Pos.Util (HasLens (..), maybeThrow) import Pos.Util.UserSecret (UserSecretDecodingError (..), WalletUserSecret (..), mkGenesisWalletUserSecret, readUserSecret, usWallet, diff --git a/wallet/src/Pos/Wallet/Web/Methods/Txp.hs b/wallet/src/Pos/Wallet/Web/Methods/Txp.hs index 6cd4dc06b02..da5841e5333 100644 --- a/wallet/src/Pos/Wallet/Web/Methods/Txp.hs +++ b/wallet/src/Pos/Wallet/Web/Methods/Txp.hs @@ -22,10 +22,10 @@ import Pos.Client.KeyStorage (MonadKeys) import Pos.Client.Txp.Addresses (MonadAddresses (..)) import Pos.Client.Txp.Util (InputSelectionPolicy (..), PendingAddresses (..), isCheckedTxError) +import Pos.Core.Chrono (getNewestFirst, toNewestFirst) import Pos.Core.Common (Coin) import Pos.Core.Txp (Tx (..), TxAux (..), TxOut (..), TxOutAux (..)) -import Pos.Crypto (PassPhrase, hash) -import Pos.Util.Chrono (getNewestFirst, toNewestFirst) +import Pos.Crypto (PassPhrase, ProtocolMagic, hash) import Pos.Util.Servant (encodeCType) import Pos.Wallet.Web.ClientTypes (AccountId, Addr, CId) import Pos.Wallet.Web.Error (WalletError (..), rewrapToWalletError) @@ -71,11 +71,13 @@ coinDistrToOutputs distr = do -- by the time of resubmission. submitAndSaveNewPtx :: TxSubmissionMode ctx m - => WalletDB + => ProtocolMagic + -> WalletDB -> (TxAux -> m Bool) -> PendingTx -> m () -submitAndSaveNewPtx db submit = submitAndSavePtx db submit ptxFirstSubmissionHandler +submitAndSaveNewPtx pm db submit = + submitAndSavePtx pm db submit ptxFirstSubmissionHandler gatherPendingTxsSummary :: MonadWalletWebMode ctx m => m [PendingTxsSummary] gatherPendingTxsSummary = diff --git a/wallet/src/Pos/Wallet/Web/Mode.hs b/wallet/src/Pos/Wallet/Web/Mode.hs index 61bac6f8afe..31fa6d9f55d 100644 --- a/wallet/src/Pos/Wallet/Web/Mode.hs +++ b/wallet/src/Pos/Wallet/Web/Mode.hs @@ -11,6 +11,7 @@ module Pos.Wallet.Web.Mode , MonadFullWalletWebMode , walletWebModeToRealMode + , realModeToWalletWebMode , getBalanceDefault , getOwnUtxosDefault @@ -39,7 +40,6 @@ import Pos.Client.Txp.Addresses (MonadAddresses (..)) import Pos.Client.Txp.Balances (MonadBalances (..)) import Pos.Client.Txp.History (MonadTxHistory (..), getBlockHistoryDefault, getLocalHistoryDefault, saveTxDefault) -import Pos.Communication.Limits (HasAdoptedBlockVersionData (..)) import Pos.Context (HasNodeContext (..)) import Pos.Core (Address, Coin, HasConfiguration, HasPrimaryKey (..), isRedeemAddress, largestHDAddressBoot, mkCoin) @@ -51,33 +51,33 @@ import Pos.DB.Class (MonadDB (..), MonadDBRead (..)) import Pos.DB.DB (gsAdoptedBVDataDefault) import Pos.DB.Rocks (dbDeleteDefault, dbGetDefault, dbIterSourceDefault, dbPutDefault, dbWriteBatchDefault) -import Pos.KnownPeers (MonadFormatPeers (..)) +import Pos.Infra.Network.Types (HasNodeType (..)) +import Pos.Infra.Recovery.Info (MonadRecoveryInfo) +import Pos.Infra.Reporting (MonadReporting (..), + HasMisbehaviorMetrics (..), + Reporter (..)) +import Pos.Infra.Shutdown (HasShutdownContext (..)) +import Pos.Infra.Slotting.Class (MonadSlots (..)) +import Pos.Infra.Slotting.Impl (currentTimeSlottingSimple, + getCurrentSlotBlockingSimple, + getCurrentSlotInaccurateSimple, + getCurrentSlotSimple) +import Pos.Infra.Slotting.MemState (HasSlottingVar (..), MonadSlotsData) +import Pos.Infra.StateLock (StateLock) +import Pos.Infra.Util.JsonLog.Events (HasJsonLogConfig (..), + jsonLogDefault) +import Pos.Infra.Util.TimeWarp (CanJsonLog (..)) import Pos.Launcher (HasConfigurations) -import Pos.Network.Types (HasNodeType (..)) import Pos.Recovery () -import Pos.Recovery.Info (MonadRecoveryInfo) -import Pos.Reporting (HasReportingContext (..), MonadReporting) -import Pos.Shutdown (HasShutdownContext (..)) -import Pos.Slotting.Class (MonadSlots (..)) -import Pos.Slotting.Impl (currentTimeSlottingSimple, - getCurrentSlotBlockingSimple, - getCurrentSlotInaccurateSimple, - getCurrentSlotSimple) -import Pos.Slotting.MemState (HasSlottingVar (..), MonadSlotsData) -import Pos.Ssc (HasSscConfiguration) import Pos.Ssc.Types (HasSscContext (..)) -import Pos.StateLock (StateLock) import Pos.Txp (HasTxpConfiguration, MempoolExt, MonadTxpLocal (..), MonadTxpMem, Utxo, addrBelongsToSet, applyUtxoModToAddrCoinMap, getUtxoModifier, withTxpLocalData) import qualified Pos.Txp.DB as DB import Pos.Util (postfixLFields) -import Pos.Util.CompileInfo (HasCompileInfo) -import Pos.Util.JsonLog (HasJsonLogConfig (..), jsonLogDefault) import Pos.Util.LoggerName (HasLoggerName' (..), askLoggerNameDefault, modifyLoggerNameDefault) import qualified Pos.Util.Modifier as MM -import Pos.Util.TimeWarp (CanJsonLog (..)) import Pos.Util.UserSecret (HasUserSecret (..)) import Pos.Util.Util (HasLens (..)) import Pos.WorkMode (MinWorkMode, RealMode, RealModeContext (..)) @@ -118,6 +118,13 @@ walletWebModeToRealMode ws cv syncRequests act = do rmc <- ask lift $ runReaderT act (WalletWebModeContext ws cv syncRequests rmc) +realModeToWalletWebMode + :: RealMode WalletMempoolExt t + -> WalletWebMode t +realModeToWalletWebMode rm = Mtl.ask >>= \ctx -> + let rmc = wwmcRealModeContext ctx + in lift (Mtl.runReaderT rm rmc) + makeLensesWith postfixLFields ''WalletWebModeContext instance HasLens SyncQueue WalletWebModeContext SyncQueue where @@ -129,8 +136,14 @@ instance HasSscContext WalletWebModeContext where instance HasPrimaryKey WalletWebModeContext where primaryKey = wwmcRealModeContext_L . primaryKey -instance HasReportingContext WalletWebModeContext where - reportingContext = wwmcRealModeContext_L . reportingContext +-- FIXME alter it so that we never send logs for info-level reports, as I +-- think that's how it was prior. +instance MonadReporting WalletWebMode where + report rt = Mtl.ask >>= \ctx -> + liftIO (runReporter (rmcReporter (wwmcRealModeContext ctx)) rt) + +instance HasMisbehaviorMetrics WalletWebModeContext where + misbehaviorMetrics = wwmcRealModeContext_L . misbehaviorMetrics instance HasUserSecret WalletWebModeContext where userSecret = wwmcRealModeContext_L . userSecret @@ -193,10 +206,8 @@ type MonadWalletWebMode ctx m = , MonadRecoveryInfo m , MonadBListener m , MonadReader ctx m - , MonadFormatPeers m , HasLens StateLock ctx StateLock , HasNodeType ctx - , HasReportingContext ctx , HasShutdownContext ctx , AccountMode ctx m , MonadBlockchainInfo m @@ -213,7 +224,7 @@ type MonadWalletWebMode ctx m = type MonadFullWalletWebMode ctx m = ( MonadWalletWebMode ctx m , MonadWalletWebSockets ctx m - , MonadReporting ctx m + , MonadReporting m , Mockable LowLevelAsync m , HasLens SyncQueue ctx SyncQueue ) @@ -252,10 +263,7 @@ instance HasConfiguration => MonadDB WalletWebMode where instance HasConfiguration => MonadGState WalletWebMode where gsAdoptedBVData = gsAdoptedBVDataDefault -instance HasConfiguration => HasAdoptedBlockVersionData WalletWebMode where - adoptedBVData = gsAdoptedBVData - -instance (HasConfiguration, HasCompileInfo) +instance (HasConfiguration) => MonadBListener WalletWebMode where onApplyBlocks = onApplyBlocksWebWallet onRollbackBlocks = onRollbackBlocksWebWallet @@ -264,7 +272,7 @@ instance MonadUpdates WalletWebMode where waitForUpdate = waitForUpdateWebWallet applyLastUpdate = applyLastUpdateWebWallet -instance (HasConfiguration, HasSscConfiguration) => +instance (HasConfiguration) => MonadBlockchainInfo WalletWebMode where networkChainDifficulty = networkChainDifficultyWebWallet localChainDifficulty = localChainDifficultyWebWallet @@ -312,19 +320,15 @@ instance HasConfiguration => MonadBalances WalletWebMode where getOwnUtxos = getOwnUtxosDefault getBalance = getBalanceDefault -instance (HasConfiguration, HasSscConfiguration, HasTxpConfiguration, HasCompileInfo) +instance (HasConfiguration, HasTxpConfiguration) => MonadTxHistory WalletWebMode where getBlockHistory = getBlockHistoryDefault getLocalHistory = getLocalHistoryDefault saveTx = saveTxDefault -instance MonadFormatPeers WalletWebMode where - -- Use the RealMode instance (ReaderT RealModeContext Production) - formatKnownPeers formatter = Mtl.withReaderT wwmcRealModeContext (formatKnownPeers formatter) - type instance MempoolExt WalletWebMode = WalletMempoolExt -instance (HasConfiguration, HasTxpConfiguration, HasCompileInfo) => +instance (HasConfiguration, HasTxpConfiguration) => MonadTxpLocal WalletWebMode where txpNormalize = txpNormalizeWebWallet txpProcessTx = txpProcessTxWebWallet @@ -343,7 +347,7 @@ getNewAddressWebWallet (accId, passphrase) = do cAddrMeta <- newAddress_ ws RandomSeed passphrase accId return $ cAddrMeta ^. wamAddress -instance (HasConfigurations, HasCompileInfo) +instance (HasConfigurations) => MonadAddresses Pos.Wallet.Web.Mode.WalletWebMode where type AddrData Pos.Wallet.Web.Mode.WalletWebMode = (AccountId, PassPhrase) -- We rely on the fact that Daedalus always uses HD addresses with diff --git a/wallet/src/Pos/Wallet/Web/Pending.hs b/wallet/src/Pos/Wallet/Web/Pending.hs index 287d4bb5dcf..9cfee575827 100644 --- a/wallet/src/Pos/Wallet/Web/Pending.hs +++ b/wallet/src/Pos/Wallet/Web/Pending.hs @@ -1,3 +1,15 @@ -- | Pending transactions. -{-# OPTIONS_GHC -F -pgmF autoexporter #-} +module Pos.Wallet.Web.Pending + ( module Pos.Wallet.Web.Pending.Functions + , module Pos.Wallet.Web.Pending.Submission + , module Pos.Wallet.Web.Pending.Types + , module Pos.Wallet.Web.Pending.Util + , module Pos.Wallet.Web.Pending.Worker + ) where + +import Pos.Wallet.Web.Pending.Functions +import Pos.Wallet.Web.Pending.Submission +import Pos.Wallet.Web.Pending.Types +import Pos.Wallet.Web.Pending.Util +import Pos.Wallet.Web.Pending.Worker diff --git a/wallet/src/Pos/Wallet/Web/Pending/Functions.hs b/wallet/src/Pos/Wallet/Web/Pending/Functions.hs index a87b4af2c05..0648fa956cd 100644 --- a/wallet/src/Pos/Wallet/Web/Pending/Functions.hs +++ b/wallet/src/Pos/Wallet/Web/Pending/Functions.hs @@ -16,10 +16,10 @@ import Universum import Formatting (build, sformat, (%)) -import Pos.Core (HasConfiguration) +import Pos.Core (HasConfiguration, protocolConstants) import Pos.Client.Txp.History (SaveTxException (..), TxHistoryEntry) import Pos.Core.Txp (TxAux (..), TxId) -import Pos.Slotting.Class (MonadSlots (..)) +import Pos.Infra.Slotting.Class (MonadSlots (..)) import Pos.Txp (ToilVerFailure (..)) import Pos.Util.Util (maybeThrow) import Pos.Wallet.Web.ClientTypes (CId, Wal) @@ -44,7 +44,7 @@ isPtxInBlocks :: PtxCondition -> Bool isPtxInBlocks = isNothing . ptxPoolInfo mkPendingTx - :: (HasConfiguration, MonadThrow m, MonadIO m, MonadSlots ctx m) + :: (HasConfiguration, MonadThrow m, MonadSlots ctx m) => WalletSnapshot -> CId Wal -> TxId -> TxAux -> TxHistoryEntry -> m PendingTx mkPendingTx ws wid _ptxTxId _ptxTxAux th = do @@ -55,7 +55,7 @@ mkPendingTx ws wid _ptxTxId _ptxTxAux th = do { _ptxCond = PtxCreating th , _ptxWallet = wid , _ptxPeerAck = False - , _ptxSubmitTiming = mkPtxSubmitTiming _ptxCreationSlot + , _ptxSubmitTiming = mkPtxSubmitTiming protocolConstants _ptxCreationSlot , .. } where @@ -85,6 +85,7 @@ isReclaimableFailure (SaveTxToilFailure tvf) = case tvf of ToilUnknownAttributes{} -> False ToilNonBootstrapDistr{} -> False ToilRepeatedInput{} -> False + ToilEmptyAfterFilter -> False usingPtxCoords :: (CId Wal -> TxId -> a) -> PendingTx -> a usingPtxCoords f PendingTx{..} = f _ptxWallet _ptxTxId diff --git a/wallet/src/Pos/Wallet/Web/Pending/Submission.hs b/wallet/src/Pos/Wallet/Web/Pending/Submission.hs index 5d1f5bd40cd..e294e55fa37 100644 --- a/wallet/src/Pos/Wallet/Web/Pending/Submission.hs +++ b/wallet/src/Pos/Wallet/Web/Pending/Submission.hs @@ -16,16 +16,17 @@ module Pos.Wallet.Web.Pending.Submission import Universum import Control.Exception.Safe (Handler (..), catches, onException) +import Data.Time.Units (fromMicroseconds) import Formatting (build, sformat, shown, stext, (%)) -import Serokell.Util (hour) import System.Wlog (WithLogger, logDebug, logInfo) import Pos.Client.Txp.History (saveTx, thTimestamp) import Pos.Client.Txp.Network (TxMode) import Pos.Configuration (walletTxCreationDisabled) -import Pos.Core (HasConfiguration, diffTimestamp, getCurrentTimestamp) +import Pos.Core (diffTimestamp, getCurrentTimestamp) import Pos.Core.Txp (TxAux) -import Pos.Util.LogSafe (buildSafe, logInfoSP, logWarningSP, secretOnlyF) +import Pos.Crypto (ProtocolMagic) +import Pos.Infra.Util.LogSafe (buildSafe, logInfoSP, logWarningSP, secretOnlyF) import Pos.Util.Util (maybeThrow) import Pos.Wallet.Web.Error (WalletError (InternalError)) import Pos.Wallet.Web.Pending.Functions (isReclaimableFailure, ptxPoolInfo, @@ -50,7 +51,7 @@ data PtxSubmissionHandlers m = PtxSubmissionHandlers } ptxFirstSubmissionHandler - :: (MonadThrow m, WithLogger m) + :: (MonadThrow m) => PtxSubmissionHandlers m ptxFirstSubmissionHandler = PtxSubmissionHandlers @@ -59,7 +60,7 @@ ptxFirstSubmissionHandler = } ptxResubmissionHandler - :: forall m. (HasConfiguration, MonadIO m, MonadThrow m, WithLogger m) + :: forall m. (MonadIO m, MonadThrow m, WithLogger m) => WalletDB -> PendingTx -> PtxSubmissionHandlers m @@ -77,7 +78,7 @@ ptxResubmissionHandler db PendingTx{..} = } where cancelPtx - :: (Exception e, Buildable e) + :: (Buildable e) => PtxPoolInfo -> e -> m () cancelPtx poolInfo e = do let newCond = PtxWontApply (sformat build e) poolInfo @@ -105,12 +106,13 @@ type TxSubmissionMode ctx m = ( TxMode m ) -- but treats tx as future /pending/ transaction. submitAndSavePtx :: TxSubmissionMode ctx m - => WalletDB + => ProtocolMagic + -> WalletDB -> (TxAux -> m Bool) -> PtxSubmissionHandlers m -> PendingTx -> m () -submitAndSavePtx db submitTx PtxSubmissionHandlers{..} ptx@PendingTx{..} = do +submitAndSavePtx pm db submitTx PtxSubmissionHandlers{..} ptx@PendingTx{..} = do -- this should've been checked before, but just in case when walletTxCreationDisabled $ throwM $ InternalError "Transaction creation is disabled by configuration!" @@ -118,7 +120,8 @@ submitAndSavePtx db submitTx PtxSubmissionHandlers{..} ptx@PendingTx{..} = do now <- getCurrentTimestamp if | PtxApplying poolInfo <- _ptxCond, Just creationTime <- poolInfo ^. thTimestamp, - diffTimestamp now creationTime > hour 1 -> do + -- 1 hour, 3600 seconds + diffTimestamp now creationTime > fromMicroseconds 3600000000 -> do let newCond = PtxWontApply "1h limit exceeded" poolInfo void $ casPtxCondition db _ptxWallet _ptxTxId _ptxCond newCond logInfo $ @@ -127,7 +130,7 @@ submitAndSavePtx db submitTx PtxSubmissionHandlers{..} ptx@PendingTx{..} = do _ptxTxId | otherwise -> do addOnlyNewPendingTx db ptx - (saveTx (_ptxTxId, _ptxTxAux) + (saveTx pm (_ptxTxId, _ptxTxAux) `catches` handlers) `onException` creationFailedHandler ack <- submitTx _ptxTxAux diff --git a/wallet/src/Pos/Wallet/Web/Pending/Types.hs b/wallet/src/Pos/Wallet/Web/Pending/Types.hs index b561f1cc28f..baa88ef770c 100644 --- a/wallet/src/Pos/Wallet/Web/Pending/Types.hs +++ b/wallet/src/Pos/Wallet/Web/Pending/Types.hs @@ -37,7 +37,8 @@ import Pos.Client.Txp.History (TxHistoryEntry) import Pos.Core.Common (ChainDifficulty) import Pos.Core.Slotting (FlatSlotId, SlotId) import Pos.Core.Txp (TxAux, TxId) -import Pos.Util.LogSafe (LogSecurityLevel, SecureLog, getSecureLog, secure, unsecure) +import Pos.Infra.Util.LogSafe (LogSecurityLevel, SecureLog, + getSecureLog, secure, unsecure) import Pos.Wallet.Web.ClientTypes.Types (CId, Wal) -- | Required information about block where given pending transaction is sited @@ -91,6 +92,14 @@ data PtxCondition -- backward-compatibility) deriving (Eq, Ord, Show) +instance NFData PtxCondition where + rnf x = case x of + PtxApplying n -> rnf n + PtxInNewestBlocks n -> rnf n + PtxPersisted -> () + PtxWontApply n m -> n `deepseq` m `deepseq` () + PtxCreating n -> rnf n + makePrisms ''PtxCondition buildPtxCondition :: LogSecurityLevel -> PtxCondition -> Builder @@ -117,6 +126,11 @@ data PtxSubmitTiming = PtxSubmitTiming , _pstNextDelay :: FlatSlotId } deriving (Eq, Show) +instance NFData PtxSubmitTiming where + rnf pt = _pstNextSlot pt + `deepseq` _pstNextDelay pt + `deepseq` () + makeLenses ''PtxSubmitTiming -- | All info kept about pending transaction @@ -131,6 +145,16 @@ data PendingTx = PendingTx , _ptxSubmitTiming :: !PtxSubmitTiming } deriving (Eq, Show) +instance NFData PendingTx where + rnf pt = _ptxTxId pt + `deepseq` _ptxTxAux pt + `deepseq` _ptxCreationSlot pt + `deepseq` _ptxCond pt + `deepseq` _ptxWallet pt + `deepseq` _ptxPeerAck pt + `deepseq` _ptxSubmitTiming pt + `deepseq` () + makeLenses ''PendingTx ptxNextSubmitSlot :: Lens' PendingTx SlotId diff --git a/wallet/src/Pos/Wallet/Web/Pending/Util.hs b/wallet/src/Pos/Wallet/Web/Pending/Util.hs index 2da0bb17c4f..480326f3a44 100644 --- a/wallet/src/Pos/Wallet/Web/Pending/Util.hs +++ b/wallet/src/Pos/Wallet/Web/Pending/Util.hs @@ -15,20 +15,21 @@ import Universum import Control.Lens ((*=), (+=), (+~), (<<*=), (<<.=)) import qualified Data.Set as Set +import Data.Reflection (give) import Pos.Client.Txp.Util (PendingAddresses (..)) import Pos.Core.Common (Address) -import Pos.Core.Configuration (HasConfiguration) +import Pos.Core (ProtocolConstants(..)) import Pos.Core.Slotting (FlatSlotId, SlotId, flatSlotId) import Pos.Crypto (WithHash (..)) import Pos.Txp (Tx (..), TxAux (..), TxOut (..), topsortTxs) -import Pos.Util.Chrono (OldestFirst (..)) +import Pos.Core.Chrono (OldestFirst (..)) import Pos.Wallet.Web.Pending.Types (PendingTx (..), PtxCondition (..), PtxCondition (..), PtxSubmitTiming (..), pstNextDelay, pstNextSlot, ptxPeerAck, ptxSubmitTiming) -mkPtxSubmitTiming :: HasConfiguration => SlotId -> PtxSubmitTiming -mkPtxSubmitTiming creationSlot = +mkPtxSubmitTiming :: ProtocolConstants -> SlotId -> PtxSubmitTiming +mkPtxSubmitTiming pc creationSlot = give pc $ PtxSubmitTiming { _pstNextSlot = creationSlot & flatSlotId +~ initialSubmitDelay , _pstNextDelay = 1 @@ -44,9 +45,10 @@ sortPtxsChrono = OldestFirst . sortWith _ptxCreationSlot . tryTopsort wHash PendingTx{..} = WithHash (taTx _ptxTxAux) _ptxTxId incPtxSubmitTimingPure - :: HasConfiguration - => PtxSubmitTiming -> PtxSubmitTiming -incPtxSubmitTimingPure = execState $ do + :: ProtocolConstants + -> PtxSubmitTiming + -> PtxSubmitTiming +incPtxSubmitTimingPure pc = give pc $ execState $ do curDelay <- pstNextDelay <<*= 2 pstNextSlot . flatSlotId += curDelay @@ -56,7 +58,7 @@ ptxMarkAcknowledgedPure = execState $ do unless wasAcked $ ptxSubmitTiming . pstNextDelay *= 8 -- | If given pending transaction is not yet confirmed, cancels it. -cancelApplyingPtx :: HasConfiguration => PendingTx -> PendingTx +cancelApplyingPtx :: () => PendingTx -> PendingTx cancelApplyingPtx ptx@PendingTx{..} | PtxApplying poolInfo <- _ptxCond = ptx { _ptxCond = PtxWontApply reason poolInfo @@ -71,11 +73,11 @@ cancelApplyingPtx ptx@PendingTx{..} -- again. -- -- Has no effect for transactions in other conditions. -resetFailedPtx :: HasConfiguration => SlotId -> PendingTx -> PendingTx -resetFailedPtx curSlot ptx@PendingTx{..} +resetFailedPtx :: ProtocolConstants -> SlotId -> PendingTx -> PendingTx +resetFailedPtx pc curSlot ptx@PendingTx{..} | PtxWontApply _ poolInfo <- _ptxCond = ptx { _ptxCond = PtxApplying poolInfo - , _ptxSubmitTiming = mkPtxSubmitTiming curSlot + , _ptxSubmitTiming = mkPtxSubmitTiming pc curSlot } | otherwise = ptx diff --git a/wallet/src/Pos/Wallet/Web/Pending/Worker.hs b/wallet/src/Pos/Wallet/Web/Pending/Worker.hs index 84bbf4dd935..b99060cd109 100644 --- a/wallet/src/Pos/Wallet/Web/Pending/Worker.hs +++ b/wallet/src/Pos/Wallet/Web/Pending/Worker.hs @@ -22,16 +22,17 @@ import Pos.Client.Txp.Network (TxMode) import Pos.Configuration (HasNodeConfiguration, pendingTxResubmitionPeriod, walletTxCreationDisabled) import Pos.Core (ChainDifficulty (..), SlotId (..), TxAux, difficultyL) +import Pos.Core.Chrono (getOldestFirst) import Pos.Core.Configuration (HasConfiguration) +import Pos.Crypto (ProtocolMagic) import qualified Pos.DB.BlockIndex as DB import Pos.DB.Class (MonadDBRead) -import Pos.Recovery.Info (MonadRecoveryInfo) -import Pos.Reporting (MonadReporting) -import Pos.Shutdown (HasShutdownContext) -import Pos.Slotting (MonadSlots, OnNewSlotParams (..), defaultOnNewSlotParams, - getNextEpochSlotDuration, onNewSlot) -import Pos.Util.Chrono (getOldestFirst) -import Pos.Util.LogSafe (logInfoSP, secretOnlyF, secureListF) +import Pos.Infra.Recovery.Info (MonadRecoveryInfo) +import Pos.Infra.Reporting (MonadReporting) +import Pos.Infra.Shutdown (HasShutdownContext) +import Pos.Infra.Slotting (MonadSlots, OnNewSlotParams (..), defaultOnNewSlotParams, + getNextEpochSlotDuration, onNewSlot) +import Pos.Infra.Util.LogSafe (logInfoSP, secretOnlyF, secureListF) import Pos.Wallet.Web.Pending.Functions (usingPtxCoords) import Pos.Wallet.Web.Pending.Submission (ptxResubmissionHandler, submitAndSavePtx) import Pos.Wallet.Web.Pending.Types (PendingTx (..), PtxCondition (..), ptxNextSubmitSlot, @@ -47,7 +48,7 @@ type MonadPendings ctx m = , MonadAddresses m , MonadDBRead m , MonadRecoveryInfo m - , MonadReporting ctx m + , MonadReporting m , HasShutdownContext ctx , MonadSlots ctx m , HasConfiguration @@ -69,15 +70,16 @@ processPtxInNewestBlocks db PendingTx{..} = do ptxDiff + depth <= tipDiff resubmitTx :: MonadPendings ctx m - => WalletDB + => ProtocolMagic + -> WalletDB -> (TxAux -> m Bool) -> PendingTx -> m () -resubmitTx db submitTx ptx = +resubmitTx pm db submitTx ptx = handleAny (\_ -> pass) $ do logInfoSP $ \sl -> sformat ("Resubmitting tx "%secretOnlyF sl build) (_ptxTxId ptx) let submissionH = ptxResubmissionHandler db ptx - submitAndSavePtx db submitTx submissionH ptx + submitAndSavePtx pm db submitTx submissionH ptx updateTiming where reportNextCheckTime time = @@ -94,15 +96,16 @@ resubmitTx db submitTx ptx = -- | Distributes pending txs submition over current slot ~evenly resubmitPtxsDuringSlot :: MonadPendings ctx m - => WalletDB + => ProtocolMagic + -> WalletDB -> (TxAux -> m Bool) -> [PendingTx] -> m () -resubmitPtxsDuringSlot db submitTx ptxs = do +resubmitPtxsDuringSlot pm db submitTx ptxs = do interval <- evalSubmitDelay (length ptxs) void . forConcurrently (enumerate ptxs) $ \(i, ptx) -> do delay (interval * i) - resubmitTx db submitTx ptx + resubmitTx pm db submitTx ptx where submitionEta = 5 :: Second evalSubmitDelay toResubmitNum = do @@ -113,12 +116,13 @@ resubmitPtxsDuringSlot db submitTx ptxs = do processPtxsToResubmit :: MonadPendings ctx m - => WalletDB + => ProtocolMagic + -> WalletDB -> (TxAux -> m Bool) -> SlotId -> [PendingTx] -> m () -processPtxsToResubmit db submitTx _curSlot ptxs = do +processPtxsToResubmit pm db submitTx _curSlot ptxs = do ptxsPerSlotLimit <- evalPtxsPerSlotLimit let toResubmit = take (min 1 ptxsPerSlotLimit) $ -- for now the limit will be 1, @@ -131,7 +135,7 @@ processPtxsToResubmit db submitTx _curSlot ptxs = do logInfoSP $ \sl -> sformat (fmt sl) (map _ptxTxId toResubmit) when (null toResubmit) $ logDebug "There are no transactions to resubmit" - resubmitPtxsDuringSlot db submitTx toResubmit + resubmitPtxsDuringSlot pm db submitTx toResubmit where fmt sl = "Transactions to resubmit on current slot: "%secureListF sl listJson evalPtxsPerSlotLimit = do @@ -147,38 +151,41 @@ processPtxsToResubmit db submitTx _curSlot ptxs = do -- if needed. processPtxs :: MonadPendings ctx m - => WalletDB + => ProtocolMagic + -> WalletDB -> (TxAux -> m Bool) -> SlotId -> [PendingTx] -> m () -processPtxs db submitTx curSlot ptxs = do +processPtxs pm db submitTx curSlot ptxs = do mapM_ (processPtxInNewestBlocks db) ptxs if walletTxCreationDisabled then logDebug "Transaction resubmission is disabled" - else processPtxsToResubmit db submitTx curSlot ptxs + else processPtxsToResubmit pm db submitTx curSlot ptxs processPtxsOnSlot :: MonadPendings ctx m - => WalletDB + => ProtocolMagic + -> WalletDB -> (TxAux -> m Bool) -> SlotId -> m () -processPtxsOnSlot db submitTx curSlot = do +processPtxsOnSlot pm db submitTx curSlot = do ws <- getWalletSnapshot db let ptxs = getPendingTxs ws let sortedPtxs = getOldestFirst $ sortPtxsChrono ptxs - processPtxs db submitTx curSlot sortedPtxs + processPtxs pm db submitTx curSlot sortedPtxs -- | On each slot this takes several pending transactions and resubmits them if -- needed and possible. startPendingTxsResubmitter :: MonadPendings ctx m - => WalletDB + => ProtocolMagic + -> WalletDB -> (TxAux -> m Bool) -> m () -startPendingTxsResubmitter db submitTx = - setLogger $ onNewSlot onsp (processPtxsOnSlot db submitTx) +startPendingTxsResubmitter pm db submitTx = + setLogger $ onNewSlot onsp (processPtxsOnSlot pm db submitTx) where setLogger = modifyLoggerName (<> "tx" <> "resubmitter") onsp :: OnNewSlotParams diff --git a/wallet/src/Pos/Wallet/Web/Server.hs b/wallet/src/Pos/Wallet/Web/Server.hs index f2ab681ebbc..15bdf9bfa4b 100644 --- a/wallet/src/Pos/Wallet/Web/Server.hs +++ b/wallet/src/Pos/Wallet/Web/Server.hs @@ -1,2 +1,11 @@ -- Pos.Wallet.Web.Server -{-# OPTIONS_GHC -F -pgmF autoexporter #-} + +module Pos.Wallet.Web.Server + ( module Pos.Wallet.Web.Server.Handlers + , module Pos.Wallet.Web.Server.Launcher + , module Pos.Wallet.Web.Server.Runner + ) where + +import Pos.Wallet.Web.Server.Handlers +import Pos.Wallet.Web.Server.Launcher +import Pos.Wallet.Web.Server.Runner diff --git a/wallet/src/Pos/Wallet/Web/Server/Handlers.hs b/wallet/src/Pos/Wallet/Web/Server/Handlers.hs index cc6d8a9e0be..ad1b832e56d 100644 --- a/wallet/src/Pos/Wallet/Web/Server/Handlers.hs +++ b/wallet/src/Pos/Wallet/Web/Server/Handlers.hs @@ -18,7 +18,9 @@ import Servant.Server (Handler, Server, ServerT, hoistServer) import Servant.Swagger.UI (swaggerSchemaUIServer) import Pos.Core.Txp (TxAux) +import Pos.Crypto (ProtocolMagic) import Pos.Update.Configuration (curSoftwareVersion) +import Pos.Util.CompileInfo (HasCompileInfo) import Pos.Wallet.WalletMode (blockchainSlotDuration) import Pos.Wallet.Web.Account (GenSeed (RandomSeed)) @@ -31,13 +33,16 @@ import Pos.Wallet.Web.Mode (MonadFullWalletWebMode) ---------------------------------------------------------------------------- servantHandlersWithSwagger - :: MonadFullWalletWebMode ctx m - => TVar NtpStatus + :: ( MonadFullWalletWebMode ctx m + , HasCompileInfo + ) + => ProtocolMagic + -> TVar NtpStatus -> (TxAux -> m Bool) -> (forall x. m x -> Handler x) -> Server A.WalletSwaggerApi -servantHandlersWithSwagger ntpStatus submitTx nat = - hoistServer A.walletApi nat (servantHandlers ntpStatus submitTx) +servantHandlersWithSwagger pm ntpStatus submitTx nat = + hoistServer A.walletApi nat (servantHandlers pm ntpStatus submitTx) :<|> swaggerSchemaUIServer swaggerSpecForWalletApi @@ -45,16 +50,23 @@ servantHandlersWithSwagger ntpStatus submitTx nat = -- The wallet API ---------------------------------------------------------------------------- -servantHandlers :: MonadFullWalletWebMode ctx m => TVar NtpStatus -> (TxAux -> m Bool) -> ServerT A.WalletApi m -servantHandlers ntpStatus submitTx = toServant' A.WalletApiRecord +servantHandlers + :: ( MonadFullWalletWebMode ctx m + , HasCompileInfo + ) + => ProtocolMagic + -> TVar NtpStatus + -> (TxAux -> m Bool) + -> ServerT A.WalletApi m +servantHandlers pm ntpStatus submitTx = toServant' A.WalletApiRecord { _test = testHandlers , _wallets = walletsHandlers , _accounts = accountsHandlers , _addresses = addressesHandlers , _profile = profileHandlers - , _txs = txsHandlers submitTx + , _txs = txsHandlers pm submitTx , _update = updateHandlers - , _redemptions = redemptionsHandlers submitTx + , _redemptions = redemptionsHandlers pm submitTx , _reporting = reportingHandlers , _settings = settingsHandlers ntpStatus , _backup = backupHandlers @@ -103,11 +115,15 @@ profileHandlers = toServant' A.WProfileApiRecord , _updateProfile = M.updateUserProfile } -txsHandlers :: MonadFullWalletWebMode ctx m => (TxAux -> m Bool) -> ServerT A.WTxsApi m -txsHandlers submitTx = toServant' A.WTxsApiRecord - { _newPayment = M.newPayment submitTx - , _newPaymentBatch = M.newPaymentBatch submitTx - , _txFee = M.getTxFee +txsHandlers + :: MonadFullWalletWebMode ctx m + => ProtocolMagic + -> (TxAux -> m Bool) + -> ServerT A.WTxsApi m +txsHandlers pm submitTx = toServant' A.WTxsApiRecord + { _newPayment = M.newPayment pm submitTx + , _newPaymentBatch = M.newPaymentBatch pm submitTx + , _txFee = M.getTxFee pm , _resetFailedPtxs = M.resetAllFailedPtxs , _cancelApplyingPtxs = M.cancelAllApplyingPtxs , _cancelSpecificApplyingPtx = M.cancelOneApplyingPtx @@ -122,10 +138,14 @@ updateHandlers = toServant' A.WUpdateApiRecord , _applyUpdate = M.applyUpdate } -redemptionsHandlers :: MonadFullWalletWebMode ctx m => (TxAux -> m Bool) -> ServerT A.WRedemptionsApi m -redemptionsHandlers submitTx = toServant' A.WRedemptionsApiRecord - { _redeemADA = M.redeemAda submitTx - , _redeemADAPaperVend = M.redeemAdaPaperVend submitTx +redemptionsHandlers + :: MonadFullWalletWebMode ctx m + => ProtocolMagic + -> (TxAux -> m Bool) + -> ServerT A.WRedemptionsApi m +redemptionsHandlers pm submitTx = toServant' A.WRedemptionsApiRecord + { _redeemADA = M.redeemAda pm submitTx + , _redeemADAPaperVend = M.redeemAdaPaperVend pm submitTx } reportingHandlers :: MonadFullWalletWebMode ctx m => ServerT A.WReportingApi m @@ -147,7 +167,7 @@ backupHandlers = toServant' A.WBackupApiRecord , _exportBackupJSON = M.exportWalletJSON } -infoHandlers :: MonadFullWalletWebMode ctx m => ServerT A.WInfoApi m +infoHandlers :: (MonadFullWalletWebMode ctx m, HasCompileInfo) => ServerT A.WInfoApi m infoHandlers = toServant' A.WInfoApiRecord { _getClientInfo = M.getClientInfo } diff --git a/wallet/src/Pos/Wallet/Web/Server/Launcher.hs b/wallet/src/Pos/Wallet/Web/Server/Launcher.hs index 6aa8a4390ae..6407138105e 100644 --- a/wallet/src/Pos/Wallet/Web/Server/Launcher.hs +++ b/wallet/src/Pos/Wallet/Web/Server/Launcher.hs @@ -10,6 +10,7 @@ module Pos.Wallet.Web.Server.Launcher , walletServer , walletServeImpl , walletServerOuts + , walletDocumentationImpl , bracketWalletWebDB , bracketWalletWS @@ -29,12 +30,11 @@ import Ntp.Client (NtpStatus) import Pos.Client.Txp.Network (sendTxOuts) import Pos.Communication (OutSpecs) -import Pos.Core (HasConfiguration) -import Pos.Diffusion.Types (Diffusion (sendTx)) -import Pos.Launcher.Configuration (HasConfigurations) +import Pos.Crypto (ProtocolMagic) +import Pos.Infra.Diffusion.Types (Diffusion (sendTx)) +import Pos.Infra.Util.TimeWarp (NetworkAddress) import Pos.Util (bracketWithLogging) import Pos.Util.CompileInfo (HasCompileInfo) -import Pos.Util.TimeWarp (NetworkAddress) import Pos.Wallet.Web.Account (findKey, myRootAddresses) import Pos.Wallet.Web.Api (WalletSwaggerApi, swaggerWalletApi) import Pos.Wallet.Web.Mode (MonadFullWalletWebMode, MonadWalletWebMode, @@ -46,21 +46,32 @@ import Pos.Wallet.Web.State (closeState, openState) import Pos.Wallet.Web.State.Storage (WalletStorage) import Pos.Wallet.Web.Tracking (syncWallet) import Pos.Wallet.Web.Tracking.Decrypt (eskToWalletDecrCredentials) -import Pos.Web (TlsParams, serveImpl) +import Pos.Web (TlsParams, serveDocImpl, serveImpl) -- TODO [CSM-407]: Mixture of logic seems to be here walletServeImpl - :: (HasConfiguration, MonadIO m) + :: (MonadIO m) => m Application -- ^ Application getter -> NetworkAddress -- ^ IP and port to listen -> Maybe TlsParams -> Maybe Settings + -> Maybe (Word16 -> IO ()) -> m () walletServeImpl app (ip, port) = serveImpl app (BS8.unpack ip) port +walletDocumentationImpl + :: (MonadIO m) + => m Application -- ^ Application getter + -> NetworkAddress -- ^ IP and port to listen + -> Maybe TlsParams + -> Maybe Settings + -> Maybe (Word16 -> IO ()) + -> m () +walletDocumentationImpl app (ip, port) = serveDocImpl app (BS8.unpack ip) port + walletApplication - :: (HasCompileInfo, MonadWalletWebMode ctx m, MonadWalletWebSockets ctx m) + :: (MonadWalletWebMode ctx m, MonadWalletWebSockets ctx m) => m (Server WalletSwaggerApi) -> m Application walletApplication serv = do @@ -69,14 +80,15 @@ walletApplication serv = do walletServer :: forall ctx m. - ( MonadFullWalletWebMode ctx m ) - => Diffusion m + ( MonadFullWalletWebMode ctx m, HasCompileInfo ) + => ProtocolMagic + -> Diffusion m -> TVar NtpStatus -> (forall x. m x -> Handler x) -> m (Server WalletSwaggerApi) -walletServer diffusion ntpStatus nat = do +walletServer pm diffusion ntpStatus nat = do mapM_ (findKey >=> syncWallet . eskToWalletDecrCredentials) =<< myRootAddresses - return $ servantHandlersWithSwagger ntpStatus submitTx nat + return $ servantHandlersWithSwagger pm ntpStatus submitTx nat where -- Diffusion layer takes care of submitting transactions. submitTx = sendTx diffusion @@ -84,7 +96,6 @@ walletServer diffusion ntpStatus nat = do bracketWalletWebDB :: ( MonadIO m , MonadMask m - , HasConfigurations , WithLogger m ) => FilePath -- ^ Path to wallet acid-state diff --git a/wallet/src/Pos/Wallet/Web/Server/Runner.hs b/wallet/src/Pos/Wallet/Web/Server/Runner.hs index f53146e3436..094c51cf2bb 100644 --- a/wallet/src/Pos/Wallet/Web/Server/Runner.hs +++ b/wallet/src/Pos/Wallet/Web/Server/Runner.hs @@ -19,32 +19,32 @@ import Universum import qualified Control.Exception.Safe as E import Control.Monad.Except (MonadError (throwError)) import qualified Control.Monad.Reader as Mtl -import Mockable (Production, runProduction) +import Mockable (Production (..), runProduction) import Network.Wai (Application) import Ntp.Client (NtpStatus) import Servant.Server (Handler) -import System.Wlog (logInfo) +import System.Wlog (logInfo, usingLoggerName) -import Pos.Communication (ActionSpec (..), OutSpecs) -import Pos.Context (NodeContext (..)) -import Pos.Diffusion.Types (Diffusion) +import Cardano.NodeIPC (startNodeJsIPC) +import Pos.Crypto (ProtocolMagic) +import Pos.Infra.Diffusion.Types (Diffusion, hoistDiffusion) +import Pos.Infra.Shutdown.Class (HasShutdownContext (shutdownContext)) +import Pos.Infra.Util.TimeWarp (NetworkAddress) import Pos.Launcher.Configuration (HasConfigurations) import Pos.Launcher.Resource (NodeResources (..)) -import Pos.Launcher.Runner (elimRealMode, runServer) -import Pos.Reporting.Ekg (EkgNodeMetrics (..)) +import Pos.Launcher.Runner (runRealMode) import Pos.Util.CompileInfo (HasCompileInfo) -import Pos.Util.TimeWarp (NetworkAddress) import Pos.Util.Util (HasLens (..)) import Pos.Wallet.WalletMode (WalletMempoolExt) import Pos.Wallet.Web.Methods (addInitialRichAccount) import Pos.Wallet.Web.Mode (WalletWebMode, WalletWebModeContext (..), - WalletWebModeContextTag, walletWebModeToRealMode) + WalletWebModeContextTag, realModeToWalletWebMode, + walletWebModeToRealMode) import Pos.Wallet.Web.Server.Launcher (walletApplication, walletServeImpl, walletServer) import Pos.Wallet.Web.Sockets (ConnectionsVar, launchNotifier) import Pos.Wallet.Web.State (WalletDB) import Pos.Wallet.Web.Tracking.Types (SyncQueue) import Pos.Web (TlsParams) -import Pos.WorkMode (RealMode) -- | 'WalletWebMode' runner. runWRealMode @@ -52,41 +52,35 @@ runWRealMode ( HasConfigurations , HasCompileInfo ) - => WalletDB + => ProtocolMagic + -> WalletDB -> ConnectionsVar -> SyncQueue -> NodeResources WalletMempoolExt - -> (ActionSpec WalletWebMode a, OutSpecs) + -> (Diffusion WalletWebMode -> WalletWebMode a) -> Production a -runWRealMode db conn syncRequests res (action, outSpecs) = - elimRealMode res serverRealMode - where - NodeContext {..} = nrContext res - ekgNodeMetrics = EkgNodeMetrics - (nrEkgStore res) - (runProduction . elimRealMode res . walletWebModeToRealMode db conn syncRequests) - serverWalletWebMode :: WalletWebMode a - serverWalletWebMode = runServer - (runProduction . elimRealMode res . walletWebModeToRealMode db conn syncRequests) - ncNodeParams - ekgNodeMetrics - outSpecs - action - serverRealMode :: RealMode WalletMempoolExt a - serverRealMode = walletWebModeToRealMode db conn syncRequests serverWalletWebMode +runWRealMode pm db conn syncRequests res action = Production $ + runRealMode pm res $ \diffusion -> + walletWebModeToRealMode db conn syncRequests $ + action (hoistDiffusion realModeToWalletWebMode (walletWebModeToRealMode db conn syncRequests) diffusion) walletServeWebFull :: ( HasConfigurations , HasCompileInfo ) - => Diffusion WalletWebMode + => ProtocolMagic + -> Diffusion WalletWebMode -> TVar NtpStatus - -> Bool -- whether to include genesis keys + -> Bool -- ^ whether to include genesis keys -> NetworkAddress -- ^ IP and Port to listen -> Maybe TlsParams -> WalletWebMode () -walletServeWebFull diffusion ntpStatus debug address mTlsParams = - walletServeImpl action address mTlsParams Nothing +walletServeWebFull pm diffusion ntpStatus debug address mTlsParams = do + ctx <- view shutdownContext + let + portCallback :: Word16 -> IO () + portCallback port = usingLoggerName "NodeIPC" $ flip runReaderT ctx $ startNodeJsIPC port + walletServeImpl action address mTlsParams Nothing (Just portCallback) where action :: WalletWebMode Application action = do @@ -95,7 +89,7 @@ walletServeWebFull diffusion ntpStatus debug address mTlsParams = wwmc <- walletWebModeContext walletApplication $ - walletServer @WalletWebModeContext @WalletWebMode diffusion ntpStatus (convertHandler wwmc) + walletServer @WalletWebModeContext @WalletWebMode pm diffusion ntpStatus (convertHandler wwmc) walletWebModeContext :: WalletWebMode WalletWebModeContext walletWebModeContext = view (lensOf @WalletWebModeContextTag) @@ -115,7 +109,7 @@ convertHandler wwmc handler = excHandlers = [E.Handler catchServant] catchServant = throwError -notifierPlugin :: (HasConfigurations, HasCompileInfo) => WalletWebMode () +notifierPlugin :: (HasConfigurations) => WalletWebMode () notifierPlugin = do wwmc <- walletWebModeContext launchNotifier (convertHandler wwmc) diff --git a/wallet/src/Pos/Wallet/Web/Sockets.hs b/wallet/src/Pos/Wallet/Web/Sockets.hs index 6d5a075bab1..eb2fe3a33bc 100644 --- a/wallet/src/Pos/Wallet/Web/Sockets.hs +++ b/wallet/src/Pos/Wallet/Web/Sockets.hs @@ -1,3 +1,13 @@ -- | Wallet websockets notifier logic. -{-# OPTIONS_GHC -F -pgmF autoexporter #-} +module Pos.Wallet.Web.Sockets + ( module Pos.Wallet.Web.Sockets.Connection + , module Pos.Wallet.Web.Sockets.ConnSet + , module Pos.Wallet.Web.Sockets.Notifier + , module Pos.Wallet.Web.Sockets.Types + ) where + +import Pos.Wallet.Web.Sockets.Connection +import Pos.Wallet.Web.Sockets.ConnSet +import Pos.Wallet.Web.Sockets.Notifier +import Pos.Wallet.Web.Sockets.Types diff --git a/wallet/src/Pos/Wallet/Web/Sockets/Connection.hs b/wallet/src/Pos/Wallet/Web/Sockets/Connection.hs index 59e32a6e202..0844a42b6d8 100644 --- a/wallet/src/Pos/Wallet/Web/Sockets/Connection.hs +++ b/wallet/src/Pos/Wallet/Web/Sockets/Connection.hs @@ -1,6 +1,8 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | Module for websockets implementation of Daedalus API. -- This implements unidirectional sockets from server to client. -- Every message received from client will be ignored. @@ -79,6 +81,7 @@ send :: MonadIO m => (WSConnection -> NotifyEvent -> IO ()) -> WSConnection -> N send f conn msg = liftIO $ f conn msg instance WS.WebSocketsData NotifyEvent where + fromDataMessage _ = error "Attempt to deserialize NotifyEvent is apparently illegal" fromLazyByteString _ = error "Attempt to deserialize NotifyEvent is illegal" toLazyByteString = encode @@ -101,4 +104,3 @@ notifyAll msg = do var <- getWalletWebSockets conns <- readTVarIO var for_ (CS.listConnections conns) $ flip sendWS msg - diff --git a/wallet/src/Pos/Wallet/Web/Sockets/Notifier.hs b/wallet/src/Pos/Wallet/Web/Sockets/Notifier.hs index 4167114be03..c3368891dc4 100644 --- a/wallet/src/Pos/Wallet/Web/Sockets/Notifier.hs +++ b/wallet/src/Pos/Wallet/Web/Sockets/Notifier.hs @@ -11,6 +11,7 @@ module Pos.Wallet.Web.Sockets.Notifier import Universum +import Control.Concurrent (threadDelay) import Control.Concurrent.Async (mapConcurrently) import Control.Lens ((.=)) import Data.Default (Default (def)) @@ -23,7 +24,6 @@ import Pos.Wallet.Web.Mode (MonadWalletWebSockets) import Pos.Wallet.Web.Sockets.Connection (notifyAll) import Pos.Wallet.Web.Sockets.Types (NotifyEvent (..)) import Pos.Wallet.Web.State (WalletDbReader, addUpdate, askWalletDB) -import Serokell.Util (threadDelay) import Servant.Server (Handler, runHandler) import System.Wlog (WithLogger, logDebug) @@ -58,13 +58,13 @@ launchNotifier nat = restartOnError action = catchAny action $ const $ do -- TODO: log error -- cooldown - threadDelay cooldownPeriod + threadDelay (fromIntegral cooldownPeriod * 1000000) restartOnError action -- TODO: use Servant.enter here -- FIXME: don't ignore errors, send error msg to the socket startNotifier = restartOnError . void . runHandler . nat notifier period action = forever $ do - liftIO $ threadDelay period + liftIO $ threadDelay (fromIntegral period) action dificultyNotifier = void . flip runStateT def $ notifier difficultyNotifyPeriod $ do whenJustM networkChainDifficulty $ diff --git a/wallet/src/Pos/Wallet/Web/State/Acidic.hs b/wallet/src/Pos/Wallet/Web/State/Acidic.hs index ddd1bd3935b..86fe1808e41 100644 --- a/wallet/src/Pos/Wallet/Web/State/Acidic.hs +++ b/wallet/src/Pos/Wallet/Web/State/Acidic.hs @@ -1,5 +1,7 @@ {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | A module which derives acidic events from actions defined -- in "Pos.Wallet.Web.State.Storage". module Pos.Wallet.Web.State.Acidic @@ -71,11 +73,10 @@ import Universum import Data.Acid (EventResult, EventState, QueryEvent, UpdateEvent, makeAcidic) import Data.Default (def) -import Serokell.AcidState (ExtendedState, closeExtendedState, openLocalExtendedState, - openMemoryExtendedState, queryExtended, tidyExtendedState, - updateExtended) +import Serokell.AcidState.ExtendedState (ExtendedState, closeExtendedState, openLocalExtendedState, + openMemoryExtendedState, queryExtended, tidyExtendedState, + updateExtended) -import Pos.Core.Configuration (HasConfiguration) import Pos.Wallet.Web.State.Storage (WalletStorage) import Pos.Wallet.Web.State.Storage as WS import Pos.Wallet.Web.State.Transactions as WST @@ -93,12 +94,12 @@ update update = updateExtended -- | Initialize wallet DB in disk mode. Used in production. -openState :: (MonadIO m, HasConfiguration) => Bool -> FilePath -> m WalletDB +openState :: (MonadIO m) => Bool -> FilePath -> m WalletDB openState deleteIfExists fp = openLocalExtendedState deleteIfExists fp def -- | Initialize empty wallet DB in pure (in-memory) mode. -- Used primarily for testing. -openMemState :: (MonadIO m, HasConfiguration) => m WalletDB +openMemState :: (MonadIO m) => m WalletDB openMemState = openMemoryExtendedState def -- | Close wallet DB resource. diff --git a/wallet/src/Pos/Wallet/Web/State/State.hs b/wallet/src/Pos/Wallet/Web/State/State.hs index 1d896d3f60a..271b54f1ccb 100644 --- a/wallet/src/Pos/Wallet/Web/State/State.hs +++ b/wallet/src/Pos/Wallet/Web/State/State.hs @@ -97,8 +97,8 @@ module Pos.Wallet.Web.State.State import Data.Acid (EventResult, EventState, QueryEvent, UpdateEvent) import qualified Data.Map as Map import Pos.Client.Txp.History (TxHistoryEntry) -import Pos.Core (Address, ChainDifficulty, HasConfiguration, HasProtocolConstants, SlotId) -import Pos.Core.Common (HeaderHash) +import Pos.Core (Address, ChainDifficulty, HasProtocolConstants, HeaderHash, SlotId, + protocolConstants) import Pos.Txp (TxId, Utxo, UtxoModifier) import Pos.Util.Servant (encodeCType) import Pos.Util.Util (HasLens', lensOf) @@ -115,6 +115,8 @@ import Pos.Wallet.Web.State.Storage (AddressInfo (..), AddressLookupMo import qualified Pos.Wallet.Web.State.Storage as S import Universum +-- TODO, remove HasConfiguration + -- | The 'WalletDbReader' constraint encapsulates the set of effects which -- are able to read the 'WalletDB'. type WalletDbReader ctx m = @@ -254,7 +256,7 @@ getWalletBalancesAndUtxo ws = queryValue ws S.getWalletBalancesAndUtxo -- Effectful function (Updates) -- -createAccount :: (MonadIO m, HasConfiguration) +createAccount :: (MonadIO m) => WalletDB -> AccountId -> CAccountMeta @@ -262,7 +264,7 @@ createAccount :: (MonadIO m, HasConfiguration) createAccount db accId accMeta = updateDisk (A.CreateAccount accId accMeta) db -createAccountWithAddress :: (MonadIO m, HasConfiguration) +createAccountWithAddress :: (MonadIO m) => WalletDB -> AccountId -> CAccountMeta @@ -271,7 +273,7 @@ createAccountWithAddress :: (MonadIO m, HasConfiguration) createAccountWithAddress db accId accMeta addrMeta = updateDisk (A.CreateAccountWithAddress accId accMeta addrMeta) db -createWallet :: (MonadIO m, HasConfiguration) +createWallet :: (MonadIO m) => WalletDB -> CId Wal -> CWalletMeta @@ -281,13 +283,13 @@ createWallet :: (MonadIO m, HasConfiguration) createWallet db cWalId cwMeta isReady lastUpdate = updateDisk (A.CreateWallet cWalId cwMeta isReady lastUpdate) db -addWAddress :: (MonadIO m, HasConfiguration) +addWAddress :: (MonadIO m) => WalletDB -> S.WAddressMeta -> m () addWAddress db addr = updateDisk (A.AddWAddress addr) db -addCustomAddress :: (MonadIO m, HasConfiguration) +addCustomAddress :: (MonadIO m) => WalletDB -> CustomAddressType -> (Address, HeaderHash) @@ -295,32 +297,32 @@ addCustomAddress :: (MonadIO m, HasConfiguration) addCustomAddress db customAddrType (addr, hash) = updateDisk (A.AddCustomAddress customAddrType (S.WAddrId addr, hash)) db -setAccountMeta :: (MonadIO m, HasConfiguration) +setAccountMeta :: (MonadIO m) => WalletDB -> AccountId -> CAccountMeta -> m () setAccountMeta db accId accMeta = updateDisk (A.SetAccountMeta accId accMeta) db -setWalletMeta :: (MonadIO m, HasConfiguration) +setWalletMeta :: (MonadIO m) => WalletDB -> CId Wal -> CWalletMeta -> m () setWalletMeta db cWalId walletMeta = updateDisk (A.SetWalletMeta cWalId walletMeta) db -setWalletReady :: (MonadIO m, HasConfiguration) +setWalletReady :: (MonadIO m) => WalletDB -> CId Wal -> Bool -> m () setWalletReady db cWalId isReady = updateDisk (A.SetWalletReady cWalId isReady) db -setWalletPassLU :: (MonadIO m, HasConfiguration) +setWalletPassLU :: (MonadIO m) => WalletDB -> CId Wal -> PassPhraseLU -> m () setWalletPassLU db cWalId lastUpdate = updateDisk (A.SetWalletPassLU cWalId lastUpdate) db -setWalletSyncTip :: (MonadIO m, HasConfiguration) +setWalletSyncTip :: (MonadIO m) => WalletDB -> CId Wal -> HeaderHash -> m () setWalletSyncTip db cWalId headerHash = updateDisk (A.SetWalletSyncTip cWalId headerHash) db -setWalletRestorationSyncTip :: (MonadIO m, HasConfiguration) +setWalletRestorationSyncTip :: (MonadIO m) => WalletDB -> CId Wal -> RestorationBlockDepth @@ -328,7 +330,7 @@ setWalletRestorationSyncTip :: (MonadIO m, HasConfiguration) setWalletRestorationSyncTip db cWalId rbd headerHash = updateDisk (A.SetWalletRestorationSyncTip cWalId rbd headerHash) db -updateSyncStatistics :: (MonadIO m, HasConfiguration) +updateSyncStatistics :: (MonadIO m) => WalletDB -> CId Wal -> SyncStatistics @@ -336,29 +338,29 @@ updateSyncStatistics :: (MonadIO m, HasConfiguration) updateSyncStatistics db cWalId stats = updateDisk (A.UpdateSyncStatistics cWalId stats) db -setProfile :: (MonadIO m, HasConfiguration) +setProfile :: (MonadIO m) => WalletDB -> CProfile -> m () setProfile db cProfile = updateDisk (A.SetProfile cProfile) db -addOnlyNewTxMetas :: (MonadIO m, HasConfiguration) +addOnlyNewTxMetas :: (MonadIO m) => WalletDB -> CId Wal -> Map TxId CTxMeta -> m () addOnlyNewTxMetas db cWalId cTxMetas = updateDisk (A.AddOnlyNewTxMetas cWalId cTxMetaList) db where cTxMetaList = [ (encodeCType txId, cTxMeta) | (txId, cTxMeta) <- Map.toList cTxMetas ] -updateWalletBalancesAndUtxo :: (MonadIO m, HasConfiguration) +updateWalletBalancesAndUtxo :: (MonadIO m) => WalletDB -> UtxoModifier -> m () updateWalletBalancesAndUtxo db utxoModifier = updateDisk (A.UpdateWalletBalancesAndUtxo utxoModifier) db -setWalletUtxo :: (MonadIO m, HasConfiguration) +setWalletUtxo :: (MonadIO m) => WalletDB -> Utxo -> m () setWalletUtxo db utxo = updateDisk (A.SetWalletUtxo utxo) db -addOnlyNewTxMeta :: (MonadIO m, HasConfiguration) +addOnlyNewTxMeta :: (MonadIO m) => WalletDB -> CId Wal -> CTxId -> CTxMeta -> m () addOnlyNewTxMeta db walletId txId txMeta = updateDisk (A.AddOnlyNewTxMeta walletId txId txMeta) db @@ -374,34 +376,34 @@ addOnlyNewTxMeta db walletId txId txMeta = -- removed. Should it be needed again, one should add 'removeWallet' -- to the set of acidic updates and add a suitable function in this -- module to invoke it. -removeWallet :: (MonadIO m, HasConfiguration) +removeWallet :: (MonadIO m) => WalletDB -> CId Wal -> m () removeWallet db walletId = updateDisk (A.RemoveWallet2 walletId) db -removeWalletTxMetas :: (MonadIO m, HasConfiguration) +removeWalletTxMetas :: (MonadIO m) => WalletDB -> CId Wal -> [CTxId] -> m () removeWalletTxMetas db walletId txIds = updateDisk (A.RemoveWalletTxMetas walletId txIds) db -removeHistoryCache :: (MonadIO m, HasConfiguration) +removeHistoryCache :: (MonadIO m) => WalletDB -> CId Wal -> m () removeHistoryCache db walletId = updateDisk (A.RemoveHistoryCache walletId) db -removeAccount :: (MonadIO m, HasConfiguration) +removeAccount :: (MonadIO m) => WalletDB -> AccountId -> m () removeAccount db accountId = updateDisk (A.RemoveAccount accountId) db -removeWAddress :: (MonadIO m, HasConfiguration) +removeWAddress :: (MonadIO m) => WalletDB -> S.WAddressMeta -> m () removeWAddress db addrMeta = updateDisk (A.RemoveWAddress addrMeta) db -removeCustomAddress :: (MonadIO m, HasConfiguration) +removeCustomAddress :: (MonadIO m) => WalletDB -> CustomAddressType -> (Address, HeaderHash) @@ -409,24 +411,24 @@ removeCustomAddress :: (MonadIO m, HasConfiguration) removeCustomAddress db customAddrType (addr, hash) = updateDisk (A.RemoveCustomAddress customAddrType (S.WAddrId addr, hash)) db -addUpdate :: (MonadIO m, HasConfiguration) +addUpdate :: (MonadIO m) => WalletDB -> CUpdateInfo -> m () addUpdate db updateInfo = updateDisk (A.AddUpdate updateInfo) db -removeNextUpdate :: (MonadIO m, HasConfiguration) +removeNextUpdate :: (MonadIO m) => WalletDB -> m () removeNextUpdate = updateDisk A.RemoveNextUpdate -testReset :: (MonadIO m, HasConfiguration) +testReset :: (MonadIO m) => WalletDB -> m () testReset = updateDisk A.TestReset -insertIntoHistoryCache :: (MonadIO m, HasConfiguration) +insertIntoHistoryCache :: (MonadIO m) => WalletDB -> CId Wal -> Map TxId TxHistoryEntry @@ -435,7 +437,7 @@ insertIntoHistoryCache db cWalId cTxs | Map.null cTxs = return () | otherwise = updateDisk (A.InsertIntoHistoryCache cWalId cTxs) db -removeFromHistoryCache :: (MonadIO m, HasConfiguration) +removeFromHistoryCache :: (MonadIO m) => WalletDB -> CId Wal -> Map TxId a @@ -447,7 +449,7 @@ removeFromHistoryCache db cWalId cTxs cTxs' :: Map TxId () cTxs' = Map.map (const ()) cTxs -setPtxCondition :: (MonadIO m, HasConfiguration) +setPtxCondition :: (MonadIO m) => WalletDB -> CId Wal -> TxId @@ -456,7 +458,7 @@ setPtxCondition :: (MonadIO m, HasConfiguration) setPtxCondition db walletId txId condition = updateDisk (A.SetPtxCondition walletId txId condition) db -casPtxCondition :: (MonadIO m, HasConfiguration) +casPtxCondition :: (MonadIO m) => WalletDB -> CId Wal -> TxId @@ -467,7 +469,7 @@ casPtxCondition db walletId txId old new = updateDisk (A.CasPtxCondition walletId txId old new) db removeOnlyCreatingPtx - :: (HasConfiguration, MonadIO m) + :: (MonadIO m) => WalletDB -> CId Wal -> TxId @@ -475,54 +477,55 @@ removeOnlyCreatingPtx removeOnlyCreatingPtx db walletId txId = updateDisk (A.RemoveOnlyCreatingPtx walletId txId) db -ptxUpdateMeta :: (HasProtocolConstants, HasConfiguration, MonadIO m) - => WalletDB - -> CId Wal - -> TxId - -> PtxMetaUpdate - -> m () +ptxUpdateMeta + :: (MonadIO m, HasProtocolConstants) + => WalletDB + -> CId Wal + -> TxId + -> PtxMetaUpdate + -> m () ptxUpdateMeta db walletId txId metaUpdate = - updateDisk (A.PtxUpdateMeta walletId txId metaUpdate) db + updateDisk (A.PtxUpdateMeta protocolConstants walletId txId metaUpdate) db -addOnlyNewPendingTx :: (MonadIO m, HasConfiguration) +addOnlyNewPendingTx :: (MonadIO m) => WalletDB -> PendingTx -> m () addOnlyNewPendingTx db pendingTx = updateDisk (A.AddOnlyNewPendingTx pendingTx) db -cancelApplyingPtxs :: (MonadIO m, HasConfiguration) +cancelApplyingPtxs :: (MonadIO m) => WalletDB -> m () cancelApplyingPtxs = updateDisk A.CancelApplyingPtxs -cancelSpecificApplyingPtx :: (MonadIO m, HasConfiguration) +cancelSpecificApplyingPtx :: (MonadIO m) => WalletDB -> TxId -> m () cancelSpecificApplyingPtx db txid = updateDisk (A.CancelSpecificApplyingPtx txid) db -resetFailedPtxs :: (MonadIO m, HasConfiguration) +resetFailedPtxs :: (MonadIO m, HasProtocolConstants) => WalletDB -> SlotId -> m () -resetFailedPtxs db slotId = updateDisk (A.ResetFailedPtxs slotId) db +resetFailedPtxs db slotId = updateDisk (A.ResetFailedPtxs protocolConstants slotId) db -flushWalletStorage :: (MonadIO m, HasConfiguration) +flushWalletStorage :: (MonadIO m) => WalletDB -> m () flushWalletStorage = updateDisk A.FlushWalletStorage applyModifierToWallet - :: (MonadIO m, HasConfiguration) - => WalletDB - -> CId Wal - -> [S.WAddressMeta] -- ^ Wallet addresses to add - -> [(S.CustomAddressType, [(Address, HeaderHash)])] -- ^ Custom addresses to add - -> UtxoModifier - -> [(CTxId, CTxMeta)] -- ^ Transaction metadata to add - -> Map TxId TxHistoryEntry -- ^ Entries for the history cache - -> [(TxId, PtxCondition)] -- ^ PTX Conditions - -> ChainDifficulty -- ^ The current depth of the blockchain - -> WalletSyncState -- ^ New 'WalletSyncState' - -> m () + :: (MonadIO m) + => WalletDB + -> CId Wal + -> [S.WAddressMeta] -- ^ Wallet addresses to add + -> [(S.CustomAddressType, [(Address, HeaderHash)])] -- ^ Custom addresses to add + -> UtxoModifier + -> [(CTxId, CTxMeta)] -- ^ Transaction metadata to add + -> Map TxId TxHistoryEntry -- ^ Entries for the history cache + -> [(TxId, PtxCondition)] -- ^ PTX Conditions + -> ChainDifficulty -- ^ The current depth of the blockchain + -> WalletSyncState -- ^ New 'WalletSyncState' + -> m () applyModifierToWallet db walId wAddrs custAddrs utxoMod txMetas historyEntries ptxConditions currentDepth syncState = @@ -534,7 +537,7 @@ applyModifierToWallet db walId wAddrs custAddrs utxoMod db rollbackModifierFromWallet - :: (MonadIO m, HasConfiguration, HasProtocolConstants) + :: (MonadIO m, HasProtocolConstants) => WalletDB -> CId Wal -> [S.WAddressMeta] -- ^ Addresses to remove @@ -550,7 +553,7 @@ rollbackModifierFromWallet db walId wAddrs custAddrs utxoMod historyEntries ptxConditions syncState = updateDisk - ( A.RollbackModifierFromWallet2 + ( A.RollbackModifierFromWallet2 protocolConstants walId wAddrs custAddrs utxoMod historyEntries' ptxConditions syncState ) diff --git a/wallet/src/Pos/Wallet/Web/State/Storage.hs b/wallet/src/Pos/Wallet/Web/State/Storage.hs index 5a41774a7c2..98cd7000f9f 100644 --- a/wallet/src/Pos/Wallet/Web/State/Storage.hs +++ b/wallet/src/Pos/Wallet/Web/State/Storage.hs @@ -1,6 +1,8 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | Module which defines internal structure of `acid-state` wallet database. module Pos.Wallet.Web.State.Storage ( @@ -108,7 +110,6 @@ import Control.Arrow ((***)) import Control.Lens (at, has, ix, lens, makeClassy, makeLenses, non', to, toListOf, traversed, (%=), (+=), (.=), (<<.=), (?=), _Empty, _Just, _head) import Control.Monad.State.Class (get, put) -import qualified Control.Monad.State.Lazy as LS import Data.Default (Default, def) import qualified Data.HashMap.Strict as HM import qualified Data.Map as M @@ -119,8 +120,8 @@ import Formatting ((%)) import qualified Formatting as F import Pos.Client.Txp.History (TxHistoryEntry, txHistoryListToMap) import Pos.Core (Address, BlockCount (..), ChainDifficulty (..), HeaderHash, SlotId, - Timestamp) -import Pos.Core.Configuration (HasConfiguration) + Timestamp, ProtocolConstants(..), VssMinTTL(..), + VssMaxTTL(..)) import Pos.Core.Txp (TxAux, TxId) import Pos.SafeCopy () import Pos.Txp (AddrCoinMap, Utxo, UtxoModifier, applyUtxoModToAddrCoinMap, @@ -146,6 +147,8 @@ data WAddressMeta = WAddressMeta , _wamAddress :: Address } deriving (Eq, Ord, Show, Generic, Typeable) +instance NFData WAddressMeta + makeClassy ''WAddressMeta instance Hashable WAddressMeta instance Buildable WAddressMeta where @@ -171,6 +174,11 @@ data AddressInfo = AddressInfo , adiSortingKey :: !AddressSortingKey } deriving Eq +instance NFData AddressInfo where + rnf x = adiWAddressMeta x + `deepseq` adiSortingKey x + `deepseq` () + type CAddresses = HashMap Address AddressInfo -- | Information about existing wallet account. @@ -188,6 +196,13 @@ data AccountInfo = AccountInfo , _aiUnusedKey :: !AddressSortingKey } deriving (Eq) +instance NFData AccountInfo where + rnf ai = _aiMeta ai + `deepseq` _aiAddresses ai + `deepseq` _aiRemovedAddresses ai + `deepseq` _aiUnusedKey ai + `deepseq` () + makeLenses ''AccountInfo -- | A 'RestorationBlockDepth' is simply a @newtype@ wrapper over a 'ChainDifficulty', @@ -195,7 +210,7 @@ makeLenses ''AccountInfo -- a certain wallet was restored. newtype RestorationBlockDepth = RestorationBlockDepth { getRestorationBlockDepth :: ChainDifficulty } - deriving (Eq, Show) + deriving (Eq, Show, NFData) -- | Datatype which stores information about the sync state -- of this wallet. Syncing here is always relative to the blockchain. @@ -216,6 +231,12 @@ data WalletSyncState -- ^ This wallet is tracking the blockchain up to 'HeaderHash'. deriving (Eq) +instance NFData WalletSyncState where + rnf x = case x of + NotSynced -> () + SyncedWith h -> rnf h + RestoringFrom a b -> a `deepseq` b `deepseq` () + -- The 'SyncThroughput' is computed during the syncing phase in terms of -- how many blocks we can sync in one second. This information can be -- used by consumers of the API to construct heuristics on the state of the @@ -231,11 +252,16 @@ data SyncStatistics = SyncStatistics { , wspCurrentBlockchainDepth :: !ChainDifficulty } deriving (Eq) +instance NFData SyncStatistics where + rnf ss = wspThroughput ss + `deepseq` wspCurrentBlockchainDepth ss + `deepseq` () + -- ^ | The 'SyncThroughput', in blocks/sec. This can be roughly computed -- during the syncing process, to provide better estimate to the frontend -- on how much time the restoration/syncing progress is going to take. newtype SyncThroughput = SyncThroughput BlockCount - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, NFData) zeroThroughput :: SyncThroughput zeroThroughput = SyncThroughput (BlockCount 0) @@ -264,6 +290,16 @@ data WalletInfo = WalletInfo , _wiIsReady :: !Bool } deriving (Eq) +instance NFData WalletInfo where + rnf wi = _wiMeta wi + `deepseq` _wiPassphraseLU wi + `deepseq` _wiCreationTime wi + `deepseq` _wiSyncState wi + `deepseq` _wiSyncStatistics wi + `deepseq` _wsPendingTxs wi + `deepseq` _wiIsReady wi + `deepseq` () + makeLenses ''WalletInfo -- | Maps addresses to their first occurrence in the blockchain @@ -314,6 +350,19 @@ data WalletStorage = WalletStorage , _wsChangeAddresses :: !CustomAddresses } deriving (Eq) +instance NFData WalletStorage where + rnf ws = _wsWalletInfos ws + `deepseq` _wsAccountInfos ws + `deepseq` _wsProfile ws + `deepseq` _wsReadyUpdates ws + `deepseq` _wsTxHistory ws + `deepseq` _wsHistoryCache ws + `deepseq` _wsUtxo ws + `deepseq` _wsBalances ws + `deepseq` _wsUsedAddresses ws + `deepseq` _wsChangeAddresses ws + `deepseq` () + makeClassy ''WalletStorage instance Default WalletStorage where @@ -332,7 +381,7 @@ instance Default WalletStorage where } type Query a = forall m. (MonadReader WalletStorage m) => m a -type Update a = forall m. (HasConfiguration, MonadState WalletStorage m) => m a +type Update a = forall m. (MonadState WalletStorage m) => m a -- | How to lookup addresses of account data AddressLookupMode @@ -704,7 +753,7 @@ checkAndSmthPtx :: WebTypes.CId WebTypes.Wal -> TxId -> (Maybe PtxCondition -> Bool) - -> LS.State (Maybe PendingTx) () + -> State (Maybe PendingTx) () -> Update Bool checkAndSmthPtx wid txId whetherModify modifier = fmap getAny $ zoom' (wsWalletInfos . ix wid . wsPendingTxs . at txId) $ do @@ -730,14 +779,19 @@ data PtxMetaUpdate | PtxMarkAcknowledged -- ^ Mark tx as acknowledged by some peer -- | Update meta info of pending transaction atomically. -ptxUpdateMeta :: WebTypes.CId WebTypes.Wal -> TxId -> PtxMetaUpdate -> Update () -ptxUpdateMeta wid txId updType = +ptxUpdateMeta + :: ProtocolConstants + -> WebTypes.CId WebTypes.Wal + -> TxId + -> PtxMetaUpdate + -> Update () +ptxUpdateMeta pc wid txId updType = wsWalletInfos . ix wid . wsPendingTxs . ix txId %= case updType of PtxIncSubmitTiming -> - ptxSubmitTiming %~ incPtxSubmitTimingPure + ptxSubmitTiming %~ incPtxSubmitTimingPure pc PtxResetSubmitTiming curSlot -> - ptxSubmitTiming .~ mkPtxSubmitTiming curSlot + ptxSubmitTiming .~ mkPtxSubmitTiming pc curSlot PtxMarkAcknowledged -> ptxMarkAcknowledgedPure @@ -759,10 +813,10 @@ addOnlyNewPendingTx ptx = -- | Move every transaction which is in 'PtxWontApply' state to 'PtxApplying' -- state, effectively starting resubmission of failed transactions again. -resetFailedPtxs :: SlotId -> Update () -resetFailedPtxs curSlot = +resetFailedPtxs :: ProtocolConstants -> SlotId -> Update () +resetFailedPtxs pc curSlot = wsWalletInfos . traversed . - wsPendingTxs . traversed %= resetFailedPtx curSlot + wsPendingTxs . traversed %= resetFailedPtx pc curSlot -- | Gets whole wallet storage. Used primarily for testing and diagnostics. getWalletStorage :: Query WalletStorage @@ -823,6 +877,9 @@ deriveSafeCopySimple 0 'base ''PendingTx deriveSafeCopySimple 0 'base ''RestorationBlockDepth deriveSafeCopySimple 0 'base ''SyncThroughput deriveSafeCopySimple 0 'base ''SyncStatistics +deriveSafeCopySimple 0 'base ''ProtocolConstants +deriveSafeCopySimple 0 'base ''VssMinTTL +deriveSafeCopySimple 0 'base ''VssMaxTTL -- Legacy versions, for migrations @@ -839,7 +896,7 @@ instance Migrate WAddressMeta where type MigrateFrom WAddressMeta = WebTypes.CWAddressMeta migrate (WebTypes.CWAddressMeta wid accIdx addrIdx cAddr) = WAddressMeta wid accIdx addrIdx $ unsafeCIdToAddress cAddr - + data WalletTip_v0 = V0_NotSynced | V0_SyncedWith !HeaderHash diff --git a/wallet/src/Pos/Wallet/Web/State/Transactions.hs b/wallet/src/Pos/Wallet/Web/State/Transactions.hs index 9da2f5a28e8..11869a708e3 100644 --- a/wallet/src/Pos/Wallet/Web/State/Transactions.hs +++ b/wallet/src/Pos/Wallet/Web/State/Transactions.hs @@ -19,8 +19,7 @@ import Data.Foldable (for_) import qualified Data.HashMap.Strict as HM import qualified Data.Map as M import Pos.Client.Txp.History (TxHistoryEntry) -import Pos.Core (Address, ChainDifficulty, HasProtocolConstants) -import Pos.Core.Common (HeaderHash) +import Pos.Core (Address, ChainDifficulty, HeaderHash, ProtocolConstants) import Pos.Txp (TxId, UtxoModifier) import Pos.Util.Servant (encodeCType) import Pos.Wallet.Web.ClientTypes (AccountId (..), CAccountMeta, CId, CTxId, CTxMeta, Wal) @@ -131,8 +130,8 @@ applyModifierToWallet walId wAddrs custAddrs utxoMod -- | Like 'rollbackModifierFromWallet', but it takes into account the given 'WalletSyncState'. rollbackModifierFromWallet2 - :: HasProtocolConstants -- Needed for ptxUpdateMeta - => CId Wal + :: ProtocolConstants -- Needed for ptxUpdateMeta + -> CId Wal -> [WS.WAddressMeta] -- ^ Addresses to remove -> [(WS.CustomAddressType, [(Address, HeaderHash)])] -- ^ Custom addresses to remove -> UtxoModifier @@ -142,7 +141,7 @@ rollbackModifierFromWallet2 -> [(TxId, PtxCondition, WS.PtxMetaUpdate)] -- ^ Deleted PTX candidates -> WS.WalletSyncState -- ^ New 'WalletSyncState' -> Update () -rollbackModifierFromWallet2 walId wAddrs custAddrs utxoMod +rollbackModifierFromWallet2 pc walId wAddrs custAddrs utxoMod historyEntries ptxConditions syncState = do case syncState of @@ -155,11 +154,11 @@ rollbackModifierFromWallet2 walId wAddrs custAddrs utxoMod WS.removeFromHistoryCache walId historyEntries WS.removeWalletTxMetas walId (encodeCType <$> M.keys historyEntries) for_ ptxConditions $ \(txId, cond, meta) -> do - WS.ptxUpdateMeta walId txId meta + WS.ptxUpdateMeta pc walId txId meta WS.setPtxCondition walId txId cond WS.setWalletRestorationSyncTip walId rhh newSyncTip (WS.SyncedWith newSyncTip) -> - rollbackModifierFromWallet walId wAddrs custAddrs utxoMod + rollbackModifierFromWallet pc walId wAddrs custAddrs utxoMod historyEntries ptxConditions newSyncTip -- See similar comment as for 'applyModifierToWallet2'. @@ -170,8 +169,8 @@ rollbackModifierFromWallet2 walId wAddrs custAddrs utxoMod -- | Rollback some set of modifiers to a wallet. -- TODO Find out the significance of this set of modifiers and document. rollbackModifierFromWallet - :: HasProtocolConstants -- Needed for ptxUpdateMeta - => CId Wal + :: ProtocolConstants + -> CId Wal -> [WS.WAddressMeta] -- ^ Addresses to remove -> [(WS.CustomAddressType, [(Address, HeaderHash)])] -- ^ Custom addresses to remove -> UtxoModifier @@ -181,7 +180,7 @@ rollbackModifierFromWallet -> [(TxId, PtxCondition, WS.PtxMetaUpdate)] -- ^ Deleted PTX candidates -> HeaderHash -- ^ New sync tip -> Update () -rollbackModifierFromWallet walId wAddrs custAddrs utxoMod +rollbackModifierFromWallet pc walId wAddrs custAddrs utxoMod historyEntries ptxConditions syncTip = do for_ wAddrs WS.removeWAddress @@ -192,6 +191,6 @@ rollbackModifierFromWallet walId wAddrs custAddrs utxoMod WS.removeFromHistoryCache walId historyEntries WS.removeWalletTxMetas walId (encodeCType <$> M.keys historyEntries) for_ ptxConditions $ \(txId, cond, meta) -> do - WS.ptxUpdateMeta walId txId meta + WS.ptxUpdateMeta pc walId txId meta WS.setPtxCondition walId txId cond WS.setWalletSyncTip walId syncTip diff --git a/wallet/src/Pos/Wallet/Web/State/Util.hs b/wallet/src/Pos/Wallet/Web/State/Util.hs index 488ea6a815a..e367835abed 100644 --- a/wallet/src/Pos/Wallet/Web/State/Util.hs +++ b/wallet/src/Pos/Wallet/Web/State/Util.hs @@ -7,11 +7,10 @@ module Pos.Wallet.Web.State.Util import Universum import Data.Acid (createArchive, createCheckpoint) -import Data.Time.Units (TimeUnit) +import Data.Time.Units (TimeUnit, Second) import Formatting (sformat, shown, (%)) import Mockable (Delay, Mockable, delay) -import Serokell.AcidState (ExtendedState (..), extendedStateToAcid) -import Serokell.Util (sec) +import Serokell.AcidState.ExtendedState (ExtendedState (..), extendedStateToAcid) import System.Directory (getModificationTime, listDirectory, removeFile) import System.FilePath (()) import System.Wlog (WithLogger, logDebug, logError) @@ -65,7 +64,7 @@ cleanupAcidStatePeriodically db interval = perform logError $ sformat ("acidCleanupWorker failed with error: "%shown% " restarting in 1m") e - delay $ sec 60 + delay (60 :: Second) report `finally` perform -- Returns how many files were deleted diff --git a/wallet/src/Pos/Wallet/Web/Swagger.hs b/wallet/src/Pos/Wallet/Web/Swagger.hs index 53e3bc38190..4af0bc8f270 100644 --- a/wallet/src/Pos/Wallet/Web/Swagger.hs +++ b/wallet/src/Pos/Wallet/Web/Swagger.hs @@ -1,3 +1,9 @@ -- | Wallet swagger implementation -{-# OPTIONS_GHC -F -pgmF autoexporter #-} +module Pos.Wallet.Web.Swagger + ( module Pos.Wallet.Web.Swagger.Spec + ) where + +import Pos.Wallet.Web.Swagger.Spec +import Pos.Wallet.Web.Swagger.Instances.Schema () +import Pos.Wallet.Web.Swagger.Instances.Swagger () diff --git a/wallet/src/Pos/Wallet/Web/Swagger/Instances/Schema.hs b/wallet/src/Pos/Wallet/Web/Swagger/Instances/Schema.hs index e2f5da33fb0..132a227e1cb 100644 --- a/wallet/src/Pos/Wallet/Web/Swagger/Instances/Schema.hs +++ b/wallet/src/Pos/Wallet/Web/Swagger/Instances/Schema.hs @@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedLists #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | Instances of `ToSchema` & `ToParamSchema` module Pos.Wallet.Web.Swagger.Instances.Schema where diff --git a/wallet/src/Pos/Wallet/Web/Swagger/Instances/Swagger.hs b/wallet/src/Pos/Wallet/Web/Swagger/Instances/Swagger.hs index 9f3b0180c63..42f2ee69932 100644 --- a/wallet/src/Pos/Wallet/Web/Swagger/Instances/Swagger.hs +++ b/wallet/src/Pos/Wallet/Web/Swagger/Instances/Swagger.hs @@ -1,5 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + -- | Swagger instances module Pos.Wallet.Web.Swagger.Instances.Swagger where diff --git a/wallet/src/Pos/Wallet/Web/Swagger/Spec.hs b/wallet/src/Pos/Wallet/Web/Swagger/Spec.hs index c317543bf31..88cb55514d2 100644 --- a/wallet/src/Pos/Wallet/Web/Swagger/Spec.hs +++ b/wallet/src/Pos/Wallet/Web/Swagger/Spec.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} -- | Swagger specification diff --git a/wallet/src/Pos/Wallet/Web/Tracking.hs b/wallet/src/Pos/Wallet/Web/Tracking.hs index a5cb7b1fc4e..c0103fe0512 100644 --- a/wallet/src/Pos/Wallet/Web/Tracking.hs +++ b/wallet/src/Pos/Wallet/Web/Tracking.hs @@ -1,3 +1,18 @@ -- | Utilities which allow to keep wallet info up to date +module Pos.Wallet.Web.Tracking + ( module Pos.Wallet.Web.Tracking.BListener + , module Pos.Wallet.Web.Tracking.Decrypt + , module Pos.Wallet.Web.Tracking.Modifier + , module Pos.Wallet.Web.Tracking.Restore + , module Pos.Wallet.Web.Tracking.Sync + , module Pos.Wallet.Web.Tracking.Types + ) where + +import Pos.Wallet.Web.Tracking.BListener +import Pos.Wallet.Web.Tracking.Decrypt +import Pos.Wallet.Web.Tracking.Modifier +import Pos.Wallet.Web.Tracking.Restore +import Pos.Wallet.Web.Tracking.Sync +import Pos.Wallet.Web.Tracking.Types + -{-# OPTIONS_GHC -F -pgmF autoexporter #-} diff --git a/wallet/src/Pos/Wallet/Web/Tracking/BListener.hs b/wallet/src/Pos/Wallet/Web/Tracking/BListener.hs index 34d69ff2639..a40e42ff218 100644 --- a/wallet/src/Pos/Wallet/Web/Tracking/BListener.hs +++ b/wallet/src/Pos/Wallet/Web/Tracking/BListener.hs @@ -21,20 +21,19 @@ import System.Wlog (HasLoggerName (modifyLoggerName), WithLogger) import Pos.Block.BListener (MonadBListener (..)) import Pos.Block.Types (Blund, undoTx) -import Pos.Core (HasConfiguration, HeaderHash, Timestamp, difficultyL, headerSlotL, - prevBlockL) +import Pos.Core (HeaderHash, Timestamp, difficultyL, headerSlotL, prevBlockL) import Pos.Core.Block (BlockHeader (..), blockHeader, getBlockHeader, mainBlockTxPayload) +import Pos.Core.Chrono (NE, NewestFirst (..), OldestFirst (..)) import Pos.Core.Txp (TxAux (..), TxUndo) import Pos.DB.BatchOp (SomeBatchOp) import Pos.DB.Class (MonadDBRead) import qualified Pos.GState as GS -import Pos.Reporting (MonadReporting, reportOrLogE) -import Pos.Slotting (MonadSlots, MonadSlotsData, getCurrentEpochSlotDuration, - getSlotStartPure, getSystemStartM) +import Pos.Infra.Reporting (MonadReporting, reportOrLogE) +import Pos.Infra.Slotting (MonadSlots, MonadSlotsData, getCurrentEpochSlotDuration, + getSlotStartPure, getSystemStartM) +import Pos.Infra.Util.LogSafe (buildSafe, logInfoSP, logWarningSP, secretOnlyF, secure) +import Pos.Infra.Util.TimeLimit (CanLogInParallel, logWarningWaitInf) import Pos.Txp.Base (flattenTxPayload) -import Pos.Util.Chrono (NE, NewestFirst (..), OldestFirst (..)) -import Pos.Util.LogSafe (buildSafe, logInfoSP, logWarningSP, secretOnlyF, secure) -import Pos.Util.TimeLimit (CanLogInParallel, logWarningWaitInf) import Pos.Wallet.Web.Tracking.Decrypt (eskToWalletDecrCredentials) import Pos.Wallet.Web.Account (AccountMode, getSKById) @@ -75,9 +74,8 @@ onApplyBlocksWebWallet , WS.WalletDbReader ctx m , MonadSlotsData ctx m , MonadDBRead m - , MonadReporting ctx m + , MonadReporting m , CanLogInParallel m - , HasConfiguration ) => OldestFirst NE Blund -> m SomeBatchOp onApplyBlocksWebWallet blunds = setLogger . reportTimeouts "apply" $ do @@ -127,9 +125,8 @@ onRollbackBlocksWebWallet , WS.WalletDbReader ctx m , MonadDBRead m , MonadSlots ctx m - , MonadReporting ctx m + , MonadReporting m , CanLogInParallel m - , HasConfiguration ) => NewestFirst NE Blund -> m SomeBatchOp onRollbackBlocksWebWallet blunds = setLogger . reportTimeouts "rollback" $ do @@ -171,7 +168,6 @@ onRollbackBlocksWebWallet blunds = setLogger . reportTimeouts "rollback" $ do blkHeaderTsGetter :: ( MonadSlotsData ctx m , MonadDBRead m - , HasConfiguration ) => m (BlockHeader -> Maybe Timestamp) blkHeaderTsGetter = do @@ -216,7 +212,7 @@ logMsg action (NE.length -> bNums) wid accModifier = action bNums wid accModifier catchInSync - :: (MonadReporting ctx m) + :: (MonadReporting m, MonadIO m, WithLogger m, MonadCatch m) => Text -> (CId Wal -> m ()) -> CId Wal -> m () catchInSync desc syncWallet wId = syncWallet wId `catchAny` \e -> do diff --git a/wallet/src/Pos/Wallet/Web/Tracking/Modifier.hs b/wallet/src/Pos/Wallet/Web/Tracking/Modifier.hs index ade1de0d5cd..e42c112843f 100644 --- a/wallet/src/Pos/Wallet/Web/Tracking/Modifier.hs +++ b/wallet/src/Pos/Wallet/Web/Tracking/Modifier.hs @@ -29,9 +29,10 @@ import Serokell.Util (listJson, listJsonIndent) import Pos.Client.Txp.History (TxHistoryEntry (..)) import Pos.Core (Address, HeaderHash) import Pos.Core.Txp (TxId) +import Pos.Infra.Util.LogSafe (BuildableSafeGen (..), + deriveSafeBuildable, secretOnlyF, + secureListF) import Pos.Txp.Toil (UtxoModifier) -import Pos.Util.LogSafe (BuildableSafeGen (..), deriveSafeBuildable, secretOnlyF, - secureListF) import Pos.Util.Modifier (MapModifier) import qualified Pos.Util.Modifier as MM diff --git a/wallet/src/Pos/Wallet/Web/Tracking/Restore.hs b/wallet/src/Pos/Wallet/Web/Tracking/Restore.hs index d125f583258..abd75256497 100644 --- a/wallet/src/Pos/Wallet/Web/Tracking/Restore.hs +++ b/wallet/src/Pos/Wallet/Web/Tracking/Restore.hs @@ -5,14 +5,13 @@ import Universum import UnliftIO (MonadUnliftIO) import qualified Data.Map as M -import System.Wlog (CanLog, HasLoggerName, WithLogger, logInfo, modifyLoggerName) +import System.Wlog (WithLogger, logInfo, modifyLoggerName) import Pos.Core (Address, HasConfiguration, HasDifficulty (..), headerHash) import Pos.Core.Txp (TxIn, TxOut (..), TxOutAux (..)) import qualified Pos.DB.BlockIndex as DB import Pos.DB.Class (MonadDBRead (..)) -import Pos.Slotting (MonadSlotsData) -import Pos.StateLock (StateLock) +import Pos.Infra.Slotting (MonadSlotsData) import Pos.Txp (genesisUtxo, unGenesisUtxo, utxoToModifier) import Pos.Txp.DB.Utxo (filterUtxo) import Pos.Util (HasLens (..)) @@ -31,9 +30,7 @@ import Pos.Wallet.Web.Tracking.Types (SyncQueue, newRestoreRequest, su restoreWallet :: ( WalletDbReader ctx m , MonadDBRead m , WithLogger m - , HasLens StateLock ctx StateLock , HasLens SyncQueue ctx SyncQueue - , MonadMask m , MonadSlotsData ctx m , MonadUnliftIO m ) => WalletDecrCredentials -> m () @@ -67,8 +64,6 @@ restoreWallet credentials = do -- | Restores the wallet balance by looking at the global Utxo and trying to decrypt -- each unspent output address. If we get a match, it means it belongs to us. restoreWalletBalance :: ( WalletDbReader ctx m - , HasLoggerName m - , CanLog m , MonadDBRead m , MonadUnliftIO m ) => WalletDB -> WalletDecrCredentials -> m () diff --git a/wallet/src/Pos/Wallet/Web/Tracking/Sync.hs b/wallet/src/Pos/Wallet/Web/Tracking/Sync.hs index 4f4edd8bb56..985352de3e4 100644 --- a/wallet/src/Pos/Wallet/Web/Tracking/Sync.hs +++ b/wallet/src/Pos/Wallet/Web/Tracking/Sync.hs @@ -40,26 +40,26 @@ module Pos.Wallet.Web.Tracking.Sync , BoundedSyncTime (..) ) where -import Control.Monad.Except (MonadError (throwError)) -import Universum -import UnliftIO (MonadUnliftIO) -import Unsafe (unsafeLast) +import Universum hiding (id) import Control.Concurrent.STM (readTQueue) import Control.Exception.Safe (handleAny) import Control.Lens (to) +import Control.Monad.Except (MonadError (throwError)) import qualified Data.DList as DL import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS +import qualified Data.List as List (last) import qualified Data.List.NonEmpty as NE import Data.Time.Units (Microsecond, TimeUnit (..)) import Formatting (build, float, sformat, shown, (%)) import Pos.Block.Types (Blund, undoTx) import Pos.Client.Txp.History (TxHistoryEntry (..), txHistoryListToMap) -import Pos.Core (Address, BlockCount (..), ChainDifficulty (..), HasConfiguration, - HasDifficulty (..), HasProtocolConstants, HeaderHash, Timestamp (..), - blkSecurityParam, genesisHash, headerHash, headerSlotL, timestampToPosix) +import Pos.Core (Address, BlockCount (..), ChainDifficulty (..), HasDifficulty (..), + HasProtocolConstants, HeaderHash, Timestamp (..), blkSecurityParam, + genesisHash, headerHash, headerSlotL, timestampToPosix) import Pos.Core.Block (BlockHeader (..), getBlockHeader, mainBlockTxPayload) +import Pos.Core.Chrono (getNewestFirst) import Pos.Core.Txp (TxAux (..), TxId, TxUndo) import Pos.Crypto (WithHash (..), shortHashF, withHash) import Pos.DB.Block (getBlund) @@ -68,13 +68,13 @@ import qualified Pos.DB.BlockIndex as DB import Pos.DB.Class (MonadDBRead (..)) import qualified Pos.GState as GS import Pos.GState.BlockExtra (resolveForwardLink) -import Pos.Slotting (MonadSlots (..), MonadSlotsData, getSlotStartPure, getSystemStartM) -import Pos.Slotting.Types (SlottingData) -import Pos.StateLock (Priority (..), StateLock, withStateLockNoMetrics) +import Pos.Infra.Slotting (MonadSlots (..), MonadSlotsData, getSlotStartPure, + getSystemStartM) +import Pos.Infra.Slotting.Types (SlottingData) +import Pos.Infra.StateLock (Priority (..), withStateLockNoMetrics) +import Pos.Infra.Util.LogSafe (buildSafe, logDebugSP, logErrorSP, logInfoSP, logWarningSP, + secretOnlyF, secure) import Pos.Txp (UndoMap, flattenTxPayload, topsortTxs, _txOutputs) -import Pos.Util.Chrono (getNewestFirst) -import Pos.Util.LogSafe (buildSafe, logDebugSP, logErrorSP, logInfoSP, logWarningSP, - secretOnlyF, secure) import qualified Pos.Util.Modifier as MM import Pos.Util.Servant (encodeCType) import Pos.Util.Util (HasLens (..), getKeys, timed) @@ -103,13 +103,8 @@ import Pos.Wallet.Web.Tracking.Types -- The update of the balance will be done immediately and synchronously, the transaction history -- will instead be recovered asynchronously. syncWallet :: ( WalletDbReader ctx m - , MonadDBRead m - , WithLogger m - , HasLens StateLock ctx StateLock , HasLens SyncQueue ctx SyncQueue - , MonadMask m , MonadSlotsData ctx m - , MonadUnliftIO m ) => WalletDecrCredentials -> m () syncWallet credentials = submitSyncRequest (newSyncRequest credentials) @@ -118,8 +113,6 @@ syncWallet credentials = submitSyncRequest (newSyncRequest credentials) processSyncRequest :: ( WalletDbReader ctx m , BlockLockMode ctx m , MonadSlotsData ctx m - , HasConfiguration - , MonadIO m ) => SyncQueue -> m () processSyncRequest syncQueue = do newRequest <- atomically (readTQueue syncQueue) @@ -197,7 +190,6 @@ syncWalletWithBlockchain ( WalletDbReader ctx m , BlockLockMode ctx m , MonadSlotsData ctx m - , HasConfiguration ) => SyncRequest -> m SyncResult @@ -273,7 +265,7 @@ syncWalletWithBlockchain syncRequest@SyncRequest{..} = setLogger $ do -- rollback can't occur more then @blkSecurityParam@ blocks, -- so we can sync wallet and GState without the block lock -- to avoid blocking of blocks verification/application. - stableBlockHeader <- unsafeLast . getNewestFirst <$> GS.loadHeadersByDepth (blkSecurityParam + 1) (headerHash gstateTipH) + stableBlockHeader <- List.last . getNewestFirst <$> GS.loadHeadersByDepth (blkSecurityParam + 1) (headerHash gstateTipH) logInfo $ sformat ( "Wallet's tip is far from GState tip. Syncing with the last stable known header " %build% " (the tip of the blockchain - k blocks) without the block lock" @@ -304,7 +296,6 @@ syncWalletWithBlockchainUnsafe , MonadDBRead m , WithLogger m , MonadSlotsData ctx m - , HasConfiguration ) => SyncRequest -> BlockHeader @@ -400,7 +391,7 @@ syncWalletWithBlockchainUnsafe syncRequest walletTip blockchainTip = setLogger $ -- if the application was interrupted during blocks application. blunds <- getNewestFirst <$> GS.loadBlundsWhile (\b -> getBlockHeader b /= blockchainTip) (headerHash wHeader) let newModifier = foldl' (\r b -> r <> rollbackBlock credentials usedAddresses b getBlockTimestamp) currentModifier blunds - pure (newModifier, getBlockHeader . fst . unsafeLast $ blunds) + pure (newModifier, getBlockHeader . fst . List.last $ blunds) | otherwise -> do logInfoSP $ \sl -> sformat ("Wallet " % secretOnlyF sl build %" has finally caught up with the blockchain.") walletId pure (currentModifier, blockchainTip) @@ -466,8 +457,7 @@ constructAllUsed usedAddresses modif = -- Addresses are used in TxIn's will be deleted, -- in TxOut's will be added. trackingApplyTxs - :: HasConfiguration - => WalletDecrCredentials -- ^ Wallet's decryption credentials + :: WalletDecrCredentials -- ^ Wallet's decryption credentials -> [(Address, HeaderHash)] -- ^ All used addresses from db along with their HeaderHashes -> (BlockHeader -> Maybe ChainDifficulty) -- ^ Function to determine tx chain difficulty -> (BlockHeader -> Maybe Timestamp) -- ^ Function to determine tx timestamp in history @@ -516,8 +506,7 @@ trackingApplyTxs credentials usedAddresses getDiff getTs getPtxBlkInfo txs = -- Process transactions on block rollback. -- Like @trackingApplyTxs@, but vise versa. trackingRollbackTxs - :: HasConfiguration - => WalletDecrCredentials -- ^ Wallet's decryption credentials + :: WalletDecrCredentials -- ^ Wallet's decryption credentials -> [(Address, HeaderHash)] -- ^ All used addresses from db along with their HeaderHashes -> (BlockHeader -> Maybe ChainDifficulty) -- ^ Function to determine tx chain difficulty -> (BlockHeader -> Maybe Timestamp) -- ^ Function to determine tx timestamp in history @@ -597,7 +586,6 @@ applyModifierToWallet :: ( CanLog m , HasLoggerName m , MonadIO m - , HasConfiguration ) => WalletDB -> TrackingOperation @@ -638,7 +626,6 @@ rollbackModifierFromWallet , HasLoggerName m , MonadSlots ctx m , HasProtocolConstants - , HasConfiguration ) => WalletDB -> TrackingOperation diff --git a/wallet/src/Pos/Wallet/Web/Tracking/Types.hs b/wallet/src/Pos/Wallet/Web/Tracking/Types.hs index ed9862f42ad..80498c157b6 100644 --- a/wallet/src/Pos/Wallet/Web/Tracking/Types.hs +++ b/wallet/src/Pos/Wallet/Web/Tracking/Types.hs @@ -20,8 +20,8 @@ import System.Wlog (WithLogger) import Pos.Core (HasConfiguration) import Pos.DB.Class (MonadDBRead (..)) -import Pos.Slotting (MonadSlotsData) -import Pos.StateLock (StateLock) +import Pos.Infra.Slotting (MonadSlotsData) +import Pos.Infra.StateLock (StateLock) import Pos.Util (HasLens (..)) import Pos.Wallet.Web.ClientTypes (CId, Wal) diff --git a/wallet/test/Test/Pos/Util/MnemonicsSpec.hs b/wallet/test/Test/Pos/Util/MnemonicsSpec.hs new file mode 100644 index 00000000000..9c17529478e --- /dev/null +++ b/wallet/test/Test/Pos/Util/MnemonicsSpec.hs @@ -0,0 +1,64 @@ +module Test.Pos.Util.MnemonicsSpec (spec, Entropy(..)) where + +import Universum + +import Data.ByteString.Char8 (pack) +import Data.Set (Set) +import Test.Hspec (Spec, it, shouldSatisfy, xit) +import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) +import Test.QuickCheck (Arbitrary (..), forAll, property) +import Test.QuickCheck.Gen (oneof, vectorOf) + +import Pos.Util.BackupPhrase (BackupPhrase (..), safeKeysFromPhrase) +import Pos.Util.Mnemonics (defMnemonic, fromMnemonic, toMnemonic) +import Pos.Wallet.Web.ClientTypes.Functions (encToCId) +import Pos.Wallet.Web.ClientTypes.Types (CId) + +import qualified Data.Set as Set + + +spec :: Spec +spec = do + it "No example mnemonic" $ + fromMnemonic defMnemonic `shouldSatisfy` isLeft + + it "No empty mnemonic" $ + (fromMnemonic "") `shouldSatisfy` isLeft + + it "No empty entropy" $ + (toMnemonic "") `shouldSatisfy` isLeft + + modifyMaxSuccess (const 10000) $ prop "toMnemonic >=> fromMnemonic = Right" $ + \(Entropy ent) -> (toMnemonic ent >>= fromMnemonic) == Right ent + + -- Turn xit -> it to run, and go get a looooong coffee. + xit "entropyToWalletId is injective, (very long to run, used for investigation)" + $ property + $ forAll (vectorOf 1000 arbitrary) + $ \inputs -> length (inject entropyToWalletId inputs) == length inputs + where + inject :: Ord b => (a -> b) -> [a] -> Set b + inject fn = + Set.fromList . fmap fn + + entropyToWalletId :: Entropy -> CId w + entropyToWalletId (Entropy ent) = cid + where + backupPhrase = either + (error . (<>) "Wrong arbitrary Entropy generated: " . show) + (BackupPhrase . words) + (toMnemonic ent) + + cid = either + (error . (<>) "Couldn't create keys from generated BackupPhrase" . show) + (encToCId . fst) + (safeKeysFromPhrase mempty backupPhrase) + + +newtype Entropy = Entropy ByteString deriving (Eq, Show) + +-- | Initial seed has to be vector or length multiple of 4 bytes and shorter +-- than 64 bytes. +instance Arbitrary Entropy where + arbitrary = + Entropy . pack <$> oneof [ vectorOf (4 * n) arbitrary | n <- [1..16] ] diff --git a/wallet/test/Test/Pos/Wallet/MigrationSpec.hs b/wallet/test/Test/Pos/Wallet/MigrationSpec.hs index 69d164fa80e..e275b3dbb5f 100644 --- a/wallet/test/Test/Pos/Wallet/MigrationSpec.hs +++ b/wallet/test/Test/Pos/Wallet/MigrationSpec.hs @@ -1,28 +1,37 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Test.Pos.Wallet.MigrationSpec (spec) where +import Universum + import Control.Arrow ((***)) +import Control.DeepSeq (force) import Data.Default (def) import qualified Data.HashMap.Strict as HM import Data.SafeCopy -import Pos.Arbitrary.Core () -import Pos.Core (HasConfiguration) -import Pos.Util.CompileInfo (withCompileInfo) +import Test.Hspec (Spec, describe, it, shouldNotBe) +import Test.Hspec.QuickCheck (modifyMaxSize, prop) +import Test.QuickCheck (Arbitrary (..), Property, oneof, (===)) + import Pos.Wallet.Web.ClientTypes (AccountId (..), Addr, CAccountMeta (..), CCoin (..), CHash (..), CId (..), CProfile (..), CTxId (..), CTxMeta (..), CUpdateInfo (..), CWAddressMeta (..), CWalletAssurance (..), CWalletMeta (..), Wal) import Pos.Wallet.Web.ClientTypes.Functions (addressToCId) +import Pos.Wallet.Web.State.Acidic (openState) +import Pos.Wallet.Web.State.State (askWalletSnapshot) import Pos.Wallet.Web.State.Storage -import Test.Hspec (Spec, describe, it) -import Test.Pos.Configuration (withDefConfigurations) -import Test.QuickCheck -import Universum + +import Test.Pos.Core.Arbitrary () +import Test.Pos.Txp.Arbitrary () -------------------------------------------------------------------------------- -- Reverse migrations @@ -130,6 +139,7 @@ deriving instance Show WalletInfo_v0 deriving instance Show WalletTip_v0 deriving instance Show WalletStorage_v2 deriving instance Show WalletStorage_v3 +deriving instance Show WalletStorage deriving instance Arbitrary CHash deriving instance Arbitrary (CId Wal) @@ -193,13 +203,13 @@ instance Arbitrary AccountId where instance Arbitrary RestorationBlockDepth where arbitrary = RestorationBlockDepth <$> arbitrary -instance HasConfiguration => Arbitrary WalletTip_v0 where +instance Arbitrary WalletTip_v0 where arbitrary = oneof [ pure V0_NotSynced , V0_SyncedWith <$> arbitrary ] -instance HasConfiguration => Arbitrary WalletSyncState where +instance Arbitrary WalletSyncState where arbitrary = oneof [ pure NotSynced , SyncedWith <$> arbitrary @@ -235,7 +245,7 @@ instance Arbitrary AccountInfo_v0 where <*> arbitrary <*> arbitrary -instance HasConfiguration => Arbitrary WalletInfo_v0 where +instance Arbitrary WalletInfo_v0 where arbitrary = WalletInfo_v0 <$> arbitrary <*> arbitrary @@ -244,7 +254,7 @@ instance HasConfiguration => Arbitrary WalletInfo_v0 where <*> pure HM.empty <*> arbitrary -instance HasConfiguration => Arbitrary WalletInfo where +instance Arbitrary WalletInfo where arbitrary = WalletInfo <$> arbitrary <*> arbitrary @@ -254,7 +264,7 @@ instance HasConfiguration => Arbitrary WalletInfo where <*> pure HM.empty <*> arbitrary -instance HasConfiguration => Arbitrary WalletStorage_v2 where +instance Arbitrary WalletStorage_v2 where arbitrary = WalletStorage_v2 <$> arbitrary <*> arbitrary @@ -267,7 +277,7 @@ instance HasConfiguration => Arbitrary WalletStorage_v2 where <*> arbitrary <*> arbitrary -instance HasConfiguration => Arbitrary WalletStorage_v3 where +instance Arbitrary WalletStorage_v3 where arbitrary = WalletStorage_v3 <$> arbitrary <*> arbitrary @@ -282,20 +292,38 @@ instance HasConfiguration => Arbitrary WalletStorage_v3 where spec :: Spec -spec = withCompileInfo def $ withDefConfigurations $ \_ -> - describe "Migration to latest version can be reversed" $ do - it "(WalletStorage_v2) migrating back results in the original" $ property prop_backMigrate_v2 - it "(WalletStorage_v3) migrating back results in the original" $ property prop_backMigrate_v3 +spec = do + resizeTests $ do + describe "Migration to latest version can be reversed" $ do + prop + "(WalletStorage_v2) migrating back results in the original" + prop_backMigrate_v2 + prop + "(WalletStorage_v3) migrating back results in the original" + prop_backMigrate_v3 + describe "Can load the 1.1.0 database" $ do + it "can load" $ do + db <- openState False "test/wallet-db-1.1.1/" + ws <- runReaderT askWalletSnapshot db + force ws `shouldNotBe` def + -- We force it to ensure there aren't any _|_s hanging around. And + -- then we say it shouldn't be def because the thing will give you + -- back a Default of the WalletStorage if the file path doesn't + -- exist (d'oh) + where + -- The tests for migrations take an enormous amount of time, so we prune the + -- size down a bit to make it more manageable. + resizeTests = modifyMaxSize (const 15) -- This test verifies that the migration to version 2 of the wallet storage is -- reversible, and as such that we don't accidentally cause any data loss in -- the conversion. - prop_backMigrate_v2 :: WalletStorage_v2 -> Bool + prop_backMigrate_v2 :: WalletStorage_v2 -> Property prop_backMigrate_v2 ws = let WalletStorage_Back_v2 ws' = migrate . migrate $ ws - in ws == ws' + in ws === ws' - prop_backMigrate_v3 :: WalletStorage_v3 -> Bool + prop_backMigrate_v3 :: WalletStorage_v3 -> Property prop_backMigrate_v3 ws = let WalletStorage_Back_v3 ws' = migrate . migrate $ ws - in ws == ws' + in ws === ws' diff --git a/wallet/test/Test/Pos/Wallet/Web/AddressSpec.hs b/wallet/test/Test/Pos/Wallet/Web/AddressSpec.hs index af922a09041..80f70b5b2d2 100644 --- a/wallet/test/Test/Pos/Wallet/Web/AddressSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/AddressSpec.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + module Test.Pos.Wallet.Web.AddressSpec ( spec ) where @@ -17,9 +20,7 @@ import Pos.Client.Txp.Addresses (getFakeChangeAddress, getNewAddress) import Pos.Core.Common (Address) import Pos.Crypto (PassPhrase) import Pos.Launcher (HasConfigurations) -import Pos.Util.CompileInfo (HasCompileInfo, withCompileInfo) -import Pos.Util.QuickCheck.Property (assertProperty, expectedOne) import Pos.Wallet.Web.Account (GenSeed (..), genUniqueAddress) import Pos.Wallet.Web.ClientTypes (AccountId, CAccountInit (..), caId) import Pos.Wallet.Web.Error (WalletError (..)) @@ -27,12 +28,12 @@ import Pos.Wallet.Web.Methods.Logic (newAccount) import Pos.Wallet.Web.State (askWalletSnapshot, getWalletAddresses, wamAddress) import Pos.Wallet.Web.Util (decodeCTypeOrFail) import Test.Pos.Configuration (withDefConfigurations) +import Test.Pos.Util.QuickCheck.Property (assertProperty, expectedOne) import Test.Pos.Wallet.Web.Mode (WalletProperty) import Test.Pos.Wallet.Web.Util (importSingleWallet, mostlyEmptyPassphrases) spec :: Spec -spec = withCompileInfo def $ - withDefConfigurations $ \_ -> +spec = withDefConfigurations $ \_ _ -> describe "Fake address has maximal possible size" $ modifyMaxSuccess (const 10) $ do prop "getNewAddress" $ @@ -43,7 +44,7 @@ spec = withCompileInfo def $ type AddressGenerator = AccountId -> PassPhrase -> WalletProperty Address fakeAddressHasMaxSizeTest - :: (HasConfigurations, HasCompileInfo) + :: HasConfigurations => AddressGenerator -> Word32 -> WalletProperty () fakeAddressHasMaxSizeTest generator accSeed = do passphrase <- importSingleWallet mostlyEmptyPassphrases @@ -66,7 +67,7 @@ changeAddressGenerator :: HasConfigurations => AddressGenerator changeAddressGenerator accId passphrase = lift $ getNewAddress (accId, passphrase) -- | Generator which is directly used in endpoints. -commonAddressGenerator :: HasConfigurations => AddressGenerator +commonAddressGenerator :: AddressGenerator commonAddressGenerator accId passphrase = do ws <- askWalletSnapshot addrSeed <- pick arbitrary diff --git a/wallet/test/Test/Pos/Wallet/Web/Methods/BackupDefaultAddressesSpec.hs b/wallet/test/Test/Pos/Wallet/Web/Methods/BackupDefaultAddressesSpec.hs index 1c46dba1566..99a1ff17e73 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Methods/BackupDefaultAddressesSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Methods/BackupDefaultAddressesSpec.hs @@ -1,36 +1,38 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + module Test.Pos.Wallet.Web.Methods.BackupDefaultAddressesSpec ( spec ) where import Universum -import Data.Default (def) import Pos.Launcher (HasConfigurations) -import Pos.Util.CompileInfo (HasCompileInfo, withCompileInfo) -import Pos.Util.QuickCheck.Property (assertProperty) + import Pos.Wallet.Web.ClientTypes (CWallet (..)) import Pos.Wallet.Web.Methods.Restore (restoreWalletFromBackup) import Test.Hspec (Spec, describe) import Test.Hspec.QuickCheck (modifyMaxSuccess) import Test.Pos.Configuration (withDefConfigurations) +import Test.Pos.Util.QuickCheck.Property (assertProperty) import Test.Pos.Wallet.Web.Mode (walletPropertySpec) import Test.QuickCheck (Arbitrary (..)) import Test.QuickCheck.Monadic (pick) spec :: Spec -spec = withCompileInfo def $ - withDefConfigurations $ \_ -> +spec = withDefConfigurations $ \_ _ -> describe "restoreAddressFromWalletBackup" $ modifyMaxSuccess (const 10) $ do restoreWalletAddressFromBackupSpec -restoreWalletAddressFromBackupSpec :: (HasCompileInfo, HasConfigurations) => Spec -restoreWalletAddressFromBackupSpec = walletPropertySpec restoreWalletAddressFromBackupDesc $ do - walletBackup <- pick arbitrary - restoredWallet <- lift $ restoreWalletFromBackup walletBackup - let noOfAccounts = cwAccountsNumber restoredWallet - assertProperty(noOfAccounts > 0) $ "Exported wallet has no accounts!" - where - restoreWalletAddressFromBackupDesc = - "Generate wallet backup; " <> - "Restore it; " <> - "Check if the wallet has some accounts; " +restoreWalletAddressFromBackupSpec :: HasConfigurations => Spec +restoreWalletAddressFromBackupSpec = + walletPropertySpec restoreWalletAddressFromBackupDesc $ do + walletBackup <- pick arbitrary + restoredWallet <- lift $ restoreWalletFromBackup walletBackup + let noOfAccounts = cwAccountsNumber restoredWallet + assertProperty (noOfAccounts > 0) $ "Exported wallet has no accounts!" + where + restoreWalletAddressFromBackupDesc = + "Generate wallet backup; " + <> "Restore it; " + <> "Check if the wallet has some accounts; " diff --git a/wallet/test/Test/Pos/Wallet/Web/Methods/LogicSpec.hs b/wallet/test/Test/Pos/Wallet/Web/Methods/LogicSpec.hs index e11a42584bc..7910ef811a7 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Methods/LogicSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Methods/LogicSpec.hs @@ -1,31 +1,31 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + module Test.Pos.Wallet.Web.Methods.LogicSpec ( spec ) where import Universum -import Data.Default (def) import Test.Hspec (Spec, describe) import Test.Hspec.QuickCheck (prop) import Pos.Launcher (HasConfigurations) -import Pos.Util.CompileInfo (HasCompileInfo, withCompileInfo) import Pos.Wallet.Web.Methods.Logic (getAccounts, getWallets) -import Pos.Util.QuickCheck.Property (stopProperty) import Test.Pos.Configuration (withDefConfigurations) +import Test.Pos.Util.QuickCheck.Property (stopProperty) import Test.Pos.Wallet.Web.Mode (WalletProperty) -- TODO remove HasCompileInfo when MonadWalletWebMode will be splitted. spec :: Spec -spec = withCompileInfo def $ - withDefConfigurations $ \_ -> +spec = withDefConfigurations $ \_ _ -> describe "Pos.Wallet.Web.Methods" $ do prop emptyWalletOnStarts emptyWallet where emptyWalletOnStarts = "wallet must be empty on start" -emptyWallet :: (HasCompileInfo, HasConfigurations) => WalletProperty () +emptyWallet :: HasConfigurations => WalletProperty () emptyWallet = do wallets <- lift getWallets unless (null wallets) $ diff --git a/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs b/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs index e7008073a3b..f6c431fa483 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Methods/PaymentSpec.hs @@ -1,8 +1,16 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + module Test.Pos.Wallet.Web.Methods.PaymentSpec ( spec ) where -import Nub (ordNub) import Universum import Control.Exception.Safe (try) @@ -24,14 +32,12 @@ import Pos.Crypto (PassPhrase) import Pos.DB.Class (MonadGState (..)) import Pos.Launcher (HasConfigurations) import Pos.Txp (TxFee (..)) -import Pos.Util.CompileInfo (HasCompileInfo, withCompileInfo) +import Pos.Util.CompileInfo (withCompileInfo) import Pos.Wallet.Web.Account (myRootAddresses) import Pos.Wallet.Web.ClientTypes (Addr, CAccount (..), CId, CTx (..), NewBatchPayment (..), Wal) import Servant.Server (ServantErr (..), err403) -import Pos.Util.QuickCheck.Property (assertProperty, expectedOne, maybeStopProperty, - splitWord, stopProperty) import Pos.Wallet.Web.Methods.Logic (getAccounts) import Pos.Wallet.Web.Methods.Payment (newPaymentBatch) import qualified Pos.Wallet.Web.State.State as WS @@ -39,9 +45,14 @@ import Pos.Wallet.Web.State.Storage (AddressInfo (..), wamAddress) import Pos.Wallet.Web.Util (decodeCTypeOrFail, getAccountAddrsOrThrow) import Pos.Util.Servant (encodeCType) + import Test.Pos.Configuration (withDefConfigurations) +import Test.Pos.Crypto.Dummy (dummyProtocolMagic) +import Test.Pos.Util.QuickCheck.Property (assertProperty, expectedOne, maybeStopProperty, + splitWord, stopProperty) import Test.Pos.Wallet.Web.Mode (WalletProperty, getSentTxs, submitTxTestMode, walletPropertySpec) + import Test.Pos.Wallet.Web.Util (deriveRandomAddress, expectedAddrBalance, importSomeWallets, mostlyEmptyPassphrases) @@ -51,7 +62,7 @@ deriving instance Eq CTx -- TODO remove HasCompileInfo when MonadWalletWebMode will be splitted. spec :: Spec spec = withCompileInfo def $ - withDefConfigurations $ \_ -> + withDefConfigurations $ \_ _ -> describe "Wallet.Web.Methods.Payment" $ modifyMaxSuccess (const 10) $ do describe "newPaymentBatch" $ do describe "Submitting a payment when restoring" rejectPaymentIfRestoringSpec @@ -70,7 +81,7 @@ data PaymentFixture = PaymentFixture { } -- | Generic block of code to be reused across all the different payment specs. -newPaymentFixture :: (HasCompileInfo, HasConfigurations) => WalletProperty PaymentFixture +newPaymentFixture :: HasConfigurations => WalletProperty PaymentFixture newPaymentFixture = do passphrases <- importSomeWallets mostlyEmptyPassphrases let l = length passphrases @@ -84,7 +95,7 @@ newPaymentFixture = do let walId = rootsWIds !! idx let pswd = passphrases !! idx let noOneAccount = sformat ("There is no one account for wallet: "%build) walId - srcAccount <- maybeStopProperty noOneAccount =<< (lift $ head <$> getAccounts (Just walId)) + srcAccount <- maybeStopProperty noOneAccount =<< (lift $ (fmap fst . uncons) <$> getAccounts (Just walId)) srcAccId <- lift $ decodeCTypeOrFail (caId srcAccount) ws <- WS.askWalletSnapshot @@ -109,15 +120,14 @@ newPaymentFixture = do -- | Assess that if we try to submit a payment when the wallet is restoring, -- the backend prevents us from doing that. -rejectPaymentIfRestoringSpec :: (HasCompileInfo, HasConfigurations) => Spec +rejectPaymentIfRestoringSpec :: HasConfigurations => Spec rejectPaymentIfRestoringSpec = walletPropertySpec "should fail with 403" $ do PaymentFixture{..} <- newPaymentFixture - res <- lift $ try (newPaymentBatch submitTxTestMode pswd batch) + res <- lift $ try (newPaymentBatch dummyProtocolMagic submitTxTestMode pswd batch) liftIO $ shouldBe res (Left (err403 { errReasonPhrase = "Transaction creation is disabled when the wallet is restoring." })) - -- | Test one single, successful payment. -oneNewPaymentBatchSpec :: (HasCompileInfo, HasConfigurations) => Spec +oneNewPaymentBatchSpec :: HasConfigurations => Spec oneNewPaymentBatchSpec = walletPropertySpec oneNewPaymentBatchDesc $ do PaymentFixture{..} <- newPaymentFixture @@ -126,7 +136,7 @@ oneNewPaymentBatchSpec = walletPropertySpec oneNewPaymentBatchDesc $ do randomSyncTip <- liftIO $ generate arbitrary WS.setWalletSyncTip db walId randomSyncTip - void $ lift $ newPaymentBatch submitTxTestMode pswd batch + void $ lift $ newPaymentBatch dummyProtocolMagic submitTxTestMode pswd batch dstAddrs <- lift $ mapM decodeCTypeOrFail dstCAddrs txLinearPolicy <- lift $ (bvdTxFeePolicy <$> gsAdoptedBVData) <&> \case TxFeePolicyTxSizeLinear linear -> linear diff --git a/wallet/test/Test/Pos/Wallet/Web/Mode.hs b/wallet/test/Test/Pos/Wallet/Web/Mode.hs index 01e065a6072..cc775ba3713 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Mode.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Mode.hs @@ -1,6 +1,14 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS -fno-warn-unused-top-binds #-} -- for lenses -- | Module which provides `MonadWalletWebMode` instance for tests @@ -45,7 +53,6 @@ import Pos.Client.Txp.Addresses (MonadAddresses (..)) import Pos.Client.Txp.Balances (MonadBalances (..)) import Pos.Client.Txp.History (MonadTxHistory (..), getBlockHistoryDefault, getLocalHistoryDefault, saveTxDefault) -import Pos.Configuration (HasNodeConfiguration) import Pos.Context (ConnectedPeers (..)) import Pos.Core (HasConfiguration, Timestamp (..), largestHDAddressBoot) import Pos.Core.Txp (TxAux) @@ -58,48 +65,47 @@ import Pos.DB.Pure (DBPureVar) import Pos.Delegation (DelegationVar, HasDlgConfiguration) import Pos.Generator.Block (BlockGenMode) import qualified Pos.GState as GS -import Pos.KnownPeers (MonadFormatPeers (..), MonadKnownPeers (..)) +import Pos.Infra.Network.Types (HasNodeType (..), NodeType (..)) +import Pos.Infra.Reporting (MonadReporting (..)) +import Pos.Infra.Shutdown (HasShutdownContext (..), ShutdownContext (..)) +import Pos.Infra.Slotting (HasSlottingVar (..), MonadSlots (..), MonadSlotsData, + SimpleSlottingStateVar, mkSimpleSlottingStateVar) +import Pos.Infra.StateLock (StateLock, StateLockMetrics (..), newStateLock) +import Pos.Infra.Util.JsonLog.Events (HasJsonLogConfig (..), JsonLogConfig (..), + MemPoolModifyReason, jsonLogDefault) +import Pos.Infra.Util.TimeWarp (CanJsonLog (..)) import Pos.Launcher (HasConfigurations) import Pos.Lrc (LrcContext) -import Pos.Network.Types (HasNodeType (..), NodeType (..)) -import Pos.Reporting (HasReportingContext (..)) -import Pos.Shutdown (HasShutdownContext (..), ShutdownContext (..)) -import Pos.Slotting (HasSlottingVar (..), MonadSlots (..), MonadSlotsData, - SimpleSlottingStateVar, mkSimpleSlottingStateVar) -import Pos.Ssc.Configuration (HasSscConfiguration) import Pos.Ssc.Mem (SscMemTag) import Pos.Ssc.Types (SscState) -import Pos.StateLock (StateLock, StateLockMetrics (..), newStateLock) import Pos.Txp (GenericTxpLocalData, MempoolExt, MonadTxpLocal (..), TxpGlobalSettings, - TxpHolderTag, txNormalize, txProcessTransactionNoLock, txpTip) + TxpHolderTag, recordTxpMetrics, txNormalize, txProcessTransactionNoLock, + txpMemPool, txpTip) import Pos.Update.Context (UpdateContext) import Pos.Util (postfixLFields) -import Pos.Util.CompileInfo (HasCompileInfo) -import Pos.Util.JsonLog (HasJsonLogConfig (..), JsonLogConfig (..), jsonLogDefault) import Pos.Util.LoggerName (HasLoggerName' (..), askLoggerNameDefault, modifyLoggerNameDefault) -import Pos.Util.TimeWarp (CanJsonLog (..)) import Pos.Util.UserSecret (HasUserSecret (..), UserSecret) import Pos.Util.Util (HasLens (..)) import Pos.Wallet.Redirect (applyLastUpdateWebWallet, blockchainSlotDurationWebWallet, connectedPeersWebWallet, localChainDifficultyWebWallet, networkChainDifficultyWebWallet, txpNormalizeWebWallet, txpProcessTxWebWallet, waitForUpdateWebWallet) +import qualified System.Metrics as Metrics import Pos.Wallet.WalletMode (MonadBlockchainInfo (..), MonadUpdates (..), WalletMempoolExt) import Pos.Wallet.Web.ClientTypes (AccountId) import Pos.Wallet.Web.Mode (getBalanceDefault, getNewAddressWebWallet, getOwnUtxosDefault) -import Pos.Wallet.Web.State (WalletDB, WalletDbReader, openMemState) +import Pos.Wallet.Web.State (WalletDB, openMemState) import Pos.Wallet.Web.Tracking.BListener (onApplyBlocksWebWallet, onRollbackBlocksWebWallet) import Pos.Wallet.Web.Tracking.Types (SyncQueue) import Test.Pos.Block.Logic.Emulation (Emulation (..), runEmulation) import Test.Pos.Block.Logic.Mode (BlockTestContext (..), BlockTestContextTag, - HasTestParams (..), TestParams (..), - btcReportingContextL, btcSystemStartL, btcTxpMemL, - currentTimeSlottingTestDefault, + HasTestParams (..), TestParams (..), btcSystemStartL, + btcTxpMemL, currentTimeSlottingTestDefault, getCurrentSlotBlockingTestDefault, getCurrentSlotInaccurateTestDefault, getCurrentSlotTestDefault, initBlockTestContext) @@ -146,6 +152,8 @@ data WalletTestContext = WalletTestContext , wtcStateLock :: !StateLock -- ^ A lock which manages access to shared resources. -- Stored hash is a hash of last applied block. + , wtcStateLockMetrics :: !(StateLockMetrics MemPoolModifyReason) + -- ^ A set of callbacks for 'StateLock'. , wtcShutdownContext :: !ShutdownContext -- ^ Stub , wtcConnectedPeers :: !ConnectedPeers @@ -171,9 +179,7 @@ getSentTxs = atomically . readTVar =<< view wtcSentTxs_L initWalletTestContext :: ( HasConfiguration - , HasSscConfiguration , HasDlgConfiguration - , HasNodeConfiguration ) => WalletTestParams -> (WalletTestContext -> Emulation a) @@ -187,6 +193,8 @@ initWalletTestContext WalletTestParams {..} callback = -- some kind of kostil to get tip tip <- readTVarIO $ txpTip $ btcTxpMem wtcBlockTestContext wtcStateLock <- newStateLock tip + store <- liftIO $ Metrics.newStore + wtcStateLockMetrics <- liftIO $ recordTxpMetrics store (txpMemPool $ btcTxpMem wtcBlockTestContext) wtcShutdownContext <- ShutdownContext <$> STM.newTVarIO False wtcConnectedPeers <- ConnectedPeers <$> STM.newTVarIO mempty wtcLastKnownHeader <- STM.newTVarIO Nothing @@ -198,9 +206,7 @@ initWalletTestContext WalletTestParams {..} callback = runWalletTestMode :: ( HasConfiguration - , HasSscConfiguration , HasDlgConfiguration - , HasNodeConfiguration ) => WalletTestParams -> WalletTestMode a @@ -220,7 +226,7 @@ type WalletProperty = PropertyM WalletTestMode -- | Convert 'WalletProperty' to 'Property' using given generator of -- 'WalletTestParams'. walletPropertyToProperty - :: (HasConfiguration, HasSscConfiguration, HasDlgConfiguration, HasNodeConfiguration) + :: (HasConfiguration, HasDlgConfiguration, Testable a) => Gen WalletTestParams -> WalletProperty a -> Property @@ -228,16 +234,17 @@ walletPropertyToProperty wtpGen walletProperty = forAll wtpGen $ \wtp -> monadic (ioProperty . runWalletTestMode wtp) walletProperty -instance (HasConfiguration, HasSscConfiguration, HasDlgConfiguration, HasNodeConfiguration) +instance (HasConfiguration, HasDlgConfiguration, Testable a) => Testable (WalletProperty a) where property = walletPropertyToProperty arbitrary walletPropertySpec :: - (HasConfiguration, HasSscConfiguration, HasDlgConfiguration, HasNodeConfiguration) + (HasConfiguration, HasDlgConfiguration, Testable a) => String -> (HasConfiguration => WalletProperty a) -> Spec -walletPropertySpec description wp = prop description (walletPropertyToProperty arbitrary wp) +walletPropertySpec description wp = + prop description (walletPropertyToProperty arbitrary wp) ---------------------------------------------------------------------------- -- Instances derived from BlockTestContext @@ -290,9 +297,6 @@ instance HasUserSecret WalletTestContext where instance HasLens UpdateContext WalletTestContext UpdateContext where lensOf = wtcBlockTestContext_L . lensOf @UpdateContext -instance HasReportingContext WalletTestContext where - reportingContext = wtcBlockTestContext_L . btcReportingContextL - instance HasJsonLogConfig WalletTestContext where jsonLogConfig = lens (const JsonLogDisabled) const @@ -327,12 +331,6 @@ instance HasConfiguration => MonadDB WalletTestMode where instance HasConfiguration => MonadGState WalletTestMode where gsAdoptedBVData = gsAdoptedBVDataDefault -instance MonadFormatPeers WalletTestMode where - formatKnownPeers _ = pure Nothing - -instance MonadKnownPeers WalletTestMode where - updatePeersBucket _ _ = pure True - ---------------------------------------------------------------------------- -- Wallet instances ---------------------------------------------------------------------------- @@ -364,19 +362,12 @@ instance HasNodeType WalletTestContext where getNodeType _ = NodeCore -- doesn't really matter, it's for reporting -- TODO may be used for callback on tx processing in future. -instance HasLens StateLockMetrics WalletTestContext StateLockMetrics where - lensOf = lens (const emptyStateMetrics) const - where - emptyStateMetrics = StateLockMetrics - { slmWait = const $ pure () - , slmAcquire = const $ const $ pure () - , slmRelease = const $ const $ pure () - } - -instance HasConfigurations => WalletDbReader WalletTestContext WalletTestMode - --- TODO remove HasCompileInfo here --- when getNewAddressWebWallet won't require MonadWalletWebMode +instance HasLens (StateLockMetrics MemPoolModifyReason) WalletTestContext (StateLockMetrics MemPoolModifyReason) where + lensOf = wtcStateLockMetrics_L + +-- This never made any sense. WalletDbReader is a type synonym. +-- instance WalletDbReader WalletTestContext WalletTestMode + instance HasConfigurations => MonadAddresses WalletTestMode where type AddrData WalletTestMode = (AccountId, PassPhrase) getNewAddress = getNewAddressWebWallet @@ -388,7 +379,7 @@ instance MonadKeysRead WalletTestMode where instance MonadKeys WalletTestMode where modifySecret = modifySecretPureDefault -instance (HasCompileInfo, HasConfigurations) => MonadTxHistory WalletTestMode where +instance (HasConfigurations) => MonadTxHistory WalletTestMode where getBlockHistory = getBlockHistoryDefault getLocalHistory = getLocalHistoryDefault saveTx = saveTxDefault @@ -401,7 +392,7 @@ instance MonadUpdates WalletTestMode where waitForUpdate = waitForUpdateWebWallet applyLastUpdate = applyLastUpdateWebWallet -instance (HasCompileInfo, HasConfigurations) => MonadBListener WalletTestMode where +instance (HasConfigurations) => MonadBListener WalletTestMode where onApplyBlocks = onApplyBlocksWebWallet onRollbackBlocks = onRollbackBlocksWebWallet @@ -413,15 +404,18 @@ instance HasConfiguration => MonadBlockchainInfo WalletTestMode where type instance MempoolExt WalletTestMode = WalletMempoolExt -instance (HasCompileInfo, HasConfigurations) +instance (HasConfigurations) => MonadTxpLocal (BlockGenMode WalletMempoolExt WalletTestMode) where txpNormalize = txNormalize txpProcessTx = txProcessTransactionNoLock -instance (HasCompileInfo, HasConfigurations) => MonadTxpLocal WalletTestMode where +instance (HasConfigurations) => MonadTxpLocal WalletTestMode where txpNormalize = txpNormalizeWebWallet txpProcessTx = txpProcessTxWebWallet submitTxTestMode :: TxAux -> WalletTestMode Bool submitTxTestMode txAux = True <$ (asks wtcSentTxs >>= atomically . flip STM.modifyTVar (txAux:)) + +instance MonadReporting WalletTestMode where + report = const (pure ()) diff --git a/wallet/test/Test/Pos/Wallet/Web/Tracking/SyncSpec.hs b/wallet/test/Test/Pos/Wallet/Web/Tracking/SyncSpec.hs index 062efb794ff..044d9d3f99e 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Tracking/SyncSpec.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Tracking/SyncSpec.hs @@ -1,14 +1,18 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + module Test.Pos.Wallet.Web.Tracking.SyncSpec ( spec ) where import Universum -import Data.Default (def) import qualified Data.HashSet as HS -import Data.List ((\\), intersect) +import Data.List (intersect, (\\)) import Pos.Client.KeyStorage (getSecretKeysPlain) -import Test.Hspec (Spec, describe) +import Test.Hspec (Spec, describe, xdescribe) import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) import Test.QuickCheck (Arbitrary (..), Property, choose, oneof, sublistOf, suchThat, vectorOf, (===)) @@ -17,27 +21,34 @@ import Test.QuickCheck.Monadic (pick) import Pos.Arbitrary.Wallet.Web.ClientTypes () import Pos.Block.Logic (rollbackBlocks) import Pos.Core (Address, BlockCount (..), blkSecurityParam) +import Pos.Core.Chrono (nonEmptyOldestFirst, toNewestFirst) import Pos.Crypto (emptyPassphrase) import Pos.Launcher (HasConfigurations) -import Pos.Util.Chrono (nonEmptyOldestFirst, toNewestFirst) -import Pos.Util.CompileInfo (HasCompileInfo, withCompileInfo) -import Pos.Util.QuickCheck.Property (assertProperty) + import qualified Pos.Wallet.Web.State as WS import Pos.Wallet.Web.State.Storage (WalletStorage (..)) import Pos.Wallet.Web.Tracking.Decrypt (eskToWalletDecrCredentials) import Pos.Wallet.Web.Tracking.Sync (evalChange, syncWalletWithBlockchain) import Pos.Wallet.Web.Tracking.Types (newSyncRequest) + +-- import Pos.Wallet.Web.ClientTypes () +-- import qualified Pos.Wallet.Web.State.State as WS +-- import Pos.Wallet.Web.State.Storage (WalletStorage (..)) +-- import Pos.Wallet.Web.Tracking.Sync (evalChange) + + import Test.Pos.Block.Logic.Util (EnableTxPayload (..), InplaceDB (..)) import Test.Pos.Configuration (withDefConfigurations) - +import Test.Pos.Crypto.Dummy (dummyProtocolMagic) +import Test.Pos.Util.QuickCheck.Property (assertProperty) import Test.Pos.Wallet.Web.Mode (walletPropertySpec) import Test.Pos.Wallet.Web.Util (importSomeWallets, wpGenBlocks) spec :: Spec -spec = withCompileInfo def $ withDefConfigurations $ \_ -> do +spec = withDefConfigurations $ \_ _ -> do describe "Pos.Wallet.Web.Tracking.BListener" $ modifyMaxSuccess (const 10) $ do describe "Two applications and rollbacks" twoApplyTwoRollbacksSpec - describe "Pos.Wallet.Web.Tracking.evalChange" $ do + xdescribe "Pos.Wallet.Web.Tracking.evalChange (pending, CSL-2473)" $ do prop evalChangeDiffAccountsDesc evalChangeDiffAccounts prop evalChangeSameAccountsDesc evalChangeSameAccounts where @@ -46,7 +57,7 @@ spec = withCompileInfo def $ withDefConfigurations $ \_ -> do evalChangeSameAccountsDesc = "Outgoing transaction from account to the same account." -twoApplyTwoRollbacksSpec :: (HasCompileInfo, HasConfigurations) => Spec +twoApplyTwoRollbacksSpec :: HasConfigurations => Spec twoApplyTwoRollbacksSpec = walletPropertySpec twoApplyTwoRollbacksDesc $ do let k = fromIntegral blkSecurityParam :: Word64 -- During these tests we need to manually switch back to the old synchronous @@ -59,16 +70,22 @@ twoApplyTwoRollbacksSpec = walletPropertySpec twoApplyTwoRollbacksDesc $ do genesisWalletDB <- lift WS.askWalletSnapshot applyBlocksCnt1 <- pick $ choose (1, k `div` 2) applyBlocksCnt2 <- pick $ choose (1, k `div` 2) - blunds1 <- wpGenBlocks (Just $ BlockCount applyBlocksCnt1) (EnableTxPayload True) (InplaceDB True) + blunds1 <- wpGenBlocks dummyProtocolMagic + (Just $ BlockCount applyBlocksCnt1) + (EnableTxPayload True) + (InplaceDB True) after1ApplyDB <- lift WS.askWalletSnapshot - blunds2 <- wpGenBlocks (Just $ BlockCount applyBlocksCnt2) (EnableTxPayload True) (InplaceDB True) + blunds2 <- wpGenBlocks dummyProtocolMagic + (Just $ BlockCount applyBlocksCnt2) + (EnableTxPayload True) + (InplaceDB True) after2ApplyDB <- lift WS.askWalletSnapshot let toNE = fromMaybe (error "sequence of blocks are empty") . nonEmptyOldestFirst let to1Rollback = toNewestFirst $ toNE blunds2 let to2Rollback = toNewestFirst $ toNE blunds1 - lift $ rollbackBlocks to1Rollback + lift $ rollbackBlocks dummyProtocolMagic to1Rollback after1RollbackDB <- lift WS.askWalletSnapshot - lift $ rollbackBlocks to2Rollback + lift $ rollbackBlocks dummyProtocolMagic to2Rollback after2RollbackDB <- lift WS.askWalletSnapshot assertProperty (after1RollbackDB == after1ApplyDB) "wallet-db after first apply doesn't equal to wallet-db after first rollback" @@ -119,6 +136,10 @@ evalChangeDiffAccounts :: AddressesFromDiffAccounts -> Property evalChangeDiffAccounts (AddressesFromDiffAccounts InpOutUsedAddresses {..}) = changeAddrs === HS.fromList (evalChange usedAddrs inpAddrs outAddrs False) +-- | newtype defined so that its Arbitrary instance can set the stage for +-- 'evalChangeSameAccounts'. The 'changeAddrs' field will always be set so +-- that it should equal +-- 'HS.fromList (evalChange usedAddrs inpAddrs outAddrs True)'. newtype AddressesFromSameAccounts = AddressesFromSameAccounts InpOutChangeUsedAddresses deriving Show @@ -126,17 +147,37 @@ instance Arbitrary AddressesFromSameAccounts where arbitrary = do wId <- arbitrary accIdx <- arbitrary - let genAddrs n = map (uncurry $ WS.WAddressMeta wId accIdx) <$> vectorOf n arbitrary - inpAddrs <- choose (1, 5) >>= genAddrs - outAddrs <- choose (1, 5) >>= genAddrs - usedBase <- (inpAddrs ++) <$> (choose (1, 10) >>= flip vectorOf arbitrary) + -- generate n WAddressMeta terms each with the same wallet and account + -- identifier ('wId' and 'accIdx' above) subject to a predicate. + -- That predicate allows us to ensure that the output address + -- ('outAddrs') are disjiont under 'WAddressMeta' equality from the + -- input addresses, which is essential for the test. + let genAddrs p n = vectorOf n $ + (uncurry (WS.WAddressMeta wId accIdx) <$> arbitrary) + `suchThat` p + inpAddrs <- choose (1, 5) >>= genAddrs (const True) + outAddrs <- choose (1, 5) >>= genAddrs (not . flip elem inpAddrs) + -- Throw on a bunch of arbitrary extra used addresses, but make sure + -- they are not 'WAddressMeta'-equal to any existing ones! + usedBase <- (inpAddrs ++) <$> (do + n <- choose (1, 10) + let allAddrs = inpAddrs ++ outAddrs + condition = not . flip elem allAddrs + vectorOf n $ arbitrary `suchThat` condition) (changeAddrs, extraUsed) <- oneof [ -- Case when all outputs addresses are fresh and - -- weren't mentioned in the blockchain + -- weren't mentioned in the blockchain. + -- Change addresses should be empty. pure (mempty, []) + -- Otherwise, there's at least one non-change address in the + -- outputs. Every address that we don't put into the second + -- component (which goes into the set of all used) should appear as + -- a change address. , do - if length outAddrs == 1 then pure (mempty, []) + if length outAddrs == 1 + then pure (mempty, []) else do + -- Problem case is when ext is all of 'outAddrs'. ext <- sublistOf outAddrs `suchThat` (not . null) pure (HS.fromList $ map (view WS.wamAddress) (outAddrs \\ ext), ext) ] diff --git a/wallet/test/Test/Pos/Wallet/Web/Util.hs b/wallet/test/Test/Pos/Wallet/Web/Util.hs index a8444d867a6..3d9c9f1b863 100644 --- a/wallet/test/Test/Pos/Wallet/Web/Util.hs +++ b/wallet/test/Test/Pos/Wallet/Web/Util.hs @@ -1,5 +1,11 @@ -- | Useful functions for testing scenarios. +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + module Test.Pos.Wallet.Web.Util ( -- * Block utils @@ -19,11 +25,10 @@ module Test.Pos.Wallet.Web.Util ) where import Universum -import Unsafe (unsafeHead) import Control.Concurrent.STM (writeTVar) import Control.Monad.Random.Strict (evalRandT) -import Data.List ((!!)) +import Data.List (head, (!!)) import qualified Data.Map as M import Formatting (build, sformat, (%)) import Test.QuickCheck (Arbitrary (..), choose, frequency, sublistOf, suchThat, vectorOf) @@ -36,25 +41,27 @@ import Pos.Client.Txp.Balances (getBalance) import Pos.Core (Address, BlockCount, Coin, HasConfiguration, genesisSecretsPoor, headerHashG) import Pos.Core.Block (blockHeader) +import Pos.Core.Chrono (OldestFirst (..)) import Pos.Core.Common (IsBootstrapEraAddr (..), deriveLvl2KeyPair) import Pos.Core.Genesis (poorSecretToEncKey) import Pos.Core.Txp (TxIn, TxOut (..), TxOutAux (..)) -import Pos.Crypto (EncryptedSecretKey, PassPhrase, ShouldCheckPassphrase (..), - emptyPassphrase, firstHardened) +import Pos.Crypto (EncryptedSecretKey, PassPhrase, ProtocolMagic, + ShouldCheckPassphrase (..), emptyPassphrase, firstHardened) import Pos.Generator.Block (genBlocks) +import Pos.Infra.StateLock (Priority (..), modifyStateLock) import Pos.Launcher (HasConfigurations) -import Pos.StateLock (Priority (..), modifyStateLock) import Pos.Txp.Toil (Utxo) import Pos.Util (HasLens (..), _neLast) -import Pos.Util.Chrono (OldestFirst (..)) -import Pos.Util.CompileInfo (HasCompileInfo) -import Pos.Util.QuickCheck.Property (assertProperty, maybeStopProperty) + import Pos.Util.Servant (encodeCType) import Pos.Util.UserSecret (mkGenesisWalletUserSecret) import Pos.Wallet.Web.ClientTypes (Addr, CId, Wal, encToCId) import Pos.Wallet.Web.Methods.Restore (importWalletDo) +import Pos.Infra.Util.JsonLog.Events (MemPoolModifyReason (ApplyBlock)) import Test.Pos.Block.Logic.Util (EnableTxPayload, InplaceDB, genBlockGenParams) +import Test.Pos.Txp.Arbitrary () +import Test.Pos.Util.QuickCheck.Property (assertProperty, maybeStopProperty) import Test.Pos.Wallet.Web.Mode (WalletProperty) ---------------------------------------------------------------------------- @@ -63,16 +70,17 @@ import Test.Pos.Wallet.Web.Mode (WalletProperty) -- | Gen blocks in WalletProperty wpGenBlocks - :: (HasCompileInfo, HasConfigurations) - => Maybe BlockCount + :: HasConfigurations + => ProtocolMagic + -> Maybe BlockCount -> EnableTxPayload -> InplaceDB -> WalletProperty (OldestFirst [] Blund) -wpGenBlocks blkCnt enTxPayload inplaceDB = do - params <- genBlockGenParams blkCnt enTxPayload inplaceDB +wpGenBlocks pm blkCnt enTxPayload inplaceDB = do + params <- genBlockGenParams pm blkCnt enTxPayload inplaceDB g <- pick $ MkGen $ \qc _ -> qc - lift $ modifyStateLock HighPriority "wpGenBlocks" $ \prevTip -> do - blunds <- OldestFirst <$> evalRandT (genBlocks params maybeToList) g + lift $ modifyStateLock HighPriority ApplyBlock $ \prevTip -> do -- FIXME is ApplyBlock the right one? + blunds <- OldestFirst <$> evalRandT (genBlocks pm params maybeToList) g case nonEmpty $ getOldestFirst blunds of Just nonEmptyBlunds -> do let tipBlockHeader = nonEmptyBlunds ^. _neLast . _1 . blockHeader @@ -82,11 +90,12 @@ wpGenBlocks blkCnt enTxPayload inplaceDB = do Nothing -> pure (prevTip, blunds) wpGenBlock - :: (HasCompileInfo, HasConfigurations) - => EnableTxPayload + :: HasConfigurations + => ProtocolMagic + -> EnableTxPayload -> InplaceDB -> WalletProperty Blund -wpGenBlock = fmap (unsafeHead . toList) ... wpGenBlocks (Just 1) +wpGenBlock pm = fmap (Data.List.head . toList) ... wpGenBlocks pm (Just 1) ---------------------------------------------------------------------------- -- Wallet test helpers @@ -95,7 +104,7 @@ wpGenBlock = fmap (unsafeHead . toList) ... wpGenBlocks (Just 1) -- | Import some nonempty set, but not bigger than given number of elements, of genesis secrets. -- Returns corresponding passphrases. importWallets - :: (HasConfigurations, HasCompileInfo) + :: HasConfigurations => Int -> Gen PassPhrase -> WalletProperty [PassPhrase] importWallets numLimit passGen = do let secrets = @@ -113,15 +122,15 @@ importWallets numLimit passGen = do pure passphrases importSomeWallets - :: (HasConfigurations, HasCompileInfo) + :: HasConfigurations => Gen PassPhrase -> WalletProperty [PassPhrase] importSomeWallets = importWallets 10 importSingleWallet - :: (HasConfigurations, HasCompileInfo) + :: HasConfigurations => Gen PassPhrase -> WalletProperty PassPhrase importSingleWallet passGen = - fromMaybe (error "No wallets imported") . head <$> importWallets 1 passGen + fromMaybe (error "No wallets imported") . (fmap fst . uncons) <$> importWallets 1 passGen mostlyEmptyPassphrases :: Gen PassPhrase mostlyEmptyPassphrases = diff --git a/wallet/test/wallet-db-1.1.1/checkpoints-0000000000.log b/wallet/test/wallet-db-1.1.1/checkpoints-0000000000.log new file mode 100644 index 00000000000..02dee07e77e Binary files /dev/null and b/wallet/test/wallet-db-1.1.1/checkpoints-0000000000.log differ diff --git a/wallet/test/wallet-db-1.1.1/checkpoints-0000000001.log b/wallet/test/wallet-db-1.1.1/checkpoints-0000000001.log new file mode 100644 index 00000000000..e69de29bb2d diff --git a/wallet/test/wallet-db-1.1.1/checkpoints.version b/wallet/test/wallet-db-1.1.1/checkpoints.version new file mode 100644 index 00000000000..1c16bd1a419 --- /dev/null +++ b/wallet/test/wallet-db-1.1.1/checkpoints.version @@ -0,0 +1 @@ +0.14.2 \ No newline at end of file diff --git a/wallet/test/wallet-db-1.1.1/events-0000000000.log b/wallet/test/wallet-db-1.1.1/events-0000000000.log new file mode 100644 index 00000000000..aa4ea998b25 Binary files /dev/null and b/wallet/test/wallet-db-1.1.1/events-0000000000.log differ diff --git a/wallet/test/wallet-db-1.1.1/events-0000000006.log b/wallet/test/wallet-db-1.1.1/events-0000000006.log new file mode 100644 index 00000000000..e69de29bb2d diff --git a/wallet/test/wallet-db-1.1.1/events.version b/wallet/test/wallet-db-1.1.1/events.version new file mode 100644 index 00000000000..1c16bd1a419 --- /dev/null +++ b/wallet/test/wallet-db-1.1.1/events.version @@ -0,0 +1 @@ +0.14.2 \ No newline at end of file diff --git a/wallet/test/wallet-db-1.1.1/open b/wallet/test/wallet-db-1.1.1/open new file mode 100644 index 00000000000..e69de29bb2d