Skip to content

ref/haskell: refactor error handling for bech32Decode #41

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
manifoldhiker wants to merge 4 commits into
base: master
Choose a base branch
from
Open

ref/haskell: refactor error handling for bech32Decode #41

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
fd6a144
Refactor `Maybe` to `Either DecodeError`
manifoldhiker Mar 15, 2018
1327235
Add .gitignore
manifoldhiker Mar 15, 2018
9861966
[LTB-7] Refactor
manifoldhiker Mar 19, 2018
ef375b8
[LTB-7] Refactor `Maybe` to `Either EncodeError`
manifoldhiker Mar 20, 2018
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 2 additions & 0 deletions .gitignore
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,2 @@
# Haskell stack build artifacts
.stack-work/
71 changes: 51 additions & 20 deletions ref/haskell/src/Codec/Binary/Bech32.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,5 +1,9 @@
module Codec.Binary.Bech32
( bech32Encode
(
DecodeError(..)
, EncodeError(..)

, bech32Encode
, bech32Decode
, toBase32
, toBase256
Expand All @@ -12,13 +16,13 @@ module Codec.Binary.Bech32

import Control.Monad (guard)
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
Expand All @@ -29,7 +33,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)
Expand Down Expand Up @@ -77,34 +81,51 @@ bech32CreateChecksum hrp dat = [word5 (polymod .>>. i) | i <- [25,20..0]]
bech32VerifyChecksum :: HRP -> [Word5] -> Bool
bech32VerifyChecksum hrp dat = bech32Polymod (bech32HRPExpand hrp ++ dat) == 1

bech32Encode :: HRP -> [Word5] -> Maybe BS.ByteString
data EncodeError =
ResultStringLengthExceeded
| InvalidHumanReadablePart
deriving (Show, Eq)

bech32Encode :: HRP -> [Word5] -> Either EncodeError BS.ByteString
bech32Encode hrp dat = do
guard $ checkHRP hrp
verify (validHRP hrp) InvalidHumanReadablePart
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
verify (BS.length result <= 90) ResultStringLengthExceeded
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

bech32Decode :: BS.ByteString -> Maybe (HRP, [Word5])
data DecodeError =
Bech32StringLengthExceeded
| CaseInconsistency
| TooShortDataPart
| InvalidHRP
| ChecksumVerificationFail
| InvalidCharsetMap
deriving (Show, Eq)

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
verify (BS.length bech32 <= 90) Bech32StringLengthExceeded
verify (validCase bech32) 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'
verify (BS.length dat >= 6) TooShortDataPart
hrp' <- maybeToRight InvalidHRP $ BSC.stripSuffix (BSC.pack "1") hrp
verify (validHRP hrp') InvalidHRP
dat' <- maybeToRight InvalidCharsetMap $ mapM charsetMap $ BSC.unpack dat
verify (bech32VerifyChecksum hrp' dat') ChecksumVerificationFail
return (hrp', take (BS.length dat - 6) dat')
where
validCase :: BS.ByteString -> Bool
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 #-}

Expand Down Expand Up @@ -146,7 +167,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
Expand All @@ -156,4 +177,14 @@ segwitDecode hrp addr = do
segwitEncode :: HRP -> Word8 -> Data -> Maybe BS.ByteString
segwitEncode hrp witver witprog = do
guard $ segwitCheck witver witprog
bech32Encode hrp $ UnsafeWord5 witver : toBase32 witprog
rightToMaybe $ bech32Encode hrp $ UnsafeWord5 witver : toBase32 witprog
Copy link
Contributor

@roconnor-blockstream roconnor-blockstream Nov 9, 2021

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think foo . bar $ x is preferred to foo $ bar $ x generally speaking. But this isn't show-stopping.


rightToMaybe :: Either l r -> Maybe r
rightToMaybe = either (const Nothing) Just

maybeToRight :: l -> Maybe r -> Either l r
maybeToRight l = maybe (Left l) Right

verify :: Bool -> a -> Either a ()
Copy link
Contributor

@roconnor-blockstream roconnor-blockstream Nov 9, 2021

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I feel that this would work better with the argument order reversed. Then it would be similar to maybeToRight.

verify True _ = Right ()
verify False v = Left v
28 changes: 17 additions & 11 deletions ref/haskell/test/Spec.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,12 +1,14 @@
import Codec.Binary.Bech32 (DecodeError (..), EncodeError (..), 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

Expand Down Expand Up @@ -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)
Copy link
Contributor

@roconnor-blockstream roconnor-blockstream Nov 9, 2021

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

something like intercalate ", " [show checksum, show err] would stop the assert failure message from being smooshed together.

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)
Copy link
Contributor

@roconnor-blockstream roconnor-blockstream Nov 9, 2021

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Shouldn't this be isError ChecksumVerificationFail instead of isLeft?

Copy link
Contributor

@roconnor-blockstream roconnor-blockstream Nov 9, 2021

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Okay, the choice of corruption sometimes produces invalid characters.

-- test that re-encoding the decoded checksum results in the same checksum.
let checksumEncoded = bech32Encode resultHRP resultData
expectedChecksum = Just $ BSC.map toLower checksum
expectedChecksum = Right $ 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)
Copy link
Contributor

@roconnor-blockstream roconnor-blockstream Nov 9, 2021

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Same here: Shouldn't this be isError ChecksumVerificationFail instead of isLeft?

Copy link
Contributor

@roconnor-blockstream roconnor-blockstream Nov 9, 2021

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Okay I see these fail for various different reasons.

, testCase "Addresses" $ forM_ validAddresses $ \(address, hexscript) -> do
let address' = BSC.map toLower address
hrp = BSC.take 2 address'
Expand All @@ -100,7 +102,7 @@ tests = testGroup "Tests"
assertBool (show address) (isNothing $ segwitDecode (BSC.pack "bc") address)
assertBool (show address) (isNothing $ segwitDecode (BSC.pack "tb") address)
, testCase "More Encoding/Decoding Cases" $ do
assertBool "length > 90" $ isNothing $
assertBool "length > 90" $ isError ResultStringLengthExceeded $
bech32Encode (BSC.pack "bc") (replicate 82 (word5 (1::Word8)))
assertBool "segwit version bounds" $ isNothing $
segwitEncode (BSC.pack "bc") 17 []
Expand All @@ -110,9 +112,13 @@ tests = testGroup "Tests"
segwitEncode (BSC.pack "bc") 1 (replicate 30 1)
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 encode" $ isError InvalidHumanReadablePart $ bech32Encode (BSC.pack "") []
assertBool "empty HRP decode" $ isError InvalidHRP $ bech32Decode (BSC.pack "10a06t8")
assertEqual "hrp lowercased"
(Just $ BSC.pack "hrp1g9xj8m")
(Right $ BSC.pack "hrp1g9xj8m")
(bech32Encode (BSC.pack "HRP") [])
]

isError :: Eq a => a -> Either a b -> Bool
isError e' (Left e) = e == e'
isError _ _ = False