ref/haskell: refactor error handling for bech32Decode

.gitignore

@@ -0,0 +1,2 @@
+# Haskell stack build artifacts
+.stack-work/

ref/haskell/src/Codec/Binary/Bech32.hs

@@ -1,5 +1,7 @@
 module Codec.Binary.Bech32
-  ( bech32Encode
+  ( DecodeError(..)
+
+  , bech32Encode
   , bech32Decode
   , toBase32
   , toBase256
@@ -10,15 +12,15 @@ module Codec.Binary.Bech32
   , fromWord5
   ) where
 
-import Control.Monad (guard)
+import Control.Monad (guard, when)
 import qualified Data.Array as Arr
-import Data.Bits (Bits, unsafeShiftL, unsafeShiftR, (.&.), (.|.), xor, testBit)
+import Data.Bits (Bits, testBit, unsafeShiftL, unsafeShiftR, xor, (.&.), (.|.))
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as BSC
 import Data.Char (toLower, toUpper)
 import Data.Foldable (foldl')
 import Data.Functor.Identity (Identity, runIdentity)
-import Data.Ix (Ix(..))
+import Data.Ix (Ix (..))
 import Data.Word (Word8)
 
 type HRP = BS.ByteString
@@ -29,7 +31,7 @@ type Data = [Word8]
 (.<<.) = unsafeShiftL
 
 newtype Word5 = UnsafeWord5 Word8
-              deriving (Eq, Ord)
+              deriving (Eq, Ord, Show)
 
 instance Ix Word5 where
   range (UnsafeWord5 m, UnsafeWord5 n) = map UnsafeWord5 $ range (m, n)
@@ -79,32 +81,43 @@ bech32VerifyChecksum hrp dat = bech32Polymod (bech32HRPExpand hrp ++ dat) == 1
 
 bech32Encode :: HRP -> [Word5] -> Maybe BS.ByteString
 bech32Encode hrp dat = do
-    guard $ checkHRP hrp
+    guard $ validHRP hrp
     let dat' = dat ++ bech32CreateChecksum hrp dat
         rest = map (charset Arr.!) dat'
         result = BSC.concat [BSC.map toLower hrp, BSC.pack "1", BSC.pack rest]
     guard $ BS.length result <= 90
     return result
 
-checkHRP :: BS.ByteString -> Bool
-checkHRP hrp = not (BS.null hrp) && BS.all (\char -> char >= 33 && char <= 126) hrp
+validHRP :: BS.ByteString -> Bool
+validHRP hrp = not (BS.null hrp) && BS.all (\char -> char >= 33 && char <= 126) hrp
+
+data DecodeError =
+    Bech32StringLengthExceeded
+  | CaseInconsistency
+  | TooShortDataPart
+  | InvalidHRP
+  | ChecksumVerificationFail
+  | InvalidCharsetMap
+  deriving (Show, Eq)
 
-bech32Decode :: BS.ByteString -> Maybe (HRP, [Word5])
+bech32Decode :: BS.ByteString -> Either DecodeError (HRP, [Word5])
 bech32Decode bech32 = do
-    guard $ BS.length bech32 <= 90
-    guard $ BSC.map toUpper bech32 == bech32 || BSC.map toLower bech32 == bech32
+    when (BS.length bech32 > 90) (Left Bech32StringLengthExceeded)
+    when (not $ validCase bech32) (Left CaseInconsistency)
     let (hrp, dat) = BSC.breakEnd (== '1') $ BSC.map toLower bech32
-    guard $ BS.length dat >= 6
-    hrp' <- BSC.stripSuffix (BSC.pack "1") hrp
-    guard $ checkHRP hrp'
-    dat' <- mapM charsetMap $ BSC.unpack dat
-    guard $ bech32VerifyChecksum hrp' dat'
+    when (BS.length dat < 6) (Left TooShortDataPart)
+    hrp' <- maybe (Left InvalidHRP) Right $ BSC.stripSuffix (BSC.pack "1") hrp
+    when (not $ validHRP hrp') (Left InvalidHRP)
+    dat' <- maybe (Left InvalidCharsetMap) Right $ mapM charsetMap $ BSC.unpack dat
+    when (not $ bech32VerifyChecksum hrp' dat') (Left ChecksumVerificationFail)
     return (hrp', take (BS.length dat - 6) dat')
+      where
+        validCase b32 = BSC.map toUpper b32 == b32 || BSC.map toLower b32 == b32
 
 type Pad f = Int -> Int -> Word -> [[Word]] -> f [[Word]]
 
 yesPadding :: Pad Identity
-yesPadding _ 0 _ result = return result
+yesPadding _ 0 _ result        = return result
 yesPadding _ _ padValue result = return $ [padValue] : result
 {-# INLINE yesPadding #-}
 
@@ -146,7 +159,7 @@ segwitCheck witver witprog =
 
 segwitDecode :: HRP -> BS.ByteString -> Maybe (Word8, Data)
 segwitDecode hrp addr = do
-    (hrp', dat) <- bech32Decode addr
+    (hrp', dat) <- rightToMaybe $ bech32Decode addr
     guard $ (hrp == hrp') && not (null dat)
     let (UnsafeWord5 witver : datBase32) = dat
     decoded <- toBase256 datBase32
@@ -157,3 +170,6 @@ segwitEncode :: HRP -> Word8 -> Data -> Maybe BS.ByteString
 segwitEncode hrp witver witprog = do
     guard $ segwitCheck witver witprog
     bech32Encode hrp $ UnsafeWord5 witver : toBase32 witprog
+
+rightToMaybe :: Either l r -> Maybe r
+rightToMaybe = either (const Nothing) Just

ref/haskell/test/Spec.hs

@@ -1,12 +1,14 @@
+import Codec.Binary.Bech32 (DecodeError (..), bech32Decode, bech32Encode, segwitDecode,
+                            segwitEncode, word5)
 import Control.Monad (forM_)
 import Data.Bits (xor)
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Base16 as B16
 import qualified Data.ByteString.Char8 as BSC
 import Data.Char (toLower)
-import Data.Maybe (isNothing, isJust)
+import Data.Either (isLeft)
+import Data.Maybe (isJust, isNothing)
 import Data.Word (Word8)
-import Codec.Binary.Bech32 (bech32Encode, bech32Decode, segwitEncode, segwitDecode, word5)
 import Test.Tasty
 import Test.Tasty.HUnit
 
@@ -75,19 +77,19 @@ tests :: TestTree
 tests = testGroup "Tests"
     [ testCase "Checksums" $ forM_ validChecksums $ \checksum -> do
           case bech32Decode checksum of
-            Nothing -> assertFailure (show checksum)
-            Just (resultHRP, resultData) -> do
+            Left err -> assertFailure (show checksum ++ show err)
+            Right (resultHRP, resultData) -> do
                 -- test that a corrupted checksum fails decoding.
                 let (hrp, rest) = BSC.breakEnd (== '1') checksum
                     Just (first, rest') = BS.uncons rest
                     checksumCorrupted = (hrp `BS.snoc` (first `xor` 1)) `BS.append` rest'
-                assertBool (show checksum ++ " corrupted") $ isNothing (bech32Decode checksumCorrupted)
+                assertBool (show checksum ++ " corrupted") $ isLeft (bech32Decode checksumCorrupted)
                 -- test that re-encoding the decoded checksum results in the same checksum.
                 let checksumEncoded = bech32Encode resultHRP resultData
                     expectedChecksum = Just $ BSC.map toLower checksum
                 assertEqual (show checksum ++ " re-encode") expectedChecksum checksumEncoded
     , testCase "Invalid checksums" $ forM_ invalidChecksums $
-          \checksum -> assertBool (show checksum) (isNothing $ bech32Decode checksum)
+          \checksum -> assertBool (show checksum) (isLeft $ bech32Decode checksum)
     , testCase "Addresses" $ forM_ validAddresses $ \(address, hexscript) -> do
           let address' = BSC.map toLower address
               hrp = BSC.take 2 address'
@@ -111,8 +113,12 @@ tests = testGroup "Tests"
           assertBool "segwit prog len version != 0" $ isNothing $
               segwitEncode (BSC.pack "bc") 1 (replicate 41 1)
           assertBool "empty HRP encode" $ isNothing $ bech32Encode (BSC.pack "") []
-          assertBool "empty HRP decode" $ isNothing $ bech32Decode (BSC.pack "10a06t8")
+          assertBool "empty HRP decode" $ isError InvalidHRP $ bech32Decode (BSC.pack "10a06t8")
           assertEqual "hrp lowercased"
               (Just $ BSC.pack "hrp1g9xj8m")
               (bech32Encode (BSC.pack "HRP") [])
     ]
+
+isError :: DecodeError -> Either DecodeError a -> Bool
+isError e' (Left e) = e == e'
+isError _ _         = False