Encoding.hs

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

{-# OPTIONS_HADDOCK hide #-}

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

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

      -- * Encode
    , encode

      -- * Decode
    , detectEncoding
    , fromBase16
    , fromBase64
    , 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 (Eq, Show, Functor)

--
-- Encode
--


-- | Encode a 'ByteString' with the given encoding.
--
-- @since 2.0.0
encode :: Encoding -> ByteString -> ByteString
encode encoding bytes = case encoding of
    EBase16 ->
        convertToBase Base16 bytes
    EBase58 ->
        encodeBase58 bitcoinAlphabet bytes
    EBech32 hrp ->
        T.encodeUtf8 $ Bech32.encodeLenient hrp $ Bech32.dataPartFromBytes bytes

--
-- Decode
--

-- | Try detecting the encoding of a given 'String'
--
-- @since 2.0.0
detectEncoding :: String -> Maybe (AbstractEncoding ())
detectEncoding str = isBase16 <|> isBech32  <|> isBase58
  where
    isBase16 = do
        guard (all ((`elem` "0123456789abcdef") . toLower) str)
        guard (even (length str))
        pure EBase16

    isBech32 = do
        guard (not (null humanpart))
        guard (all (\c -> ord c >= 33 && ord c <= 126) humanpart)
        guard (length datapart >= 6)
        guard (all (`elem` Bech32.dataCharList) datapart)
        guard (all isUpper alpha || all isLower alpha)
        pure (EBech32 ())
      where
        datapart  = reverse . takeWhile (/= '1') . reverse $ str
        humanpart = takeWhile (/= '1') str
        alpha = filter isLetter str

    isBase58 = do
        guard (all (`elem` T.unpack (T.decodeUtf8 $ unAlphabet bitcoinAlphabet)) str)
        pure EBase58

-- | Try decoding a base16-encoded 'ByteString'
--
-- @since 2.0.0
fromBase16 :: ByteString -> Either String ByteString
fromBase16 = convertFromBase Base16

-- | Try decoding a base64-encoded 'ByteString'
--
-- @since 3.13.0
fromBase64 :: ByteString -> Either String ByteString
fromBase64 = convertFromBase Base64

-- | Try decoding a bech32-encoded 'ByteString'
--
-- @since 2.0.0
fromBech32
    :: ([Int] -> String -> String)
    -> ByteString
    -> Either String (HumanReadablePart, ByteString)
fromBech32 markCharsRedAtIndices raw = left errToString $ do
    (hrp, dp) <- left Just $ Bech32.decodeLenient $ T.decodeUtf8 raw
    maybe (Left Nothing) (Right . (hrp,)) $ Bech32.dataPartToBytes dp
  where
    unCharPos (Bech32.CharPosition x) = x
    invalidCharsMsg = "Invalid character(s) in string"
    errToString = ("Bech32 error: " <>) . \case
        Just Bech32.StringToDecodeTooLong ->
            "string is too long"
        Just Bech32.StringToDecodeTooShort ->
            "string is too short"
        Just Bech32.StringToDecodeHasMixedCase ->
            "string has mixed case"
        Just Bech32.StringToDecodeMissingSeparatorChar ->
            "string has no separator char"
        Just (Bech32.StringToDecodeContainsInvalidChars []) ->
            invalidCharsMsg
        Just (Bech32.StringToDecodeContainsInvalidChars ixs) ->
            invalidCharsMsg <> ":\n" <> markCharsRedAtIndices
                (map unCharPos ixs)
                (T.unpack . T.decodeUtf8 $ raw)
        Nothing ->
            "invalid data-part; these bytes ain't uint8."

fromBase58 :: ByteString -> Either String ByteString
fromBase58 raw = maybe (Left "Invalid Base58-encoded string.") Right $ do
    decodeBase58 bitcoinAlphabet raw