{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_HADDOCK hide #-}
module Codec.Binary.Encoding
(
AbstractEncoding (..)
, Encoding
, encode
, detectEncoding
, fromBase16
, fromBase58
, fromBech32
) where
import Prelude
import Codec.Binary.Bech32
( HumanReadablePart )
import Control.Applicative
( (<|>) )
import Control.Arrow
( left )
import Control.Monad
( guard )
import Data.ByteArray.Encoding
( Base (..), convertFromBase, convertToBase )
import Data.ByteString
( ByteString )
import Data.ByteString.Base58
( bitcoinAlphabet, decodeBase58, encodeBase58, unAlphabet )
import Data.Char
( isLetter, isLower, isUpper, ord, toLower )
import qualified Codec.Binary.Bech32 as Bech32
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
type Encoding = AbstractEncoding HumanReadablePart
data AbstractEncoding a
= EBase16
| EBase58
| EBech32 a
deriving (AbstractEncoding a -> AbstractEncoding a -> Bool
(AbstractEncoding a -> AbstractEncoding a -> Bool)
-> (AbstractEncoding a -> AbstractEncoding a -> Bool)
-> Eq (AbstractEncoding a)
forall a. Eq a => AbstractEncoding a -> AbstractEncoding a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AbstractEncoding a -> AbstractEncoding a -> Bool
$c/= :: forall a. Eq a => AbstractEncoding a -> AbstractEncoding a -> Bool
== :: AbstractEncoding a -> AbstractEncoding a -> Bool
$c== :: forall a. Eq a => AbstractEncoding a -> AbstractEncoding a -> Bool
Eq, Int -> AbstractEncoding a -> ShowS
[AbstractEncoding a] -> ShowS
AbstractEncoding a -> String
(Int -> AbstractEncoding a -> ShowS)
-> (AbstractEncoding a -> String)
-> ([AbstractEncoding a] -> ShowS)
-> Show (AbstractEncoding a)
forall a. Show a => Int -> AbstractEncoding a -> ShowS
forall a. Show a => [AbstractEncoding a] -> ShowS
forall a. Show a => AbstractEncoding a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AbstractEncoding a] -> ShowS
$cshowList :: forall a. Show a => [AbstractEncoding a] -> ShowS
show :: AbstractEncoding a -> String
$cshow :: forall a. Show a => AbstractEncoding a -> String
showsPrec :: Int -> AbstractEncoding a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> AbstractEncoding a -> ShowS
Show, a -> AbstractEncoding b -> AbstractEncoding a
(a -> b) -> AbstractEncoding a -> AbstractEncoding b
(forall a b. (a -> b) -> AbstractEncoding a -> AbstractEncoding b)
-> (forall a b. a -> AbstractEncoding b -> AbstractEncoding a)
-> Functor AbstractEncoding
forall a b. a -> AbstractEncoding b -> AbstractEncoding a
forall a b. (a -> b) -> AbstractEncoding a -> AbstractEncoding b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> AbstractEncoding b -> AbstractEncoding a
$c<$ :: forall a b. a -> AbstractEncoding b -> AbstractEncoding a
fmap :: (a -> b) -> AbstractEncoding a -> AbstractEncoding b
$cfmap :: forall a b. (a -> b) -> AbstractEncoding a -> AbstractEncoding b
Functor)
encode :: Encoding -> ByteString -> ByteString
encode :: Encoding -> ByteString -> ByteString
encode Encoding
encoding ByteString
bytes = case Encoding
encoding of
Encoding
EBase16 ->
Base -> ByteString -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base16 ByteString
bytes
Encoding
EBase58 ->
Alphabet -> ByteString -> ByteString
encodeBase58 Alphabet
bitcoinAlphabet ByteString
bytes
EBech32 HumanReadablePart
hrp ->
Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ HumanReadablePart -> DataPart -> Text
Bech32.encodeLenient HumanReadablePart
hrp (DataPart -> Text) -> DataPart -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> DataPart
Bech32.dataPartFromBytes ByteString
bytes
detectEncoding :: String -> Maybe (AbstractEncoding ())
detectEncoding :: String -> Maybe (AbstractEncoding ())
detectEncoding String
str = Maybe (AbstractEncoding ())
forall a. Maybe (AbstractEncoding a)
isBase16 Maybe (AbstractEncoding ())
-> Maybe (AbstractEncoding ()) -> Maybe (AbstractEncoding ())
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (AbstractEncoding ())
isBech32 Maybe (AbstractEncoding ())
-> Maybe (AbstractEncoding ()) -> Maybe (AbstractEncoding ())
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (AbstractEncoding ())
forall a. Maybe (AbstractEncoding a)
isBase58
where
isBase16 :: Maybe (AbstractEncoding a)
isBase16 = do
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"0123456789abcdef") (Char -> Char
toLower (Char -> Char) -> ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
str))
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int -> Bool
forall a. Integral a => a -> Bool
even (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str))
AbstractEncoding a -> Maybe (AbstractEncoding a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure AbstractEncoding a
forall a. AbstractEncoding a
EBase16
isBech32 :: Maybe (AbstractEncoding ())
isBech32 = do
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
humanpart))
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Char
c -> Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
33 Bool -> Bool -> Bool
&& Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
126) String
humanpart)
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
datapart Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
6)
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
Bech32.dataCharList) String
datapart)
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isUpper String
alpha Bool -> Bool -> Bool
|| (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isLower String
alpha)
AbstractEncoding () -> Maybe (AbstractEncoding ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> AbstractEncoding ()
forall a. a -> AbstractEncoding a
EBech32 ())
where
datapart :: String
datapart = ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'1') ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. [a] -> [a]
reverse ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String
str
humanpart :: String
humanpart = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'1') String
str
alpha :: String
alpha = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
isLetter String
str
isBase58 :: Maybe (AbstractEncoding a)
isBase58 = do
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Text -> String
T.unpack (ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Alphabet -> ByteString
unAlphabet Alphabet
bitcoinAlphabet)) String
str)
AbstractEncoding a -> Maybe (AbstractEncoding a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure AbstractEncoding a
forall a. AbstractEncoding a
EBase58
fromBase16 :: ByteString -> Either String ByteString
fromBase16 :: ByteString -> Either String ByteString
fromBase16 = Base -> ByteString -> Either String ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
Base16
fromBech32
:: ([Int] -> String -> String)
-> ByteString
-> Either String (HumanReadablePart, ByteString)
fromBech32 :: ([Int] -> ShowS)
-> ByteString -> Either String (HumanReadablePart, ByteString)
fromBech32 [Int] -> ShowS
markCharsRedAtIndices ByteString
raw = (Maybe DecodingError -> String)
-> Either (Maybe DecodingError) (HumanReadablePart, ByteString)
-> Either String (HumanReadablePart, ByteString)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left Maybe DecodingError -> String
errToString (Either (Maybe DecodingError) (HumanReadablePart, ByteString)
-> Either String (HumanReadablePart, ByteString))
-> Either (Maybe DecodingError) (HumanReadablePart, ByteString)
-> Either String (HumanReadablePart, ByteString)
forall a b. (a -> b) -> a -> b
$ do
(HumanReadablePart
hrp, DataPart
dp) <- (DecodingError -> Maybe DecodingError)
-> Either DecodingError (HumanReadablePart, DataPart)
-> Either (Maybe DecodingError) (HumanReadablePart, DataPart)
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left DecodingError -> Maybe DecodingError
forall a. a -> Maybe a
Just (Either DecodingError (HumanReadablePart, DataPart)
-> Either (Maybe DecodingError) (HumanReadablePart, DataPart))
-> Either DecodingError (HumanReadablePart, DataPart)
-> Either (Maybe DecodingError) (HumanReadablePart, DataPart)
forall a b. (a -> b) -> a -> b
$ Text -> Either DecodingError (HumanReadablePart, DataPart)
Bech32.decodeLenient (Text -> Either DecodingError (HumanReadablePart, DataPart))
-> Text -> Either DecodingError (HumanReadablePart, DataPart)
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
raw
Either (Maybe DecodingError) (HumanReadablePart, ByteString)
-> (ByteString
-> Either (Maybe DecodingError) (HumanReadablePart, ByteString))
-> Maybe ByteString
-> Either (Maybe DecodingError) (HumanReadablePart, ByteString)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe DecodingError
-> Either (Maybe DecodingError) (HumanReadablePart, ByteString)
forall a b. a -> Either a b
Left Maybe DecodingError
forall a. Maybe a
Nothing) ((HumanReadablePart, ByteString)
-> Either (Maybe DecodingError) (HumanReadablePart, ByteString)
forall a b. b -> Either a b
Right ((HumanReadablePart, ByteString)
-> Either (Maybe DecodingError) (HumanReadablePart, ByteString))
-> (ByteString -> (HumanReadablePart, ByteString))
-> ByteString
-> Either (Maybe DecodingError) (HumanReadablePart, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HumanReadablePart
hrp,)) (Maybe ByteString
-> Either (Maybe DecodingError) (HumanReadablePart, ByteString))
-> Maybe ByteString
-> Either (Maybe DecodingError) (HumanReadablePart, ByteString)
forall a b. (a -> b) -> a -> b
$ DataPart -> Maybe ByteString
Bech32.dataPartToBytes DataPart
dp
where
unCharPos :: CharPosition -> Int
unCharPos (Bech32.CharPosition Int
x) = Int
x
invalidCharsMsg :: String
invalidCharsMsg = String
"Invalid character(s) in string"
errToString :: Maybe DecodingError -> String
errToString = (String
"Bech32 error: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ShowS
-> (Maybe DecodingError -> String) -> Maybe DecodingError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
Just DecodingError
Bech32.StringToDecodeTooLong ->
String
"string is too long"
Just DecodingError
Bech32.StringToDecodeTooShort ->
String
"string is too short"
Just DecodingError
Bech32.StringToDecodeHasMixedCase ->
String
"string has mixed case"
Just DecodingError
Bech32.StringToDecodeMissingSeparatorChar ->
String
"string has no separator char"
Just (Bech32.StringToDecodeContainsInvalidChars []) ->
String
invalidCharsMsg
Just (Bech32.StringToDecodeContainsInvalidChars [CharPosition]
ixs) ->
String
invalidCharsMsg String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Int] -> ShowS
markCharsRedAtIndices
((CharPosition -> Int) -> [CharPosition] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map CharPosition -> Int
unCharPos [CharPosition]
ixs)
(Text -> String
T.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8 (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString
raw)
Maybe DecodingError
Nothing ->
String
"invalid data-part; these bytes ain't uint8."
fromBase58 :: ByteString -> Either String ByteString
fromBase58 :: ByteString -> Either String ByteString
fromBase58 ByteString
raw = Either String ByteString
-> (ByteString -> Either String ByteString)
-> Maybe ByteString
-> Either String ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String ByteString
forall a b. a -> Either a b
Left String
"Invalid Base58-encoded string.") ByteString -> Either String ByteString
forall a b. b -> Either a b
Right (Maybe ByteString -> Either String ByteString)
-> Maybe ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ do
Alphabet -> ByteString -> Maybe ByteString
decodeBase58 Alphabet
bitcoinAlphabet ByteString
raw