From 9a2ad80fbf5564295842a0833a7cc4a6f2e73b81 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Fri, 29 Nov 2013 12:06:42 +0400 Subject: Return Either instead of error --- base32-bytestring.cabal | 2 +- src/Data/ByteString/Base32.hs | 4 ++-- src/Data/ByteString/Base32/Hex.hs | 4 ++-- src/Data/ByteString/Base32/Internal.hs | 19 +++++++++++---- tests/Data/ByteString/Base32/HexSpec.hs | 41 +++++++++++++++++---------------- tests/Data/ByteString/Base32Spec.hs | 41 +++++++++++++++++---------------- 6 files changed, 61 insertions(+), 50 deletions(-) diff --git a/base32-bytestring.cabal b/base32-bytestring.cabal index 1925b62..d314bbd 100644 --- a/base32-bytestring.cabal +++ b/base32-bytestring.cabal @@ -46,7 +46,7 @@ library test-suite spec default-language: Haskell2010 - default-extensions: OverloadedStrings + default-extensions: type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: Spec.hs diff --git a/src/Data/ByteString/Base32.hs b/src/Data/ByteString/Base32.hs index efc5951..79939d1 100644 --- a/src/Data/ByteString/Base32.hs +++ b/src/Data/ByteString/Base32.hs @@ -57,10 +57,10 @@ decTable = BS.pack $ L.map decW5 [minBound .. maxBound] -- | Decode a base32 encoded bytestring. This functions is -- case-insensitive and do not require correct padding. -decode :: Base32 -> ByteString +decode :: Base32 -> Either String ByteString decode = pack5 decTable -- | The same as 'decode' but with additional leniency: decodeLenient -- will skip non-alphabet characters. -decodeLenient :: Base32 -> ByteString +decodeLenient :: Base32 -> Either String ByteString decodeLenient = pack5Lenient decTable \ No newline at end of file diff --git a/src/Data/ByteString/Base32/Hex.hs b/src/Data/ByteString/Base32/Hex.hs index c38c2da..d866570 100644 --- a/src/Data/ByteString/Base32/Hex.hs +++ b/src/Data/ByteString/Base32/Hex.hs @@ -55,10 +55,10 @@ decTable = BS.pack $ L.map decW5 [minBound .. maxBound] -- | Decode a base32hex encoded bytestring. This functions is -- case-insensitive and do not requires correct padding. -decode :: Base32Hex -> ByteString +decode :: Base32Hex -> Either String ByteString decode = pack5 decTable -- | The same as 'decode' but with additional leniency: decodeLenient -- will skip non-alphabet characters. -decodeLenient :: Base32Hex -> ByteString +decodeLenient :: Base32Hex -> Either String ByteString decodeLenient = pack5Lenient decTable \ No newline at end of file diff --git a/src/Data/ByteString/Base32/Internal.hs b/src/Data/ByteString/Base32/Internal.hs index 5902f60..78b1146 100644 --- a/src/Data/ByteString/Base32/Internal.hs +++ b/src/Data/ByteString/Base32/Internal.hs @@ -22,6 +22,7 @@ module Data.ByteString.Base32.Internal , invIx ) where +import Control.Exception hiding (mask) import Data.Bits.Extras import Data.ByteString as BS import Data.ByteString.Internal as BS @@ -151,9 +152,17 @@ unpack5 (PS fptr off len) bs invIx :: Word5 invIx = 255 -pack5Ptr :: Ptr Word5 -> ByteString -> ByteString +type Result = Either String + +cleanup :: IO a -> Result a +cleanup io = unsafePerformIO $ + catch (io >>= evaluate >>= return . Right) handler + where + handler (ErrorCall msg) = return (Left msg) + +pack5Ptr :: Ptr Word5 -> ByteString -> Result ByteString pack5Ptr !tbl bs @ (PS fptr off sz) = - unsafePerformIO $ do + cleanup $ do let packedSize = dstSize $ BS.length bs BS.createAndTrim packedSize $ \ dst -> do withForeignPtr fptr $ \ ptr -> do @@ -162,7 +171,7 @@ pack5Ptr !tbl bs @ (PS fptr off sz) = where lookupTable :: Word8 -> Word5 lookupTable ix - | x == invIx = error $ "base32: decode: invalid character" ++ show ix + | x == invIx = error $ show (w2c ix) ++ " is not base32 character" | otherwise = x where x = inlinePerformIO (peekByteOff tbl (fromIntegral ix)) {-# INLINE lookupTable #-} @@ -221,7 +230,7 @@ pack5Ptr !tbl bs @ (PS fptr off sz) = type DecTable = ByteString -pack5 :: DecTable -> ByteString -> ByteString +pack5 :: DecTable -> ByteString -> Result ByteString pack5 (PS fptr off len) bs | len /= 256 = error $ "base32: pack5: invalid lookup table size " ++ show len @@ -238,7 +247,7 @@ isInAlphabet :: Ptr Word5 -> Word8 -> Bool isInAlphabet !tbl !ix = inlinePerformIO (peekByteOff tbl (fromIntegral ix)) /= invIx -pack5Lenient :: DecTable -> ByteString -> ByteString +pack5Lenient :: DecTable -> ByteString -> Either String ByteString pack5Lenient tbl @ (PS fptr _ _) bs = unsafePerformIO $ do withForeignPtr fptr $ \ !tbl_ptr -> do diff --git a/tests/Data/ByteString/Base32/HexSpec.hs b/tests/Data/ByteString/Base32/HexSpec.hs index 2cdadef..7cddb69 100644 --- a/tests/Data/ByteString/Base32/HexSpec.hs +++ b/tests/Data/ByteString/Base32/HexSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS -fno-warn-orphans #-} module Data.ByteString.Base32.HexSpec ( spec ) where @@ -28,19 +29,19 @@ spec = do describe "decode" $ do it "conform rfc examples" $ do - decode "" `shouldBe` "" - decode "CO======" `shouldBe` "f" - decode "CPNG====" `shouldBe` "fo" - decode "CPNMU===" `shouldBe` "foo" - decode "CPNMUOG=" `shouldBe` "foob" - decode "CPNMUOJ1" `shouldBe` "fooba" - decode "CPNMUOJ1E8======" `shouldBe` "foobar" + decode "" `shouldBe` Right "" + decode "CO======" `shouldBe` Right "f" + decode "CPNG====" `shouldBe` Right "fo" + decode "CPNMU===" `shouldBe` Right "foo" + decode "CPNMUOG=" `shouldBe` Right "foob" + decode "CPNMUOJ1" `shouldBe` Right "fooba" + decode "CPNMUOJ1E8======" `shouldBe` Right "foobar" it "inverse for encode" $ property $ \bs -> - decode (encode bs) == bs + decode (encode bs) == Right bs it "case insensitive" $ property $ \bs -> - decode (BC.map toLower (encode bs)) == bs + decode (BC.map toLower (encode bs)) == Right bs it "fail gracefully if encoded data contains non alphabet chars" $ do evaluate (decode "#=======") `shouldThrow` anyErrorCall @@ -48,20 +49,20 @@ spec = do describe "decodeLenient" $ do it "conform RFC examples" $ do - decode "" `shouldBe` "" - decode "CO======" `shouldBe` "f" - decode "CPNG====" `shouldBe` "fo" - decode "CPNMU===" `shouldBe` "foo" - decode "CPNMUOG=" `shouldBe` "foob" - decode "CPNMUOJ1" `shouldBe` "fooba" - decode "CPNMUOJ1E8======" `shouldBe` "foobar" + decode "" `shouldBe` Right "" + decode "CO======" `shouldBe` Right "f" + decode "CPNG====" `shouldBe` Right "fo" + decode "CPNMU===" `shouldBe` Right "foo" + decode "CPNMUOG=" `shouldBe` Right "foob" + decode "CPNMUOJ1" `shouldBe` Right "fooba" + decode "CPNMUOJ1E8======" `shouldBe` Right "foobar" it "inverse for encode" $ property $ \bs -> - decodeLenient (encode bs) == bs + decodeLenient (encode bs) == Right bs it "case insensitive" $ property $ \bs -> - decodeLenient (BC.map toLower (encode bs)) == bs + decodeLenient (BC.map toLower (encode bs)) == Right bs it "skip non alphabet chars" $ do - decodeLenient "|" `shouldBe` "" - decodeLenient "C|O" `shouldBe` "f" + decodeLenient "|" `shouldBe` Right "" + decodeLenient "C|O" `shouldBe` Right "f" diff --git a/tests/Data/ByteString/Base32Spec.hs b/tests/Data/ByteString/Base32Spec.hs index 148539a..4cec8f9 100644 --- a/tests/Data/ByteString/Base32Spec.hs +++ b/tests/Data/ByteString/Base32Spec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS -fno-warn-orphans #-} module Data.ByteString.Base32Spec (spec) where @@ -34,19 +35,19 @@ spec = do describe "decode" $ do it "conform RFC examples" $ do - decode "" `shouldBe` "" - decode "MY======" `shouldBe` "f" - decode "MZXQ====" `shouldBe` "fo" - decode "MZXW6===" `shouldBe` "foo" - decode "MZXW6YQ=" `shouldBe` "foob" - decode "MZXW6YTB" `shouldBe` "fooba" - decode "MZXW6YTBOI======" `shouldBe` "foobar" + decode "" `shouldBe` Right "" + decode "MY======" `shouldBe` Right "f" + decode "MZXQ====" `shouldBe` Right "fo" + decode "MZXW6===" `shouldBe` Right "foo" + decode "MZXW6YQ=" `shouldBe` Right "foob" + decode "MZXW6YTB" `shouldBe` Right "fooba" + decode "MZXW6YTBOI======" `shouldBe` Right "foobar" it "inverse for encode" $ property $ \bs -> - decode (encode bs) == bs + decode (encode bs) == Right bs it "case insensitive" $ property $ \bs -> - decode (BC.map toLower (encode bs)) == bs + decode (BC.map toLower (encode bs)) == Right bs it "fail gracefully if encoded data contains non alphabet chars" $ do evaluate (decode "0=======") `shouldThrow` anyErrorCall @@ -54,20 +55,20 @@ spec = do describe "decodeLenient" $ do it "conform RFC examples" $ do - decodeLenient "" `shouldBe` "" - decodeLenient "MY======" `shouldBe` "f" - decodeLenient "MZXQ====" `shouldBe` "fo" - decodeLenient "MZXW6===" `shouldBe` "foo" - decodeLenient "MZXW6YQ=" `shouldBe` "foob" - decodeLenient "MZXW6YTB" `shouldBe` "fooba" - decodeLenient "MZXW6YTBOI======" `shouldBe` "foobar" + decodeLenient "" `shouldBe` Right "" + decodeLenient "MY======" `shouldBe` Right "f" + decodeLenient "MZXQ====" `shouldBe` Right "fo" + decodeLenient "MZXW6===" `shouldBe` Right "foo" + decodeLenient "MZXW6YQ=" `shouldBe` Right "foob" + decodeLenient "MZXW6YTB" `shouldBe` Right "fooba" + decodeLenient "MZXW6YTBOI======" `shouldBe` Right "foobar" it "inverse for encode" $ property $ \bs -> - decodeLenient (encode bs) == bs + decodeLenient (encode bs) == Right bs it "case insensitive" $ property $ \bs -> - decodeLenient (BC.map toLower (encode bs)) == bs + decodeLenient (BC.map toLower (encode bs)) == Right bs it "skip non alphabet chars" $ do - decodeLenient "|" `shouldBe` "" - decodeLenient "M|Y" `shouldBe` "f" + decodeLenient "|" `shouldBe` Right "" + decodeLenient "M|Y" `shouldBe` Right "f" -- cgit v1.2.3