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
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
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
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)
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)
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
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
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
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