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