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