Add stubs for lenient decoding

3 files changed, 48 insertions, 20 deletions

diff --git a/src/Data/ByteString/Base32.hs b/src/Data/ByteString/Base32.hs
index e9ac3ee..0568c54 100644
--- a/src/Data/ByteString/Base32.hs
+++ b/src/Data/ByteString/Base32.hs
@@ -21,7 +21,6 @@ module Data.ByteString.Base32
        ) where
 
 import Data.ByteString as BS
-import Data.ByteString.Internal as BS
 import Data.ByteString.Base32.Internal
 import Data.List as L
 
@@ -60,23 +59,6 @@ decTable = BS.pack $ L.map decW5 [minBound .. maxBound]
 decode :: Base32 -> ByteString
 decode = pack5 decTable
 
-decCharLenient :: Char -> Word5
-decCharLenient x
-  | x <  '2'  = err
-  | x <= '7'  = 26 + fromIntegral (fromEnum x) - fromIntegral (fromEnum '2')
-  | x <  'A'  = err
-  | x <= 'Z'  = fromIntegral (fromEnum x) - fromIntegral (fromEnum 'A')
-  | x <  'a'  = err
-  | x <= 'z'  = fromIntegral (fromEnum x) - fromIntegral (fromEnum 'a')
-  | otherwise = err
-  where
-    err = error "base32: decodeChar: out of range"
-
-decW5Lenient :: Word8 -> Word5
-decW5Lenient = decCharLenient . w2c
-{-# INLINE decW5Lenient #-}
-
--- TODO padding leniency
 -- | Case-insensitive counterpart of the 'decode'.
 decodeLenient :: Base32 -> ByteString
-decodeLenient = id -- pack5 nullPtr decW5Lenient
\ No newline at end of file
+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 ce7682b..db5fe1b 100644
--- a/src/Data/ByteString/Base32/Hex.hs
+++ b/src/Data/ByteString/Base32/Hex.hs
@@ -58,4 +58,4 @@ decode :: Base32Hex -> ByteString
 decode = pack5 decTable
 
 decodeLenient :: Base32Hex -> ByteString
-decodeLenient = id
\ No newline at end of file
+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 c34e80c..725be37 100644
--- a/src/Data/ByteString/Base32/Internal.hs
+++ b/src/Data/ByteString/Base32/Internal.hs
@@ -18,6 +18,7 @@ module Data.ByteString.Base32.Internal
 
        , DecTable
        , pack5
+       , pack5Lenient
        , invIx
        ) where
 
@@ -228,3 +229,48 @@ pack5 (PS fptr off len) bs
     unsafePerformIO $ do
       withForeignPtr fptr $ \ptr ->
         return $ pack5Ptr (ptr `advancePtr` off) bs
+
+{-----------------------------------------------------------------------
+-- Lenient Decoding
+-----------------------------------------------------------------------}
+
+pack5PtrLenient :: Ptr Word5 -> ByteString -> ByteString
+pack5PtrLenient !tbl bs @ (PS fptr off sz) =
+  unsafePerformIO $ do
+    BS.createAndTrim (sz * 2) $ \ dst -> do
+        withForeignPtr fptr $ \ ptr -> do
+          dst_end <- smallStep dst (advancePtr ptr off) sz 0 0
+          return (dst_end `minusPtr` dst)
+  where
+    lookupTable :: Word8 -> Word5
+    lookupTable ix = inlinePerformIO (peekByteOff tbl (fromIntegral ix))
+    {-# INLINE lookupTable #-}
+
+    smallStep :: Ptr Word8 -> Ptr Word5 -> Int -> Word -> Int
+              -> IO (Ptr Word5)
+    smallStep !dst !src !s !unused !un_cnt
+      | un_cnt >= 8 = do
+        poke dst $ fromIntegral (unused `unsafeShiftR` (un_cnt - 8))
+        smallStep (dst `advancePtr` 1) src s unused (un_cnt - 8)
+
+      |   s == 0  = return dst
+      | otherwise = do
+        w8 <- peek src
+        if w2c w8 == '='
+           then if (bit un_cnt - 1) .&. unused == 0
+                then smallStep dst src 0 0 0
+                else smallStep dst src 0 (unused `shiftL` (8 - un_cnt)) 8
+           else smallStep dst
+                  (src `advancePtr` 1) (pred s)
+                  ((unused `unsafeShiftL` 5)
+                   .|. fromIntegral (lookupTable (fromIntegral w8)))
+                  (un_cnt + 5)
+
+pack5Lenient :: DecTable -> ByteString -> ByteString
+pack5Lenient (PS fptr off len) bs
+  | len /= 256
+  = error $ "base32: pack5: invalid lookup table size " ++ show len
+  |  otherwise  =
+    unsafePerformIO $ do
+      withForeignPtr fptr $ \ptr ->
+        return $ pack5Ptr (ptr `advancePtr` off) bs