asn1-data 0.1.1 → 0.2

raw patch · 7 files changed

+228/−158 lines, 7 filesdep ~QuickCheckPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: QuickCheck

API changes (from Hackage documentation)

Files

• Data/ASN1/BER.hs +21/−19
• Data/ASN1/CER.hs +7/−7
• Data/ASN1/DER.hs +7/−7
• Data/ASN1/Prim.hs +50/−23
• Data/ASN1/Raw.hs +51/−46
• Tests.hs +90/−54
• asn1-data.cabal +2/−2

@@ -7,19 +7,19 @@ -- -- A module containing ASN1 BER specification serialization/derialization tools ---module Data.ASN1.BER (-	TagClass(..),-	ASN1(..),+module Data.ASN1.BER+	( TagClass(..)+	, ASN1(..)  	-- * BER interface when using directly Raw objects-	ofRaw,-	toRaw,+	, ofRaw+	, toRaw  	-- * BER serial functions-	decodeASN1Get,-	decodeASN1,-	encodeASN1Put,-	encodeASN1+	, decodeASN1Get+	, decodeASN1+	, encodeASN1Put+	, encodeASN1 	) where  import Data.ASN1.Raw@@ -59,12 +59,12 @@ ofRaw (Value Universal 0x16 v)               = getIA5String v ofRaw (Value Universal 0x17 x)               = getUTCTime x ofRaw (Value Universal 0x18 x)               = getGeneralizedTime x-ofRaw (Value Universal 0x19 _)               = Left $ ASN1NotImplemented "x"-ofRaw (Value Universal 0x1a _)               = Left $ ASN1NotImplemented "x"-ofRaw (Value Universal 0x1b _)               = Left $ ASN1NotImplemented "x"-ofRaw (Value Universal 0x1c _)               = Left $ ASN1NotImplemented "x"-ofRaw (Value Universal 0x1d _)               = Left $ ASN1NotImplemented "CHARACTER STRING"-ofRaw (Value Universal 0x1e _)               = Left $ ASN1NotImplemented "BMPString"+ofRaw (Value Universal 0x19 x)               = getGraphicString x+ofRaw (Value Universal 0x1a x)               = getVisibleString x+ofRaw (Value Universal 0x1b x)               = getGeneralString x+ofRaw (Value Universal 0x1c x)               = getUniversalString x+ofRaw (Value Universal 0x1d x)               = getCharacterString x+ofRaw (Value Universal 0x1e x)               = getBMPString x ofRaw (Value tc tn (Primitive b))            = Right $ Other tc tn (Left b) ofRaw (Value tc tn (Constructed l))          = either Left (Right . Other tc tn . Right) $ ofRaws l @@ -74,7 +74,7 @@ toRaw (IntVal i)             = Value Universal 0x2 (putInteger i) toRaw (BitString i bits)     = Value Universal 0x3 (putBitString i bits) toRaw (OctetString b)        = Value Universal 0x4 (putString b)-toRaw Null                   = Value Universal 0x5 (Primitive $ B.empty)+toRaw Null                   = Value Universal 0x5 (Primitive B.empty) toRaw (OID oid)              = Value Universal 0x6 (putOID oid) toRaw (Real f)               = Value Universal 0x9 (Constructed []) -- not implemented toRaw Enumerated             = Value Universal 0xa (Constructed []) -- not implemented@@ -92,16 +92,18 @@ toRaw (VisibleString b)      = Value Universal 0x1a (putString b) toRaw (GeneralString b)      = Value Universal 0x1b (putString b) toRaw (UniversalString b)    = Value Universal 0x1c (putString b)+toRaw (CharacterString b)    = Value Universal 0x1d (putString b)+toRaw (BMPString b)          = Value Universal 0x1e (putString b) toRaw (Other tc tn c)        = Value tc tn (either Primitive (Constructed . map toRaw) c)  decodeASN1Get :: Get (Either ASN1Err ASN1)-decodeASN1Get = runGetErrInGet getValue >>= return . either Left ofRaw+decodeASN1Get = either Left ofRaw `fmap` runGetErrInGet getValue  decodeASN1 :: L.ByteString -> Either ASN1Err ASN1-decodeASN1 b = either Left ofRaw $ runGetErr getValue b+decodeASN1 = either Left ofRaw . runGetErr getValue  encodeASN1Put :: ASN1 -> Put-encodeASN1Put d = putValue $ toRaw d+encodeASN1Put = putValue . toRaw  encodeASN1 :: ASN1 -> L.ByteString encodeASN1 = runPut . encodeASN1Put

@@ -7,15 +7,15 @@ -- -- A module containing ASN1 CER specification serialization/derialization tools ---module Data.ASN1.CER (-	TagClass(..),-	ASN1(..),+module Data.ASN1.CER+	( TagClass(..)+	, ASN1(..)  	-- * CER serial functions-	decodeASN1Get,-	decodeASN1,-	encodeASN1Put,-	encodeASN1+	, decodeASN1Get+	, decodeASN1+	, encodeASN1Put+	, encodeASN1 	) where  import Data.ASN1.Raw

@@ -7,15 +7,15 @@ -- -- A module containing ASN1 DER specification serialization/derialization tools ---module Data.ASN1.DER (-	TagClass(..),-	ASN1(..),+module Data.ASN1.DER+	( TagClass(..)+	, ASN1(..)  	-- * DER serialize functions-	decodeASN1Get,-	decodeASN1,-	encodeASN1Put,-	encodeASN1+	, decodeASN1Get+	, decodeASN1+	, encodeASN1Put+	, encodeASN1 	) where  import Data.ASN1.Raw

@@ -8,34 +8,41 @@ -- Tools to read ASN1 primitive (e.g. boolean, int) -- -module Data.ASN1.Prim (+module Data.ASN1.Prim+	( 	-- * ASN1 high level algebraic type-	ASN1(..),+	  ASN1(..)  	-- * marshall an ASN1 type from a val struct or a bytestring-	getEOC,-	getBoolean,-	getInteger,-	getBitString,-	getOctetString,-	getUTF8String,-	getNumericString,-	getPrintableString,-	getT61String,-	getVideoTexString,-	getIA5String,-	getNull,-	getOID,-	getUTCTime,-	getGeneralizedTime,+	, getEOC+	, getBoolean+	, getInteger+	, getBitString+	, getOctetString+	, getUTF8String+	, getNumericString+	, getPrintableString+	, getT61String+	, getVideoTexString+	, getIA5String+	, getNull+	, getOID+	, getUTCTime+	, getGeneralizedTime+	, getGraphicString+	, getVisibleString+	, getGeneralString+	, getUniversalString+	, getCharacterString+	, getBMPString  	-- * marshall an ASN1 type to a bytestring-	putUTCTime,-	putGeneralizedTime,-	putInteger,-	putBitString,-	putString,-	putOID+	, putUTCTime+	, putGeneralizedTime+	, putInteger+	, putBitString+	, putString+	, putOID 	) where  import Data.ASN1.Internal@@ -73,6 +80,8 @@ 	| VisibleString L.ByteString 	| GeneralString L.ByteString 	| UniversalString L.ByteString+	| CharacterString L.ByteString+	| BMPString L.ByteString 	| Other TagClass TagNumber (Either ByteString [ASN1]) 	deriving (Show, Eq) @@ -151,6 +160,24 @@  getIA5String :: ValStruct -> Either ASN1Err ASN1 getIA5String = either Left (Right . IA5String) . getString (\_ -> Nothing)++getGraphicString :: ValStruct -> Either ASN1Err ASN1+getGraphicString = either Left (Right . GraphicString) . getString (\_ -> Nothing)++getVisibleString :: ValStruct -> Either ASN1Err ASN1+getVisibleString = either Left (Right . VisibleString) . getString (\_ -> Nothing)++getGeneralString :: ValStruct -> Either ASN1Err ASN1+getGeneralString = either Left (Right . GeneralString) . getString (\_ -> Nothing)++getUniversalString :: ValStruct -> Either ASN1Err ASN1+getUniversalString = either Left (Right . UniversalString) . getString (\_ -> Nothing)++getCharacterString :: ValStruct -> Either ASN1Err ASN1+getCharacterString = either Left (Right . CharacterString) . getString (\_ -> Nothing)++getBMPString :: ValStruct -> Either ASN1Err ASN1+getBMPString = either Left (Right . BMPString) . getString (\_ -> Nothing)  getNull :: ByteString -> Either ASN1Err ASN1 getNull s = if B.length s == 0 then Right Null else Left $ ASN1Misc "Null: data length not within bound"

@@ -8,21 +8,25 @@ -- -- A module containing raw ASN1 serialization/derialization tools ---module Data.ASN1.Raw (-	GetErr,-	runGetErr,-	runGetErrInGet,-	ASN1Err(..),-	CheckFn,-	TagClass(..),-	TagNumber,-	ValLength(..),-	ValStruct(..),-	Value(..),-	getValueCheck,-	getValue,-	putValuePolicy,-	putValue+module Data.ASN1.Raw+	( GetErr+	-- * get structure+	, runGetErr+	, runGetErrInGet+	-- * ASN1 definitions+	, ASN1Err(..)+	, CheckFn+	, TagClass(..)+	, TagNumber+	, ValLength(..)+	, ValStruct(..)+	, Value(..)+	-- * get value from a Get structure+	, getValueCheck+	, getValue+	-- * put value in a Put structure+	, putValuePolicy+	, putValue 	) where  import Data.Bits@@ -81,10 +85,10 @@ 	fmap f = GE . fmap f . runGE  runGetErr :: GetErr a -> L.ByteString -> Either ASN1Err a-runGetErr f b = runGet (runErrorT (runGE f)) b+runGetErr = runGet . runErrorT . runGE  runGetErrInGet :: GetErr a -> Get (Either ASN1Err a)-runGetErrInGet f = runErrorT (runGE f)+runGetErrInGet = runErrorT . runGE  liftGet :: Get a -> GetErr a liftGet = GE . lift@@ -96,27 +100,27 @@ geteBytes = liftGet . getBytes  {- marshall helper for getIdentifier to unserialize long tag number -}-getTagNumberLong :: Bool -> GetErr TagNumber-getTagNumberLong nz = do-	t <- geteWord8-	let tval = fromIntegral (t .&. 0x7f)-	when (nz && tval == 0) $ error "long tag encoding failure: first value is 0"-	if (t .&. 0x80) > 0-		then do-			trest <- getTagNumberLong False-			return ((tval `shiftL` 7) + trest)-		else-			return tval+getTagNumberLong :: GetErr TagNumber+getTagNumberLong = getNext 0 True+	where getNext n nz = do+		t <- fromIntegral `fmap` geteWord8+		when (nz && t == 0x80) $ throwError ASN1LengthDecodingLongContainsZero+		if testBit t 7+			then getNext (n `shiftL` 7 + clearBit t 7) False+			else return (n `shiftL` 7 + t)  {- marshall helper for putIdentifier to serialize long tag number -} putTagNumberLong :: TagNumber -> Put-putTagNumberLong i = do-	if i > 0x7f-		then do-			putWord8 $ fromIntegral (0x80 .|. (i .&. 0x7f))-			putTagNumberLong (i `shiftR` 7)-		else-			putWord8 $ fromIntegral (i .&. 0x7f)+putTagNumberLong n = mapM_ putWord8 $ 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)+		  {- | getIdentifier get an ASN1 encoded Identifier.  - if the first 5 bytes value is less than 1f then it's encoded on 1 byte, otherwise@@ -125,7 +129,7 @@ getIdentifier = do 	w <- geteWord8 	let cl =-		case (w `shiftR` 7) .&. 3 of+		case (w `shiftR` 6) .&. 3 of 			0 -> Universal 			1 -> Application  			2 -> Context@@ -133,8 +137,8 @@ 			_ -> Universal -- this cannot happens because of the .&. 3 	let pc = (w .&. 0x20) > 0 	let val = fromIntegral (w .&. 0x1f)-	vencoded <- if val < 0x1f then return val else getTagNumberLong True-	return $ (cl, pc, vencoded)+	vencoded <- if val < 0x1f then return val else getTagNumberLong+	return (cl, pc, vencoded)  {- | putIdentifier encode an ASN1 Identifier into a marshalled value -} putIdentifier :: Identifier -> Put@@ -147,9 +151,9 @@ 	let pcval = if pc then 0x20 else 0x00 	if val < 0x1f 		then-			putWord8 $ fromIntegral $ (cli `shiftL` 7) .|. pcval .|. (val)+			putWord8 $ fromIntegral $ (cli `shiftL` 6) .|. pcval .|. val 		else do-			putWord8 $ fromIntegral $ (cli `shiftL` 7) .|. pcval .|. 0x1f+			putWord8 $ fromIntegral $ (cli `shiftL` 6) .|. pcval .|. 0x1f 			putTagNumberLong val  {- | getLength get the ASN1 encoded length of an item.@@ -161,7 +165,7 @@ getLength = do 	l1 <- geteWord8 	if testBit l1 7-		then do+		then 			case fromIntegral (clearBit l1 7) of 				0   -> return LenIndefinite 				len -> do@@ -189,7 +193,7 @@ {- helper to getValue to build a constructed list of values when length is known -} getValueConstructed :: CheckFn -> GetErr [Value] getValueConstructed check = do-	remain <- liftGet $ remaining+	remain <- liftGet remaining 	if remain > 0 		then do 			o <- getValueCheck check@@ -212,12 +216,13 @@ getValueOfLength :: CheckFn -> Int -> Bool -> GetErr ValStruct getValueOfLength check len pc = do 	b <- geteBytes len-	case pc of-		True  -> do+	if pc+		then 			case runGetErr (getValueConstructed check) (L.fromChunks [b]) of 				Right x  -> return $ Constructed x 				Left err -> throwError err-		False -> return $ Primitive b+		else+			return $ Primitive b  {- | getValueCheck decode an ASN1 value and check the values received through the check fn -} getValueCheck :: CheckFn -> GetErr Value@@ -232,7 +237,7 @@  	struct <- case vallen of 		LenIndefinite -> do-			when (not pc) $ throwError $ ASN1Misc "lenght indefinite not allowed with primitive"+			unless pc $ throwError $ ASN1Misc "lenght indefinite not allowed with primitive" 			vs <- getValueConstructedUntilEOC check 			return $ Constructed vs 		(LenShort len)  -> getValueOfLength check len pc

@@ -1,81 +1,117 @@ import Test.QuickCheck-import qualified Test.HUnit as Unit-import Test.HUnit ((~:), (~=?)) import Text.Printf+ import Data.ASN1.Raw import Data.ASN1.DER (ASN1(..)) import qualified Data.ASN1.DER as DER+ import Data.Binary.Get import Data.Binary.Put import Data.Word+ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L -mkSeq l = Value Universal 0x10 (Constructed l)-mkBool t = Value Universal 0x1 (Primitive $ B.pack [ if t then 0x1 else 0x0 ])-mkInt t = Value Universal 0x2 (Primitive $ B.pack [ t ])+import Control.Monad+import System.IO -famous_oids :: [[Integer]]-famous_oids =-	[ [2,1,2]-	, [1,38,53]-	, [2,24,840,24042,530,530]-	, [0,20,84,249,59342,53295392,325993252935]-	, [1,2,840,113549,1,1,1]-	]+arbitraryOID :: Gen [Integer]+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) -instance Arbitrary Value where-	arbitrary = elements [-		mkSeq [],-		mkSeq [ mkBool True, mkInt 124 ],-		mkSeq [ mkSeq [ mkBool True, mkInt 124 ], mkSeq [] ]-		]-	coarbitrary (Value _ tn _) = variant tn+instance Arbitrary B.ByteString where+	arbitrary = do+		len <- choose (0, 529) :: Gen Int+		ws <- replicateM len (choose (0, 255) :: Gen Int)+		return $ B.pack $ map fromIntegral ws -instance Arbitrary ASN1 where-	arbitrary = elements (-		   [Boolean False,Boolean True,Null,EOC]-		++ map IntVal ([0..512] ++ [10241024..10242048])-		++ map OID famous_oids-		)+instance Arbitrary L.ByteString where+	arbitrary = do+		len <- choose (0, 529) :: Gen Int+		ws <- replicateM len (choose (0, 255) :: Gen Int)+		return $ L.pack $ map fromIntegral ws +instance Arbitrary TagClass where+	arbitrary = elements [ Universal, Application, Context, Private ] -getVal = either (const (Value Application (-1) (Constructed []))) id . runGetErr getValue-putVal = runPut . putValue+arbitraryValueList = choose (0,20) >>= \len -> replicateM len (suchThat arbitrary (not . isConstructed))+	where+		isConstructed (Value _ _ (Constructed _)) = True+		isConstructed _                           = False -decodeASN1 = either (const EOC) id . DER.decodeASN1+instance Arbitrary ValStruct where+	arbitrary = oneof+		[ liftM Primitive arbitrary+		, liftM Constructed arbitraryValueList ] -prop_getput_value_id :: Value -> Bool-prop_getput_value_id v = (getVal . putVal) v == v+instance Arbitrary Value where+	arbitrary = liftM3 Value arbitrary (suchThat arbitrary (\i -> i > 0)) arbitrary -prop_getput_asn1_id :: ASN1 -> Bool-prop_getput_asn1_id v = (DER.decodeASN1 . DER.encodeASN1) v == Right v+arbitraryTime = do+	y <- choose (1950, 2050)+	m <- choose (0, 11)+	d <- choose (0, 31)+	h <- choose (0, 23)+	mi <- choose (0, 59)+	se <- choose (0, 59)+	z <- arbitrary+	return (y,m,d,h,mi,se,z) -tests =-	[ ("get.put value/id", test prop_getput_value_id)-	, ("get.put DER.ASN1/id", test prop_getput_asn1_id)-	]+arbitraryListASN1 = choose (0, 20) >>= \len -> replicateM len (suchThat arbitrary (not . aList))+	where+		aList (Set _)      = True+		aList (Sequence _) = True+		aList _            = False -quickCheckMain = mapM_ (\(s,a) -> printf "%-25s: " s >> a) tests+instance Arbitrary ASN1 where+	arbitrary = oneof+		[ return EOC+		, liftM Boolean arbitrary+		, liftM IntVal arbitrary+		, liftM2 BitString (choose (0,7)) arbitrary+		, liftM OctetString arbitrary+		, return Null+		, liftM OID arbitraryOID+		--, Real Double+		-- , return Enumerated+		, liftM UTF8String arbitrary+		, liftM Sequence arbitraryListASN1+		, liftM Set arbitraryListASN1+		, liftM NumericString arbitrary+		, liftM PrintableString arbitrary+		, liftM T61String arbitrary+		, liftM VideoTexString arbitrary+		, liftM IA5String arbitrary+		, liftM UTCTime arbitraryTime+		, liftM GeneralizedTime arbitraryTime+		, liftM GraphicString arbitrary+		, liftM VisibleString arbitrary+		, liftM GeneralString arbitrary+		, liftM UniversalString arbitrary+		] +prop_value_marshalling_id :: Value -> Bool+prop_value_marshalling_id v = (getVal . putVal) v == Right v+	where+		getVal = runGetErr getValue+		putVal = runPut . putValue -value_units :: [ (String, Value, [Word8]) ]-value_units = [-	("empty Sequence", mkSeq [], [ 0x30, 0x0 ]),-	("long Sequence", mkSeq (replicate 50 (mkBool True)), [ 0x30, 0x81, 150 ] ++ (concat $ replicate 50 [ 0x01, 0x1, 0x1 ]))-	]+prop_asn1_marshalling_id :: ASN1 -> Bool+prop_asn1_marshalling_id v = (DER.decodeASN1 . DER.encodeASN1) v == Right v -asn1_units :: [ (String, ASN1) ]-asn1_units =-	map (\oid -> ("OID " ++ show oid, OID oid)) famous_oids ++-	[]+args = Args+	{ replay     = Nothing+	, maxSuccess = 500+	, maxDiscard = 2000+	, maxSize    = 500+	} -utests :: [Unit.Test]-utests =-	map (\ (s, v, r) -> ("put " ++ s) ~: s ~: r ~=? (L.unpack $ putVal v)) value_units ++-	map (\ (s, v, r) -> ("get " ++ s) ~: s ~: v ~=? (getVal $ L.pack r)) value_units ++-	map (\ (s, v) -> ("decode/encode=id") ~: s ~: v ~=? (decodeASN1 . DER.encodeASN1) v) asn1_units+run_test n t = putStr ("  " ++ n ++ " ... ") >> hFlush stdout >> quickCheckWith args t  main = do-	Unit.runTestTT (Unit.TestList utests)-	quickCheckMain+	run_test "marshalling value = id" prop_value_marshalling_id+	run_test "marshalling asn1 = id" prop_asn1_marshalling_id

@@ -1,5 +1,5 @@ Name:                asn1-data-Version:             0.1.1+Version:             0.2 Description:     ASN1 data reader/writer in raw form with supports for high level forms of ASN1 (BER/CER/DER) License:             BSD3@@ -36,7 +36,7 @@   Main-Is:           Tests.hs   if flag(test)     Buildable:       True-    Build-depends:   base >= 3 && < 5, HUnit, QuickCheck, bytestring+    Build-depends:   base >= 3 && < 5, HUnit, QuickCheck >= 2, bytestring   else     Buildable:       False