diff -Nru haskell-asn1-encoding-0.8.1.1/asn1-encoding.cabal haskell-asn1-encoding-0.9.3/asn1-encoding.cabal --- haskell-asn1-encoding-0.8.1.1/asn1-encoding.cabal 2013-09-19 10:17:24.000000000 +0000 +++ haskell-asn1-encoding-0.9.3/asn1-encoding.cabal 2015-09-21 13:12:05.000000000 +0000 @@ -1,31 +1,20 @@ Name: asn1-encoding -Version: 0.8.1.1 +Version: 0.9.3 +Synopsis: ASN1 data reader and writer in RAW, BER and DER forms Description: ASN1 data reader and writer in raw form with supports for high level forms of ASN1 (BER, and DER). License: BSD3 License-file: LICENSE Copyright: Vincent Hanquez Author: Vincent Hanquez -Maintainer: Vincent Hanquez -Synopsis: ASN1 data reader and writer in RAW, BER and DER forms -Build-Type: Simple +Maintainer: vincent@snarc.org Category: Data stability: experimental -Cabal-Version: >=1.6 +Build-Type: Simple +Cabal-Version: >=1.10 Homepage: http://github.com/vincenthz/hs-asn1 -Flag test - Description: Build unit test - Default: False - Library - Build-Depends: base >= 3 && < 5 - , bytestring - , text >= 0.11 - , mtl - , time - , asn1-types >= 0.2.1 && < 0.3 - Exposed-modules: Data.ASN1.Error Data.ASN1.BinaryEncoding Data.ASN1.BinaryEncoding.Raw @@ -38,21 +27,30 @@ Data.ASN1.Internal Data.ASN1.Serialize Data.ASN1.Get - ghc-options: -Wall + Build-Depends: base >= 3 && < 5 + , bytestring + , hourglass >= 0.2.6 + , asn1-types >= 0.3.0 && < 0.4 + ghc-options: -Wall -fwarn-tabs + Default-Language: Haskell2010 -Executable Tests +Test-Suite tests-asn1-encoding + type: exitcode-stdio-1.0 + hs-source-dirs: tests . Main-Is: Tests.hs - if flag(test) - Buildable: True - Build-depends: base >= 3 && < 7 - , HUnit - , QuickCheck >= 2 + Build-depends: base >= 3 && < 7 , bytestring - , test-framework >= 0.3 - , test-framework-quickcheck2 >= 0.2 - else - Buildable: False + , text + , mtl + , tasty + , tasty-quickcheck + , asn1-types + , asn1-encoding + , hourglass + ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures + Default-Language: Haskell2010 source-repository head type: git location: git://github.com/vincenthz/hs-asn1 + subdir: asn1-encoding diff -Nru haskell-asn1-encoding-0.8.1.1/Data/ASN1/BinaryEncoding/Parse.hs haskell-asn1-encoding-0.9.3/Data/ASN1/BinaryEncoding/Parse.hs --- haskell-asn1-encoding-0.8.1.1/Data/ASN1/BinaryEncoding/Parse.hs 2013-09-19 10:17:24.000000000 +0000 +++ haskell-asn1-encoding-0.9.3/Data/ASN1/BinaryEncoding/Parse.hs 2015-09-21 13:12:05.000000000 +0000 @@ -43,6 +43,11 @@ type ParsePosition = Word64 -- | represent the parsing state of an ASN1 stream. +-- +-- * the stack of constructed elements. +-- * the next expected type. +-- * the position in the stream. +-- data ParseState = ParseState [ConstructionEndAt] ParseExpect ParsePosition -- | create a new empty parse state. position is 0 @@ -96,7 +101,7 @@ Partial f -> Right (([], ParseState stackEnd (ExpectHeader $ Just f) pos), B.empty) Done hdr nPos remBytes | isEOC hdr -> case stackEnd of - [] -> Left StreamUnexpectedEOC + [] -> Right (([], ParseState [] (ExpectHeader Nothing) nPos), remBytes) Just _:_ -> Left StreamUnexpectedEOC Nothing:newStackEnd -> Right ( ( [ConstructionEnd] , ParseState newStackEnd (ExpectHeader Nothing) nPos) diff -Nru haskell-asn1-encoding-0.8.1.1/Data/ASN1/Encoding.hs haskell-asn1-encoding-0.9.3/Data/ASN1/Encoding.hs --- haskell-asn1-encoding-0.8.1.1/Data/ASN1/Encoding.hs 2013-09-19 10:17:24.000000000 +0000 +++ haskell-asn1-encoding-0.9.3/Data/ASN1/Encoding.hs 2015-09-21 13:12:05.000000000 +0000 @@ -37,7 +37,7 @@ class ASN1Encoding a where -- | encode a stream into a lazy bytestring encodeASN1 :: a -> [ASN1] -> L.ByteString - + -- | decode a strict bytestring into an ASN1 stream decodeASN1' :: ASN1Decoding a => a -> B.ByteString -> Either ASN1Error [ASN1] decodeASN1' encoding bs = decodeASN1 encoding $ L.fromChunks [bs] diff -Nru haskell-asn1-encoding-0.8.1.1/Data/ASN1/Get.hs haskell-asn1-encoding-0.9.3/Data/ASN1/Get.hs --- haskell-asn1-encoding-0.8.1.1/Data/ASN1/Get.hs 2013-09-19 10:17:24.000000000 +0000 +++ haskell-asn1-encoding-0.9.3/Data/ASN1/Get.hs 2015-09-21 13:12:05.000000000 +0000 @@ -72,7 +72,7 @@ -- | The Get monad is an Exception and State monad. newtype Get a = Get - { unGet :: forall r. Input -> Buffer -> More -> Position -> Failure r -> Success a r -> Result r } + { unGet :: forall r. Input -> Buffer -> More -> Position -> Failure r -> Success a r -> Result r } append :: Buffer -> Buffer -> Buffer append l r = B.append `fmap` l <*> r diff -Nru haskell-asn1-encoding-0.8.1.1/Data/ASN1/Prim.hs haskell-asn1-encoding-0.9.3/Data/ASN1/Prim.hs --- haskell-asn1-encoding-0.8.1.1/Data/ASN1/Prim.hs 2013-09-19 10:17:24.000000000 +0000 +++ haskell-asn1-encoding-0.9.3/Data/ASN1/Prim.hs 2015-09-21 13:12:05.000000000 +0000 @@ -10,36 +10,36 @@ {-# LANGUAGE ViewPatterns #-} module Data.ASN1.Prim - ( - -- * ASN1 high level algebraic type - ASN1(..) - , ASN1ConstructionType(..) - - , encodeHeader - , encodePrimitiveHeader - , encodePrimitive - , decodePrimitive - , encodeConstructed - , encodeList - , encodeOne - , mkSmallestLength - - -- * marshall an ASN1 type from a val struct or a bytestring - , getBoolean - , getInteger - , getBitString - , getOctetString - , getNull - , getOID - , getTime - - -- * marshall an ASN1 type to a bytestring - , putTime - , putInteger - , putBitString - , putString - , putOID - ) where + ( + -- * ASN1 high level algebraic type + ASN1(..) + , ASN1ConstructionType(..) + + , encodeHeader + , encodePrimitiveHeader + , encodePrimitive + , decodePrimitive + , encodeConstructed + , encodeList + , encodeOne + , mkSmallestLength + + -- * marshall an ASN1 type from a val struct or a bytestring + , getBoolean + , getInteger + , getBitString + , getOctetString + , getNull + , getOID + , getTime + + -- * marshall an ASN1 type to a bytestring + , putTime + , putInteger + , putBitString + , putString + , putOID + ) where import Data.ASN1.Internal import Data.ASN1.Stream @@ -52,11 +52,10 @@ import Data.Word import Data.List (unfoldr) import Data.ByteString (ByteString) -import Data.Char (ord) +import Data.Char (ord, isDigit) import qualified Data.ByteString as B -import Data.Time.Calendar -import Data.Time.Clock -import Data.Time.LocalTime +import qualified Data.ByteString.Char8 as BC +import Data.Hourglass import Control.Applicative import Control.Arrow (first) @@ -73,15 +72,15 @@ where characterStringType UTF8 = 0xc characterStringType Numeric = 0x12 characterStringType Printable = 0x13 - characterStringType T61 = 0x14 - characterStringType VideoTex = 0x15 - characterStringType IA5 = 0x16 - characterStringType Graphic = 0x19 - characterStringType Visible = 0x1a - characterStringType General = 0x1b - characterStringType UTF32 = 0x1c + characterStringType T61 = 0x14 + characterStringType VideoTex = 0x15 + characterStringType IA5 = 0x16 + characterStringType Graphic = 0x19 + characterStringType Visible = 0x1a + characterStringType General = 0x1b + characterStringType UTF32 = 0x1c characterStringType Character = 0x1d - characterStringType BMP = 0x1e + characterStringType BMP = 0x1e encodeHeader pc len (ASN1Time TimeUTC _ _) = ASN1Header Universal 0x17 pc len encodeHeader pc len (ASN1Time TimeGeneralized _ _) = ASN1Header Universal 0x18 pc len encodeHeader pc len (Start Sequence) = ASN1Header Universal 0x10 pc len @@ -109,16 +108,16 @@ encodePrimitive :: ASN1 -> (Int, [ASN1Event]) encodePrimitive a = - let b = encodePrimitiveData a in - let blen = B.length b in - let len = makeLength blen in - let hdr = encodePrimitiveHeader len a in - (B.length (putHeader hdr) + blen, [Header hdr, Primitive b]) - where - makeLength len - | len < 0x80 = LenShort len - | otherwise = LenLong (nbBytes len) len - nbBytes nb = if nb > 255 then 1 + nbBytes (nb `div` 256) else 1 + let b = encodePrimitiveData a + blen = B.length b + len = makeLength blen + hdr = encodePrimitiveHeader len a + in (B.length (putHeader hdr) + blen, [Header hdr, Primitive b]) + where + makeLength len + | len < 0x80 = LenShort len + | otherwise = LenLong (nbBytes len) len + nbBytes nb = if nb > 255 then 1 + nbBytes (nb `div` 256) else 1 encodeOne :: ASN1 -> (Int, [ASN1Event]) encodeOne (Start _) = error "encode one cannot do start" @@ -128,31 +127,31 @@ encodeList [] = (0, []) encodeList (End _:xs) = encodeList xs encodeList (t@(Start _):xs) = - let (ys, zs) = getConstructedEnd 0 xs in - let (llen, lev) = encodeList zs in - let (len, ev) = encodeConstructed t ys in - (llen + len, ev ++ lev) + let (ys, zs) = getConstructedEnd 0 xs + (llen, lev) = encodeList zs + (len, ev) = encodeConstructed t ys + in (llen + len, ev ++ lev) encodeList (x:xs) = - let (llen, lev) = encodeList xs in - let (len, ev) = encodeOne x in - (llen + len, ev ++ lev) + let (llen, lev) = encodeList xs + (len, ev) = encodeOne x + in (llen + len, ev ++ lev) encodeConstructed :: ASN1 -> [ASN1] -> (Int, [ASN1Event]) encodeConstructed c@(Start _) children = - let (clen, events) = encodeList children in - let len = mkSmallestLength clen in - let h = encodeHeader True len c in - let tlen = B.length (putHeader h) + clen in - (tlen, Header h : ConstructionBegin : events ++ [ConstructionEnd]) + (tlen, Header h : ConstructionBegin : events ++ [ConstructionEnd]) + where (clen, events) = encodeList children + len = mkSmallestLength clen + h = encodeHeader True len c + tlen = B.length (putHeader h) + clen encodeConstructed _ _ = error "not a start node" mkSmallestLength :: Int -> ASN1Length mkSmallestLength i - | i < 0x80 = LenShort i - | otherwise = LenLong (nbBytes i) i - where nbBytes nb = if nb > 255 then 1 + nbBytes (nb `div` 256) else 1 + | i < 0x80 = LenShort i + | otherwise = LenLong (nbBytes i) i + where nbBytes nb = if nb > 255 then 1 + nbBytes (nb `div` 256) else 1 type ASN1Ret = Either ASN1Error ASN1 @@ -190,12 +189,12 @@ getBoolean :: Bool -> ByteString -> Either ASN1Error ASN1 getBoolean isDer s = - if B.length s == 1 - then case B.head s of - 0 -> Right (Boolean False) - 0xff -> Right (Boolean True) - _ -> if isDer then Left $ PolicyFailed "DER" "boolean value not canonical" else Right (Boolean True) - else Left $ TypeDecodingFailed "boolean: length not within bound" + if B.length s == 1 + then case B.head s of + 0 -> Right (Boolean False) + 0xff -> Right (Boolean True) + _ -> if isDer then Left $ PolicyFailed "DER" "boolean value not canonical" else Right (Boolean True) + else Left $ TypeDecodingFailed "boolean: length not within bound" {- | getInteger, parse a value bytestring and get the integer out of the two complement encoded bytes -} getInteger :: ByteString -> Either ASN1Error ASN1 @@ -210,24 +209,24 @@ {- | According to X.690 section 8.4 integer and enumerated values should be encoded the same way. -} getIntegerRaw :: String -> ByteString -> Either ASN1Error Integer getIntegerRaw typestr s - | B.length s == 0 = Left . TypeDecodingFailed $ typestr ++ ": null encoding" - | B.length s == 1 = Right $ snd $ intOfBytes s - | otherwise = - if (v1 == 0xff && testBit v2 7) || (v1 == 0x0 && (not $ testBit v2 7)) - then Left . TypeDecodingFailed $ typestr ++ ": not shortest encoding" - else Right $ snd $ intOfBytes s - where - v1 = s `B.index` 0 - v2 = s `B.index` 1 + | B.length s == 0 = Left . TypeDecodingFailed $ typestr ++ ": null encoding" + | B.length s == 1 = Right $ snd $ intOfBytes s + | otherwise = + if (v1 == 0xff && testBit v2 7) || (v1 == 0x0 && (not $ testBit v2 7)) + then Left . TypeDecodingFailed $ typestr ++ ": not shortest encoding" + else Right $ snd $ intOfBytes s + where + v1 = s `B.index` 0 + v2 = s `B.index` 1 getBitString :: ByteString -> Either ASN1Error ASN1 getBitString s = - let toSkip = B.head s in - let toSkip' = if toSkip >= 48 && toSkip <= 48 + 7 then toSkip - (fromIntegral $ ord '0') else toSkip in - let xs = B.tail s in - if toSkip' >= 0 && toSkip' <= 7 - then Right $ BitString $ toBitArray xs (fromIntegral toSkip') - else Left $ TypeDecodingFailed ("bitstring: skip number not within bound " ++ show toSkip' ++ " " ++ show s) + let toSkip = B.head s in + let toSkip' = if toSkip >= 48 && toSkip <= 48 + 7 then toSkip - (fromIntegral $ ord '0') else toSkip in + let xs = B.tail s in + if toSkip' >= 0 && toSkip' <= 7 + then Right $ BitString $ toBitArray xs (fromIntegral toSkip') + else Left $ TypeDecodingFailed ("bitstring: skip number not within bound " ++ show toSkip' ++ " " ++ show s) getCharacterString :: ASN1StringEncoding -> ByteString -> Either ASN1Error ASN1 getCharacterString encoding bs = Right $ ASN1String (ASN1CharacterString encoding bs) @@ -243,123 +242,123 @@ {- | return an OID -} getOID :: ByteString -> Either ASN1Error ASN1 getOID s = Right $ OID $ (fromIntegral (x `div` 40) : fromIntegral (x `mod` 40) : groupOID xs) - where - (x:xs) = B.unpack s + where + (x:xs) = B.unpack s - groupOID :: [Word8] -> [Integer] - groupOID = map (foldl (\acc n -> (acc `shiftL` 7) + fromIntegral n) 0) . groupSubOID + groupOID :: [Word8] -> [Integer] + groupOID = map (foldl (\acc n -> (acc `shiftL` 7) + fromIntegral n) 0) . groupSubOID - groupSubOIDHelper [] = Nothing - groupSubOIDHelper l = Just $ spanSubOIDbound l + groupSubOIDHelper [] = Nothing + groupSubOIDHelper l = Just $ spanSubOIDbound l - groupSubOID :: [Word8] -> [[Word8]] - groupSubOID = unfoldr groupSubOIDHelper + groupSubOID :: [Word8] -> [[Word8]] + groupSubOID = unfoldr groupSubOIDHelper - spanSubOIDbound [] = ([], []) - spanSubOIDbound (a:as) = if testBit a 7 then (clearBit a 7 : ys, zs) else ([a], as) - where (ys, zs) = spanSubOIDbound as + spanSubOIDbound [] = ([], []) + spanSubOIDbound (a:as) = if testBit a 7 then (clearBit a 7 : ys, zs) else ([a], as) + where (ys, zs) = spanSubOIDbound as getTime :: ASN1TimeType -> ByteString -> Either ASN1Error ASN1 -getTime timeType (B.unpack -> b) = Right $ ASN1Time timeType (UTCTime cDay cDiffTime) tz - where - cDay = fromGregorian year (fromIntegral month) (fromIntegral day) - cDiffTime = secondsToDiffTime (hour * 3600 + minute * 60 + sec) + - picosecondsToDiffTime msec --picosecondsToDiffTime (msec * ) - (year, b2) = case timeType of - TimeUTC -> first ((1900 +) . centurize . toInt) $ splitAt 2 b - TimeGeneralized -> first toInt $ splitAt 4 b - (month, b3) = first toInt $ splitAt 2 b2 - (day, b4) = first toInt $ splitAt 2 b3 - (hour, b5) = first toInt $ splitAt 2 b4 - (minute, b6) = first toInt $ splitAt 2 b5 - (sec, b7) = first toInt $ splitAt 2 b6 - (msec, b8) = case b7 of -- parse .[0-9] - 0x2e:b7' -> first toPico $ spanToLength 3 (\c -> fromIntegral c >= ord '0' && fromIntegral c <= ord '9') b7' - _ -> (0,b7) - (tz, _) = case b8 of - 0x5a:b8' -> (Just utc, b8') -- zulu - 0x2b:b8' -> (Just undefined, b8') -- + - 0x2d:b8' -> (Just undefined, b8') -- - - _ -> (Nothing, b8) - - spanToLength :: Int -> (Word8 -> Bool) -> [Word8] -> ([Word8], [Word8]) - spanToLength len p l = loop 0 l - where loop i z - | i >= len = ([], z) - | otherwise = case z of - [] -> ([], []) - x:xs -> if p x - then let (r1,r2) = loop (i+1) xs - in (x:r1, r2) - else ([], z) - - toPico :: [Word8] -> Integer - toPico l = toInt l * order * 1000000000 - where len = length l - order = case len of +getTime timeType bs + | hasNonASCII bs = decodingError "contains non ASCII characters" + | otherwise = + case timeParseE format (BC.unpack bs) of -- BC.unpack is safe as we check ASCIIness first + Left _ -> + case timeParseE formatNoSeconds (BC.unpack bs) of + Left _ -> decodingError ("cannot convert string " ++ BC.unpack bs) + Right r -> parseRemaining r + Right r -> parseRemaining r + where + parseRemaining r = + case parseTimezone $ parseMs $ first adjustUTC r of + Left err -> decodingError err + Right (dt', tz) -> Right $ ASN1Time timeType dt' tz + + adjustUTC dt@(DateTime (Date y m d) tod) + | timeType == TimeGeneralized = dt + | y > 2050 = DateTime (Date (y - 100) m d) tod + | otherwise = dt + formatNoSeconds = init format + format | timeType == TimeGeneralized = 'Y':'Y':baseFormat + | otherwise = baseFormat + baseFormat = "YYMMDDHMIS" + + parseMs (dt,s) = + case s of + '.':s' -> let (ns, r) = first toNano $ spanToLength 3 isDigit s' + in (dt { dtTime = (dtTime dt) { todNSec = ns } }, r) + _ -> (dt,s) + parseTimezone (dt,s) = + case s of + '+':s' -> Right (dt, parseTimezoneFormat id s') + '-':s' -> Right (dt, parseTimezoneFormat ((-1) *) s') + 'Z':[] -> Right (dt, Just timezone_UTC) + "" -> Right (dt, Nothing) + _ -> Left ("unknown timezone format: " ++ s) + + parseTimezoneFormat transform s + | length s == 4 = Just $ toTz $ toInt $ fst $ spanToLength 4 isDigit s + | otherwise = Nothing + where toTz z = let (h,m) = z `divMod` 100 in TimezoneOffset $ transform (h * 60 + m) + + toNano :: String -> NanoSeconds + toNano l = fromIntegral (toInt l * order * 1000000) + where len = length l + order = case len of 1 -> 100 2 -> 10 3 -> 1 _ -> 1 - toInt :: [Word8] -> Integer - toInt = foldl (\acc w -> acc * 10 + fromIntegral (fromIntegral w - ord '0')) 0 - - centurize v - | v <= 50 = v + 100 - | otherwise = v - -putTime :: ASN1TimeType -> UTCTime -> Maybe TimeZone -> ByteString -putTime ty (UTCTime day diff) mtz = B.pack etime - where + spanToLength :: Int -> (Char -> Bool) -> String -> (String, String) + spanToLength len p l = loop 0 l + where loop i z + | i >= len = ([], z) + | otherwise = case z of + [] -> ([], []) + x:xs -> if p x + then let (r1,r2) = loop (i+1) xs + in (x:r1, r2) + else ([], z) + + toInt :: String -> Int + toInt = foldl (\acc w -> acc * 10 + (ord w - ord '0')) 0 + + decodingError reason = Left $ TypeDecodingFailed ("time format invalid for " ++ show timeType ++ " : " ++ reason) + hasNonASCII = maybe False (const True) . B.find (\c -> c > 0x7f) + +-- FIXME need msec printed +putTime :: ASN1TimeType -> DateTime -> Maybe TimezoneOffset -> ByteString +putTime ty dt mtz = BC.pack etime + where etime - | ty == TimeUTC = [y3, y4, m1, m2, d1, d2, h1, h2, mi1, mi2, s1, s2]++tzStr - | otherwise = [y1, y2, y3, y4, m1, m2, d1, d2, h1, h2, mi1, mi2, s1, s2]++msecStr++tzStr - - charZ = 90 - + | ty == TimeUTC = timePrint "YYMMDDHMIS" dt ++ tzStr + | otherwise = timePrint "YYYYMMDDHMIS" dt ++ msecStr ++ tzStr msecStr = [] tzStr = case mtz of - Nothing -> [] - Just tz | timeZoneMinutes tz == 0 -> [charZ] - | otherwise -> asciiToWord8 $ timeZoneOffsetString tz - - (y_,m,d) = toGregorian day - y = fromIntegral y_ - - secs = truncate (realToFrac diff :: Double) :: Integer - - (h,mins) = secs `divMod` 3600 - (mi,s) = mins `divMod` 60 - - split2 n = (fromIntegral $ n `div` 10 + ord '0', fromIntegral $ n `mod` 10 + ord '0') - ((y1,y2),(y3,y4)) = (split2 (y `div` 100), split2 (y `mod` 100)) - (m1, m2) = split2 m - (d1, d2) = split2 d - (h1, h2) = split2 $ fromIntegral h - (mi1, mi2) = split2 $ fromIntegral mi - (s1, s2) = split2 $ fromIntegral s - - asciiToWord8 :: [Char] -> [Word8] - asciiToWord8 = map (fromIntegral . fromEnum) + Nothing -> "" + Just tz | tz == timezone_UTC -> "Z" + | otherwise -> show tz putInteger :: Integer -> ByteString putInteger i = B.pack $ bytesOfInt i putBitString :: BitArray -> ByteString putBitString (BitArray n bits) = - B.concat [B.singleton (fromIntegral i),bits] - where i = (8 - (n `mod` 8)) .&. 0x7 + B.concat [B.singleton (fromIntegral i),bits] + where i = (8 - (n `mod` 8)) .&. 0x7 putString :: ByteString -> ByteString putString l = l {- no enforce check that oid1 is between [0..2] and oid2 is between [0..39] -} putOID :: [Integer] -> ByteString -putOID oids = B.cons eoidclass subeoids - where - (oid1:oid2:suboids) = oids - eoidclass = fromIntegral (oid1 * 40 + oid2) - encode x | x == 0 = B.singleton 0 - | otherwise = putVarEncodingIntegral x - subeoids = B.concat $ map encode suboids +putOID oids = case oids of + (oid1:oid2:suboids) -> + let eoidclass = fromIntegral (oid1 * 40 + oid2) + subeoids = B.concat $ map encode suboids + in B.cons eoidclass subeoids + _ -> error ("invalid OID format " ++ show oids) + where + encode x | x == 0 = B.singleton 0 + | otherwise = putVarEncodingIntegral x diff -Nru haskell-asn1-encoding-0.8.1.1/Data/ASN1/Serialize.hs haskell-asn1-encoding-0.9.3/Data/ASN1/Serialize.hs --- haskell-asn1-encoding-0.8.1.1/Data/ASN1/Serialize.hs 2013-09-19 10:17:24.000000000 +0000 +++ haskell-asn1-encoding-0.9.3/Data/ASN1/Serialize.hs 2015-09-21 13:12:05.000000000 +0000 @@ -20,33 +20,32 @@ -- | parse an ASN1 header getHeader :: Get ASN1Header getHeader = do - (cl,pc,t1) <- parseFirstWord <$> getWord8 - tag <- if t1 == 0x1f then getTagLong else return t1 - len <- getLength - return $ ASN1Header cl tag pc len + (cl,pc,t1) <- parseFirstWord <$> getWord8 + tag <- if t1 == 0x1f then getTagLong else return t1 + len <- getLength + return $ ASN1Header cl tag pc len -- | Parse the first word of an header parseFirstWord :: Word8 -> (ASN1Class, Bool, ASN1Tag) parseFirstWord w = (cl,pc,t1) - where - cl = toEnum $ fromIntegral $ (w `shiftR` 6) - pc = testBit w 5 - t1 = fromIntegral (w .&. 0x1f) + where cl = toEnum $ fromIntegral $ (w `shiftR` 6) + pc = testBit w 5 + t1 = fromIntegral (w .&. 0x1f) {- when the first tag is 0x1f, the tag is in long form, where - we get bytes while the 7th bit is set. -} getTagLong :: Get ASN1Tag getTagLong = do - t <- fromIntegral <$> getWord8 - when (t == 0x80) $ error "not canonical encoding of tag" - if testBit t 7 - then loop (clearBit t 7) - else return t - where loop n = do - t <- fromIntegral <$> getWord8 - if testBit t 7 - then loop (n `shiftL` 7 + clearBit t 7) - else return (n `shiftL` 7 + t) + t <- fromIntegral <$> getWord8 + when (t == 0x80) $ error "not canonical encoding of tag" + if testBit t 7 + then loop (clearBit t 7) + else return t + where loop n = do + t <- fromIntegral <$> getWord8 + if testBit t 7 + then loop (n `shiftL` 7 + clearBit t 7) + else return (n `shiftL` 7 + t) {- get the asn1 length which is either short form if 7th bit is not set, @@ -55,25 +54,25 @@ -} getLength :: Get ASN1Length getLength = do - l1 <- fromIntegral <$> getWord8 - if testBit l1 7 - then case clearBit l1 7 of - 0 -> return LenIndefinite - len -> do - lw <- getBytes len - return (LenLong len $ uintbs lw) - else - return (LenShort l1) - where - {- uintbs return the unsigned int represented by the bytes -} - uintbs = B.foldl (\acc n -> (acc `shiftL` 8) + fromIntegral n) 0 + l1 <- fromIntegral <$> getWord8 + if testBit l1 7 + then case clearBit l1 7 of + 0 -> return LenIndefinite + len -> do + lw <- getBytes len + return (LenLong len $ uintbs lw) + else + return (LenShort l1) + where + {- uintbs return the unsigned int represented by the bytes -} + uintbs = B.foldl (\acc n -> (acc `shiftL` 8) + fromIntegral n) 0 -- | putIdentifier encode an ASN1 Identifier into a marshalled value putHeader :: ASN1Header -> B.ByteString putHeader (ASN1Header cl tag pc len) = B.concat - [B.singleton word1 - ,if tag < 0x1f then B.empty else tagBS - ,lenBS] + [ B.singleton word1 + , if tag < 0x1f then B.empty else tagBS + , lenBS] where cli = shiftL (fromIntegral $ fromEnum cl) 6 pcval = shiftL (if pc then 0x1 else 0x0) 5 tag0 = if tag < 0x1f then fromIntegral tag else 0x1f @@ -85,12 +84,12 @@ - see getLength for the encoding rules -} putLength :: ASN1Length -> [Word8] putLength (LenShort i) - | i < 0 || i > 0x7f = error "putLength: short length is not between 0x0 and 0x80" - | otherwise = [fromIntegral i] + | i < 0 || i > 0x7f = error "putLength: short length is not between 0x0 and 0x80" + | otherwise = [fromIntegral i] putLength (LenLong _ i) - | i < 0 = error "putLength: long length is negative" - | otherwise = lenbytes : lw - where - lw = bytesOfUInt $ fromIntegral i - lenbytes = fromIntegral (length lw .|. 0x80) + | i < 0 = error "putLength: long length is negative" + | otherwise = lenbytes : lw + where + lw = bytesOfUInt $ fromIntegral i + lenbytes = fromIntegral (length lw .|. 0x80) putLength (LenIndefinite) = [0x80] diff -Nru haskell-asn1-encoding-0.8.1.1/debian/changelog haskell-asn1-encoding-0.9.3/debian/changelog --- haskell-asn1-encoding-0.8.1.1/debian/changelog 2013-12-09 10:42:34.000000000 +0000 +++ haskell-asn1-encoding-0.9.3/debian/changelog 2016-01-04 01:03:47.000000000 +0000 @@ -1,8 +1,58 @@ -haskell-asn1-encoding (0.8.1.1-1build1) trusty; urgency=low +haskell-asn1-encoding (0.9.3-1~ubuntu14.04.1~ppa1) trusty; urgency=medium - * Rebuild for new GHC ABIs. + * No-change backport to trusty - -- Colin Watson Mon, 09 Dec 2013 10:42:34 +0000 + -- Justin Geibel Sun, 03 Jan 2016 20:03:47 -0500 + +haskell-asn1-encoding (0.9.3-1) unstable; urgency=medium + + * New upstream release + + -- Clint Adams Thu, 03 Dec 2015 23:51:33 -0500 + +haskell-asn1-encoding (0.9.0-5) unstable; urgency=medium + + * Switch Vcs-Git/Vcs-Browser headers to new location. + + -- Clint Adams Thu, 03 Dec 2015 14:54:04 -0500 + +haskell-asn1-encoding (0.9.0-4) experimental; urgency=medium + + * Bump standards-version to 3.9.6 + * Depend on haskell-devscripts >= 0.10 to ensure that this package + builds against GHC in experimental + + -- Joachim Breitner Thu, 20 Aug 2015 10:26:57 +0200 + +haskell-asn1-encoding (0.9.0-3) unstable; urgency=medium + + * Rebuild due to haskell-devscripts bug affecting the previous + + -- Joachim Breitner Tue, 28 Apr 2015 23:58:16 +0200 + +haskell-asn1-encoding (0.9.0-2) unstable; urgency=medium + + * Upload to unstable + + -- Joachim Breitner Mon, 27 Apr 2015 11:47:38 +0200 + +haskell-asn1-encoding (0.9.0-1) experimental; urgency=medium + + * New upstream release + + -- Joachim Breitner Sun, 05 Apr 2015 16:30:36 +0200 + +haskell-asn1-encoding (0.8.1.3-2) experimental; urgency=medium + + * Depend on haskell-devscripts 0.9, found in experimental + + -- Joachim Breitner Sat, 20 Dec 2014 17:09:28 +0100 + +haskell-asn1-encoding (0.8.1.3-1) unstable; urgency=medium + + * New upstream version. + + -- Clint Adams Mon, 03 Mar 2014 15:28:55 -0500 haskell-asn1-encoding (0.8.1.1-1) unstable; urgency=low diff -Nru haskell-asn1-encoding-0.8.1.1/debian/control haskell-asn1-encoding-0.9.3/debian/control --- haskell-asn1-encoding-0.8.1.1/debian/control 2013-10-07 03:37:16.000000000 +0000 +++ haskell-asn1-encoding-0.9.3/debian/control 2015-12-04 05:05:09.000000000 +0000 @@ -1,40 +1,37 @@ Source: haskell-asn1-encoding -Section: haskell -Priority: extra Maintainer: Debian Haskell Group Uploaders: Clint Adams -Build-Depends: debhelper (>= 9) - , cdbs - , haskell-devscripts (>= 0.8.15) - , ghc - , ghc-prof - , libghc-asn1-types-dev (>> 0.2.1) - , libghc-asn1-types-dev (<< 0.3) - , libghc-asn1-types-prof - , libghc-mtl-dev - , libghc-mtl-prof - , libghc-text-dev (>> 0.11) - , libghc-text-prof -Build-Depends-Indep: ghc-doc - , libghc-asn1-types-doc - , libghc-mtl-doc - , libghc-text-doc -Standards-Version: 3.9.4 -Homepage: http://hackage.haskell.org/package/asn1-encoding -Vcs-Darcs: http://darcs.debian.org/pkg-haskell/haskell-asn1-encoding -Vcs-Browser: http://darcs.debian.org/cgi-bin/darcsweb.cgi?r=pkg-haskell/haskell-asn1-encoding +Priority: extra +Section: haskell +Build-Depends: debhelper (>= 9), + haskell-devscripts (>= 0.10), + cdbs, + ghc, + ghc-prof, + libghc-asn1-types-dev (>= 0.3.0), + libghc-asn1-types-dev (<< 0.4), + libghc-asn1-types-prof, + libghc-hourglass-dev (>= 0.2.6), + libghc-hourglass-prof, +Build-Depends-Indep: ghc-doc, + libghc-asn1-types-doc, + libghc-hourglass-doc, +Standards-Version: 3.9.6 +Homepage: http://github.com/vincenthz/hs-asn1 +Vcs-Browser: https://anonscm.debian.org/cgit/pkg-haskell/DHG_packages.git/ +Vcs-Git: git://git.debian.org/git/pkg-haskell/DHG_packages.git X-Description: ASN1 data reader/writer in RAW, BER, and DER forms ASN1 data reader and writer in raw form with supports for high level forms of ASN1 (BER and DER). Package: libghc-asn1-encoding-dev Architecture: any -Depends: ${haskell:Depends} - , ${shlibs:Depends} - , ${misc:Depends} -Recommends: ${haskell:Recommends} -Suggests: ${haskell:Suggests} -Provides: ${haskell:Provides} +Depends: ${haskell:Depends}, + ${shlibs:Depends}, + ${misc:Depends}, +Recommends: ${haskell:Recommends}, +Suggests: ${haskell:Suggests}, +Provides: ${haskell:Provides}, Description: ${haskell:ShortDescription}${haskell:ShortBlurb} ${haskell:LongDescription} . @@ -42,22 +39,23 @@ Package: libghc-asn1-encoding-prof Architecture: any -Depends: ${haskell:Depends} - , ${misc:Depends} -Recommends: ${haskell:Recommends} -Suggests: ${haskell:Suggests} -Provides: ${haskell:Provides} +Depends: ${haskell:Depends}, + ${misc:Depends}, +Recommends: ${haskell:Recommends}, +Suggests: ${haskell:Suggests}, +Provides: ${haskell:Provides}, Description: ${haskell:ShortDescription}${haskell:ShortBlurb} ${haskell:LongDescription} . ${haskell:Blurb} Package: libghc-asn1-encoding-doc -Section: doc Architecture: all -Depends: ${misc:Depends}, ${haskell:Depends} -Recommends: ${haskell:Recommends} -Suggests: ${haskell:Suggests} +Section: doc +Depends: ${misc:Depends}, + ${haskell:Depends}, +Recommends: ${haskell:Recommends}, +Suggests: ${haskell:Suggests}, Description: ${haskell:ShortDescription}${haskell:ShortBlurb} ${haskell:LongDescription} . diff -Nru haskell-asn1-encoding-0.8.1.1/tests/Tests.hs haskell-asn1-encoding-0.9.3/tests/Tests.hs --- haskell-asn1-encoding-0.8.1.1/tests/Tests.hs 1970-01-01 00:00:00.000000000 +0000 +++ haskell-asn1-encoding-0.9.3/tests/Tests.hs 2015-09-21 13:12:05.000000000 +0000 @@ -0,0 +1,206 @@ +import Test.Tasty.QuickCheck +import Test.Tasty + +import Control.Applicative +import Data.ASN1.Get (runGet, Result(..)) +import Data.ASN1.BitArray +import Data.ASN1.Prim +import Data.ASN1.Serialize +import Data.ASN1.BinaryEncoding.Parse +import Data.ASN1.BinaryEncoding.Writer +import Data.ASN1.BinaryEncoding +import Data.ASN1.Encoding +import Data.ASN1.Types +import Data.ASN1.Types.Lowlevel + +import Data.Hourglass + +import qualified Data.ByteString as B + +import Control.Monad + +instance Arbitrary ASN1Class where + arbitrary = elements [ Universal, Application, Context, Private ] + +instance Arbitrary ASN1Length where + arbitrary = do + c <- choose (0,2) :: Gen Int + case c of + 0 -> liftM LenShort (choose (0,0x79)) + 1 -> do + nb <- choose (0x80,0x1000) + return $ mkSmallestLength nb + _ -> return LenIndefinite + where + nbBytes nb = if nb > 255 then 1 + nbBytes (nb `div` 256) else 1 + +arbitraryDefiniteLength :: Gen ASN1Length +arbitraryDefiniteLength = arbitrary `suchThat` (\l -> l /= LenIndefinite) + +arbitraryTag :: Gen ASN1Tag +arbitraryTag = choose(1,10000) + +instance Arbitrary ASN1Header where + arbitrary = liftM4 ASN1Header arbitrary arbitraryTag arbitrary arbitrary + +arbitraryEvents :: Gen ASN1Events +arbitraryEvents = do + hdr@(ASN1Header _ _ _ len) <- liftM4 ASN1Header arbitrary arbitraryTag (return False) arbitraryDefiniteLength + let blen = case len of + LenLong _ x -> x + LenShort x -> x + _ -> 0 + pr <- liftM Primitive (arbitraryBSsized blen) + return (ASN1Events [Header hdr, pr]) + +newtype ASN1Events = ASN1Events [ASN1Event] + +instance Show ASN1Events where + show (ASN1Events x) = show x + +instance Arbitrary ASN1Events where + arbitrary = arbitraryEvents + + +arbitraryOID :: Gen OID +arbitraryOID = do + i1 <- choose (0,2) :: Gen Integer + i2 <- choose (0,39) :: Gen Integer + ran <- choose (0,30) :: Gen Int + l <- replicateM ran (suchThat arbitrary (\i -> i > 0)) + return $ (i1:i2:l) + +arbitraryBSsized :: Int -> Gen B.ByteString +arbitraryBSsized len = do + ws <- replicateM len (choose (0, 255) :: Gen Int) + return $ B.pack $ map fromIntegral ws + +instance Arbitrary B.ByteString where + arbitrary = do + len <- choose (0, 529) :: Gen Int + arbitraryBSsized len + +instance Arbitrary BitArray where + arbitrary = do + bs <- arbitrary + w <- choose (0,7) :: Gen Int + return $ toBitArray bs w + +instance Arbitrary Date where + arbitrary = do + y <- choose (1951, 2050) + m <- elements [ January .. December] + d <- choose (1, 30) + return $ normalizeDate $ Date y m d + +normalizeDate :: Date -> Date +normalizeDate origDate + | y < 1951 = normalizeDate (Date (y + 50) m d) + | otherwise = normalizedDate + where + normalizedDate@(Date y m d) = timeConvert (timeConvert origDate :: Elapsed) + +instance Arbitrary TimeOfDay where + arbitrary = do + h <- choose (0, 23) + mi <- choose (0, 59) + se <- choose (0, 59) + nsec <- return 0 + return $ TimeOfDay (Hours h) (Minutes mi) (Seconds se) nsec + +instance Arbitrary DateTime where + arbitrary = DateTime <$> arbitrary <*> arbitrary + +instance Arbitrary TimezoneOffset where + arbitrary = elements [ timezone_UTC, TimezoneOffset 60, TimezoneOffset 120, TimezoneOffset (-360) ] + +instance Arbitrary Elapsed where + arbitrary = Elapsed . Seconds <$> arbitrary + +instance Arbitrary ASN1TimeType where + arbitrary = elements [TimeUTC, TimeGeneralized] + +instance Arbitrary ASN1StringEncoding where + arbitrary = elements [UTF8, Numeric, Printable, T61, VideoTex, IA5, Graphic, Visible, General, UTF32, BMP] + +arbitraryPrintString encoding = do + let printableString = (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ " ()+,-./:=?") + asn1CharacterString encoding <$> replicateM 21 (elements printableString) + +arbitraryBS encoding = ASN1CharacterString encoding . B.pack <$> replicateM 7 (choose (0,0xff)) + +arbitraryIA5String = asn1CharacterString IA5 <$> replicateM 21 (choose (toEnum 0,toEnum 127)) + +arbitraryUCS2 :: Gen ASN1CharacterString +arbitraryUCS2 = asn1CharacterString BMP <$> replicateM 12 (choose (toEnum 0,toEnum 0xffff)) + +arbitraryUnicode :: ASN1StringEncoding -> Gen ASN1CharacterString +arbitraryUnicode e = asn1CharacterString e <$> replicateM 35 (choose (toEnum 0,toEnum 0x10ffff)) + +instance Arbitrary ASN1CharacterString where + arbitrary = oneof + [ arbitraryUnicode UTF8 + , arbitraryUnicode UTF32 + , arbitraryUCS2 + , arbitraryPrintString Numeric + , arbitraryPrintString Printable + , arbitraryBS T61 + , arbitraryBS VideoTex + , arbitraryIA5String + , arbitraryPrintString Graphic + , arbitraryPrintString Visible + , arbitraryPrintString General + ] + +instance Arbitrary ASN1 where + arbitrary = oneof + [ liftM Boolean arbitrary + , liftM IntVal arbitrary + , liftM BitString arbitrary + , liftM OctetString arbitrary + , return Null + , liftM OID arbitraryOID + --, Real Double + -- , return Enumerated + , ASN1String <$> arbitrary + , ASN1Time <$> arbitrary <*> arbitrary <*> arbitrary + ] + +newtype ASN1s = ASN1s [ASN1] + +instance Show ASN1s where + show (ASN1s x) = show x + +instance Arbitrary ASN1s where + arbitrary = do + x <- choose (0,5) :: Gen Int + z <- case x of + 4 -> makeList Sequence + 3 -> makeList Set + _ -> resize 2 $ listOf1 arbitrary + return $ ASN1s z + where + makeList str = do + (ASN1s l) <- arbitrary + return ([Start str] ++ l ++ [End str]) + +prop_header_marshalling_id :: ASN1Header -> Bool +prop_header_marshalling_id v = (ofDone $ runGet getHeader $ putHeader v) == Right v + where ofDone (Done r _ _) = Right r + ofDone _ = Left "not done" + +prop_event_marshalling_id :: ASN1Events -> Bool +prop_event_marshalling_id (ASN1Events e) = (parseLBS $ toLazyByteString e) == Right e + +prop_asn1_der_marshalling_id v = (decodeASN1 DER . encodeASN1 DER) v `assertEq` Right v + where assertEq got expected + | got /= expected = error ("got: " ++ show got ++ " expected: " ++ show expected) + | otherwise = True + +marshallingTests = testGroup "Marshalling" + [ testProperty "Header" prop_header_marshalling_id + , testProperty "Event" prop_event_marshalling_id + , testProperty "DER" prop_asn1_der_marshalling_id + ] + +main = defaultMain $ testGroup "asn1-encoding" [marshallingTests] diff -Nru haskell-asn1-encoding-0.8.1.1/Tests.hs haskell-asn1-encoding-0.9.3/Tests.hs --- haskell-asn1-encoding-0.8.1.1/Tests.hs 2013-09-19 10:17:24.000000000 +0000 +++ haskell-asn1-encoding-0.9.3/Tests.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,214 +0,0 @@ -import Test.QuickCheck -import Test.Framework(defaultMain, testGroup) -import Test.Framework.Providers.QuickCheck2(testProperty) - -import Text.Printf - -import Control.Applicative -import Data.ASN1.Get (runGet, Result(..)) -import Data.ASN1.BitArray -import Data.ASN1.Stream -import Data.ASN1.Prim -import Data.ASN1.Serialize -import Data.ASN1.BinaryEncoding.Parse -import Data.ASN1.BinaryEncoding.Writer -import Data.ASN1.BinaryEncoding -import Data.ASN1.Encoding -import Data.ASN1.Types -import Data.ASN1.Types.Lowlevel -import Data.ASN1.OID - -import Data.Time.Clock -import Data.Time.Calendar -import Data.Time.LocalTime - -import Data.Word - -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import qualified Data.Text.Lazy as T - -import Control.Monad -import Control.Monad.Identity -import System.IO - -instance Arbitrary ASN1Class where - arbitrary = elements [ Universal, Application, Context, Private ] - -instance Arbitrary ASN1Length where - arbitrary = do - c <- choose (0,2) :: Gen Int - case c of - 0 -> liftM LenShort (choose (0,0x79)) - 1 -> do - nb <- choose (0x80,0x1000) - return $ mkSmallestLength nb - _ -> return LenIndefinite - where - nbBytes nb = if nb > 255 then 1 + nbBytes (nb `div` 256) else 1 - -arbitraryDefiniteLength :: Gen ASN1Length -arbitraryDefiniteLength = arbitrary `suchThat` (\l -> l /= LenIndefinite) - -arbitraryTag :: Gen ASN1Tag -arbitraryTag = choose(1,10000) - -instance Arbitrary ASN1Header where - arbitrary = liftM4 ASN1Header arbitrary arbitraryTag arbitrary arbitrary - -arbitraryEvents :: Gen ASN1Events -arbitraryEvents = do - hdr@(ASN1Header _ _ _ len) <- liftM4 ASN1Header arbitrary arbitraryTag (return False) arbitraryDefiniteLength - let blen = case len of - LenLong _ x -> x - LenShort x -> x - _ -> 0 - pr <- liftM Primitive (arbitraryBSsized blen) - return (ASN1Events [Header hdr, pr]) - -newtype ASN1Events = ASN1Events [ASN1Event] - -instance Show ASN1Events where - show (ASN1Events x) = show x - -instance Arbitrary ASN1Events where - arbitrary = arbitraryEvents - - -arbitraryOID :: Gen OID -arbitraryOID = do - i1 <- choose (0,2) :: Gen Integer - i2 <- choose (0,39) :: Gen Integer - ran <- choose (0,30) :: Gen Int - l <- replicateM ran (suchThat arbitrary (\i -> i > 0)) - return $ (i1:i2:l) - -arbitraryBSsized :: Int -> Gen B.ByteString -arbitraryBSsized len = do - ws <- replicateM len (choose (0, 255) :: Gen Int) - return $ B.pack $ map fromIntegral ws - -instance Arbitrary B.ByteString where - arbitrary = do - len <- choose (0, 529) :: Gen Int - arbitraryBSsized len - -instance Arbitrary T.Text where - arbitrary = do - len <- choose (0, 529) :: Gen Int - ws <- replicateM len arbitrary - return $ T.pack ws - -instance Arbitrary BitArray where - arbitrary = do - bs <- arbitrary - --w <- choose (0,7) :: Gen Int - return $ toBitArray bs 0 - -instance Arbitrary Day where - arbitrary = do - y <- choose (1951, 2050) - m <- choose (0, 11) - d <- choose (0, 31) - return $ fromGregorian y m d - -instance Arbitrary DiffTime where - arbitrary = do - h <- choose (0, 23) - mi <- choose (0, 59) - se <- choose (0, 59) - return $ secondsToDiffTime (h*3600+mi*60+se) - -instance Arbitrary UTCTime where - arbitrary = UTCTime <$> arbitrary <*> arbitrary - -instance Arbitrary TimeZone where - arbitrary = return $ utc - -instance Arbitrary ASN1TimeType where - arbitrary = elements [TimeUTC, TimeGeneralized] - -instance Arbitrary ASN1StringEncoding where - arbitrary = elements [UTF8, Numeric, Printable, T61, VideoTex, IA5, Graphic, Visible, General, UTF32, BMP] - -arbitraryPrintString encoding = do - let printableString = (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ " ()+,-./:=?") - asn1CharacterString encoding <$> replicateM 21 (elements printableString) - -arbitraryBS encoding = ASN1CharacterString encoding . B.pack <$> replicateM 7 (choose (0,0xff)) - -arbitraryIA5String = asn1CharacterString IA5 <$> replicateM 21 (choose (toEnum 0,toEnum 127)) - -arbitraryUCS2 :: Gen ASN1CharacterString -arbitraryUCS2 = asn1CharacterString BMP <$> replicateM 12 (choose (toEnum 0,toEnum 0xffff)) - -arbitraryUnicode :: ASN1StringEncoding -> Gen ASN1CharacterString -arbitraryUnicode e = asn1CharacterString e <$> replicateM 35 (choose (toEnum 0,toEnum 0x10ffff)) - -instance Arbitrary ASN1CharacterString where - arbitrary = oneof - [ arbitraryUnicode UTF8 - , arbitraryUnicode UTF32 - , arbitraryUCS2 - , arbitraryPrintString Numeric - , arbitraryPrintString Printable - , arbitraryBS T61 - , arbitraryBS VideoTex - , arbitraryIA5String - , arbitraryPrintString Graphic - , arbitraryPrintString Visible - , arbitraryPrintString General - ] - -instance Arbitrary ASN1 where - arbitrary = oneof - [ liftM Boolean arbitrary - , liftM IntVal arbitrary - , liftM BitString arbitrary - , liftM OctetString arbitrary - , return Null - , liftM OID arbitraryOID - --, Real Double - -- , return Enumerated - , ASN1String <$> arbitrary - , ASN1Time <$> arbitrary <*> arbitrary <*> arbitrary - ] - -newtype ASN1s = ASN1s [ASN1] - -instance Show ASN1s where - show (ASN1s x) = show x - -instance Arbitrary ASN1s where - arbitrary = do - x <- choose (0,5) :: Gen Int - z <- case x of - 4 -> makeList Sequence - 3 -> makeList Set - _ -> resize 2 $ listOf1 arbitrary - return $ ASN1s z - where - makeList str = do - (ASN1s l) <- arbitrary - return ([Start str] ++ l ++ [End str]) - -prop_header_marshalling_id :: ASN1Header -> Bool -prop_header_marshalling_id v = (ofDone $ runGet getHeader $ putHeader v) == Right v - where ofDone (Done r _ _) = Right r - ofDone _ = Left "not done" - -prop_event_marshalling_id :: ASN1Events -> Bool -prop_event_marshalling_id (ASN1Events e) = (parseLBS $ toLazyByteString e) == Right e - -prop_asn1_der_marshalling_id v = (decodeASN1 DER . encodeASN1 DER) v `assertEq` Right v - where assertEq got expected - | got /= expected = error ("got: " ++ show got ++ " expected: " ++ show expected) - | otherwise = True - -marshallingTests = testGroup "Marshalling" - [ testProperty "Header" prop_header_marshalling_id - , testProperty "Event" prop_event_marshalling_id - , testProperty "DER" prop_asn1_der_marshalling_id - ] - -main = defaultMain [marshallingTests]