{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}

{-# OPTIONS_HADDOCK hide #-}

module Codec.Binary.Encoding
    ( -- * Types
      AbstractEncoding (..)
    , Encoding

      -- * Encode
    , encode

      -- * Decode
    , 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


--
-- Encoding
--

-- | A concrete 'Encoding' algebraic data-type.
type Encoding = AbstractEncoding HumanReadablePart

-- | An abstract 'Encoding' to make it easy to map over the bech32 component.
-- Typically used as 'AbstractEncoding HumanReadablePart'.
--
-- > λ> let xpubHRP = [humanReadablePart|xpub|]
-- > λ> let xprvHRP = [humanReadablePart|xprv|]
-- >
-- > λ> fmap (const xpubHRP) (EBech32 xprvHRP)
-- > EBech32 (HumanReadablePart "xpub")
--
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
--


-- | Encode a 'ByteString' with the given encoding.
--
-- @since 2.0.0
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

--
-- Decode
--

-- | Try detecting the encoding of a given 'String'
--
-- @since 2.0.0
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

-- | Try decoding a base16-encoded 'ByteString'
--
-- @since 2.0.0
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

-- | Try decoding a bech32-encoded 'ByteString'
--
-- @since 2.0.0
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