From 9a2ad80fbf5564295842a0833a7cc4a6f2e73b81 Mon Sep 17 00:00:00 2001
From: Sam Truzjan <pxqr.sta@gmail.com>
Date: Fri, 29 Nov 2013 12:06:42 +0400
Subject: Return Either instead of error

---
 src/Data/ByteString/Base32.hs          |  4 ++--
 src/Data/ByteString/Base32/Hex.hs      |  4 ++--
 src/Data/ByteString/Base32/Internal.hs | 19 ++++++++++++++-----
 3 files changed, 18 insertions(+), 9 deletions(-)

(limited to 'src/Data/ByteString')

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
-- 
cgit v1.2.3