-- | Utilities shared by multiple cryptographic primitives.

module Tezos.Crypto.Util
  ( CryptoParseError (..)
  , encodeBase58Check
  , decodeBase58Check
  , B58CheckWithPrefixError (..)
  , decodeBase58CheckWithPrefix
  , formatImpl
  , parseImpl
  , firstRight
  , deterministic
  ) where

import Crypto.Error (CryptoError)
import Crypto.Number.Serialize (os2ip)
import Crypto.Random (ChaChaDRG, MonadPseudoRandom, drgNewSeed, seedFromInteger, withDRG)
import qualified Data.ByteArray as ByteArray
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base58 as Base58
import Fmt (Buildable, Builder, build, fmt, hexF)

import Tezos.Crypto.Hash

-- | Error that can happen during parsing of cryptographic primitive types.
data CryptoParseError
  = CryptoParseWrongBase58Check
  | CryptoParseWrongTag ByteString
  | CryptoParseCryptoError CryptoError
  | CryptoParseUnexpectedLength Builder Int
  deriving stock (Int -> CryptoParseError -> ShowS
[CryptoParseError] -> ShowS
CryptoParseError -> String
(Int -> CryptoParseError -> ShowS)
-> (CryptoParseError -> String)
-> ([CryptoParseError] -> ShowS)
-> Show CryptoParseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CryptoParseError] -> ShowS
$cshowList :: [CryptoParseError] -> ShowS
show :: CryptoParseError -> String
$cshow :: CryptoParseError -> String
showsPrec :: Int -> CryptoParseError -> ShowS
$cshowsPrec :: Int -> CryptoParseError -> ShowS
Show, CryptoParseError -> CryptoParseError -> Bool
(CryptoParseError -> CryptoParseError -> Bool)
-> (CryptoParseError -> CryptoParseError -> Bool)
-> Eq CryptoParseError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CryptoParseError -> CryptoParseError -> Bool
$c/= :: CryptoParseError -> CryptoParseError -> Bool
== :: CryptoParseError -> CryptoParseError -> Bool
$c== :: CryptoParseError -> CryptoParseError -> Bool
Eq)

instance NFData CryptoParseError where
  rnf :: CryptoParseError -> ()
rnf = NFData String => String -> ()
forall a. NFData a => a -> ()
rnf @String (String -> ())
-> (CryptoParseError -> String) -> CryptoParseError -> ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CryptoParseError -> String
forall b a. (Show a, IsString b) => a -> b
show

instance Buildable CryptoParseError where
  build :: CryptoParseError -> Builder
build =
    \case
      CryptoParseWrongBase58Check -> "Wrong base58check encoding of bytes"
      CryptoParseWrongTag tag :: ByteString
tag -> "Prefix is wrong tag: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
forall b. FromBuilder b => Builder -> b
fmt (ByteString -> Builder
forall a. FormatAsHex a => a -> Builder
hexF ByteString
tag)
      CryptoParseCryptoError err :: CryptoError
err ->
        "Cryptographic library reported an error: " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
        String -> Builder
forall p. Buildable p => p -> Builder
build (CryptoError -> String
forall e. Exception e => e -> String
displayException CryptoError
err)
      CryptoParseUnexpectedLength what :: Builder
what l :: Int
l ->
        "Unexpected length of " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
what Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ": " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
forall p. Buildable p => p -> Builder
build Int
l

-- | Encode a bytestring in Base58Check format.
encodeBase58Check :: ByteString -> Text
encodeBase58Check :: ByteString -> Text
encodeBase58Check =
  ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Alphabet -> ByteString -> ByteString
Base58.encodeBase58 Alphabet
Base58.bitcoinAlphabet (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
withCheckSum
  where
    withCheckSum :: ByteString -> ByteString
    withCheckSum :: ByteString -> ByteString
withCheckSum bs :: ByteString
bs = ByteString
bs ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
checkSum ByteString
bs

-- | Decode a bytestring from Base58Check format.
decodeBase58Check :: Text -> Maybe ByteString
decodeBase58Check :: Text -> Maybe ByteString
decodeBase58Check text :: Text
text = do
  ByteString
bytes <- Alphabet -> ByteString -> Maybe ByteString
Base58.decodeBase58 Alphabet
Base58.bitcoinAlphabet (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
text)
  let (payload :: ByteString
payload, chk :: ByteString
chk) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt (ByteString -> Int
forall t. Container t => t -> Int
length ByteString
bytes Int -> Int -> Int
forall a. Num a => a -> a -> a
- 4) ByteString
bytes
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ ByteString
chk ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> ByteString
checkSum ByteString
payload
  return ByteString
payload

checkSum :: ByteString -> ByteString
checkSum :: ByteString -> ByteString
checkSum = Int -> ByteString -> ByteString
BS.take 4 (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString
sha256 (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
sha256)

data B58CheckWithPrefixError
  = B58CheckWithPrefixWrongPrefix ByteString
  | B58CheckWithPrefixWrongEncoding
  deriving stock (Int -> B58CheckWithPrefixError -> ShowS
[B58CheckWithPrefixError] -> ShowS
B58CheckWithPrefixError -> String
(Int -> B58CheckWithPrefixError -> ShowS)
-> (B58CheckWithPrefixError -> String)
-> ([B58CheckWithPrefixError] -> ShowS)
-> Show B58CheckWithPrefixError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [B58CheckWithPrefixError] -> ShowS
$cshowList :: [B58CheckWithPrefixError] -> ShowS
show :: B58CheckWithPrefixError -> String
$cshow :: B58CheckWithPrefixError -> String
showsPrec :: Int -> B58CheckWithPrefixError -> ShowS
$cshowsPrec :: Int -> B58CheckWithPrefixError -> ShowS
Show)

-- | Parse a base58check encoded value expecting some prefix. If the
-- actual prefix matches the expected one, it's stripped of and the
-- resulting payload is returned.
decodeBase58CheckWithPrefix ::
  ByteString -> Text -> Either B58CheckWithPrefixError ByteString
decodeBase58CheckWithPrefix :: ByteString -> Text -> Either B58CheckWithPrefixError ByteString
decodeBase58CheckWithPrefix prefix :: ByteString
prefix text :: Text
text =
  case Text -> Maybe ByteString
decodeBase58Check Text
text of
    Nothing -> B58CheckWithPrefixError
-> Either B58CheckWithPrefixError ByteString
forall a b. a -> Either a b
Left B58CheckWithPrefixError
B58CheckWithPrefixWrongEncoding
    Just bs :: ByteString
bs ->
      let (actualPrefix :: ByteString
actualPrefix, payload :: ByteString
payload) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt (ByteString -> Int
forall t. Container t => t -> Int
length ByteString
prefix) ByteString
bs
       in if ByteString
actualPrefix ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
prefix
          then ByteString -> Either B58CheckWithPrefixError ByteString
forall a b. b -> Either a b
Right ByteString
payload
          else B58CheckWithPrefixError
-> Either B58CheckWithPrefixError ByteString
forall a b. a -> Either a b
Left (ByteString -> B58CheckWithPrefixError
B58CheckWithPrefixWrongPrefix ByteString
actualPrefix)

-- | Template for 'format*' functions.
formatImpl :: ByteArray.ByteArrayAccess x => ByteString -> x -> Text
formatImpl :: ByteString -> x -> Text
formatImpl tag :: ByteString
tag = ByteString -> Text
encodeBase58Check (ByteString -> Text) -> (x -> ByteString) -> x -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
mappend ByteString
tag (ByteString -> ByteString) -> (x -> ByteString) -> x -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert

-- | Template for 'parse*' functions.
parseImpl
  :: ByteString
  -> (ByteString -> Either CryptoParseError res)
  -> Text
  -> Either CryptoParseError res
parseImpl :: ByteString
-> (ByteString -> Either CryptoParseError res)
-> Text
-> Either CryptoParseError res
parseImpl expectedTag :: ByteString
expectedTag constructor :: ByteString -> Either CryptoParseError res
constructor text :: Text
text = do
  let convertErr :: B58CheckWithPrefixError -> CryptoParseError
      convertErr :: B58CheckWithPrefixError -> CryptoParseError
convertErr =
        \case B58CheckWithPrefixWrongPrefix prefix :: ByteString
prefix -> ByteString -> CryptoParseError
CryptoParseWrongTag ByteString
prefix
              B58CheckWithPrefixWrongEncoding -> CryptoParseError
CryptoParseWrongBase58Check
  ByteString
payload <- (B58CheckWithPrefixError -> CryptoParseError)
-> Either B58CheckWithPrefixError ByteString
-> Either CryptoParseError ByteString
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first B58CheckWithPrefixError -> CryptoParseError
convertErr (Either B58CheckWithPrefixError ByteString
 -> Either CryptoParseError ByteString)
-> Either B58CheckWithPrefixError ByteString
-> Either CryptoParseError ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Text -> Either B58CheckWithPrefixError ByteString
decodeBase58CheckWithPrefix ByteString
expectedTag Text
text
  ByteString -> Either CryptoParseError res
constructor ByteString
payload

-- | Returns first encountered 'Right' in a list. If there are none,
-- returns arbitrary 'Left'.
-- It is useful to implement parsing.
firstRight :: NonEmpty (Either e a) -> Either e a
firstRight :: NonEmpty (Either e a) -> Either e a
firstRight (h :: Either e a
h :| rest :: [Either e a]
rest) =
  case Either e a
h of
    Left e :: e
e -> Either e a
-> (NonEmpty (Either e a) -> Either e a)
-> Maybe (NonEmpty (Either e a))
-> Either e a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> Either e a
forall a b. a -> Either a b
Left e
e) NonEmpty (Either e a) -> Either e a
forall e a. NonEmpty (Either e a) -> Either e a
firstRight (Maybe (NonEmpty (Either e a)) -> Either e a)
-> Maybe (NonEmpty (Either e a)) -> Either e a
forall a b. (a -> b) -> a -> b
$ [Either e a] -> Maybe (NonEmpty (Either e a))
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Either e a]
rest
    Right a :: a
a -> a -> Either e a
forall a b. b -> Either a b
Right a
a

-- | Do randomized action using specified seed.
deterministic :: ByteString -> MonadPseudoRandom ChaChaDRG a -> a
deterministic :: ByteString -> MonadPseudoRandom ChaChaDRG a -> a
deterministic seed :: ByteString
seed = (a, ChaChaDRG) -> a
forall a b. (a, b) -> a
fst ((a, ChaChaDRG) -> a)
-> (MonadPseudoRandom ChaChaDRG a -> (a, ChaChaDRG))
-> MonadPseudoRandom ChaChaDRG a
-> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChaChaDRG -> MonadPseudoRandom ChaChaDRG a -> (a, ChaChaDRG)
forall gen a. DRG gen => gen -> MonadPseudoRandom gen a -> (a, gen)
withDRG ChaChaDRG
chachaSeed
  where
    chachaSeed :: ChaChaDRG
chachaSeed = Seed -> ChaChaDRG
drgNewSeed (Seed -> ChaChaDRG)
-> (ByteString -> Seed) -> ByteString -> ChaChaDRG
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Seed
seedFromInteger (Integer -> Seed) -> (ByteString -> Integer) -> ByteString -> Seed
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Integer
forall ba. ByteArrayAccess ba => ba -> Integer
os2ip (ByteString -> ChaChaDRG) -> ByteString -> ChaChaDRG
forall a b. (a -> b) -> a -> b
$ ByteString
seed