content: {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE QuasiQuotes #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE TupleSections #-}
  {-# LANGUAGE TypeApplications #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE TypeOperators #-}
  {-# LANGUAGE UndecidableInstances #-}
  
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  {-# OPTIONS_GHC -fno-warn-deprecations #-}
  
  module Test.Arbitrary
      ( unsafeMkMnemonic
      , unsafeMkSomeMnemonicFromEntropy
      , unsafeFromHex
      , unsafeFromRight
      ) where
  
  import Prelude
  
  import Cardano.Address
      ( AddressDiscrimination (..), ChainPointer (..), NetworkTag (..) )
  import Cardano.Address.Derivation
      ( Depth (..)
      , GenMasterKey (..)
      , HardDerivation (..)
      , Index (..)
      , XPrv
      , XPub
      , generate
      , generateNew
      , indexFromWord32
      , toXPub
      , xprvToBytes
      )
  import Cardano.Address.Style.Byron
      ( Byron
      , byronMainnet
      , byronPreprod
      , byronPreview
      , byronStaging
      , byronTestnet
      )
  import Cardano.Address.Style.Icarus
      ( Icarus
      , icarusMainnet
      , icarusPreprod
      , icarusPreview
      , icarusStaging
      , icarusTestnet
      )
  import Cardano.Address.Style.Shelley
      ( Shelley )
  import Cardano.Mnemonic
      ( ConsistentEntropy
      , Entropy
      , EntropySize
      , Mnemonic
      , MnemonicException (..)
      , MnemonicWords
      , SomeMnemonic (..)
      , entropyToMnemonic
      , mkEntropy
      , mkMnemonic
      )
  import Codec.Binary.Bech32
      ( HumanReadablePart )
  import Codec.Binary.Bech32.TH
      ( humanReadablePart )
  import Codec.Binary.Encoding
      ( AbstractEncoding (..) )
  import Crypto.Encoding.BIP39
      ( ValidChecksumSize, ValidEntropySize, ValidMnemonicSentence )
  import Data.ByteArray.Encoding
      ( Base (..), convertFromBase )
  import Data.ByteString
      ( ByteString )
  import Data.Function
      ( on )
  import Data.List
      ( intercalate )
  import Data.Maybe
      ( fromMaybe, mapMaybe )
  import Data.Proxy
      ( Proxy (..) )
  import Data.Text
      ( Text )
  import Data.Word
      ( Word64 )
  import GHC.Stack
      ( HasCallStack )
  import GHC.TypeLits
      ( natVal )
  import Numeric.Natural
      ( Natural )
  import Options.Applicative.Derivation
      ( DerivationIndex
      , DerivationPath
      , derivationIndexToString
      , derivationPathFromString
      , indexToInteger
      , mkDerivationIndex
      )
  import Test.QuickCheck
      ( Arbitrary (..), Gen, choose, elements, genericShrink, oneof, vector )
  
  import qualified Cardano.Address.Style.Icarus as Icarus
  import qualified Cardano.Address.Style.Shelley as Shelley
  import qualified Data.ByteArray as BA
  import qualified Data.ByteString as BS
  import qualified Data.ByteString.Char8 as B8
  
  --
  -- Arbitrary Instances
  --
  
  instance Arbitrary XPrv where
      arbitrary = oneof
          [ flip generateNew (mempty :: ByteString) . BS.pack <$> vector 16
          , generate . BS.pack <$> vector 32
          ]
  
  instance Arbitrary XPub where
      arbitrary =
          toXPub <$> arbitrary
  
  instance Arbitrary DerivationIndex where
      arbitrary = unsafeFromRight . mkDerivationIndex
          <$> choose (indexToInteger minBound, indexToInteger maxBound)
  
  instance Arbitrary DerivationPath where
      arbitrary = do
          n <- choose (1, 10)
          ixs <- vector @DerivationIndex n
          pure $ unsafeFromRight $ derivationPathFromString $
              intercalate "/" (derivationIndexToString <$> ixs)
  
  instance Arbitrary (AbstractEncoding HumanReadablePart) where
      arbitrary = elements
          [ EBase16
          , EBase58
          , EBech32 [humanReadablePart|bech32|]
          ]
  
  instance Arbitrary Natural where
      arbitrary =
          fromIntegral <$> choose (1 :: Word64, 10000000000)
  
  instance Arbitrary ChainPointer where
      arbitrary = do
          slot <- arbitrary
          ix1 <- fromIntegral <$> choose (1 :: Word64, 1000000)
          ix2 <- fromIntegral <$> choose (1 :: Word64, 1000000)
          pure $ ChainPointer slot ix1 ix2
  
  -- | The initial seed has to be vector or length multiple of 4 bytes and shorter
  -- than 64 bytes. Note that this is good for testing or examples, but probably
  -- not for generating truly random Mnemonic words.
  --
  -- See 'Crypto.Random.Entropy (getEntropy)'
  instance
      ( ValidEntropySize n
      , ValidChecksumSize n csz
      ) => Arbitrary (Entropy n) where
      arbitrary =
          let
              size = fromIntegral $ natVal @n Proxy
              entropy =
                  mkEntropy  @n . BA.convert . B8.pack <$> vector (size `quot` 8)
          in
              either (error . show . UnexpectedEntropyError) id <$> entropy
  
  -- | Same remark from 'Arbitrary Entropy' applies here.
  instance
      ( n ~ EntropySize mw
      , mw ~ MnemonicWords n
      , ValidChecksumSize n csz
      , ValidEntropySize n
      , ValidMnemonicSentence mw
      , Arbitrary (Entropy n)
      ) => Arbitrary (Mnemonic mw) where
      arbitrary =
          entropyToMnemonic <$> arbitrary @(Entropy n)
  
  instance (Bounded ix, ix ~ Index ty depth) => Arbitrary (Index ty depth) where
      -- Use the Word32 shrink fun.
      shrink = mapMaybe indexFromWord32 . shrink . indexToWord32
      -- Use convert Index bounds to Word32 and choose from that range.
      arbitrary = fromMaybe err . indexFromWord32 <$> choose bounds
        where
          bounds = (indexToWord32 (minBound @ix), indexToWord32 (maxBound @ix))
          err = error "Arbitrary Index"
  
  instance Arbitrary SomeMnemonic where
      arbitrary = SomeMnemonic <$> genMnemonic @12
  
  instance Arbitrary (Byron 'PaymentK XPub) where
      shrink _ = []
      arbitrary = do
          mw <- SomeMnemonic <$> genMnemonic @12
          rootK <- genMasterKeyFromMnemonic mw   <$> arbitrary
          acctK <- deriveAccountPrivateKey rootK <$> arbitrary
          addrK <- deriveAddressPrivateKey acctK () <$> arbitrary
          pure $ toXPub <$> addrK
  
  instance Arbitrary (Icarus 'PaymentK XPub) where
      shrink _ = []
      arbitrary = do
          mw <- SomeMnemonic <$> genMnemonic @15
          bytes <- BA.convert . BS.pack <$> (choose (0, 32) >>= vector)
          let rootK = genMasterKeyFromMnemonic mw bytes
          acctK <- deriveAccountPrivateKey rootK <$> arbitrary
          addrK <- deriveAddressPrivateKey acctK <$> arbitrary <*> arbitrary
          pure $ toXPub <$> addrK
  
  instance Arbitrary (Shelley 'PaymentK XPub) where
      shrink _ = []
      arbitrary = do
          mw <- SomeMnemonic <$> genMnemonic @15
          bytes <- BA.convert . BS.pack <$> (choose (0, 32) >>= vector)
          let rootK = genMasterKeyFromMnemonic mw bytes
          acctK <- deriveAccountPrivateKey rootK <$> arbitrary
          addrK <- deriveAddressPrivateKey acctK <$> arbitrary <*> arbitrary
          pure $ toXPub <$> addrK
  
  instance Arbitrary (Shelley 'DelegationK XPub) where
      shrink _ = []
      arbitrary = do
          mw <- SomeMnemonic <$> genMnemonic @15
          bytes <- BA.convert . BS.pack <$> (choose (0, 32) >>= vector)
          let rootK = genMasterKeyFromMnemonic mw bytes
          acctK <- deriveAccountPrivateKey rootK <$> arbitrary
          let delegationK = Shelley.deriveDelegationPrivateKey acctK
          pure $ toXPub <$> delegationK
  
  instance {-# OVERLAPS #-} Arbitrary (AddressDiscrimination, NetworkTag) where
      arbitrary = oneof
          -- NOTE using explicit smart-constructor as a quick-win for the coverage :)
          [ (RequiresNoTag,) <$> arbitrary
          , (RequiresNetworkTag,) <$> arbitrary
          , pure byronMainnet
          , pure byronStaging
          , pure byronTestnet
          , pure byronPreview
          , pure byronPreprod
          , pure icarusMainnet
          , pure icarusStaging
          , pure icarusTestnet
          , pure icarusPreview
          , pure icarusPreprod
          ]
  
  instance Arbitrary NetworkTag where
      shrink (NetworkTag tag) = NetworkTag <$> shrink tag
      arbitrary = NetworkTag <$> choose (0, 15)
  
  instance Arbitrary Shelley.Role where
      shrink = genericShrink
      arbitrary = elements
          [ Shelley.UTxOExternal
          , Shelley.UTxOInternal
          , Shelley.Stake
          , Shelley.DRep
          , Shelley.CCCold
          , Shelley.CCHot
          ]
  
  instance Arbitrary Icarus.Role where
      shrink = genericShrink
      arbitrary = elements
          [ Icarus.UTxOExternal
          , Icarus.UTxOInternal
          ]
  
  --
  -- Extra Instances
  --
  
  -- Necessary unsound Show instance for QuickCheck failure reporting
  instance Show XPrv where
      show = show . xprvToBytes
  
  -- Necessary unsound Eq instance for QuickCheck properties
  instance Eq XPrv where
      (==) = (==) `on` xprvToBytes
  --
  -- Useful functions
  --
  
  -- | Generates an arbitrary mnemonic of a size according to the type parameter.
  --
  -- E.g:
  -- >>> arbitrary = SomeMnemonic <$> genMnemonic @12
  genMnemonic
      :: forall mw ent csz.
       ( ConsistentEntropy ent mw csz
       , EntropySize mw ~ ent
       )
      => Gen (Mnemonic mw)
  genMnemonic = do
          let n = fromIntegral (natVal $ Proxy @(EntropySize mw)) `div` 8
          bytes <- BS.pack <$> vector n
          let ent = unsafeMkEntropy @(EntropySize mw) bytes
          return $ entropyToMnemonic ent
  
  unsafeMkEntropy
      :: forall ent csz.
          ( HasCallStack
          , ValidEntropySize ent
          , ValidChecksumSize ent csz
          )
      => ByteString
      -> Entropy ent
  unsafeMkEntropy = either (error . show) id . mkEntropy . BA.convert
  
  -- | Build 'Mnemonic' from literals
  unsafeMkMnemonic
      :: forall mw n csz
      .  (ConsistentEntropy n mw csz, EntropySize mw ~ n, HasCallStack)
      => [Text]
      -> Mnemonic mw
  unsafeMkMnemonic m =
      case mkMnemonic m of
          Left e -> error $ "unsafeMnemonic: " <> show e
          Right a -> a
  
  unsafeMkSomeMnemonicFromEntropy
      :: forall mw ent csz.
          ( HasCallStack
          , ValidEntropySize ent
          , ValidChecksumSize ent csz
          , ValidMnemonicSentence mw
          , ent ~ EntropySize mw
          , mw ~ MnemonicWords ent
          )
      => Proxy mw
      -> ByteString
      -> SomeMnemonic
  unsafeMkSomeMnemonicFromEntropy _ = SomeMnemonic
      . entropyToMnemonic
      . unsafeMkEntropy @ent
  
  -- | Decode an hex-encoded 'ByteString' into raw bytes, or fail.
  unsafeFromHex :: HasCallStack => ByteString -> ByteString
  unsafeFromHex =
      either (error . show) id . convertFromBase @ByteString @ByteString Base16
  
  -- | Use the 'Right' of an Either
  unsafeFromRight :: (HasCallStack, Show left) => Either left right -> right
  unsafeFromRight = either (error . show) id
  