diff options
Diffstat (limited to 'src/Codec/Binary/Base32.hs')
-rw-r--r-- | src/Codec/Binary/Base32.hs | 155 |
1 files changed, 155 insertions, 0 deletions
diff --git a/src/Codec/Binary/Base32.hs b/src/Codec/Binary/Base32.hs new file mode 100644 index 0000000..4f88667 --- /dev/null +++ b/src/Codec/Binary/Base32.hs | |||
@@ -0,0 +1,155 @@ | |||
1 | -- | | ||
2 | -- Module : Codec.Binary.Base32 | ||
3 | -- Copyright : (c) 2007 Magnus Therning | ||
4 | -- License : BSD3 | ||
5 | -- | ||
6 | -- Implemented as specified in RFC 4648 | ||
7 | -- (<http://tools.ietf.org/html/rfc4648>). | ||
8 | -- | ||
9 | -- Further documentation and information can be found at | ||
10 | -- <http://www.haskell.org/haskellwiki/Library/Data_encoding>. | ||
11 | module Codec.Binary.Base32 | ||
12 | ( EncIncData(..) | ||
13 | , EncIncRes(..) | ||
14 | , encodeInc | ||
15 | , encode | ||
16 | , DecIncData(..) | ||
17 | , DecIncRes(..) | ||
18 | , decodeInc | ||
19 | , decode | ||
20 | , chop | ||
21 | , unchop | ||
22 | ) where | ||
23 | |||
24 | import Codec.Binary.Util | ||
25 | |||
26 | import Control.Monad | ||
27 | import Data.Array | ||
28 | import Data.Bits | ||
29 | import Data.Maybe | ||
30 | import Data.Word | ||
31 | import qualified Data.Map as M | ||
32 | |||
33 | -- {{{1 enc/dec map | ||
34 | _encMap = | ||
35 | [ (0, 'A'), (1, 'B'), (2, 'C'), (3, 'D'), (4, 'E') | ||
36 | , (5, 'F'), (6, 'G'), (7, 'H'), (8, 'I'), (9, 'J') | ||
37 | , (10, 'K'), (11, 'L'), (12, 'M'), (13, 'N'), (14, 'O') | ||
38 | , (15, 'P'), (16, 'Q'), (17, 'R'), (18, 'S'), (19, 'T') | ||
39 | , (20, 'U'), (21, 'V'), (22, 'W'), (23, 'X'), (24, 'Y') | ||
40 | , (25, 'Z'), (26, '2'), (27, '3'), (28, '4'), (29, '5') | ||
41 | , (30, '6'), (31, '7') ] | ||
42 | |||
43 | -- {{{1 encodeArray | ||
44 | encodeArray :: Array Word8 Char | ||
45 | encodeArray = array (0, 32) _encMap | ||
46 | |||
47 | -- {{{1 decodeMap | ||
48 | decodeMap :: M.Map Char Word8 | ||
49 | decodeMap = M.fromList [(snd i, fst i) | i <- _encMap] | ||
50 | |||
51 | -- {{{1 encode | ||
52 | -- | Incremental encoder function. | ||
53 | encodeInc :: EncIncData -> EncIncRes String | ||
54 | encodeInc e = eI [] e | ||
55 | where | ||
56 | enc5 [o1, o2, o3, o4, o5] = map (encodeArray !) [i1, i2, i3, i4, i5, i6, i7, i8] | ||
57 | where | ||
58 | i1 = o1 `shiftR` 3 | ||
59 | i2 = (o1 `shiftL` 2 .|. o2 `shiftR` 6) .&. 0x1f | ||
60 | i3 = o2 `shiftR` 1 .&. 0x1f | ||
61 | i4 = (o2 `shiftL` 4 .|. o3 `shiftR` 4) .&. 0x1f | ||
62 | i5 = (o3 `shiftL` 1 .|. o4 `shiftR` 7) .&. 0x1f | ||
63 | i6 = o4 `shiftR` 2 .&. 0x1f | ||
64 | i7 = (o4 `shiftL` 3 .|. o5 `shiftR` 5) .&. 0x1f | ||
65 | i8 = o5 .&. 0x1f | ||
66 | |||
67 | eI [] EDone = EFinal [] | ||
68 | eI [o1] EDone = EFinal (take 2 cs ++ "======") | ||
69 | where | ||
70 | cs = enc5 [o1, 0, 0, 0, 0] | ||
71 | eI [o1, o2] EDone = EFinal (take 4 cs ++ "====") | ||
72 | where | ||
73 | cs = enc5 [o1, o2, 0, 0, 0] | ||
74 | eI [o1, o2, o3] EDone = EFinal (take 5 cs ++ "===") | ||
75 | where | ||
76 | cs = enc5 [o1, o2, o3, 0, 0] | ||
77 | eI [o1, o2, o3, o4] EDone = EFinal (take 7 cs ++ "=") | ||
78 | where | ||
79 | cs = enc5 [o1, o2, o3, o4, 0] | ||
80 | eI lo (EChunk bs) = doEnc [] (lo ++ bs) | ||
81 | where | ||
82 | doEnc acc (o1:o2:o3:o4:o5:os) = doEnc (acc ++ enc5 [o1, o2, o3, o4, o5]) os | ||
83 | doEnc acc os = EPart acc (eI os) | ||
84 | |||
85 | -- | Encode data. | ||
86 | encode :: [Word8] -> String | ||
87 | encode = encoder encodeInc | ||
88 | |||
89 | -- {{{1 decode | ||
90 | -- | Incremental decoder function. | ||
91 | decodeInc :: DecIncData String -> DecIncRes String | ||
92 | decodeInc d = dI [] d | ||
93 | where | ||
94 | dec8 cs = let | ||
95 | ds = map (flip M.lookup decodeMap) cs | ||
96 | es@[e1, e2, e3, e4, e5, e6, e7, e8] = map fromJust ds | ||
97 | o1 = e1 `shiftL` 3 .|. e2 `shiftR` 2 | ||
98 | o2 = e2 `shiftL` 6 .|. e3 `shiftL` 1 .|. e4 `shiftR` 4 | ||
99 | o3 = e4 `shiftL` 4 .|. e5 `shiftR` 1 | ||
100 | o4 = e5 `shiftL` 7 .|. e6 `shiftL` 2 .|. e7 `shiftR` 3 | ||
101 | o5 = e7 `shiftL` 5 .|. e8 | ||
102 | allJust = and . map isJust | ||
103 | in if allJust ds | ||
104 | then Just [o1, o2, o3, o4, o5] | ||
105 | else Nothing | ||
106 | |||
107 | dI [] DDone = DFinal [] [] | ||
108 | dI lo DDone = DFail [] lo | ||
109 | dI lo (DChunk s) = doDec [] (lo ++ s) | ||
110 | where | ||
111 | doDec acc s@(c1:c2:'=':'=':'=':'=':'=':'=':cs) = maybe | ||
112 | (DFail acc s) | ||
113 | (\ bs -> DFinal (acc ++ take 1 bs) cs) | ||
114 | (dec8 [c1, c2, 'A', 'A', 'A', 'A', 'A', 'A']) | ||
115 | doDec acc s@(c1:c2:c3:c4:'=':'=':'=':'=':cs) = maybe | ||
116 | (DFail acc s) | ||
117 | (\ bs -> DFinal (acc ++ take 2 bs) cs) | ||
118 | (dec8 [c1, c2, c3, c4, 'A', 'A', 'A', 'A']) | ||
119 | doDec acc s@(c1:c2:c3:c4:c5:'=':'=':'=':cs) = maybe | ||
120 | (DFail acc s) | ||
121 | (\ bs -> DFinal (acc ++ take 3 bs) cs) | ||
122 | (dec8 [c1, c2, c3, c4, c5, 'A', 'A', 'A']) | ||
123 | doDec acc s@(c1:c2:c3:c4:c5:c6:c7:'=':cs) = maybe | ||
124 | (DFail acc s) | ||
125 | (\ bs -> DFinal (acc ++ take 4 bs) cs) | ||
126 | (dec8 [c1, c2, c3, c4, c5, c6, c7, 'A']) | ||
127 | doDec acc s@(c1:c2:c3:c4:c5:c6:c7:c8:cs) = maybe | ||
128 | (DFail acc s) | ||
129 | (\ bs -> doDec (acc ++ bs) cs) | ||
130 | (dec8 [c1, c2, c3, c4, c5, c6, c7, c8]) | ||
131 | doDec acc s = DPart acc (dI s) | ||
132 | |||
133 | -- | Decode data. | ||
134 | decode :: String | ||
135 | -> Maybe [Word8] | ||
136 | decode = decoder decodeInc | ||
137 | |||
138 | -- {{{1 chop | ||
139 | -- | Chop up a string in parts. | ||
140 | -- | ||
141 | -- The length given is rounded down to the nearest multiple of 8. | ||
142 | chop :: Int -- ^ length of individual lines | ||
143 | -> String | ||
144 | -> [String] | ||
145 | chop n "" = [] | ||
146 | chop n s = let | ||
147 | enc_len | n < 8 = 8 | ||
148 | | otherwise = n `div` 8 * 8 | ||
149 | in take enc_len s : chop n (drop enc_len s) | ||
150 | |||
151 | -- {{{1 unchop | ||
152 | -- | Concatenate the strings into one long string. | ||
153 | unchop :: [String] | ||
154 | -> String | ||
155 | unchop = foldr (++) "" | ||