{-# 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