asn1-encoding 0.8.1.3 → 0.9.6
raw patch · 8 files changed
Files
- Data/ASN1/BinaryEncoding/Parse.hs +1/−1
- Data/ASN1/Error.hs +1/−0
- Data/ASN1/Get.hs +17/−10
- Data/ASN1/Prim.hs +168/−78
- Data/ASN1/Serialize.hs +39/−40
- Tests.hs +0/−214
- asn1-encoding.cabal +28/−31
- tests/Tests.hs +222/−0
Data/ASN1/BinaryEncoding/Parse.hs view
@@ -124,7 +124,7 @@ , remBytes) go (ParseState stackEnd (ExpectPrimitive len cont) pos) bs = case runGetPrimitive cont len pos bs of- Fail _ -> error "primitive parsing failed"+ Fail _ -> Left ParsingPartial Partial f -> Right (([], ParseState stackEnd (ExpectPrimitive len $ Just f) pos), B.empty) Done p nPos remBytes -> Right (([Primitive p], ParseState stackEnd (ExpectHeader Nothing) nPos), remBytes)
Data/ASN1/Error.hs view
@@ -25,6 +25,7 @@ | ParsingPartial -- ^ Parsing is not finished, there is construction unended. | TypeNotImplemented String -- ^ Decoding of a type that is not implemented. Contribution welcome. | TypeDecodingFailed String -- ^ Decoding of a knowed type failed.+ | TypePrimitiveInvalid String -- ^ Invalid primitive type | PolicyFailed String String -- ^ Policy failed including the name of the policy and the reason. deriving (Typeable, Show, Eq)
Data/ASN1/Get.hs view
@@ -16,6 +16,7 @@ -- case for asn1 and augmented by a position. -- {-# LANGUAGE Rank2Types #-}+{-# LANGUAGE CPP #-} module Data.ASN1.Get ( Result(..) , Input@@ -33,7 +34,6 @@ import Foreign import qualified Data.ByteString as B-import qualified Data.ByteString.Unsafe as B -- | The result of a parse. data Result r = Fail String@@ -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@@ -104,7 +104,10 @@ let ks' s1 b1 m1 p1 a = unGet (g a) s1 b1 m1 p1 kf ks in unGet m s0 b0 m0 p0 kf ks' - fail = failDesc+#if MIN_VERSION_base(4,13,0)+instance MonadFail Get where+#endif+ fail = failDesc instance MonadPlus Get where mzero = failDesc "mzero"@@ -185,13 +188,17 @@ -- | Pull @n@ bytes from the input, as a strict ByteString. getBytes :: Int -> Get B.ByteString-getBytes n = do- s <- ensure n- put (fromIntegral n) $ B.unsafeDrop n s- return $ B.unsafeTake n s+getBytes n+ | n <= 0 = return B.empty+ | otherwise = do+ s <- ensure n+ let (b1, b2) = B.splitAt n s+ put (fromIntegral n) b2+ return b1 getWord8 :: Get Word8 getWord8 = do- s <- ensure 1- put 1 $ B.unsafeTail s- return $ B.unsafeHead s+ s <- ensure 1+ case B.uncons s of+ Nothing -> error "getWord8: ensure internal error"+ Just (h,b2) -> put 1 b2 >> return h
Data/ASN1/Prim.hs view
@@ -8,6 +8,7 @@ -- Tools to read ASN1 primitive (e.g. boolean, int) -- +{-# LANGUAGE CPP #-} {-# LANGUAGE ViewPatterns #-} module Data.ASN1.Prim (@@ -27,6 +28,7 @@ -- * marshall an ASN1 type from a val struct or a bytestring , getBoolean , getInteger+ , getDouble , getBitString , getOctetString , getNull@@ -36,6 +38,7 @@ -- * marshall an ASN1 type to a bytestring , putTime , putInteger+ , putDouble , putBitString , putString , putOID@@ -49,16 +52,18 @@ import Data.ASN1.Error import Data.ASN1.Serialize import Data.Bits+import Data.Monoid 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 Control.Applicative+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Unsafe as B+import Data.Hourglass import Control.Arrow (first)+import Control.Applicative+import Control.Monad encodeHeader :: Bool -> ASN1Length -> ASN1 -> ASN1Header encodeHeader pc len (Boolean _) = ASN1Header Universal 0x1 pc len@@ -100,7 +105,7 @@ encodePrimitiveData (OctetString b) = putString b encodePrimitiveData Null = B.empty encodePrimitiveData (OID oidv) = putOID oidv-encodePrimitiveData (Real _) = B.empty -- not implemented+encodePrimitiveData (Real d) = putDouble d encodePrimitiveData (Enumerated i) = putInteger $ fromIntegral i encodePrimitiveData (ASN1String cs) = getCharacterStringRawData cs encodePrimitiveData (ASN1Time ty ti tz) = putTime ty ti tz@@ -165,13 +170,13 @@ decodePrimitive (ASN1Header Universal 0x6 _ _) p = getOID p decodePrimitive (ASN1Header Universal 0x7 _ _) _ = Left $ TypeNotImplemented "Object Descriptor" decodePrimitive (ASN1Header Universal 0x8 _ _) _ = Left $ TypeNotImplemented "External"-decodePrimitive (ASN1Header Universal 0x9 _ _) _ = Left $ TypeNotImplemented "real"+decodePrimitive (ASN1Header Universal 0x9 _ _) p = getDouble p decodePrimitive (ASN1Header Universal 0xa _ _) p = getEnumerated p decodePrimitive (ASN1Header Universal 0xb _ _) _ = Left $ TypeNotImplemented "EMBEDDED PDV" decodePrimitive (ASN1Header Universal 0xc _ _) p = getCharacterString UTF8 p decodePrimitive (ASN1Header Universal 0xd _ _) _ = Left $ TypeNotImplemented "RELATIVE-OID"-decodePrimitive (ASN1Header Universal 0x10 _ _) _ = error "sequence not a primitive"-decodePrimitive (ASN1Header Universal 0x11 _ _) _ = error "set not a primitive"+decodePrimitive (ASN1Header Universal 0x10 _ _) _ = Left $ TypePrimitiveInvalid "sequence"+decodePrimitive (ASN1Header Universal 0x11 _ _) _ = Left $ TypePrimitiveInvalid "set" decodePrimitive (ASN1Header Universal 0x12 _ _) p = getCharacterString Numeric p decodePrimitive (ASN1Header Universal 0x13 _ _) p = getCharacterString Printable p decodePrimitive (ASN1Header Universal 0x14 _ _) p = getCharacterString T61 p@@ -220,6 +225,50 @@ v1 = s `B.index` 0 v2 = s `B.index` 1 +getDouble :: ByteString -> Either ASN1Error ASN1+getDouble s = Real <$> getDoubleRaw s++getDoubleRaw :: ByteString -> Either ASN1Error Double+getDoubleRaw s+ | B.null s = Right 0+getDoubleRaw s@(B.unsafeHead -> h)+ | h == 0x40 = Right $! (1/0) -- Infinity+ | h == 0x41 = Right $! (-1/0) -- -Infinity+ | h == 0x42 = Right $! (0/0) -- NaN+ | otherwise = do+ let len = B.length s+ base <- case (h `testBit` 5, h `testBit` 4) of+ -- extract bits 5,4 for the base+ (False, False) -> return 2+ (False, True) -> return 8+ (True, False) -> return 16+ _ -> Left . TypeDecodingFailed $ "real: invalid base detected"+ -- check bit 6 for the sign+ let mkSigned = if h `testBit` 6 then negate else id+ -- extract bits 3,2 for the scaling factor+ let scaleFactor = (h .&. 0x0c) `shiftR` 2+ expLength <- getExponentLength len h s+ -- 1 byte for the header, expLength for the exponent, and at least 1 byte for the mantissa+ unless (len > 1 + fromIntegral expLength) $+ Left . TypeDecodingFailed $ "real: not enough input for exponent and mantissa"+ let (_, exp'') = intOfBytes $ B.unsafeTake (fromIntegral expLength) $ B.unsafeDrop 1 s+ let exp' = case base :: Int of+ 2 -> exp''+ 8 -> 3 * exp''+ _ -> 4 * exp'' -- must be 16+ exponent = exp' - fromIntegral scaleFactor+ -- whatever is leftover is the mantissa, unsigned+ (_, mantissa) = uintOfBytes $ B.unsafeDrop (1 + fromIntegral expLength) s+ Right $! encodeFloat (mkSigned $ toInteger mantissa) (fromIntegral exponent)++getExponentLength :: Int -> Word8 -> ByteString -> Either ASN1Error Word8+getExponentLength len h s =+ case h .&. 0x03 of+ l | l == 0x03 -> do+ unless (len > 1) $ Left . TypeDecodingFailed $ "real: not enough input to decode exponent length"+ return $ B.unsafeIndex s 1+ | otherwise -> return $ l + 1+ getBitString :: ByteString -> Either ASN1Error ASN1 getBitString s = let toSkip = B.head s in@@ -260,88 +309,86 @@ 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 _ ->+ 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 - 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)+ 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" - toPico :: [Word8] -> Integer- toPico l = toInt l * order * 1000000000- where len = length l- order = case len of+ 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+ 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@@ -365,3 +412,46 @@ where encode x | x == 0 = B.singleton 0 | otherwise = putVarEncodingIntegral x++putDouble :: Double -> ByteString+putDouble d+ | d == 0 = B.pack []+ | d == (1/0) = B.pack [0x40]+ | d == negate (1/0) = B.pack [0x41]+ | isNaN d = B.pack [0x42]+ | otherwise = B.cons (header .|. (expLen - 1)) -- encode length of exponent+ (expBS <> manBS)+ where+ (mkUnsigned, header)+ | d < 0 = (negate, bINARY_NEGATIVE_NUMBER_ID)+ | otherwise = (id, bINARY_POSITIVE_NUMBER_ID)+ (man, exp) = decodeFloat d+ (mantissa, exponent) = normalize (fromIntegral $ mkUnsigned man, exp)+ expBS = putInteger (fromIntegral exponent)+ expLen = fromIntegral (B.length expBS)+ manBS = putInteger (fromIntegral mantissa)++-- | Normalize the mantissa and adjust the exponent.+--+-- DER requires the mantissa to either be 0 or odd, so we right-shift it+-- until the LSB is 1, and then add the shift amount to the exponent.+--+-- TODO: handle denormal numbers+normalize :: (Word64, Int) -> (Word64, Int)+normalize (mantissa, exponent) = (mantissa `shiftR` sh, exponent + sh)+ where+ sh = countTrailingZeros mantissa++#if !(MIN_VERSION_base(4,8,0))+ countTrailingZeros :: FiniteBits b => b -> Int+ countTrailingZeros x = go 0+ where+ go i | i >= w = i+ | testBit x i = i+ | otherwise = go (i+1)+ w = finiteBitSize x+#endif++bINARY_POSITIVE_NUMBER_ID, bINARY_NEGATIVE_NUMBER_ID :: Word8+bINARY_POSITIVE_NUMBER_ID = 0x80+bINARY_NEGATIVE_NUMBER_ID = 0xc0
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) $ fail "non canonical encoding of long 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,58 +1,55 @@ Name: asn1-encoding-Version: 0.8.1.3+Version: 0.9.6+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-Homepage: http://github.com/vincenthz/hs-asn1--Flag test- Description: Build unit test- Default: False+Build-Type: Simple+Cabal-Version: >=1.10+Homepage: https://github.com/vincenthz/hs-asn1 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 Data.ASN1.Encoding Data.ASN1.Stream Data.ASN1.Object- other-modules: Data.ASN1.Prim- Data.ASN1.BinaryEncoding.Parse+ Data.ASN1.Prim+ other-modules: Data.ASN1.BinaryEncoding.Parse Data.ASN1.BinaryEncoding.Writer 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+ , 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+ location: https://github.com/vincenthz/hs-asn1+ subdir: encoding
+ tests/Tests.hs view
@@ -0,0 +1,222 @@+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+ , liftM Real arbitrary+ -- , 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 :: [ASN1] -> Bool+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++prop_real_der_marshalling_id :: Double -> Bool+prop_real_der_marshalling_id v = (decodeASN1 DER . encodeASN1 DER) [Real v] `assertEq` Right [Real v]+ where assertEq got expected+ | got /= expected = error ("got: " ++ show got ++ " expected: " ++ show expected)+ | otherwise = True++prop_integral_real_der_marshalling_id :: Integer -> Bool+prop_integral_real_der_marshalling_id v = (decodeASN1 DER . encodeASN1 DER) [Real (fromInteger v)]+ `assertEq` Right [Real (fromInteger 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+ , testProperty "Real" prop_real_der_marshalling_id+ , testProperty "Integral Real" prop_integral_real_der_marshalling_id+ ]++main = defaultMain $ testGroup "asn1-encoding" [marshallingTests]