diff options
Diffstat (limited to 'src/Codec/Binary/Base64Url.hs')
-rw-r--r-- | src/Codec/Binary/Base64Url.hs | 137 |
1 files changed, 137 insertions, 0 deletions
diff --git a/src/Codec/Binary/Base64Url.hs b/src/Codec/Binary/Base64Url.hs new file mode 100644 index 0000000..7599670 --- /dev/null +++ b/src/Codec/Binary/Base64Url.hs | |||
@@ -0,0 +1,137 @@ | |||
1 | -- | | ||
2 | -- Module : Codec.Binary.Base64Url | ||
3 | -- Copyright : (c) 2007 Magnus Therning | ||
4 | -- License : BSD3 | ||
5 | -- | ||
6 | -- Implemented as specified in RFC 4648 (<http://tools.ietf.org/html/rfc4648>). | ||
7 | -- | ||
8 | -- Further documentation and information can be found at | ||
9 | -- <http://www.haskell.org/haskellwiki/Library/Data_encoding>. | ||
10 | module Codec.Binary.Base64Url | ||
11 | ( EncIncData(..) | ||
12 | , EncIncRes(..) | ||
13 | , encodeInc | ||
14 | , encode | ||
15 | , DecIncData(..) | ||
16 | , DecIncRes(..) | ||
17 | , decodeInc | ||
18 | , decode | ||
19 | , chop | ||
20 | , unchop | ||
21 | ) where | ||
22 | |||
23 | import Codec.Binary.Util | ||
24 | |||
25 | import Data.Maybe | ||
26 | import Data.Word | ||
27 | import Data.Bits | ||
28 | import Data.Array | ||
29 | import qualified Data.Map as M | ||
30 | |||
31 | import qualified Codec.Binary.Base64 as Base64 | ||
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, 'a'), (27, 'b'), (28, 'c'), (29, 'd') | ||
41 | , (30, 'e'), (31, 'f'), (32, 'g'), (33, 'h'), (34, 'i') | ||
42 | , (35, 'j'), (36, 'k'), (37, 'l'), (38, 'm'), (39, 'n') | ||
43 | , (40, 'o'), (41, 'p'), (42, 'q'), (43, 'r'), (44, 's') | ||
44 | , (45, 't'), (46, 'u'), (47, 'v'), (48, 'w'), (49, 'x') | ||
45 | , (50, 'y'), (51, 'z'), (52, '0'), (53, '1'), (54, '2') | ||
46 | , (55, '3'), (56, '4'), (57, '5'), (58, '6'), (59, '7') | ||
47 | , (60, '8'), (61, '9'), (62, '-'), (63, '_') ] | ||
48 | |||
49 | -- {{{1 encodeArray | ||
50 | encodeArray :: Array Word8 Char | ||
51 | encodeArray = array (0, 64) _encMap | ||
52 | |||
53 | -- {{{1 decodeMap | ||
54 | decodeMap :: M.Map Char Word8 | ||
55 | decodeMap = M.fromList [(snd i, fst i) | i <- _encMap] | ||
56 | |||
57 | -- {{{1 encode | ||
58 | -- | Incremental encoder function. | ||
59 | encodeInc :: EncIncData -> EncIncRes String | ||
60 | encodeInc e = eI [] e | ||
61 | where | ||
62 | enc3 [o1, o2, o3] = cs | ||
63 | where | ||
64 | i1 = o1 `shiftR` 2 | ||
65 | i2 = (o1 `shiftL` 4 .|. o2 `shiftR` 4) .&. 0x3f | ||
66 | i3 = (o2 `shiftL` 2 .|. o3 `shiftR` 6) .&. 0x3f | ||
67 | i4 = o3 .&. 0x3f | ||
68 | cs = map (encodeArray !) [i1, i2, i3, i4] | ||
69 | |||
70 | eI [] EDone = EFinal [] | ||
71 | eI [o1] EDone = EFinal (take 2 cs ++ "==") | ||
72 | where cs = enc3 [o1, 0, 0] | ||
73 | eI [o1, o2] EDone = EFinal (take 3 cs ++ "=") | ||
74 | where cs = enc3 [o1, o2, 0] | ||
75 | eI lo (EChunk bs) = doEnc [] (lo ++ bs) | ||
76 | where | ||
77 | doEnc acc (o1:o2:o3:os) = doEnc (acc ++ enc3 [o1, o2, o3]) os | ||
78 | doEnc acc os = EPart acc (eI os) | ||
79 | |||
80 | -- | Encode data. | ||
81 | encode :: [Word8] -> String | ||
82 | encode = encoder encodeInc | ||
83 | |||
84 | -- {{{1 decode | ||
85 | -- | Incremental encoder function. | ||
86 | decodeInc :: DecIncData String -> DecIncRes String | ||
87 | decodeInc d = dI [] d | ||
88 | where | ||
89 | dec4 cs = let | ||
90 | ds = map (flip M.lookup decodeMap) cs | ||
91 | es@[e1, e2, e3, e4] = map fromJust ds | ||
92 | o1 = e1 `shiftL` 2 .|. e2 `shiftR` 4 | ||
93 | o2 = e2 `shiftL` 4 .|. e3 `shiftR` 2 | ||
94 | o3 = e3 `shiftL` 6 .|. e4 | ||
95 | allJust = and . map isJust | ||
96 | in if allJust ds | ||
97 | then Just [o1, o2, o3] | ||
98 | else Nothing | ||
99 | |||
100 | dI [] (DDone) = DFinal [] [] | ||
101 | dI lo (DDone) = DFail [] lo | ||
102 | dI lo (DChunk s) = doDec [] (lo ++ s) | ||
103 | where | ||
104 | doDec acc s@(c1:c2:'=':'=':cs) = maybe | ||
105 | (DFail acc s) | ||
106 | (\ bs -> DFinal (acc ++ take 1 bs) cs) | ||
107 | (dec4 [c1, c2, 'A', 'A']) | ||
108 | doDec acc s@(c1:c2:c3:'=':cs) = maybe | ||
109 | (DFail acc s) | ||
110 | (\ bs -> DFinal (acc ++ take 2 bs) cs) | ||
111 | (dec4 [c1, c2, c3, 'A']) | ||
112 | doDec acc s@(c1:c2:c3:c4:cs) = maybe | ||
113 | (DFail acc s) | ||
114 | (\ bs -> doDec (acc ++ bs) cs) | ||
115 | (dec4 [c1, c2, c3, c4]) | ||
116 | doDec acc s = DPart acc (dI s) | ||
117 | |||
118 | -- | Decode data. | ||
119 | decode :: String -> Maybe [Word8] | ||
120 | decode = decoder decodeInc | ||
121 | |||
122 | -- {{{1 chop | ||
123 | -- | Chop up a string in parts. | ||
124 | -- | ||
125 | -- See 'Base64.chop' in "Base64" for more details. | ||
126 | chop :: Int -- ^ length of individual lines | ||
127 | -> String | ||
128 | -> [String] | ||
129 | chop = Base64.chop | ||
130 | |||
131 | -- {{{1 unchop | ||
132 | -- | Concatenate the strings into one long string. | ||
133 | -- | ||
134 | -- See 'Base64.unchop' in "Codec.Binary.Base64" for more details. | ||
135 | unchop :: [String] | ||
136 | -> String | ||
137 | unchop = Base64.unchop | ||