content: -- | A pure logic layer. As such, it does nothing, but won't crash.
  
  module Pos.Logic.Pure
      ( pureLogic
      , blockVersionData
      ) where
  
  import           Universum
  
  import qualified Data.ByteString as BS
  import           Data.Coerce (coerce)
  
  import           Pos.Binary.Class (serialize')
  import           Pos.Chain.Block (Block, BlockHeader (..),
                       BlockHeaderAttributes, BlockSignature (..), HeaderHash,
                       MainBlock, MainBlockHeader, MainBody (..),
                       MainConsensusData (..), MainExtraBodyData (..),
                       MainExtraHeaderData (..), MainProof (..),
                       mkGenericBlockHeaderUnsafe, mkGenericBlockUnsafe)
  import           Pos.Chain.Delegation (DlgPayload (..))
  import           Pos.Chain.Ssc (SscPayload (..), SscProof (..),
                       VssCertificatesMap (..))
  import           Pos.Chain.Txp (TxProof (..), emptyTxPayload)
  import           Pos.Chain.Update (ApplicationName (..), BlockVersion (..),
                       BlockVersionData (..), SoftforkRule (..),
                       SoftwareVersion (..), UpdatePayload (..), UpdateProof)
  import           Pos.Core (TxFeePolicy (..), unsafeCoinPortionFromDouble)
  import           Pos.Core.Attributes (Attributes (..), UnparsedFields (..))
  import           Pos.Core.Chrono (NewestFirst (..), OldestFirst (..))
  import           Pos.Core.Common (BlockCount (..), ChainDifficulty (..))
  import           Pos.Core.Merkle (MerkleRoot (..))
  import           Pos.Core.Slotting (EpochIndex (..), LocalSlotIndex (..),
                       SlotId (..))
  import           Pos.Crypto.Configuration (ProtocolMagic (..),
                       ProtocolMagicId (..), RequiresNetworkMagic (..))
  import           Pos.Crypto.Hashing (Hash, unsafeMkAbstractHash)
  import           Pos.Crypto.Signing (PublicKey (..), SecretKey (..),
                       Signature (..), deterministicKeyGen, signRaw)
  import           Pos.DB.Class (Serialized (..), SerializedBlock)
  
  import           Pos.Logic.Types (KeyVal (..), Logic (..))
  
  -- | Serves up a single (invalid but well-formed) block and block header for
  -- any request.
  pureLogic
      :: ( Monad m )
      => Logic m
  pureLogic = Logic
      { getSerializedBlock = \_ -> pure (Just serializedBlock)
      , streamBlocks       = \_ k -> k (pure ())
      , getBlockHeader     = \_ -> pure (Just blockHeader)
      , getHashesRange     = \_ _ _ -> pure (Right (OldestFirst (pure mainBlockHeaderHash)))
      , getBlockHeaders    = \_ _ _ -> pure (Right (NewestFirst (pure blockHeader)))
        -- This definition of getLcaMainChain decides that all of the input
        -- hashes are *not* in the chain.
      , getLcaMainChain    = \hashes -> pure (NewestFirst [], hashes)
      , getTip             = pure block
      , getAdoptedBVData   = pure blockVersionData
      , postBlockHeader    = \_ _ -> pure ()
      , postPskHeavy       = \_ -> pure True
      , postTx             = dummyKeyVal
      , postUpdate         = dummyKeyVal
      , postVote           = dummyKeyVal
      , postSscCommitment  = dummyKeyVal
      , postSscOpening     = dummyKeyVal
      , postSscShares      = dummyKeyVal
      , postSscVssCert     = dummyKeyVal
      , recoveryInProgress = pure False
      }
    where
      dummyKeyVal :: Applicative m => KeyVal key val m
      dummyKeyVal = KeyVal
          { toKey      = \_ -> error "dummy: can't make key"
          , handleInv  = \_ -> pure False
          , handleReq  = \_ -> pure Nothing
          , handleData = \_ -> pure False
          }
  
  blockVersionData :: BlockVersionData
  blockVersionData = BlockVersionData
      { bvdScriptVersion = 0
      , bvdSlotDuration  = 0
      -- FIXME
      -- Unfortunately, the choices we make here will affect the functioning of
      -- the diffusion layer.
      -- There's no way to say "no limit".
      --
      -- To fix this, perhaps we should augment the logic layer interface with
      --
      --   limits :: m Limits
      --
      -- where Limits gives all of these 4 limits. Then we can use them to do
      -- limiting at the value level, rather than how it is now, via type classes.
      , bvdMaxBlockSize    = limit
      , bvdMaxHeaderSize   = limit
      , bvdMaxTxSize       = limit
      , bvdMaxProposalSize = limit
  
      , bvdMpcThd            = unsafeCoinPortionFromDouble 0
      , bvdHeavyDelThd       = unsafeCoinPortionFromDouble 0
      , bvdUpdateVoteThd     = unsafeCoinPortionFromDouble 0
      , bvdUpdateProposalThd = unsafeCoinPortionFromDouble 0
  
      , bvdUpdateImplicit = 0
  
      , bvdSoftforkRule     = SoftforkRule
            { srInitThd      = unsafeCoinPortionFromDouble 0
            , srMinThd       = unsafeCoinPortionFromDouble 0
            , srThdDecrement = unsafeCoinPortionFromDouble 0
            }
      , bvdTxFeePolicy      = TxFeePolicyUnknown 0 mempty
      , bvdUnlockStakeEpoch = EpochIndex { getEpochIndex = 0 }
      }
    where
      limit = fromIntegral ((2 :: Int) ^ (32 :: Int))
  
  -- What follows is the definition of a block.
  -- It's not a *valid* block, but that's OK! I just want a well-formed block
  -- which this pure logic layer can give out for every block request (getBlock,
  -- getTip), along with a well-formed block header to give for every header
  -- request.
  -- The diffusion layer should work just fine even if the logic layer gives
  -- *invalid* but *well-formed* blocks.
  
  -- | This block is always given by 'getBlock' and 'getTip'
  block :: Block
  block = Right mainBlock
  
  serializedBlock :: SerializedBlock
  serializedBlock = Serialized $ serialize' block
  
  mainBlock :: MainBlock
  mainBlock = mkGenericBlockUnsafe mainBlockHeader blockBody extraBodyData
  
  blockBody :: MainBody
  blockBody = MainBody
      { _mbTxPayload     = emptyTxPayload
      , _mbSscPayload    = emptySscPayload
      , _mbDlgPayload    = emptyDlgPayload
      , _mbUpdatePayload = emptyUpdatePayload
      }
  
  -- SscPayload is 4 alternatives. I chose CertificatesPayload because it has
  -- the fewest fields...
  emptySscPayload :: SscPayload
  emptySscPayload = CertificatesPayload
      (UnsafeVssCertificatesMap
            { getVssCertificatesMap = mempty
            }
      )
  
  emptyDlgPayload :: DlgPayload
  emptyDlgPayload = UnsafeDlgPayload
      { getDlgPayload = mempty
      }
  
  emptyUpdatePayload :: UpdatePayload
  emptyUpdatePayload = UpdatePayload
      { upProposal = Nothing
      , upVotes    = []
      }
  
  extraBodyData :: MainExtraBodyData
  extraBodyData = MainExtraBodyData
      { _mebAttributes = Attributes
            { attrData   = ()
            , attrRemain = UnparsedFields mempty
            }
      }
  
  blockHeader :: BlockHeader
  blockHeader = BlockHeaderMain mainBlockHeader
  
  mainBlockHeader :: MainBlockHeader
  mainBlockHeader = mkGenericBlockHeaderUnsafe
      protocolMagic
      mainBlockHeaderHash
      bodyProof
      consensusData
      extraHeaderData
  
  mainBlockHeaderHash :: HeaderHash
  mainBlockHeaderHash = unsafeMkAbstractHash mempty
  
  bodyProof :: MainProof
  bodyProof = MainProof
      { mpTxProof       = txProof
      , mpMpcProof      = sscProof
      , mpProxySKsProof = dlgProof
      , mpUpdateProof   = updateProof
      }
  
  txProof :: TxProof
  txProof = TxProof
      { txpNumber        = 0
      , txpRoot          = MerkleRoot (unsafeMkAbstractHash mempty)
      , txpWitnessesHash = unsafeMkAbstractHash mempty
      }
  
  sscProof :: SscProof
  sscProof = CertificatesProof
      (unsafeMkAbstractHash mempty)
  
  dlgProof :: Hash DlgPayload
  dlgProof = unsafeMkAbstractHash mempty
  
  updateProof :: UpdateProof
  updateProof = unsafeMkAbstractHash mempty
  
  consensusData :: MainConsensusData
  consensusData = MainConsensusData
      { _mcdSlot       = slotId
      , _mcdLeaderKey  = publicKey
      , _mcdDifficulty = chainDifficulty
      , _mcdSignature  = blockSignature
      }
  
  slotId :: SlotId
  slotId = SlotId
      { siEpoch = EpochIndex { getEpochIndex = 0 }
      , siSlot  = UnsafeLocalSlotIndex { getSlotIndex = 0 }
      }
  
  -- Trivia: the seed has to be at least 32 bytes.
  publicKey :: PublicKey
  secretKey :: SecretKey
  (publicKey, secretKey) = deterministicKeyGen (BS.pack (replicate 32 0))
  
  chainDifficulty :: ChainDifficulty
  chainDifficulty = ChainDifficulty
      { getChainDifficulty = BlockCount { getBlockCount = 0 }
      }
  
  blockSignature :: BlockSignature
  blockSignature = BlockSignature (coerce (signRaw protocolMagic Nothing secretKey mempty))
  
  protocolMagicId :: ProtocolMagicId
  protocolMagicId = ProtocolMagicId 0
  
  protocolMagic :: ProtocolMagic
  protocolMagic = ProtocolMagic protocolMagicId RequiresNoMagic
  
  extraHeaderData :: MainExtraHeaderData
  extraHeaderData = MainExtraHeaderData
      { _mehBlockVersion    = blockVersion
      , _mehSoftwareVersion = softwareVersion
      , _mehAttributes      = blockHeaderAttributes
      , _mehEBDataProof     = extraBodyDataProof
      }
  
  blockVersion :: BlockVersion
  blockVersion = BlockVersion
      { bvMajor = 0
      , bvMinor = 0
      , bvAlt   = 0
      }
  
  softwareVersion :: SoftwareVersion
  softwareVersion = SoftwareVersion
      { svAppName = appName
      , svNumber  = 0
      }
    where
      appName = ApplicationName (mempty :: Text)
  
  blockHeaderAttributes :: BlockHeaderAttributes
  blockHeaderAttributes = Attributes
      { attrData   = ()
      , attrRemain = UnparsedFields mempty
      }
  
  extraBodyDataProof :: Hash MainExtraBodyData
  extraBodyDataProof = unsafeMkAbstractHash mempty
  