diff options
Diffstat (limited to 'src/Codec/Binary/Xx.hs')
-rw-r--r-- | src/Codec/Binary/Xx.hs | 149 |
1 files changed, 149 insertions, 0 deletions
diff --git a/src/Codec/Binary/Xx.hs b/src/Codec/Binary/Xx.hs new file mode 100644 index 0000000..875ac04 --- /dev/null +++ b/src/Codec/Binary/Xx.hs | |||
@@ -0,0 +1,149 @@ | |||
1 | -- | | ||
2 | -- Module : Codec.Binary.Xx | ||
3 | -- Copyright : (c) 2007 Magnus Therning | ||
4 | -- License : BSD3 | ||
5 | -- | ||
6 | -- Xxencoding is obsolete but still included for completeness. Further | ||
7 | -- information on the encoding can be found at | ||
8 | -- <http://en.wikipedia.org/wiki/Xxencode>. It should be noted that this | ||
9 | -- implementation performs no padding, due to the splitting up between encoding | ||
10 | -- and chopping. | ||
11 | -- | ||
12 | -- Further documentation and information can be found at | ||
13 | -- <http://www.haskell.org/haskellwiki/Library/Data_encoding>. | ||
14 | module Codec.Binary.Xx | ||
15 | ( EncIncData(..) | ||
16 | , EncIncRes(..) | ||
17 | , encodeInc | ||
18 | , encode | ||
19 | , DecIncData(..) | ||
20 | , DecIncRes(..) | ||
21 | , decodeInc | ||
22 | , decode | ||
23 | , chop | ||
24 | , unchop | ||
25 | ) where | ||
26 | |||
27 | import Codec.Binary.Util | ||
28 | |||
29 | import Control.Monad | ||
30 | import Data.Array | ||
31 | import Data.Bits | ||
32 | import Data.Maybe | ||
33 | import Data.Word | ||
34 | import qualified Data.Map as M | ||
35 | |||
36 | -- {{{1 enc/dec map | ||
37 | _encMap = zip [0..] "+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" | ||
38 | |||
39 | -- {{{1 encodeArray | ||
40 | encodeArray :: Array Word8 Char | ||
41 | encodeArray = array (0, 64) _encMap | ||
42 | |||
43 | -- {{{1 decodeMap | ||
44 | decodeMap :: M.Map Char Word8 | ||
45 | decodeMap = M.fromList [(snd i, fst i) | i <- _encMap] | ||
46 | |||
47 | -- {{{1 encode | ||
48 | -- | Incremental encoder function. | ||
49 | encodeInc :: EncIncData -> EncIncRes String | ||
50 | encodeInc e = eI [] e | ||
51 | where | ||
52 | enc3 [o1, o2, o3] = map (encodeArray !) [i1, i2, i3, i4] | ||
53 | where | ||
54 | i1 = o1 `shiftR` 2 | ||
55 | i2 = (o1 `shiftL` 4 .|. o2 `shiftR` 4) .&. 0x3f | ||
56 | i3 = (o2 `shiftL` 2 .|. o3 `shiftR` 6) .&. 0x3f | ||
57 | i4 = o3 .&. 0x3f | ||
58 | |||
59 | eI [] EDone = EFinal [] | ||
60 | eI [o1] EDone = EFinal $ take 2 $ enc3 [o1, 0, 0] | ||
61 | eI [o1, o2] EDone = EFinal $ take 3 $ enc3 [o1, o2, 0] | ||
62 | eI lo (EChunk bs) = doEnc [] (lo ++ bs) | ||
63 | where | ||
64 | doEnc acc (o1:o2:o3:os) = doEnc (acc ++ enc3 [o1, o2, o3]) os | ||
65 | doEnc acc os = EPart acc (eI os) | ||
66 | |||
67 | -- | Encode data. | ||
68 | encode :: [Word8] -> String | ||
69 | encode = encoder encodeInc | ||
70 | |||
71 | -- {{{1 decode | ||
72 | -- | Incremental decoder function. | ||
73 | decodeInc :: DecIncData String -> DecIncRes String | ||
74 | decodeInc d = dI [] d | ||
75 | where | ||
76 | dec4 cs = let | ||
77 | ds = map (flip M.lookup decodeMap) cs | ||
78 | [e1, e2, e3, e4] = map fromJust ds | ||
79 | o1 = e1 `shiftL` 2 .|. e2 `shiftR` 4 | ||
80 | o2 = e2 `shiftL` 4 .|. e3 `shiftR` 2 | ||
81 | o3 = e3 `shiftL` 6 .|. e4 | ||
82 | allJust = and . map isJust | ||
83 | in if allJust ds | ||
84 | then Just [o1, o2, o3] | ||
85 | else Nothing | ||
86 | |||
87 | dI [] DDone = DFinal [] [] | ||
88 | dI lo@[c1, c2] DDone = maybe | ||
89 | (DFail [] lo) | ||
90 | (\ bs -> DFinal (take 1 bs) []) | ||
91 | (dec4 [c1, c2, '+', '+']) | ||
92 | dI lo@[c1, c2, c3] DDone = maybe | ||
93 | (DFail [] lo) | ||
94 | (\ bs -> DFinal (take 2 bs) []) | ||
95 | (dec4 [c1, c2, c3, '+']) | ||
96 | dI lo DDone = DFail [] lo | ||
97 | dI lo (DChunk s) = doDec [] (lo ++ s) | ||
98 | where | ||
99 | doDec acc s'@(c1:c2:c3:c4:cs) = maybe | ||
100 | (DFail acc s') | ||
101 | (\ bs -> doDec (acc ++ bs) cs) | ||
102 | (dec4 [c1, c2, c3, c4]) | ||
103 | doDec acc s' = DPart acc (dI s') | ||
104 | |||
105 | -- | Decode data. | ||
106 | decode :: String | ||
107 | -> Maybe [Word8] | ||
108 | decode = decoder decodeInc | ||
109 | |||
110 | -- {{{1 chop | ||
111 | -- | Chop up a string in parts. Each string in the resulting list is prepended | ||
112 | -- with the length according to the xxencode \"specificiation\". | ||
113 | -- | ||
114 | -- /Notes:/ | ||
115 | -- | ||
116 | -- * The length of the strings in the result will be @(n -1) `div` 4 * 4 + | ||
117 | -- 1@. The @-1@ comes from the need to prepend the length (which explains | ||
118 | -- the final @+1@). Keeping it to a multiple of 4 means that strings | ||
119 | -- returned from 'encode' can be chopped without requiring any changes. | ||
120 | chop :: Int -- ^ length (value should be in the range @[5..85]@) | ||
121 | -> String | ||
122 | -> [String] | ||
123 | chop n "" = [] | ||
124 | chop n s = let | ||
125 | enc_len | n < 5 = 4 | ||
126 | | n >= 85 = 84 | ||
127 | | otherwise = min 64 $ (n - 1) `div` 4 * 4 | ||
128 | enc_line = take enc_len s | ||
129 | act_len = fromIntegral $ case (length enc_line `divMod` 4) of | ||
130 | (l, 0) -> l * 3 | ||
131 | (l, 2) -> l * 3 + 1 | ||
132 | (l, 3) -> l * 3 + 2 | ||
133 | len = (encodeArray ! act_len) | ||
134 | in (len : enc_line) : chop n (drop enc_len s) | ||
135 | |||
136 | -- {{{1 unchop | ||
137 | -- | Concatenate the strings into one long string. Each string is assumed to | ||
138 | -- be prepended with the length according to the xxencode specification. | ||
139 | unchop :: [String] | ||
140 | -> String | ||
141 | unchop ss = let | ||
142 | singleUnchop (l : cs) = let | ||
143 | act_len = fromIntegral $ decodeMap M.! l | ||
144 | enc_len = case (act_len `divMod` 3) of | ||
145 | (n, 0) -> n * 4 | ||
146 | (n, 1) -> n * 4 + 2 | ||
147 | (n, 2) -> n * 4 + 3 | ||
148 | in take enc_len cs | ||
149 | in foldr ((++) . singleUnchop) "" ss | ||