never executed always true always false

    1 {-# LANGUAGE DeriveFunctor #-}
    2 {-# LANGUAGE FlexibleContexts #-}
    3 {-# LANGUAGE LambdaCase #-}
    4 {-# LANGUAGE TupleSections #-}
    5 
    6 {-# OPTIONS_HADDOCK hide #-}
    7 
    8 module Codec.Binary.Encoding
    9     ( -- * Types
   10       AbstractEncoding (..)
   11     , Encoding
   12 
   13       -- * Encode
   14     , encode
   15 
   16       -- * Decode
   17     , detectEncoding
   18     , fromBase16
   19     , fromBase64
   20     , fromBase58
   21     , fromBech32
   22     ) where
   23 
   24 import Prelude
   25 
   26 import Codec.Binary.Bech32
   27     ( HumanReadablePart )
   28 import Control.Applicative
   29     ( (<|>) )
   30 import Control.Arrow
   31     ( left )
   32 import Control.Monad
   33     ( guard )
   34 import Data.ByteArray.Encoding
   35     ( Base (..), convertFromBase, convertToBase )
   36 import Data.ByteString
   37     ( ByteString )
   38 import Data.ByteString.Base58
   39     ( bitcoinAlphabet, decodeBase58, encodeBase58, unAlphabet )
   40 import Data.Char
   41     ( isLetter, isLower, isUpper, ord, toLower )
   42 
   43 import qualified Codec.Binary.Bech32 as Bech32
   44 import qualified Data.Text as T
   45 import qualified Data.Text.Encoding as T
   46 
   47 
   48 --
   49 -- Encoding
   50 --
   51 
   52 -- | A concrete 'Encoding' algebraic data-type.
   53 type Encoding = AbstractEncoding HumanReadablePart
   54 
   55 -- | An abstract 'Encoding' to make it easy to map over the bech32 component.
   56 -- Typically used as 'AbstractEncoding HumanReadablePart'.
   57 --
   58 -- > λ> let xpubHRP = [humanReadablePart|xpub|]
   59 -- > λ> let xprvHRP = [humanReadablePart|xprv|]
   60 -- >
   61 -- > λ> fmap (const xpubHRP) (EBech32 xprvHRP)
   62 -- > EBech32 (HumanReadablePart "xpub")
   63 --
   64 data AbstractEncoding a
   65     = EBase16
   66     | EBase58
   67     | EBech32 a
   68     deriving (Eq, Show, Functor)
   69 
   70 --
   71 -- Encode
   72 --
   73 
   74 
   75 -- | Encode a 'ByteString' with the given encoding.
   76 --
   77 -- @since 2.0.0
   78 encode :: Encoding -> ByteString -> ByteString
   79 encode encoding bytes = case encoding of
   80     EBase16 ->
   81         convertToBase Base16 bytes
   82     EBase58 ->
   83         encodeBase58 bitcoinAlphabet bytes
   84     EBech32 hrp ->
   85         T.encodeUtf8 $ Bech32.encodeLenient hrp $ Bech32.dataPartFromBytes bytes
   86 
   87 --
   88 -- Decode
   89 --
   90 
   91 -- | Try detecting the encoding of a given 'String'
   92 --
   93 -- @since 2.0.0
   94 detectEncoding :: String -> Maybe (AbstractEncoding ())
   95 detectEncoding str = isBase16 <|> isBech32  <|> isBase58
   96   where
   97     isBase16 = do
   98         guard (all ((`elem` "0123456789abcdef") . toLower) str)
   99         guard (even (length str))
  100         pure EBase16
  101 
  102     isBech32 = do
  103         guard (not (null humanpart))
  104         guard (all (\c -> ord c >= 33 && ord c <= 126) humanpart)
  105         guard (length datapart >= 6)
  106         guard (all (`elem` Bech32.dataCharList) datapart)
  107         guard (all isUpper alpha || all isLower alpha)
  108         pure (EBech32 ())
  109       where
  110         datapart  = reverse . takeWhile (/= '1') . reverse $ str
  111         humanpart = takeWhile (/= '1') str
  112         alpha = filter isLetter str
  113 
  114     isBase58 = do
  115         guard (all (`elem` T.unpack (T.decodeUtf8 $ unAlphabet bitcoinAlphabet)) str)
  116         pure EBase58
  117 
  118 -- | Try decoding a base16-encoded 'ByteString'
  119 --
  120 -- @since 2.0.0
  121 fromBase16 :: ByteString -> Either String ByteString
  122 fromBase16 = convertFromBase Base16
  123 
  124 -- | Try decoding a base64-encoded 'ByteString'
  125 --
  126 -- @since 3.13.0
  127 fromBase64 :: ByteString -> Either String ByteString
  128 fromBase64 = convertFromBase Base64
  129 
  130 -- | Try decoding a bech32-encoded 'ByteString'
  131 --
  132 -- @since 2.0.0
  133 fromBech32
  134     :: ([Int] -> String -> String)
  135     -> ByteString
  136     -> Either String (HumanReadablePart, ByteString)
  137 fromBech32 markCharsRedAtIndices raw = left errToString $ do
  138     (hrp, dp) <- left Just $ Bech32.decodeLenient $ T.decodeUtf8 raw
  139     maybe (Left Nothing) (Right . (hrp,)) $ Bech32.dataPartToBytes dp
  140   where
  141     unCharPos (Bech32.CharPosition x) = x
  142     invalidCharsMsg = "Invalid character(s) in string"
  143     errToString = ("Bech32 error: " <>) . \case
  144         Just Bech32.StringToDecodeTooLong ->
  145             "string is too long"
  146         Just Bech32.StringToDecodeTooShort ->
  147             "string is too short"
  148         Just Bech32.StringToDecodeHasMixedCase ->
  149             "string has mixed case"
  150         Just Bech32.StringToDecodeMissingSeparatorChar ->
  151             "string has no separator char"
  152         Just (Bech32.StringToDecodeContainsInvalidChars []) ->
  153             invalidCharsMsg
  154         Just (Bech32.StringToDecodeContainsInvalidChars ixs) ->
  155             invalidCharsMsg <> ":\n" <> markCharsRedAtIndices
  156                 (map unCharPos ixs)
  157                 (T.unpack . T.decodeUtf8 $ raw)
  158         Nothing ->
  159             "invalid data-part; these bytes ain't uint8."
  160 
  161 fromBase58 :: ByteString -> Either String ByteString
  162 fromBase58 raw = maybe (Left "Invalid Base58-encoded string.") Right $ do
  163     decodeBase58 bitcoinAlphabet raw