chainweb-mining-client 0.2 → 0.5
raw patch · 22 files changed
+3478/−225 lines, 22 filesdep +QuickCheckdep +attoparsecdep +base16-bytestringdep −containersdep ~basedep ~hostaddresssetup-changed
Dependencies added: QuickCheck, attoparsec, base16-bytestring, clock, quickcheck-instances, streaming-commons, sydtest
Dependencies removed: containers
Dependency ranges changed: base, hostaddress
Files
- CHANGELOG.md +20/−0
- README.md +312/−7
- Setup.hs +3/−1
- chainweb-mining-client.cabal +69/−15
- main/Main.hs +89/−48
- src/JsonRpc.hs +216/−0
- src/Logger.hs +17/−13
- src/Target.hs +370/−0
- src/Utils.hs +403/−0
- src/Worker.hs +26/−28
- src/Worker/CPU.hs +43/−107
- src/Worker/External.hs +3/−3
- src/Worker/Simulation.hs +2/−3
- src/Worker/Stratum.hs +129/−0
- src/Worker/Stratum/Protocol.hs +515/−0
- src/Worker/Stratum/Server.hs +700/−0
- src/WorkerUtils.hs +165/−0
- test/Main.hs +53/−0
- test/Test/Target.hs +143/−0
- test/Test/Utils.hs +65/−0
- test/Test/WorkerUtils.hs +97/−0
- test/TestUtils.hs +38/−0
CHANGELOG.md view
@@ -1,5 +1,25 @@ # Revision history for chainweb-mining-client +## 0.5 -- 2022-11-23++* Add `--stratum-rate` option, which specifies the mining rate (in+ milliseconds) at which each worker thread emits new mining jobs to the+ client.++* Change default value for thread count to 2.+* Change default to connect to chainweb-node over an unsecure connection.+* Change default to require valid certificates when TLS is enabled.+* Change default chainweb-node host address to use port 1848.++## 0.4 -- 2021-11-29++* Add `--account` command line option for specifying the mining account. The+ default value is public miner key prefix with `:k` (k-account).++## 0.3 -- 2021-11-10++* Add stratum server (#9)+ ## 0.2 -- 2020-08-20 * Rename package into chainweb-mining-client
README.md view
@@ -1,10 +1,315 @@-A mining client for Kadena Chainweb. It supports+# Mining Client for Kadena +A mining client for Kadena's chainweb node mining API. It supports++* mining with ASICs through a stratum server,+* simulated mining for testing, * multi threaded CPU mining,-* external mining workers (e.g. a GPU),-* simulated mining for testing.+* external mining workers (e.g. a GPU). -Competitive mining on the Kadena Chainweb Mainnet requires special mining-hardware, which usually comes with its own mining client and mining pool-support implementations. This generic mining client is intended mostly for-testing.+*Competitive mining on the Kadena Mainnet requires special mining hardware+(ASIC), which connects to a Stratum Server from where it obtains work.*++*All other mining modes (GPU, CPU, and simulation) are intended only for testing.*++* [Installation](#installation)+* [Usage](#usage)+* [Usage Examples](#usage-examples)+ * [Generating a New Key Pair](#generating-a-new-key-pair)+ * [Mining on Mainnet With an ASIC](#mining-on-mainnet-with-an-asic)+ * [CPU Mining](#cpu-mining)+ * [GPU Mining](#gpu-mining)+ * [Creating a Configuration File](#creating-a-configuration-file)+* [Related Resources](#related-resources)++## Installation++A docker image of the latest version is available at+`ghcr.io/kadena-io/chainweb-mining-client:lastest`.++Binaries can also be compiled with a recent version of GHC and cabal directly+from [Hackage](https://hackage.haskell.org/package/chainweb-mining-client)++```sh+cabal install chainweb-mining-client+```++or from the GitHub sources++```sh+git clone https://github.com/kadena-io/chainweb-mining-client/+cd chainweb-mining-client+cabal build+cabal run chainweb-mining-client -- --help+```++## Usage++Calling `chainweb-mining-client --help` provides an overview of the available+usage options:++```txt+Usage: chainweb-mining-client [--info] [--long-info] [-v|--version] [--license]+ [-?|-h|--help]+ [--print-config-as full|minimal|diff |+ --print-config] [--config-file FILE]+ [-r|--hash-rate ARG] [-n|--node DOMAIN:PORT]+ [(-t|--tls) | --no-tls]+ [(-x|--insecure) | --no-insecure]+ [-k|--public-key ARG] [-a|--account ARG]+ [-c|--thread-count ARG]+ [--generate-key | --no-generate-key]+ [-l|--log-level error|warn|info|debug]+ [-w|--worker cpu|external|simulation|stratum]+ [--external-worker-cmd ARG] [--stratum-port ARG]+ [--stratum-interface ARG]+ [--stratum-difficulty ARG] [-s|--stratum-rate ARG]++ Kadena Chainweb Mining Client++Available options:+ --info Print program info message and exit+ --long-info Print detailed program info message and exit+ -v,--version Print version string and exit+ --license Print license of the program and exit+ -?,-h,--help Show this help message+ --print-config-as full|minimal|diff+ Print the parsed configuration to standard out and+ exit+ --print-config Print the parsed configuration to standard out and+ exit. This is an alias for --print-config-as=full+ --config-file FILE Configuration file in YAML or JSON format. If more+ than a single config file option is present files are+ loaded in the order in which they appear on the+ command line.+ -r,--hash-rate ARG hashes per second (only relevant for mining+ simulation, ignored by the cpu worker)+ -n,--node DOMAIN:PORT node to which to connect+ -t,--tls use TLS to connect to node+ --no-tls unset flag tls+ -x,--insecure accept self-signed TLS certificates+ --no-insecure unset flag insecure+ -k,--public-key ARG public-key for the mining rewards account+ -a,--account ARG account for the mining rewards (default: public-key+ prefixed with 'k:')+ -c,--thread-count ARG number of concurrent mining threads+ --generate-key Generate a new key pair and exit+ --no-generate-key unset flag generate-key+ -l,--log-level error|warn|info|debug+ Level at which log messages are written to the+ console+ -w,--worker cpu|external|simulation|stratum+ The type of mining worker that is used+ --external-worker-cmd ARG+ command that is used to call an external worker. When+ the command is called the target value is added as+ last parameter to the command line.+ --stratum-port ARG the port on which the stratum server listens+ --stratum-interface ARG network interface that the stratum server binds to+ --stratum-difficulty ARG How the difficulty for stratum mining shares is+ choosen. Possible values are "block" for using the+ block target of the most most recent notification of+ new work, or number between 0 and 256 for specifiying+ a fixed difficulty as logarithm of base 2 (number of+ leading zeros).+ -s,--stratum-rate ARG Rate (in milliseconds) at which a stratum worker+ thread emits jobs.++Configurations are loaded in order from the following sources:+ 1. Configuration files from locations provided through --config-file options+ in the order as they appear.+ 2. Command line options.++Configuration file locations can be either local file system paths or remote+HTTP or HTTPS URLs. Remote URLs must start with either "http://" or "https://".++Configuration settings that are loaded later overwrite settings that were loaded+before.+```++## Usage Examples++### Generating a New Key Pair++```sh+chainweb-mining-client --generate-key+```++This outputs a public and a private key. The public key is given to the mining+client. The private key must be kept secret.++```txt+public: 87ef8fdb229ad10285ae191a168ea2ec0794621a127df21e372f41fd0246e4cf+private: 64ef6379db5ef6004aff98182688c6e8b4a5229e706f1ccf6a73b05b1432aedf+```++### Mining on Mainnet With an ASIC++chainweb-mining-client needs access to the mining API of a full [Chainweb+node](https://github.com/kadena-io/chainweb-node) in+the Kadena Mainnet. The node must be configured to enable the mining API with+the Pact *public* key (and, optionally, account name) of the miner. Rewards for+mined blocks will be credited to that account. The default is to use the `k:`+account for the key.++The `--enable-mining-coordination`, `--mining-public-key` can be used to+configure chainweb-node for mining. The mining API is served on the service API+port (default is 1848).+++Assuming that `example.com` serves the chainweb-node mining API on port 1848,+the following command can be used to run chainweb-mining-client with the stratum+server on port 1917:++```+chainweb-mining-client \+ --public-key 87ef8fdb229ad10285ae191a168ea2ec0794621a127df21e372f41fd0246e4cf \+ --node example.com:1848 \+ --stratum-port 1917+```++Assuming that the host on which chainweb-mining-client runs is 192.168.1.2, the+pool address that is used to configure the ASIC miner is+`stratum+tcp://192.168.1.2:1917`.++One can point more than a single ASIC miner to the same chainweb-mining-client+stratum server. All connected clients work together and all mining rewards are+credited to the same account, that is configured in chainweb node.++By default the stratum server sets the difficulty of the work that is sent to+the mining clients to the actual difficulty of the block of the most recent+work. This means that it can take a long time before the client solves any work.+It also means that the target is reset for each new block.++It is also possible to set a custom difficulty. As a consequence not all+accepted solutions qualify as solved blocks, but ASIC miner may provide a more+continuous feedback on its current performance. Some devices may also be more+efficient in this mode an yield higher returns.++The thread count determines how many independent stratum works are used to+concurrently provide work to the clients. Each stratum worker receives one work+header at a time from the chainweb-node mining API and emits jobs for that work+to all clients at a configurable rate. The effective rate of jobs is higher than+then configured rate because when upstream work gets preempted. Each client+receives are all jobs from all workers.++The following command runs two stratum workers that serve jobs at least every 500+milliseconds at a fixed difficulty level of 50.++```+chainweb-mining-client \+ --public-key 87ef8fdb229ad10285ae191a168ea2ec0794621a127df21e372f41fd0246e4cf \+ --node example.com:1848 \+ --stratum-port 1917 \+ --stratum-difficulty=50 \+ --stratum-rate=500 \+ --thread-count=2+```++The solution space for each mining job is about 280 terra hashes. The+`--stratum-rate` should be chosen such that the mining devices does not perform+more than that number of hashes within the provided time range. For instance,+for an miner that performs 140TH/s the `--stratum-rate` should be at least 2000+(2 seconds).++The `--stratum-difficulty` parameter expects a integral number between 0 and+256. It denotes the difficulty as a logarithm of base 2. In practice the actual+target uses a difficulty level of at least 42 and at most the difficulty of+block of the current work.++It may help to experiment a little with the `--stratum-difficulty`,+`--stratum-rate`, and the `--thread-count` parameters. We found, that small+values for `--thread-count` (one to three) and moderate values for+`--stratum-difficulty` (in the upper forties / lower fifties) yielded good+results. The But that may differ between different devices and setups.++If the chainweb-node mining API is served via a reverse proxy with TLS the+`--tls` flag must be used to enable HTTPS.++### CPU Mining++Assuming that `example.com` serves the chainweb-node mining API on port 1848, the+following command can be used for CPU mining to the from the previous example:++```sh+chainweb-mining-client \+ --public-key 87ef8fdb229ad10285ae191a168ea2ec0794621a127df21e372f41fd0246e4cfa \+ --node example.com:1848 \+ --worker cpu \+ --thread-count 16 \+```++### GPU Mining++GPU mining is supported via calling an external worker that does the mining+work. An example for such a GPU mining tool for Kadena is+[bigolchunugus](https://github.com/kadena-community/bigolchungus).++```sh+chainweb-mining-client \+ --public-key 87ef8fdb229ad10285ae191a168ea2ec0794621a127df21e372f41fd0246e4cf \+ --node example.com:1848 \+ --worker external \+ --external-miner-cmd bigolchunus+```++For selecting the GPU or passing additional arguments to the external tools, the+extra parameters are appended to the command. E.g.++```sh+chainweb-mining-client \+ --public-key 87ef8fdb229ad10285ae191a168ea2ec0794621a127df21e372f41fd0246e4cf \+ --node example.com:1848 \+ --worker external \+ --external-worker-cmd "bigolchunus -d 2"+```++The external mining tool is called by adding the target as the last command line+parameter and passing the work bytes on stdin.++### Creating a Configuration File++The current configuration of chainweb-mining-client can be stored in a+configuration file by adding the `--print-config` parameter++```sh+chainweb-mining-client \+ --public-key 87ef8fdb229ad10285ae191a168ea2ec0794621a127df21e372f41fd0246e4cf \+ --node example.com:1848 \+ --stratum-port 1917 \+ --statum-difficulty=50+ --print-config > config.yml+```++This results in the following configuration file:++```yaml+account: null+externalWorkerCommand: echo 'no external worker command configured' && /bin/false+generateKey: false+hashRate: 1000000.0+insecure: true+logLevel: info+node: example.com:1848+publicKey: 87ef8fdb229ad10285ae191a168ea2ec0794621a127df21e372f41fd0246e4cf+stratumDifficulty: 50+stratumInterface: '*'+stratumPort: 1917+threadCount: 10+useTls: true+worker: stratum+```++The configuration can then be used via++```sh+chainweb-mining-client --config-file config.yml+```++## Related Resources++* [Chainweb Node Project Page](https://github.com/kadena-io/chainweb-node)+* [Kadena Stratum Protocol](https://gist.github.com/mightybyte/f1567c2bec0380539c638225fb8c1cf4)+* [mining API of chainweb-node](https://api.chainweb.com/openapi/#tag/mining)+* [work header format](https://github.com/kadena-io/chainweb-node/wiki/Block-Header-Binary-Encoding#work-header-binary-format).+* [mining API wiki](https://github.com/kadena-io/chainweb-node/wiki/Mining-API).
Setup.hs view
@@ -1,4 +1,6 @@ module Main (main) where -import Configuration.Utils.Setup+import qualified Configuration.Utils.Setup +main :: IO ()+main = Configuration.Utils.Setup.main
chainweb-mining-client.cabal view
@@ -3,16 +3,17 @@ description: A mining client for Kadena Chainweb. It supports + * mining with ASICs through a stratum server,+ * simulated mining for testing, * multi threaded CPU mining,- * external mining workers (e.g. a GPU),- * simulated mining for testing.+ * external mining workers (e.g. a GPU). - Competitive mining on the Kadena Chainweb Mainnet requires special mining- hardware, which usually comes with its own mining client and mining pool- support implementations. This generic mining client is intended mostly for- testing.+ Competitive mining on the Kadena Mainnet requires special mining hardware+ (ASIC), which connects to a Stratum Server from where it obtains work. -version: 0.2+ All other mining modes (GPU, CPU, and simulation) are intended only for testing.++version: 0.5 synopsis: Mining Client for Kadena Chainweb homepage: https://github.com/kadena-io/chainweb-mining-client bug-reports: https://github.com/kadena-io/chainweb-mining-client/issues@@ -20,12 +21,13 @@ license-file: LICENSE author: Lars Kuhtz maintainer: lars@kadena.io-copyright: Copyright (c) 2019 - 2020, Kadena LLC+copyright: Copyright (c) 2019 - 2022, Kadena LLC category: Data, Mathematics build-type: Custom tested-with:- GHC==8.10.2- , GHC==8.8.4+ GHC==9.2.4+ , GHC==9.0.2+ , GHC==8.10.7 extra-source-files: README.md CHANGELOG.md@@ -37,19 +39,26 @@ custom-setup setup-depends: base >=4.10 && <5- , Cabal >=3.0+ , Cabal >=3.0 && <4 , configuration-tools >=0.5 executable chainweb-mining-client hs-source-dirs: main, src main-is: Main.hs other-modules:- PkgInfo+ JsonRpc Logger+ PkgInfo+ Target+ Utils Worker Worker.CPU Worker.External Worker.Simulation+ Worker.Stratum+ Worker.Stratum.Protocol+ Worker.Stratum.Server+ WorkerUtils autogen-modules: PkgInfo default-language: Haskell2010@@ -58,18 +67,20 @@ -threaded -with-rtsopts=-N build-depends:- base >=4.10 && <4.15+ attoparsec >=0.14+ , base >=4.10 && <5+ , base16-bytestring >=1.0 , aeson >=1.5 , async >=2.2 , bytes >=0.17 , bytestring >=0.10+ , clock >=0.8 , configuration-tools >=0.5 , connection >=0.3- , containers >=0.5 , cryptonite >=0.27 , exceptions >=0.10 , hashable >=1.3- , hostaddress >=0.1+ , hostaddress >=0.2 , http-client >=0.7 , http-client-tls >=0.3 , http-types >=0.12@@ -81,8 +92,51 @@ , retry >=0.8 , stm >=2.5 , streaming >=0.2+ , streaming-commons >=0.2.2 , streaming-events >=1.0 , text >=1.2 , time >=1.9 , unordered-containers >=0.2 , wai-extra >=3.0++test-suite tests+ type: exitcode-stdio-1.0+ hs-source-dirs: test, src+ default-language: Haskell2010+ ghc-options:+ -rtsopts+ -threaded+ -with-rtsopts=-N+ main-is: Main.hs+ other-modules:+ Utils+ Worker+ WorkerUtils++ Target+ TestUtils+ Test.Target+ Test.Utils+ Test.WorkerUtils+ build-depends:+ -- external+ QuickCheck >= 2.13+ , aeson >=1.5+ , base >=4.11 && <5+ , base16-bytestring >=1.0+ , bytes >=0.17+ , bytestring >=0.10+ , clock >=0.8+ , configuration-tools >=0.5+ , cryptonite >=0.27+ , exceptions >=0.10+ , hashable >=1.3+ , hostaddress >=0.2+ , memory >=0.15+ , quickcheck-instances >=0.3+ , stm >=2.5+ , streaming-commons >=0.2.2+ , sydtest >=0.4+ , text >=1.2+ , time >=1.9+
main/Main.hs view
@@ -5,12 +5,14 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -40,7 +42,6 @@ import Crypto.Hash.Algorithms (Blake2s_256) import qualified Crypto.PubKey.Ed25519 as C -import Data.Bifunctor import qualified Data.ByteArray.Encoding as BA import Data.Bytes.Get import Data.Bytes.Put@@ -50,7 +51,8 @@ import qualified Data.ByteString.Short as BS import Data.Hashable import qualified Data.HashMap.Strict as HM-import Data.String+import Data.Maybe+import Data.Streaming.Network import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Word@@ -81,33 +83,14 @@ -- internal modules +import Utils import Logger import Worker import Worker.CPU import Worker.External import Worker.Simulation---- -------------------------------------------------------------------------- ----- Orphans--instance ToJSON HostAddress where- toJSON = toJSON . hostAddressToText- {-# INLINE toJSON #-}--instance FromJSON HostAddress where- parseJSON = withText "HostAddress"- $ either (fail . show) return . hostAddressFromText- {-# INLINE parseJSON #-}---- -------------------------------------------------------------------------- ----- Utils--textReader :: (T.Text -> Either SomeException a) -> ReadM a-textReader p = eitherReader $ first show . p . T.pack--sshow :: Show a => IsString b => a -> b-sshow = fromString . show-{-# INLINE sshow #-}+import qualified Worker.Stratum as Stratum+import qualified Worker.Stratum.Server as Stratum -- -------------------------------------------------------------------------- -- -- Integral Unit Prefixes@@ -197,13 +180,17 @@ {-# INLINE parseJSON #-} -- TODO perform well-formedness checks -newtype Miner = Miner MinerPublicKey+newtype MinerAccount = MinerAccount T.Text deriving (Show, Eq, Ord, Generic)- deriving newtype (Hashable)+ deriving newtype (Hashable, ToJSON, FromJSON) +data Miner = Miner MinerPublicKey (Maybe MinerAccount)+ deriving (Show, Eq, Ord, Generic)+ deriving anyclass (Hashable)+ instance ToJSON Miner where- toJSON (Miner (MinerPublicKey k)) = object- [ "account" .= k+ toJSON (Miner (MinerPublicKey k) account) = object+ [ "account" .= fromMaybe (MinerAccount ("k:" <> k)) account , "public-keys" .= [ k ] , "predicate" .= ("keys-all" :: T.Text) ]@@ -215,6 +202,7 @@ = CpuWorker | ExternalWorker | SimulationWorker+ | StratumWorker deriving (Show, Eq, Ord, Generic) deriving anyclass (Hashable) @@ -231,13 +219,15 @@ workerConfigToText CpuWorker = "cpu" workerConfigToText ExternalWorker = "external" workerConfigToText SimulationWorker = "simulation"+workerConfigToText StratumWorker = "stratum" workerConfigFromText :: MonadThrow m => T.Text -> m WorkerConfig workerConfigFromText t = case T.toCaseFold t of "cpu" -> return CpuWorker "external" -> return ExternalWorker "simulation" -> return SimulationWorker- _ -> error $ "unknown worker configuraton: " <> T.unpack t+ "stratum" -> return StratumWorker+ _ -> throwM $ FromTextException $ "unknown worker configuraton: " <> t -- -------------------------------------------------------------------------- -- -- Configuration@@ -252,11 +242,16 @@ , _configUseTls :: !Bool , _configInsecure :: !Bool , _configPublicKey :: !MinerPublicKey+ , _configAccount :: !(Maybe MinerAccount) , _configThreadCount :: !Natural , _configGenerateKey :: !Bool , _configLogLevel :: !LogLevel , _configWorker :: !WorkerConfig , _configExternalWorkerCommand :: !String+ , _configStratumPort :: !Port+ , _configStratumInterface :: !HostPreference+ , _configStratumDifficulty :: !Stratum.StratumDifficulty+ , _configStratumRate :: !Natural } deriving (Show, Eq, Ord, Generic) @@ -265,15 +260,20 @@ defaultConfig :: Config defaultConfig = Config { _configHashRate = UnitPrefixed defaultHashRate- , _configNode = unsafeHostAddressFromText "localhost:1789"- , _configUseTls = True- , _configInsecure = True+ , _configNode = unsafeHostAddressFromText "localhost:1848"+ , _configUseTls = False+ , _configInsecure = False , _configPublicKey = MinerPublicKey ""- , _configThreadCount = 10+ , _configAccount = Nothing+ , _configThreadCount = 2 , _configGenerateKey = False , _configLogLevel = Info- , _configWorker = CpuWorker+ , _configWorker = StratumWorker , _configExternalWorkerCommand = "echo 'no external worker command configured' && /bin/false"+ , _configStratumPort = 1917+ , _configStratumInterface = "*"+ , _configStratumDifficulty = Stratum.WorkDifficulty+ , _configStratumRate = 1000 } instance ToJSON Config where@@ -283,11 +283,16 @@ , "useTls" .= _configUseTls c , "insecure" .= _configInsecure c , "publicKey" .= _configPublicKey c+ , "account" .= _configAccount c , "threadCount" .= _configThreadCount c , "generateKey" .= _configGenerateKey c , "logLevel" .= logLevelToText @T.Text (_configLogLevel c) , "worker" .= _configWorker c , "externalWorkerCommand" .= _configExternalWorkerCommand c+ , "stratumPort" .= _configStratumPort c+ , "stratumInterface" .= _configStratumInterface c+ , "stratumDifficulty" .= _configStratumDifficulty c+ , "stratumRate" .= _configStratumRate c ] instance FromJSON (Config -> Config) where@@ -297,11 +302,16 @@ <*< configUseTls ..: "useTls" % o <*< configInsecure ..: "insecure" % o <*< configPublicKey ..: "publicKey" % o+ <*< configAccount ..: "account" % o <*< configThreadCount ..: "threadCount" % o <*< configGenerateKey ..: "generateKey" % o <*< setProperty configLogLevel "logLevel" parseLogLevel o <*< configWorker ..: "worker" % o <*< configExternalWorkerCommand ..: "externalWorkerCommand" % o+ <*< configStratumPort ..: "stratumPort" % o+ <*< configStratumInterface ..: "stratumInterface" % o+ <*< configStratumDifficulty ..: "stratumDifficulty" % o+ <*< configStratumRate ..: "stratumRate" % o where parseLogLevel = withText "LogLevel" $ return . logLevelFromText @@ -327,7 +337,11 @@ <*< configPublicKey .:: fmap MinerPublicKey . strOption % short 'k' <> long "public-key"- <> help "the public-key for the mining rewards account"+ <> help "public-key for the mining rewards account"+ <*< configAccount .:: fmap (Just . MinerAccount) . strOption+ % short 'a'+ <> long "account"+ <> help "account for the mining rewards (default: public-key prefixed with 'k:')" <*< configThreadCount .:: option auto % short 'c' <> long "thread-count"@@ -344,10 +358,23 @@ % short 'w' <> long "worker" <> help "The type of mining worker that is used"- <> metavar "cpu|external|simulation"+ <> metavar "cpu|external|simulation|stratum" <*< configExternalWorkerCommand .:: option (textReader $ Right . T.unpack) % long "external-worker-cmd" <> help "command that is used to call an external worker. When the command is called the target value is added as last parameter to the command line."+ <*< configStratumPort .:: option jsonReader+ % long "stratum-port"+ <> help "the port on which the stratum server listens"+ <*< configStratumInterface .:: option jsonReader+ % long "stratum-interface"+ <> help "network interface that the stratum server binds to"+ <*< configStratumDifficulty .:: option (textReader Stratum.stratumDifficultyFromText)+ % long "stratum-difficulty"+ <> help "How the difficulty for stratum mining shares is choosen. Possible values are \"block\" for using the block target of the most most recent notification of new work, or number between 0 and 256 for specifiying a fixed difficulty as logarithm of base 2 (number of leading zeros)."+ <*< configStratumRate .:: option auto+ % short 's'+ <> long "stratum-rate"+ <> help "Rate (in milliseconds) at which a stratum worker thread emits jobs." -- -------------------------------------------------------------------------- -- -- HTTP Retry Logic@@ -483,12 +510,16 @@ getJob :: Config -> ChainwebVersion -> HTTP.Manager -> IO (ChainId, Target, Work) getJob conf ver mgr = do bytes <- HTTP.httpLbs req mgr- case runGetS decodeJob (BL.toStrict $ HTTP.responseBody $ bytes) of+ case runGetS decodeJob (BL.toStrict $ HTTP.responseBody bytes) of Left e -> error $ "failed to decode work: " <> sshow e Right (a,b,c) -> return (a, b, c) where req = (baseReq conf ver "mining/work")- { HTTP.requestBody = HTTP.RequestBodyLBS $ encode $ Miner $ _configPublicKey conf+ { HTTP.requestBody = HTTP.RequestBodyLBS+ $ encode+ $ Miner+ (_configPublicKey conf)+ (_configAccount conf) , HTTP.requestHeaders = [("content-type", "application/json")] } @@ -513,14 +544,13 @@ where logg = writeLog logger req = (baseReq conf ver "mining/solved")- { HTTP.requestBody = HTTP.RequestBodyBS $ BS.fromShort $ bytes+ { HTTP.requestBody = HTTP.RequestBodyBS $ BS.fromShort bytes , HTTP.method = "POST" } -- | Automatically restarts the stream when the response status is 2** and throws -- and exception otherwise. ----- No -- No retry is used. Retrying is handled by the outer logic. -- updateStream@@ -772,17 +802,28 @@ -- For private mining that is done asynchronously. Public mining is -- considered deprecated. ver <- getNodeVersion conf mgr- rng <- MWC.createSystemRandom updateMap <- newUpdateMap- forConcurrently_ [0 .. (_configThreadCount conf) - 1] $ \i ->- withLogTag logger ("Thread " <> sshow i) $ \taggedLogger ->- miningLoop conf ver taggedLogger mgr updateMap $- case _configWorker conf of- SimulationWorker -> simulationWorker taggedLogger rng workerRate- ExternalWorker -> externalWorker taggedLogger (_configExternalWorkerCommand conf)- CpuWorker -> cpuWorker @Blake2s_256 taggedLogger+ withWorker $ \worker -> do+ forConcurrently_ [0 .. _configThreadCount conf - 1] $ \i ->+ withLogTag logger ("Thread " <> sshow i) $ \taggedLogger ->+ miningLoop conf ver taggedLogger mgr updateMap (worker taggedLogger) where tlsSettings = HTTP.TLSSettingsSimple (_configInsecure conf) False False workerRate = _getUnitPrefixed (_configHashRate conf) / fromIntegral (_configThreadCount conf)++ -- provide the inner computation with an initialized worker+ withWorker f = case _configWorker conf of+ SimulationWorker -> do+ rng <- MWC.createSystemRandom+ f $ \l -> simulationWorker l rng workerRate+ ExternalWorker -> f $ \l -> externalWorker l (_configExternalWorkerCommand conf)+ CpuWorker -> f $ cpuWorker @Blake2s_256+ StratumWorker -> Stratum.withStratumServer+ logger+ (_configStratumPort conf)+ (_configStratumInterface conf)+ (_configStratumDifficulty conf)+ (_configStratumRate conf)+ (f . Stratum.submitWork)
+ src/JsonRpc.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module: JsonRpc+-- Copyright: Copyright © 2021 Kadena LLC.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@kadena.io>+-- Stability: experimental+--+-- TODO+--+module JsonRpc+(+-- * JSON Utils+ Static(..)+, pattern StaticNull+, pattern StaticTrue+, pattern StaticFalse+, T1(..)++-- JSON RPC Message Ids+, MsgId(..)++-- JSON RPC Error+, Error(..)++-- * JSON RPC Request Messages+, requestProperties++-- * JSON RPC Result Messages+, responseProperties+, parseResponse+, parseResponse'+) where++import qualified Data.Aeson as A+import qualified Data.Aeson.Encoding.Internal as A+import qualified Data.Aeson.Types as A (Pair, Parser)+import Data.Foldable+import qualified Data.Text as T++-- internal modules++-- -------------------------------------------------------------------------- --+-- JSON Utils++data Static (a :: k) = Static+ deriving (Show, Eq, Ord)++pattern StaticNull :: Static 'Nothing+pattern StaticNull = Static++pattern StaticTrue :: Static 'True+pattern StaticTrue = Static++pattern StaticFalse :: Static 'False+pattern StaticFalse = Static++instance A.ToJSON (Static 'Nothing) where+ toEncoding _ = A.null_+ toJSON _ = A.Null+ {-# INLINE toEncoding #-}+ {-# INLINE toJSON #-}++instance A.FromJSON (Static 'Nothing) where+ parseJSON A.Null = return Static+ parseJSON a = fail $ "expected \'null\' but got " <> show a+ {-# INLINE parseJSON #-}++instance A.ToJSON (Static 'True) where+ toEncoding _ = A.toEncoding True+ toJSON _ = A.toJSON True+ {-# INLINE toEncoding #-}+ {-# INLINE toJSON #-}++instance A.FromJSON (Static 'True) where+ parseJSON = A.withBool "True" $ \b -> if b+ then return Static+ else fail "expected constant \'true\' but got \'false\'"+ {-# INLINE parseJSON #-}++instance A.ToJSON (Static 'False) where+ toEncoding _ = A.toEncoding False+ toJSON _ = A.toJSON False+ {-# INLINE toEncoding #-}+ {-# INLINE toJSON #-}++instance A.FromJSON (Static 'False) where+ parseJSON = A.withBool "False" $ \b -> if b+ then fail "expected constant \'false\' but got \'true\'"+ else return Static+ {-# INLINE parseJSON #-}++-- | Unary Tuple+--+newtype T1 a = T1 { _getT1 :: a }+ deriving (Show, Eq, Ord)++instance A.ToJSON a => A.ToJSON (T1 a) where+ toEncoding (T1 a) = A.toEncoding [a]+ toJSON (T1 a) = A.toJSON [a]+ {-# INLINE toEncoding #-}+ {-# INLINE toJSON #-}++instance A.FromJSON a => A.FromJSON (T1 a) where+ parseJSON = A.withArray "T1" $ \x -> case toList x of+ [a] -> T1 <$> A.parseJSON a+ l -> fail $ "Expected array of length 1, got length " <> show (length l)+ {-# INLINE parseJSON #-}++-- -------------------------------------------------------------------------- --+-- | JSON RPC Message Id+--+-- This is used to match result message to requests within a JSON RPC session.+--+-- It usually is an integral number, the can be encoded either as a string or+-- a number.+--+newtype MsgId = MsgId A.Value+ deriving (Show, Eq, Ord)+ deriving newtype (A.ToJSON, A.FromJSON)++-- -------------------------------------------------------------------------- --+-- JSON RPC Error++newtype Error = Error (Int, T.Text, A.Value)+ deriving (Show, Eq, Ord)+ deriving newtype (A.ToJSON, A.FromJSON)++-- -------------------------------------------------------------------------- --+-- | JSON RPC Request Messages+--+-- A remote method is invoked by sending a request to a remote service. The+-- request is a single object serialized using JSON.+--+-- A notification is a special request which does not have a response. The+-- notification is a single object serialized using JSON.+--+-- * method - A String containing the name of the method to be invoked.+--+-- * params - An Array of objects to pass as arguments to the method.+--+-- * id - The request id. This can be of any type. It is used to match the+-- response with the request that it is replying to.+--+-- This is @null@ when the request if a notification. In that case no response+-- is expected.+--+-- In this implementation we limit the value to be an integral number of @null@.+--+requestProperties :: A.KeyValue kv => A.ToJSON a => T.Text -> a -> Maybe MsgId -> [kv]+requestProperties method params i =+ [ "method" A..= method+ , "params" A..= params+ , "id" A..= i+ ]+{-# INLINE requestProperties #-}+{-# SPECIALIZE requestProperties :: A.ToJSON a => T.Text -> a -> Maybe MsgId -> [A.Series] #-}+{-# SPECIALIZE requestProperties :: A.ToJSON a => T.Text -> a -> Maybe MsgId -> [A.Pair] #-}++-- -------------------------------------------------------------------------- --+-- | JSON RPC Result Messages+--+-- When the method invocation completes, the service must reply with a response.+-- The response is a single object serialized using JSON.+--+-- It has three properties:+--+-- * result - The Object that was returned by the invoked method. This must be+-- null in case there was an error invoking the method.+--+-- It seems that for Stratum this actully is an array++-- * error - An Error object if there was an error invoking the method. It must be+-- null if there was no error.++-- * id - This must be the same id as the request it is responding to.+--+-- In this implementation we limit the value to be an integral number or @null@.+--+responseProperties+ :: A.KeyValue kv+ => A.ToJSON a+ => A.ToJSON b+ => MsgId+ -> Either a b+ -> [kv]+responseProperties i r =+ [ "result" A..= either (const Nothing) Just r+ , "error" A..= either Just (const Nothing) r+ , "id" A..= i+ ]+{-# INLINE responseProperties #-}+{-# SPECIALIZE responseProperties :: A.ToJSON a => A.ToJSON b => MsgId -> Either a b -> [A.Series] #-}+{-# SPECIALIZE responseProperties :: A.ToJSON a => A.ToJSON b => MsgId -> Either a b -> [A.Pair] #-}++parseResponse :: A.FromJSON a => A.FromJSON b => A.Object -> A.Parser (Either a b)+parseResponse o = o A..: "error" >>= \case+ Nothing -> o A..: "result"+ Just e -> return $ Left e+{-# INLINE parseResponse #-}++parseResponse' :: A.FromJSON a => (A.Value -> A.Parser b) -> A.Object -> A.Parser (Either a b)+parseResponse' paramsParser o = o A..: "error" >>= \case+ Nothing -> Right <$> (o A..: "result" >>= paramsParser)+ Just e -> return $ Left e+{-# INLINE parseResponse' #-}+
src/Logger.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} -- | -- Module: Logger@@ -51,13 +52,14 @@ decrementCounter ref = atomicModifyIORef' ref $ \x -> (x - 1, ()) resetCounter :: IORef Int -> IO Int-resetCounter ref = atomicModifyIORef' ref $ \x -> (0, x)+resetCounter ref = atomicModifyIORef' ref (0,) -- -------------------------------------------------------------------------- -- -- Terminal Colors useColor :: Bool useColor = unsafePerformIO $ hIsTerminalDevice stdout+{-# NOINLINE useColor #-} data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White @@ -163,7 +165,7 @@ -- Nothing in here is expected to block or throw. So the mask should be -- sufficient. (TODO what about the getSystemTime?) c <- readIORef (_loggerApproxQueueSize logger)- if (c > _loggerMaxQueueSize logger)+ if c > _loggerMaxQueueSize logger then incrementCounter (_loggerSkipped logger) else do skipped <- resetCounter (_loggerSkipped logger)@@ -213,15 +215,17 @@ where -- TODO: implement batch processing --- backend queue sizeRef = forever $ do- -- No need for masking here. If anything throws in here we exit the- -- application anyways.- --- -- TODO: there is no way to check if Chan is empty. Use a different- -- queue that allows to check that sizeRef and the Queue are- -- approximately in sync.- --- msg <- readChan queue- decrementCounter sizeRef- T.putStrLn $ formatLogMessage msg+ backend queue sizeRef = do+ hSetBuffering stdout NoBuffering+ forever $ do+ -- No need for masking here. If anything throws in here we exit the+ -- application anyways.+ --+ -- TODO: there is no way to check if Chan is empty. Use a different+ -- queue that allows to check that sizeRef and the Queue are+ -- approximately in sync.+ --+ msg <- readChan queue+ decrementCounter sizeRef+ T.putStrLn $ formatLogMessage msg
+ src/Target.hs view
@@ -0,0 +1,370 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UnboxedTuples #-}++-- |+-- Module: Target+-- Copyright: Copyright © 2021 Kadena LLC.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@kadena.io>+-- Stability: experimental+--+-- TODO+--+module Target+(+-- * Target+ Target(..)+, mkTarget+, nullTarget+, maxTarget+, avgTarget++-- * Target Words+, TargetWords(..)+, targetToWords+, targetFromWords++-- * Binary Encodings+, encodeTarget+, decodeTarget++-- * Textual Encodings+, targetToText16Le+, targetToText16Be++-- * Difficulty+, Period(..)+, HashRate(..)+, Difficulty(..)+, targetToDifficulty+, difficultyToTarget+, adjustDifficulty++-- * Difficulty Level (leading zeros)+, Level+, level+, mkTargetLevel+, getTargetLevel+, increaseLevel+, reduceLevel+, leveled+) where++import Control.Monad++import qualified Data.Aeson as A+import qualified Data.Aeson.Encoding as A+import Data.Bits+import Data.Bytes.Get+import Data.Bytes.Put+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Lazy as LB+import Data.Hashable+import Data.String+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Read as T+import Data.Word++import GHC.Generics++import Numeric.Natural++import Text.Read++-- internal modules++import Utils++-- -------------------------------------------------------------------------- --+-- Target++-- | Hash target. A little endian encoded 256 bit (unsigned) word.+--+-- Cf. https://github.com/kadena-io/chainweb-node/wiki/Block-Header-Binary-Encoding#work-header-binary-format+--+-- This is encoded as a positive integer with that it is smaller than 2^256+--+-- Binary encoding in a block header is fixed size 256 little endian format+-- (padded with zero bits).+--+-- Textual endcoding in JSON and debugging and log messages is fixed size 64+-- hexadecimal (padded with zeros).+--+-- All arithmetic is done is infinite precision rational arithmetic with+-- the final result capped at 2^256-1.+--+newtype Target = Target Natural+ deriving (Generic)+ deriving newtype (Eq, Ord, Enum, Hashable)++instance Bounded Target where+ minBound = Target 0+ maxBound = Target (2 ^ (256::Int) - 1)++mkTarget :: MonadFail m => Integral a => a -> m Target+mkTarget a+ | a < 0 = fail "newTarget: target can not be smaller than zero"+ | a >= 2 ^ (256 :: Int) = fail "newTarget: target can not be larger than 2^256-1"+ | otherwise = return $ Target $ int a++nullTarget :: Target+nullTarget = minBound++maxTarget :: Target+maxTarget = maxBound++avgTarget :: Target -> Target -> Target+avgTarget (Target a) (Target b) = Target $ (a + b) `div` 2+{-# INLINE avgTarget #-}++-- -------------------------------------------------------------------------- --+-- Representation as Word++-- Little Endian ordered. The words themself are in host byte ordering.+--+data TargetWords = TargetWords+ {-# UNPACK #-} !Word64+ {-# UNPACK #-} !Word64+ {-# UNPACK #-} !Word64+ {-# UNPACK #-} !Word64++-- TODO on 64 bit platform we could use mkNatural instead+--+targetFromWords :: TargetWords -> Target+targetFromWords (TargetWords a b c d) = Target $+ ((int d * 0x10000000000000000 + int c) * 0x10000000000000000 + int b) * 0x10000000000000000 + int a+{-# INLINE targetFromWords #-}++-- TODO with GHC-9 and ghc-bignum we could switch the type of Target to+-- use BigNat on 64 bit systems.+--+targetToWords :: Target -> TargetWords+targetToWords (Target i0) = TargetWords (int a) (int b) (int c) (int d)+ where+ (i1, a) = i0 `quotRem` 0x10000000000000000+ (i2, b) = i1 `quotRem` 0x10000000000000000+ (d, c) = i2 `quotRem` 0x10000000000000000+{-# INLINE targetToWords #-}++-- -------------------------------------------------------------------------- --+-- Binary Encodings++decodeTarget :: MonadGet m => m Target+decodeTarget = fmap targetFromWords $+ TargetWords+ <$> getWord64le+ <*> getWord64le+ <*> getWord64le+ <*> getWord64le+{-# INLINE decodeTarget #-}++encodeTarget :: MonadPut m => Target -> m ()+encodeTarget t = do+ putWord64le a+ putWord64le b+ putWord64le c+ putWord64le d+ where+ TargetWords a b c d = targetToWords t+{-# INLINE encodeTarget #-}++-- -------------------------------------------------------------------------- --+-- Textual Encodings++targetBuilderHexBe :: Target -> BB.Builder+targetBuilderHexBe t+ = BB.word64HexFixed d+ <> BB.word64HexFixed c+ <> BB.word64HexFixed b+ <> BB.word64HexFixed a+ where+ TargetWords a b c d = targetToWords t+{-# INLINE targetBuilderHexBe #-}++targetBuilderHexLe :: Target -> BB.Builder+targetBuilderHexLe t+ = BB.word64HexFixed a+ <> BB.word64HexFixed b+ <> BB.word64HexFixed c+ <> BB.word64HexFixed d+ where+ TargetWords a b c d = targetToWords t+{-# INLINE targetBuilderHexLe #-}++instance Show Target where+ show t = "Target " <> show (targetToText16Be t)+ {-# INLINE show #-}++instance Read Target where+ readPrec = do+ Ident "Target" <- lexP+ readPrec >>= targetFromText16Be++instance IsString Target where+ fromString s = case targetFromText16Be (T.pack s) of+ Just x -> x+ Nothing -> error "Target.IsString.fromString: failed to parse target"+ {-# INLINE fromString #-}++instance A.ToJSON Target where+ toEncoding = A.unsafeToEncoding . quoted . targetBuilderHexBe+ toJSON = A.toJSON . targetToText16Be+ {-# INLINE toEncoding #-}+ {-# INLINE toJSON #-}++instance A.FromJSON Target where+ parseJSON = A.withText "Target" targetFromText16Be+ {-# INLINE parseJSON #-}++targetFromText16Be :: MonadFail m => T.Text -> m Target+targetFromText16Be t+ | T.length t /= 64 =+ fail $ "Target string has wrong length. Expected 64 ," <> " got " <> sshow (T.length t)+ | otherwise = case T.hexadecimal t of+ Right (n, "") -> mkTarget @_ @Natural n+ Right (n, x) -> fail $ "failed to parse target: pending characters after reading " <> show n <> ": " <> T.unpack x+ Left e -> fail $ "failed to parse target: " <> e+{-# INLINE targetFromText16Be #-}++-- | Represent target bytes in hexadecimal base in little endian byte order+--+targetToText16Le :: Target -> T.Text+targetToText16Le = T.decodeUtf8 . LB.toStrict . BB.toLazyByteString . targetBuilderHexLe+{-# INLINE targetToText16Le #-}++-- | Represent target bytes in hexadecimal base in big endian byte order (used by Stratum)+--+targetToText16Be :: Target -> T.Text+targetToText16Be = T.decodeUtf8 . LB.toStrict . BB.toLazyByteString . targetBuilderHexBe+{-# INLINE targetToText16Be #-}++-- -------------------------------------------------------------------------- --+-- Difficulty++-- | Difficulty measures the expected number of random Bernoulli trials for+-- solving a block, i.e. the number of nonce that a miner must try in order to+-- find a hash that matches are target. Conversely, the inverse of the+-- difficulty is the probabily that a nonce, that haven't been tried before,+-- results in a valid solution.+--+-- For pools, it measures the weight of a share within a round.+--+-- The minimum possible difficulty is 1. The maximum difficulty is 2^256, which+-- corresponds to a target value of 0.+--+-- Since Difficulty and target are related, the notion of difficuylty is+-- redundant. However, compared to the notion of target it is a more intuitive+-- representation of the work of a miner. Also, since it is represented as+-- double it is often more convenient to work with when perfect precision isn't+-- required.+--+newtype Difficulty = Difficulty Double+ deriving (Show)+ deriving newtype (Eq, Ord)++pruneDifficulty :: Double -> Difficulty+pruneDifficulty d = Difficulty $ min m (max 1 d)+ where+ m = 2^(256 :: Int)++targetToDifficulty :: Target -> Difficulty+targetToDifficulty (Target t) = Difficulty $ m / int (t + 1)+ where+ m = 2^(256 :: Int)++difficultyToTarget :: Difficulty -> Target+-- difficultyToTarget (Difficulty d) = Target $ floor (m / d) - 1+difficultyToTarget (Difficulty d) = Target $ floor (m / d) - 1+ where+ m = 2^(256 :: Int)++-- | Time per share. Usually this is used scaled to some larger number+-- of shares to account for the exponential distribution with which shares+-- arrive.+--+-- This is measured in seconds+--+newtype Period = Period Double+ deriving (Show, Eq, Ord)++newtype HashRate = HashRate Double+ deriving (Show, Eq, Ord)++-- | The period values must have the same denominator. (If not they must be+-- scaled.)+--+adjustDifficulty+ :: Double+ -- ^ dead band, tolerance for which not adjustement is performed+ -- in order to reduce jitter+ -> HashRate+ -- ^ estimated hash rate+ -> Period+ -- ^ targeted period+ -> Difficulty+ -- ^ current difficulty+ -> Difficulty+ -- ^ new difficulty+adjustDifficulty tolerance estimatedHashRate trgP curD+ | abs (cp - tp) / tp <= tolerance = curD+ | otherwise = pruneDifficulty $ d * tp / cp+ where+ Difficulty d = curD+ HashRate hr = estimatedHashRate+ Period tp = trgP+ cp = d / hr++-- -------------------------------------------------------------------------- --+-- Difficulty Levels (leading zeros)++newtype Level = Level Int+ deriving (Show, Eq, Ord)++level :: Show a => Integral a => a -> Level+level i+ | i < 0 || i > 256 = error $ "Invalid difficulty level. Expected [0,256]; got " <> show i+ | otherwise = Level (int i)+{-# INLINE level #-}++instance A.ToJSON Level where+ toJSON (Level i) = A.toJSON i+ {-# INLINE toJSON #-}++instance A.FromJSON Level where+ parseJSON = A.parseJSON >=> \i -> if+ | i < 0 || i > 256 -> fail $ "Invalid difficulty level. Expected an integral value between 0 and 256; got " <> show i+ | otherwise -> return $ Level i+ {-# INLINE parseJSON #-}++mkTargetLevel :: Level -> Target+mkTargetLevel (Level i) = Target $ 2^(256-i) - 1++getTargetLevel :: Target -> Level+getTargetLevel (Target 0) = Level 256+getTargetLevel (Target i) = Level $ int $ 256 - naturalLog2 i - 1+{-# INLINE getTargetLevel #-}++reduceLevel :: Int -> Target -> Target+reduceLevel i (Target t) = Target $ shiftL t i+{-# INLINE reduceLevel #-}++increaseLevel :: Int -> Target -> Target+increaseLevel i (Target t) = Target $ shiftR t i+{-# INLINE increaseLevel #-}++leveled :: Target -> Target+leveled = mkTargetLevel . getTargetLevel+{-# INLINE leveled #-}
+ src/Utils.hs view
@@ -0,0 +1,403 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |+-- Module: Utils+-- Copyright: Copyright © 2020 Kadena LLC.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@kadena.io>+-- Stability: experimental+--+module Utils+(+-- Hexadecimal Encoding for Integral Types+ IntHexText(..)++-- * Hex-Encoded Short ByteString+, HexEncodedShortByteString(..)+, shortByteStringToHex+, shortByteStringFromHex++-- * Byte Swapped Hex-Encoded Short ByteStrings+, ReversedHexEncodedShortByteString(..)+, reversedShortByteStringToHex+, reversedShortByteStringFromHex++-- * Byte Swapped Hex-Encoded Short ByteStrings of Static Length+, ReversedHexEncodedShortByteStringN(..)++-- * Exceptions++, FromTextException(..)++-- * Misc+, nat+, int+, sshow+, quoted+, le64+, le64#+, peekWord64OffLe+, seconds+, secondsNs+, writeTMVar+, naturalLog2+, textReader++-- * Internal+, naturalLog2_compat+) where++import Configuration.Utils hiding (Error)++import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Catch++import Data.Aeson.Encoding hiding (int)+import Data.Bifunctor+import qualified Data.ByteString as B+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Short as BS+import Data.Function+import Data.String+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TB+import qualified Data.Text.Lazy.Builder.Int as TB+import qualified Data.Text.Read as T+import Data.Word++import GHC.ByteOrder+import GHC.Exts+import GHC.TypeNats++import Data.Streaming.Network+import qualified Data.Streaming.Network.Internal as NI++import Network.HostAddress++import Foreign.Storable++import System.Clock++import Text.Read++-- -------------------------------------------------------------------------- --+-- Base Compatibility++#if MIN_VERSION_base(4,15,0)+import GHC.Num.Natural+import GHC.Num.Integer+#else+import GHC.Float+import Numeric.Natural+#endif++-- -------------------------------------------------------------------------- --+--+-- | Hexadecimal Encoding for Integral Types+--+newtype IntHexText a = IntHexText { _getIntHexText :: a}+ deriving newtype (Eq, Ord, Integral, Enum, Real, Num)++instance (Integral a) => Show (IntHexText a) where+ show = TL.unpack . TB.toLazyText . TB.hexadecimal+ {-# INLINE show #-}++instance (Integral a) => ToJSON (IntHexText a) where+ toEncoding = unsafeToEncoding . quoted . BB.wordHex . int+ toJSON = toJSON . TB.toLazyText . TB.hexadecimal+ {-# INLINE toEncoding #-}+ {-# INLINE toJSON #-}++instance (Show a, Integral a) => FromJSON (IntHexText a) where+ parseJSON = withText "IntHexText" $ \t -> case T.hexadecimal t of+ Right (n, "") -> return n+ Right (n, x) -> fail $ "failed to parse hex encoded integral number: pending characters after reading " <> show n <> ": " <> T.unpack x+ Left e -> fail $ "failed to read hex encoded integral number: " <> e+ {-# INLINE parseJSON #-}++-- -------------------------------------------------------------------------- --+--+-- | Hex Encoded Short ByteString+--+newtype HexEncodedShortByteString = HexEncodedShortByteString+ { _getHexEncodedShortByteString :: BS.ShortByteString }+ deriving (Eq, Ord)++instance IsString HexEncodedShortByteString where+ fromString a = case shortByteStringFromHex $ T.pack a of+ Right x -> HexEncodedShortByteString x+ Left e -> error $ "failed to parse hex encoded byte string: " <> e++instance Show HexEncodedShortByteString where+ show = show . T.unpack . shortByteStringToHex . _getHexEncodedShortByteString++instance Read HexEncodedShortByteString where+ readPrec = do+ s <- readPrec+ case shortByteStringFromHex (T.pack s) of+ Right x -> return $ HexEncodedShortByteString x+ Left err -> fail err++instance ToJSON HexEncodedShortByteString where+ toEncoding = toEncoding . shortByteStringToHex . _getHexEncodedShortByteString+ toJSON = toJSON . shortByteStringToHex . _getHexEncodedShortByteString+ {-# INLINE toEncoding #-}+ {-# INLINE toJSON #-}++instance FromJSON HexEncodedShortByteString where+ parseJSON = withText "HexEncodedBytes" $ \t ->+ case shortByteStringFromHex t of+ Right x -> return $ HexEncodedShortByteString x+ Left err -> fail err+ {-# INLINE parseJSON #-}++-- | Represent a 'BS.ShortByteString' in hexadecimal base+--+shortByteStringToHex :: BS.ShortByteString -> T.Text+shortByteStringToHex = T.decodeUtf8 . B16.encode . BS.fromShort+{-# INLINE shortByteStringToHex #-}++shortByteStringFromHex :: T.Text -> Either String BS.ShortByteString+shortByteStringFromHex = fmap BS.toShort . B16.decode . T.encodeUtf8+{-# INLINE shortByteStringFromHex #-}++-- -------------------------------------------------------------------------- --+--+-- | ByteSwapped Hex Encoding+-- Comparision is done lexicographically starting with the most significant bytes.+--+newtype ReversedHexEncodedShortByteString = ReversedHexEncodedShortByteString+ { _getReversedHexEncodedShortByteString :: BS.ShortByteString }+ deriving (Eq)++instance Ord ReversedHexEncodedShortByteString where+ compare = compare `on` (B.reverse . BS.fromShort . _getReversedHexEncodedShortByteString)++instance IsString ReversedHexEncodedShortByteString where+ fromString a = case reversedShortByteStringFromHex $ T.pack a of+ Right x -> ReversedHexEncodedShortByteString x+ Left e -> error $ "failed to parse hex encoded byte string: " <> e++instance Show ReversedHexEncodedShortByteString where+ show = show . T.unpack . reversedShortByteStringToHex . _getReversedHexEncodedShortByteString++instance Read ReversedHexEncodedShortByteString where+ readPrec = do+ s <- readPrec @T.Text+ case reversedShortByteStringFromHex s of+ Right x -> return $ ReversedHexEncodedShortByteString x+ Left err -> fail err++instance ToJSON ReversedHexEncodedShortByteString where+ toEncoding = toEncoding . reversedShortByteStringToHex . _getReversedHexEncodedShortByteString+ toJSON = toJSON . reversedShortByteStringToHex . _getReversedHexEncodedShortByteString+ {-# INLINE toEncoding #-}+ {-# INLINE toJSON #-}++instance FromJSON ReversedHexEncodedShortByteString where+ parseJSON = withText "ReversedHexEncodedBytes" $ \t ->+ case reversedShortByteStringFromHex t of+ Right x -> return $ ReversedHexEncodedShortByteString x+ Left err -> fail err+ {-# INLINE parseJSON #-}++-- | Represent a 'BS.ShortByteString' in hexadecimal base+--+reversedShortByteStringToHex :: BS.ShortByteString -> T.Text+reversedShortByteStringToHex = T.decodeUtf8 . B16.encode . B.reverse . BS.fromShort+{-# INLINE reversedShortByteStringToHex #-}++reversedShortByteStringFromHex :: T.Text -> Either String BS.ShortByteString+reversedShortByteStringFromHex = fmap (BS.toShort . B.reverse) . B16.decode . T.encodeUtf8+{-# INLINE reversedShortByteStringFromHex #-}++-- -------------------------------------------------------------------------- --+--+-- | ByteSwapped Hex Encoding Of Static Length+--+-- Comparision is done lexicographically starting with the most significant bytes.+--+newtype ReversedHexEncodedShortByteStringN (n :: Nat) = ReversedHexEncodedShortByteStringN+ { _getReversedHexEncodedShortByteStringN :: ReversedHexEncodedShortByteString }+ deriving newtype (Eq, Ord, Show, ToJSON)++reversedHexEncodedShortByteStringN+ :: forall n+ . KnownNat n+ => ReversedHexEncodedShortByteString+ -> Either T.Text (ReversedHexEncodedShortByteStringN n)+reversedHexEncodedShortByteStringN r@(ReversedHexEncodedShortByteString a)+ | BS.length a /= nat @n = Left $ "ReversedHexEncodedShortByteStringN has wrong length. Expected " <> sshow @Int (nat @n) <> " got " <> sshow (BS.length a)+ | otherwise = Right $ ReversedHexEncodedShortByteStringN r++instance KnownNat n => IsString (ReversedHexEncodedShortByteStringN n) where+ fromString = either (error . T.unpack) id+ . reversedHexEncodedShortByteStringN+ . fromString++instance KnownNat n => Read (ReversedHexEncodedShortByteStringN n) where+ readPrec = do+ a <- reversedHexEncodedShortByteStringN @n <$> readPrec+ either (fail . T.unpack) return a++instance KnownNat n => FromJSON (ReversedHexEncodedShortByteStringN n) where+ parseJSON v = do+ a <- reversedHexEncodedShortByteStringN @n <$> parseJSON v+ either (fail . T.unpack) return a+ {-# INLINE parseJSON #-}++-- -------------------------------------------------------------------------- --+-- Exceptions++newtype FromTextException = FromTextException T.Text+ deriving (Eq, Show, Ord)++instance Exception FromTextException++-- -------------------------------------------------------------------------- --+-- Misc++textReader :: (T.Text -> Either SomeException a) -> ReadM a+textReader p = eitherReader $ first show . p . T.pack+{-# INLINE textReader #-}++int :: Integral a => Num b => a -> b+int = fromIntegral+{-# INLINE int #-}++sshow :: Show a => IsString b => a -> b+sshow = fromString . show+{-# INLINE sshow #-}++quoted :: IsString a => Monoid a => a -> a+quoted b = "\"" <> b <> "\""+{-# INLINE quoted #-}++nat :: forall (n :: Nat) a . KnownNat n => Integral a => a+nat = int $ natVal' (proxy# :: Proxy# n)+{-# INLINE nat #-}++-- | Encode to or from little endian. This is @id@ on little endian platforms.+--+le64 :: Word64 -> Word64+le64 = f targetByteOrder+ where+ f BigEndian = byteSwap64+ f LittleEndian = id+ {-# INLINE f #-}+{-# INLINE le64 #-}++-- | Encode to or from little endian. This is @id@ on little endian platforms.+--+le64# :: Word# -> Word#+le64# = f targetByteOrder+ where+ f BigEndian x = byteSwap64# x+ f LittleEndian x = x+ {-# INLINE f #-}+{-# INLINE le64# #-}++-- | the Position is indexed in bytes+--+peekWord64OffLe :: Ptr Word64 -> Int -> IO Word64+peekWord64OffLe ptr i = le64 <$> peekByteOff ptr i+{-# INLINE peekWord64OffLe #-}++seconds :: Integer -> TimeSpec+seconds i = fromNanoSecs $ i * 1_000_000_000+{-# INLINE seconds #-}++secondsNs :: Integer -> Integer+secondsNs i = i * 1_000_000_000+{-# INLINE secondsNs #-}++writeTMVar :: TMVar a -> a -> STM ()+writeTMVar var a = tryTakeTMVar var >> putTMVar var a+{-# INLINE writeTMVar #-}++-- -------------------------------------------------------------------------- --+-- BigNum Compatibility++-- | @naturalLog2@ is only available starting with GHC-9 via the ghc-bignum package.+--+naturalLog2_compat :: Natural -> Word+naturalLog2_compat = int . integerLogBase 2 . int+{-# INLINE naturalLog2_compat #-}++#if !MIN_VERSION_base(4,15,0)+naturalLog2 :: Natural -> Word+naturalLog2 = naturalLog2_compat+{-# INLINE naturalLog2 #-}+#endif++-- -------------------------------------------------------------------------- --+-- HostAddress Orphans++instance ToJSON HostAddress where+ toJSON = toJSON . hostAddressToText+ {-# INLINE toJSON #-}++instance FromJSON HostAddress where+ parseJSON = withText "HostAddress"+ $ either (fail . show) return . hostAddressFromText+ {-# INLINE parseJSON #-}++instance ToJSON Port where+ toJSON = toJSON . int @_ @Int++instance FromJSON Port where+ parseJSON = parseJSON @Int >=> \x -> if+ | 0 <= x && x <= int (maxBound @Word16) -> return $ int x+ | otherwise -> fail $ "invalid port number: " <> sshow x++-- -------------------------------------------------------------------------- --+-- Host Preference++hostPreferenceToText :: HostPreference -> T.Text+hostPreferenceToText NI.HostAny = "*"+hostPreferenceToText NI.HostIPv4 = "*4"+hostPreferenceToText NI.HostIPv4Only = "!4"+hostPreferenceToText NI.HostIPv6 = "*6"+hostPreferenceToText NI.HostIPv6Only = "!6"+hostPreferenceToText (NI.Host s) = T.pack s++hostPreferenceFromText :: MonadThrow m => T.Text -> m HostPreference+hostPreferenceFromText "*" = return NI.HostAny+hostPreferenceFromText "*4" = return NI.HostIPv4+hostPreferenceFromText "!4" = return NI.HostIPv4Only+hostPreferenceFromText "*6" = return NI.HostIPv6+hostPreferenceFromText "!6" = return NI.HostIPv6Only+hostPreferenceFromText s = NI.Host . T.unpack . hostnameToText <$> hostnameFromText s++instance ToJSON HostPreference where+ toJSON = toJSON . hostPreferenceToText+ {-# INLINE toJSON #-}++instance FromJSON HostPreference where+ parseJSON = withText "HostPreference" $ \t -> case hostPreferenceFromText t of+ Left e -> fail $ show e+ Right h -> return h+ {-# INLINE parseJSON #-}+
src/Worker.hs view
@@ -1,9 +1,12 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} -- | -- Module: Worker@@ -20,7 +23,8 @@ Target(..) , encodeTarget , decodeTarget-, targetToText16+, targetToText16Le+, targetToText16Be -- * Mining Work , Work(..)@@ -34,41 +38,21 @@ , Worker ) where -import qualified Data.ByteArray.Encoding as BA+import qualified Data.Aeson as A import Data.Bytes.Get import Data.Bytes.Put import qualified Data.ByteString.Short as BS import Data.Hashable-import qualified Data.Text as T-import qualified Data.Text.Encoding as T import Data.Word import GHC.Generics --- -------------------------------------------------------------------------- ----- Hash Target---- | Hash target. A little endian encoded 256 bit (unsigned) word.------ Cf. https://github.com/kadena-io/chainweb-node/wiki/Block-Header-Binary-Encoding#work-header-binary-format----newtype Target = Target { _targetBytes :: BS.ShortByteString }- deriving (Show, Eq, Ord, Generic)- deriving newtype (Hashable)--decodeTarget :: MonadGet m => m Target-decodeTarget = Target . BS.toShort <$> getBytes 32-{-# INLINE decodeTarget #-}+import Text.Read -encodeTarget :: MonadPut m => Target -> m ()-encodeTarget (Target b) = putByteString $ BS.fromShort b-{-# INLINE encodeTarget #-}+-- internal modules --- | Represent target bytes in hexadecimal base----targetToText16 :: Target -> T.Text-targetToText16 = T.decodeUtf8 . BA.convertToBase BA.Base16 . BS.fromShort . _targetBytes-{-# INLINE targetToText16 #-}+import Utils+import Target -- -------------------------------------------------------------------------- -- -- Work@@ -78,10 +62,23 @@ -- -- Cf. https://github.com/kadena-io/chainweb-node/wiki/Block-Header-Binary-Encoding#work-header-binary-format --+-- NOTE: in Stratum this value is represented as encoded hexadecimal JSON+-- string.+-- newtype Work = Work BS.ShortByteString- deriving (Show, Eq, Ord, Generic)+ deriving (Eq, Ord, Generic) deriving newtype (Hashable)+ deriving (A.ToJSON, A.FromJSON) via HexEncodedShortByteString +instance Show Work where+ show (Work b) = "Work " <> show (HexEncodedShortByteString b)++instance Read Work where+ readPrec = do+ Symbol "Work" <- lexP+ (HexEncodedShortByteString b) <- readPrec+ return (Work b)+ decodeWork :: MonadGet m => m Work decodeWork = Work . BS.toShort <$> getBytes 286 {-# INLINE decodeWork #-}@@ -96,8 +93,9 @@ -- | POW Nonce -- newtype Nonce = Nonce Word64- deriving (Show, Eq, Ord, Generic)+ deriving (Eq, Ord, Generic) deriving newtype (Hashable)+ deriving (Show, A.ToJSON, A.FromJSON) via (IntHexText Word64) -- -------------------------------------------------------------------------- -- -- Mining Worker
src/Worker/CPU.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -21,91 +22,27 @@ import Crypto.Hash.IO import qualified Data.ByteArray as BA-import Data.Bytes.Signed import qualified Data.ByteString as B import qualified Data.ByteString.Short as BS import Data.Int import Data.IORef-import qualified Data.Memory.Endian as BA import qualified Data.Text as T-import Data.Time.Clock.System import Data.Word import Foreign.Marshal.Alloc (allocaBytes)-import Foreign.Ptr (Ptr, castPtr)-import Foreign.Storable (peekElemOff, pokeByteOff)+import Foreign.Ptr (castPtr) +import GHC.Exts+ import System.LogLevel -- internal modules import Logger+import Target import Worker---- -------------------------------------------------------------------------- ----- Utils--int :: Integral a => Num b => a -> b-int = fromIntegral--getCurrentTimeMicros :: IO Int64-getCurrentTimeMicros = do- MkSystemTime secs nanos <- getSystemTime- return $! secs * 1000000 + (int nanos `div` 1000)---- | `injectNonce` makes low-level assumptions about the byte layout of a--- hashed `BlockHeader`. If that layout changes, this functions need to be--- updated. The assumption allows us to iterate on new nonces quickly.------ Recall: `Nonce` contains a `Word64`, and is thus 8 bytes long.------ See also: https://github.com/kadena-io/chainweb-node/wiki/Block-Header-Binary-Encoding----injectNonce :: Nonce -> Ptr Word8 -> IO ()-injectNonce (Nonce n) buf = pokeByteOff buf 278 n-{-# INLINE injectNonce #-}--injectTime :: Int64 -> Ptr Word8 -> IO ()-injectTime t buf = pokeByteOff buf 8 $ encodeTimeToWord64 t-{-# INLINE injectTime #-}--encodeTimeToWord64 :: Int64 -> Word64-encodeTimeToWord64 t = BA.unLE . BA.toLE $ unsigned t-{-# INLINE encodeTimeToWord64 #-}---- | `PowHashNat` interprets POW hashes as unsigned 256 bit integral numbers in--- little endian encoding, hence we compare against the target from the end of--- the bytes first, then move toward the front 8 bytes at a time.----fastCheckTarget :: Ptr Word64 -> Ptr Word64 -> IO Bool-fastCheckTarget !trgPtr !powPtr =- fastCheckTargetN 3 trgPtr powPtr >>= \case- LT -> return False- GT -> return True- EQ -> fastCheckTargetN 2 trgPtr powPtr >>= \case- LT -> return False- GT -> return True- EQ -> fastCheckTargetN 1 trgPtr powPtr >>= \case- LT -> return False- GT -> return True- EQ -> fastCheckTargetN 0 trgPtr powPtr >>= \case- LT -> return False- GT -> return True- EQ -> return True-{-# INLINE fastCheckTarget #-}---- | Recall that `peekElemOff` acts like `drop` for the size of the type in--- question. Here, this is `Word64`. Since our hash is treated as a `Word256`,--- each @n@ knocks off a `Word64`'s worth of bytes, and there would be 4 such--- sections (64 * 4 = 256).------ This must never be called for @n >= 4@.----fastCheckTargetN :: Int -> Ptr Word64 -> Ptr Word64 -> IO Ordering-fastCheckTargetN n trgPtr powPtr = compare- <$> peekElemOff trgPtr n- <*> peekElemOff powPtr n-{-# INLINE fastCheckTargetN #-}+import WorkerUtils+import Utils -- -------------------------------------------------------------------------- -- -- Worker@@ -120,49 +57,48 @@ . HashAlgorithm a => Logger -> Worker-cpuWorker logger orig@(Nonce o) target work = do+cpuWorker logger orig@(Nonce o) trg work = do nonces <- newIORef 0- BA.withByteArray tbytes $ \trgPtr -> do- !ctx <- hashMutableInit @a- new <- BA.copy hbytes $ \buf ->- allocaBytes (powSize :: Int) $ \pow -> do+ !ctx <- hashMutableInit @a+ new <- BA.copy hbytes $ \buf ->+ allocaBytes (powSize :: Int) $ \pow -> do - -- inner mining loop- --- let go1 0 n = return (Just n)- go1 !i !n@(Nonce nv) = do- -- Compute POW hash for the nonce- injectNonce n buf- hash ctx buf pow+ -- inner mining loop+ --+ let go1 0 n = return (Just n)+ go1 !i n@(Nonce nv) = do+ -- Compute POW hash for the nonce+ injectNonce_ n buf+ hash ctx buf pow - -- check whether the nonce meets the target- fastCheckTarget trgPtr (castPtr pow) >>= \case- True -> Nothing <$ writeIORef nonces (nv - o)- False -> go1 (i - 1) (Nonce $! nv + 1)+ -- check whether the nonce meets the target+ fastCheckTarget trgWords (castPtr pow) >>= \case+ True -> Nothing <$ writeIORef nonces (nv - o)+ False -> go1 (i - 1) (Nonce $! nv + 1) - -- outer loop- -- Estimates how many iterations of the inner loop run in one second. It runs the inner loop- -- that many times and injects an updated creation time in each cycle.- let go0 :: Int -> Int64 {- microseconds -} -> Nonce -> IO ()- go0 x t !n = do- injectTime t buf- go1 x n >>= \case- Nothing -> return ()- Just n' -> do- t' <- getCurrentTimeMicros- let td = t' - t- x' = round @Double (int x * 1000000 / int td) -- target 1 second- go0 x' t' n'+ -- outer loop+ -- Estimates how many iterations of the inner loop run in one second. It runs the inner loop+ -- that many times and injects an updated creation time in each cycle.+ let go0 :: Int -> Int64 {- microseconds -} -> Nonce -> IO ()+ go0 x t !n = do+ injectTime_ t buf+ go1 x n >>= \case+ Nothing -> return ()+ Just n' -> do+ t' <- getCurrentTimeMicros+ let td = t' - t+ x' = round @Double (int x * 1000000 / int td) -- target 1 second+ go0 x' t' n' - -- Start outer mining loop- t <- getCurrentTimeMicros- go0 100000 t orig- attempts <- readIORef nonces- writeLog logger Info $ "Solved header with " <> T.pack (show attempts) <> " attempts."- return (Work $ BS.toShort new)+ -- Start outer mining loop+ t <- getCurrentTimeMicros+ go0 100000 t orig+ attempts <- readIORef nonces+ writeLog logger Info $ "Solved header with " <> T.pack (show attempts) <> " attempts."+ return (Work $ BS.toShort new) where- tbytes = let (Target b) = target in BS.fromShort b- hbytes = let (Work b) = work in BS.fromShort b+ !trgWords = targetToWords trg+ !hbytes = let (Work b) = work in BS.fromShort b bufSize :: Int !bufSize = B.length hbytes
src/Worker/External.hs view
@@ -78,7 +78,7 @@ withLogTag logger "Worker" $ \workerLogger -> P.withCreateProcess workerProc (go workerLogger) where- targetArg = T.unpack $ targetToText16 target+ targetArg = T.unpack $ targetToText16Le target workerProc = (P.shell $ cmd <> " " <> targetArg) { P.std_in = P.CreatePipe@@ -96,7 +96,7 @@ code <- P.waitForProcess ph (outbytes, _) <- (,) <$> wait stdoutThread <*> wait stderrThread writeLog logger Info "received nonce for solved work from external worker"- if (code /= ExitSuccess)+ if code /= ExitSuccess then throwM $ ExternalWorkerException $ "External worker failed with code: " <> (T.pack . show) code@@ -118,7 +118,7 @@ | otherwise -> return $ Work $! BS.toShort $ B.take 278 (BS.fromShort work) <> B.reverse bs - go _ _ _ _ _ = throwM $ ExternalWorkerException $+ go _ _ _ _ _ = throwM $ ExternalWorkerException "impossible: process is opened with CreatePipe in/out/err" errThread l hstderr = next
src/Worker/Simulation.hs view
@@ -28,7 +28,6 @@ import Control.Concurrent (threadDelay) import Data.Aeson-import qualified Data.ByteString.Short as BS import Data.Hashable import qualified Data.Text as T @@ -62,7 +61,7 @@ -- the work bytes unchanged after that time has passed. -- simulationWorker :: Logger -> MWC.GenIO -> HashRate -> Worker-simulationWorker logger rng rate _nonce (Target targetBytes) work = do+simulationWorker logger rng rate _nonce (Target targetNat) work = do delay <- round <$> MWC.exponential scale rng logg Info $ "solve time (microseconds): " <> T.pack (show delay) threadDelay delay@@ -81,5 +80,5 @@ -- Target is an little endian encoded (unsigned) 256 bit word. targetNum :: Rational- targetNum = foldr (\b a -> fromIntegral b + 256 * a) 0 $ BS.unpack $ targetBytes+ targetNum = fromIntegral targetNat
+ src/Worker/Stratum.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module: Worker.Stratum+-- Copyright: Copyright © 2021 Kadena LLC.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@kadena.io>+-- Stability: experimental+--+-- Kadena Stratum Mining Protocol+--+-- cf. https://gist.github.com/mightybyte/f1567c2bec0380539c638225fb8c1cf4+--+-- TODO+--+-- * Create datatype for Error codes+-- * Find out if there is some standard for reporting errors+-- * proper reporting of discarded and stale shares (what are the precise modes)+--+-- Open Questions+-- * is authorizaiton required or optional (what are possible results)+-- * meaning of result of submit+-- * precise meaning notify 'clear' field+--+module Worker.Stratum+( submitWork+) where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Monad.Catch++import qualified Data.HashMap.Strict as HM+import Data.IORef+import qualified Data.Text as T++import qualified System.LogLevel as L++-- internal modules++import Logger+import Target+import Utils+import Worker+import WorkerUtils+import Worker.Stratum.Protocol+import Worker.Stratum.Server++-- -------------------------------------------------------------------------- --+-- Worker Interface++-- | This is called from the mining loop of chainweb-mining-client:+--+-- It is recommended to start several worker threads, so that there are always+-- enough active work items available.+--+submitWork :: StratumServerCtx -> Logger -> Nonce -> Target -> Work -> IO Work+submitWork ctx l nonce trg work = withLogTag l "Stratum Worker" $ \logger ->+ let run w = waitForFirst+ (runJob ctx logger nonce trg w)+ (threadDelay jobRateMicros >> run (incrementTimeMicros jobRateMicros w))+ in run work+ where+ jobRateMicros :: Integral a => a+ jobRateMicros = 1000 * fromIntegral (_ctxRate ctx)++ waitForFirst :: IO Work -> IO Work -> IO Work+ waitForFirst a b = race a b >>= \case+ Right x -> return x+ Left x -> return x+++runJob :: StratumServerCtx -> Logger -> Nonce -> Target -> Work -> IO Work+runJob ctx logger _nonce trg work = mask $ \umask -> do+ job <- umask $ newJob logger ctx trg work+ flip onException (writeLog logger L.Info ("discarded unfinished job: " <> sshow (_jobId job))) $+ flip finally (removeJob ctx (_jobId job)) $ umask $ checkJob job+ where+ -- Check that the solution for a job is correct. This should never fail.+ -- Sessions should only submit shares that are actually solving the+ -- block.+ checkJob job = do+ nonce <- takeMVar (_jobResult job) -- at this point the mvar is available again+ !w <- injectNonce nonce (_jobWork job)+ checkTarget (_jobTarget job) w >>= \case+ True -> do+ writeLog logger L.Info $ "submitted job " <> sshow (_jobId job)+ return w+ False -> do+ writeLog logger L.Error $ "rejected job: invalid result " <> sshow (_jobId job)+ writeLog logger L.Info $ "invalid nonce: " <> sshow nonce+ <> ", target: " <> sshow (_jobTarget job)+ <> ", job work: " <> sshow (_jobWork job)+ <> ", result work: " <> sshow w+ <> ". Continue with job"+ checkJob job++newJob :: Logger -> StratumServerCtx -> Target -> Work -> IO Job+newJob logger ctx trg work = do++ -- Create new job+ jid <- atomicModifyIORef' (_ctxCurrentId ctx) (\x -> (nextJobId x, x))+ job <- Job jid trg work <$> newEmptyMVar++ flip onException (removeJob ctx jid) $ do++ -- add job to the job table+ atomically $ modifyTVar' (_ctxJobs ctx) $ HM.insert jid job++ -- notify all active connections+ -- (no need to do this in the same tx as above)+ atomically $ writeTVar (_ctxCurrentJob ctx) job++ writeLog logger L.Info $ "created new job " <> T.pack (show (_jobId job))+ return job++removeJob :: StratumServerCtx -> JobId -> IO ()+removeJob ctx jid = atomically $ modifyTVar' (_ctxJobs ctx) $ HM.delete jid+
+ src/Worker/Stratum/Protocol.hs view
@@ -0,0 +1,515 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module: Worker.Stratum.Protocol+-- Copyright: Copyright © 2021 Kadena LLC.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@kadena.io>+-- Stability: experimental+--+-- TODO+--+module Worker.Stratum.Protocol+(+-- * Nonces++-- ** Nonce Size+ NonceSize+, nonceSize+, nonceSize'+, complementNonceSize++-- ** Nonce1+, Nonce1+, nonce1+, nonce1Size+, parseNonce1+, deriveNonce1++-- ** Nonce2+, Nonce2+, nonce2+, nonce2Size+, parseNonce2++, composeNonce++-- * Messages++-- ** Misc Types+, Agent+, Username+, Password+, JobId+, noJobId+, nextJobId+, ClientWorker++-- ** Requests+, MiningRequest(..)+, parseMiningRequest++-- ** Responses+, MiningResponse(..)+, parseMiningResponse+, subscribeResponse+, authorizeResponse+, authorizeError++-- ** Notificates+, MiningNotification(..)+) where++import Control.Applicative+import Control.Monad++import qualified Data.Aeson as A+import qualified Data.Aeson.Types as A+import Data.Bifunctor+import Data.Bits+import Data.Hashable+import Data.Maybe+import qualified Data.Text as T++-- internal modules++import JsonRpc+import Target+import Utils+import Worker++-- -------------------------------------------------------------------------- --+-- Nonce Sizes++-- | Size of a nonce in bytes. This is a number between 0 and 8.+--+newtype NonceSize = NonceSize Int+ deriving (Show, Eq, Ord)+ deriving newtype (A.ToJSON, A.FromJSON)++-- | Smart Constructor for NonceSize+--+nonceSize :: Integral a => a -> Maybe NonceSize+nonceSize (int -> a)+ | a >= 0 && a <= 8 = Just $ NonceSize a+ | otherwise = Nothing+{-# INLINE nonceSize #-}++nonceSize' :: Show a => Integral a => a -> NonceSize+nonceSize' a = fromMaybe (error $ "Invalid Nonce Size: " <> sshow a) $ nonceSize a+{-# INLINE nonceSize' #-}++complementNonceSize :: NonceSize -> NonceSize+complementNonceSize (NonceSize a) = NonceSize (8 - a)+{-# INLINE complementNonceSize #-}++-- -------------------------------------------------------------------------- --+-- Nonce1++-- | The most significant bytes of the nonce. These are set by the pool.+--+-- The nonce bytes are injected into the work header in little endian encoding:+-- @Nonce2 <> Nonce1@+--+-- In stratum messages nonce bytes are encoded as hex strings with big endian+-- byte order.+--+data Nonce1 = Nonce1 NonceSize Nonce+ deriving (Eq, Ord)++-- | Smart Constructor for Nonce1+--+nonce1 :: NonceSize -> Nonce -> Maybe Nonce1+nonce1 (NonceSize s) n@(Nonce w)+ | w < 2 ^ (s * 8) = Just $ Nonce1 (NonceSize s) n+ | otherwise = Nothing+{-# INLINE nonce1 #-}++nonce1Size :: Nonce1 -> NonceSize+nonce1Size (Nonce1 s _) = s+{-# INLINE nonce1Size #-}++instance Show Nonce1 where+ show (Nonce1 _ n) = show n++instance A.ToJSON Nonce1 where+ toEncoding (Nonce1 _ n) = A.toEncoding n+ toJSON (Nonce1 _ n) = A.toJSON n+ {-# INLINE toEncoding #-}+ {-# INLINE toJSON #-}++parseNonce1 :: NonceSize -> A.Value -> A.Parser Nonce1+parseNonce1 s v = do+ n <- A.parseJSON v+ case nonce1 s n of+ Nothing -> fail $ "Nonce with invalid size (expected size " <> show s <> "): " <> show n+ Just x -> return x+{-# INLINE parseNonce1 #-}++deriveNonce1 :: NonceSize -> Int -> String -> Nonce1+deriveNonce1 ns@(NonceSize s) salt input = Nonce1 ns+ $ Nonce (shiftR (int $ hashWithSalt salt input) (8 * (8 - int s)))++-- -------------------------------------------------------------------------- --+-- Nonce2++-- | The least significant bytes of the nonce. These respresent the share of+-- work performed by the client.+--+-- The nonce bytes are injected into the work header in little endian encoding:+-- @Nonce2 <> Nonce1@+--+-- In stratum messages nonce bytes are encoded as hex strings with big endian+-- byte order.+--+data Nonce2 = Nonce2 NonceSize Nonce+ deriving (Eq, Ord)++-- | Smart Constructor for Nonce2+--+nonce2 :: NonceSize -> Nonce -> Maybe Nonce2+nonce2 (NonceSize s) n@(Nonce w)+ | w < 2 ^ (s * 8) = Just $ Nonce2 (NonceSize s) n+ | otherwise = Nothing+{-# INLINE nonce2 #-}++nonce2Size :: Nonce2 -> NonceSize+nonce2Size (Nonce2 s _) = s+{-# INLINE nonce2Size #-}++instance Show Nonce2 where+ show (Nonce2 _ n) = show n++instance A.ToJSON Nonce2 where+ toEncoding (Nonce2 _ n) = A.toEncoding n+ toJSON (Nonce2 _ n) = A.toJSON n+ {-# INLINE toEncoding #-}+ {-# INLINE toJSON #-}++parseNonce2 :: NonceSize -> A.Value -> A.Parser Nonce2+parseNonce2 s v = do+ n <- A.parseJSON v+ case nonce2 s n of+ Nothing -> fail $ "Nonce with invalid size (expected size " <> show s <> "): " <> show n+ Just x -> return x+{-# INLINE parseNonce2 #-}++-- | Compose Nonce1 (pool) and Nonce2 (mining client) to form the final+-- nonce.+--+-- Nonces are stored as Word64 and are injected into the block header in little+-- endian binary encoding. They are sent to the client in big endian hexadecimal+-- encoding.+--+composeNonce :: Nonce1 -> Nonce2 -> Nonce+composeNonce (Nonce1 (NonceSize s1) (Nonce n1)) (Nonce2 (NonceSize s2) (Nonce n2))+ | s1 + s2 == 8 = Nonce $ shiftL n2 (8 * int s1) + n1+ | otherwise = error $ "composeNonce: invalid size of combined nonce"+ <> "; size of nonce1: " <> show s1+ <> "; size of nonce2: " <> show s2+{-# INLINE composeNonce #-}++-- -------------------------------------------------------------------------- --+-- Parameter Types++-- | The mining agent of the client. For Kadena pools this can be any string.+--+newtype Agent = Agent T.Text+ deriving (Eq, Ord)+ deriving newtype (Show, A.ToJSON, A.FromJSON)++-- | Kadena Pools expect the user name to be the miner key. An optional worker+-- id can be appended with a dot as separator. It allows users to to identify+-- shares/rewards with workers in the statistics of the pool.+--+newtype Username = Username T.Text+ deriving (Eq, Ord)+ deriving newtype (Show, A.ToJSON, A.FromJSON)++-- | This is currently ignored by all Kadena Pools.+--+newtype Password = Password T.Text+ deriving (Eq, Ord)+ deriving newtype (Show, A.ToJSON, A.FromJSON)++-- | The Identifier for a job that is sent to the client. It is used to match a+-- nonce that is submitted by the client with a work header.+--+newtype JobId = JobId Int+ deriving (Eq, Ord)+ deriving newtype (Hashable)+ deriving (Show, A.ToJSON, A.FromJSON) via (IntHexText Int)++noJobId :: JobId+noJobId = JobId (-1)++nextJobId :: JobId -> JobId+nextJobId (JobId i) = JobId (i + 1)+{-# INLINE nextJobId #-}++-- | A string that identifies the client mining device. It is submited with+-- shares and pools may keep a record for the user to identify what device mined+-- shares.+--+newtype ClientWorker = ClientWorker T.Text+ deriving (Show, Eq, Ord)+ deriving newtype (A.ToJSON, A.FromJSON)++-- -------------------------------------------------------------------------- --+-- Requests++data MiningRequest+ = Subscribe MsgId (Agent, Static 'Nothing)+ -- ^ Subscribe+ --+ -- * params: @["agent", null]@+ -- * result: @[null, "nonce1", "nonce2 size"]@+ --+ -- nonce_1 is first part of the block header nonce in hex.+ --+ -- request:+ --+ -- @+ -- {+ -- "id": 1,+ -- "method": "mining.subscribe",+ -- "params": ["kdaminer-v1.0.0", null]+ -- }+ -- @+ --+ -- response:+ --+ -- @+ -- {+ -- "id": 1,+ -- "result": [null, "012345", 5],+ -- "error": null+ -- }+ -- @+ --+ -- Note: BM-K1 omits the @null@ parameter+ --+ | Authorize MsgId (Username, Password)+ -- ^ Authorize+ --+ -- * params: @["username.worker", "password"]@+ -- * result: @true@+ --+ -- @username@ is the wallet address. Worker id is used to identify the+ -- device. It is not clear to what extend different pools support the+ -- addition of the worker to the username in this message.+ --+ -- @password@ is ignored by all Kadena pools.+ --+ -- request:+ --+ -- @+ -- {+ -- "id": 2,+ -- "method": "mining.authorize",+ -- "params": ["900703b6dd2493696068af72957a94129e54e85f269becc665672bf4730fc6a3", "x"]+ -- }+ -- @+ --+ -- response:+ --+ -- @+ -- {+ -- "id": 2,+ -- "result": true,+ -- "error": null+ -- }+ -- @+ --+ | Submit MsgId (Username, ClientWorker, JobId, Nonce2)+ -- ^ Submit+ --+ -- * params: @["username.worker", "jobId", "nonce2"]@+ -- * result: @true / false@+ --+ -- request:+ --+ -- @+ -- {+ -- "id": 102,+ -- "method": "mining.submit",+ -- "params": [+ -- "900703b6dd2493696068af72957a94129e54e85f269becc665672bf4730fc6a3.worker1",+ -- "1234",+ -- "6789abcdef"+ -- ]+ -- }+ -- @+ --++deriving instance Show MiningRequest++instance A.ToJSON MiningRequest where+ toEncoding = A.pairs . mconcat . \case+ Subscribe mid params -> requestProperties "mining.subscribe" params (Just mid)+ Authorize mid params -> requestProperties "mining.authorize" params (Just mid)+ Submit mid params -> requestProperties "mining.submit" params (Just mid)+ toJSON = A.object . \case+ Subscribe mid params -> requestProperties "mining.subscribe" params (Just mid)+ Authorize mid params -> requestProperties "mining.authorize" params (Just mid)+ Submit mid params -> requestProperties "mining.submit" (submitParams params) (Just mid)+ where+ submitParams (Username u, ClientWorker w, j, n) = (u <> "." <> w, j, n)+ {-# INLINE toEncoding #-}+ {-# INLINE toJSON #-}++parseMiningRequest+ :: NonceSize+ -- ^ Nonce2 size+ -> A.Value+ -> A.Parser MiningRequest+parseMiningRequest n2s = A.withObject "MiningRequest" $ \o -> do+ mid <- (o A..: "id") :: A.Parser MsgId+ (o A..: "method") >>= \case+ "mining.subscribe" -> (Subscribe mid <$> parseSubscribeParams o) A.<?> A.Key "mining.subscribe"+ "mining.authorize" -> (Authorize mid <$> parseAuthorizeParams o) A.<?> A.Key "mining.authorize"+ "mining.submit" -> (Submit mid <$> parseSubmitParams o) A.<?> A.Key "mining.submit"+ m -> fail $ "unknown message type " <> m+ where+ parseSubmitParams o = do+ (uw, j, n) <- o A..: "params"+ n2 <- parseNonce2 n2s n+ let (u,w) = bimap Username ClientWorker $ T.break (== '.') uw+ return (u, w, j, n2)++ parseSubscribeParams o = o A..: "params"+ <|> ((, Static :: Static 'Nothing) . _getT1 <$> o A..: "params")+ <|> (\() -> (Agent "unknown", Static :: Static 'Nothing)) <$> o A..: "params"++ parseAuthorizeParams o = o A..: "params"+{-# INLINE parseMiningRequest #-}++-- -------------------------------------------------------------------------- --+-- Notification++data MiningNotification+ = SetTarget (T1 Target)+ -- ^ Set Target+ --+ -- * params: @["32 bytes target in big endian hex"]@+ --+ -- @+ -- {+ -- "id": null,+ -- "method": "mining.set_target",+ -- "params": ["0001000000000000000000000000000000000000000000000000000000000000"]+ -- }+ -- @+ --++ | Notify (JobId, Work, Bool)+ -- ^ Notify+ --+ -- * params: @["jobId", "header", cleanJob]@+ --+ -- @+ -- {+ -- "id": null,+ -- "method": "mining.notify",+ -- "params": [+ -- "1234",+ -- "286 bytes header in hex",+ -- true+ -- ]+ -- }+ -- @+ --++instance A.ToJSON MiningNotification where+ toEncoding = A.pairs . mconcat . \case+ SetTarget p -> requestProperties "mining.set_target" p Nothing+ Notify p -> requestProperties "mining.notify" p Nothing+ toJSON = A.object . \case+ SetTarget p -> requestProperties "mining.set_target" p Nothing+ Notify p -> requestProperties "mining.notify" p Nothing+ {-# INLINE toEncoding #-}+ {-# INLINE toJSON #-}++instance A.FromJSON MiningNotification where+ parseJSON = A.withObject "MiningNotification" $ \o -> do+ (o A..: "method") >>= \case+ "mining.set_target" -> SetTarget <$> o A..: "params"+ "mining.notify" -> Notify <$> o A..: "params"+ m -> fail $ "unknown message type " <> m+ {-# INLINE parseJSON #-}++-- -------------------------------------------------------------------------- --+-- Respones++data MiningResponse+ = SubscribeResponse MsgId (Either Error (Nonce1, NonceSize))+ | AuthorizeResponse MsgId (Either Error ())+ | SubmitResponse MsgId (Either Error Bool)++deriving instance Show MiningResponse++subscribeResponse :: MsgId -> Nonce1 -> NonceSize -> MiningResponse+subscribeResponse mid n1 n2s = SubscribeResponse mid $ Right (n1, n2s)++subscribeError :: MsgId -> T.Text -> MiningResponse+subscribeError mid msg = SubscribeResponse mid (Left $ Error (2,msg, A.Null))++authorizeResponse :: MsgId -> MiningResponse+authorizeResponse mid = AuthorizeResponse mid (Right ())++authorizeError :: MsgId -> T.Text -> MiningResponse+authorizeError mid msg = AuthorizeResponse mid (Left $ Error (1, msg, A.Null))++submitResponse :: MsgId -> Bool -> MiningResponse+submitResponse mid b = SubmitResponse mid (Right b)++submitError :: MsgId -> T.Text -> MiningResponse+submitError mid msg = SubmitResponse mid (Left $ Error (3, msg, A.Null))++instance A.ToJSON MiningResponse where+ toEncoding = A.pairs . mconcat . \case+ SubscribeResponse mid r -> responseProperties mid (subscribeReponseParams r)+ AuthorizeResponse mid r -> responseProperties mid r+ SubmitResponse mid r -> responseProperties mid r+ toJSON = A.object . \case+ SubscribeResponse mid r -> responseProperties mid (subscribeReponseParams r)+ AuthorizeResponse mid r -> responseProperties mid r+ SubmitResponse mid r -> responseProperties mid r+ {-# INLINE toEncoding #-}+ {-# INLINE toJSON #-}++subscribeReponseParams :: Either Error (Nonce1, NonceSize) -> Either Error (Static 'Nothing, Nonce1, NonceSize)+subscribeReponseParams (Right (n1, ns)) = Right (StaticNull, n1, ns)+subscribeReponseParams (Left e) = Left e++-- | FIXME parse nonce in subscribe response+--+parseMiningResponse+ :: (MsgId -> MiningRequest)+ -- ^ Lookup for matching MiningRequests+ -> A.Value+ -> A.Parser (MiningRequest, MiningResponse)+parseMiningResponse pendingRequests = A.withObject "MiningResponse" $ \o -> do+ mid <- (o A..: "id") :: A.Parser MsgId+ case pendingRequests mid of+ r@Subscribe{} -> (r,) . SubscribeResponse mid <$> parseResponse' parseSubscribeParams o+ r@Authorize{} -> (r,) . AuthorizeResponse mid <$> parseResponse' parseAuthorizeParams o+ r@Submit{} -> (r,) . SubmitResponse mid <$> parseResponse o++ where+ parseSubscribeParams = A.parseJSON >=> \(StaticNull, v, s) -> case nonceSize @Int s of+ Nothing -> fail $ "invalid nonce2 size. Expected a value between 0 and 8 but got " <> show s+ Just ns -> (, ns) <$> parseNonce1 (complementNonceSize ns) v++ parseAuthorizeParams = A.parseJSON >=> \(T1 StaticTrue) -> return ()+{-# INLINE parseMiningResponse #-}+
+ src/Worker/Stratum/Server.hs view
@@ -0,0 +1,700 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module: Worker.Stratum.Server+-- Copyright: Copyright © 2021 Kadena LLC.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@kadena.io>+-- Stability: experimental+--+-- TODO+--+module Worker.Stratum.Server+( withStratumServer+, Job(..)+, StratumServerCtx(..) -- TODO only expose API+, StratumDifficulty(..)+, stratumDifficultyFromText+) where++import Control.Concurrent.Async+import Control.Concurrent.MVar+import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Catch+import Control.Monad.IO.Class++import qualified Data.Aeson as A+import qualified Data.Aeson.Types as A+import qualified Data.Attoparsec.ByteString as P+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.HashMap.Strict as HM+import Data.Int+import Data.IORef+import Data.Maybe+import Data.Streaming.Network+import qualified Data.Text as T++import Network.HostAddress++import Numeric.Natural++import qualified Streaming.Prelude as S++import System.Clock+import System.IO.Unsafe+import qualified System.LogLevel as L+import System.Random.MWC++import Text.Read++-- internal modules++import JsonRpc+import Logger+import Target+import Utils+import Worker+import WorkerUtils+import Worker.Stratum.Protocol++-- -------------------------------------------------------------------------- --+-- Clients and Shares++-- | 16 bit allows for 65536 mining clients+--+-- nonce1Size :: NonceSize+-- nonce1Size = 2++data PoolCtx = PoolCtx+ { _workerAuthorization :: Authorize+ }++-- | A share is a solution of a job with respect to the session target.+--+-- Shares are the basis for paying out miners. This structure stores all+-- information about a share that is needed for a pool to implement differnt+-- payment methods.+--+data Share = Share+ { _shareId :: !JobId+ , _shareTarget :: !Target+ , _shareWork :: !Work+ -- ^ work with nonce of the share+ , _shareMiner :: !Username+ , _shareWorkerId :: !ClientWorker+ , _shareIsBlock :: !Bool+ }++data MiningClient = MiningClient+ { _miningClientNonce1 :: !Nonce1+ , _miningClientCurrentTarget :: !Target+ , _miningClientShares :: !Share+ }++-- authorize :: Username -> WorkerId -> Password -> IO Bool+-- authorize = error "TODO"++-- -------------------------------------------------------------------------- --+-- Intialize Global Stratum Server++serverSalt :: Int+serverSalt = unsafePerformIO $ do+ createSystemRandom >>= uniform+{-# NOINLINE serverSalt #-}++type Authorize = Username -> Password -> IO (Either T.Text ())++-- | TODO distinguish between job and share:+--+-- Job: global from worker, solution for block+-- Share: session, solution for share target+--+data Job = Job+ { _jobId :: !JobId+ , _jobTarget :: !Target+ , _jobWork :: !Work+ , _jobResult :: !(MVar Nonce)+ }++incrementJobTime :: Int64 -> Job -> Job+incrementJobTime i job = job+ { _jobWork = incrementTimeMicros i (_jobWork job)+ }++noopJob :: Job+noopJob = unsafePerformIO $ Job noJobId nullTarget (Work "") <$> newEmptyMVar+{-# NOINLINE noopJob #-}++-- | Stratum Server Context+--+-- A stratum server distributes work to clients. Solved work is recorded in+-- shares and the server keeps track of those.+--+-- Work is distributed in a non-overlapping way by assigning clients nonce+-- ranges. A nonce range is defined through an nonce prefix. The nonce prefix+-- is assigned during subscription.+--+-- The difficulty of a share is defined via a target.+--+-- Targets are adjusted from time to time and are the basis for measuring the+-- difficulty of the work that determines the value of share.+--+-- JobIds are used to match solutions (nonces) to the respective work work+-- items.+--+data StratumServerCtx = StratumServerCtx+ { _ctxAuthorizeFn :: !Authorize+ -- ^ function for user authentication and authorization. This sets+ -- the public key for paying out the mining rewards for a session.+ --+ -- Kadena pools don't use passwords and the scope of authorization is+ -- the stratum session.+ --+ -- For bookkeeping it is also possible to associate a device/worker id+ -- with the shares from a session.++ , _ctxJobs :: !(TVar (HM.HashMap JobId Job))+ -- ^ there might be some contention on this variable, but we don't care+ -- too much. It is modified only by the workers, which access it for+ -- each new work item that they get. That's roughly the block rate+ -- time the numbers of worker. The latter number should be small.+ -- (there's little benefit in having a larger number)+ --+ -- It is read by all sessions using readTVarIO. If a job disappears+ -- while processing the share, the share is still counted, even if the+ -- block is solved in between. So, the time of the `readTVarIO` of the+ -- job marks the point in time until a share must be found. (we could+ -- change that by doing another read + job lookup when the share is+ -- recorded)+ --+ -- Solutions are synchronized on the result MVar within a job.+ -- Contention on that is much lower, since only valid solution are+ -- submitted to that variable.++ , _ctxCurrentJob :: !(TVar Job)+ -- ^ the most recent job. This is used as basis for the job stream+ -- of each session. There is no guarantee that each session sees each+ -- job. Actually, it may even make sense for sessions to ignore some of+ -- these in order to reduce the number of notifications that are send to+ -- the client.++ , _ctxCurrentId :: !(IORef JobId)+ -- ^ Ticket counter for job ids.++ , _ctxDifficulty :: !StratumDifficulty++ , _ctxRate :: !Natural+ -- ^ Rate in milliseconds at which a jobs for a given work item are+ -- emitted. Note that each indiviual stratum worker will emit jobs at+ -- this rate.+ }++newStratumServerCtx :: StratumDifficulty -> Natural -> IO StratumServerCtx+newStratumServerCtx spec rate = StratumServerCtx+ (\_ _ -> return (Right ()))+ <$> newTVarIO mempty+ <*> newTVarIO noopJob+ <*> newIORef noJobId+ <*> pure spec+ <*> pure rate++-- -------------------------------------------------------------------------- --+-- Sessions++-- | 16 bit allows for 65536 mining clients/spaces+--+-- This leaves about 2^(6*8) different nonces for the miner. That's corresponds+-- to 280TH. So a miner with 280TH/s would exhaustively search this space in 1s.+--+defaultNonce1Size :: NonceSize+defaultNonce1Size = fromJust $ nonceSize @Int 2++sessionNonce2Size :: SessionState -> NonceSize+sessionNonce2Size = complementNonceSize . nonce1Size . _sessionNonce1++data SessionState = SessionState+ { _sessionNonce1 :: !Nonce1+ -- ^ a fixed unique nonce that is derived from the application+ -- and a server salt. It is used as prefix to provide the session+ -- with a private space of nonces.+ , _sessionTarget :: !(TVar Target)+ , _authorized :: !(TMVar Username)+ , _subscribed :: !(TMVar Agent)++ -- the followint entries are used to compute the estimated hashrate+ , _sessionLastShare :: !(TVar TimeSpec)+ , _sessionHashRateSum :: !(TVar HashRate)+ , _sessionShardCount :: !(TVar Int)+ -- ^ Estiumated hash rate of current session. Meassured as Hashes per second+ }++estimateHashRate :: SessionState -> IO HashRate+estimateHashRate ctx = do+ now <- getTime Monotonic++ atomically $ do+ lastShare <- swapTVar (_sessionLastShare ctx) now+ Difficulty currentDifficulty <- targetToDifficulty <$> readTVar (_sessionTarget ctx)+ HashRate prevR <- readTVar (_sessionHashRateSum ctx)+ curCount <- (+ 1) <$> readTVar (_sessionShardCount ctx)++ let currentPeriodSeconds = realToFrac (toNanoSecs (diffTimeSpec now lastShare)) / 1_000_000_000+ let recentHashRate = currentDifficulty / currentPeriodSeconds+ let newAvgHashRateSum = prevR + recentHashRate++ writeTVar (_sessionHashRateSum ctx) $ HashRate newAvgHashRateSum+ writeTVar (_sessionShardCount ctx) curCount++ return $ HashRate $ newAvgHashRateSum / int curCount++data AppResult+ = JsonRpcError T.Text+ | StratumError T.Text+ | TimeoutError T.Text+ | ConnectionClosed T.Text+ deriving (Show, Eq, Ord)++instance Exception AppResult++type RequestStream = S.Stream (S.Of MiningRequest) IO AppResult++send :: A.ToJSON a => AppData -> a -> IO ()+send app a = appWrite app (BL.toStrict $ A.encode a) >> appWrite app "\n"++replyError :: AppData -> Error -> IO ()+replyError = send++reply :: AppData -> MiningResponse -> IO ()+reply = send++targetPeriod :: Period+targetPeriod = Period 10++notify :: Logger -> AppData -> SessionState -> Job -> IO ()+notify logger app sessionCtx job = do+ writeLog logger L.Info "sending notification"+ send app $ Notify (_jobId job, _jobWork job, True) -- for now we always replace previous work+++-- | TODO: we probably need some protection against clients keeping+-- connections open without making progress.+--+-- * limit size of messages and fail parsing if the limit is exeeced+-- * add timeout within parsing of a single message+-- * add timeout for time between messages?+--+--+messages :: SessionState -> AppData -> RequestStream+messages sessionCtx app = go mempty+ where+ n2s = sessionNonce2Size sessionCtx++ go :: B.ByteString -> S.Stream (S.Of MiningRequest) IO AppResult+ go i = P.parseWith (liftIO (appRead app)) A.json' i >>= \case+ P.Fail _ path err ->+ return $ JsonRpcError $ "Failed to parse JSON RPC message: " <> T.pack err <> " " <> sshow path+ P.Partial _cont ->+ -- Can this actually happen, or would it a P.Fail?+ return $ ConnectionClosed "Connection closed unexpectedly"+ P.Done i' val -> case A.parse (parseMiningRequest n2s) val of+ A.Error err ->+ return $ StratumError $ "Unrecognized message: " <> T.pack err <> ". " <> sshow val+ A.Success result -> do+ S.yield result+ go i'++-- -------------------------------------------------------------------------- --+-- Stratum Server Config++data StratumDifficulty+ = WorkDifficulty+ | DifficultyLevel Level+ | DifficultyPeriod Period+ deriving (Show, Eq, Ord)++stratumDifficultyFromText :: MonadThrow m => T.Text -> m StratumDifficulty+stratumDifficultyFromText "block" = return WorkDifficulty+stratumDifficultyFromText t = case readEither @Int $ T.unpack t of+ Right n+ | 0 <= n && n <= 256 -> return $ DifficultyLevel $ level n+ | otherwise -> throwM $ FromTextException $ "Illegal value for stratum difficulty level. Expected a number between 0 and 256 but got " <> sshow n+ Left _ ->+ throwM $ FromTextException $ "failed to read stratum difficulty specification: " <> t++instance A.ToJSON StratumDifficulty where+ toJSON WorkDifficulty = "block"+ toJSON (DifficultyLevel i) = A.toJSON i+ toJSON (DifficultyPeriod i) = error "ToJSON StratumDifficulty: difficulty period is currently not supported"++instance A.FromJSON StratumDifficulty where+ parseJSON v = case v of+ A.String "block" -> return WorkDifficulty+ i@A.Number{} -> DifficultyLevel <$> A.parseJSON i+ e -> fail $ "failed to parse stratum difficulty specification: " <> show e++-- -------------------------------------------------------------------------- --+-- Target Adjustment++-- | ASICs are powerful machines. When connected to a network with low+-- difficulty it may produce a large amount of shares that can overload the+-- network, the stratum server, or the device itself. For that reason we set a+-- minimum target -- even if it means that the client does more work than needed+-- to solve a single block. In the end, producing blocks faster than they can be+-- processed down stream has no benefit and can even be harmful.+--+-- TODO: this should be configurable (possibly also on a per agent base)+--+maxSessionTarget :: Target+maxSessionTarget = mkTargetLevel $ level (42 :: Int)++-- | Start easy, the target will adjust quickly+--+initialTarget :: Target+initialTarget = maxSessionTarget++periodTolerance :: Double+periodTolerance = 0.25++-- | Purely compute a new session target+--+getNewSessionTarget+ :: StratumDifficulty+ -- ^ type of target computation+ -> HashRate+ -- ^ Current estimated hash rate+ -> Target+ -- ^ Current session target+ -> Target+ -- ^ job target+ -> Maybe Target+ -- ^ updated target+getNewSessionTarget stratumDifficulty currentHashRate currentTarget jobTarget+ | newTarget == currentTarget = Nothing+ | otherwise = Just newTarget+ where+ newTarget = case stratumDifficulty of+ WorkDifficulty -> jobTarget+ DifficultyLevel l -> mkTargetLevel l+ DifficultyPeriod p -> newPeriodTarget p++ -- The final target must be inbetween maxSessionTarget and jobTarget+ newPeriodTarget p = max jobTarget (min maxSessionTarget candidate)+ where+ curD = targetToDifficulty currentTarget+ newD = adjustDifficulty periodTolerance currentHashRate targetPeriod curD+ candidate = leveled $ difficultyToTarget newD++-- | Update the session target when a new share is found.+--+updateSessionTarget+ :: Logger+ -> StratumServerCtx+ -> AppData+ -> SessionState+ -> Job+ -> IO ()+updateSessionTarget logger serverCtx app sessionCtx job = do++ newHashRate <- estimateHashRate sessionCtx++ -- there is the chance of some race here, if we get several shares+ -- concurrently. It's possible that the effective target doesn't match the+ -- latest update of the period. We anways consider all previous targets, So+ -- not sure how much we care about this race.++ -- FIXME Find out whether changing target slows down the ASICs+ --+ -- TODO: the pool context should provide guidance what session target+ -- should be used.+ --+ currentTarget <- readTVarIO (_sessionTarget sessionCtx)+ writeLog logger L.Info $ "calculating new target"+ <> "; hashrate: " <> sshow newHashRate+ <> "; " <> prettyTarget "session" currentTarget+ <> "; " <> prettyTarget "job" (_jobTarget job)+ <> "; target Priod: " <> sshow targetPeriod+ case getNewSessionTarget (_ctxDifficulty serverCtx) newHashRate currentTarget (_jobTarget job) of+ Just t -> do+ writeLog logger L.Info $ "setting session target"+ <> "; " <> prettyTarget "new" t+ <> "; " <> prettyTarget "old" currentTarget+ <> "; " <> prettyTarget "job" (_jobTarget job)+ <> "; hashrate: " <> sshow newHashRate+ send app $ SetTarget $ T1 t+ atomically $ writeTVar (_sessionTarget sessionCtx) t+ -- Note, that there is a small chance of a race here, if the device is really fast+ -- and returns a solution before this is updated. We could solve that by+ -- making the target a TMVar or MVar and taking it before we send the+ -- "mining.set_target".+ --+ -- Most likely target changes are minor and shares are accepted even in+ -- case of a race.++ Nothing -> do+ t <- readTVarIO $ _sessionTarget sessionCtx+ writeLog logger L.Info $ "session target unchanged"+ <> "; " <> prettyTarget "session" t+ <> "; " <> prettyTarget "job" (_jobTarget job)+ where+ prettyTarget :: T.Text -> Target -> T.Text+ prettyTarget l t = l <> " " <> sshow t <> "[" <> sshow (getTargetLevel t) <> "]"++-- -------------------------------------------------------------------------- --+-- Session Loop++initialSessionState :: AppData -> IO SessionState+initialSessionState app = do+ SessionState sessionNonce1+ <$> newTVarIO initialTarget+ <*> newEmptyTMVarIO+ <*> newEmptyTMVarIO+ <*> (getTime Monotonic >>= newTVarIO)+ <*> newTVarIO (HashRate 0)+ <*> newTVarIO 0+ where+ sessionNonce1 = deriveNonce1 defaultNonce1Size serverSalt+ $ show (appSockAddr app) <> show (appLocalAddr app)++session :: Logger -> StratumServerCtx -> AppData -> IO ()+session l ctx app = withLogTag l "Stratum Session" $ \l2 -> withLogTag l2 (sshow (appSockAddr app)) $ \logger ->+ flip finally (appCloseConnection app) $ do+ sessionCtx <- initialSessionState app+ writeLog logger L.Info $ "new session"+ <> "; sessionNonce1 " <> sshow (_sessionNonce1 sessionCtx)++ -- Run Request Stream and Job Stream+ r <- race (processRequests logger sessionCtx) $ do+ awaitSubscribe sessionCtx++ -- initial target+ now <- getTime Monotonic+ atomically $ writeTVar (_sessionLastShare sessionCtx) now+ curJob <- liftIO $ readTVarIO (_ctxCurrentJob ctx)+ let jt = _jobTarget curJob+ -- TODO not sure what is a good starting value...+ -- let t = max jt (min maxSessionTarget (avgTarget maxSessionTarget jt))+ let t = max jt maxSessionTarget+ writeLog logger L.Info $ "setting initial session target: " <> sshow t+ atomically $ writeTVar (_sessionTarget sessionCtx) t+ send app $ SetTarget $ T1 t++ S.mapM_ (notify logger app sessionCtx) jobStream++ case r of+ Right _ -> writeLog logger L.Error "Stratum session ended unexpectedly because an internal chainweb-mining-client issue"+ Left e@(JsonRpcError msg) -> do+ replyError app $ Error (-32700, "Parse Error", A.String msg)+ writeLog logger L.Warn $ "session termianted with " <> sshow e+ Left e@(StratumError msg) -> do+ replyError app $ Error (-32600, "Invalid Request", A.String msg)+ -- FIXME be more specific (cf. json rpc internal error codes)+ writeLog logger L.Warn $ "session termianted with " <> sshow e+ Left e@(TimeoutError msg) -> do+ replyError app $ Error (-1, "Request Timeout", A.String msg)+ -- TODO not yet implemented+ writeLog logger L.Warn $ "session termianted with " <> sshow e+ Left e@(ConnectionClosed msg) -> do+ replyError app $ Error (-2, "Connection Error", A.String msg)+ -- TODO: is the connection actually closed if we receive this?+ -- TODO: if the connection got closed we can't reply+ writeLog logger L.Warn $ "session termianted with " <> sshow e++ where++ authorize = _ctxAuthorizeFn ctx++ awaitSubscribe sctx = atomically $ void $ takeTMVar (_subscribed sctx)++ jobStream :: S.Stream (S.Of Job) IO ()+ jobStream = do+ cur <- liftIO $ readTVarIO (_ctxCurrentJob ctx)+ go cur+ where+ go :: Job -> S.Stream (S.Of Job) IO ()+ go old = do+ new <- liftIO $ atomically $ do+ cur <- readTVar (_ctxCurrentJob ctx)+ if _jobId old == _jobId cur+ then retry+ else return cur+ S.yield new+ go new++ processRequests :: Logger -> SessionState -> IO AppResult+ processRequests logger sessionCtx = S.mapM_ (handleRequest logger sessionCtx) (messages sessionCtx app)++ handleRequest :: Logger -> SessionState -> MiningRequest -> IO ()+ handleRequest logger sessionCtx = \case++ -- AUTHORIZE+ (Authorize mid (user, pwd)) -> do+ authorize user pwd >>= \case+ Right () -> reply app $ authorizeResponse mid+ Left err -> reply app $ authorizeError mid err+ atomically $ writeTMVar (_authorized sessionCtx) user++ -- SUBSCRIBE+ (Subscribe mid (agent, _)) -> do+ reply app $ subscribeResponse mid (_sessionNonce1 sessionCtx) (sessionNonce2Size sessionCtx)+ atomically $ writeTMVar (_subscribed sessionCtx) agent++ -- SUBMIT+ (Submit mid (_u, _w, j, n2)) -> withLogTag logger ("job-" <> sshow j) $ \jlog -> do++ -- Do all checks before obtaining the lock on the job+ readTVarIO (_ctxJobs ctx) >>= \m -> case HM.lookup j m of++ -- Inactive job: Discard stale share+ Nothing -> do+ writeLog jlog L.Info "Discarded stale share"+ reply app $ SubmitResponse mid (Right False) -- FIXME is this the correct response?++ -- Active Job: Check share+ Just job -> do++ let n = composeNonce (_sessionNonce1 sessionCtx) n2++ -- Check if share is valid (matches share target)+ finalWork <- injectNonce n (_jobWork job)++ -- we make sure that we never reject shares that solved a block!+ -- (this add a little bit of skew to the share computation but everybody+ -- benefits from it. The actual problem is that we don't associate+ -- shares-works with their respective targets at notification in first place.+ -- Also, this mostly affects solo miners that use sessions targets that+ -- are, or a close to, the job targets.)+ st <- max (_jobTarget job) <$> readTVarIO (_sessionTarget sessionCtx)+ checkTarget st finalWork >>= \case++ -- Invalid Share:+ False -> do+ writeLog jlog L.Warn "reject invalid nonce"+ writeLog jlog L.Info $ "invalid nonce"+ <> "; nonce2:" <> sshow n2+ <> "; nonce: " <> sshow n+ <> "; work: " <> sshow (_jobWork job)+ <> "; final work: " <> sshow finalWork+ <> "; target: " <> sshow (_jobTarget job)+ <> "; session target: " <> sshow st+ reply app $ SubmitResponse mid (Left $ Error (31, "invalid nonce", A.Null)) -- FIXME is this correct reponse?++ -- Valid Share:+ True -> do++ updateSessionTarget logger ctx app sessionCtx job++ -- We've got a valid share+ --+ -- TODO: record share in the Pool Context+ writeLog jlog L.Info $ "got valid share"+ <> "; nonce2:" <> sshow n2+ <> "; nonce: " <> sshow n+ <> "; work: " <> sshow finalWork+ <> "; target: " <> sshow (_jobTarget job)++ -- Check whether it is a solution for the job and+ -- only submit if it is. We do this here in order to+ -- fail early and avoid contention on the job result+ -- MVar.++ -- TODO we could save a few CPU cycles by reusing the hash+ -- from the previous check+ checkTarget (_jobTarget job) finalWork >>= \case+ False ->+ reply app $ SubmitResponse mid (Right True)+ True -> do+ writeLog jlog L.Info $ "solved block: nonce2:" <> sshow n2 <> "; nonce: " <> sshow n+ -- Yeah, we've solved a block+ -- Commit final result to job+ void $ tryPutMVar (_jobResult job) n+ reply app $ SubmitResponse mid (Right True)++-- -------------------------------------------------------------------------- --+-- Stratum Server++withStratumServer+ :: Logger+ -> Port+ -> HostPreference+ -> StratumDifficulty+ -> Natural+ -> (StratumServerCtx -> IO ())+ -> IO ()+withStratumServer l port host spec rate inner = withLogTag l "Stratum Server" $ \logger -> do+ ctx <- newStratumServerCtx spec rate+ race (server logger ctx) (inner ctx) >>= \case+ Left _ -> writeLog logger L.Error "server exited unexpectedly"+ Right _ -> do+ writeLog logger L.Error "mining loop existed unexpectedly"+ return ()+ where+ server logger ctx = flip finally (writeLog logger L.Info "server stopped") $ do+ writeLog logger L.Info "Start stratum server"+ runTCPServer (serverSettingsTCP (int port) host) (session logger ctx)++-- -------------------------------------------------------------------------- --+-- Example sessions++-- $ telnet kda.f2pool.com 5400+-- Trying 47.111.206.170...+-- Connected to kda.f2pool.com.+-- Escape character is '^]'.+-- { "id":1, "method": "mining.authorize", "params":["136029d4a40642de75bebca833ea150fc027e08fbedd29c943aab87810e77378", ""] }+-- {"id":1,"result":true,"error":null}+-- { "id":2, "method": "mining.subscribe", "params":["my-miner", null] }+-- {"id":2,"result":[null,"09e8",6],"error":null}+-- {"id":null,"method":"mining.set_target","params":["0000000000ffffffffffffffffffffffffffffffffffffffffffffffffffffff"]}+-- {"id":null,"method":"mining.notify","params":["6412800009e8","00000000000000001128f13f5ccf050092f4573bc51d0fcf58a3729d3d4f57f9f279bbb50c793a6446fcfd226c8a4c1d0300080000003903c8b45da2ceaf0fab587860f7868ab29ea35fc4ac16796f7dcba43749f86b0d000000e77649998da94d3be41ad1e8d4038c0d326680a7ee9fdbaccb98f98ac25f7fe512000000d88e2cf14591a36a52bf31f1176f5306a196e95dde5e18abf6af306442a402f1019fd29b54b24d0c484656cd24bc0ba6aade86888e889f9c100100000000000014e70eccbc36b15e8960c845a895817f9cc3722059a51a233eb4839ffaa5824503000000b44b93673c8f1b633403000000000000000000000000000000000000000000006e0620000000000005000000648c1c745bcf05000000000000000000",true]}+-- {"id":null,"method":"mining.notify","params":["645a800809e8","0000000000000000f4450a405ccf0500d8c9800d1a2021618d83f88b5d1b3d21fd068d40e73676fb3b8a164d8878d51e0300010000002f4fa19a2ddbc10ffb1e6076e6ca881fbd254e109b7490ac6362c8ce371e501d08000000b8b8d54da5d10f79b9920dce6eb1884ad9cedf85640eea2ef5164fea8de08a4c09000000423e846c73a0d1f7f002bb34de2ba9b4559dea999c8a00a94caa84408cf87ceff9e53f39b6b03dbb6e67fe63d1659afc888d4842049ac7260f01000000000000dcc0c0a68efe1a30ea8d72f4a748a46b7cc1ded1d5cc5932d7709c1b9f16abd606000000f37dbe0df9aac5663403000000000000000000000000000000000000000000006d0620000000000005000000615dc5725bcf05000000000000000000",true]}+--+-- $ telenet kda.ss.poolflare.com 443+-- Trying 192.99.233.13...+-- Connected to kda.ss.poolflare.com.+-- Escape character is '^]'.+-- { "id":1, "method": "mining.authorize", "params":["136029d4a40642de75bebca833ea150fc027e08fbedd29c943aab87810e77378", ""] }+-- {"id":1,"result":true,"error":null}+-- { "id":2, "method": "mining.subscribe", "params":["my-miner", null] }+-- {"id":2,"result":[null,"a796",6],"error":null}+-- {"id":null,"method":"mining.set_target","params":["0000000000400000000000000000000000000000000000000000000000000000"]}+-- {"id":null,"method":"mining.notify","params":["5d064e41","0000000000000000ab87cfaf5ccf050098d107d0470e4de368c92aa0235e190e67cc5c7cb9ee9c485439b51c566fc249030008000000608351babdabc848f90ad4891044462291d652e390a1dd6ecbb44ab733a33dce0d000000377b67dfa6df2f33f3edcb784cf3044ceee29fefaef0b90a69996c91b874c80812000000339a23f547d271eb4a68c0761b16bb5d558a1cd927a57312ece1f5ea7381f839693e8cb25bc71cc2bcb4ef84fe0119f21300b83ab768a44105010000000000002491767e21e31c67eef18cf5e8a704dc936e3a98b026f2175e672b506fa9068203000000bfde81ee849ecca0340300000000000000000000000000000000000000000000ad0620000000000005000000e243b7415ccf05000000000000000000"]}+-- {"id":null,"method":"mining.notify","params":["02040844","0000000000000000ac87cfaf5ccf050098d107d0470e4de368c92aa0235e190e67cc5c7cb9ee9c485439b51c566fc249030008000000608351babdabc848f90ad4891044462291d652e390a1dd6ecbb44ab733a33dce0d000000377b67dfa6df2f33f3edcb784cf3044ceee29fefaef0b90a69996c91b874c80812000000339a23f547d271eb4a68c0761b16bb5d558a1cd927a57312ece1f5ea7381f839693e8cb25bc71cc2bcb4ef84fe0119f21300b83ab768a44105010000000000002491767e21e31c67eef18cf5e8a704dc936e3a98b026f2175e672b506fa9068203000000bfde81ee849ecca0340300000000000000000000000000000000000000000000ad0620000000000005000000e243b7415ccf05000000000000000000"]}+-- {"id":null,"method":"mining.notify","params":["243fc4d7","0000000000000000a298c5b05ccf050098d107d0470e4de368c92aa0235e190e67cc5c7cb9ee9c485439b51c566fc249030008000000608351babdabc848f90ad4891044462291d652e390a1dd6ecbb44ab733a33dce0d000000377b67dfa6df2f33f3edcb784cf3044ceee29fefaef0b90a69996c91b874c80812000000339a23f547d271eb4a68c0761b16bb5d558a1cd927a57312ece1f5ea7381f839693e8cb25bc71cc2bcb4ef84fe0119f21300b83ab768a44105010000000000002491767e21e31c67eef18cf5e8a704dc936e3a98b026f2175e672b506fa9068203000000bfde81ee849ecca0340300000000000000000000000000000000000000000000ad0620000000000005000000e243b7415ccf05000000000000000000"]}++-- $ telnet kda.antpool.com 9026+-- Trying 172.65.236.4...+-- Connected to 707385506aed4610a1756cb8ac239332.pacloudflare.com.+-- Escape character is '^]'.+-- { "id":1, "method": "mining.authorize", "params":["136029d4a40642de75bebca833ea150fc027e08fbedd29c943aab87810e77378", ""] }+-- {"error":null,"id":1,"result":true}+-- {"id":null,"method":"mining.set_target","params":["0000000000ffff00000000000000000000000000000000000000000000000000"]}+-- {"id":null,"method":"mining.notify","params":["425","0000000000000000f8292ccbb8ed050062ee1868a76a8dcab27205756faf64f675f719bf1abe4aaf3aa016c58bca78b703000600000059fdb247d287d818e205cb180d1990de6377953f5ced9a2f3c39baed1b209dda0b0000000614c98cabe4573ea0c10d35f842b72dfb878960131660c9a9bf26755c29b9e410000000d042253d5ab72315f2aa246aa391b997a596c7da52d086c56ecb097b3b1ef8f5d21327dc3d6a411db58e439434eab8d041c36315371f7ff73b000000000000009b8122e092a3ee286b0a6e054825cd61a10567c4525358cbc9384034959cce2a010000005820b5183128e3547b29000000000000000000000000000000000000000000002efe3000000000000500000045032236b8ed05000000000000000000",true]}+-- {"id":null,"method":"mining.notify","params":["438","000000000000000050d833cbb8ed05009cc3917479d76870c546e0d88691e70d963bef9f4ea8dcc8d41d9e9b3d7767d3030004000000d22584a2605b362cf57472e920e2daef770b7cb30066e17296b934e503e121a20600000059fdb247d287d818e205cb180d1990de6377953f5ced9a2f3c39baed1b209dda07000000b8cda94e11f8f19090986db5b9ef4f42124767f7c5071bee779851feff8d1a110f8ae2b41d2314ca286bb5876ffc3f4efa322cbdbf6aaeec3b000000000000002c032268b9e594faa613290ba5c1d49b8578c3604c040cc87265540fc93d7ed90900000058adf5dd455728697a29000000000000000000000000000000000000000000002efe3000000000000500000055e0a635b8ed05000000000000000000",true]}+-- {"id":null,"method":"mining.notify","params":["451","0000000000000000ec893bcbb8ed05009cc3917479d76870c546e0d88691e70d963bef9f4ea8dcc8d41d9e9b3d7767d3030004000000d22584a2605b362cf57472e920e2daef770b7cb30066e17296b934e503e121a20600000059fdb247d287d818e205cb180d1990de6377953f5ced9a2f3c39baed1b209dda07000000b8cda94e11f8f19090986db5b9ef4f42124767f7c5071bee779851feff8d1a110f8ae2b41d2314ca286bb5876ffc3f4efa322cbdbf6aaeec3b000000000000002c032268b9e594faa613290ba5c1d49b8578c3604c040cc87265540fc93d7ed90900000058adf5dd455728697a29000000000000000000000000000000000000000000002efe3000000000000500000055e0a635b8ed05000000000000000000",true]}+-- {"id":null,"method":"mining.notify","params":["454","00000000000000006f0d43cbb8ed05005edfece3f8b166b0084433dd2aacaa849b19d7650ad24ad93816af4cebe39a180300020000005fc46a2c71c2672d14cf5a58533cbe91df0c04c17f0f97be7a1098d01daf00cf0b0000000614c98cabe4573ea0c10d35f842b72dfb878960131660c9a9bf26755c29b9e40d0000004cff0d5516544015708da9202ebc5c162290b788166fe4fa8f823444a8009a46225e14118236c18aaac6780a1b2103b04d6f6a260952ed433c000000000000000ac24e695066907ff13c861240f973c80d42c1c4b315f22aa1f4a7ec7613e8280c000000fcc8d972caa977b36329000000000000000000000000000000000000000000002efe3000000000000500000041f14f37b8ed05000000000000000000",true]}+-- {"id":null,"method":"mining.notify","params":["467","000000000000000036bd4acbb8ed0500c204c9975e77ac13fdfe913112ff79ffdc2c1f3832427a78cee92c42447e17ed030000000000a020bb7a69c62664ddbbc45faa5532a71f3dd8b82e5f3bb6ff2e969d4dc7caad07000000b8cda94e11f8f19090986db5b9ef4f42124767f7c5071bee779851feff8d1a1108000000e9c616392da600c5d9d452490a8c2b6772999b9d026f071ec970954efeb31c62329e1465ff2d31987909a9bb96ffa1417d5e6739bc641cdd3b000000000000001c46e571fd4fc984c4a1014fd0331c237e35c14632b5aefddf8f6ee6d55eb3c005000000880047099442ae1a7a29000000000000000000000000000000000000000000002efe3000000000000500000064c14236b8ed05000000000000000000",true]}+-- {"id":null,"method":"mining.notify","params":["480","0000000000000000167a52cbb8ed05009cc3917479d76870c546e0d88691e70d963bef9f4ea8dcc8d41d9e9b3d7767d3030004000000d22584a2605b362cf57472e920e2daef770b7cb30066e17296b934e503e121a20600000059fdb247d287d818e205cb180d1990de6377953f5ced9a2f3c39baed1b209dda07000000b8cda94e11f8f19090986db5b9ef4f42124767f7c5071bee779851feff8d1a110f8ae2b41d2314ca286bb5876ffc3f4efa322cbdbf6aaeec3b000000000000002c032268b9e594faa613290ba5c1d49b8578c3604c040cc87265540fc93d7ed90900000058adf5dd455728697a29000000000000000000000000000000000000000000002efe3000000000000500000055e0a635b8ed05000000000000000000",true]}+-- {"id":null,"method":"mining.notify","params":["493","0000000000000000f5255acbb8ed0500a280506fc375d85e97cc8f0a65bf75ed26271f28b1de5e6cae62cbca2cca301b030000000000ed88eb6c75faede50680a13561a41938dfaf98a36d1e1f9359a1393b532fbb870e0000007c0360ade127803445c0d7dc99949f2af9ab8add3e220857f0aeacd1b69300e8100000003a78fd1ff11f3feed926993890fa1ef9e90628d1a25b0522a3a0d5b3197300b8104a109e2ca44a6929a0d2dc6d2130162c7b048aa864491c3c0000000000000005fc75ac3d13b3d3303132a71d31729076534968b203f17fe12dff53bc5b40fd0f000000662a1f088ff36ecb6329000000000000000000000000000000000000000000002dfe30000000000005000000a2f26c36b8ed05000000000000000000",true]}+-- {"id":null,"method":"mining.notify","params":["498","0000000000000000abf25ccbb8ed05009cc3917479d76870c546e0d88691e70d963bef9f4ea8dcc8d41d9e9b3d7767d3030004000000d22584a2605b362cf57472e920e2daef770b7cb30066e17296b934e503e121a20600000059fdb247d287d818e205cb180d1990de6377953f5ced9a2f3c39baed1b209dda07000000b8cda94e11f8f19090986db5b9ef4f42124767f7c5071bee779851feff8d1a110f8ae2b41d2314ca286bb5876ffc3f4efa322cbdbf6aaeec3b000000000000002c032268b9e594faa613290ba5c1d49b8578c3604c040cc87265540fc93d7ed90900000058adf5dd455728697a29000000000000000000000000000000000000000000002efe3000000000000500000055e0a635b8ed05000000000000000000",true]}+-- { "id":2, "method": "mining.subscribe", "params":["my-miner", null] }+-- {"error":null,"id":2,"result":[[["mining.notify","40591"],["mining.set_difficulty","40592"]],"4059",6]}++-- $ telnet 34.102.20.81 1917+-- Trying 34.102.20.81...+-- Connected to 81.20.102.34.bc.googleusercontent.com.+-- Escape character is '^]'.+-- { "id":1, "method": "mining.authorize", "params":["136029d4a40642de75bebca833ea150fc027e08fbedd29c943aab87810e77378", ""] }+-- {"result":[],"error":null,"id":1}+-- { "id":2, "method": "mining.subscribe", "params":["my-miner", null] }+-- {"result":[null,"38ba",6],"error":null,"id":2}+-- {"method":"mining.set_target","params":["00000000003fffffffffffffffffffffffffffffffffffffffffffffffffffff"],"id":null}+-- {"method":"mining.notify","params":["5d4","00000000000000005e0f4de0b8ed05001d7cf6289cebdbf3b7c156796d8a2f937792ef66abd53d0b1c78d7bd00e886270300070000008cd6b42c5d486651c209224efa1953486a6641e5fa6d4b3f96212a6676cb0cab0c000000ae6e012958c9ee703c3044aafc5dfd276ead2fdedbfe328f4d65f6990ac1e8bf1100000035971bf6d4deada7c06bfdec1865b68373158a604730224ec13585746642788d6ed88c9cfbe14532b99e7d5572d7498f932bc41662f941143c000000000000005fb2d766a58fc21f61b11f9e77f0ea77200198aef10154182e4a0c0217e3ce4c020000006e1e8bbe0c3f3cd07b29000000000000000000000000000000000000000000003afe300000000000050000008176e136b8ed05000000000000000000",true],"id":null}+-- {"method":"mining.notify","params":["5d5","0000000000000000d95e93e0b8ed050006608be04391857a960a7921209660b020ad62077e5cfadff66e70c1073e9f8c0300050000005a9d21a6bb03076830021840058fc5c96737bcd514da656bece52764c24d4aa70a00000037941034111e34be30306976d63912d1ccdfc538538d2f4c38c9d5ce19ae666a0f00000072e88ea4ffb8aa55ce46f9986a970a3d50fcf7e33d796eb1123313e5716256b55a175f9c36bdfe57c938d7b8d9b8eaab53eeb5adcc94b30c3c00000000000000fea5d9ffb9ea09369257d452cc132452cbae7039c7b812ce883ccaa8feb861c400000000db2ffb09fcbdab857b29000000000000000000000000000000000000000000003afe3000000000000500000099625c36b8ed05000000000000000000",true],"id":null}+-- {"method":"mining.notify","params":["5d6","0000000000000000d907b2e0b8ed0500ae6e012958c9ee703c3044aafc5dfd276ead2fdedbfe328f4d65f6990ac1e8bf0300020000001d7cf6289cebdbf3b7c156796d8a2f937792ef66abd53d0b1c78d7bd00e886270b000000dd1edf2d73e77956d324d3a0ff82e1c086bfb26f890e9ad2c711be558e280e6b0d00000028092a25fd071dcbece38875460d222707cf0e05a2cf56bd1aaa9c72cc3bd0c2225e14118236c18aaac6780a1b2103b04d6f6a260952ed433c000000000000000bc09afd942ff2bed160e404647cc9f4b5df50e6dc63a1be4f72f02199b2597e0c0000003ce58106702771e66329000000000000000000000000000000000000000000003afe3000000000000500000041f14f37b8ed05000000000000000000",true],"id":null}+-- {"method":"mining.notify","params":["5d7","0000000000000000f9940ce1b8ed0500850e84f9f0b5eaa7d95ed01a1b70302f0b04404335376cc81cc503aeaf838e02030002000000acb32cd9f5650670a8a1e38ec653e1dbc673e56ae9ca2fb462c4b52ab4c8a61a100000003e7ebc27d4af598daefb04dedee897e0aa9eacd538db87f6ebf792b472217423120000002db1e2ec9227c7da18eec7cdb384d0b76304f2913428781385cec4c0d5b538ee7ba55a342140fa689a4266949337723eb3591ffd694b3f053c00000000000000b799e1664c78958d44503032c50b256f5c2e2754d9061a7349f057a1229398a1110000004c285a3c7d86ebfd6329000000000000000000000000000000000000000000003bfe300000000000050000007014e235b8ed05000000000000000000",true],"id":null}+
+ src/WorkerUtils.hs view
@@ -0,0 +1,165 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module: WorkerUtils+-- Copyright: Copyright © 2021 Kadena LLC.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@kadena.io>+-- Stability: experimental+--+-- TODO+--+module WorkerUtils+( -- * Block Creation Time+ getCurrentTimeMicros+, injectTime+, injectTime_+, encodeTimeToWord64+, incrementTimeMicros+, incrementTimeMicros_++-- * Nonces+, injectNonce+, injectNonce_++-- * Check Target+, checkTarget+, fastCheckTarget+, powHash+, powHashToTargetWords+) where++import Crypto.Hash++import qualified Data.ByteArray as BA+import Data.Bytes.Signed+import qualified Data.ByteString.Short as BS+import Data.Int+import qualified Data.Memory.Endian as BA+import Data.Time.Clock.System+import Data.Word++import Foreign.Ptr (castPtr)+import Foreign.Storable (peekElemOff, pokeByteOff, peekByteOff)++import GHC.Exts++-- internal modules++import Target++import Utils++import Worker+import Data.Text.Unsafe (unsafeDupablePerformIO)++-- -------------------------------------------------------------------------- --+-- Block Creation Time++getCurrentTimeMicros :: IO Int64+getCurrentTimeMicros = do+ MkSystemTime secs nanos <- getSystemTime+ return $! secs * 1000000 + (int nanos `div` 1000)++encodeTimeToWord64 :: Int64 -> Word64+encodeTimeToWord64 t = BA.unLE . BA.toLE $ unsigned t+{-# INLINE encodeTimeToWord64 #-}++decodeTimeToInt64 :: Word64 -> Int64+decodeTimeToInt64 t = signed . BA.fromLE $ BA.LE t++{-# INLINE decodeTimeToInt64 #-}+injectTime_ :: Int64 -> Ptr Word8 -> IO ()+injectTime_ t buf = pokeByteOff buf 8 $ encodeTimeToWord64 t+{-# INLINE injectTime_ #-}++injectTime :: Int64 -> Work -> Work+injectTime t (Work bytes) = unsafeDupablePerformIO $+ BS.useAsCStringLen bytes $ \(ptr, l) -> do+ injectTime_ t (castPtr ptr)+ Work <$> BS.packCStringLen (ptr, l)+{-# INLINE injectTime #-}++incrementTimeMicros_ :: Int64 -> Ptr Word8 -> IO ()+incrementTimeMicros_ i buf = do+ t <- decodeTimeToInt64 <$> peekByteOff buf 8+ pokeByteOff buf 8 $ encodeTimeToWord64 (t + i)+{-# INLINE incrementTimeMicros_ #-}++-- | Increment the time value in a work header by the given number of+-- microseconds+--+incrementTimeMicros :: Int64 -> Work -> Work+incrementTimeMicros t (Work bytes) = unsafeDupablePerformIO $+ BS.useAsCStringLen bytes $ \(ptr, l) -> do+ incrementTimeMicros_ t (castPtr ptr)+ Work <$> BS.packCStringLen (ptr, l)+{-# INLINE incrementTimeMicros #-}++-- -------------------------------------------------------------------------- --+-- Check Work Headers++-- | `injectNonce` makes low-level assumptions about the byte layout of a+-- hashed `BlockHeader`. If that layout changes, this functions need to be+-- updated. The assumption allows us to iterate on new nonces quickly.+--+-- Recall: `Nonce` contains a `Word64`, and is thus 8 bytes long.+--+-- See also: https://github.com/kadena-io/chainweb-node/wiki/Block-Header-Binary-Encoding+--+injectNonce_ :: Nonce -> Ptr Word8 -> IO ()+injectNonce_ (Nonce n) buf = pokeByteOff buf 278 $ le64 n+{-# INLINE injectNonce_ #-}++injectNonce :: Nonce -> Work -> IO Work+injectNonce n (Work bytes) = BS.useAsCStringLen bytes $ \(ptr, l) -> do+ injectNonce_ n (castPtr ptr)+ Work <$> BS.packCStringLen (ptr, l)+{-# INLINE injectNonce #-}++-- | `PowHashNat` interprets POW hashes as unsigned 256 bit integral numbers in+-- little endian encoding, hence we compare against the target from the end of+-- the bytes first, then move toward the front 8 bytes at a time.+--+fastCheckTarget :: TargetWords -> Ptr Word64 -> IO Bool+fastCheckTarget (TargetWords a b c d) !powPtr =+ checkTargetWordOff d 3 powPtr >>= \case+ LT -> return False+ GT -> return True+ EQ -> checkTargetWordOff c 2 powPtr >>= \case+ LT -> return False+ GT -> return True+ EQ -> checkTargetWordOff b 1 powPtr >>= \case+ LT -> return False+ GT -> return True+ EQ -> checkTargetWordOff a 0 powPtr >>= \case+ LT -> return False+ GT -> return True+ EQ -> return True+{-# INLINE fastCheckTarget #-}++checkTargetWordOff :: Word64 -> Int -> Ptr Word64 -> IO Ordering+checkTargetWordOff !w !n !powPtr = compare w <$> peekElemOff powPtr n+{-# INLINE checkTargetWordOff #-}++checkTarget :: Target -> Work -> IO Bool+checkTarget t w = do+ t' <- powHashToTargetWords (powHash w)+ return $ targetFromWords t' <= t+{-# INLINE checkTarget #-}++powHashToTargetWords :: Digest Blake2s_256 -> IO TargetWords+powHashToTargetWords h = BA.withByteArray h $ \ptr -> TargetWords+ <$> peekWord64OffLe ptr 0+ <*> peekWord64OffLe ptr 8+ <*> peekWord64OffLe ptr 16+ <*> peekWord64OffLe ptr 24+{-# INLINE powHashToTargetWords #-}++powHash :: Work -> Digest Blake2s_256+powHash (Work bytes) = hash (BS.fromShort bytes)+{-# INLINE powHash #-}+
+ test/Main.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module: Main+-- Copyright: Copyright © 2021 Kadena LLC.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@kadena.io>+-- Stability: experimental+--+-- TODO+--+module Main+( main+) where++import Test.QuickCheck++import Test.Syd++-- internal modules++import qualified Test.Target+import qualified Test.Utils+import qualified Test.WorkerUtils++-- -------------------------------------------------------------------------- --+-- Main++main :: IO ()+main = sydTest tests++tests :: Spec+tests = do+ describe "Test.Target" Test.Target.tests+ describe "Test.Utils" Test.Utils.tests+ describe "Test.WorkerUtils" Test.WorkerUtils.tests++-- -- -------------------------------------------------------------------------- --+-- -- ByteSwap+--+-- prop_byteSwap_id :: ByteSwap a => a -> Property+-- prop_byteSwap_id a = a === (byteSwap . byteSwap) a+--+-- byteSwap_properties =+-- [ "@Int", property $ prop_byteSwap_id @Int+-- , "@Word", property $ prop_byteSwap_id @Word+-- , "@Word8", property $ prop_byteSwap_id @Word8j+-- , "@Word16", property $ prop_byteSwap_id @Word16+-- , "@Word32", property $ prop_byteSwap_id @Word32+-- , "@Word64", property $ prop_byteSwap_id @Word64+-- ]
+ test/Test/Target.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++-- |+-- Module: Test.Target+-- Copyright: Copyright © 2021 Kadena LLC.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@kadena.io>+-- Stability: experimental+--+-- TODO+--+module Test.Target+( tests+) where++import Control.Monad++import Data.Bits+import Data.Char+import Data.Either+import Data.String+import qualified Data.Text as T+import Data.Word++import Test.QuickCheck+import Test.Syd++import Text.Read++-- internal modules++import Target++import TestUtils++import Utils++-- -------------------------------------------------------------------------- --+-- Utils++instance Arbitrary Target where+ arbitrary = Target . fromIntegral <$> chooseInteger (0, 2^256-1)++newtype TargetBit = TargetBit Int+ deriving (Show, Eq, Ord)++instance Arbitrary TargetBit where+ arbitrary = TargetBit <$> chooseInt (0, 255)++instance Arbitrary Level where+ arbitrary = level <$> choose @Int (0, 255)++nibbleClz :: Char -> Int+nibbleClz = (\x -> x - 4) . countLeadingZeros . int @_ @Word8 . digitToInt++hexClz :: T.Text -> Int+hexClz hexStr = case T.uncons <$> T.break (/= '0') hexStr of+ (a, Nothing) -> T.length a * 4+ (a, Just (b, _)) -> T.length a * 4 + nibbleClz b++-- -------------------------------------------------------------------------- --+-- Tests++tests :: Spec+tests = describe "Target tests" $ do+ prop "prop_json_encode_decode @Target" (prop_json_encode_decode @Target)+ prop "prop_show_read @Target" (prop_show_read @Target)++ prop "prop_targetWords" prop_targetWords+ prop "prop_fromString" prop_fromString+ prop "prop_targetLevel" prop_targetLevel+ prop "prop_getTargetLevel" prop_getTargetLevel+ prop "prop_level_difficulty" prop_level_difficulty+ test_level_difficulty++ prop_read_empty+ prop_read_wrong_size+ prop_read_size++-- -------------------------------------------------------------------------- --+-- Properties++prop_read_empty :: Spec+prop_read_empty = describe "target from empty string fails" $+ prop "read empty string fails" $ isLeft $ readEither @Target $ targetString ""++prop_read_wrong_size :: Spec+prop_read_wrong_size = describe "read target of wrong size fails" $ do+ forM_ ([0..31] <> [33..40]) $ \s ->+ prop "read string of wrong size failes"+ $ fmap (isLeft . readEither @Target . targetString)+ $ vectorOf (s * 2)+ $ elements "0123456789abcdef"++prop_read_size :: Spec+prop_read_size = prop "read string of correct size succeeds"+ $ fmap (isRight . readEither @Target . targetString)+ $ vectorOf (32 * 2)+ $ elements "0123456789abcdef"++targetString :: String -> String+targetString s = "Target \"" <> s <> "\""++prop_targetWords :: Target -> Property+prop_targetWords t = targetFromWords (targetToWords t) === t++prop_fromString :: Target -> Property+prop_fromString t = (fromString $ T.unpack $ targetToText16Be t) === t++-- -------------------------------------------------------------------------- --+-- Level Stuff++prop_targetLevel :: Level -> Property+prop_targetLevel l =+ level lzc === l+ .&&.+ T.all (== 'f') r === True+ where+ (lzc, r) = case T.uncons <$> T.break (/= '0') str of+ (a, Nothing) -> (T.length a * 4, r)+ (a, Just (b, c)) -> (T.length a * 4 + nibbleClz b , c)++ str = targetToText16Be (mkTargetLevel l)++prop_getTargetLevel :: Target -> Property+prop_getTargetLevel t = getTargetLevel t === level (hexClz (targetToText16Be t))++prop_level_difficulty :: Level -> Property+prop_level_difficulty l = f l === l+ where+ f = getTargetLevel . difficultyToTarget . targetToDifficulty . mkTargetLevel++test_level_difficulty :: Spec+test_level_difficulty = describe "level is the log2 of difficulty" $+ mapM_ (\x -> it (show x) $ f x `shouldBe` x) $ level <$> [0..256]+ where+ f = getTargetLevel . difficultyToTarget . targetToDifficulty . mkTargetLevel
+ test/Test/Utils.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module: Test.Utils+-- Copyright: Copyright © 2021 Kadena LLC.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@kadena.io>+-- Stability: experimental+--+-- TODO+--+module Test.Utils+( tests+) where++import Data.Word++import Foreign.Marshal+import Foreign.Ptr+import Foreign.Storable++import Numeric.Natural++import System.IO.Unsafe++import Test.QuickCheck+import Test.Syd++import Test.QuickCheck.Instances ({- Arbitrary Natural -})++-- internal modules++import Utils++-- -------------------------------------------------------------------------- --+-- Tests++tests :: Spec+tests = describe "Utils" $ do+ prop "prop_naturalLog2" prop_naturalLog2+ prop "prop_le64_poke" prop_le64_poke+ prop "prop_le64_peek" prop_le64_peek++word8LeToWord64 :: [Word8] -> Word64+word8LeToWord64 w8s = foldr (\a c -> (int @Word8 a) + c * 256) 0 w8s++-- -------------------------------------------------------------------------- --+-- Properties++prop_naturalLog2 :: Natural -> Property+prop_naturalLog2 x = naturalLog2 x === naturalLog2_compat x++prop_le64_poke :: Word64 -> Property+prop_le64_poke w = word8LeToWord64 w8s === w+ where+ w8s = unsafePerformIO $ with (le64 w) $ peekArray 8 . castPtr++prop_le64_peek :: Property+prop_le64_peek = property $ do+ w8s <- vector 8+ let w = unsafePerformIO $ withArray w8s $ peek @Word64 . castPtr+ return $ word8LeToWord64 w8s === w
+ test/Test/WorkerUtils.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module: Test.WorkerUtils+-- Copyright: Copyright © 2021 Kadena LLC.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@kadena.io>+-- Stability: experimental+--+-- TODO+--+module Test.WorkerUtils+( tests+) where++import qualified Data.Aeson as A+import Data.Bytes.Get+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Short as BS+import Data.Maybe+import Data.Word++import Foreign.Marshal+import Foreign.Ptr+import Foreign.Storable++import System.IO.Unsafe++import Test.Syd++-- internal modules++import Target++import Worker++import WorkerUtils++import Utils++-- -------------------------------------------------------------------------- --+-- Tests++tests :: Spec+tests = do+ test_checkTarget_testHeaders++-- -------------------------------------------------------------------------- --+-- Test headers++newtype Header = Header { _headerBytes :: BS.ShortByteString }++decodeHeader :: MonadGet m => m Header+decodeHeader = Header . BS.toShort <$> getBytes 318+{-# INLINE decodeHeader #-}++testHeaders :: [Header]+testHeaders = unsafePerformIO $ do+ bs <- B.readFile "test/data/test-headers.bin"+ case go bs of+ Left e -> error $ "parsing testHeaders failed: " <> e+ Right x -> return x+ where+ go (B.splitAt 318 -> (a,b)) = (:)+ <$> runGetS decodeHeader a+ <*> parse b+ parse b+ | B.null b = return mempty+ | B.length b < 318 = Left $ "missing input bytes. Expected 318; got " <> show (B.length b)+ | otherwise = go b+{-# NOINLINE testHeaders #-}++extractTarget :: Work -> Target+extractTarget (Work bytes) = targetFromWords $ unsafePerformIO $+ BS.useAsCStringLen bytes $ \(ptr,_) -> TargetWords+ <$> peekWord64OffLe (castPtr ptr) 158+ <*> peekWord64OffLe (castPtr ptr) 166+ <*> peekWord64OffLe (castPtr ptr) 174+ <*> peekWord64OffLe (castPtr ptr) 182++testWorks :: [Work]+testWorks = Work . BS.toShort . B.take 286 . BS.fromShort . _headerBytes <$> testHeaders++-- -------------------------------------------------------------------------- --+-- Test cases++test_checkTarget_testHeaders :: Spec+test_checkTarget_testHeaders = describe "WorkerUtils.checkTarget succeeds for test headers"+ $ mapM_ (uncurry checkWork) (zip [0..] testWorks)+ where+ checkWork i w = it (show i) $+ checkTarget (extractTarget w) w `shouldReturn` True+
+ test/TestUtils.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module: TestUtils+-- Copyright: Copyright © 2021 Kadena LLC.+-- License: MIT+-- Maintainer: Lars Kuhtz <lars@kadena.io>+-- Stability: experimental+--+-- TODO+--+module TestUtils+( prop_show_read+, prop_json_encode_decode+) where++import qualified Data.Aeson as A++import Test.QuickCheck++-- -------------------------------------------------------------------------- --+-- Generic Utilities++prop_show_read :: Eq a => Show a => Read a => Arbitrary a => a -> Property+prop_show_read a = read (show a) === a++prop_json_encode_decode+ :: Eq a+ => Show a+ => Arbitrary a+ => A.ToJSON a+ => A.FromJSON a+ => a+ -> Property+prop_json_encode_decode a = A.decode (A.encode a) === Just a+