summaryrefslogtreecommitdiff
path: root/src/Data/ByteString/Base32.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Data/ByteString/Base32.hs')
-rw-r--r--src/Data/ByteString/Base32.hs210
1 files changed, 1 insertions, 209 deletions
diff --git a/src/Data/ByteString/Base32.hs b/src/Data/ByteString/Base32.hs
index ca377e2..704aac6 100644
--- a/src/Data/ByteString/Base32.hs
+++ b/src/Data/ByteString/Base32.hs
@@ -19,127 +19,9 @@ module Data.ByteString.Base32
19 , decodeLenient 19 , decodeLenient
20 ) where 20 ) where
21 21
22import Data.Bits.Extras
23import Data.ByteString as BS 22import Data.ByteString as BS
24import Data.ByteString.Internal as BS 23import Data.ByteString.Internal as BS
25import Data.Word 24import Data.ByteString.Base32.Internal
26import Foreign hiding (unsafePerformIO)
27import System.IO.Unsafe (unsafePerformIO)
28import System.Endian
29
30
31{-----------------------------------------------------------------------
32-- Utils
33-----------------------------------------------------------------------}
34
35type Word5 = Word8
36
37-- System.Endian.toBE32 is slower because toBE32 implemented using
38-- cbits shuffle functions while toBE32' implemented used gcc
39-- intrinsics
40--
41toBE64' :: Word64 -> Word64
42toBE64' = if getSystemEndianness == BigEndian then id else byteSwap
43{-# INLINE toBE64' #-}
44
45toBE32' :: Word32 -> Word32
46toBE32' = if getSystemEndianness == BigEndian then id else byteSwap
47{-# INLINE toBE32' #-}
48
49fromBE32' :: Word32 -> Word32
50fromBE32' = toBE32'
51{-# INLINE fromBE32' #-}
52
53-- n = 2 ^ d
54padCeilN :: Int -> Int -> Int
55padCeilN !n !x
56 | remd == 0 = x
57 | otherwise = (x - remd) + n
58 where mask = n - 1
59 remd = x .&. mask
60
61{-----------------------------------------------------------------------
62-- Encoding
63-----------------------------------------------------------------------}
64
65unpack5Ptr :: Ptr Word8 -> ByteString -> ByteString
66unpack5Ptr !tbl bs @ (PS fptr off sz) =
67 unsafePerformIO $ do
68 let unpackedSize = dstSize $ BS.length bs
69 BS.create unpackedSize $ \ dst -> do
70 withForeignPtr fptr $ \ ptr -> do
71 dst_end <- bigStep dst (advancePtr ptr off) sz
72 _ <- fillPadding dst_end (unpackedSize - (dst_end `minusPtr` dst))
73 return ()
74 where
75 dstSize x = padCeilN 8 (d + if m == 0 then 0 else 1)
76 where (d, m) = (x * 8) `quotRem` 5
77
78 fillPadding dst s = memset dst (c2w '=') (fromIntegral s)
79
80 bigStep !dst !src !s
81 | s >= 5 = do
82 unpack5_40 dst src
83 bigStep (dst `advancePtr` 8) (src `advancePtr` 5) (s - 5)
84 | otherwise = smallStep dst src s 0 0
85
86 unpack5_40 !dst !src = do
87 w32he <- peek (castPtr src) :: IO Word32
88 let w32 = toBE32' w32he
89 fill8_32 0 (w32 `unsafeShiftR` 27)
90 fill8_32 1 (w32 `unsafeShiftR` 22)
91 fill8_32 2 (w32 `unsafeShiftR` 17)
92 fill8_32 3 (w32 `unsafeShiftR` 12)
93 fill8_32 4 (w32 `unsafeShiftR` 7)
94 fill8_32 5 (w32 `unsafeShiftR` 2)
95
96 w8 <- peekElemOff src 4
97 fill8_32 6 ( (w32 `unsafeShiftL` 3)
98 .|. fromIntegral (w8 `unsafeShiftR` 5))
99 fill8_32 7 (fromIntegral w8)
100 where
101 fill8_32 :: Int -> Word32 -> IO ()
102 fill8_32 !i !w32 = do
103 w8 <- peekByteOff tbl (fromIntegral w32 .&. 0x1f)
104 poke (dst `advancePtr` i) w8
105
106 smallStep !dst !src !s !unused !un_cnt
107 | un_cnt >= 5 = do
108 let ix = unused `unsafeShiftR` 3
109 peekByteOff tbl (fromIntegral ix) >>= poke dst
110 smallStep (advancePtr dst 1)
111 src s
112 (unused `unsafeShiftL` 5)
113 (un_cnt - 5)
114
115 | s == 0 = do
116 if un_cnt == 0
117 then return dst
118 else do
119 let ix = unused `unsafeShiftR` 3
120 peekByteOff tbl (fromIntegral ix) >>= poke dst
121 return (dst `advancePtr` 1)
122
123 | otherwise = do
124 w8 <- peek src
125 let usd_cnt = 5 - un_cnt
126 let bits = w8 .&. complement (bit (8 - usd_cnt) - 1)
127 let ix = (unused .|. bits `shiftR` un_cnt) `unsafeShiftR` 3
128 peekByteOff tbl (fromIntegral ix) >>= poke dst
129 smallStep (advancePtr dst 1)
130 (advancePtr src 1) (pred s)
131 (w8 `shiftL` usd_cnt) (8 - usd_cnt)
132
133type EncTable = ByteString
134
135unpack5 :: EncTable -> ByteString -> ByteString
136unpack5 (PS fptr off len) bs
137 | len /= 32
138 = error $ "base32: unpack5: invalid lookup table size " ++ show len
139 | otherwise =
140 unsafePerformIO $ do
141 withForeignPtr fptr $ \ptr -> do
142 return $ unpack5Ptr (ptr `advancePtr` off) bs
143 25
144encW5 :: Word5 -> Word8 26encW5 :: Word5 -> Word8
145encW5 !x 27encW5 !x
@@ -154,92 +36,6 @@ encTable = BS.pack $ fmap encW5 [0..31]
154encode :: ByteString -> ByteString 36encode :: ByteString -> ByteString
155encode = unpack5 encTable 37encode = unpack5 encTable
156 38
157{-----------------------------------------------------------------------
158-- Decoding
159-----------------------------------------------------------------------}
160
161invIx :: Word5
162invIx = 255
163
164pack5Ptr :: Ptr Word5 -> ByteString -> ByteString
165pack5Ptr !tbl bs @ (PS fptr off sz) =
166 unsafePerformIO $ do
167 let packedSize = dstSize $ BS.length bs
168 BS.createAndTrim packedSize $ \ dst -> do
169 withForeignPtr fptr $ \ ptr -> do
170 dst_end <- bigStep dst (advancePtr ptr off) sz
171 return (dst_end `minusPtr` dst)
172 where
173 lookupTable :: Word8 -> Word5
174 lookupTable ix
175 | x == invIx = error $ "base32: decode: invalid character" ++ show ix
176 | otherwise = x
177 where x = inlinePerformIO (peekByteOff tbl (fromIntegral ix))
178 {-# INLINE lookupTable #-}
179
180 dstSize x = d + if m == 0 then 0 else 1
181 where (d, m) = (x * 5) `quotRem` 8
182
183 bigStep !dst !src !s
184 | s > 8 = do
185 pack5_40 dst src
186 bigStep (dst `advancePtr` 5) (src `advancePtr` 8) (s - 8)
187 | otherwise = smallStep dst src s (0 :: Word64) 0
188
189 pack5_40 !dst !src = do
190 w64he <- peek (castPtr src) :: IO Word64
191 let w64 = toBE64' w64he
192 let w40 = putAsW5 (w64 `unsafeShiftR` 00) $
193 putAsW5 (w64 `unsafeShiftR` 08) $
194 putAsW5 (w64 `unsafeShiftR` 16) $
195 putAsW5 (w64 `unsafeShiftR` 24) $
196 putAsW5 (w64 `unsafeShiftR` 32) $
197 putAsW5 (w64 `unsafeShiftR` 40) $
198 putAsW5 (w64 `unsafeShiftR` 48) $
199 putAsW5 (w64 `unsafeShiftR` 56) 0
200 pokeW40 w40
201 where
202 putAsW5 :: Word64 -> Word64 -> Word64
203 {-# INLINE putAsW5 #-}
204 putAsW5 !w8 !acc = (acc `unsafeShiftL` 5)
205 .|. fromIntegral (lookupTable (fromIntegral w8))
206
207 pokeW40 :: Word64 -> IO ()
208 {-# INLINE pokeW40 #-}
209 pokeW40 !w40 = do
210 poke dst (fromIntegral (w40 `unsafeShiftR` 32) :: Word8)
211 poke (castPtr (dst `advancePtr` 1))
212 (fromBE32' (fromIntegral w40 :: Word32))
213
214 smallStep !dst !src !s !unused !un_cnt
215 | un_cnt >= 8 = do
216 poke dst $ fromIntegral (unused `unsafeShiftR` (un_cnt - 8))
217 smallStep (dst `advancePtr` 1) src s unused (un_cnt - 8)
218
219 | s == 0 = return dst
220 | otherwise = do
221 w8 <- peek src
222 if w2c w8 == '='
223 then if (bit un_cnt - 1) .&. unused == 0
224 then smallStep dst src 0 0 0
225 else smallStep dst src 0 (unused `shiftL` (8 - un_cnt)) 8
226 else smallStep dst
227 (src `advancePtr` 1) (pred s)
228 ((unused `unsafeShiftL` 5)
229 .|. fromIntegral (lookupTable (fromIntegral w8)))
230 (un_cnt + 5)
231
232type DecTable = ByteString
233
234pack5 :: DecTable -> ByteString -> ByteString
235pack5 (PS fptr off len) bs
236 | len /= 256
237 = error $ "base32: pack5: invalid lookup table size " ++ show len
238 | otherwise =
239 unsafePerformIO $ do
240 withForeignPtr fptr $ \ptr ->
241 return $ pack5Ptr (ptr `advancePtr` off) bs
242
243decW5 :: Word8 -> Word5 39decW5 :: Word8 -> Word5
244decW5 !x 40decW5 !x
245 | x < 50 {- c2w '2' -} = invIx 41 | x < 50 {- c2w '2' -} = invIx
@@ -258,10 +54,6 @@ decTable = BS.pack $ fmap decW5 [minBound .. maxBound]
258decode :: ByteString -> ByteString 54decode :: ByteString -> ByteString
259decode = pack5 decTable 55decode = pack5 decTable
260 56
261{-----------------------------------------------------------------------
262-- Lenient Decoding
263-----------------------------------------------------------------------}
264
265decCharLenient :: Char -> Word5 57decCharLenient :: Char -> Word5
266decCharLenient x 58decCharLenient x
267 | x < '2' = err 59 | x < '2' = err
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-13 01:01:47 +0000