{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Module: Main
-- Copyright: Copyright © 2020 Kadena LLC.
-- License: MIT
-- Maintainer: Lars Kuhtz <lars@kadena.io>
-- Stability: experimental
--
module Main
( main
) where
import Configuration.Utils hiding (Error)
import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import Control.Exception (IOException, SomeAsyncException)
import Control.Lens hiding ((.=))
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Retry
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
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Short as BS
import Data.Hashable
import qualified Data.HashMap.Strict as HM
import Data.String
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Word
import GHC.Generics
import qualified Network.Connection as HTTP
import Network.HostAddress
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Client.TLS as HTTP
import qualified Network.HTTP.Types.Status as HTTP
import Network.Wai.EventSource.EventStream
import Network.Wai.EventSource.Streaming
import Numeric.Natural
import PkgInfo hiding (tag)
import qualified Streaming.Prelude as SP
import System.LogLevel
import qualified System.Random.MWC as MWC
import qualified Text.ParserCombinators.ReadP as R
import qualified Text.ParserCombinators.ReadPrec as P
import Text.Printf
import Text.Read (Read(..), readListPrecDefault)
-- internal modules
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 #-}
-- -------------------------------------------------------------------------- --
-- Integral Unit Prefixes
-- | TODO: make this type roundtripable and add support for fractional unit
-- prefixes.
--
newtype UnitPrefixed a = UnitPrefixed { _getUnitPrefixed :: a }
deriving newtype
( Show
, Eq
, Ord
, Enum
, Bounded
, Num
, Integral
, Fractional
, Floating
, Real
, ToJSON
, FromJSON
)
instance (Num a, Read a) => Read (UnitPrefixed a) where
readPrec = UnitPrefixed <$> readWithUnit
readListPrec = readListPrecDefault
{-# INLINE readPrec #-}
{-# INLINE readListPrec #-}
-- | Read number with Unit Prefixes. The implementation supports integral SI
-- units prefixes. Binary prefixes are supported according to ISO/IEC 80000.
--
-- "Kilo" is supported, both in upper and lower case.
--
readWithUnit :: forall a . Num a => Read a => P.ReadPrec a
readWithUnit = do
n <- readPrec
p <- P.lift $ noPrefix <|> siPrefix <|> binaryPrefix
return $! n * p
where
noPrefix :: R.ReadP a
noPrefix = 1 <$ R.eof
siPrefix :: R.ReadP a
siPrefix
= 10^(1 :: Int) <$ R.string "da"
<|> 10^(2 :: Int) <$ R.char 'h'
<|> 10^(3 :: Int) <$ (R.char 'K' <|> R.char 'k')
<|> 10^(6 :: Int) <$ R.char 'M'
<|> 10^(9 :: Int) <$ R.char 'G'
<|> 10^(12 :: Int) <$ R.char 'T'
<|> 10^(15 :: Int) <$ R.char 'P'
<|> 10^(18 :: Int) <$ R.char 'E'
<|> 10^(21 :: Int) <$ R.char 'Z'
<|> 10^(24 :: Int) <$ R.char 'Y'
binaryPrefix :: R.ReadP a
binaryPrefix
= 1024^(1 :: Int) <$ (R.string "Ki" <|> R.string "ki")
<|> 1024^(2 :: Int) <$ R.string "Mi"
<|> 1024^(3 :: Int) <$ R.string "Gi"
<|> 1024^(4 :: Int) <$ R.string "Ti"
<|> 1024^(5 :: Int) <$ R.string "Pi"
<|> 1024^(6 :: Int) <$ R.string "Ei"
<|> 1024^(7 :: Int) <$ R.string "Zi"
<|> 1024^(8 :: Int) <$ R.string "Yi"
-- -------------------------------------------------------------------------- --
-- Miner
-- | The account name is that same as the public key. Different account names
-- are not supported.
--
-- Only a single base64UrlWithoutPadding encoded key may be used and the keyset
-- is "keys-all".
--
newtype MinerPublicKey = MinerPublicKey T.Text
deriving (Show, Eq, Ord, Generic)
deriving newtype (Hashable)
instance ToJSON MinerPublicKey where
toJSON (MinerPublicKey k) = toJSON k
{-# INLINE toJSON #-}
instance FromJSON MinerPublicKey where
parseJSON = withText "MinerPublicKey" $ return . MinerPublicKey
{-# INLINE parseJSON #-}
-- TODO perform well-formedness checks
newtype Miner = Miner MinerPublicKey
deriving (Show, Eq, Ord, Generic)
deriving newtype (Hashable)
instance ToJSON Miner where
toJSON (Miner (MinerPublicKey k)) = object
[ "account" .= k
, "public-keys" .= [ k ]
, "predicate" .= ("keys-all" :: T.Text)
]
-- -------------------------------------------------------------------------- --
-- Worker Configuration
data WorkerConfig
= CpuWorker
| ExternalWorker
| SimulationWorker
deriving (Show, Eq, Ord, Generic)
deriving anyclass (Hashable)
instance ToJSON WorkerConfig where
toJSON = toJSON . workerConfigToText
{-# INLINE toJSON #-}
instance FromJSON WorkerConfig where
parseJSON = withText "WorkerConfig" $
either (fail . show) return . workerConfigFromText
{-# INLINE parseJSON #-}
workerConfigToText :: WorkerConfig -> T.Text
workerConfigToText CpuWorker = "cpu"
workerConfigToText ExternalWorker = "external"
workerConfigToText SimulationWorker = "simulation"
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
-- -------------------------------------------------------------------------- --
-- Configuration
newtype ChainwebVersion = ChainwebVersion T.Text
deriving (Show, Read, Eq, Ord, Generic)
deriving newtype (Hashable, ToJSON, FromJSON)
data Config = Config
{ _configHashRate :: !(UnitPrefixed HashRate)
, _configNode :: !HostAddress
, _configUseTls :: !Bool
, _configInsecure :: !Bool
, _configPublicKey :: !MinerPublicKey
, _configThreadCount :: !Natural
, _configGenerateKey :: !Bool
, _configLogLevel :: !LogLevel
, _configWorker :: !WorkerConfig
, _configExternalWorkerCommand :: !String
}
deriving (Show, Eq, Ord, Generic)
makeLenses ''Config
defaultConfig :: Config
defaultConfig = Config
{ _configHashRate = UnitPrefixed defaultHashRate
, _configNode = unsafeHostAddressFromText "localhost:1789"
, _configUseTls = True
, _configInsecure = True
, _configPublicKey = MinerPublicKey ""
, _configThreadCount = 10
, _configGenerateKey = False
, _configLogLevel = Info
, _configWorker = CpuWorker
, _configExternalWorkerCommand = "echo 'no external worker command configured' && /bin/false"
}
instance ToJSON Config where
toJSON c = object
[ "hashRate" .= _configHashRate c
, "node" .= _configNode c
, "useTls" .= _configUseTls c
, "insecure" .= _configInsecure c
, "publicKey" .= _configPublicKey c
, "threadCount" .= _configThreadCount c
, "generateKey" .= _configGenerateKey c
, "logLevel" .= logLevelToText @T.Text (_configLogLevel c)
, "worker" .= _configWorker c
, "externalWorkerCommand" .= _configExternalWorkerCommand c
]
instance FromJSON (Config -> Config) where
parseJSON = withObject "Config" $ \o -> id
<$< configHashRate ..: "hashRate" % o
<*< configNode ..: "node" % o
<*< configUseTls ..: "useTls" % o
<*< configInsecure ..: "insecure" % o
<*< configPublicKey ..: "publicKey" % o
<*< configThreadCount ..: "threadCount" % o
<*< configGenerateKey ..: "generateKey" % o
<*< setProperty configLogLevel "logLevel" parseLogLevel o
<*< configWorker ..: "worker" % o
<*< configExternalWorkerCommand ..: "externalWorkerCommand" % o
where
parseLogLevel = withText "LogLevel" $ return . logLevelFromText
parseConfig :: MParser Config
parseConfig = id
<$< configHashRate .:: option auto
% short 'r'
<> long "hash-rate"
<> help "hashes per second (only relevant for mining simulation, ignored by the cpu worker)"
<*< configNode .:: option (textReader hostAddressFromText)
% short 'n'
<> long "node"
<> help "node to which to connect"
<> metavar "DOMAIN:PORT"
<*< configUseTls .:: boolOption_
% short 't'
<> long "tls"
<> help "use TLS to connect to node"
<*< configInsecure .:: boolOption_
% short 'x'
<> long "insecure"
<> help "accept self-signed TLS certificates"
<*< configPublicKey .:: fmap MinerPublicKey . strOption
% short 'k'
<> long "public-key"
<> help "the public-key for the mining rewards account"
<*< configThreadCount .:: option auto
% short 'c'
<> long "thread-count"
<> help "number of concurrent mining threads"
<*< configGenerateKey .:: boolOption_
% long "generate-key"
<> help "Generate a new key pair and exit"
<*< configLogLevel .:: option (textReader $ Right . logLevelFromText)
% short 'l'
<> long "log-level"
<> help "Level at which log messages are written to the console"
<> metavar "error|warn|info|debug"
<*< configWorker .:: option (textReader workerConfigFromText)
% short 'w'
<> long "worker"
<> help "The type of mining worker that is used"
<> metavar "cpu|external|simulation"
<*< 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."
-- -------------------------------------------------------------------------- --
-- HTTP Retry Logic
-- | We don't limit retries. The maximum delay between retries is 5 seconds.
--
-- TODO: add configuration option for limitRetriesByCumulativeDelay
--
retryHttp :: Logger -> IO a -> IO a
retryHttp logger = recovering policy (httpRetryHandler logger) . const
where
policy = capDelay 5000000 $ fullJitterBackoff 100
httpRetryHandler :: Logger -> [RetryStatus -> Handler IO Bool]
httpRetryHandler logger = skipAsyncExceptions <>
[ logRetries (return . httpRetries) f
, logRetries (\(_ :: SomeException) -> return True) logRetry
]
where
logRetry True reason s = writeLog logger Warn
$ "Http request failed: " <> sshow reason
<> ". Retrying attempt " <> sshow (rsIterNumber s)
logRetry False reason s = writeLog logger Warn
$ "Http request finally failed after " <> sshow (rsIterNumber s)
<> " retries: " <> sshow reason
f True (HTTP.HttpExceptionRequest _req reason) s = logRetry True reason s
f False (HTTP.HttpExceptionRequest _req reason) s = logRetry False reason s
f _ e _ = throwM e
-- | HTTP Exceptions for which a retry may result in subsequent succes.
--
-- This retries rather aggressively on any server or network related failure
-- condition.
--
httpRetries :: HTTP.HttpException -> Bool
httpRetries (HTTP.HttpExceptionRequest _req reason) = case reason of
HTTP.StatusCodeException resp _body
| HTTP.statusIsServerError (HTTP.responseStatus resp) -> True
HTTP.ResponseTimeout -> True
HTTP.ConnectionTimeout -> True
HTTP.ConnectionFailure _e -> True
HTTP.InvalidStatusLine _bs -> True
HTTP.InvalidHeader _bs -> True
HTTP.InternalException _e -> True
HTTP.ProxyConnectException _host _port status
| HTTP.statusIsServerError status -> True
HTTP.NoResponseDataReceived -> True
HTTP.ResponseBodyTooShort _expected _actual -> True
HTTP.InvalidChunkHeaders -> True
HTTP.IncompleteHeaders -> True
HTTP.HttpZlibException _e -> True
HTTP.ConnectionClosed -> True
_ -> False
httpRetries (HTTP.InvalidUrlException _url _reason) = False
-- -------------------------------------------------------------------------- --
-- Chainweb Mining API Types
-- | ChainId
--
newtype ChainId = ChainId Word32
deriving (Show, Eq, Ord, Generic)
deriving anyclass (Hashable)
decodeChainId :: MonadGet m => m ChainId
decodeChainId = ChainId <$> getWord32le
encodeChainId :: MonadPut m => ChainId -> m ()
encodeChainId (ChainId w32) = putWord32le w32
-- -------------------------------------------------------------------------- --
-- Chainweb Mining API Requetss
newtype GetWorkFailure = GetWorkFailure T.Text
deriving (Show, Eq, Ord)
instance Exception GetWorkFailure
-- | Make an HTTP request with an JSON response
--
getJson :: FromJSON a => HTTP.Manager -> HTTP.Request -> IO a
getJson mgr req = (eitherDecode . HTTP.responseBody <$> HTTP.httpLbs req mgr) >>= \case
Left e -> error $ "Failed to decode json response: " <> show e
Right r -> return r
-- | Base request type for chainweb queries
--
baseReq :: Config -> ChainwebVersion -> B.ByteString -> HTTP.Request
baseReq conf (ChainwebVersion v) pathSuffix = HTTP.defaultRequest
{ HTTP.host = T.encodeUtf8 $ hostnameToText $ _hostAddressHost node
, HTTP.path = "chainweb/0.0/" <> T.encodeUtf8 v <> "/" <> pathSuffix
, HTTP.port = fromIntegral $ _hostAddressPort node
, HTTP.secure = _configUseTls conf
, HTTP.method = "GET"
, HTTP.checkResponse = HTTP.throwErrorStatusCodes
}
where
node = _configNode conf
-- | Query node info
--
getInfo :: Config -> HTTP.Manager -> IO (HM.HashMap T.Text Value)
getInfo conf mgr = getJson mgr req
where
req = HTTP.defaultRequest
{ HTTP.host = T.encodeUtf8 $ hostnameToText $ _hostAddressHost node
, HTTP.path = "info"
, HTTP.port = fromIntegral $ _hostAddressPort node
, HTTP.secure = _configUseTls conf
, HTTP.method = "GET"
, HTTP.checkResponse = HTTP.throwErrorStatusCodes
}
node = _configNode conf
-- | Obtain chainweb version of the chainweb node
--
-- No retry here. This is use at startup and we want to fail fast if the node
-- isn't available.
--
getNodeVersion :: Config -> HTTP.Manager -> IO ChainwebVersion
getNodeVersion conf mgr = do
i <- getInfo conf mgr
case HM.lookup "nodeVersion" i of
Just (String x) -> return $ ChainwebVersion x
_ -> error "failed to parse chainweb version from node info"
-- | Get new work from the chainweb node (for some available chain)
--
-- We don't retry here. If this fails, we loop around.
--
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
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.requestHeaders = [("content-type", "application/json")]
}
decodeJob :: MonadGet m => m (ChainId, Target, Work)
decodeJob = (,,)
<$> decodeChainId
<*> decodeTarget
<*> decodeWork
-- | Post solved work to the chainweb node
--
-- No timeout is used and in case of failure we retry aggressively. If the
-- solvedwork becomes stale, the thread will be preempted and cancled.
--
postSolved :: Config -> ChainwebVersion -> Logger -> HTTP.Manager -> Work -> IO ()
postSolved conf ver logger mgr (Work bytes) = retryHttp logger $ do
logg Info "post solved worked"
(void $ HTTP.httpLbs req mgr)
`catch` \(e@(HTTP.HttpExceptionRequest _ _)) -> do
logg Error $ "failed to submit solved work: " <> sshow e
return ()
where
logg = writeLog logger
req = (baseReq conf ver "mining/solved")
{ 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
:: Config
-> ChainwebVersion
-> Logger
-> HTTP.Manager
-> ChainId
-> TVar Int
-> IO ()
updateStream conf v logger mgr cid var =
liftIO $ withEvents req mgr $ \updates -> updates
& SP.filter realEvent
& SP.chain (\_ -> logg Info $ "got update on chain " <> sshow cid)
& SP.mapM_ (\_ -> atomically $ modifyTVar' var (+ 1))
where
logg = writeLog logger
realEvent ServerEvent{} = True
realEvent _ = False
req = (baseReq conf v "mining/updates")
{ HTTP.requestBody = HTTP.RequestBodyBS $ runPutS $ encodeChainId cid
, HTTP.responseTimeout = HTTP.responseTimeoutNone
}
-- -------------------------------------------------------------------------- --
-- Trigger Type
data Reason = Timeout | Update | StreamClosed | StreamFailed SomeException
deriving (Show)
-- | A trigger is used to preempt a worker thread.
--
newtype Trigger = Trigger (STM Reason)
awaitTrigger :: Trigger -> IO Reason
awaitTrigger (Trigger t) = atomically t
-- -------------------------------------------------------------------------- --
-- Update Map
newtype UpdateFailure = UpdateFailure T.Text
deriving (Show, Eq, Ord)
instance Exception UpdateFailure
-- | This keeps track of the current work for the respective chain. It is shared
-- among all worker threads. If an update for some chain is received the worker
-- threads are preempted and query new work.
--
-- It also keeps track of the long-polling update streams.
--
newtype UpdateMap = UpdateMap
{ _updateMap :: MVar (HM.HashMap ChainId (TVar Int, Async ()))
}
-- | Creates a map that maintains one upstream for each chain
--
newUpdateMap :: IO UpdateMap
newUpdateMap = UpdateMap <$> newMVar mempty
-- | Obtain a trigger that is used to preempt a worker threads. It notifies the
-- thread if an update is available.
--
getTrigger
:: Config
-> ChainwebVersion
-> Logger
-> HTTP.Manager
-> UpdateMap
-> ChainId
-> IO Trigger
getTrigger conf ver logger mgr (UpdateMap v) k = modifyMVar v $ \m -> case HM.lookup k m of
-- If there exists already an update stream, check that it's live, and
-- restart if necessary.
--
Just s -> do
logg Debug "use existing update stream"
n@(!var, !a) <- checkStream s
!t <- newTrigger var a
let !x = HM.insert k n m
return (x, t)
-- If there isn't an update stream in the map, create a new one.
--
Nothing -> do
logg Debug "create new update stream"
n@(!var, !a) <- newTVarIO 0 >>= newUpdateStream
!t <- newTrigger var a
let !x = HM.insert k n m
return (x, t)
where
logg = writeLog logger
checkStream :: (TVar Int, Async ()) -> IO (TVar Int, Async ())
checkStream (!var, !a) = poll a >>= \case
Nothing -> return (var, a)
Just (Left _) -> newUpdateStream var -- TODO logging, throttling
Just (Right _) -> newUpdateStream var
newUpdateStream :: TVar Int -> IO (TVar Int, Async ())
newUpdateStream var = (var,)
<$> async (updateStream conf ver logger mgr k var)
-- There are three possible outcomes
--
newTrigger :: TVar Int -> Async () -> IO Trigger
newTrigger var a = do
cur <- readTVarIO var
timeoutVar <- registerDelay (5 * 30_000_000)
-- 5 times the block time ~ 0.7% of all blocks. This for detecting if
-- a stream gets stale without failing.
return $ Trigger $ pollSTM a >>= \case
Just (Right ()) -> return StreamClosed
Just (Left e) -> return $ StreamFailed e
Nothing -> do
isTimeout <- readTVar timeoutVar
isUpdate <- (/= cur) <$> readTVar var
unless (isTimeout || isUpdate) retry
return Update
-- | Run an operation that is preempted if an update event occurs.
--
-- Streams are restarted automatically, when they got closed by the server. We
-- don't restart streams automatically in case of a failure, but instead throw
-- an exception. Failures are supposed to be handled in the outer mining
-- functions.
--
-- There is risk that a stream stalls without explicitely failing. We solve this
-- by preempting the loop if we haven't seen an update after 5 times the block
-- time (which will affect about 0.7% of all blocks).
--
withPreemption
:: Config
-> ChainwebVersion
-> Logger
-> HTTP.Manager
-> UpdateMap
-> ChainId
-> IO a
-> IO (Either () a)
withPreemption conf ver logger mgr m k = race awaitChange
where
awaitChange = do
trigger <- getTrigger conf ver logger mgr m k
awaitTrigger trigger >>= \case
StreamClosed -> awaitChange
StreamFailed e -> throwM $ UpdateFailure $ "update stream failed: " <> errMsg e
Timeout -> throwM $ UpdateFailure "timeout of update stream"
Update -> return ()
errMsg e = case fromException e of
Just (HTTP.HttpExceptionRequest _ ex) -> sshow ex
_ -> sshow e
-- -------------------------------------------------------------------------- --
-- Mining Loop
data Recovery = Irrecoverable | Recoverable
-- | The outer mining loop.
--
miningLoop
:: Config
-> ChainwebVersion
-> Logger
-> HTTP.Manager
-> UpdateMap
-> Worker
-> IO ()
miningLoop conf ver logger mgr umap worker = go
where
nonce = Nonce 0
logg = writeLog logger
go = (forever loopBody `catches` handlers) >>= \case
Irrecoverable -> return ()
Recoverable -> threadDelay 500_000 >> go
handlers =
[ Handler $ \(e :: IOException) -> do
logg Error $ T.pack $ displayException e
return Irrecoverable
, Handler $ \(e :: GetWorkFailure) -> do
logg Error $ T.pack $ displayException e
return Irrecoverable -- FIXME we want proper retry logic for all of this!
, Handler $ \(e :: UpdateFailure) -> do
logg Error $ T.pack $ displayException e
return Recoverable
, Handler $ \(e :: SomeAsyncException) -> do
logg Warn $ "Mining Loop terminated: " <> sshow e
throwM e
, Handler $ \(e :: SomeException) -> do
logg Warn "Some general error in mining loop. Trying again..."
logg Info $ "Exception: " <> T.pack (displayException e)
return Recoverable
]
loopBody = do
(cid, target, work) <- getJob conf ver mgr
logg Info $ "got new work for chain " <> sshow cid
withPreemption conf ver logger mgr umap cid (worker nonce target work) >>= \case
Right solved -> do
-- TODO: we should do this asynchronously, however, preemption
-- should still apply. So, ideally, we would kick of a new
-- asynchronous loop interation while continuing this loop
-- iteration here.
postSolved conf ver logger mgr solved
logg Debug "submitted work"
Left () ->
logg Info "Mining loop was preempted. Getting updated work ..."
-- -------------------------------------------------------------------------- --
-- Key generation
genKeys :: IO ()
genKeys = do
sk <- C.generateSecretKey
let !pk = C.toPublic sk
printf "public: %s\n" (B8.unpack $ BA.convertToBase BA.Base16 pk)
printf "private: %s\n" (B8.unpack $ BA.convertToBase BA.Base16 sk)
-- -------------------------------------------------------------------------- --
-- Main
mainInfo :: ProgramInfo Config
mainInfo = programInfo "Kadena Chainweb Mining Client" parseConfig defaultConfig
-- | TODO: validate the configuration:
--
-- * MinerPublicKey must be present
-- * node must be present
--
main :: IO ()
main = runWithPkgInfoConfiguration mainInfo pkgInfo $ \conf ->
if _configGenerateKey conf
then genKeys
else withLogger (_configLogLevel conf) $ run conf
run :: Config -> Logger -> IO ()
run conf logger = do
mgr <- HTTP.newManager (HTTP.mkManagerSettings tlsSettings Nothing)
{ HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro 1000000 }
-- We don't want to wait too long, because latencies matter in
-- mining. NOTE, however, that for large blocks it can take a while
-- to get new work. This can be an issue with public mining mode.
-- 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
where
tlsSettings = HTTP.TLSSettingsSimple (_configInsecure conf) False False
workerRate = _getUnitPrefixed (_configHashRate conf) / fromIntegral (_configThreadCount conf)