diff -ruN asn1-data-0.5.0/asn1-data.cabal asn1-data-0.5.1/asn1-data.cabal --- asn1-data-0.5.0/asn1-data.cabal 2011-04-03 23:57:10.000000000 -0700 +++ asn1-data-0.5.1/asn1-data.cabal 2011-06-19 00:44:25.000000000 -0700 @@ -1,5 +1,5 @@ Name: asn1-data -Version: 0.5.0 +Version: 0.5.1 Description: ASN1 data reader and writer in raw form with supports for high level forms of ASN1 (BER, CER and DER). . @@ -44,7 +44,12 @@ Main-Is: Tests.hs if flag(test) Buildable: True - Build-depends: base >= 3 && < 7, HUnit, QuickCheck >= 2, bytestring + Build-depends: base >= 3 && < 7 + , HUnit + , QuickCheck >= 2 + , bytestring + , test-framework >= 0.3 + , test-framework-quickcheck2 >= 0.2 else Buildable: False diff -ruN asn1-data-0.5.0/Data/ASN1/Internal.hs asn1-data-0.5.1/Data/ASN1/Internal.hs --- asn1-data-0.5.0/Data/ASN1/Internal.hs 2011-04-03 23:57:10.000000000 -0700 +++ asn1-data-0.5.1/Data/ASN1/Internal.hs 2011-06-19 00:44:25.000000000 -0700 @@ -3,6 +3,7 @@ , intOfBytes , bytesOfUInt , bytesOfInt + , putVarEncodingIntegral ) where import Data.Word @@ -42,3 +43,22 @@ nints = reverse $ plusOne $ reverse $ map complement $ uints plusOne [] = [1] plusOne (x:xs) = if x == 0xff then 0 : plusOne xs else (x+1) : xs + +{- ASN1 often uses a particular kind of 7-bit encoding of integers like + in the case of long tags or encoding of integer component of OID's. + Use this function for such an encoding. Assumes a positive integer. + + Here is the description of the algorithm of the above encoding: + + 1. The integer is chunked up into 7-bit groups. Each of these 7bit + chunks are encoded as a single octet. + + 2. All the octets except the last one has its 8th bit set. +-} +putVarEncodingIntegral :: (Bits i, Integral i) => i -> ByteString +putVarEncodingIntegral i = B.reverse $ B.unfoldr genOctets (i,True) + where genOctets (x,first) + | x > 0 = + let out = fromIntegral (x .&. 0x7F) .|. (if first then 0 else 0x80) in + Just (out, (shiftR x 7, False)) + | otherwise = Nothing diff -ruN asn1-data-0.5.0/Data/ASN1/Prim.hs asn1-data-0.5.1/Data/ASN1/Prim.hs --- asn1-data-0.5.0/Data/ASN1/Prim.hs 2011-04-03 23:57:10.000000000 -0700 +++ asn1-data-0.5.1/Data/ASN1/Prim.hs 2011-06-19 00:44:25.000000000 -0700 @@ -386,13 +386,10 @@ {- no enforce check that oid1 is between [0..2] and oid2 is between [0..39] -} putOID :: [Integer] -> ByteString -putOID oids = B.pack $ eoid +putOID oids = B.cons eoidclass subeoids where (oid1:oid2:suboids) = oids eoidclass = fromIntegral (oid1 * 40 + oid2) - ungroupSubOID x = unfoldr (\i -> if i == 0 then Nothing else Just (fromIntegral (i .&. 0x7f), i `shiftR` 7)) x - setHighBits [] = [] - setHighBits [x] = [x] - setHighBits (x:xs) = setBit x 7 : setHighBits xs - subeoids = concatMap (setHighBits . reverse . ungroupSubOID) suboids - eoid = eoidclass : subeoids + encode x | x == 0 = B.singleton 0 + | otherwise = putVarEncodingIntegral x + subeoids = B.concat $ map encode suboids diff -ruN asn1-data-0.5.0/Data/ASN1/Raw.hs asn1-data-0.5.1/Data/ASN1/Raw.hs --- asn1-data-0.5.0/Data/ASN1/Raw.hs 2011-04-03 23:57:10.000000000 -0700 +++ asn1-data-0.5.1/Data/ASN1/Raw.hs 2011-06-19 00:44:25.000000000 -0700 @@ -218,30 +218,14 @@ {- | putIdentifier encode an ASN1 Identifier into a marshalled value -} putHeader :: ASN1Header -> ByteString -putHeader (ASN1Header cl tag pc len) = B.pack - ( putFirstWord (cl, pc, if tag < 0x1f then tag else 0x1f) - : (if tag >= 0x1f then putTagLong tag else []) - ++ putLength len - ) - -{- put first word of a header -} -putFirstWord :: (ASN1Class, Bool, ASN1Tag) -> Word8 -putFirstWord (cl,pc,t1) = (cli `shiftL` 6) .|. (pcval `shiftL` 5) .|. (fromIntegral t1 .&. 0x1f) - where - cli = fromIntegral $ fromEnum cl - pcval = if pc then 0x1 else 0x0 - -{- marshall helper for putIdentifier to serialize long tag number -} -putTagLong :: ASN1Tag -> [Word8] -putTagLong n = revSethighbits $ split7bits n - where - revSethighbits :: [Word8] -> [Word8] - revSethighbits [] = [] - revSethighbits (x:xs) = reverse $ (x : map (\i -> setBit i 7) xs) - split7bits i - | i == 0 = [] - | i <= 0x7f = [ fromIntegral i ] - | otherwise = fromIntegral (i .&. 0x7f) : split7bits (i `shiftR` 7) +putHeader (ASN1Header cl tag pc len) = B.append tgBytes lenBytes + 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 + word1 = cli .|. pcval .|. tag0 + tgBytes = if tag < 0x1f then B.singleton word1 + else B.cons word1 $ putVarEncodingIntegral tag + lenBytes = B.pack $ putLength len {- | putLength encode a length into a ASN1 length. - see getLength for the encoding rules -} diff -ruN asn1-data-0.5.0/Tests.hs asn1-data-0.5.1/Tests.hs --- asn1-data-0.5.0/Tests.hs 2011-04-03 23:57:10.000000000 -0700 +++ asn1-data-0.5.1/Tests.hs 2011-06-19 00:44:25.000000000 -0700 @@ -1,4 +1,7 @@ import Test.QuickCheck +import Test.Framework(defaultMain, testGroup) +import Test.Framework.Providers.QuickCheck2(testProperty) + import Text.Printf import Data.ASN1.Raw @@ -223,19 +226,14 @@ prop_asn1_der_marshalling_id :: T.ASN1t -> Bool prop_asn1_der_marshalling_id v = (DER.decodeASN1 . DER.encodeASN1) v == Right v -args = stdArgs - { replay = Nothing - , maxSuccess = 500 - , maxDiscard = 2000 - , maxSize = 500 - } - -run_test n t = putStr (" " ++ n ++ " ... ") >> hFlush stdout >> quickCheckWith args t - -main = do - run_test "marshalling header = id" prop_header_marshalling_id - run_test "marshalling event = id" prop_event_marshalling_id - run_test "marshalling asn1 stream = id" prop_asn1_event_marshalling_id - run_test "marshalling asn1 repr = id" prop_asn1_event_repr_id - run_test "marshalling asn1 BER type = id" prop_asn1_ber_marshalling_id - run_test "marshalling asn1 DER type = id" prop_asn1_der_marshalling_id + +marshallingTests = testGroup "Marshalling" + [ testProperty "Header" prop_header_marshalling_id + , testProperty "Event" prop_event_marshalling_id + , testProperty "Stream" prop_asn1_event_marshalling_id + , testProperty "Repr" prop_asn1_event_repr_id + , testProperty "BER" prop_asn1_ber_marshalling_id + , testProperty "DER" prop_asn1_der_marshalling_id + ] + +main = do defaultMain [marshallingTests]