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