asn1-encoding 0.8.1.3 → 0.9.0
raw patch · 6 files changed
+332/−355 lines, 6 filesdep +asn1-encodingdep +hourglassdep +tastydep −HUnitdep −QuickCheckdep −test-frameworkdep ~asn1-typesdep ~text
Dependencies added: asn1-encoding, hourglass, tasty, tasty-quickcheck
Dependencies removed: HUnit, QuickCheck, test-framework, test-framework-quickcheck2, time
Dependency ranges changed: asn1-types, text
Files
- Data/ASN1/Get.hs +1/−1
- Data/ASN1/Prim.hs +64/−73
- Data/ASN1/Serialize.hs +39/−40
- Tests.hs +0/−214
- asn1-encoding.cabal +26/−27
- tests/Tests.hs +202/−0
Data/ASN1/Get.hs view
@@ -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
Data/ASN1/Prim.hs view
@@ -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) @@ -260,88 +259,80 @@ 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)+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 _ -> decodingError ("cannot convert string " ++ BC.unpack bs)+ Right r ->+ case parseTimezone $ parseMs $ first adjustUTC $ r of+ Left err -> decodingError err+ Right (dt', tz) -> Right $ ASN1Time timeType dt' tz+ where+ adjustUTC dt@(DateTime (Date y m d) tod)+ | timeType == TimeGeneralized = dt+ | y > 2050 = DateTime (Date (y - 100) m d) tod+ | otherwise = dt+ format | timeType == TimeGeneralized = 'Y':'Y':baseFormat+ | otherwise = baseFormat+ baseFormat = "YYMMDDHMIS" - 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)+ 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) - toPico :: [Word8] -> Integer- toPico l = toInt l * order * 1000000000- where len = length l- order = case len of+ 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+ 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) - centurize v- | v <= 50 = v + 100- | otherwise = v+ toInt :: String -> Int+ toInt = foldl (\acc w -> acc * 10 + (ord w - ord '0')) 0 -putTime :: ASN1TimeType -> UTCTime -> Maybe TimeZone -> ByteString-putTime ty (UTCTime day diff) mtz = B.pack etime+ 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
Data/ASN1/Serialize.hs view
@@ -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]
− Tests.hs
@@ -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 w--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]
asn1-encoding.cabal view
@@ -1,31 +1,20 @@ Name: asn1-encoding-Version: 0.8.1.3+Version: 0.9.0+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 <vincent@snarc.org> Author: Vincent Hanquez <vincent@snarc.org>-Maintainer: Vincent Hanquez <vincent@snarc.org>-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,31 @@ Data.ASN1.Internal Data.ASN1.Serialize Data.ASN1.Get- ghc-options: -Wall+ Build-Depends: base >= 3 && < 5+ , bytestring+ , mtl+ , 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
+ tests/Tests.hs view
@@ -0,0 +1,202 @@+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 d = timeConvert (timeConvert d :: 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]