diff options
author | Sam T <pxqr.sta@gmail.com> | 2013-09-26 20:58:11 +0400 |
---|---|---|
committer | Sam T <pxqr.sta@gmail.com> | 2013-09-26 20:58:11 +0400 |
commit | 4756424235c5222a832e1967d54c5ddb369f6fbf (patch) | |
tree | e5683c8d3cf0fbdb04cea29d38ead37aa97a2b8f /src |
Initial commit
Diffstat (limited to 'src')
-rw-r--r-- | src/Data/ByteString/Base32.hi | bin | 0 -> 1805 bytes | |||
-rw-r--r-- | src/Data/ByteString/Base32.hs | 269 | ||||
-rw-r--r-- | src/Data/ByteString/Base32.o | bin | 0 -> 55200 bytes |
3 files changed, 269 insertions, 0 deletions
diff --git a/src/Data/ByteString/Base32.hi b/src/Data/ByteString/Base32.hi new file mode 100644 index 0000000..ce22b69 --- /dev/null +++ b/src/Data/ByteString/Base32.hi | |||
Binary files differ | |||
diff --git a/src/Data/ByteString/Base32.hs b/src/Data/ByteString/Base32.hs new file mode 100644 index 0000000..96bb893 --- /dev/null +++ b/src/Data/ByteString/Base32.hs | |||
@@ -0,0 +1,269 @@ | |||
1 | -- | | ||
2 | -- Copyright : (c) Sam Truzjan 2013 | ||
3 | -- License : BSD3 | ||
4 | -- Maintainer : pxqr.sta@gmail.com | ||
5 | -- Stability : stable | ||
6 | -- Portability : portable | ||
7 | -- | ||
8 | -- Efficient encoding and decoding of base32 encoded bytestring | ||
9 | -- according to RFC 4648. <http://tools.ietf.org/html/rfc4648> | ||
10 | -- | ||
11 | -- This module recommended to be imported as | ||
12 | -- @import Data.ByteString.Base32 as Base32@ to avoid name clashes | ||
13 | -- with @Data.Binary@ or @Data.ByteString.Base64@ modules. | ||
14 | -- | ||
15 | {-# LANGUAGE BangPatterns #-} | ||
16 | module Data.ByteString.Base32 | ||
17 | ( encode | ||
18 | , decode | ||
19 | , decodeLenient | ||
20 | ) where | ||
21 | |||
22 | import Data.Bits.Extras | ||
23 | import Data.ByteString as BS | ||
24 | import Data.ByteString.Internal as BS | ||
25 | import Data.Word | ||
26 | import Foreign hiding (unsafePerformIO) | ||
27 | import System.IO.Unsafe (unsafePerformIO) | ||
28 | import System.Endian | ||
29 | |||
30 | |||
31 | {----------------------------------------------------------------------- | ||
32 | -- Utils | ||
33 | -----------------------------------------------------------------------} | ||
34 | |||
35 | type 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 | -- | ||
41 | toBE64' :: Word64 -> Word64 | ||
42 | toBE64' = if getSystemEndianness == BigEndian then id else byteSwap | ||
43 | {-# INLINE toBE64' #-} | ||
44 | |||
45 | toBE32' :: Word32 -> Word32 | ||
46 | toBE32' = if getSystemEndianness == BigEndian then id else byteSwap | ||
47 | {-# INLINE toBE32' #-} | ||
48 | |||
49 | fromBE32' :: Word32 -> Word32 | ||
50 | fromBE32' = toBE32' | ||
51 | {-# INLINE fromBE32' #-} | ||
52 | |||
53 | -- n = 2 ^ d | ||
54 | padCeilN :: Int -> Int -> Int | ||
55 | padCeilN !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 | |||
65 | type EncTable = Ptr Word8 | ||
66 | |||
67 | unpack5 :: EncTable -> ByteString -> ByteString | ||
68 | unpack5 !tbl bs @ (PS fptr off sz) = | ||
69 | unsafePerformIO $ do | ||
70 | let unpackedSize = dstSize $ BS.length bs | ||
71 | BS.create unpackedSize $ \ dst -> do | ||
72 | withForeignPtr fptr $ \ ptr -> do | ||
73 | dst_end <- bigStep dst (advancePtr ptr off) sz | ||
74 | _ <- fillPadding dst_end (unpackedSize - (dst_end `minusPtr` dst)) | ||
75 | return () | ||
76 | where | ||
77 | dstSize x = padCeilN 8 (d + if m == 0 then 0 else 1) | ||
78 | where (d, m) = (x * 8) `quotRem` 5 | ||
79 | |||
80 | fillPadding dst s = memset dst (c2w '=') (fromIntegral s) | ||
81 | |||
82 | bigStep !dst !src !s | ||
83 | | s >= 5 = do | ||
84 | unpack5_40 dst src | ||
85 | bigStep (dst `advancePtr` 8) (src `advancePtr` 5) (s - 5) | ||
86 | | otherwise = smallStep dst src s 0 0 | ||
87 | |||
88 | unpack5_40 !dst !src = do | ||
89 | w32he <- peek (castPtr src) :: IO Word32 | ||
90 | let w32 = toBE32' w32he | ||
91 | fill8_32 0 (w32 `unsafeShiftR` 27) | ||
92 | fill8_32 1 (w32 `unsafeShiftR` 22) | ||
93 | fill8_32 2 (w32 `unsafeShiftR` 17) | ||
94 | fill8_32 3 (w32 `unsafeShiftR` 12) | ||
95 | fill8_32 4 (w32 `unsafeShiftR` 7) | ||
96 | fill8_32 5 (w32 `unsafeShiftR` 2) | ||
97 | |||
98 | w8 <- peekElemOff src 4 | ||
99 | fill8_32 6 ( (w32 `unsafeShiftL` 3) | ||
100 | .|. fromIntegral (w8 `unsafeShiftR` 5)) | ||
101 | fill8_32 7 (fromIntegral w8) | ||
102 | where | ||
103 | fill8_32 :: Int -> Word32 -> IO () | ||
104 | fill8_32 !i !w32 = do | ||
105 | w8 <- peekByteOff tbl (fromIntegral w32 .&. 0x1f) | ||
106 | poke (dst `advancePtr` i) w8 | ||
107 | |||
108 | smallStep !dst !src !s !unused !un_cnt | ||
109 | | un_cnt >= 5 = do | ||
110 | let ix = unused `unsafeShiftR` 3 | ||
111 | peekByteOff tbl (fromIntegral ix) >>= poke dst | ||
112 | smallStep (advancePtr dst 1) | ||
113 | src s | ||
114 | (unused `unsafeShiftL` 5) | ||
115 | (un_cnt - 5) | ||
116 | |||
117 | | s == 0 = do | ||
118 | if un_cnt == 0 | ||
119 | then return dst | ||
120 | else do | ||
121 | let ix = unused `unsafeShiftR` 3 | ||
122 | peekByteOff tbl (fromIntegral ix) >>= poke dst | ||
123 | return (dst `advancePtr` 1) | ||
124 | |||
125 | | otherwise = do | ||
126 | w8 <- peek src | ||
127 | let usd_cnt = 5 - un_cnt | ||
128 | let bits = w8 .&. complement (bit (8 - usd_cnt) - 1) | ||
129 | let ix = (unused .|. bits `shiftR` un_cnt) `unsafeShiftR` 3 | ||
130 | peekByteOff tbl (fromIntegral ix) >>= poke dst | ||
131 | smallStep (advancePtr dst 1) | ||
132 | (advancePtr src 1) (pred s) | ||
133 | (w8 `shiftL` usd_cnt) (8 - usd_cnt) | ||
134 | |||
135 | encW5 :: Word5 -> Word8 | ||
136 | encW5 !x | ||
137 | | x <= 25 = 65 + x | ||
138 | | otherwise = 24 + x | ||
139 | {-# INLINE encW5 #-} | ||
140 | |||
141 | encTable :: ForeignPtr Word8 | ||
142 | PS encTable _ _ = BS.pack $ fmap encW5 [0..31] | ||
143 | |||
144 | -- | Encode a bytestring into base32 form. | ||
145 | encode :: ByteString -> ByteString | ||
146 | encode bs = | ||
147 | unsafePerformIO $ do | ||
148 | withForeignPtr encTable $ \ptr -> do | ||
149 | return $ unpack5 ptr bs | ||
150 | |||
151 | {----------------------------------------------------------------------- | ||
152 | -- Decoding | ||
153 | -----------------------------------------------------------------------} | ||
154 | |||
155 | type DecTable = Ptr Word5 | ||
156 | |||
157 | pack5 :: DecTable -> (Word8 -> Word5) -> ByteString -> ByteString | ||
158 | pack5 !tbl !f bs @ (PS fptr off sz) = | ||
159 | unsafePerformIO $ do | ||
160 | let packedSize = dstSize $ BS.length bs | ||
161 | BS.createAndTrim packedSize $ \ dst -> do | ||
162 | withForeignPtr fptr $ \ ptr -> do | ||
163 | dst_end <- bigStep dst (advancePtr ptr off) sz | ||
164 | return (dst_end `minusPtr` dst) | ||
165 | where | ||
166 | lookupTable :: Word8 -> Word5 | ||
167 | lookupTable ix | ||
168 | | x == invIx = error $ "base32: decode: invalid character" ++ show ix | ||
169 | | otherwise = x | ||
170 | where x = inlinePerformIO (peekByteOff tbl (fromIntegral ix)) | ||
171 | {-# INLINE lookupTable #-} | ||
172 | |||
173 | dstSize x = d + if m == 0 then 0 else 1 | ||
174 | where (d, m) = (x * 5) `quotRem` 8 | ||
175 | |||
176 | bigStep !dst !src !s | ||
177 | | s > 8 = do | ||
178 | pack5_40 dst src | ||
179 | bigStep (dst `advancePtr` 5) (src `advancePtr` 8) (s - 8) | ||
180 | | otherwise = smallStep dst src s (0 :: Word64) 0 | ||
181 | |||
182 | pack5_40 !dst !src = do | ||
183 | w64he <- peek (castPtr src) :: IO Word64 | ||
184 | let w64 = toBE64' w64he | ||
185 | let w40 = putAsW5 (w64 `unsafeShiftR` 00) $ | ||
186 | putAsW5 (w64 `unsafeShiftR` 08) $ | ||
187 | putAsW5 (w64 `unsafeShiftR` 16) $ | ||
188 | putAsW5 (w64 `unsafeShiftR` 24) $ | ||
189 | putAsW5 (w64 `unsafeShiftR` 32) $ | ||
190 | putAsW5 (w64 `unsafeShiftR` 40) $ | ||
191 | putAsW5 (w64 `unsafeShiftR` 48) $ | ||
192 | putAsW5 (w64 `unsafeShiftR` 56) 0 | ||
193 | pokeW40 w40 | ||
194 | where | ||
195 | putAsW5 :: Word64 -> Word64 -> Word64 | ||
196 | {-# INLINE putAsW5 #-} | ||
197 | putAsW5 !w8 !acc = (acc `unsafeShiftL` 5) | ||
198 | .|. fromIntegral (lookupTable (fromIntegral w8)) | ||
199 | |||
200 | pokeW40 :: Word64 -> IO () | ||
201 | {-# INLINE pokeW40 #-} | ||
202 | pokeW40 !w40 = do | ||
203 | poke dst (fromIntegral (w40 `unsafeShiftR` 32) :: Word8) | ||
204 | poke (castPtr (dst `advancePtr` 1)) | ||
205 | (fromBE32' (fromIntegral w40 :: Word32)) | ||
206 | |||
207 | smallStep !dst !src !s !unused !un_cnt | ||
208 | | un_cnt >= 8 = do | ||
209 | poke dst $ fromIntegral (unused `unsafeShiftR` (un_cnt - 8)) | ||
210 | smallStep (dst `advancePtr` 1) src s unused (un_cnt - 8) | ||
211 | |||
212 | | s == 0 = return dst | ||
213 | | otherwise = do | ||
214 | w8 <- peek src | ||
215 | if w2c w8 == '=' | ||
216 | then if (bit un_cnt - 1) .&. unused == 0 | ||
217 | then smallStep dst src 0 0 0 | ||
218 | else smallStep dst src 0 (unused `shiftL` (8 - un_cnt)) 8 | ||
219 | else smallStep dst | ||
220 | (src `advancePtr` 1) (pred s) | ||
221 | ((unused `unsafeShiftL` 5) .|. fromIntegral (f w8)) | ||
222 | (un_cnt + 5) | ||
223 | |||
224 | invIx :: Word5 | ||
225 | invIx = 255 | ||
226 | |||
227 | decW5 :: Word8 -> Word5 | ||
228 | decW5 !x | ||
229 | | x < 50 {- c2w '2' -} = invIx | ||
230 | | x <= 55 {- c2w '7' -} = x - 24 | ||
231 | | x < 65 {- c2w 'A' -} = invIx | ||
232 | | x <= 90 {- c2w 'Z' -} = x - 65 | ||
233 | | otherwise = invIx | ||
234 | {-# INLINE decW5 #-} | ||
235 | |||
236 | decTable :: ForeignPtr Word8 | ||
237 | PS decTable _ _ = BS.pack $ fmap decW5 [minBound .. maxBound] | ||
238 | |||
239 | -- | Decode a base32 encoded bytestring. | ||
240 | decode :: ByteString -> ByteString | ||
241 | decode bs = | ||
242 | unsafePerformIO $ do | ||
243 | withForeignPtr decTable $ \tbl -> | ||
244 | return $ pack5 tbl decW5 bs | ||
245 | |||
246 | {----------------------------------------------------------------------- | ||
247 | -- Lenient Decoding | ||
248 | -----------------------------------------------------------------------} | ||
249 | |||
250 | decCharLenient :: Char -> Word5 | ||
251 | decCharLenient x | ||
252 | | x < '2' = err | ||
253 | | x <= '7' = 26 + fromIntegral (fromEnum x) - fromIntegral (fromEnum '2') | ||
254 | | x < 'A' = err | ||
255 | | x <= 'Z' = fromIntegral (fromEnum x) - fromIntegral (fromEnum 'A') | ||
256 | | x < 'a' = err | ||
257 | | x <= 'z' = fromIntegral (fromEnum x) - fromIntegral (fromEnum 'a') | ||
258 | | otherwise = err | ||
259 | where | ||
260 | err = error "base32: decodeChar: out of range" | ||
261 | |||
262 | decW5Lenient :: Word8 -> Word5 | ||
263 | decW5Lenient = decCharLenient . w2c | ||
264 | {-# INLINE decW5Lenient #-} | ||
265 | |||
266 | -- TODO padding leniency | ||
267 | -- | Case-insensitive counterpart of the 'decode'. | ||
268 | decodeLenient :: ByteString -> ByteString | ||
269 | decodeLenient = id -- pack5 nullPtr decW5Lenient \ No newline at end of file | ||
diff --git a/src/Data/ByteString/Base32.o b/src/Data/ByteString/Base32.o new file mode 100644 index 0000000..eadc3fe --- /dev/null +++ b/src/Data/ByteString/Base32.o | |||
Binary files differ | |||