Use a richer error return type for decode.

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -58,20 +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
-    ( eitherToMaybe )
+    ( maybeToEither )
 import Data.Foldable
     ( foldl' )
 import Data.Functor.Identity
     ( Identity, runIdentity )
 import Data.Ix
     ( Ix (..) )
+import Data.Maybe
+    ( isJust )
 import Data.Word
     ( Word8 )
 
@@ -141,18 +146,59 @@ encode hrp@(HumanReadablePart hrpBytes) payload = do
 data EncodingError = EncodedStringTooLong
     deriving (Eq, Show)
 
-decode :: ByteString -> Maybe (HumanReadablePart, ByteString)
+decode :: ByteString -> Either DecodingError (HumanReadablePart, ByteString)
 decode bech32 = do
-    guard $ BS.length bech32 <= encodedStringMaxLength
-    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 >>= eitherToMaybe . 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
@@ -305,3 +351,11 @@ toBase256 dat =
 
 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,12 +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
@@ -50,15 +52,15 @@ 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
@@ -67,7 +69,7 @@ spec = do
 
     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
@@ -88,7 +90,7 @@ spec = do
     describe "Roundtrip (encode . decode)" $ do
         it "Can perform roundtrip for valid data" $ property $ \(hrp, bytes) ->
             (eitherToMaybe (Bech32.encode hrp bytes)
-                >>= Bech32.decode) === Just (hrp, bytes)
+                >>= eitherToMaybe . Bech32.decode) === Just (hrp, bytes)
 
     describe "Roundtrip (toBase256 . toBase32)" $ do
         it "Can perform roundtrip base conversion" $ property $ \ws ->