diff --git a/dataenc.cabal b/dataenc.cabal --- a/dataenc.cabal +++ b/dataenc.cabal @@ -1,5 +1,5 @@ name: dataenc -version: 0.13.0.5 +version: 0.14 license: BSD3 license-file: LICENSE cabal-version: >= 1.6 @@ -7,7 +7,7 @@ author: Magnus Therning maintainer: magnus@therning.org homepage: http://www.haskell.org/haskellwiki/Library/Data_encoding -copyright: Magnus Therning, 2007-2009 +copyright: Magnus Therning, 2007-2011 category: Codec synopsis: Data encoding library description: Data encoding library currently providing Base16, Base32, @@ -42,9 +42,10 @@ executable tests main-is: Test.hs hs-source-dirs: test-src src - ghc-options: -fhpc + -- ghc-options: -fhpc if flag(BuildTests) build-depends: test-framework, test-framework-hunit, HUnit, - test-framework-quickcheck2, QuickCheck == 2.1.* + test-framework-quickcheck2, QuickCheck ==2.1.*, + test-framework-th else buildable: False diff --git a/src/Codec/Binary/Base16.hs b/src/Codec/Binary/Base16.hs --- a/src/Codec/Binary/Base16.hs +++ b/src/Codec/Binary/Base16.hs @@ -8,13 +8,20 @@ -- Further documentation and information can be found at -- . module Codec.Binary.Base16 - ( encode + ( EncIncData(..) + , EncIncRes(..) + , encodeInc + , encode + , DecIncData(..) + , DecIncRes(..) + , decodeInc , decode - , decode' , chop , unchop ) where +import Codec.Binary.Util + import Control.Monad import Data.Array import Data.Bits @@ -38,29 +45,42 @@ decodeMap = M.fromList [(snd i, fst i) | i <- _encMap] -- {{{1 encode +-- | Incremental encoder function. +encodeInc :: EncIncData -> EncIncRes String +encodeInc EDone = EFinal [] +encodeInc (EChunk os) = EPart (concat $ map toHex os) encodeInc + -- | Encode data. -encode :: [Word8] - -> String -encode os = let - splitOctet o = [ o `shiftR` 4, o .&. 0xf ] - in map (encodeArray !) $ foldr ((++) . splitOctet) [] os +encode :: [Word8] -> String +encode = encoder encodeInc -- {{{1 decode --- | Decode data (lazy). -decode' :: String - -> [Maybe Word8] -decode' = let - dec [] = [] - dec (Just o1 : Just o2 : os) = - Just (o1 `shiftL` 4 .|. o2) : dec os - dec _ = [Nothing] - in - dec . map (flip M.lookup decodeMap) +-- | Incremental decoder function. +decodeInc :: DecIncData String -> DecIncRes String +decodeInc d = dI [] d + where + dec2 cs = let + ds = map (flip M.lookup decodeMap) cs + es@[e1, e2] = map fromJust ds + o = e1 `shiftL` 4 .|. e2 + allJust = and . map isJust + in if allJust ds + then Just o + else Nothing --- | Decode data (strict). -decode :: String - -> Maybe [Word8] -decode = sequence . decode' + 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') + (\ b -> doDec (acc ++ [b]) cs) + (dec2 [c1, c2]) + doDec acc s = DPart acc (dI s) + +-- | Decode data. +decode :: String -> Maybe [Word8] +decode = decoder decodeInc -- {{{1 chop -- | Chop up a string in parts. diff --git a/src/Codec/Binary/Base32.hs b/src/Codec/Binary/Base32.hs --- a/src/Codec/Binary/Base32.hs +++ b/src/Codec/Binary/Base32.hs @@ -9,13 +9,20 @@ -- Further documentation and information can be found at -- . module Codec.Binary.Base32 - ( encode + ( EncIncData(..) + , EncIncRes(..) + , encodeInc + , encode + , DecIncData(..) + , DecIncRes(..) + , decodeInc , decode - , decode' , chop , unchop ) where +import Codec.Binary.Util + import Control.Monad import Data.Array import Data.Bits @@ -42,17 +49,12 @@ decodeMap = M.fromList [(snd i, fst i) | i <- _encMap] -- {{{1 encode --- | Encode data. -encode :: [Word8] - -> String -encode = let - pad n = replicate n 0 - enc [] = "" - enc l@[o] = (++ "======") . take 2 . enc $ l ++ pad 4 - enc l@[o1, o2] = (++ "====") . take 4 . enc $ l ++ pad 3 - enc l@[o1, o2, o3] = (++ "===") . take 5 . enc $ l ++ pad 2 - enc l@[o1, o2, o3, o4] = (++ "=") . take 7 . enc $ l ++ pad 1 - enc (o1 : o2 : o3 : o4 : o5 : os) = let +-- | Incremental encoder function. +encodeInc :: EncIncData -> EncIncRes String +encodeInc e = eI [] e + where + enc5 [o1, o2, o3, o4, o5] = map (encodeArray !) [i1, i2, i3, i4, i5, i6, i7, i8] + where i1 = o1 `shiftR` 3 i2 = (o1 `shiftL` 2 .|. o2 `shiftR` 6) .&. 0x1f i3 = o2 `shiftR` 1 .&. 0x1f @@ -61,35 +63,77 @@ i6 = o4 `shiftR` 2 .&. 0x1f i7 = (o4 `shiftL` 3 .|. o5 `shiftR` 5) .&. 0x1f i8 = o5 .&. 0x1f - in foldr ((:) . (encodeArray !)) "" [i1, i2, i3, i4, i5, i6, i7, i8] ++ enc os - in enc + eI [] EDone = EFinal [] + eI [o1] EDone = EFinal (take 2 cs ++ "======") + where + cs = enc5 [o1, 0, 0, 0, 0] + eI [o1, o2] EDone = EFinal (take 4 cs ++ "====") + where + cs = enc5 [o1, o2, 0, 0, 0] + eI [o1, o2, o3] EDone = EFinal (take 5 cs ++ "===") + where + cs = enc5 [o1, o2, o3, 0, 0] + eI [o1, o2, o3, o4] EDone = EFinal (take 7 cs ++ "=") + where + cs = enc5 [o1, o2, o3, o4, 0] + eI lo (EChunk bs) = doEnc [] (lo ++ bs) + where + doEnc acc (o1:o2:o3:o4:o5:os) = doEnc (acc ++ enc5 [o1, o2, o3, o4, o5]) os + doEnc acc os = EPart acc (eI os) + +-- | Encode data. +encode :: [Word8] -> String +encode = encoder encodeInc + -- {{{1 decode --- | Decode data (lazy). -decode' :: String - -> [Maybe Word8] -decode' = let - pad n = replicate n $ Just 0 - dec [] = [] - dec l@[Just eo1, Just eo2] = take 1 . dec $ l ++ pad 6 - dec l@[Just eo1, Just eo2, Just eo3, Just eo4] = take 2 . dec $ l ++ pad 4 - dec l@[Just eo1, Just eo2, Just eo3, Just eo4, Just eo5] = take 3 . dec $ l ++ pad 3 - dec l@[Just eo1, Just eo2, Just eo3, Just eo4, Just eo5, Just eo6, Just eo7] = take 4 . dec $ l ++ pad 1 - dec (Just eo1 : Just eo2 : Just eo3 : Just eo4 : Just eo5 : Just eo6 : Just eo7 : Just eo8 : eos) = let - o1 = eo1 `shiftL` 3 .|. eo2 `shiftR` 2 - o2 = eo2 `shiftL` 6 .|. eo3 `shiftL` 1 .|. eo4 `shiftR` 4 - o3 = eo4 `shiftL` 4 .|. eo5 `shiftR` 1 - o4 = eo5 `shiftL` 7 .|. eo6 `shiftL` 2 .|. eo7 `shiftR` 3 - o5 = eo7 `shiftL` 5 .|. eo8 - in Just o1 : Just o2 : Just o3 : Just o4 : Just o5 : dec eos - dec _ = [Nothing] - in - dec . map (flip M.lookup decodeMap) . takeWhile (/= '=') +-- | Incremental decoder function. +decodeInc :: DecIncData String -> DecIncRes String +decodeInc d = dI [] d + where + dec8 cs = let + ds = map (flip M.lookup decodeMap) cs + es@[e1, e2, e3, e4, e5, e6, e7, e8] = map fromJust ds + o1 = e1 `shiftL` 3 .|. e2 `shiftR` 2 + o2 = e2 `shiftL` 6 .|. e3 `shiftL` 1 .|. e4 `shiftR` 4 + o3 = e4 `shiftL` 4 .|. e5 `shiftR` 1 + o4 = e5 `shiftL` 7 .|. e6 `shiftL` 2 .|. e7 `shiftR` 3 + o5 = e7 `shiftL` 5 .|. e8 + allJust = and . map isJust + in if allJust ds + then Just [o1, o2, o3, o4, o5] + else Nothing --- | Decode data (strict). + 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) + (dec8 [c1, c2, 'A', 'A', 'A', 'A', 'A', 'A']) + doDec acc s@(c1:c2:c3:c4:'=':'=':'=':'=':cs) = maybe + (DFail acc s) + (\ bs -> DFinal (acc ++ take 2 bs) cs) + (dec8 [c1, c2, c3, c4, 'A', 'A', 'A', 'A']) + doDec acc s@(c1:c2:c3:c4:c5:'=':'=':'=':cs) = maybe + (DFail acc s) + (\ bs -> DFinal (acc ++ take 3 bs) cs) + (dec8 [c1, c2, c3, c4, c5, 'A', 'A', 'A']) + doDec acc s@(c1:c2:c3:c4:c5:c6:c7:'=':cs) = maybe + (DFail acc s) + (\ bs -> DFinal (acc ++ take 4 bs) cs) + (dec8 [c1, c2, c3, c4, c5, c6, c7, 'A']) + doDec acc s@(c1:c2:c3:c4:c5:c6:c7:c8:cs) = maybe + (DFail acc s) + (\ bs -> doDec (acc ++ bs) cs) + (dec8 [c1, c2, c3, c4, c5, c6, c7, c8]) + doDec acc s = DPart acc (dI s) + +-- | Decode data. decode :: String -> Maybe [Word8] -decode = sequence . decode' +decode = decoder decodeInc -- {{{1 chop -- | Chop up a string in parts. diff --git a/src/Codec/Binary/Base32Hex.hs b/src/Codec/Binary/Base32Hex.hs --- a/src/Codec/Binary/Base32Hex.hs +++ b/src/Codec/Binary/Base32Hex.hs @@ -9,13 +9,20 @@ -- Further documentation and information can be found at -- . module Codec.Binary.Base32Hex - ( encode + ( EncIncData(..) + , EncIncRes(..) + , encodeInc + , encode + , DecIncData(..) + , DecIncRes(..) + , decodeInc , decode - , decode' , chop , unchop ) where +import Codec.Binary.Util + import Control.Monad import Data.Array import Data.Bits @@ -44,17 +51,12 @@ decodeMap = M.fromList [(snd i, fst i) | i <- _encMap] -- {{{1 encode --- | Encode data. -encode :: [Word8] - -> String -encode = let - pad n = replicate n 0 - enc [] = "" - enc l@[o] = (++ "======") . take 2 . enc $ l ++ pad 4 - enc l@[o1, o2] = (++ "====") . take 4 . enc $ l ++ pad 3 - enc l@[o1, o2, o3] = (++ "===") . take 5 . enc $ l ++ pad 2 - enc l@[o1, o2, o3, o4] = (++ "=") . take 7 . enc $ l ++ pad 1 - enc (o1 : o2 : o3 : o4 : o5 : os) = let +-- | Incremental encoder function. +encodeInc :: EncIncData -> EncIncRes String +encodeInc e = eI [] e + where + enc5 [o1, o2, o3, o4, o5] = map (encodeArray !) [i1, i2, i3, i4, i5, i6, i7, i8] + where i1 = o1 `shiftR` 3 i2 = (o1 `shiftL` 2 .|. o2 `shiftR` 6) .&. 0x1f i3 = o2 `shiftR` 1 .&. 0x1f @@ -63,35 +65,77 @@ i6 = o4 `shiftR` 2 .&. 0x1f i7 = (o4 `shiftL` 3 .|. o5 `shiftR` 5) .&. 0x1f i8 = o5 .&. 0x1f - in foldr ((:) . (encodeArray !)) "" [i1, i2, i3, i4, i5, i6, i7, i8] ++ enc os - in enc + eI [] EDone = EFinal [] + eI [o1] EDone = EFinal (take 2 cs ++ "======") + where + cs = enc5 [o1, 0, 0, 0, 0] + eI [o1, o2] EDone = EFinal (take 4 cs ++ "====") + where + cs = enc5 [o1, o2, 0, 0, 0] + eI [o1, o2, o3] EDone = EFinal (take 5 cs ++ "===") + where + cs = enc5 [o1, o2, o3, 0, 0] + eI [o1, o2, o3, o4] EDone = EFinal (take 7 cs ++ "=") + where + cs = enc5 [o1, o2, o3, o4, 0] + eI lo (EChunk bs) = doEnc [] (lo ++ bs) + where + doEnc acc (o1:o2:o3:o4:o5:os) = doEnc (acc ++ enc5 [o1, o2, o3, o4, o5]) os + doEnc acc os = EPart acc (eI os) + +-- | Encode data. +encode :: [Word8] -> String +encode = encoder encodeInc + -- {{{1 decode --- | Decode data (lazy). -decode' :: String - -> [Maybe Word8] -decode' = let - pad n = replicate n $ Just 0 - dec [] = [] - dec l@[Just eo1, Just eo2] = take 1 . dec $ l ++ pad 6 - dec l@[Just eo1, Just eo2, Just eo3, Just eo4] = take 2 . dec $ l ++ pad 4 - dec l@[Just eo1, Just eo2, Just eo3, Just eo4, Just eo5] = take 3 . dec $ l ++ pad 3 - dec l@[Just eo1, Just eo2, Just eo3, Just eo4, Just eo5, Just eo6, Just eo7] = take 4 . dec $ l ++ pad 1 - dec (Just eo1 : Just eo2 : Just eo3 : Just eo4 : Just eo5 : Just eo6 : Just eo7 : Just eo8 : eos) = let - o1 = eo1 `shiftL` 3 .|. eo2 `shiftR` 2 - o2 = eo2 `shiftL` 6 .|. eo3 `shiftL` 1 .|. eo4 `shiftR` 4 - o3 = eo4 `shiftL` 4 .|. eo5 `shiftR` 1 - o4 = eo5 `shiftL` 7 .|. eo6 `shiftL` 2 .|. eo7 `shiftR` 3 - o5 = eo7 `shiftL` 5 .|. eo8 - in Just o1 : Just o2 : Just o3 : Just o4 : Just o5 : dec eos - dec _ = [Nothing] - in - dec . map (flip M.lookup decodeMap) . takeWhile (/= '=') +-- | Incremental decoder function. +decodeInc :: DecIncData String -> DecIncRes String +decodeInc d = dI [] d + where + dec8 cs = let + ds = map (flip M.lookup decodeMap) cs + es@[e1, e2, e3, e4, e5, e6, e7, e8] = map fromJust ds + o1 = e1 `shiftL` 3 .|. e2 `shiftR` 2 + o2 = e2 `shiftL` 6 .|. e3 `shiftL` 1 .|. e4 `shiftR` 4 + o3 = e4 `shiftL` 4 .|. e5 `shiftR` 1 + o4 = e5 `shiftL` 7 .|. e6 `shiftL` 2 .|. e7 `shiftR` 3 + o5 = e7 `shiftL` 5 .|. e8 + allJust = and . map isJust + in if allJust ds + then Just [o1, o2, o3, o4, o5] + else Nothing --- | Decode data (strict). + 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) + (dec8 [c1, c2, 'A', 'A', 'A', 'A', 'A', 'A']) + doDec acc s@(c1:c2:c3:c4:'=':'=':'=':'=':cs) = maybe + (DFail acc s) + (\ bs -> DFinal (acc ++ take 2 bs) cs) + (dec8 [c1, c2, c3, c4, 'A', 'A', 'A', 'A']) + doDec acc s@(c1:c2:c3:c4:c5:'=':'=':'=':cs) = maybe + (DFail acc s) + (\ bs -> DFinal (acc ++ take 3 bs) cs) + (dec8 [c1, c2, c3, c4, c5, 'A', 'A', 'A']) + doDec acc s@(c1:c2:c3:c4:c5:c6:c7:'=':cs) = maybe + (DFail acc s) + (\ bs -> DFinal (acc ++ take 4 bs) cs) + (dec8 [c1, c2, c3, c4, c5, c6, c7, 'A']) + doDec acc s@(c1:c2:c3:c4:c5:c6:c7:c8:cs) = maybe + (DFail acc s) + (\ bs -> doDec (acc ++ bs) cs) + (dec8 [c1, c2, c3, c4, c5, c6, c7, c8]) + doDec acc s = DPart acc (dI s) + +-- | Decode data. decode :: String -> Maybe [Word8] -decode = sequence . decode' +decode = decoder decodeInc -- {{{1 chop -- | Chop up a string in parts. diff --git a/src/Codec/Binary/Base64.hs b/src/Codec/Binary/Base64.hs --- a/src/Codec/Binary/Base64.hs +++ b/src/Codec/Binary/Base64.hs @@ -9,13 +9,20 @@ -- Further documentation and information can be found at -- . module Codec.Binary.Base64 - ( encode + ( EncIncData(..) + , EncIncRes(..) + , encodeInc + , encode + , DecIncData(..) + , DecIncRes(..) + , decodeInc , decode - , decode' , chop , unchop ) where +import Codec.Binary.Util + import Control.Monad import Data.Array import Data.Bits @@ -48,44 +55,69 @@ decodeMap = M.fromList [(snd i, fst i) | i <- _encMap] -- {{{1 encode --- | Encode data. -encode :: [Word8] - -> String -encode = let - pad n = replicate n 0 - enc [] = "" - enc l@[o] = (++ "==") . take 2 .enc $ l ++ pad 2 - enc l@[o1, o2] = (++ "=") . take 3 . enc $ l ++ pad 1 - enc (o1 : o2 : o3 : os) = let +-- | 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 - in foldr ((:) . (encodeArray !)) "" [i1, i2, i3, i4] ++ enc os - in enc + 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 --- | Decode data (lazy). -decode' :: String - -> [Maybe Word8] -decode' = let - pad n = replicate n $ Just 0 - dec [] = [] - dec l@[Just eo1, Just eo2] = take 1 . dec $ l ++ pad 2 - dec l@[Just eo1, Just eo2, Just eo3] = take 2 . dec $ l ++ pad 1 - dec (Just eo1 : Just eo2 : Just eo3 : Just eo4 : eos) = let - o1 = eo1 `shiftL` 2 .|. eo2 `shiftR` 4 - o2 = eo2 `shiftL` 4 .|. eo3 `shiftR` 2 - o3 = eo3 `shiftL` 6 .|. eo4 - in Just o1 : Just o2 : Just o3 : dec eos - dec _ = [Nothing] - in - dec . map (flip M.lookup decodeMap) . takeWhile (/= '=') +-- | 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 --- | Decode data (strict). -decode :: String - -> Maybe [Word8] -decode = sequence . decode' + 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. diff --git a/src/Codec/Binary/Base64Url.hs b/src/Codec/Binary/Base64Url.hs --- a/src/Codec/Binary/Base64Url.hs +++ b/src/Codec/Binary/Base64Url.hs @@ -8,44 +8,116 @@ -- Further documentation and information can be found at -- . module Codec.Binary.Base64Url - ( encode + ( EncIncData(..) + , EncIncRes(..) + , encodeInc + , encode + , DecIncData(..) + , DecIncRes(..) + , decodeInc , decode - , decode' , chop , unchop ) where +import Codec.Binary.Util + import Data.Maybe import Data.Word +import Data.Bits +import Data.Array +import qualified Data.Map as M import qualified Codec.Binary.Base64 as Base64 +-- {{{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 os = let - swapUrlChar c = case c of - '+' -> '-' - '/' -> '_' - _ -> c - in map swapUrlChar $ Base64.encode os +encode :: [Word8] -> String +encode = encoder encodeInc -- {{{1 decode --- | Decode data (lazy). -decode' :: String - -> [Maybe Word8] -decode' = let - unSwapUrlChar c = case c of - '-' -> '+' - '_' -> '/' - _ -> c - in Base64.decode' . map unSwapUrlChar +-- | Incremental encoder 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 --- | Decode data (strict). -decode :: String - -> Maybe [Word8] -decode = sequence . decode' + 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. diff --git a/src/Codec/Binary/Base85.hs b/src/Codec/Binary/Base85.hs --- a/src/Codec/Binary/Base85.hs +++ b/src/Codec/Binary/Base85.hs @@ -8,13 +8,20 @@ -- Further documentation and information can be found at -- . module Codec.Binary.Base85 - ( encode + ( EncIncData(..) + , EncIncRes(..) + , encodeInc + , encode + , DecIncData(..) + , DecIncRes(..) + , decodeInc , decode - , decode' , chop , unchop ) where +import Codec.Binary.Util + import Data.Array import Data.Bits import Data.Char @@ -35,55 +42,85 @@ decodeMap = M.fromList [(snd i, fst i) | i <- _encMap] -- {{{1 encode +-- | Incremental encoder function. +encodeInc :: EncIncData -> EncIncRes String +encodeInc e = eI [] e + where + enc4 [0, 0, 0, 0] = "z" + enc4 [20, 20, 20, 20] = "y" + enc4 os@[o1, o2, o3, o4] = map (encodeArray !) group + where + group2Word32 = foldl (\ a b -> a `shiftL` 8 + fromIntegral b) 0 os + encodeWord32ToWord8s :: Word32 -> [Word8] + encodeWord32ToWord8s = + map (fromIntegral . (`mod` 85)) . take 5 . iterate (`div` 85) + adjustNReverse = reverse . map (+ 33) + group = (adjustNReverse .encodeWord32ToWord8s) group2Word32 + + eI [] EDone = EFinal [] + eI [o1] EDone = EFinal (take 2 cs) + where + cs = enc4 [o1, 0, 0, 1] + eI [o1, o2] EDone = EFinal (take 3 cs) + where + cs = enc4 [o1, o2, 0, 1] + eI [o1, o2, o3] EDone = EFinal (take 4 cs) + where + cs = enc4 [o1, o2, o3, 1] + eI lo (EChunk bs) = doEnc [] (lo ++ bs) + where + doEnc acc (o1:o2:o3:o4:os) = doEnc (acc ++ enc4 [o1, o2, o3, o4]) os + doEnc acc os = EPart acc (eI os) + -- | Encode data. -- -- The result will not be enclosed in \<~ ~\>. -encode :: [Word8] - -> String -encode [] = "" -encode [b1] = take 2 $ encode [b1, 0, 0, 1] -encode [b1, b2] = take 3 $ encode [b1, b2, 0, 1] -encode [b1, b2, b3] = take 4 $ encode [b1, b2, b3, 1] -encode (0 : 0 : 0 : 0 : bs) = 'z' : encode bs -encode (b1 : b2 : b3 : b4 : bs) = foldr ((:) . (encodeArray !)) "" group ++ encode bs - where - group2Word32 :: Word32 - group2Word32 = foldl (\ a b -> a `shiftL` 8 + fromIntegral b) 0 [b1, b2, b3, b4] - encodeWord32ToWord8s :: Word32 -> [Word8] - encodeWord32ToWord8s = map (fromIntegral . (`mod` 85)) . take 5 . iterate (`div` 85) - adjustNReverse = reverse . map (+ 33) - group = (adjustNReverse .encodeWord32ToWord8s) group2Word32 +encode :: [Word8] -> String +encode = encoder encodeInc -- {{{1 decode --- | Decode data (lazy). --- --- The input must not be enclosed in \<~ ~\>. -decode' :: String - -> [Maybe Word8] -decode' [] = [] -decode' ('z' : cs) = Just 0 : Just 0 : Just 0 : Just 0 : decode' cs -decode' cs = let - pad n = replicate n $ Just 0 - dec :: [Maybe Word8] -> [Maybe Word8] - dec l@[Just c1, Just c2] = take 1 . dec $ l ++ pad 3 - dec l@[Just c1, Just c2, Just c3] = take 2 . dec $ l ++ pad 2 - dec l@[Just c1, Just c2, Just c3, Just c4] = take 3 . dec $ l ++ pad 1 - dec l@[Just c1, Just c2, Just c3, Just c4, Just c5] = let - adjRev = map (flip (-) 33) [c5, c4, c3, c2, c1] - group2Word32 :: [Word8] -> Word32 +-- | Incremental decoder function. +decodeInc :: DecIncData String -> DecIncRes String +decodeInc d = dI [] d + where + dec5 cs = let + ds = map (flip M.lookup decodeMap) cs + es@[e1, e2, e3, e4, e5] = map fromJust ds + adjRev = map (\ i -> i - 33) [e5, e4, e3, e2, e1] group2Word32 = foldl1 (+) . zipWith (*) (map (85 ^) [0..4]) . map fromIntegral - word32ToGroup :: Word32 -> [Maybe Word8] - word32ToGroup = map (Just . fromIntegral) . reverse . take 4 . iterate (`div` 256) - in (word32ToGroup . group2Word32) adjRev - dec _ = [Nothing] - in (dec . map (flip M.lookup decodeMap) $ take 5 cs) ++ decode' (drop 5 cs) + word32ToGroup :: Word32 -> [Word8] + word32ToGroup = map fromIntegral . reverse . take 4 . iterate (`div` 256) + allJust = and . map isJust + in if allJust ds + then Just $ word32ToGroup $ group2Word32 adjRev + else Nothing --- | Decode data (strict). + dI lo (DChunk s) = doDec [] (lo ++ s) + dI [] DDone = DFinal [] [] + dI cs@[c1, c2] DDone = case doDec [] (cs ++ "uuu") of + (DPart r _) -> DFinal (take 1 r) [] + f -> f + dI cs@[c1, c2, c3] DDone = case doDec [] (cs ++ "uu") of + (DPart r _) -> DFinal (take 2 r) [] + f -> f + dI cs@[c1, c2, c3, c4] DDone = case doDec [] (cs ++ "u") of + (DPart r _) -> DFinal (take 3 r) [] + f -> f + dI lo DDone = DFail [] lo + + doDec acc ('z':cs) = doDec (acc ++ [0, 0, 0, 0]) cs + doDec acc ('y':cs) = doDec (acc ++ [20, 20, 20, 20]) cs + doDec acc s@(c1:c2:c3:c4:c5:cs) = maybe + (DFail acc s) + (\ bs -> doDec (acc ++ bs) cs) + (dec5 [c1, c2, c3, c4, c5]) + doDec acc cs = DPart acc (dI cs) + +-- | Decode data. -- -- The input must not be enclosed in \<~ ~\>. -decode :: String - -> Maybe [Word8] -decode = sequence . decode' +decode :: String -> Maybe [Word8] +decode = decoder decodeInc -- {{{1 chop -- | Chop up a string in parts. diff --git a/src/Codec/Binary/DataEncoding.hs b/src/Codec/Binary/DataEncoding.hs --- a/src/Codec/Binary/DataEncoding.hs +++ b/src/Codec/Binary/DataEncoding.hs @@ -19,7 +19,6 @@ , base85 , chop , decode - , decode' , encode , py , qp @@ -49,7 +48,6 @@ data DataCodec = DataCodec { encode :: [Word8] -> String, decode :: String -> Maybe [Word8], - decode' :: String -> [Maybe Word8], chop :: Int -> String -> [String], unchop :: [String] -> String } @@ -61,7 +59,6 @@ base16 = DataCodec { encode=Base16.encode, decode=Base16.decode, - decode'=Base16.decode', chop=Base16.chop, unchop=Base16.unchop } @@ -73,7 +70,6 @@ base32 = DataCodec { encode=Base32.encode, decode=Base32.decode, - decode'=Base32.decode', chop=Base32.chop, unchop=Base32.unchop } @@ -85,7 +81,6 @@ base32Hex = DataCodec { encode=Base32Hex.encode, decode=Base32Hex.decode, - decode'=Base32Hex.decode', chop=Base32Hex.chop, unchop=Base32Hex.unchop } @@ -97,7 +92,6 @@ base64 = DataCodec { encode=Base64.encode, decode=Base64.decode, - decode'=Base64.decode', chop=Base64.chop, unchop=Base64.unchop } @@ -109,7 +103,6 @@ base64Url = DataCodec { encode=Base64Url.encode, decode=Base64Url.decode, - decode'=Base64Url.decode', chop=Base64Url.chop, unchop=Base64Url.unchop } @@ -121,7 +114,6 @@ base85 = DataCodec { encode=Base85.encode, decode=Base85.decode, - decode'=Base85.decode', chop=Base85.chop, unchop=Base85.unchop } @@ -133,7 +125,6 @@ uu = DataCodec { encode=Uu.encode, decode=Uu.decode, - decode'=Uu.decode', chop=Uu.chop, unchop=Uu.unchop } @@ -145,7 +136,6 @@ xx = DataCodec { encode=Xx.encode, decode=Xx.decode, - decode'=Xx.decode', chop=Xx.chop, unchop=Xx.unchop } @@ -157,7 +147,6 @@ qp = DataCodec { encode = QP.encode , decode = QP.decode - , decode' = QP.decode' , chop = QP.chop , unchop = QP.unchop } @@ -169,7 +158,6 @@ py = DataCodec { encode = Py.encode , decode = Py.decode - , decode' = Py.decode' , chop = Py.chop , unchop = Py.unchop } @@ -181,7 +169,6 @@ url = DataCodec { encode = Url.encode , decode = Url.decode - , decode' = Url.decode' , chop = Url.chop , unchop = Url.unchop } diff --git a/src/Codec/Binary/PythonString.hs b/src/Codec/Binary/PythonString.hs --- a/src/Codec/Binary/PythonString.hs +++ b/src/Codec/Binary/PythonString.hs @@ -27,46 +27,69 @@ -- Further documentation and information can be found at -- . module Codec.Binary.PythonString - ( encode + ( EncIncData(..) + , EncIncRes(..) + , encodeInc + , encode + , DecIncData(..) + , DecIncRes(..) + , decodeInc , decode - , decode' , chop , unchop ) where +import Codec.Binary.Util + import Data.Char +import Data.Maybe import Data.Word -import Codec.Binary.Util - -- {{{1 encode +-- | Incremental encoder function. +encodeInc :: EncIncData -> EncIncRes String +encodeInc e = eI e + where + enc [] = [] + enc (o:os) + | o < 0x20 || o > 0x7e = ('\\' : 'x' : toHex o) ++ enc os + | o == 34 = "\\\"" ++ enc os + | o == 39 = "\\'" ++ enc os + | o == 92 = "\\\\" ++ enc os + | otherwise = chr (fromIntegral o) : enc os + + eI EDone = EFinal [] + eI (EChunk bs) = EPart (enc bs) encodeInc + -- | Encode data. -encode :: [Word8] - -> String -encode [] = "" -encode (o : os) - | o < 0x20 || o > 0x7e = ('\\' : 'x' : toHex o) ++ encode os - | o == 34 = "\\\"" ++ encode os - | o == 39 = "\\'" ++ encode os - | o == 92 = "\\\\" ++ encode os - | otherwise = chr (fromIntegral o) : encode os +encode :: [Word8] -> String +encode = encoder encodeInc -- {{{1 decode --- -- | Decode data (lazy). -decode' :: String - -> [Maybe Word8] -decode' [] = [] -decode' ('\\':'x' : c0 : c1 : cs) = fromHex [c0, c1] : decode' cs -decode' ('\\':'\\' : cs) = (Just $ fromIntegral $ ord '\\') : decode' cs -decode' ('\\':'\'' : cs) = (Just $ fromIntegral $ ord '\'') : decode' cs -decode' ('\\':'\"' : cs) = (Just $ fromIntegral $ ord '\"') : decode' cs -decode' (c : cs) - | c /= '\\' = (Just $ fromIntegral $ ord c) : decode' cs - | otherwise = [Nothing] +-- | Incremental decoder function. +decodeInc :: DecIncData String -> DecIncRes String +decodeInc d = dI [] d + where + dI [] DDone = DFinal [] [] + dI lo DDone = DFail [] lo + dI lo (DChunk s) = doDec [] (lo ++ s) + where + doDec acc [] = DPart acc (dI []) + doDec acc s'@('\\':'x':c0:c1:cs) = let + o = fromHex [c0, c1] + in if isJust o + then doDec (acc ++ [fromJust o]) cs + else DFail acc s' + doDec acc s'@('\\':'\\':cs) = doDec (acc ++ [fromIntegral $ ord '\\']) cs + doDec acc s'@('\\':'\'':cs) = doDec (acc ++ [fromIntegral $ ord '\'']) cs + doDec acc s'@('\\':'\"':cs) = doDec (acc ++ [fromIntegral $ ord '\"']) cs + doDec acc s'@(c:cs) + | c /= '\\' = doDec (acc ++ [fromIntegral $ ord c]) cs + | otherwise = DPart acc (dI s') --- | Decode data (strict). +-- | Decode data. decode :: String -> Maybe [Word8] -decode = sequence . decode' +decode = decoder decodeInc -- {{{1 chop -- | Chop up a string in parts. diff --git a/src/Codec/Binary/QuotedPrintable.hs b/src/Codec/Binary/QuotedPrintable.hs --- a/src/Codec/Binary/QuotedPrintable.hs +++ b/src/Codec/Binary/QuotedPrintable.hs @@ -14,41 +14,63 @@ -- Further documentation and information can be found at -- . module Codec.Binary.QuotedPrintable - ( encode + ( EncIncData(..) + , EncIncRes(..) + , encodeInc + , encode + , DecIncData(..) + , DecIncRes(..) + , decodeInc , decode - , decode' , chop , unchop ) where +import Codec.Binary.Util + import Data.Char +import Data.Maybe import Data.Word -import Codec.Binary.Util - -- {{{1 encode --- | Encode data. -encode :: [Word8] - -> String -encode [] = "" -encode (o : os) - | o < 33 || o == 61 || o > 126 = ('=' : toHex o) ++ encode os - | otherwise = chr (fromIntegral o) : encode os +-- | Incremental encoder function. +encodeInc :: EncIncData -> EncIncRes String +encodeInc e = eI e + where + enc [] = [] + enc (o:os) + | o < 33 || o == 61 || o > 126 = ('=' : toHex o) ++ enc os + | otherwise = chr (fromIntegral o) : enc os + eI EDone = EFinal [] + eI (EChunk bs) = EPart (enc bs) encodeInc +-- | Encode data. +encode :: [Word8] -> String +encode = encoder encodeInc + -- {{{1 decode --- -- | Decode data (lazy). -decode' :: String - -> [Maybe Word8] -decode' [] = [] -decode' ('=' : c0 : c1 : cs) = fromHex [c0, c1] : decode' cs -decode' (c : cs) - | c /= '=' = (Just $ fromIntegral $ ord c) : decode' cs - | otherwise = [Nothing] +-- | Incremental decoder function. +decodeInc :: DecIncData String -> DecIncRes String +decodeInc d = dI [] d + where + dI [] DDone = DFinal [] [] + dI lo DDone = DFail [] lo + dI lo (DChunk s) = doDec [] (lo ++ s) + where + doDec acc [] = DPart acc (dI []) + doDec acc s'@('=':c0:c1:cs) = let + o = fromHex [c0, c1] + in if isJust o + then doDec (acc ++ [fromJust o]) cs + else DFail acc s' + doDec acc s'@(c:cs) + | c /= '=' = doDec (acc ++ [fromIntegral $ ord c]) cs + | otherwise = DPart acc (dI s') --- | Decode data (strict). +-- | Decode data. decode :: String -> Maybe [Word8] -decode = sequence . decode' +decode = decoder decodeInc -- {{{1 chop -- | Chop up a string in parts. diff --git a/src/Codec/Binary/Url.hs b/src/Codec/Binary/Url.hs --- a/src/Codec/Binary/Url.hs +++ b/src/Codec/Binary/Url.hs @@ -10,19 +10,26 @@ -- . module Codec.Binary.Url - ( encode + ( EncIncData(..) + , EncIncRes(..) + , encodeInc + , encode + , DecIncData + , DecIncRes + , decodeInc , decode - , decode' , chop , unchop ) where +import Codec.Binary.Util + import qualified Data.Map as M import Data.Char(ord) import Data.Word(Word8) - -import Codec.Binary.Util(toHex,fromHex) +import Data.Maybe(isJust, fromJust) +-- {{{1 enc/dec map _unreservedChars = zip [65..90] "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ++ zip [97..122] "abcdefghijklmnopqrstuvwxyz" ++ zip [48..57] "0123456789" @@ -35,28 +42,45 @@ decodeMap = M.fromList [(b, a) | (a, b) <- _unreservedChars] -- {{{1 encode +-- | Incremental decoder function. +encodeInc :: EncIncData -> EncIncRes String +encodeInc e = eI e + where + enc [] = [] + enc (o : os) = case (M.lookup o encodeMap) of + Just c -> c : enc os + Nothing -> ('%' : toHex o) ++ enc os + + eI EDone = EFinal [] + eI (EChunk bs) = EPart (enc bs) encodeInc + -- | Encode data. -encode :: [Word8] - -> String -encode [] = "" -encode (o : os) = case (M.lookup o encodeMap) of - Just c -> c : encode os - Nothing -> ('%' : toHex o) ++ encode os +encode :: [Word8] -> String +encode = encoder encodeInc -- {{{1 decode --- | Decode data (lazy). -decode' :: String - -> [Maybe Word8] -decode' [] = [] -decode' ('%' : c0 : c1 : cs) = fromHex [c0, c1] : decode' cs -decode' (c : cs) - | c /= '%' = (Just $ fromIntegral $ ord c) : decode' cs - | otherwise = [Nothing] +-- | Incremental decoder function. +decodeInc :: DecIncData String -> DecIncRes String +decodeInc d = dI [] d + where + dI [] DDone = DFinal [] [] + dI lo DDone = DFail [] lo + dI lo (DChunk s) = doDec [] (lo ++ s) + where + doDec acc [] = DPart acc (dI []) + doDec acc s'@('%':c0:c1:cs) = let + o = fromHex [c0, c1] + in if isJust o + then doDec (acc ++ [fromJust o]) cs + else DFail acc s' + doDec acc s'@(c:cs) + | c /= '%' = doDec (acc ++ [fromIntegral $ ord c]) cs + | otherwise = DPart acc (dI s') --- | Decode data (strict). +-- | Decode data. decode :: String -> Maybe [Word8] -decode = sequence . decode' +decode = decoder decodeInc -- {{{1 chop -- | Chop up a string in parts. diff --git a/src/Codec/Binary/Util.hs b/src/Codec/Binary/Util.hs --- a/src/Codec/Binary/Util.hs +++ b/src/Codec/Binary/Util.hs @@ -7,6 +7,12 @@ module Codec.Binary.Util ( toHex , fromHex + , EncIncData(..) + , EncIncRes(..) + , DecIncData(..) + , DecIncRes(..) + , encoder + , decoder ) where import Data.Array @@ -39,3 +45,38 @@ in Just o dec _ = Nothing in dec . map (flip M.lookup hexDecodeMap . toUpper) + +-- {{{1 incremental coding +-- | Data type for the incremental encoding functions. +data EncIncData = EChunk [Word8] -- ^ a chunk of data to be encoded + | EDone -- ^ the signal to the encoder that the stream of data is ending + +-- | Data type for the result of calling the incremental encoding functions. +data EncIncRes i = EPart i (EncIncData -> EncIncRes i) -- ^ a partial result together with the continuation to use for further encoding + | EFinal i -- ^ the final result of encoding (the response to 'EDone') + +encoder f os = case f (EChunk os) of + EPart r1 f' -> case f' EDone of + EFinal r2 -> r1 ++ r2 + +-- | Data type for the incremental decoding functions. +data DecIncData i = DChunk i -- ^ a chunk of data to be decoded + | DDone -- ^ the signal to the decoder that the stream of data is ending + +-- | Data type for the result of calling the incremental encoding functions. +data DecIncRes i = DPart [Word8] (DecIncData i -> DecIncRes i) -- ^ a partial result together with the continuation to user for further decoding + | DFinal [Word8] i -- ^ the final result of decoding (the response to 'DDone') + | DFail [Word8] i -- ^ a partial result for a failed decoding, together with the remainder of the data passed in so far + +decoder :: (DecIncData i -> DecIncRes i) -> i -> Maybe [Word8] +decoder f s = let + d = f (DChunk s) + in case d of + DFinal da _ -> Just da + DFail _ _ -> Nothing + DPart da f -> let + d' = f DDone + in case d' of + DFinal da' _ -> Just $ da ++ da' + DFail _ _ -> Nothing + DPart _ _ -> Nothing -- should never happen diff --git a/src/Codec/Binary/Uu.hs b/src/Codec/Binary/Uu.hs --- a/src/Codec/Binary/Uu.hs +++ b/src/Codec/Binary/Uu.hs @@ -10,13 +10,20 @@ -- Further documentation and information can be found at -- . module Codec.Binary.Uu - ( encode + ( EncIncData(..) + , EncIncRes(..) + , encodeInc + , encode + , DecIncData(..) + , DecIncRes(..) + , decodeInc , decode - , decode' , chop , unchop ) where +import Codec.Binary.Util + import Control.Monad import Data.Array import Data.Bits @@ -36,44 +43,66 @@ decodeMap = M.fromList [(snd i, fst i) | i <- _encMap] -- {{{1 encode --- | Encode data. -encode :: [Word8] - -> String -encode = let - pad n = replicate n 0 - enc [] = "" - enc l@[o] = take 2 . enc $ l ++ pad 2 - enc l@[o1, o2] = take 3 . enc $ l ++ pad 1 - enc (o1 : o2 : o3 : os) = let +-- | Incremental encoder function. +encodeInc :: EncIncData -> EncIncRes String +encodeInc e = eI [] e + where + enc3 [o1, o2, o3] = map (encodeArray !) [i1, i2, i3, i4] + where i1 = o1 `shiftR` 2 i2 = (o1 `shiftL` 4 .|. o2 `shiftR` 4) .&. 0x3f i3 = (o2 `shiftL` 2 .|. o3 `shiftR` 6) .&. 0x3f i4 = o3 .&. 0x3f - in foldr ((:) . (encodeArray !)) "" [i1, i2, i3, i4] ++ enc os - in enc + eI [] EDone = EFinal [] + eI [o1] EDone = EFinal $ take 2 $ enc3 [o1, 0, 0] + eI [o1, o2] EDone = EFinal $ take 3 $ 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 --- | Decode data (lazy). -decode' :: String - -> [Maybe Word8] -decode' = let - pad n = replicate n $ Just 0 - dec [] = [] - dec l@[Just eo1, Just eo2] = take 1 . dec $ l ++ pad 2 - dec l@[Just eo1, Just eo2, Just eo3] = take 2 . dec $ l ++ pad 1 - dec (Just eo1 : Just eo2 : Just eo3 : Just eo4 : eos) = let - o1 = eo1 `shiftL` 2 .|. eo2 `shiftR` 4 - o2 = eo2 `shiftL` 4 .|. eo3 `shiftR` 2 - o3 = eo3 `shiftL` 6 .|. eo4 - in Just o1 : Just o2 : Just o3 : dec eos - dec _ = [Nothing] - in - dec . map (flip M.lookup decodeMap) +-- | Incremental decoder function. +decodeInc :: DecIncData String -> DecIncRes String +decodeInc d = dI [] d + where + dec4 cs = let + ds = map (flip M.lookup decodeMap) cs + [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 --- | Decode data (strict). -decode :: String - -> Maybe [Word8] -decode = sequence . decode' + dI [] DDone = DFinal [] [] + dI lo@[c1, c2] DDone = maybe + (DFail [] lo) + (\ bs -> DFinal (take 1 bs) []) + (dec4 [c1, c2, '`', '`']) + dI lo@[c1, c2, c3] DDone = maybe + (DFail [] lo) + (\ bs -> DFinal (take 2 bs) []) + (dec4 [c1, c2, c3, '`']) + dI lo DDone = DFail [] lo + dI lo (DChunk s) = doDec [] (lo ++ s) + where + 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. Each string in the resulting list is prepended diff --git a/src/Codec/Binary/Xx.hs b/src/Codec/Binary/Xx.hs --- a/src/Codec/Binary/Xx.hs +++ b/src/Codec/Binary/Xx.hs @@ -12,13 +12,20 @@ -- Further documentation and information can be found at -- . module Codec.Binary.Xx - ( encode + ( EncIncData(..) + , EncIncRes(..) + , encodeInc + , encode + , DecIncData(..) + , DecIncRes(..) + , decodeInc , decode - , decode' , chop , unchop ) where +import Codec.Binary.Util + import Control.Monad import Data.Array import Data.Bits @@ -38,44 +45,67 @@ decodeMap = M.fromList [(snd i, fst i) | i <- _encMap] -- {{{1 encode --- | Encode data. -encode :: [Word8] - -> String -encode = let - pad n = replicate n 0 - enc [] = "" - enc l@[o] = take 2 . enc $ l ++ pad 2 - enc l@[o1, o2] = take 3 . enc $ l ++ pad 1 - enc (o1 : o2 : o3 : os) = let +-- | Incremental encoder function. +encodeInc :: EncIncData -> EncIncRes String +encodeInc e = eI [] e + where + enc3 [o1, o2, o3] = map (encodeArray !) [i1, i2, i3, i4] + where i1 = o1 `shiftR` 2 i2 = (o1 `shiftL` 4 .|. o2 `shiftR` 4) .&. 0x3f i3 = (o2 `shiftL` 2 .|. o3 `shiftR` 6) .&. 0x3f i4 = o3 .&. 0x3f - in foldr ((:) . (encodeArray !)) "" [i1, i2, i3, i4] ++ enc os - in enc + eI [] EDone = EFinal [] + eI [o1] EDone = EFinal $ take 2 $ enc3 [o1, 0, 0] + eI [o1, o2] EDone = EFinal $ take 3 $ 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 --- | Decode data (lazy). -decode' :: String - -> [Maybe Word8] -decode' = let - pad n = replicate n $ Just 0 - dec [] = [] - dec l@[Just eo1, Just eo2] = take 1 . dec $ l ++ pad 2 - dec l@[Just eo1, Just eo2, Just eo3] = take 2 . dec $ l ++ pad 1 - dec (Just eo1 : Just eo2 : Just eo3 : Just eo4 : eos) = let - o1 = eo1 `shiftL` 2 .|. eo2 `shiftR` 4 - o2 = eo2 `shiftL` 4 .|. eo3 `shiftR` 2 - o3 = eo3 `shiftL` 6 .|. eo4 - in Just o1 : Just o2 : Just o3 : dec eos - dec _ = [Nothing] - in - dec . map (flip M.lookup decodeMap) +-- | Incremental decoder function. +decodeInc :: DecIncData String -> DecIncRes String +decodeInc d = dI [] d + where + dec4 cs = let + ds = map (flip M.lookup decodeMap) cs + [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 --- | Decode data (strict). + dI [] DDone = DFinal [] [] + dI lo@[c1, c2] DDone = maybe + (DFail [] lo) + (\ bs -> DFinal (take 1 bs) []) + (dec4 [c1, c2, '+', '+']) + dI lo@[c1, c2, c3] DDone = maybe + (DFail [] lo) + (\ bs -> DFinal (take 2 bs) []) + (dec4 [c1, c2, c3, '+']) + dI lo DDone = DFail [] lo + dI lo (DChunk s) = doDec [] (lo ++ s) + where + 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 = sequence . decode' +decode = decoder decodeInc -- {{{1 chop -- | Chop up a string in parts. Each string in the resulting list is prepended diff --git a/src/Codec/Binary/Yenc.hs b/src/Codec/Binary/Yenc.hs --- a/src/Codec/Binary/Yenc.hs +++ b/src/Codec/Binary/Yenc.hs @@ -9,39 +9,58 @@ -- Further documentation and information can be found at -- . module Codec.Binary.Yenc - ( encode + ( EncIncData(..) + , EncIncRes(..) + , encodeInc + , encode + , DecIncData(..) + , DecIncRes(..) + , decodeInc , decode - , decode' , chop , unchop ) where +import Codec.Binary.Util + import Data.Word _criticalsIn = [0xd6, 0xe0, 0xe3, 0x13] _equal = 0x3d -- {{{1 encode +-- | Incremental encoder function. +encodeInc :: EncIncData -> EncIncRes [Word8] +encodeInc e = eI e + where + enc [] = [] + enc (o:os) + | o `elem` _criticalsIn = _equal : o + 106 : enc os + | otherwise = o + 42 : enc os + + eI EDone = EFinal [] + eI (EChunk bs) = EPart (enc bs) encodeInc + -- | Encode data. -encode :: [Word8] - -> [Word8] -encode (d : ds) - | d `elem` _criticalsIn = _equal : d + 106 : encode ds - | otherwise = d + 42 : encode ds -encode _ = [] +encode :: [Word8] -> [Word8] +encode = encoder encodeInc -- {{{1 decode --- | Decode data (lazy). -decode' :: [Word8] - -> [Maybe Word8] -decode' (0x3d : d : ds) = Just (d + 150) : decode' ds -decode' (d : ds) = Just (d + 214) : decode' ds -decode' _ = [] +-- | Incremental decoder function. +decodeInc :: DecIncData [Word8] -> DecIncRes [Word8] +decodeInc d = dI [] d + where + dI [] DDone = DFinal [] [] + dI lo DDone = DFail [] lo + dI lo (DChunk s) = doDec [] (lo ++ s) + where + doDec acc (0x3d:d:ds) = doDec (acc ++ [d + 150]) ds + doDec acc (d:ds) = doDec (acc ++ [d + 214]) ds + doDec acc s' = DPart acc (dI s') --- | Decode data (strict). -decode :: [Word8] - -> Maybe [Word8] -decode = sequence . decode' +-- | Decode data. +decode :: [Word8] -> Maybe [Word8] +decode = decoder decodeInc -- {{{1 chop -- | Chop up a string in parts. diff --git a/test-src/DataencQC.hs b/test-src/DataencQC.hs --- a/test-src/DataencQC.hs +++ b/test-src/DataencQC.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -XTemplateHaskell #-} + {- - Copyright : (c) 2007 Magnus Therning - License : BSD3 @@ -6,6 +8,8 @@ module DataencQC where +import Test.Framework.TH + import Data.Maybe import Data.Word import Test.QuickCheck @@ -137,34 +141,4 @@ where runAll = Url.decode . Url.unchop . Url.chop n . Url.encode -- {{{1 all the tests -allTests = - [ testProperty "uuEncode" prop_uuEncode - , testProperty "uuChop" prop_uuChop - , testProperty "uuCombined" prop_uuCombined - , testProperty "xxEncode" prop_xxEncode - , testProperty "xxChop" prop_xxChop - , testProperty "xxCombined" prop_xxCombined - , testProperty "base85Encode" prop_base85Encode - , testProperty "base85Chop" prop_base85Chop - , testProperty "base64Encode" prop_base64Encode - , testProperty "base64Chop" prop_base64Chop - , testProperty "base64UrlEncode" prop_base64UrlEncode - , testProperty "base64UrlChop" prop_base64UrlChop - , testProperty "base32Encode" prop_base32Encode - , testProperty "base32Chop" prop_base32Chop - , testProperty "base32HexEncode" prop_base32HexEncode - , testProperty "base32HexChop" prop_base32HexChop - , testProperty "base16Encode" prop_base16Encode - , testProperty "base16Chop" prop_base16Chop - , testProperty "yencEncode" prop_yencEncode - , testProperty "yencChop" prop_yencChop - , testProperty "qpEncode" prop_qpEncode - , testProperty "qpChop" prop_qpChop - , testProperty "qpCombined" prop_qpCombined - , testProperty "pyEncode" prop_pyEncode - , testProperty "pyChop" prop_pyChop - , testProperty "pyCombined" prop_pyCombined - , testProperty "urlEncode" prop_urlEncode - , testProperty "urlChop" prop_urlChop - , testProperty "urlCombined" prop_urlCombined - ] +allTests = $(testGroupGenerator) diff --git a/test-src/DataencUT.hs b/test-src/DataencUT.hs --- a/test-src/DataencUT.hs +++ b/test-src/DataencUT.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -XTemplateHaskell #-} {- - Copyright : (c) 2007 Magnus Therning - License : BSD3 @@ -11,27 +12,16 @@ import System.Exit import Data.Maybe import qualified Test.Framework.Providers.API as TFAPI +import Test.Framework.TH import Test.Framework.Providers.HUnit import Codec.Binary.DataEncoding import qualified Codec.Binary.Yenc as Yenc --- {{{1 buildTestList --- builds a list of successful tests based on a tuple (suite, description, --- encoded data, decoded data, codec) -buildTestList td = TestList $ concat [ - [ TestLabel (suite ++ " encode " ++ desc) (enc ~=? encode codec dec) - , TestLabel (suite ++ " decode " ++ desc) (dec ~=? fromJust (decode codec enc)) - ] | (suite, desc, enc, dec, codec) <- td ] - --- {{{1 unitTest2TFTest -unitTest2TFTest :: Test -> [TFAPI.Test] -unitTest2TFTest t = let - unitTest2TFTest' desc (TestCase a) = [testCase desc a] - unitTest2TFTest' desc (TestLabel s t) = unitTest2TFTest' (desc ++ ":" ++ s) t - unitTest2TFTest' desc (TestList ts) = concatMap (unitTest2TFTest' desc) ts - in unitTest2TFTest' "" t - +-- {{{1 checkAssertions +checkAssertions (suite, desc, enc, dec, codec) = do + enc @=? encode codec dec + dec @=? fromJust (decode codec enc) -- {{{1 uuencode tests uuTestData = @@ -43,23 +33,19 @@ , ("uu", "AAAA", "04%!00", [65, 65, 65, 65], uu) , ("uu", "Example", "17AA;7!L90", [69,120,97,109,112,108,101], uu) ] -uuTests = buildTestList uuTestData +case_uuTests = mapM_ checkAssertions uuTestData -uuTests2 = test - [ "uu unchop.chop" ~: "EI2" ~=? unchop uu (chop uu 1 "EI2") - , "uu unchop.chop" ~: "EI3-" ~=? unchop uu (chop uu 1 "EI3-") - , "uu unchop.chop" ~: "EI3-EE" ~=? unchop uu (chop uu 1 "EI3-EE") - , "uu full circle" ~: [0..255] ~=? fromJust (decode uu $ unchop uu $ chop uu 1 $ encode uu [0..255]) - , "uu full circle" ~: [0..255] ~=? fromJust (decode uu $ unchop uu $ chop uu 61 $ encode uu [0..255]) - , "uu full circle" ~: [0..255] ~=? fromJust (decode uu $ unchop uu $ chop uu 100 $ encode uu [0..255]) - ] +case_uuTests2 = do + "EI2" @=? unchop uu (chop uu 1 "EI2") + "EI3-" @=? unchop uu (chop uu 1 "EI3-") + "EI3-EE" @=? unchop uu (chop uu 1 "EI3-EE") + [0..255] @=? fromJust (decode uu $ unchop uu $ chop uu 1 $ encode uu [0..255]) + [0..255] @=? fromJust (decode uu $ unchop uu $ chop uu 61 $ encode uu [0..255]) + [0..255] @=? fromJust (decode uu $ unchop uu $ chop uu 100 $ encode uu [0..255]) -uuTestsFail = test - [ "uu decode short" ~: Nothing ~=? decode uu "A" - , "uu decode' short" ~: [Nothing] ~=? decode' uu "A" - , "uu decode illegal" ~: Nothing ~=? decode uu "aa" - , "uu decode' illegal" ~: [Nothing] ~=? decode' uu "aa" - ] +case_uuTestsFail = do + Nothing @=? decode uu "A" + Nothing @=? decode uu "aa" -- {{{1 xxencode tests xxTestData = @@ -71,23 +57,19 @@ , ("xx", "AAAA", "EI3-EE", [65, 65, 65, 65], xx) , ("xx", "Example", "FLVVPL-gNE", [69,120,97,109,112,108,101], xx) ] -xxTests = buildTestList xxTestData +case_xxTest = mapM_ checkAssertions xxTestData -xxTests2 = test - [ "xx unchop.chop" ~: "EI2" ~=? unchop xx (chop xx 1 "EI2") - , "xx unchop.chop" ~: "EI3-" ~=? unchop xx (chop xx 1 "EI3-") - , "xx unchop.chop" ~: "EI3-EE" ~=? unchop xx (chop xx 1 "EI3-EE") - , "xx full circle" ~: [0..255] ~=? fromJust (decode xx $ unchop xx $ chop xx 1 $ encode xx [0..255]) - , "xx full circle" ~: [0..255] ~=? fromJust (decode xx $ unchop xx $ chop xx 61 $ encode xx [0..255]) - , "xx full circle" ~: [0..255] ~=? fromJust (decode xx $ unchop xx $ chop xx 100 $ encode xx [0..255]) - ] +case_xxTests2 = do + "EI2" @=? unchop xx (chop xx 1 "EI2") + "EI3-" @=? unchop xx (chop xx 1 "EI3-") + "EI3-EE" @=? unchop xx (chop xx 1 "EI3-EE") + [0..255] @=? fromJust (decode xx $ unchop xx $ chop xx 1 $ encode xx [0..255]) + [0..255] @=? fromJust (decode xx $ unchop xx $ chop xx 61 $ encode xx [0..255]) + [0..255] @=? fromJust (decode xx $ unchop xx $ chop xx 100 $ encode xx [0..255]) -xxTestsFail = test - [ "xx decode short" ~: Nothing ~=? decode xx "A" - , "xx decode' short" ~: [Nothing] ~=? decode' xx "A" - , "xx decode illegal" ~: Nothing ~=? decode xx "''" - , "xx decode' illegal" ~: [Nothing] ~=? decode' xx "''" - ] +case_xxTestsFail = do + Nothing @=? decode xx "A" + Nothing @=? decode xx "''" -- {{{1 base85 tests base85TestData = @@ -101,15 +83,16 @@ , ("base85", "\0", "!!", [0], base85) , ("base85", "foob\0\0\0\0ar", "AoDTszEW", [102,111,111,98,0,0,0,0,114], base85) , ("base85", "Example", "7<0x1f><0x20><0x7e><0x7f><0xff>", "\\x00\\x1F ~\\x7F\\xFF", [0x00, 0x1f, 0x20, 0x7e, 0x7f, 0xff], py) , ("py", "\"\'\\", "\\\"\\'\\\\", [34, 39, 92], py) ] -pyTests = buildTestList pyTestData +case_pyTests = mapM_ checkAssertions pyTestData -pyTestsFail = test - [ "py decode bad char after \\" ~: Nothing ~=? decode py "\\z" - , "py decode' bad char after \\" ~: [Nothing] ~=? decode' py "\\z" - ] +case_pyTestsFail = do + Nothing @=? decode py "\\z" -- {{{1 url encoding urlTestData = @@ -251,40 +215,11 @@ , ("url", "aA", "aA", [97, 65], url) , ("url", "~ ", "~%20", [126, 0x20], url) ] -urlTests = buildTestList urlTestData +case_urlTests = mapM_ checkAssertions urlTestData -urlTestsFail = test - [ "url decode bad char after %" ~: Nothing ~=? decode url "%ga" - , "url decode' bad char after %" ~: [Nothing] ~=? decode' url "%ga" - , "url decode bad char after %" ~: Nothing ~=? decode url "%%" - , "url decode' bad char after %" ~: [Nothing] ~=? decode' url "%%" - ] +case_urlTestsFail = do + Nothing @=? decode url "%ga" + Nothing @=? decode url "%%" -- {{{1 all the tests -allTests = concat - [ unitTest2TFTest uuTests - , unitTest2TFTest uuTests2 - , unitTest2TFTest uuTestsFail - , unitTest2TFTest xxTests - , unitTest2TFTest xxTests2 - , unitTest2TFTest xxTestsFail - , unitTest2TFTest base85Tests - , unitTest2TFTest base85TestsFail - , unitTest2TFTest base64Tests - , unitTest2TFTest base64TestsFail - , unitTest2TFTest base64UrlTests - , unitTest2TFTest base32Tests - , unitTest2TFTest base32TestsFail - , unitTest2TFTest base32HexTests - , unitTest2TFTest base32HexTestsFail - , unitTest2TFTest base16Tests - , unitTest2TFTest base16TestsFail - , unitTest2TFTest yencTests - , unitTest2TFTest qpTests - , unitTest2TFTest qpTestsSucc - , unitTest2TFTest qpTestsFail - , unitTest2TFTest pyTests - , unitTest2TFTest pyTestsFail - , unitTest2TFTest urlTests - , unitTest2TFTest urlTestsFail - ] +allTests = $(testGroupGenerator) diff --git a/test-src/Test.hs b/test-src/Test.hs --- a/test-src/Test.hs +++ b/test-src/Test.hs @@ -11,9 +11,6 @@ import qualified DataencQC as DQC import qualified DataencUT as DUT -tests = - [ testGroup "quickcheck" DQC.allTests - , testGroup "unit test" DUT.allTests - ] +tests = [ DQC.allTests , DUT.allTests ] main = defaultMain tests