{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK prune #-}

-- |
-- Copyright: 2020 Input Output (Hong Kong) Ltd., 2021-2022 Input Output Global Inc. (IOG), 2023-2025 Intersect
-- License: Apache-2.0

module Cardano.Mnemonic
    (
      -- * Introduction
      -- $introduction

      -- * @SomeMnemonic@
      SomeMnemonic(..)
    , MkSomeMnemonic (..)
    , MkSomeMnemonicError(..)
    , someMnemonicToBytes
    , NatVals (..)

      -- * @Mnemonic@
    , Mnemonic
    , mkMnemonic
    , MkMnemonicError(..)
    , mnemonicToText
    , mnemonicToEntropy

      -- * @Entropy@
    , Entropy
    , genEntropy
    , mkEntropy
    , entropyToBytes
    , entropyToMnemonic

      -- Internals & Re-export from @Crypto.Encoding.BIP39@
    , EntropyError(..)
    , DictionaryError(..)
    , MnemonicWordsError(..)
    , ValidEntropySize
    , ValidChecksumSize
    , ValidMnemonicSentence
    , ConsistentEntropy
    , CheckSumBits
    , EntropySize
    , MnemonicWords
    , MnemonicException(..)

      -- * Troubleshooting
      -- $troubleshooting
    ) where

import Prelude

import Basement.NormalForm
    ( NormalForm (..) )
import Basement.Sized.List
    ( unListN )
import Control.Arrow
    ( left )
import Control.DeepSeq
    ( NFData (..) )
import Control.Monad.Catch
    ( throwM )
import Crypto.Encoding.BIP39
    ( CheckSumBits
    , ConsistentEntropy
    , DictionaryError (..)
    , Entropy
    , EntropyError (..)
    , EntropySize
    , MnemonicSentence
    , MnemonicWords
    , MnemonicWordsError (..)
    , ValidChecksumSize
    , ValidEntropySize
    , ValidMnemonicSentence
    , dictionaryIndexToWord
    , entropyRaw
    , entropyToWords
    , mnemonicPhrase
    , mnemonicPhraseToMnemonicSentence
    , mnemonicSentenceToListN
    , toEntropy
    , wordsToEntropy
    )
import Data.Bifunctor
    ( bimap )
import Data.ByteArray
    ( ScrubbedBytes )
import Data.List
    ( intercalate )
import Data.Proxy
    ( Proxy (..) )
import Data.Text
    ( Text )
import Data.Type.Equality
    ( (:~:) (..), testEquality )
import Data.Typeable
    ( Typeable )
import GHC.TypeLits
    ( KnownNat, Nat, natVal )
import Type.Reflection
    ( typeOf )

import qualified Basement.Compat.Base as Basement
import qualified Basement.String as Basement
import qualified Crypto.Encoding.BIP39.English as Dictionary
import qualified Crypto.Random.Entropy as Crypto
import qualified Data.ByteArray as BA
import qualified Data.Text as T

-- $introduction
--
-- We call 'Entropy' an arbitrary sequence of bytes that has been generated
-- through __high quality randomness methods__. The allowed size of an
-- 'Entropy' is @96-256@ bits and is __necessarily a multiple of 32 bits__ (4
-- bytes).
--
-- We call 'Mnemonic' an 'Entropy' with an appended checksum calculated by
-- taking the first @ent / 32@ bits of the /SHA256/ hash of it, where ent
-- designates the 'Entropy' size in bits.
--
-- The concatenated result is split into groups of @11@ bits, each encoding a
-- number from 0 to 2047 serving as an index into a known dictionary:
--
-- https://github.com/cardano-foundation/cardano-wallet/tree/master/specifications/mnemonic/english.txt
--
-- This makes for a __human-readable sentence__ of English words.
--
-- +---------------------+---------------+-----------------+-------------------------------------------------------------------------------------------------------------------------------------------------+
-- | Entropy Size        | Checksum Size | Sentence Length | Example                                                                                                                                         |
-- +=====================+===============+=================+=================================================================================================================================================+
-- | 96  bits (12 bytes) | 3 bits        | 9 words         | test child burst immense armed parrot company walk dog                                                                                          |
-- +---------------------+---------------+-----------------+-------------------------------------------------------------------------------------------------------------------------------------------------+
-- | 128 bits (16 bytes) | 4 bits        | 12 words        | test walk nut penalty hip pave soap entry language right filter choice                                                                          |
-- +---------------------+---------------+-----------------+-------------------------------------------------------------------------------------------------------------------------------------------------+
-- | 160 bits (20 bytes) | 5 bits        | 15 words        | art forum devote street sure rather head chuckle guard poverty release quote oak craft enemy                                                    |
-- +---------------------+---------------+-----------------+-------------------------------------------------------------------------------------------------------------------------------------------------+
-- | 192 bits (24 bytes) | 6 bits        | 18 words        | churn shaft spoon second erode useless thrive burst group seed element sign scrub buffalo jelly grace neck useless                              |
-- +---------------------+---------------+-----------------+-------------------------------------------------------------------------------------------------------------------------------------------------+
-- | 224 bits (28 bytes) | 7 bits        | 21 words        | draft ability female child jump maid roof hurt below live topple paper exclude ordinary coach churn sunset emerge blame ketchup much            |
-- +---------------------+---------------+-----------------+-------------------------------------------------------------------------------------------------------------------------------------------------+
-- | 256 bits (32 bytes) | 8 bits        | 24 words        | excess behave track soul table wear ocean cash stay nature item turtle palm soccer lunch horror start stumble month panic right must lock dress |
-- +---------------------+---------------+-----------------+-------------------------------------------------------------------------------------------------------------------------------------------------+

-- A opaque 'Mnemonic' type.
data Mnemonic (mw :: Nat) = Mnemonic
    { mnemonicToEntropy  :: Entropy (EntropySize mw)
        -- ^ Convert a 'Mnemonic' back to an 'Entropy'.
        --
        -- @since 1.0.0
    , mnemonicToSentence :: MnemonicSentence mw
    } deriving stock (Eq, Show)

-- This wraps EntropyError of "Cardano.Encoding.BIP39"
newtype MnemonicException csz =
    UnexpectedEntropyError (EntropyError csz)
    -- ^ Invalid entropy length or checksum
    deriving stock (Show, Typeable)
    deriving newtype NFData

-- | This wraps errors from "Cardano.Encoding.BIP39"
data MkMnemonicError csz
    = ErrMnemonicWords MnemonicWordsError
      -- ^ Wrong number of words in mnemonic.
    | ErrEntropy (EntropyError csz)
      -- ^ Invalid entropy length or checksum.
    | ErrDictionary DictionaryError
      -- ^ Invalid word in mnemonic.
    deriving stock (Eq, Show)

deriving instance Eq (EntropyError czs)
deriving instance Eq MnemonicWordsError
deriving instance Eq DictionaryError

-- NFData instances
instance NFData (Mnemonic mw) where
    rnf (Mnemonic ent ws) = toNormalForm ent `seq` toNormalForm ws
instance NFData (EntropyError csz) where
    rnf (ErrInvalidEntropyLength a b) = rnf a `seq` rnf b
    rnf (ErrInvalidEntropyChecksum a b) = toNormalForm a `seq` toNormalForm b
instance NFData MnemonicWordsError where
    rnf (ErrWrongNumberOfWords a b) = rnf a `seq` rnf b
instance NFData DictionaryError where
    rnf (ErrInvalidDictionaryWord s) = toNormalForm s
instance NFData (MkMnemonicError csz) where
    rnf (ErrMnemonicWords e) = rnf e
    rnf (ErrEntropy e) = rnf e
    rnf (ErrDictionary e) = rnf e

-- | Smart-constructor for the 'Entropy'. Make sure the 'ByteString' comes from a highly random source or use 'genEntropy'.
--
-- __example__:
--
-- >>> mkEntropy @160 bytes
-- Entropy {} :: Entropy 160
--
-- __property__:
--
-- prop> mkEntropy (entropyToBytes ent) == Right ent
--
-- @since 1.0.0
mkEntropy
    :: forall (ent :: Nat) csz. (ValidEntropySize ent, ValidChecksumSize ent csz)
    => ScrubbedBytes
    -> Either (EntropyError csz) (Entropy ent)
mkEntropy = toEntropy

-- | Generate Entropy of a given size using a cryptographically secure random seed.
--
-- __example:__
--
-- >>> genEntropy @128
-- Entropy {} :: Entropy 128
--
-- @since 1.0.0
genEntropy
    :: forall (ent :: Nat) csz. (ValidEntropySize ent, ValidChecksumSize ent csz)
    => IO (Entropy ent)
genEntropy =
    let
        size =
            fromIntegral $ natVal @ent Proxy
        eitherToIO =
            either (throwM . UnexpectedEntropyError) return
    in
        (eitherToIO . mkEntropy) =<< Crypto.getEntropy (size `div` 8)

-- | Smart-constructor for 'Mnemonic'. Requires a type application to
-- disambiguate the mnemonic size.
--
-- __example__:
--
-- >>> mkMnemonic @15 sentence
-- Mnemonic {} :: Mnemonic 15
--
-- __property__:
--
-- prop> mkMnemonic (mnemonicToText mnemonic) == Right mnemonic
--
-- @since 1.0.0
mkMnemonic
    :: forall (mw :: Nat) (ent :: Nat) csz.
     ( ConsistentEntropy ent mw csz
     , EntropySize mw ~ ent
     )
    => [Text]
    -> Either (MkMnemonicError csz) (Mnemonic mw)
mkMnemonic wordsm = do
    phrase <- left ErrMnemonicWords
        $ mnemonicPhrase @mw (toUtf8String <$> wordsm)

    sentence <- left ErrDictionary
        $ mnemonicPhraseToMnemonicSentence Dictionary.english phrase

    entropy <- left ErrEntropy
        $ wordsToEntropy sentence

    pure Mnemonic
        { mnemonicToEntropy  = entropy
        , mnemonicToSentence = sentence
        }

-- | Convert an Entropy to a corresponding Mnemonic Sentence. Since 'Entropy'
-- and 'Mnemonic' can only be created through smart-constructors, this function
-- cannot fail and is total.
--
-- @since 1.0.0
entropyToMnemonic
    :: forall mw ent csz.
     ( ValidMnemonicSentence mw
     , ValidEntropySize ent
     , ValidChecksumSize ent csz
     , ent ~ EntropySize mw
     , mw ~ MnemonicWords ent
     )
    => Entropy ent
    -> Mnemonic mw
entropyToMnemonic entropy = Mnemonic
    { mnemonicToSentence = entropyToWords entropy
    , mnemonicToEntropy  = entropy
    }

-- | Convert 'Entropy' to plain bytes.
--
-- @since 1.0.0
entropyToBytes
    :: Entropy n
    -> ScrubbedBytes
entropyToBytes = BA.convert . entropyRaw

toUtf8String
    :: Text
    -> Basement.String
toUtf8String = Basement.fromString . T.unpack

fromUtf8String
    :: Basement.String
    -> Text
fromUtf8String = T.pack . Basement.toList

instance (KnownNat csz) => Basement.Exception (MnemonicException csz)

-- | Convert a 'Mnemonic' to a sentence of English mnemonic words.
--
-- @since 1.0.0
mnemonicToText
    :: Mnemonic mw
    -> [Text]
mnemonicToText =
    map (fromUtf8String . dictionaryIndexToWord Dictionary.english)
    . unListN
    . mnemonicSentenceToListN
    . mnemonicToSentence

-- | Convert a 'SomeMnemonic' to bytes.
--
-- @since 1.0.1
someMnemonicToBytes :: SomeMnemonic -> ScrubbedBytes
someMnemonicToBytes (SomeMnemonic mw) = entropyToBytes $ mnemonicToEntropy mw

-- | Ease the manipulation of 'Mnemonic' by encapsulating the type constraints inside a constructor.
-- This is particularly useful for functions which do not require anything but a valid 'Mnemonic' without any
-- particular pre-condition on the size of the 'Mnemonic' itself.
--
-- @since 1.0.0
data SomeMnemonic where
    SomeMnemonic :: forall mw. KnownNat mw => Mnemonic mw -> SomeMnemonic

deriving instance Show SomeMnemonic
instance Eq SomeMnemonic where
    (SomeMnemonic mwa) == (SomeMnemonic mwb) =
        case typeOf mwa `testEquality` typeOf mwb of
            Nothing -> False
            Just Refl -> mwa == mwb
instance NFData SomeMnemonic where
    rnf (SomeMnemonic mnem) = rnf mnem

-- | This class enables caller to parse text list of variable length
-- into mnemonic sentences.
--
-- Note that the given 'Nat's **have** to be valid mnemonic sizes, otherwise the
-- underlying code won't even compile, with not-so-friendly error messages.
class MkSomeMnemonic (sz :: [Nat]) where
    -- | Construct a mnemonic from a list of words. This function is particularly useful when the
    -- number of words is not necessarily known at runtime. The function is however /ambiguous/ and
    -- requires thereby a type application.
    --
    -- __examples:__
    --
    -- >>> mkSomeMnemonic @'[ 12 ] [ "test", "child", "burst", "immense", "armed", "parrot", "company", "walk", "dog" ]
    -- Left "Invalid number of words: 12 words are expected."
    --
    -- >>> mkSomeMnemonic @'[ 9, 12, 15 ] [ "test", "child", "burst", "immense", "armed", "parrot", "company", "walk", "dog" ]
    -- Right (SomeMnemonic ...)
    --
    -- @since 1.0.0
    mkSomeMnemonic :: [Text] -> Either (MkSomeMnemonicError sz) SomeMnemonic

-- | Error reported from trying to create a passphrase from a given mnemonic
--
-- @since 1.0.0
newtype MkSomeMnemonicError (sz :: [Nat]) =
    MkSomeMnemonicError { getMkSomeMnemonicError :: String }
    deriving stock (Eq, Show)

instance {-# OVERLAPS #-}
    ( n ~ EntropySize mw
    , csz ~ CheckSumBits n
    , ConsistentEntropy n mw csz
    , MkSomeMnemonic rest
    , NatVals rest
    ) =>
    MkSomeMnemonic (mw ': rest)
  where
    mkSomeMnemonic parts = case parseMW of
        Left err -> left (promote err) parseRest
        Right mw -> Right mw
      where
        parseMW = left (MkSomeMnemonicError . getMkSomeMnemonicError) $ -- coerce
            mkSomeMnemonic @'[mw] parts
        parseRest = left (MkSomeMnemonicError . getMkSomeMnemonicError) $ -- coerce
            mkSomeMnemonic @rest parts
        promote e e' =
            let
                sz = fromEnum <$> natVals (Proxy :: Proxy (mw ': rest))
                mw = fromEnum $ natVal (Proxy :: Proxy mw)
            in if length parts `notElem` sz
                then MkSomeMnemonicError
                    $  "Invalid number of words: "
                    <> intercalate ", " (show <$> init sz)
                    <> (if length sz > 1 then " or " else "") <> show (last sz)
                    <> " words are expected."
                else if length parts == mw then e else e'

-- | Small helper to collect 'Nat' values from a type-level list
class NatVals (ns :: [Nat]) where
    natVals :: Proxy ns -> [Integer]

instance NatVals '[] where
    natVals _ = []

instance (KnownNat n, NatVals rest) => NatVals (n ': rest) where
    natVals _ = natVal (Proxy :: Proxy n) : natVals (Proxy :: Proxy rest)

instance
    ( n ~ EntropySize mw
    , csz ~ CheckSumBits n
    , ConsistentEntropy n mw csz
    ) =>
    MkSomeMnemonic (mw ': '[])
  where
    mkSomeMnemonic parts = do
        bimap (MkSomeMnemonicError . pretty) SomeMnemonic (mkMnemonic @mw parts)
      where
        pretty = \case
            ErrMnemonicWords ErrWrongNumberOfWords{} ->
                "Invalid number of words: "
                <> show (natVal (Proxy :: Proxy mw))
                <> " words are expected."
            ErrDictionary (ErrInvalidDictionaryWord _) ->
                "Found an unknown word not present in the pre-defined dictionary. \
                \The full dictionary is available here: \
                \https://github.com/cardano-foundation/cardano-wallet/tree/master/specifications/mnemonic/english.txt"
            ErrEntropy ErrInvalidEntropyChecksum{} ->
                "Invalid entropy checksum: please double-check the last word of \
                \your mnemonic sentence."
            ErrEntropy ErrInvalidEntropyLength{} ->
                "Something went wrong when trying to generate the entropy from \
                \the given mnemonic. As a user, there's nothing you can do."

-- $troubleshooting
--
-- - /Natural XX is out of bounds for Int/:
--   This usually occurs when ones is trying to specify an invalid size for an
--   'Entropy' or 'Mnemonic'. For example:
--
--   >>> genEntropy @42
--   error:
--     • Natural CheckSumBits 42 is out of bounds for Int
--
-- - This could be the case as well when forgetting to use an adequate type application:
--
--   >>> mkEntropy mempty
--   error:
--     • Natural ent is out of bounds for Int