{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns             #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}

-- This module is for examples and tests (not the library) so orphans are ok
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Concrete block
--
-- The network library should not export a concrete block type at all, except
-- that it might need one in its tests (but not exported). Right now this module
-- serves to isolate this in a specific module so we can identify easily where
-- it is used; eventually it should be simplified and then moved to the
-- network layer tests; the more sophiscated block abstraction (abstracted over
-- an Ouroboros protocol) will live in the consensus layer.
module Ouroboros.Network.Testing.ConcreteBlock
  ( Block (..)
  , BlockHeader (..)
  , BlockBody (..)
  , hashHeader
  , BodyHash (..)
  , ConcreteHeaderHash (..)
  , hashBody
    -- * Converting slots to times
  , convertSlotToTimeForTestsAssumingNoHardFork
    -- * Creating sample chains
  , mkChain
  , mkChainSimple
  , mkAnchoredFragment
  , mkAnchoredFragmentSimple
    -- * Generator utilities
  , mkPartialBlock
  , mkPartialBlockHeader
  , fixupBlock
  , fixupBlockHeader
  , fixupBlockAfterBlock
  , fixupChain
  , fixupAnchoredFragmentFrom
  ) where

import           Data.ByteString (ByteString)
import           Data.Function (fix)
import           Data.Hashable
import           Data.String (IsString)
import           Data.Time.Calendar (fromGregorian)
import           Data.Time.Clock (UTCTime (..), addUTCTime,
                     secondsToNominalDiffTime)
import           NoThunks.Class (NoThunks)

import           Codec.CBOR.Decoding (decodeBytes, decodeInt, decodeListLenOf,
                     decodeWord64)
import           Codec.CBOR.Encoding (encodeBytes, encodeInt, encodeListLen,
                     encodeWord64)
import           Codec.Serialise (Serialise (..))
import           GHC.Generics (Generic)

import           Ouroboros.Network.AnchoredFragment (Anchor (..),
                     AnchoredFragment)
import qualified Ouroboros.Network.AnchoredFragment as AF
import           Ouroboros.Network.Block
import           Ouroboros.Network.MockChain.Chain (Chain)
import qualified Ouroboros.Network.MockChain.Chain as C
import           Ouroboros.Network.Point (withOrigin)
import           Ouroboros.Network.Util.ShowProxy

{-------------------------------------------------------------------------------
  Concrete block shape used currently in the network layer

  This should only exist in the network layer /tests/.
-------------------------------------------------------------------------------}

-- | Our highly-simplified version of a block. It retains the separation
-- between a block header and body, which is a detail needed for the protocols.
--
data Block = Block {
       Block -> BlockHeader
blockHeader :: BlockHeader,
       Block -> BlockBody
blockBody   :: BlockBody
     }
   deriving (Int -> Block -> ShowS
[Block] -> ShowS
Block -> String
(Int -> Block -> ShowS)
-> (Block -> String) -> ([Block] -> ShowS) -> Show Block
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Block] -> ShowS
$cshowList :: [Block] -> ShowS
show :: Block -> String
$cshow :: Block -> String
showsPrec :: Int -> Block -> ShowS
$cshowsPrec :: Int -> Block -> ShowS
Show, Block -> Block -> Bool
(Block -> Block -> Bool) -> (Block -> Block -> Bool) -> Eq Block
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Block -> Block -> Bool
$c/= :: Block -> Block -> Bool
== :: Block -> Block -> Bool
$c== :: Block -> Block -> Bool
Eq, (forall x. Block -> Rep Block x)
-> (forall x. Rep Block x -> Block) -> Generic Block
forall x. Rep Block x -> Block
forall x. Block -> Rep Block x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Block x -> Block
$cfrom :: forall x. Block -> Rep Block x
Generic)

instance ShowProxy Block where

newtype BlockBody = BlockBody ByteString
  deriving (Int -> BlockBody -> ShowS
[BlockBody] -> ShowS
BlockBody -> String
(Int -> BlockBody -> ShowS)
-> (BlockBody -> String)
-> ([BlockBody] -> ShowS)
-> Show BlockBody
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BlockBody] -> ShowS
$cshowList :: [BlockBody] -> ShowS
show :: BlockBody -> String
$cshow :: BlockBody -> String
showsPrec :: Int -> BlockBody -> ShowS
$cshowsPrec :: Int -> BlockBody -> ShowS
Show, BlockBody -> BlockBody -> Bool
(BlockBody -> BlockBody -> Bool)
-> (BlockBody -> BlockBody -> Bool) -> Eq BlockBody
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlockBody -> BlockBody -> Bool
$c/= :: BlockBody -> BlockBody -> Bool
== :: BlockBody -> BlockBody -> Bool
$c== :: BlockBody -> BlockBody -> Bool
Eq, Eq BlockBody
Eq BlockBody
-> (BlockBody -> BlockBody -> Ordering)
-> (BlockBody -> BlockBody -> Bool)
-> (BlockBody -> BlockBody -> Bool)
-> (BlockBody -> BlockBody -> Bool)
-> (BlockBody -> BlockBody -> Bool)
-> (BlockBody -> BlockBody -> BlockBody)
-> (BlockBody -> BlockBody -> BlockBody)
-> Ord BlockBody
BlockBody -> BlockBody -> Bool
BlockBody -> BlockBody -> Ordering
BlockBody -> BlockBody -> BlockBody
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BlockBody -> BlockBody -> BlockBody
$cmin :: BlockBody -> BlockBody -> BlockBody
max :: BlockBody -> BlockBody -> BlockBody
$cmax :: BlockBody -> BlockBody -> BlockBody
>= :: BlockBody -> BlockBody -> Bool
$c>= :: BlockBody -> BlockBody -> Bool
> :: BlockBody -> BlockBody -> Bool
$c> :: BlockBody -> BlockBody -> Bool
<= :: BlockBody -> BlockBody -> Bool
$c<= :: BlockBody -> BlockBody -> Bool
< :: BlockBody -> BlockBody -> Bool
$c< :: BlockBody -> BlockBody -> Bool
compare :: BlockBody -> BlockBody -> Ordering
$ccompare :: BlockBody -> BlockBody -> Ordering
$cp1Ord :: Eq BlockBody
Ord, String -> BlockBody
(String -> BlockBody) -> IsString BlockBody
forall a. (String -> a) -> IsString a
fromString :: String -> BlockBody
$cfromString :: String -> BlockBody
IsString, (forall x. BlockBody -> Rep BlockBody x)
-> (forall x. Rep BlockBody x -> BlockBody) -> Generic BlockBody
forall x. Rep BlockBody x -> BlockBody
forall x. BlockBody -> Rep BlockBody x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BlockBody x -> BlockBody
$cfrom :: forall x. BlockBody -> Rep BlockBody x
Generic)

instance Hashable BlockBody where
    hash :: BlockBody -> Int
hash (BlockBody ByteString
body) = ByteString -> Int
forall a. Hashable a => a -> Int
hash ByteString
body

hashBody :: Hashable body => body -> BodyHash
hashBody :: body -> BodyHash
hashBody body
body = Int -> BodyHash
BodyHash (body -> Int
forall a. Hashable a => a -> Int
hash body
body)

-- | A block header. It retains simplified versions of all the essential
-- elements.
--
data BlockHeader = BlockHeader {
       BlockHeader -> HeaderHash BlockHeader
headerHash     :: HeaderHash BlockHeader,  -- ^ The cached 'HeaderHash' of this header.
       BlockHeader -> ChainHash BlockHeader
headerPrevHash :: ChainHash BlockHeader,   -- ^ The 'headerHash' of the previous block header
       BlockHeader -> SlotNo
headerSlot     :: SlotNo,                  -- ^ The Ouroboros time slot index of this block
       BlockHeader -> BlockNo
headerBlockNo  :: BlockNo,                 -- ^ The block index from the Genesis
       BlockHeader -> BodyHash
headerBodyHash :: BodyHash                 -- ^ The hash of the corresponding block body
     }
   deriving (Int -> BlockHeader -> ShowS
[BlockHeader] -> ShowS
BlockHeader -> String
(Int -> BlockHeader -> ShowS)
-> (BlockHeader -> String)
-> ([BlockHeader] -> ShowS)
-> Show BlockHeader
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BlockHeader] -> ShowS
$cshowList :: [BlockHeader] -> ShowS
show :: BlockHeader -> String
$cshow :: BlockHeader -> String
showsPrec :: Int -> BlockHeader -> ShowS
$cshowsPrec :: Int -> BlockHeader -> ShowS
Show, BlockHeader -> BlockHeader -> Bool
(BlockHeader -> BlockHeader -> Bool)
-> (BlockHeader -> BlockHeader -> Bool) -> Eq BlockHeader
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlockHeader -> BlockHeader -> Bool
$c/= :: BlockHeader -> BlockHeader -> Bool
== :: BlockHeader -> BlockHeader -> Bool
$c== :: BlockHeader -> BlockHeader -> Bool
Eq, (forall x. BlockHeader -> Rep BlockHeader x)
-> (forall x. Rep BlockHeader x -> BlockHeader)
-> Generic BlockHeader
forall x. Rep BlockHeader x -> BlockHeader
forall x. BlockHeader -> Rep BlockHeader x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BlockHeader x -> BlockHeader
$cfrom :: forall x. BlockHeader -> Rep BlockHeader x
Generic)

instance ShowProxy BlockHeader where

-- | Compute the 'HeaderHash' of the 'BlockHeader'.
--
hashHeader :: BlockHeader -> ConcreteHeaderHash
hashHeader :: BlockHeader -> ConcreteHeaderHash
hashHeader (BlockHeader HeaderHash BlockHeader
_ ChainHash BlockHeader
b SlotNo
c BlockNo
d BodyHash
e) = Int -> ConcreteHeaderHash
HeaderHash ((ChainHash BlockHeader, SlotNo, BlockNo, BodyHash) -> Int
forall a. Hashable a => a -> Int
hash (ChainHash BlockHeader
b, SlotNo
c, BlockNo
d, BodyHash
e))

deriving instance Hashable SlotNo
deriving instance Hashable BlockNo

-- | 'Hashable' instance for 'Hash'
--
-- We don't insist that 'Hashable' in 'StandardHash' because 'Hashable' is
-- only used in the network layer /tests/.
--
-- This requires @UndecidableInstances@ because @Hashable (HeaderHash b)@
-- is no smaller than @Hashable (ChainHash b)@.
instance Hashable (HeaderHash b) => Hashable (ChainHash b)
 -- use generic instance

-- | The hash of all the information in a 'BlockHeader'.
--
newtype ConcreteHeaderHash = HeaderHash Int
  deriving (Int -> ConcreteHeaderHash -> ShowS
[ConcreteHeaderHash] -> ShowS
ConcreteHeaderHash -> String
(Int -> ConcreteHeaderHash -> ShowS)
-> (ConcreteHeaderHash -> String)
-> ([ConcreteHeaderHash] -> ShowS)
-> Show ConcreteHeaderHash
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConcreteHeaderHash] -> ShowS
$cshowList :: [ConcreteHeaderHash] -> ShowS
show :: ConcreteHeaderHash -> String
$cshow :: ConcreteHeaderHash -> String
showsPrec :: Int -> ConcreteHeaderHash -> ShowS
$cshowsPrec :: Int -> ConcreteHeaderHash -> ShowS
Show, ConcreteHeaderHash -> ConcreteHeaderHash -> Bool
(ConcreteHeaderHash -> ConcreteHeaderHash -> Bool)
-> (ConcreteHeaderHash -> ConcreteHeaderHash -> Bool)
-> Eq ConcreteHeaderHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConcreteHeaderHash -> ConcreteHeaderHash -> Bool
$c/= :: ConcreteHeaderHash -> ConcreteHeaderHash -> Bool
== :: ConcreteHeaderHash -> ConcreteHeaderHash -> Bool
$c== :: ConcreteHeaderHash -> ConcreteHeaderHash -> Bool
Eq, Eq ConcreteHeaderHash
Eq ConcreteHeaderHash
-> (ConcreteHeaderHash -> ConcreteHeaderHash -> Ordering)
-> (ConcreteHeaderHash -> ConcreteHeaderHash -> Bool)
-> (ConcreteHeaderHash -> ConcreteHeaderHash -> Bool)
-> (ConcreteHeaderHash -> ConcreteHeaderHash -> Bool)
-> (ConcreteHeaderHash -> ConcreteHeaderHash -> Bool)
-> (ConcreteHeaderHash -> ConcreteHeaderHash -> ConcreteHeaderHash)
-> (ConcreteHeaderHash -> ConcreteHeaderHash -> ConcreteHeaderHash)
-> Ord ConcreteHeaderHash
ConcreteHeaderHash -> ConcreteHeaderHash -> Bool
ConcreteHeaderHash -> ConcreteHeaderHash -> Ordering
ConcreteHeaderHash -> ConcreteHeaderHash -> ConcreteHeaderHash
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ConcreteHeaderHash -> ConcreteHeaderHash -> ConcreteHeaderHash
$cmin :: ConcreteHeaderHash -> ConcreteHeaderHash -> ConcreteHeaderHash
max :: ConcreteHeaderHash -> ConcreteHeaderHash -> ConcreteHeaderHash
$cmax :: ConcreteHeaderHash -> ConcreteHeaderHash -> ConcreteHeaderHash
>= :: ConcreteHeaderHash -> ConcreteHeaderHash -> Bool
$c>= :: ConcreteHeaderHash -> ConcreteHeaderHash -> Bool
> :: ConcreteHeaderHash -> ConcreteHeaderHash -> Bool
$c> :: ConcreteHeaderHash -> ConcreteHeaderHash -> Bool
<= :: ConcreteHeaderHash -> ConcreteHeaderHash -> Bool
$c<= :: ConcreteHeaderHash -> ConcreteHeaderHash -> Bool
< :: ConcreteHeaderHash -> ConcreteHeaderHash -> Bool
$c< :: ConcreteHeaderHash -> ConcreteHeaderHash -> Bool
compare :: ConcreteHeaderHash -> ConcreteHeaderHash -> Ordering
$ccompare :: ConcreteHeaderHash -> ConcreteHeaderHash -> Ordering
$cp1Ord :: Eq ConcreteHeaderHash
Ord, (forall x. ConcreteHeaderHash -> Rep ConcreteHeaderHash x)
-> (forall x. Rep ConcreteHeaderHash x -> ConcreteHeaderHash)
-> Generic ConcreteHeaderHash
forall x. Rep ConcreteHeaderHash x -> ConcreteHeaderHash
forall x. ConcreteHeaderHash -> Rep ConcreteHeaderHash x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ConcreteHeaderHash x -> ConcreteHeaderHash
$cfrom :: forall x. ConcreteHeaderHash -> Rep ConcreteHeaderHash x
Generic, Int -> ConcreteHeaderHash -> Int
ConcreteHeaderHash -> Int
(Int -> ConcreteHeaderHash -> Int)
-> (ConcreteHeaderHash -> Int) -> Hashable ConcreteHeaderHash
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: ConcreteHeaderHash -> Int
$chash :: ConcreteHeaderHash -> Int
hashWithSalt :: Int -> ConcreteHeaderHash -> Int
$chashWithSalt :: Int -> ConcreteHeaderHash -> Int
Hashable, Context -> ConcreteHeaderHash -> IO (Maybe ThunkInfo)
Proxy ConcreteHeaderHash -> String
(Context -> ConcreteHeaderHash -> IO (Maybe ThunkInfo))
-> (Context -> ConcreteHeaderHash -> IO (Maybe ThunkInfo))
-> (Proxy ConcreteHeaderHash -> String)
-> NoThunks ConcreteHeaderHash
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy ConcreteHeaderHash -> String
$cshowTypeOf :: Proxy ConcreteHeaderHash -> String
wNoThunks :: Context -> ConcreteHeaderHash -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ConcreteHeaderHash -> IO (Maybe ThunkInfo)
noThunks :: Context -> ConcreteHeaderHash -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> ConcreteHeaderHash -> IO (Maybe ThunkInfo)
NoThunks)

-- | The hash of all the information in a 'BlockBody'.
--
newtype BodyHash = BodyHash Int
  deriving (Int -> BodyHash -> ShowS
[BodyHash] -> ShowS
BodyHash -> String
(Int -> BodyHash -> ShowS)
-> (BodyHash -> String) -> ([BodyHash] -> ShowS) -> Show BodyHash
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [BodyHash] -> ShowS
$cshowList :: [BodyHash] -> ShowS
show :: BodyHash -> String
$cshow :: BodyHash -> String
showsPrec :: Int -> BodyHash -> ShowS
$cshowsPrec :: Int -> BodyHash -> ShowS
Show, BodyHash -> BodyHash -> Bool
(BodyHash -> BodyHash -> Bool)
-> (BodyHash -> BodyHash -> Bool) -> Eq BodyHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BodyHash -> BodyHash -> Bool
$c/= :: BodyHash -> BodyHash -> Bool
== :: BodyHash -> BodyHash -> Bool
$c== :: BodyHash -> BodyHash -> Bool
Eq, Eq BodyHash
Eq BodyHash
-> (BodyHash -> BodyHash -> Ordering)
-> (BodyHash -> BodyHash -> Bool)
-> (BodyHash -> BodyHash -> Bool)
-> (BodyHash -> BodyHash -> Bool)
-> (BodyHash -> BodyHash -> Bool)
-> (BodyHash -> BodyHash -> BodyHash)
-> (BodyHash -> BodyHash -> BodyHash)
-> Ord BodyHash
BodyHash -> BodyHash -> Bool
BodyHash -> BodyHash -> Ordering
BodyHash -> BodyHash -> BodyHash
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BodyHash -> BodyHash -> BodyHash
$cmin :: BodyHash -> BodyHash -> BodyHash
max :: BodyHash -> BodyHash -> BodyHash
$cmax :: BodyHash -> BodyHash -> BodyHash
>= :: BodyHash -> BodyHash -> Bool
$c>= :: BodyHash -> BodyHash -> Bool
> :: BodyHash -> BodyHash -> Bool
$c> :: BodyHash -> BodyHash -> Bool
<= :: BodyHash -> BodyHash -> Bool
$c<= :: BodyHash -> BodyHash -> Bool
< :: BodyHash -> BodyHash -> Bool
$c< :: BodyHash -> BodyHash -> Bool
compare :: BodyHash -> BodyHash -> Ordering
$ccompare :: BodyHash -> BodyHash -> Ordering
$cp1Ord :: Eq BodyHash
Ord, (forall x. BodyHash -> Rep BodyHash x)
-> (forall x. Rep BodyHash x -> BodyHash) -> Generic BodyHash
forall x. Rep BodyHash x -> BodyHash
forall x. BodyHash -> Rep BodyHash x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BodyHash x -> BodyHash
$cfrom :: forall x. BodyHash -> Rep BodyHash x
Generic, Int -> BodyHash -> Int
BodyHash -> Int
(Int -> BodyHash -> Int) -> (BodyHash -> Int) -> Hashable BodyHash
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: BodyHash -> Int
$chash :: BodyHash -> Int
hashWithSalt :: Int -> BodyHash -> Int
$chashWithSalt :: Int -> BodyHash -> Int
Hashable)

{-------------------------------------------------------------------------------
  HasHeader instances
-------------------------------------------------------------------------------}

instance StandardHash BlockHeader
instance StandardHash Block

type instance HeaderHash BlockHeader = ConcreteHeaderHash
type instance HeaderHash Block       = ConcreteHeaderHash

instance HasHeader BlockHeader where
  getHeaderFields :: BlockHeader -> HeaderFields BlockHeader
getHeaderFields BlockHeader
hdr = HeaderFields :: forall b. SlotNo -> BlockNo -> HeaderHash b -> HeaderFields b
HeaderFields {
      headerFieldHash :: HeaderHash BlockHeader
headerFieldHash    = BlockHeader -> HeaderHash BlockHeader
headerHash BlockHeader
hdr,
      headerFieldSlot :: SlotNo
headerFieldSlot    = BlockHeader -> SlotNo
headerSlot BlockHeader
hdr,
      headerFieldBlockNo :: BlockNo
headerFieldBlockNo = BlockHeader -> BlockNo
headerBlockNo BlockHeader
hdr
      }

instance HasFullHeader BlockHeader where
    blockPrevHash :: BlockHeader -> ChainHash BlockHeader
blockPrevHash  = BlockHeader -> ChainHash BlockHeader
headerPrevHash

    -- | The header invariant is that the cached header hash is correct.
    --
    blockInvariant :: BlockHeader -> Bool
blockInvariant BlockHeader
b =
        BlockHeader -> ConcreteHeaderHash
hashHeader BlockHeader
b ConcreteHeaderHash -> ConcreteHeaderHash -> Bool
forall a. Eq a => a -> a -> Bool
== BlockHeader -> HeaderHash BlockHeader
headerHash BlockHeader
b

instance HasHeader Block where
  getHeaderFields :: Block -> HeaderFields Block
getHeaderFields = HeaderFields BlockHeader -> HeaderFields Block
forall b b'.
(HeaderHash b ~ HeaderHash b') =>
HeaderFields b -> HeaderFields b'
castHeaderFields (HeaderFields BlockHeader -> HeaderFields Block)
-> (Block -> HeaderFields BlockHeader)
-> Block
-> HeaderFields Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHeader -> HeaderFields BlockHeader
forall b. HasHeader b => b -> HeaderFields b
getHeaderFields (BlockHeader -> HeaderFields BlockHeader)
-> (Block -> BlockHeader) -> Block -> HeaderFields BlockHeader
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> BlockHeader
blockHeader

instance HasFullHeader Block where
    blockPrevHash :: Block -> ChainHash Block
blockPrevHash  = ChainHash BlockHeader -> ChainHash Block
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
ChainHash b -> ChainHash b'
castHash (ChainHash BlockHeader -> ChainHash Block)
-> (Block -> ChainHash BlockHeader) -> Block -> ChainHash Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlockHeader -> ChainHash BlockHeader
headerPrevHash (BlockHeader -> ChainHash BlockHeader)
-> (Block -> BlockHeader) -> Block -> ChainHash BlockHeader
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> BlockHeader
blockHeader

    -- | The block invariant is just that the actual block body hash matches the
    -- body hash listed in the header.
    --
    blockInvariant :: Block -> Bool
blockInvariant Block { BlockBody
blockBody :: BlockBody
blockBody :: Block -> BlockBody
blockBody, BlockHeader
blockHeader :: BlockHeader
blockHeader :: Block -> BlockHeader
blockHeader } =
        BlockHeader -> Bool
forall b. HasFullHeader b => b -> Bool
blockInvariant BlockHeader
blockHeader
     Bool -> Bool -> Bool
&& BlockHeader -> BodyHash
headerBodyHash BlockHeader
blockHeader BodyHash -> BodyHash -> Bool
forall a. Eq a => a -> a -> Bool
== BlockBody -> BodyHash
forall body. Hashable body => body -> BodyHash
hashBody BlockBody
blockBody

{-------------------------------------------------------------------------------
  Constructing sample chains
-------------------------------------------------------------------------------}

-- | This takes the blocks in order from /oldest to newest/.
--
mkChain :: [(SlotNo, BlockBody)] -> Chain Block
mkChain :: [(SlotNo, BlockBody)] -> Chain Block
mkChain =
    (Anchor Block -> Block -> Block) -> [Block] -> Chain Block
forall b. HasFullHeader b => (Anchor b -> b -> b) -> [b] -> Chain b
fixupChain Anchor Block -> Block -> Block
forall block.
(HeaderHash block ~ HeaderHash BlockHeader) =>
Anchor block -> Block -> Block
fixupBlock
  ([Block] -> Chain Block)
-> ([(SlotNo, BlockBody)] -> [Block])
-> [(SlotNo, BlockBody)]
-> Chain Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((SlotNo, BlockBody) -> Block) -> [(SlotNo, BlockBody)] -> [Block]
forall a b. (a -> b) -> [a] -> [b]
map ((SlotNo -> BlockBody -> Block) -> (SlotNo, BlockBody) -> Block
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SlotNo -> BlockBody -> Block
mkPartialBlock)
  ([(SlotNo, BlockBody)] -> [Block])
-> ([(SlotNo, BlockBody)] -> [(SlotNo, BlockBody)])
-> [(SlotNo, BlockBody)]
-> [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SlotNo, BlockBody)] -> [(SlotNo, BlockBody)]
forall a. [a] -> [a]
reverse

mkChainSimple :: [BlockBody] -> Chain Block
mkChainSimple :: [BlockBody] -> Chain Block
mkChainSimple = [(SlotNo, BlockBody)] -> Chain Block
mkChain ([(SlotNo, BlockBody)] -> Chain Block)
-> ([BlockBody] -> [(SlotNo, BlockBody)])
-> [BlockBody]
-> Chain Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SlotNo] -> [BlockBody] -> [(SlotNo, BlockBody)]
forall a b. [a] -> [b] -> [(a, b)]
zip [SlotNo
1..]

mkAnchoredFragment :: Anchor Block
                   -> [(SlotNo, BlockBody)]
                   -> AnchoredFragment Block
mkAnchoredFragment :: Anchor Block -> [(SlotNo, BlockBody)] -> AnchoredFragment Block
mkAnchoredFragment Anchor Block
anchor =
    Anchor Block
-> (Anchor Block -> Block -> Block)
-> [Block]
-> AnchoredFragment Block
forall b.
HasFullHeader b =>
Anchor b -> (Anchor b -> b -> b) -> [b] -> AnchoredFragment b
fixupAnchoredFragmentFrom Anchor Block
anchor Anchor Block -> Block -> Block
forall block.
(HeaderHash block ~ HeaderHash BlockHeader) =>
Anchor block -> Block -> Block
fixupBlock
  ([Block] -> AnchoredFragment Block)
-> ([(SlotNo, BlockBody)] -> [Block])
-> [(SlotNo, BlockBody)]
-> AnchoredFragment Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((SlotNo, BlockBody) -> Block) -> [(SlotNo, BlockBody)] -> [Block]
forall a b. (a -> b) -> [a] -> [b]
map ((SlotNo -> BlockBody -> Block) -> (SlotNo, BlockBody) -> Block
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry SlotNo -> BlockBody -> Block
mkPartialBlock)
  ([(SlotNo, BlockBody)] -> [Block])
-> ([(SlotNo, BlockBody)] -> [(SlotNo, BlockBody)])
-> [(SlotNo, BlockBody)]
-> [Block]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SlotNo, BlockBody)] -> [(SlotNo, BlockBody)]
forall a. [a] -> [a]
reverse

mkAnchoredFragmentSimple :: [BlockBody] -> AnchoredFragment Block
mkAnchoredFragmentSimple :: [BlockBody] -> AnchoredFragment Block
mkAnchoredFragmentSimple =
    Anchor Block -> [(SlotNo, BlockBody)] -> AnchoredFragment Block
mkAnchoredFragment Anchor Block
forall block. Anchor block
AnchorGenesis ([(SlotNo, BlockBody)] -> AnchoredFragment Block)
-> ([BlockBody] -> [(SlotNo, BlockBody)])
-> [BlockBody]
-> AnchoredFragment Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SlotNo] -> [BlockBody] -> [(SlotNo, BlockBody)]
forall a b. [a] -> [b] -> [(a, b)]
zip [SlotNo
1..]


mkPartialBlock :: SlotNo -> BlockBody -> Block
mkPartialBlock :: SlotNo -> BlockBody -> Block
mkPartialBlock SlotNo
sl BlockBody
body =
    Block :: BlockHeader -> BlockBody -> Block
Block {
      blockHeader :: BlockHeader
blockHeader = SlotNo -> BlockBody -> BlockHeader
mkPartialBlockHeader SlotNo
sl BlockBody
body
    , blockBody :: BlockBody
blockBody   = BlockBody
body
    }

mkPartialBlockHeader :: SlotNo -> BlockBody -> BlockHeader
mkPartialBlockHeader :: SlotNo -> BlockBody -> BlockHeader
mkPartialBlockHeader SlotNo
sl BlockBody
body =
    BlockHeader :: HeaderHash BlockHeader
-> ChainHash BlockHeader
-> SlotNo
-> BlockNo
-> BodyHash
-> BlockHeader
BlockHeader {
      headerSlot :: SlotNo
headerSlot     = SlotNo
sl,
      headerHash :: HeaderHash BlockHeader
headerHash     = String -> ConcreteHeaderHash
forall a. String -> a
partialField String
"headerHash",
      headerPrevHash :: ChainHash BlockHeader
headerPrevHash = String -> ChainHash BlockHeader
forall a. String -> a
partialField String
"headerPrevHash",
      headerBlockNo :: BlockNo
headerBlockNo  = String -> BlockNo
forall a. String -> a
partialField String
"headerBlockNo",
      headerBodyHash :: BodyHash
headerBodyHash = BlockBody -> BodyHash
forall body. Hashable body => body -> BodyHash
hashBody BlockBody
body
    }
  where
    partialField :: String -> a
partialField String
n = String -> a
forall a. HasCallStack => String -> a
error (String
"mkPartialBlock: you didn't fill in field " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n)

{-------------------------------------------------------------------------------
  "Fixup" is used for chain construction in the network tests. These functions
  don't make much sense for real chains.
-------------------------------------------------------------------------------}

-- | Fix up a block so that it fits on top of the given anchor. Only the block
-- number, the previous hash and the block hash are updated; the slot number and
-- the signers are kept intact.
--
fixupBlock :: (HeaderHash block ~ HeaderHash BlockHeader)
           => Anchor block -> Block -> Block
fixupBlock :: Anchor block -> Block -> Block
fixupBlock Anchor block
prev b :: Block
b@Block{BlockBody
blockBody :: BlockBody
blockBody :: Block -> BlockBody
blockBody, BlockHeader
blockHeader :: BlockHeader
blockHeader :: Block -> BlockHeader
blockHeader} =
    Block
b {
      blockHeader :: BlockHeader
blockHeader = (Anchor block -> BlockHeader -> BlockHeader
forall block.
(HeaderHash block ~ HeaderHash BlockHeader) =>
Anchor block -> BlockHeader -> BlockHeader
fixupBlockHeader Anchor block
prev BlockHeader
blockHeader) {
                      headerBodyHash :: BodyHash
headerBodyHash = BlockBody -> BodyHash
forall body. Hashable body => body -> BodyHash
hashBody BlockBody
blockBody
                    }
    }

-- | Fixup block header to fit it on top of a chain.  Only block number and
-- previous hash are updated; the slot and signer are kept unchanged.
--
fixupBlockHeader :: (HeaderHash block ~ HeaderHash BlockHeader)
                 => Anchor block -> BlockHeader -> BlockHeader
fixupBlockHeader :: Anchor block -> BlockHeader -> BlockHeader
fixupBlockHeader Anchor block
prev BlockHeader
b =
    (BlockHeader -> BlockHeader) -> BlockHeader
forall a. (a -> a) -> a
fix ((BlockHeader -> BlockHeader) -> BlockHeader)
-> (BlockHeader -> BlockHeader) -> BlockHeader
forall a b. (a -> b) -> a -> b
$ \BlockHeader
b' ->
    BlockHeader
b {
      headerHash :: HeaderHash BlockHeader
headerHash     = BlockHeader -> ConcreteHeaderHash
hashHeader BlockHeader
b',
      headerPrevHash :: ChainHash BlockHeader
headerPrevHash = ChainHash block -> ChainHash BlockHeader
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
ChainHash b -> ChainHash b'
castHash (Anchor block -> ChainHash block
forall block. Anchor block -> ChainHash block
AF.anchorToHash Anchor block
prev),
      headerBlockNo :: BlockNo
headerBlockNo  = BlockNo -> (BlockNo -> BlockNo) -> WithOrigin BlockNo -> BlockNo
forall b t. b -> (t -> b) -> WithOrigin t -> b
withOrigin (Word64 -> BlockNo
BlockNo Word64
0) BlockNo -> BlockNo
forall a. Enum a => a -> a
succ (Anchor block -> WithOrigin BlockNo
forall block. Anchor block -> WithOrigin BlockNo
AF.anchorToBlockNo Anchor block
prev)
    }


-- | Fixup a block so to fit it on top of a given previous block.

-- Like 'fixupBlock' but it takes the info from a given block.
--
fixupBlockAfterBlock :: Block -> Block -> Block
fixupBlockAfterBlock :: Block -> Block -> Block
fixupBlockAfterBlock Block
prev = Anchor Block -> Block -> Block
forall block.
(HeaderHash block ~ HeaderHash BlockHeader) =>
Anchor block -> Block -> Block
fixupBlock (Block -> Anchor Block
forall block. HasHeader block => block -> Anchor block
AF.anchorFromBlock Block
prev)

fixupBlocks :: HasFullHeader b
            => (c -> b -> c)
            -> c
            -> Anchor b -- ^ Override prev hash and block number based on the anchor
            -> (Anchor b -> b -> b)
            -> [b] -> c
fixupBlocks :: (c -> b -> c) -> c -> Anchor b -> (Anchor b -> b -> b) -> [b] -> c
fixupBlocks c -> b -> c
_f c
z Anchor b
_     Anchor b -> b -> b
_fixup []      = c
z
fixupBlocks  c -> b -> c
f c
z Anchor b
anchor Anchor b -> b -> b
fixup (b
b0:[b]
c0) =
    (c, b) -> c
forall a b. (a, b) -> a
fst (b -> [b] -> (c, b)
go b
b0 [b]
c0)
  where
    go :: b -> [b] -> (c, b)
go b
b [] = (c
z c -> b -> c
`f` b
b', b
b')
      where
        b' :: b
b' = Anchor b -> b -> b
fixup Anchor b
anchor b
b

    go b
b (b
b1:[b]
c1) = (c
c' c -> b -> c
`f` b
b', b
b')
      where
        (c
c', b
b1') = b -> [b] -> (c, b)
go b
b1 [b]
c1
        b' :: b
b'        = Anchor b -> b -> b
fixup (b -> Anchor b
forall block. HasHeader block => block -> Anchor block
AF.anchorFromBlock b
b1') b
b

-- | Fix up the block number and hashes of a 'Chain'. This also fixes up the
-- first block to chain-on from genesis, since by construction the 'Chain' type
-- starts from genesis.
--
fixupChain :: HasFullHeader b
           => (Anchor b -> b -> b)
           -> [b] -> Chain b
fixupChain :: (Anchor b -> b -> b) -> [b] -> Chain b
fixupChain =
    (Chain b -> b -> Chain b)
-> Chain b -> Anchor b -> (Anchor b -> b -> b) -> [b] -> Chain b
forall b c.
HasFullHeader b =>
(c -> b -> c) -> c -> Anchor b -> (Anchor b -> b -> b) -> [b] -> c
fixupBlocks
      Chain b -> b -> Chain b
forall block. Chain block -> block -> Chain block
(C.:>) Chain b
forall block. Chain block
C.Genesis
      Anchor b
forall block. Anchor block
AnchorGenesis

fixupAnchoredFragmentFrom :: HasFullHeader b
                          => Anchor b
                          -> (Anchor b -> b -> b)
                          -> [b] -> AnchoredFragment b
fixupAnchoredFragmentFrom :: Anchor b -> (Anchor b -> b -> b) -> [b] -> AnchoredFragment b
fixupAnchoredFragmentFrom Anchor b
anchor =
    (AnchoredFragment b -> b -> AnchoredFragment b)
-> AnchoredFragment b
-> Anchor b
-> (Anchor b -> b -> b)
-> [b]
-> AnchoredFragment b
forall b c.
HasFullHeader b =>
(c -> b -> c) -> c -> Anchor b -> (Anchor b -> b -> b) -> [b] -> c
fixupBlocks
      AnchoredFragment b -> b -> AnchoredFragment b
forall v a b.
Anchorable v a b =>
AnchoredSeq v a b -> b -> AnchoredSeq v a b
(AF.:>)
      (Anchor b -> AnchoredFragment b
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
AF.Empty Anchor b
anchor)
      Anchor b
anchor

{-------------------------------------------------------------------------------
  Serialisation
-------------------------------------------------------------------------------}

instance Serialise ConcreteHeaderHash where
  encode :: ConcreteHeaderHash -> Encoding
encode (HeaderHash Int
h) = Int -> Encoding
encodeInt Int
h
  decode :: Decoder s ConcreteHeaderHash
decode = Int -> ConcreteHeaderHash
HeaderHash (Int -> ConcreteHeaderHash)
-> Decoder s Int -> Decoder s ConcreteHeaderHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Int
forall s. Decoder s Int
decodeInt

instance Serialise BodyHash where
  encode :: BodyHash -> Encoding
encode (BodyHash Int
h) = Int -> Encoding
encodeInt Int
h
  decode :: Decoder s BodyHash
decode = Int -> BodyHash
BodyHash (Int -> BodyHash) -> Decoder s Int -> Decoder s BodyHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Int
forall s. Decoder s Int
decodeInt

instance Serialise Block where

  encode :: Block -> Encoding
encode Block {BlockHeader
blockHeader :: BlockHeader
blockHeader :: Block -> BlockHeader
blockHeader, BlockBody
blockBody :: BlockBody
blockBody :: Block -> BlockBody
blockBody} =
      Word -> Encoding
encodeListLen Word
2
   Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> BlockHeader -> Encoding
forall a. Serialise a => a -> Encoding
encode BlockHeader
blockHeader
   Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> BlockBody -> Encoding
forall a. Serialise a => a -> Encoding
encode   BlockBody
blockBody

  decode :: Decoder s Block
decode = do
      Int -> Decoder s ()
forall s. Int -> Decoder s ()
decodeListLenOf Int
2
      BlockHeader -> BlockBody -> Block
Block (BlockHeader -> BlockBody -> Block)
-> Decoder s BlockHeader -> Decoder s (BlockBody -> Block)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s BlockHeader
forall a s. Serialise a => Decoder s a
decode Decoder s (BlockBody -> Block)
-> Decoder s BlockBody -> Decoder s Block
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s BlockBody
forall a s. Serialise a => Decoder s a
decode

instance Serialise BlockHeader where

  encode :: BlockHeader -> Encoding
encode BlockHeader {
         headerHash :: BlockHeader -> HeaderHash BlockHeader
headerHash     = HeaderHash BlockHeader
headerHash,
         headerPrevHash :: BlockHeader -> ChainHash BlockHeader
headerPrevHash = ChainHash BlockHeader
headerPrevHash,
         headerSlot :: BlockHeader -> SlotNo
headerSlot     = SlotNo Word64
headerSlot,
         headerBlockNo :: BlockHeader -> BlockNo
headerBlockNo  = BlockNo Word64
headerBlockNo,
         headerBodyHash :: BlockHeader -> BodyHash
headerBodyHash = BodyHash Int
headerBodyHash
       } =
      Word -> Encoding
encodeListLen Word
5
   Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ConcreteHeaderHash -> Encoding
forall a. Serialise a => a -> Encoding
encode     HeaderHash BlockHeader
ConcreteHeaderHash
headerHash
   Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ChainHash BlockHeader -> Encoding
forall a. Serialise a => a -> Encoding
encode     ChainHash BlockHeader
headerPrevHash
   Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word64 -> Encoding
encodeWord64 Word64
headerSlot
   Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word64 -> Encoding
encodeWord64 Word64
headerBlockNo
   Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Int -> Encoding
encodeInt  Int
headerBodyHash

  decode :: Decoder s BlockHeader
decode = do
      Int -> Decoder s ()
forall s. Int -> Decoder s ()
decodeListLenOf Int
5
      HeaderHash BlockHeader
-> ChainHash BlockHeader
-> SlotNo
-> BlockNo
-> BodyHash
-> BlockHeader
ConcreteHeaderHash
-> ChainHash BlockHeader
-> SlotNo
-> BlockNo
-> BodyHash
-> BlockHeader
BlockHeader (ConcreteHeaderHash
 -> ChainHash BlockHeader
 -> SlotNo
 -> BlockNo
 -> BodyHash
 -> BlockHeader)
-> Decoder s ConcreteHeaderHash
-> Decoder
     s
     (ChainHash BlockHeader
      -> SlotNo -> BlockNo -> BodyHash -> BlockHeader)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s ConcreteHeaderHash
forall a s. Serialise a => Decoder s a
decode
                  Decoder
  s
  (ChainHash BlockHeader
   -> SlotNo -> BlockNo -> BodyHash -> BlockHeader)
-> Decoder s (ChainHash BlockHeader)
-> Decoder s (SlotNo -> BlockNo -> BodyHash -> BlockHeader)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (ChainHash BlockHeader)
forall a s. Serialise a => Decoder s a
decode
                  Decoder s (SlotNo -> BlockNo -> BodyHash -> BlockHeader)
-> Decoder s SlotNo
-> Decoder s (BlockNo -> BodyHash -> BlockHeader)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Decoder s Word64 -> Decoder s SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Word64
forall s. Decoder s Word64
decodeWord64)
                  Decoder s (BlockNo -> BodyHash -> BlockHeader)
-> Decoder s BlockNo -> Decoder s (BodyHash -> BlockHeader)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Word64 -> BlockNo
BlockNo (Word64 -> BlockNo) -> Decoder s Word64 -> Decoder s BlockNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Word64
forall s. Decoder s Word64
decodeWord64)
                  Decoder s (BodyHash -> BlockHeader)
-> Decoder s BodyHash -> Decoder s BlockHeader
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Int -> BodyHash
BodyHash (Int -> BodyHash) -> Decoder s Int -> Decoder s BodyHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s Int
forall s. Decoder s Int
decodeInt)

instance Serialise BlockBody where

  encode :: BlockBody -> Encoding
encode (BlockBody ByteString
b) = ByteString -> Encoding
encodeBytes ByteString
b

  decode :: Decoder s BlockBody
decode = ByteString -> BlockBody
BlockBody (ByteString -> BlockBody)
-> Decoder s ByteString -> Decoder s BlockBody
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s ByteString
forall s. Decoder s ByteString
decodeBytes

{-------------------------------------------------------------------------------
  Simple static time conversions, since no HardFork
-------------------------------------------------------------------------------}

-- | Arbitrarily but consistently converts slots UTCTimes.
--
-- It is only intended for use in tests. Notably it assumes a fixed system
-- start time, slot length, and the absence of a hard fork (ie no
-- HardForkCombinator). This is how it's available as a pure function.
convertSlotToTimeForTestsAssumingNoHardFork :: SlotNo -> UTCTime
convertSlotToTimeForTestsAssumingNoHardFork :: SlotNo -> UTCTime
convertSlotToTimeForTestsAssumingNoHardFork SlotNo
sl =
    (NominalDiffTime -> UTCTime -> UTCTime)
-> UTCTime -> NominalDiffTime -> UTCTime
forall a b c. (a -> b -> c) -> b -> a -> c
flip NominalDiffTime -> UTCTime -> UTCTime
addUTCTime UTCTime
startTime (NominalDiffTime -> UTCTime) -> NominalDiffTime -> UTCTime
forall a b. (a -> b) -> a -> b
$
      --   ^^^ arbitrary start time for testing
    Pico -> NominalDiffTime
secondsToNominalDiffTime (Pico -> NominalDiffTime) -> Pico -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$
    Word64 -> Pico
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Pico) -> Word64 -> Pico
forall a b. (a -> b) -> a -> b
$ SlotNo -> Word64
unSlotNo SlotNo
sl Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
* Word64
10
      --   ^^^ arbitrary slot length for testing
  where
    startTime :: UTCTime
startTime = UTCTime :: Day -> DiffTime -> UTCTime
UTCTime {
        utctDay :: Day
utctDay     = Integer -> Int -> Int -> Day
fromGregorian Integer
2000 Int
1 Int
1,
        utctDayTime :: DiffTime
utctDayTime = DiffTime
0
      }