diff --git a/Data/ASN1/Get.hs b/Data/ASN1/Get.hs --- a/Data/ASN1/Get.hs +++ b/Data/ASN1/Get.hs @@ -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 --git a/Data/ASN1/Prim.hs b/Data/ASN1/Prim.hs --- a/Data/ASN1/Prim.hs +++ b/Data/ASN1/Prim.hs @@ -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 diff --git a/Data/ASN1/Serialize.hs b/Data/ASN1/Serialize.hs --- a/Data/ASN1/Serialize.hs +++ b/Data/ASN1/Serialize.hs @@ -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 --git a/Tests.hs b/Tests.hs deleted file mode 100644 --- a/Tests.hs +++ /dev/null @@ -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] diff --git a/asn1-encoding.cabal b/asn1-encoding.cabal --- a/asn1-encoding.cabal +++ b/asn1-encoding.cabal @@ -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 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,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 diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -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]