Merge pull request #271 from input-output-hk/jonathanknowles/bech32-e…

…rrors

Use richer errors for Bech32 encoder and decoder

lib/bech32/bech32.cabal

@@ -32,6 +32,7 @@ library
       array
     , base
     , bytestring
+    , extra
   hs-source-dirs:
       src
   exposed-modules:
@@ -56,6 +57,7 @@ test-suite bech32-test
       array
     , base
     , bech32
+    , extra
     , hspec
     , bytestring
     , QuickCheck

lib/bech32/src/Codec/Binary/Bech32/Internal.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -19,16 +20,22 @@ module Codec.Binary.Bech32.Internal
     (
       -- * Encoding & Decoding
       encode
+    , EncodingError (..)
     , decode
     , checksumLength
-    , maxEncodedStringLength
+    , separatorLength
+    , encodedStringMaxLength
+    , encodedStringMinLength
 
       -- * Human-Readable Parts
     , HumanReadablePart
+    , HumanReadablePartError (..)
     , mkHumanReadablePart
     , humanReadablePartToBytes
     , humanReadableCharsetMinBound
     , humanReadableCharsetMaxBound
+    , humanReadablePartMinLength
+    , humanReadablePartMaxLength
 
       -- * Bit Manipulation
     , convertBits
@@ -52,18 +59,24 @@ import Control.Monad
     ( guard )
 import Data.Array
     ( Array )
+import Data.Bifunctor
+    ( first )
 import Data.Bits
     ( Bits, testBit, unsafeShiftL, unsafeShiftR, xor, (.&.), (.|.) )
 import Data.ByteString
     ( ByteString )
 import Data.Char
-    ( toLower, toUpper )
+    ( ord, toLower, toUpper )
+import Data.Either.Extra
+    ( maybeToEither )
 import Data.Foldable
     ( foldl' )
 import Data.Functor.Identity
     ( Identity, runIdentity )
 import Data.Ix
     ( Ix (..) )
+import Data.Maybe
+    ( isJust )
 import Data.Word
     ( Word8 )
 
@@ -78,15 +91,30 @@ import qualified Data.ByteString.Char8 as B8
 newtype HumanReadablePart = HumanReadablePart ByteString
     deriving (Show, Eq)
 
-mkHumanReadablePart :: ByteString -> Maybe HumanReadablePart
-mkHumanReadablePart hrp = do
-    guard $ not (BS.null hrp) && BS.all valid hrp
-    return (HumanReadablePart hrp)
+mkHumanReadablePart
+    :: ByteString -> Either HumanReadablePartError HumanReadablePart
+mkHumanReadablePart hrp
+    | BS.length hrp < humanReadablePartMinLength =
+        Left HumanReadablePartTooShort
+    | BS.length hrp > humanReadablePartMaxLength =
+        Left HumanReadablePartTooLong
+    | BS.length invalidPortion > 0 =
+        Left $ HumanReadablePartContainsInvalidChar $ CharPosition $
+            BS.length validPortion
+    | otherwise =
+        Right $ HumanReadablePart hrp
   where
+    (validPortion, invalidPortion) = BS.break (not . valid) hrp
     valid c =
         c >= humanReadableCharsetMinBound &&
         c <= humanReadableCharsetMaxBound
 
+data HumanReadablePartError
+    = HumanReadablePartTooShort
+    | HumanReadablePartTooLong
+    | HumanReadablePartContainsInvalidChar CharPosition
+    deriving (Eq, Show)
+
 humanReadableCharsetMinBound :: Word8
 humanReadableCharsetMinBound = 33
 
@@ -96,43 +124,105 @@ humanReadableCharsetMaxBound = 126
 humanReadablePartToBytes :: HumanReadablePart -> ByteString
 humanReadablePartToBytes (HumanReadablePart bytes) = bytes
 
+humanReadablePartMinLength :: Int
+humanReadablePartMinLength = 1
+
+humanReadablePartMaxLength :: Int
+humanReadablePartMaxLength = 83
+
 {-------------------------------------------------------------------------------
                             Encoding & Decoding
 -------------------------------------------------------------------------------}
 
-encode :: HumanReadablePart -> ByteString -> Maybe ByteString
+encode :: HumanReadablePart -> ByteString -> Either EncodingError ByteString
 encode hrp@(HumanReadablePart hrpBytes) payload = do
     let payload5 = toBase32 (BS.unpack payload)
     let payload' = payload5 ++ bech32CreateChecksum hrp payload5
     let rest = map (charset Arr.!) payload'
     let output = B8.map toLower hrpBytes <> B8.pack "1" <> B8.pack rest
-    guard (BS.length output <= maxEncodedStringLength)
+    guardE (BS.length output <= encodedStringMaxLength) EncodedStringTooLong
     return output
 
-decode :: ByteString -> Maybe (HumanReadablePart, ByteString)
+data EncodingError = EncodedStringTooLong
+    deriving (Eq, Show)
+
+decode :: ByteString -> Either DecodingError (HumanReadablePart, ByteString)
 decode bech32 = do
-    guard $ BS.length bech32 <= maxEncodedStringLength
-    guard $ B8.map toUpper bech32 == bech32 || B8.map toLower bech32 == bech32
-    let (hrp, dat) = B8.breakEnd (== '1') $ B8.map toLower bech32
-    guard $ BS.length dat >= checksumLength
-    hrp' <- B8.stripSuffix (B8.pack "1") hrp >>= mkHumanReadablePart
-    dat' <- mapM charsetMap $ B8.unpack dat
-    guard $ bech32VerifyChecksum hrp' dat'
-    result <- toBase256 (take (BS.length dat - checksumLength) dat')
-    return (hrp', BS.pack result)
+    (hrpUnparsed , dcpUnparsed) <-
+        maybeToEither StringToDecodeMissingSeparatorChar $
+            splitAtLastOccurrence separatorChar $ B8.map toLower bech32
+    hrp <- first hrpError $ mkHumanReadablePart hrpUnparsed
+    dcp <- first
+        (\(CharPosition p) -> StringToDecodeContainsInvalidChar $
+            CharPosition $ p + BS.length hrpUnparsed + separatorLength)
+        (parseDataPart $ B8.unpack dcpUnparsed)
+    guardE (BS.length bech32 <= encodedStringMaxLength)
+        StringToDecodeTooLong
+    guardE (BS.length bech32 >= encodedStringMinLength)
+        StringToDecodeTooShort
+    guardE (B8.map toUpper bech32 == bech32 || B8.map toLower bech32 == bech32)
+        StringToDecodeHasMixedCase
+    guardE (length dcp >= checksumLength)
+        StringToDecodeTooShort
+    guardE (bech32VerifyChecksum hrp dcp)
+        StringToDecodeContainsInvalidChars
+    dp <- maybeToEither StringToDecodeContainsInvalidChars $
+        toBase256 (take (length dcp - checksumLength) dcp)
+    return (hrp, BS.pack dp)
+  where
+    parseDataPart :: String -> Either CharPosition [Word5]
+    parseDataPart dpUnparsed =
+        case mapM charsetMap dpUnparsed of
+            Just dp -> pure dp
+            Nothing -> Left $ CharPosition $ length $
+                takeWhile isJust (charsetMap <$> dpUnparsed)
+    hrpError = \case
+        HumanReadablePartTooLong ->
+            StringToDecodeContainsInvalidChar $ CharPosition
+                humanReadablePartMaxLength
+        HumanReadablePartTooShort ->
+            StringToDecodeContainsInvalidChar $ CharPosition $
+                humanReadablePartMinLength - 1
+        HumanReadablePartContainsInvalidChar p ->
+            StringToDecodeContainsInvalidChar p
+
+data DecodingError
+    = StringToDecodeTooLong
+    | StringToDecodeTooShort
+    | StringToDecodeHasMixedCase
+    | StringToDecodeMissingSeparatorChar
+    | StringToDecodeContainsInvalidChar CharPosition
+    | StringToDecodeContainsInvalidChars
+    deriving (Eq, Show)
+
+-- | The separator character. This character appears immediately after the
+-- human-readable part and before the data part.
+separatorChar :: Word8
+separatorChar = fromIntegral $ ord '1'
 
 -- | The length of the checksum portion of an encoded string, in bytes.
 checksumLength :: Int
 checksumLength = 6
 
+-- | The length of the separator portion of an encoded string, in bytes.
+separatorLength :: Int
+separatorLength = 1
+
 -- | The maximum length of an encoded string, in bytes. This length includes the
 --   human-readable part, the separator character, the encoded data portion,
 --   and the checksum.
-maxEncodedStringLength :: Int
-maxEncodedStringLength = 90
+encodedStringMaxLength :: Int
+encodedStringMaxLength = 90
+
+-- | The minimum length of an encoded string, in bytes. This length includes the
+--   human-readable part, the separator character, the encoded data portion,
+--   and the checksum.
+encodedStringMinLength :: Int
+encodedStringMinLength =
+    humanReadablePartMinLength + separatorLength + checksumLength
 
 {-------------------------------------------------------------------------------
-                          Character Set Manipulation
+                            Character Manipulation
 -------------------------------------------------------------------------------}
 
 charset :: Array Word5 Char
@@ -153,6 +243,10 @@ charsetMap c
         Arr.//
         (map swap (Arr.assocs charset))
 
+-- | The zero-based position of a character in a string, counting from the left.
+newtype CharPosition = CharPosition Int
+    deriving (Eq, Show)
+
 {-------------------------------------------------------------------------------
                               Bit Manipulation
 -------------------------------------------------------------------------------}
@@ -251,3 +345,17 @@ toBase256 :: [Word5] -> Maybe [Word8]
 toBase256 dat =
     map fromIntegral <$> convertBits (map fromWord5 dat) 5 8 noPadding
 
+{-------------------------------------------------------------------------------
+                                   Utilities
+-------------------------------------------------------------------------------}
+
+guardE :: Bool -> e -> Either e ()
+guardE b e = if b then Right () else Left e
+
+-- | Splits the given 'ByteString' into a prefix and a suffix using the last
+-- occurrence of the specified separator character as a splitting point.
+-- Evaluates to 'Nothing' if the 'ByteString` does not contain the separator
+-- character.
+splitAtLastOccurrence :: Word8 -> ByteString -> Maybe (ByteString, ByteString)
+splitAtLastOccurrence w s =
+    (\i -> (BS.take i s, BS.drop (i + 1) s)) <$> BS.elemIndexEnd w s

lib/bech32/test/Codec/Binary/Bech32Spec.hs

@@ -19,10 +19,14 @@ import Data.ByteString
     ( ByteString )
 import Data.Char
     ( toLower, toUpper )
+import Data.Either
+    ( isLeft )
+import Data.Either.Extra
+    ( eitherToMaybe )
 import Data.Functor.Identity
     ( runIdentity )
 import Data.Maybe
-    ( catMaybes, isJust, isNothing )
+    ( catMaybes, isJust )
 import Data.Word
     ( Word8 )
 import Test.Hspec
@@ -48,45 +52,45 @@ spec :: Spec
 spec = do
     describe "Valid Checksums" $ forM_ validChecksums $ \checksum ->
         it (B8.unpack checksum) $ case Bech32.decode checksum of
-            Nothing ->
+            Left _ ->
                 expectationFailure (show checksum)
-            Just (resultHRP, resultData) -> do
+            Right (resultHRP, resultData) -> do
                 -- test that a corrupted checksum fails decoding.
                 let (hrp, rest) = B8.breakEnd (== '1') checksum
                 let Just (first, rest') = BS.uncons rest
                 let checksumCorrupted =
                         (hrp `BS.snoc` (first `xor` 1)) `BS.append` rest'
-                (Bech32.decode checksumCorrupted) `shouldSatisfy` isNothing
+                (Bech32.decode checksumCorrupted) `shouldSatisfy` isLeft
                 -- test that re-encoding the decoded checksum results in
                 -- the same checksum.
                 let checksumEncoded = Bech32.encode resultHRP resultData
-                let expectedChecksum = Just $ B8.map toLower checksum
+                let expectedChecksum = Right $ B8.map toLower checksum
                 checksumEncoded `shouldBe` expectedChecksum
 
     describe "Invalid Checksums" $ forM_ invalidChecksums $ \checksum ->
         it (B8.unpack checksum) $
-            Bech32.decode checksum `shouldSatisfy` isNothing
+            Bech32.decode checksum `shouldSatisfy` isLeft
 
     describe "More Encoding/Decoding Cases" $ do
         it "length > maximum" $ do
             let hrpUnpacked = "ca"
             let hrpLength = length hrpUnpacked
-            let (Just hrp) = mkHumanReadablePart (B8.pack hrpUnpacked)
-            let separatorLength = 1
+            let (Right hrp) = mkHumanReadablePart (B8.pack hrpUnpacked)
             let maxDataLength =
-                    Bech32.maxEncodedStringLength
-                    - Bech32.checksumLength - separatorLength - hrpLength
+                    Bech32.encodedStringMaxLength
+                    - Bech32.checksumLength - Bech32.separatorLength - hrpLength
             Bech32.encode hrp (BS.pack (replicate (maxDataLength + 1) 1))
-                `shouldSatisfy` isNothing
+                `shouldBe` Left Bech32.EncodedStringTooLong
 
         it "hrp lowercased" $ do
-            let (Just hrp) = mkHumanReadablePart (B8.pack "HRP")
+            let (Right hrp) = mkHumanReadablePart (B8.pack "HRP")
             Bech32.encode hrp mempty
-                `shouldBe` Just (B8.pack "hrp1g9xj8m")
+                `shouldBe` Right (B8.pack "hrp1g9xj8m")
 
     describe "Roundtrip (encode . decode)" $ do
         it "Can perform roundtrip for valid data" $ property $ \(hrp, bytes) ->
-            (Bech32.encode hrp bytes >>= Bech32.decode) === Just (hrp, bytes)
+            (eitherToMaybe (Bech32.encode hrp bytes)
+                >>= eitherToMaybe . Bech32.decode) === Just (hrp, bytes)
 
     describe "Roundtrip (toBase256 . toBase32)" $ do
         it "Can perform roundtrip base conversion" $ property $ \ws ->
@@ -164,15 +168,15 @@ invalidChecksums = map B8.pack
     ]
 
 instance Arbitrary HumanReadablePart where
-    shrink hrp = catMaybes
-        (mkHumanReadablePart <$> shrink (humanReadablePartToBytes hrp))
+    shrink hrp = catMaybes $ eitherToMaybe .
+        mkHumanReadablePart <$> shrink (humanReadablePartToBytes hrp)
     arbitrary = do
         let range =
                 ( Bech32.humanReadableCharsetMinBound
                 , Bech32.humanReadableCharsetMaxBound )
         bytes <-
             choose (1, 10) >>= \n -> vectorOf n (choose range)
-        let (Just hrp) = mkHumanReadablePart (B8.map toLower $ BS.pack bytes)
+        let (Right hrp) = mkHumanReadablePart (B8.map toLower $ BS.pack bytes)
         return hrp
 
 instance Arbitrary ByteString where