{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}

{-# OPTIONS_GHC -Wno-orphans #-}
module Ouroboros.Consensus.Mock.Node.Abstract (
    CodecConfig (..)
  , RunMockBlock (..)
  , constructMockNetworkMagic
  ) where

import           Data.Hashable (hash)
import           Data.Time.Calendar (fromGregorian)
import           Data.Time.Clock (UTCTime (..))
import           GHC.Stack

import           Ouroboros.Network.Magic (NetworkMagic (..))

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.BlockchainTime (SystemStart (..))
import           Ouroboros.Consensus.Config.SupportsNode
import           Ouroboros.Consensus.Mock.Ledger.Block
import           Ouroboros.Consensus.Protocol.Abstract

import           Ouroboros.Consensus.Storage.Serialisation

-- | Protocol specific functionality required to run consensus with mock blocks
class ( MockProtocolSpecific c ext
      , EncodeDisk (SimpleBlock c ext) (ChainDepState (BlockProtocol (SimpleBlock c ext)))
      , DecodeDisk (SimpleBlock c ext) (ChainDepState (BlockProtocol (SimpleBlock c ext)))
      ) => RunMockBlock c ext where
  mockNetworkMagic
    :: BlockConfig (SimpleBlock c ext)
    -> NetworkMagic

-- | Construct protocol magic ID depending on where in the code this is called
--
-- The sole purpose of this is to make sure that these mock protocols have
-- different IDs from each other and from regular protocols.
constructMockNetworkMagic :: HasCallStack => NetworkMagic
constructMockNetworkMagic :: NetworkMagic
constructMockNetworkMagic =
    Word32 -> NetworkMagic
NetworkMagic (Word32 -> NetworkMagic) -> Word32 -> NetworkMagic
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ String -> Int
forall a. Hashable a => a -> Int
hash (CallStack -> String
prettyCallStack CallStack
HasCallStack => CallStack
callStack)

instance RunMockBlock c ext
      => ConfigSupportsNode (SimpleBlock c ext) where
  getSystemStart :: BlockConfig (SimpleBlock c ext) -> SystemStart
getSystemStart = SystemStart -> BlockConfig (SimpleBlock c ext) -> SystemStart
forall a b. a -> b -> a
const (SystemStart -> BlockConfig (SimpleBlock c ext) -> SystemStart)
-> SystemStart -> BlockConfig (SimpleBlock c ext) -> SystemStart
forall a b. (a -> b) -> a -> b
$ UTCTime -> SystemStart
SystemStart UTCTime
dummyDate
    where
      --  This doesn't matter much
      dummyDate :: UTCTime
dummyDate = Day -> DiffTime -> UTCTime
UTCTime (Integer -> Int -> Int -> Day
fromGregorian Integer
2019 Int
8 Int
13) DiffTime
0

  getNetworkMagic :: BlockConfig (SimpleBlock c ext) -> NetworkMagic
getNetworkMagic = BlockConfig (SimpleBlock c ext) -> NetworkMagic
forall c ext.
RunMockBlock c ext =>
BlockConfig (SimpleBlock c ext) -> NetworkMagic
mockNetworkMagic