Mining.hs

module Integration.Mining
    ( mineTestChain
    ) where

import qualified Control.Concurrent.Async          as Async
import qualified Control.Concurrent.MVar           as MVar
import           Control.Monad                     (forM, void)
import qualified Data.Aeson                        as Aeson
import qualified Data.ByteString.Lazy              as Lazy
import qualified Data.List.NonEmpty                as NonEmpty
import           Data.Monoid                       ((<>))
import qualified Data.Time.Clock                   as Time

import qualified Data.Blockchain.Core.Blockchain   as B
import qualified Data.Blockchain.Core.Crypto       as Crypto
import qualified Data.Blockchain.Core.Types        as B
import qualified Data.Blockchain.Mining.Block      as Mining
import qualified Data.Blockchain.Mining.Blockchain as Mining

data MinerSpec = MinerSpec
    { mid               :: Int
    , pubKey            :: Crypto.PublicKey
    , receiveBlock      :: IO B.Block
    , sendBlock         :: B.Block -> IO ()
    , persistBlockchain :: B.Blockchain B.Validated -> IO ()
    }


mineTestChain :: Int -> IO ()
mineTestChain miners = runTestMultiMiner miners config persist
  where
    persist i = writeJSON $ "data/test_blockchain_" <> show i <> ".json"
    config = B.defaultConfig
        { B.initialMiningReward           = 500
        , B.difficultyRecalculationHeight = 10
        , B.miningRewardHalvingHeight     = 20
        }


runTestMultiMiner
    :: Int -> B.BlockchainConfig
    -> (Int -> B.Blockchain B.Validated -> IO ()) -> IO ()
runTestMultiMiner numMiners config persist = do
    putStrLn "Creating blockchain and mining genesis block"
    blockchain <- Mining.createBlockchain config

    let idList = [1..numMiners]

    vars <- mapM (const MVar.newEmptyMVar) idList

    let sends    = MVar.putMVar <$> vars
        receives = MVar.takeMVar <$> (tail vars <> pure (head vars))
        specs    = zip3 sends receives idList

    miners <- forM specs $ \(sendBlock, receiveBlock, mid) -> do
        let persistBlockchain = persist mid
        (Crypto.KeyPair pubKey _privKey) <- Crypto.generate
        return MinerSpec{..}

    asyncs <- mapM (Async.async . runMinerFakeNetwork blockchain) miners
    void (Async.waitAny asyncs)


runMinerFakeNetwork :: B.Blockchain B.Validated -> MinerSpec -> IO ()
runMinerFakeNetwork blockchain spec@(MinerSpec mid _pubKey receive send persist) = do
    miningThread <- Async.async $ do
        block <- runMining spec blockchain
        log' "Found block, broadcasting to other miners"
        send block

        case B.addBlock block blockchain of
            Right blockchain' -> return blockchain'
            Left  e           -> error $ "Mined invalid block: " <> show e

    receiveBlockThread <- Async.async $ do
        block <- receive

        case B.addBlock block blockchain of
            Right blockchain' -> do
                log' "Received valid block. Stopping mining on current block and re-broadcasting."
                send block
                return blockchain'
            Left e -> log' ("Received invalid block - unable to insert block into chain. Reason: " <> show e) >> return blockchain

    blockchain' <- either id id <$> Async.waitEitherCancel miningThread receiveBlockThread

    persist blockchain'
    runMinerFakeNetwork blockchain' spec
  where
    log' s = do
        timestamp <- Time.getCurrentTime
        putStrLn $ pad 30 (show timestamp) <> " [miner_" <> show mid <> "] " <> s

runMining :: MinerSpec -> B.Blockchain B.Validated -> IO B.Block
runMining (MinerSpec mid pubKey _ _ _) chain = do
    let mainChain   = NonEmpty.toList $ B.longestChain chain
        chainLength = length mainChain
        config      = B.blockchainConfig chain

    log' $ "Mining block #" <> show chainLength
    -- TODO: bad interface to find diff. Exported interface should just take blockchain.
    log' $ "Target difficulty: " <> show (B.targetDifficulty config mainChain)

    start <- Time.getCurrentTime
    block <- throwLeft <$> Mining.mineEmptyBlock pubKey chain
    end   <- Time.getCurrentTime

    let h = Crypto.hash (B.blockHeader block)

    log' "Found next block"
    log' $ "  Hash: " <> show h
    log' $ "  Elapsed time: " <> show (Time.diffUTCTime end start)

    return block
  where
    log' s = do
        timestamp <- Time.getCurrentTime
        putStrLn $ pad 30 (show timestamp) <> " [miner_" <> show mid <> "] " <> s

throwLeft :: Show a => Either a b -> b
throwLeft = either (error . show) id

pad :: Int -> String -> String
pad x str = str <> replicate (x - length str) ' '


writeJSON :: Aeson.ToJSON a => FilePath -> a -> IO ()
writeJSON path = Lazy.writeFile path . Aeson.encode