asn1-data 0.3.0 → 0.4.0

raw patch · 11 files changed

+937/−528 lines, 11 filesdep +attoparsecdep +attoparsec-enumeratordep +enumeratordep −binarydep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: attoparsec, attoparsec-enumerator, enumerator

Dependencies removed: binary

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Data/ASN1/BER.hs +145/−100
• Data/ASN1/CER.hs +18/−47
• Data/ASN1/DER.hs +90/−46
• Data/ASN1/Internal.hs +5/−5
• Data/ASN1/Prim.hs +184/−86
• Data/ASN1/Raw.hs +206/−204
• Data/ASN1/Stream.hs +52/−0
• Data/ASN1/Types.hs +106/−0
• TODO +4/−1
• Tests.hs +118/−36
• asn1-data.cabal +9/−3

@@ -8,126 +8,171 @@ -- A module containing ASN1 BER specification serialization/derialization tools -- module Data.ASN1.BER-	( TagClass(..)+	( ASN1Class(..) 	, ASN1(..)+	, ASN1ConstructionType(..) -	-- * BER interface when using directly Raw objects-	, ofRaw-	, toRaw+	-- * enumeratee to transform between ASN1 and raw+	, enumReadRaw+	, enumWriteRaw -	-- * BER serial functions-	, decodeASN1Get-	, decodeASN1State+	-- * enumeratee to transform between ASN1 and bytes+	, enumReadBytes+	, enumWriteBytes++	-- * iterate over common representation to an ASN1 stream+	, iterateFile+	, iterateByteString++	-- * BER serialize functions+	, decodeASN1Stream+	, encodeASN1Stream++	-- * BER serialize functions, deprecated 	, decodeASN1 	, decodeASN1s-	, encodeASN1Put-	, encodeASN1sPut 	, encodeASN1 	, encodeASN1s 	) where -import Data.Int-import Data.ASN1.Raw+import Data.ASN1.Raw (ASN1Header(..), ASN1Class(..), ASN1Err(..))+import qualified Data.ASN1.Raw as Raw++import Data.ASN1.Stream+import Data.ASN1.Types (ofStream, toStream, ASN1t) import Data.ASN1.Prim-import Data.Either-import Data.Binary.Get-import Data.Binary.Put-import Control.Monad (liftM)-import Control.Monad.Error (throwError)++import Control.Monad.Identity+import Control.Exception+ import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString as B-import Data.Text.Lazy.Encoding (encodeUtf8, encodeUtf32BE)+import Data.ByteString (ByteString) -ofRaws :: [Value] -> Either ASN1Err [ASN1]-ofRaws x = if l == [] then Right r else Left $ ASN1Multiple l+import Data.Enumerator.IO+import Data.Enumerator (Iteratee(..), Enumeratee, ($$), (>>==))+import qualified Data.Enumerator as E++decodeConstruction :: ASN1Header -> ASN1ConstructionType+decodeConstruction (ASN1Header Universal 0x10 _ _) = Sequence+decodeConstruction (ASN1Header Universal 0x11 _ _) = Set+decodeConstruction (ASN1Header c t _ _)            = Container c t++{- | enumReadRaw is an enumeratee from raw events to asn1 -}+enumReadRaw :: Monad m => Enumeratee Raw.ASN1Event ASN1 m a+enumReadRaw = E.checkDone $ \k -> k (E.Chunks []) >>== loop [] 	where-		(l, r) = partitionEithers $ map ofRaw x+		loop l = E.checkDone $ go l+		go l k = E.head >>= \x -> case x of+			Nothing                  ->+				if l == [] then  k (E.Chunks []) >>== return else E.throwError (Raw.ASN1ParsingPartial)+			Just Raw.ConstructionEnd ->+				k (E.Chunks [head l]) >>== loop (tail l)+			Just (Raw.Header hdr@(ASN1Header _ _ True _)) -> E.head >>= \z -> case z of+				Nothing                    -> E.throwError (Raw.ASN1ParsingFail "expecting construction, got EOF")+				Just Raw.ConstructionBegin ->+					let ctype = decodeConstruction hdr in+					k (E.Chunks [Start ctype]) >>== loop (End ctype : l)+				Just _                     -> E.throwError (Raw.ASN1ParsingFail "expecting construction")+			Just (Raw.Header hdr@(ASN1Header _ _ False _)) -> E.head >>= \z -> case z of+				Nothing -> E.throwError (Raw.ASN1ParsingFail "expecting primitive, got EOF")+				Just (Raw.Primitive p) ->+					let (Right pr) = decodePrimitive hdr p in+					k (E.Chunks [pr]) >>== loop l+				Just _  -> E.throwError (Raw.ASN1ParsingFail "expecting primitive")+			Just _ -> E.throwError (Raw.ASN1ParsingFail "boundary not a header") -ofRaw :: Value -> Either ASN1Err ASN1-ofRaw (Value Universal 0x0 (Primitive b))    = getEOC b-ofRaw (Value Universal 0x1 (Primitive b))    = getBoolean False b-ofRaw (Value Universal 0x2 (Primitive b))    = getInteger b-ofRaw (Value Universal 0x3 v)                = getBitString v-ofRaw (Value Universal 0x4 v)                = getOctetString v-ofRaw (Value Universal 0x5 (Primitive b))    = getNull b-ofRaw (Value Universal 0x6 (Primitive b))    = getOID b-ofRaw (Value Universal 0x7 (Primitive _))    = Left $ ASN1NotImplemented "Object Descriptor"-ofRaw (Value Universal 0x8 (Constructed _))  = Left $ ASN1NotImplemented "External"-ofRaw (Value Universal 0x9 (Primitive _))    = Left $ ASN1NotImplemented "real"-ofRaw (Value Universal 0xa (Primitive _))    = Left $ ASN1NotImplemented "enumerated"-ofRaw (Value Universal 0xb (Constructed _))  = Left $ ASN1NotImplemented "EMBEDDED PDV"-ofRaw (Value Universal 0xc v)                = getUTF8String v-ofRaw (Value Universal 0xd (Primitive _))    = Left $ ASN1NotImplemented "RELATIVE-OID"-ofRaw (Value Universal 0x10 (Constructed l)) = either Left (Right . Sequence) $ ofRaws l-ofRaw (Value Universal 0x11 (Constructed l)) = either Left (Right . Set) $ ofRaws l-ofRaw (Value Universal 0x12 v)               = getNumericString v-ofRaw (Value Universal 0x13 v)               = getPrintableString v-ofRaw (Value Universal 0x14 v)               = getT61String v-ofRaw (Value Universal 0x15 v)               = getVideoTexString v-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 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+{- | enumWriteRaw is an enumeratee from asn1 to raw events -}+enumWriteRaw :: Monad m => Enumeratee ASN1 Raw.ASN1Event m a+enumWriteRaw = \f -> E.joinI (enumWriteTree $$ (enumWriteTreeRaw f)) -toRaw :: ASN1 -> Value-toRaw EOC                    = Value Universal 0x0 (Primitive B.empty)-toRaw (Boolean v)            = Value Universal 0x1 (Primitive $ B.singleton (if v then 0xff else 0))-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 (OID oid)              = Value Universal 0x6 (putOID oid)-toRaw (Real _)               = Value Universal 0x9 (Constructed []) -- not implemented-toRaw Enumerated             = Value Universal 0xa (Constructed []) -- not implemented-toRaw (UTF8String b)         = Value Universal 0xc (putString $ encodeUtf8 b)-toRaw (Sequence children)    = Value Universal 0x10 (Constructed $ map toRaw children)-toRaw (Set children)         = Value Universal 0x11 (Constructed $ map toRaw children)-toRaw (NumericString b)      = Value Universal 0x12 (putString b)-toRaw (PrintableString b)    = Value Universal 0x13 (putString $ encodeUtf8 b)-toRaw (T61String b)          = Value Universal 0x14 (putString b)-toRaw (VideoTexString b)     = Value Universal 0x15 (putString b)-toRaw (IA5String b)          = Value Universal 0x16 (putString $ encodeUtf8 b)-toRaw (UTCTime time)         = Value Universal 0x17 (putUTCTime time)-toRaw (GeneralizedTime time) = Value Universal 0x18 (putGeneralizedTime time)-toRaw (GraphicString b)      = Value Universal 0x19 (putString b)-toRaw (VisibleString b)      = Value Universal 0x1a (putString b)-toRaw (GeneralString b)      = Value Universal 0x1b (putString b)-toRaw (UniversalString b)    = Value Universal 0x1c (putString $ encodeUtf32BE b)-toRaw (CharacterString b)    = Value Universal 0x1d (putString b)-toRaw (BMPString b)          = Value Universal 0x1e (putString $ encodeUCS2BE b)-toRaw (Other tc tn c)        = Value tc tn (either Primitive (Constructed . map toRaw) c)+enumWriteTree :: Monad m => Enumeratee ASN1 (ASN1, [ASN1]) m a+enumWriteTree = do+	E.checkDone $ \k -> k (E.Chunks []) >>== loop+	where+		loop = E.checkDone $ go+		go k = E.head >>= \x -> case x of+			Nothing          -> k (E.Chunks []) >>== return+			Just n@(Start _) -> consumeTillEnd >>= \y -> k (E.Chunks [(n, y)] ) >>== loop+			Just p           -> k (E.Chunks [(p, [])] ) >>== loop -decodeASN1Get :: Get (Either ASN1Err ASN1)-decodeASN1Get = either Left ofRaw `fmap` runGetErrInGet getValue+		consumeTillEnd :: Monad m => Iteratee ASN1 m [ASN1]+		consumeTillEnd = E.liftI $ step (1 :: Int) id where+			step l acc chunk = case chunk of+				E.Chunks [] -> E.Continue $ E.returnI . step l acc+				E.Chunks xs -> do+					let (ys, zs) = spanEnd l xs+					let nbend = length $ filter isEnd ys+					let nbstart = length $ filter isStart ys+					let nl = l - nbend + nbstart+					if nl == 0+						then E.Yield (acc ys) (E.Chunks zs)+						else E.Continue $ E.returnI . (step nl $ acc . (ys ++))+				E.EOF       -> E.Yield (acc []) E.EOF -decodeASN1State :: L.ByteString -> Either ASN1Err (ASN1, L.ByteString, Int64)-decodeASN1State b =-	runGetErrState (getValue >>= either throwError return . ofRaw) b 0+			spanEnd :: Int -> [ASN1] -> ([ASN1], [ASN1])+			spanEnd _ []               = ([], [])+			spanEnd 0 (x@(End _):xs)   = ([x], xs)+			spanEnd 0 (x@(Start _):xs) = let (ys, zs) = spanEnd 1 xs in (x:ys, zs)+			spanEnd 0 (x:xs)           = let (ys, zs) = spanEnd 0 xs in (x:ys, zs)+			spanEnd l (x:xs)           = case x of+				Start _ -> let (ys, zs) = spanEnd (l+1) xs in (x:ys, zs)+				End _   -> let (ys, zs) = spanEnd (l-1) xs in (x:ys, zs)+				_       -> let (ys, zs) = spanEnd l xs in (x:ys, zs) -decodeASN1 :: L.ByteString -> Either ASN1Err ASN1-decodeASN1 = either Left ofRaw . runGetErr getValue+			isStart (Start _) = True+			isStart _         = False+			isEnd (End _)     = True+			isEnd _           = False -decodeASN1s :: L.ByteString -> Either ASN1Err [ASN1]-decodeASN1s = loop where-	loop z = case decodeASN1State z of-		Left err -> throwError err-		Right (v, rest, _) -> if L.length rest > 0 then liftM (v :) (loop rest) else return [v] -encodeASN1Put :: ASN1 -> Put-encodeASN1Put = putValue . toRaw+enumWriteTreeRaw :: Monad m => Enumeratee (ASN1, [ASN1]) Raw.ASN1Event m a+enumWriteTreeRaw = E.concatMap writeTree+	where writeTree (p,children) = snd $ case p of+		Start _ -> encodeConstructed p children+		_       -> encodePrimitive p -encodeASN1sPut :: [ASN1] -> Put-encodeASN1sPut = mapM_ encodeASN1Put+{-| enumReadBytes is an enumeratee converting from bytestring to ASN1+  it transforms chunks of bytestring into chunks of ASN1 objects -}+enumReadBytes :: Monad m => Enumeratee ByteString ASN1 m a+enumReadBytes = \f -> E.joinI (Raw.enumReadBytes $$ (enumReadRaw f)) -encodeASN1 :: ASN1 -> L.ByteString-encodeASN1 = runPut . encodeASN1Put+{-| enumWriteBytes is an enumeratee converting from ASN1 to bytestring.+  it transforms chunks of ASN1 objects into chunks of bytestring  -}+enumWriteBytes :: Monad m => Enumeratee ASN1 ByteString m a+enumWriteBytes = \f -> E.joinI (enumWriteRaw $$ (Raw.enumWriteBytes f)) -encodeASN1s :: [ASN1] -> L.ByteString-encodeASN1s = runPut . encodeASN1sPut+{-| iterate over a file using a file enumerator. -}+iterateFile :: FilePath -> Iteratee ASN1 IO a -> IO (Either SomeException a)+iterateFile path p = E.run (enumFile path $$ E.joinI $ enumReadBytes $$ p)++{-| iterate over a bytestring using a list enumerator over each chunks -}+iterateByteString :: Monad m => L.ByteString -> Iteratee ASN1 m a -> m (Either SomeException a)+iterateByteString bs p = E.run (E.enumList 1 (L.toChunks bs) $$ E.joinI $ enumReadBytes $$ p)++{-| decode a lazy bytestring as an ASN1 stream -}+decodeASN1Stream :: L.ByteString -> Either ASN1Err [ASN1]+decodeASN1Stream l = do+	case runIdentity (iterateByteString l E.consume) of+		Left err -> Left (maybe (ASN1ParsingFail "unknown") id $ fromException err)+		Right x  -> Right x++encodeASN1Stream :: Monad m => [ASN1] -> Iteratee ByteString m a -> m (Either SomeException a)+encodeASN1Stream l p = E.run (E.enumList 1 l $$ E.joinI $ enumWriteBytes $$ p)++{-# DEPRECATED decodeASN1s "use stream types with decodeASN1Stream" #-}+decodeASN1s :: L.ByteString -> Either ASN1Err [ASN1t]+decodeASN1s l = either (Left) (Right . ofStream) $ decodeASN1Stream l++{-# DEPRECATED decodeASN1 "use stream types with decodeASN1Stream" #-}+decodeASN1 :: L.ByteString -> Either ASN1Err ASN1t+decodeASN1 = either (Left) (Right . head) . decodeASN1s++{-# DEPRECATED encodeASN1s "use stream types with encodeASN1Stream" #-}+encodeASN1s :: [ASN1t] -> L.ByteString+encodeASN1s l = case runIdentity (encodeASN1Stream (toStream l) E.consume) of+	Left _  -> error "encoding failed"+	Right x -> L.fromChunks x++{-# DEPRECATED encodeASN1 "use stream types with encodeASN1Stream" #-}+encodeASN1 :: ASN1t -> L.ByteString+encodeASN1 = encodeASN1s . (:[])

@@ -8,34 +8,22 @@ -- A module containing ASN1 CER specification serialization/derialization tools -- module Data.ASN1.CER-	( TagClass(..)+	( ASN1Class(..) 	, ASN1(..)  	-- * CER serial functions-	, decodeASN1Get+	, decodeASN1s+	, encodeASN1s 	, decodeASN1-	, encodeASN1Put 	, encodeASN1 	) where  import Data.ASN1.Raw import Data.ASN1.Prim-import Data.Binary.Get-import Data.Binary.Put+import Data.ASN1.Types (ASN1t) import qualified Data.ASN1.BER as BER-import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L-import Data.Text.Lazy.Encoding (encodeUtf8, encodeUtf32BE) -{- | check if the value is bounded by CER policies -}-check :: (TagClass, Bool, TagNumber) -> ValLength -> Maybe ASN1Err-check (_, _, _) _ = Nothing--{- | ofRaw same as BER.ofRAW but check some additional CER constraint. -}-ofRaw :: Value -> Either ASN1Err ASN1-ofRaw v = BER.ofRaw v-- {- - 9.2        String encoding forms string values shall be encoded with a primitive encoding if they would@@ -43,6 +31,7 @@ The string fragments contained in the constructed encoding shall be encoded with a primitive encoding. The encoding of each fragment, except possibly the last, shall have 1000 contents octets. -}+{- putStringCER :: Int -> L.ByteString -> ValStruct putStringCER tn l = 	if L.length l > 1000@@ -56,38 +45,20 @@ 					x1 : repack1000 x2 				else 					[ x ]--{- | toRaw create a CER encoded value ready -}-toRaw :: ASN1 -> Value-toRaw (BitString i bits)     = Value Universal 0x3 (putBitString i bits)-toRaw (OctetString b)        = Value Universal 0x4 (putStringCER 0x4 b)-toRaw (UTF8String b)         = Value Universal 0xc (putStringCER 0xc (encodeUtf8 b))-toRaw (NumericString b)      = Value Universal 0x12 (putStringCER 0x12 b)-toRaw (PrintableString b)    = Value Universal 0x13 (putStringCER 0x13 (encodeUtf8 b))-toRaw (T61String b)          = Value Universal 0x14 (putStringCER 0x14 b)-toRaw (VideoTexString b)     = Value Universal 0x15 (putStringCER 0x15 b)-toRaw (IA5String b)          = Value Universal 0x16 (putStringCER 0x16 (encodeUtf8 b))-toRaw (GraphicString b)      = Value Universal 0x19 (putStringCER 0x19 b)-toRaw (VisibleString b)      = Value Universal 0x1a (putStringCER 0x1a b)-toRaw (GeneralString b)      = Value Universal 0x1b (putStringCER 0x1b b)-toRaw (UniversalString b)    = Value Universal 0x1c (putStringCER 0x1c (encodeUtf32BE b))-toRaw (BMPString b)          = Value Universal 0x1e (putStringCER 0x1e (encodeUCS2BE b))-toRaw v                      = BER.toRaw v--decodeASN1Get :: Get (Either ASN1Err ASN1)-decodeASN1Get = runGetErrInGet (getValueCheck check) >>= return . either Left ofRaw+-} -decodeASN1 :: L.ByteString -> Either ASN1Err ASN1-decodeASN1 b = either Left ofRaw $ runGetErr (getValueCheck check) b+{-# DEPRECATED decodeASN1s "use stream types with decodeASN1Stream" #-}+decodeASN1s :: L.ByteString -> Either ASN1Err [ASN1t]+decodeASN1s = BER.decodeASN1s -encodePolicyCER :: Value -> Int -> ValLength-encodePolicyCER (Value _ _ (Primitive _)) len-	| len < 0x80   = LenShort len-	| otherwise    = LenLong 0 len-encodePolicyCER (Value _ _ (Constructed _)) _ = LenIndefinite+{-# DEPRECATED decodeASN1 "use stream types with decodeASN1Stream" #-}+decodeASN1 :: L.ByteString -> Either ASN1Err ASN1t+decodeASN1 = BER.decodeASN1 -encodeASN1Put :: ASN1 -> Put-encodeASN1Put d = putValuePolicy encodePolicyCER $ toRaw d+{-# DEPRECATED encodeASN1s "use stream types with encodeASN1Stream" #-}+encodeASN1s :: [ASN1t] -> L.ByteString+encodeASN1s = BER.encodeASN1s -encodeASN1 :: ASN1 -> L.ByteString-encodeASN1 = runPut . encodeASN1Put+{-# DEPRECATED encodeASN1 "use stream types with encodeASN1Stream" #-}+encodeASN1 :: ASN1t -> L.ByteString+encodeASN1 = BER.encodeASN1

@@ -8,80 +8,124 @@ -- A module containing ASN1 DER specification serialization/derialization tools -- module Data.ASN1.DER-	( TagClass(..)+	( ASN1Class(..) 	, ASN1(..)+	, ASN1ConstructionType(..) +	-- * enumeratee to transform between ASN1 and raw+	, enumReadRaw+	, enumWriteRaw++	-- * enumeratee to transform between ASN1 and bytes+	, enumReadBytes+	, enumWriteBytes++	-- * iterate over common representation to an ASN1 stream+	, iterateFile+	, iterateByteString+ 	-- * DER serialize functions-	, decodeASN1Get-	, decodeASN1State+	, decodeASN1Stream+	, encodeASN1Stream++	-- * DER serialize functions, deprecated 	, decodeASN1 	, decodeASN1s-	, encodeASN1Put-	, encodeASN1sPut 	, encodeASN1 	, encodeASN1s 	) where -import Data.Int-import Data.ASN1.Raw+import Data.ASN1.Raw (ASN1Class(..), ASN1Length(..), ASN1Header(..), ASN1Event(..), ASN1Err(..))+import qualified Data.ASN1.Raw as Raw+ import Data.ASN1.Prim-import Data.Binary.Get-import Data.Binary.Put-import Control.Monad (mplus, liftM)-import Control.Monad.Error (throwError)+import Data.ASN1.Types (ofStream, toStream, ASN1t)+ import qualified Data.ASN1.BER as BER++import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L +import Control.Monad.Identity+import Control.Exception++import Data.Enumerator (Iteratee, Enumeratee, ($$), (>>==))+import Data.Enumerator.IO+import qualified Data.Enumerator as E+ {- | Check if the length is the minimum possible and it's not indefinite -}-checkLength :: ValLength -> Maybe ASN1Err+checkLength :: ASN1Length -> Maybe ASN1Err checkLength LenIndefinite = Just $ ASN1PolicyFailed "DER" "indefinite length not allowed" checkLength (LenShort _)  = Nothing checkLength (LenLong n i) 	| n == 1 && i < 0x80  = Just $ ASN1PolicyFailed "DER" "long length should be a short length" 	| n == 1 && i >= 0x80 = Nothing-	| otherwise           = if i >= 2^((n-1)*8) && i < 2^(n*8) then Nothing else Just $ ASN1PolicyFailed "DER" "long length is not shortest"+	| otherwise           = if i >= 2^((n-1)*8) && i < 2^(n*8)+		then Nothing+		else Just $ ASN1PolicyFailed "DER" "long length is not shortest" -{- | check if the value type is correct -}-checkType :: TagClass -> TagNumber -> Maybe ASN1Err-checkType _ _ = Nothing+checkRawDER :: Monad m => Enumeratee Raw.ASN1Event Raw.ASN1Event m a+checkRawDER = E.checkDone $ \k -> k (E.Chunks []) >>== loop+	where+		loop = E.checkDone go+		go k = E.head >>= \x -> case x of+			Nothing -> k (E.Chunks []) >>== return+			Just l  -> case tyCheck l of+				Nothing  -> k (E.Chunks [l]) >>== loop+				Just err -> E.throwError err+		tyCheck (Header (ASN1Header _ _ _ len)) = checkLength len+		tyCheck _                               = Nothing -{- | check if the value is bounded by DER policies -}-check :: (TagClass, Bool, TagNumber) -> ValLength -> Maybe ASN1Err-check (tc,_,tn) vallen = checkLength vallen `mplus` checkType tc tn+{- | enumReadRaw is an enumeratee from raw events to asn1 -}+enumReadRaw :: Monad m => Enumeratee Raw.ASN1Event ASN1 m a+enumReadRaw = \f -> E.joinI (checkRawDER $$ BER.enumReadRaw f) -{- | ofRaw same as BER.ofRAW but check some additional DER constraint. -}-ofRaw :: Value -> Either ASN1Err ASN1-ofRaw (Value Universal 0x1 (Primitive b)) = getBoolean True b-ofRaw v                                   = BER.ofRaw v+{- | enumWriteRaw is an enumeratee from asn1 to raw events -}+enumWriteRaw :: Monad m => Enumeratee ASN1 Raw.ASN1Event m a+enumWriteRaw = BER.enumWriteRaw -{- | toRaw create a DER encoded value ready -}-toRaw :: ASN1 -> Value-toRaw = BER.toRaw+{-| enumReadBytes is an enumeratee converting from bytestring to ASN1+  it transforms chunks of bytestring into chunks of ASN1 objects -}+enumReadBytes :: Monad m => Enumeratee ByteString ASN1 m a+enumReadBytes = \f -> E.joinI (Raw.enumReadBytes $$ (BER.enumReadRaw f)) -decodeASN1Get :: Get (Either ASN1Err ASN1)-decodeASN1Get = runGetErrInGet (getValueCheck check) >>= return . either Left ofRaw+{-| enumWriteBytes is an enumeratee converting from ASN1 to bytestring.+  it transforms chunks of ASN1 objects into chunks of bytestring  -}+enumWriteBytes :: Monad m => Enumeratee ASN1 ByteString m a+enumWriteBytes = \f -> E.joinI (enumWriteRaw $$ (Raw.enumWriteBytes f)) -decodeASN1State :: L.ByteString -> Either ASN1Err (ASN1, L.ByteString, Int64)-decodeASN1State b =-	runGetErrState (getValueCheck check >>= either throwError return . BER.ofRaw) b 0+{-| iterate over a file using a file enumerator. -}+iterateFile :: FilePath -> Iteratee ASN1 IO a -> IO (Either SomeException a)+iterateFile path p = E.run (enumFile path $$ E.joinI $ enumReadBytes $$ p) -decodeASN1 :: L.ByteString -> Either ASN1Err ASN1-decodeASN1 b = either Left BER.ofRaw $ runGetErr (getValueCheck check) b+{-| iterate over a bytestring using a list enumerator over each chunks -}+iterateByteString :: Monad m => L.ByteString -> Iteratee ASN1 m a -> m (Either SomeException a)+iterateByteString bs p = E.run (E.enumList 1 (L.toChunks bs) $$ E.joinI $ enumReadBytes $$ p) -decodeASN1s :: L.ByteString -> Either ASN1Err [ASN1]-decodeASN1s = loop where-	loop z = case decodeASN1State z of-		Left err -> throwError err-		Right (v, rest, _) -> if L.length rest > 0 then liftM (v :) (loop rest) else return [v]+{-| decode a lazy bytestring as an ASN1 stream -}+decodeASN1Stream :: L.ByteString -> Either ASN1Err [ASN1]+decodeASN1Stream l = do+	case runIdentity (iterateByteString l E.consume) of+		Left err -> Left (maybe (ASN1ParsingFail "unknown") id $ fromException err)+		Right x  -> Right x -encodeASN1Put :: ASN1 -> Put-encodeASN1Put d = putValue $ toRaw d+encodeASN1Stream :: Monad m => [ASN1] -> Iteratee ByteString m a -> m (Either SomeException a)+encodeASN1Stream l p = E.run (E.enumList 1 l $$ E.joinI $ enumWriteBytes $$ p) -encodeASN1sPut :: [ASN1] -> Put-encodeASN1sPut = mapM_ encodeASN1Put+{-# DEPRECATED decodeASN1s "use stream types with decodeASN1Stream" #-}+decodeASN1s :: L.ByteString -> Either ASN1Err [ASN1t]+decodeASN1s l = either (Left) (Right . ofStream) $ decodeASN1Stream l -encodeASN1 :: ASN1 -> L.ByteString-encodeASN1 = runPut . encodeASN1Put+{-# DEPRECATED decodeASN1 "use stream types with decodeASN1Stream" #-}+decodeASN1 :: L.ByteString -> Either ASN1Err ASN1t+decodeASN1 = either (Left) (Right . head) . decodeASN1s -encodeASN1s :: [ASN1] -> L.ByteString-encodeASN1s = runPut . encodeASN1sPut+{-# DEPRECATED encodeASN1s "use stream types with encodeASN1Stream" #-}+encodeASN1s :: [ASN1t] -> L.ByteString+encodeASN1s l = case runIdentity (encodeASN1Stream (toStream l) E.consume) of+	Left _  -> error "encoding failed"+	Right x -> L.fromChunks x++{-# DEPRECATED encodeASN1 "use stream types with encodeASN1Stream" #-}+encodeASN1 :: ASN1t -> L.ByteString+encodeASN1 = encodeASN1s . (:[])

@@ -1,8 +1,8 @@-module Data.ASN1.Internal (-	uintOfBytes,-	intOfBytes,-	bytesOfUInt,-	bytesOfInt+module Data.ASN1.Internal+	( uintOfBytes+	, intOfBytes+	, bytesOfUInt+	, bytesOfInt 	) where  import Data.Word

@@ -12,9 +12,18 @@ 	( 	-- * ASN1 high level algebraic type 	  ASN1(..)+	, ASN1ConstructionType(..) +	, encodeHeader+	, encodePrimitiveHeader+	, encodePrimitive+	, decodePrimitive+	, encodeConstructed+	, encodeList+	, encodeOne+	, mkSmallestLength+ 	-- * marshall an ASN1 type from a val struct or a bytestring-	, getEOC 	, getBoolean 	, getInteger 	, getBitString@@ -43,14 +52,13 @@ 	, putBitString 	, putString 	, putOID-	, encodeUCS2BE 	) where  import Data.ASN1.Internal import Data.ASN1.Raw+import Data.ASN1.Stream import Data.Bits import Data.Word-import Data.Maybe (catMaybes) import Data.List (unfoldr) import Data.ByteString (ByteString) import Data.Char (ord)@@ -58,36 +66,7 @@ import qualified Data.ByteString.Lazy as L import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as T-import Data.Text.Lazy.Encoding (decodeASCII, decodeUtf8, decodeUtf32BE)--data ASN1 =-	  EOC-	| Boolean Bool-	| IntVal Integer-	| BitString Int L.ByteString-	| OctetString L.ByteString-	| Null-	| OID [Integer]-	| Real Double-	| Enumerated-	| UTF8String Text-	| Sequence [ASN1]-	| Set [ASN1]-	| NumericString L.ByteString-	| PrintableString Text-	| T61String L.ByteString-	| VideoTexString L.ByteString-	| IA5String Text-	| UTCTime (Int, Int, Int, Int, Int, Int, Bool)-	| GeneralizedTime (Int, Int, Int, Int, Int, Int, Bool)-	| GraphicString L.ByteString-	| VisibleString L.ByteString-	| GeneralString L.ByteString-	| UniversalString Text-	| CharacterString L.ByteString-	| BMPString Text-	| Other TagClass TagNumber (Either ByteString [ASN1])-	deriving (Show, Eq)+import Data.Text.Lazy.Encoding (decodeASCII, decodeUtf8, decodeUtf32BE, encodeUtf8, encodeUtf32BE)  encodeUCS2BE :: Text -> L.ByteString encodeUCS2BE t =@@ -105,12 +84,145 @@ 					_     -> loop r 	 -getEOC :: ByteString -> Either ASN1Err ASN1-getEOC s =-	if B.length s == 0-		then Right $ EOC-		else Left $ ASN1Misc "EOC: data length not within bound"+encodeHeader :: Bool -> ASN1Length -> ASN1 -> ASN1Header+encodeHeader pc len (Boolean _)                = ASN1Header Universal 0x1 pc len+encodeHeader pc len (IntVal _)                 = ASN1Header Universal 0x2 pc len+encodeHeader pc len (BitString _ _)            = ASN1Header Universal 0x3 pc len+encodeHeader pc len (OctetString _)            = ASN1Header Universal 0x4 pc len+encodeHeader pc len Null                       = ASN1Header Universal 0x5 pc len+encodeHeader pc len (OID _)                    = ASN1Header Universal 0x6 pc len+encodeHeader pc len (Real _)                   = ASN1Header Universal 0x9 pc len+encodeHeader pc len Enumerated                 = ASN1Header Universal 0xa pc len+encodeHeader pc len (UTF8String _)             = ASN1Header Universal 0xc pc len+encodeHeader pc len (NumericString _)          = ASN1Header Universal 0x12 pc len+encodeHeader pc len (PrintableString _)        = ASN1Header Universal 0x13 pc len+encodeHeader pc len (T61String _)              = ASN1Header Universal 0x14 pc len+encodeHeader pc len (VideoTexString _)         = ASN1Header Universal 0x15 pc len+encodeHeader pc len (IA5String _)              = ASN1Header Universal 0x16 pc len+encodeHeader pc len (UTCTime _)                = ASN1Header Universal 0x17 pc len+encodeHeader pc len (GeneralizedTime _)        = ASN1Header Universal 0x18 pc len+encodeHeader pc len (GraphicString _)          = ASN1Header Universal 0x19 pc len+encodeHeader pc len (VisibleString _)          = ASN1Header Universal 0x1a pc len+encodeHeader pc len (GeneralString _)          = ASN1Header Universal 0x1b pc len+encodeHeader pc len (UniversalString _)        = ASN1Header Universal 0x1c pc len+encodeHeader pc len (CharacterString _)        = ASN1Header Universal 0x1d pc len+encodeHeader pc len (BMPString _)              = ASN1Header Universal 0x1e pc len+encodeHeader pc len (Start Sequence)           = ASN1Header Universal 0x10 pc len+encodeHeader pc len (Start Set)                = ASN1Header Universal 0x11 pc len+encodeHeader pc len (Start (Container tc tag)) = ASN1Header tc tag pc len+encodeHeader pc len (Other tc tag _)           = ASN1Header tc tag pc len+encodeHeader _ _ (End _)                       = error "this should not happen" +encodePrimitiveHeader :: ASN1Length -> ASN1 -> ASN1Header+encodePrimitiveHeader = encodeHeader False++encodePrimitiveData :: ASN1 -> ByteString+encodePrimitiveData (Boolean b)         = B.singleton (if b then 0xff else 0)+encodePrimitiveData (IntVal i)          = putInteger i+encodePrimitiveData (BitString i bits)  = putBitString i bits+encodePrimitiveData (OctetString b)     = putString b+encodePrimitiveData Null                = B.empty+encodePrimitiveData (OID oid)           = putOID oid+encodePrimitiveData (Real _)            = B.empty -- not implemented+encodePrimitiveData Enumerated          = B.empty -- not implemented+encodePrimitiveData (UTF8String b)      = putString $ encodeUtf8 b+encodePrimitiveData (NumericString b)   = putString b+encodePrimitiveData (PrintableString b) = putString $ encodeUtf8 b+encodePrimitiveData (T61String b)       = putString b+encodePrimitiveData (VideoTexString b)  = putString b+encodePrimitiveData (IA5String b)       = putString $ encodeUtf8 b+encodePrimitiveData (UTCTime t)         = putUTCTime t+encodePrimitiveData (GeneralizedTime t) = putGeneralizedTime t+encodePrimitiveData (GraphicString b)   = putString b+encodePrimitiveData (VisibleString b)   = putString b+encodePrimitiveData (GeneralString b)   = putString b+encodePrimitiveData (UniversalString b) = putString $ encodeUtf32BE b+encodePrimitiveData (CharacterString b) = putString b+encodePrimitiveData (BMPString b)       = putString $ encodeUCS2BE b+encodePrimitiveData (Other _ _ b)       = b+encodePrimitiveData o                   = error ("not a primitive " ++ show o)++encodePrimitive :: ASN1 -> (Int, [ASN1Event])+encodePrimitive a =+	let b = encodePrimitiveData a in+	let blen = B.length b in+	let len = makeLength blen in+	let hdr = encodePrimitiveHeader len a in+	(B.length (putHeader hdr) + blen, [Header hdr, Primitive b])+	where+		makeLength len+			| len < 0x80 = LenShort len+			| otherwise  = LenLong (nbBytes len) len+		nbBytes nb = if nb > 255 then 1 + nbBytes (nb `div` 256) else 1++encodeOne :: ASN1 -> (Int, [ASN1Event])+encodeOne (Start _) = error "encode one cannot do start"+encodeOne t         = encodePrimitive t++encodeList :: [ASN1] -> (Int, [ASN1Event])+encodeList []               = (0, [])+encodeList (End _:xs)       = encodeList xs+encodeList (t@(Start _):xs) =+	let (ys, zs)    = getConstructedEnd 0 xs in+	let (llen, lev) = encodeList zs in+	let (len, ev)   = encodeConstructed t ys in+	(llen + len, ev ++ lev)++encodeList (x:xs)           =+	let (llen, lev) = encodeList xs in+	let (len, ev)   = encodeOne x in+	(llen + len, ev ++ lev)++encodeConstructed :: ASN1 -> [ASN1] -> (Int, [ASN1Event])+encodeConstructed c@(Start _) children =+	let (clen, events) = encodeList children in+	let len = mkSmallestLength clen in+	let h = encodeHeader True len c in+	let tlen = B.length (putHeader h) + clen in+	(tlen, Header h : ConstructionBegin : events ++ [ConstructionEnd])++encodeConstructed _ _ = error "not a start node"++mkSmallestLength :: Int -> ASN1Length+mkSmallestLength i+	| i < 0x80  = LenShort i+	| otherwise = LenLong (nbBytes i) i+		where nbBytes nb = if nb > 255 then 1 + nbBytes (nb `div` 256) else 1++type ASN1Ret = Either ASN1Err ASN1++decodePrimitive :: ASN1Header -> B.ByteString -> ASN1Ret+decodePrimitive (ASN1Header Universal 0x1 _ _) p   = getBoolean False p+decodePrimitive (ASN1Header Universal 0x2 _ _) p   = getInteger p+decodePrimitive (ASN1Header Universal 0x3 _ _) p   = getBitString p+decodePrimitive (ASN1Header Universal 0x4 _ _) p   = getOctetString p+decodePrimitive (ASN1Header Universal 0x5 _ _) p   = getNull p+decodePrimitive (ASN1Header Universal 0x6 _ _) p   = getOID p+decodePrimitive (ASN1Header Universal 0x7 _ _) _   = Left $ ASN1NotImplemented "Object Descriptor"+decodePrimitive (ASN1Header Universal 0x8 _ _) _   = Left $ ASN1NotImplemented "External"+decodePrimitive (ASN1Header Universal 0x9 _ _) _   = Left $ ASN1NotImplemented "real"+decodePrimitive (ASN1Header Universal 0xa _ _) _   = Left $ ASN1NotImplemented "enumerated"+decodePrimitive (ASN1Header Universal 0xb _ _) _   = Left $ ASN1NotImplemented "EMBEDDED PDV"+decodePrimitive (ASN1Header Universal 0xc _ _) p   = getUTF8String p+decodePrimitive (ASN1Header Universal 0xd _ _) _   = Left $ ASN1NotImplemented "RELATIVE-OID"+decodePrimitive (ASN1Header Universal 0x10 _ _) _  = error "sequence not a primitive"+decodePrimitive (ASN1Header Universal 0x11 _ _) _  = error "set not a primitive"+decodePrimitive (ASN1Header Universal 0x12 _ _) p  = getNumericString p+decodePrimitive (ASN1Header Universal 0x13 _ _) p  = getPrintableString p+decodePrimitive (ASN1Header Universal 0x14 _ _) p  = getT61String p+decodePrimitive (ASN1Header Universal 0x15 _ _) p  = getVideoTexString p+decodePrimitive (ASN1Header Universal 0x16 _ _) p  = getIA5String p+decodePrimitive (ASN1Header Universal 0x17 _ _) p  = getUTCTime p+decodePrimitive (ASN1Header Universal 0x18 _ _) p  = getGeneralizedTime p+decodePrimitive (ASN1Header Universal 0x19 _ _) p  = getGraphicString p+decodePrimitive (ASN1Header Universal 0x1a _ _) p  = getVisibleString p+decodePrimitive (ASN1Header Universal 0x1b _ _) p  = getGeneralString p+decodePrimitive (ASN1Header Universal 0x1c _ _) p  = getUniversalString p+decodePrimitive (ASN1Header Universal 0x1d _ _) p  = getCharacterString p+decodePrimitive (ASN1Header Universal 0x1e _ _) p  = getBMPString p+decodePrimitive (ASN1Header tc        tag  _ _) p  = Right $ Other tc tag p++ getBoolean :: Bool -> ByteString -> Either ASN1Err ASN1 getBoolean isDer s = 	if B.length s == 1@@ -135,8 +247,8 @@ 			v2 = s `B.index` 1  -getBitString :: ValStruct -> Either ASN1Err ASN1-getBitString (Primitive s) =+getBitString :: ByteString -> Either ASN1Err ASN1+getBitString s = 	let toSkip = B.head s in 	let toSkip' = if toSkip >= 48 && toSkip <= 48 + 7 then toSkip - (fromIntegral $ ord '0') else toSkip in 	let xs = B.tail s in@@ -144,59 +256,49 @@ 		then Right $ BitString (fromIntegral toSkip') (L.fromChunks [xs]) 		else Left $ ASN1Misc ("bitstring: skip number not within bound " ++ show toSkip' ++ " " ++  show s) -getBitString (Constructed _) = Left $ ASN1NotImplemented "bitstring"--getString :: (Either ByteString Value -> Maybe ASN1Err) -> ValStruct -> Either ASN1Err L.ByteString-getString check (Primitive s) =-	case check (Left s) of+getString :: (ByteString -> Maybe ASN1Err) -> ByteString -> Either ASN1Err L.ByteString+getString check s =+	case check s of 		Nothing  -> Right $ L.fromChunks [s] 		Just err -> Left err -getString check (Constructed l) =-	case catMaybes $ map (check . Right) l of-		[]   -> Right $ L.fromChunks $ map catPrimitiveString l-		errs -> Left $ ASN1Multiple errs-	where-		catPrimitiveString (Value _ _ (Primitive b)) = b-		catPrimitiveString (Value _ _ (Constructed _)) = B.empty {- FIXME -}--getOctetString :: ValStruct -> Either ASN1Err ASN1+getOctetString :: ByteString -> Either ASN1Err ASN1 getOctetString = either Left (Right . OctetString) . getString (\_ -> Nothing) -getNumericString :: ValStruct -> Either ASN1Err ASN1+getNumericString :: ByteString -> Either ASN1Err ASN1 getNumericString = either Left (Right . NumericString) . getString (\_ -> Nothing) -getPrintableString :: ValStruct -> Either ASN1Err ASN1+getPrintableString :: ByteString -> Either ASN1Err ASN1 getPrintableString = either Left (Right . PrintableString . decodeASCII) . getString (\_ -> Nothing) -getUTF8String :: ValStruct -> Either ASN1Err ASN1+getUTF8String :: ByteString -> Either ASN1Err ASN1 getUTF8String = either Left (Right . UTF8String . decodeUtf8) . getString (\_ -> Nothing) -getT61String :: ValStruct -> Either ASN1Err ASN1+getT61String :: ByteString -> Either ASN1Err ASN1 getT61String = either Left (Right . T61String) . getString (\_ -> Nothing) -getVideoTexString :: ValStruct -> Either ASN1Err ASN1+getVideoTexString :: ByteString -> Either ASN1Err ASN1 getVideoTexString = either Left (Right . VideoTexString) . getString (\_ -> Nothing) -getIA5String :: ValStruct -> Either ASN1Err ASN1+getIA5String :: ByteString -> Either ASN1Err ASN1 getIA5String = either Left (Right . IA5String . decodeASCII) . getString (\_ -> Nothing) -getGraphicString :: ValStruct -> Either ASN1Err ASN1+getGraphicString :: ByteString -> Either ASN1Err ASN1 getGraphicString = either Left (Right . GraphicString) . getString (\_ -> Nothing) -getVisibleString :: ValStruct -> Either ASN1Err ASN1+getVisibleString :: ByteString -> Either ASN1Err ASN1 getVisibleString = either Left (Right . VisibleString) . getString (\_ -> Nothing) -getGeneralString :: ValStruct -> Either ASN1Err ASN1+getGeneralString :: ByteString -> Either ASN1Err ASN1 getGeneralString = either Left (Right . GeneralString) . getString (\_ -> Nothing) -getUniversalString :: ValStruct -> Either ASN1Err ASN1+getUniversalString :: ByteString -> Either ASN1Err ASN1 getUniversalString = either Left (Right . UniversalString . decodeUtf32BE) . getString (\_ -> Nothing) -getCharacterString :: ValStruct -> Either ASN1Err ASN1+getCharacterString :: ByteString -> Either ASN1Err ASN1 getCharacterString = either Left (Right . CharacterString) . getString (\_ -> Nothing) -getBMPString :: ValStruct -> Either ASN1Err ASN1+getBMPString :: ByteString -> Either ASN1Err ASN1 getBMPString = either Left (Right . BMPString . decodeUCS2BE) . getString (\_ -> Nothing)  getNull :: ByteString -> Either ASN1Err ASN1@@ -221,8 +323,8 @@ 		spanSubOIDbound (a:as) = if testBit a 7 then (clearBit a 7 : ys, zs) else ([a], as) 			where (ys, zs) = spanSubOIDbound as -getUTCTime :: ValStruct -> Either ASN1Err ASN1-getUTCTime (Primitive s) =+getUTCTime :: ByteString -> Either ASN1Err ASN1+getUTCTime s = 	case B.unpack s of 		[y1, y2, m1, m2, d1, d2, h1, h2, mi1, mi2, s1, s2, z] -> 			let y = integerise y1 y2 in@@ -237,10 +339,8 @@ 	where 		integerise a b = ((fromIntegral a) - (ord '0')) * 10 + ((fromIntegral b) - (ord '0')) -getUTCTime (Constructed _) = Left $ ASN1NotImplemented "utctime constructed"--getGeneralizedTime :: ValStruct -> Either ASN1Err ASN1-getGeneralizedTime (Primitive s) =+getGeneralizedTime :: ByteString -> Either ASN1Err ASN1+getGeneralizedTime s = 	case B.unpack s of 		[y1, y2, y3, y4, m1, m2, d1, d2, h1, h2, mi1, mi2, s1, s2, z] -> 			let year = (integerise y1 y2) * 100 + (integerise y3 y4) in@@ -253,11 +353,9 @@ 		_                                                     -> Left $ ASN1Misc "utctime unexpected format" 	where 		integerise a b = ((fromIntegral a) - (ord '0')) * 10 + ((fromIntegral b) - (ord '0'))-getGeneralizedTime (Constructed _) = Left $ ASN1NotImplemented "generalizedtime constructed" -putTime :: Bool -> (Int, Int, Int, Int, Int, Int, Bool) -> ValStruct-putTime generalized (y,m,d,h,mi,s,z) =-	Primitive $ B.pack etime+putTime :: Bool -> (Int, Int, Int, Int, Int, Int, Bool) -> ByteString+putTime generalized (y,m,d,h,mi,s,z) = B.pack etime 	where 		etime = 			if generalized@@ -271,24 +369,24 @@ 		(mi1, mi2)        = split2 mi 		(s1, s2)          = split2 s -putUTCTime :: (Int, Int, Int, Int, Int, Int, Bool) -> ValStruct+putUTCTime :: (Int, Int, Int, Int, Int, Int, Bool) -> ByteString putUTCTime time = putTime False time -putGeneralizedTime :: (Int, Int, Int, Int, Int, Int, Bool) -> ValStruct+putGeneralizedTime :: (Int, Int, Int, Int, Int, Int, Bool) -> ByteString putGeneralizedTime time = putTime True time -putInteger :: Integer -> ValStruct-putInteger i = Primitive $ B.pack $ bytesOfInt i+putInteger :: Integer -> ByteString+putInteger i = B.pack $ bytesOfInt i -putBitString :: Int -> L.ByteString -> ValStruct-putBitString i bits = Primitive $ B.concat $ B.singleton (fromIntegral i) : L.toChunks bits+putBitString :: Int -> L.ByteString -> ByteString+putBitString i bits = B.concat $ B.singleton (fromIntegral i) : L.toChunks bits -putString :: L.ByteString -> ValStruct-putString l = Primitive $ B.concat $ L.toChunks l+putString :: L.ByteString -> ByteString+putString l = B.concat $ L.toChunks l  {- no enforce check that oid1 is between [0..2] and oid2 is between [0..39] -}-putOID :: [Integer] -> ValStruct-putOID oids = Primitive $ B.pack $ eoid+putOID :: [Integer] -> ByteString+putOID oids = B.pack $ eoid 	where 		(oid1:oid2:suboids) = oids 		eoidclass           = fromIntegral (oid1 * 40 + oid2)

@@ -1,4 +1,4 @@-{-#  LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE BangPatterns, DeriveDataTypeable #-} -- | -- Module      : Data.ASN1.Raw -- License     : BSD-style@@ -8,118 +8,229 @@ -- -- A module containing raw ASN1 serialization/derialization tools --+ module Data.ASN1.Raw-	( GetErr-	-- * get structure-	, runGetErr-	, runGetErrState-	, runGetErrInGet+	( 	-- * ASN1 definitions+	  ASN1Class(..)+	, ASN1Tag+	, ASN1Length(..)+	, ASN1Header(..) 	, ASN1Err(..)-	, CheckFn-	, TagClass(..)-	, TagNumber-	, ValLength(..)-	, ValStruct(..)-	, Value(..)-	-- * get value from a Get structure-	, getValueCheck-	, getValue-	-- * put value in a Put structure-	, putValuePolicy-	, putValue+	-- * Enumerator events+	, ASN1Event(..)+	, iterateFile+	, iterateByteString+	, enumReadBytes+	, enumWriteBytes+	-- * serialize asn1 headers+	, getHeader+	, putHeader 	) where -import Data.Bits-import Data.Int-import Data.ASN1.Internal-import Data.Binary.Get-import Data.Binary.Put+import Data.Enumerator hiding (head, length, map)+import qualified Data.Enumerator as E+import Data.Enumerator.IO+import Data.Attoparsec.Enumerator+import Data.Attoparsec+import qualified Data.Attoparsec as A import Data.ByteString (ByteString)-import Data.Word-import Control.Monad.Error import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L+import Data.ASN1.Internal+import Control.Exception+import Data.Typeable+import Data.Word+import Data.Bits+import Control.Monad+import Control.Applicative ((<|>), (<$>)) -data TagClass =+data ASN1Class = 	  Universal 	| Application 	| Context 	| Private-	deriving (Show, Eq)+	deriving (Show,Eq,Ord,Enum) -data ValLength =+type ASN1Tag = Int++data ASN1Length = 	  LenShort Int      -- ^ Short form with only one byte. length has to be < 127. 	| LenLong Int Int   -- ^ Long form of N bytes 	| LenIndefinite     -- ^ Length is indefinite expect an EOC in the stream to finish the type-	deriving (Show, Eq)--type TagNumber = Int-type TagConstructed = Bool-type Identifier = (TagClass, TagConstructed, TagNumber)+	deriving (Show,Eq) -data ValStruct =-	  Primitive ByteString -- ^ Primitive of a strict value-	| Constructed [Value]  -- ^ Constructed of a list of values-	deriving (Show, Eq)+data ASN1Header = ASN1Header !ASN1Class !ASN1Tag !Bool !ASN1Length+	deriving (Show,Eq) -data Value = Value TagClass TagNumber ValStruct-	deriving (Show, Eq)+data ASN1Event =+	  Header ASN1Header     -- ^ ASN1 Header+	| Primitive !ByteString -- ^ Primitive+	| ConstructionBegin     -- ^ Constructed value start+	| ConstructionEnd       -- ^ Constructed value end+	deriving (Show,Eq)  data ASN1Err = 	  ASN1LengthDecodingLongContainsZero+	| ASN1WritingUnexpectedConstructionEnd+	| ASN1WritingUnexpectedInputEOF 	| ASN1PolicyFailed String String 	| ASN1NotImplemented String 	| ASN1Multiple [ASN1Err] 	| ASN1Misc String-	deriving (Show, Eq)+	| ASN1ParsingPartial+	| ASN1ParsingFail String+	deriving (Typeable, Show, Eq) -type CheckFn = (TagClass, Bool, TagNumber) -> ValLength -> Maybe ASN1Err+instance Exception ASN1Err -instance Error ASN1Err where-	noMsg = ASN1Misc ""-	strMsg = ASN1Misc+{-| iterate over a file using a file enumerator. -}+iterateFile :: FilePath -> Iteratee ASN1Event IO a -> IO (Either SomeException a)+iterateFile path p = run (enumFile path $$ joinI (enumReadBytes $$ p)) -newtype GetErr a = GE { runGE :: ErrorT ASN1Err Get a }-	deriving (Monad, MonadError ASN1Err)+{-| iterate over a lazy bytestring using a list enumerator over the bytestring chunks. -}+iterateByteString :: Monad m => L.ByteString -> Iteratee ASN1Event m a -> m (Either SomeException a)+iterateByteString bs p = run (enumList 1 (L.toChunks bs) $$ joinI (enumReadBytes $$ p)) -instance Functor GetErr where-	fmap f = GE . fmap f . runGE+{- parse state machine -}+data ParseState =+	  PSPrimitive Int+	| PSConstructing Int+	| PSConstructingEOC -runGetErr :: GetErr a -> L.ByteString -> Either ASN1Err a-runGetErr = runGet . runErrorT . runGE+{-| enumReadBytes parse bytestring and generate asn1event. -}+enumReadBytes :: Monad m => Enumeratee ByteString ASN1Event m a+enumReadBytes = checkDone $ \k -> k (Chunks []) >>== loop [0] []+	where+		loop !cs !ps = checkDone (go cs ps)+		go (n:[]) [] k = iterDesc >>= eofCheck k+				(\(c,e,nps) -> case nps of+					PSPrimitive _ -> k (Chunks [e]) >>== loop [c+n] [nps]+					_             -> k (Chunks [e, ConstructionBegin]) >>== loop [0, c+n] [nps]+				) -runGetErrState :: GetErr a -> L.ByteString -> Int64 -> Either ASN1Err (a, L.ByteString, Int64)-runGetErrState g l o =-	case runGetState (runErrorT $ runGE g) l o of-		(Left err, _, _)           -> Left err-		(Right v, datarem, parsed) -> Right (v, datarem, parsed)+		go (n:cs) (PSPrimitive i:pss) k =+			iterPrim i >>= (\e -> k (Chunks [e]) >>== loop (n+i:cs) pss) -runGetErrInGet :: GetErr a -> Get (Either ASN1Err a)-runGetErrInGet = runErrorT . runGE+		go (n:m:cs) fps@(PSConstructing i:pss) k+			| n == i    = k (Chunks [ConstructionEnd]) >>== loop (n+m:cs) pss+			| otherwise = iterDesc >>= eofCheck k+				(\(c, e, nps) -> case nps of+					PSPrimitive _ -> k (Chunks [e]) >>== loop (n+c:m:cs) (nps:fps)+					_             -> k (Chunks [e, ConstructionBegin]) >>== loop (0:n+c:m:cs) (nps:fps)+				) -liftGet :: Get a -> GetErr a-liftGet = GE . lift+		go (n:m:cs) fps@(PSConstructingEOC:pss) k =+			iterDesc >>= eofCheck k+				(\(c, e, nps) -> case e of -- check if EOC or continue+					(Header (ASN1Header _ 0 _ _)) -> k (Chunks [ConstructionEnd]) >>== loop (c+n+m:cs) pss+					_                             -> k (Chunks [e]) >>== loop (n+c:m:cs) (nps:fps)+				)+		-- error case+		go _ _ k = k (Chunks []) >>== return -geteWord8 :: GetErr Word8-geteWord8 = liftGet getWord8+		eofCheck k _ Nothing  = k (Chunks []) >>== return+		eofCheck _ f (Just x) = f $! x -geteBytes :: Int -> GetErr ByteString-geteBytes = liftGet . getBytes+		iterDesc :: Monad m => Iteratee ByteString m (Maybe (Int, ASN1Event, ParseState))+		iterDesc = iterParser ((endOfInput >> return Nothing) <|> fmap Just parseHeaderEvent) -{- marshall helper for getIdentifier to unserialize long tag number -}-getTagNumberLong :: GetErr TagNumber-getTagNumberLong = getNext 0 True-	where getNext n nz = do-		t <- fromIntegral `fmap` geteWord8-		when (nz && t == 0x80) $ throwError ASN1LengthDecodingLongContainsZero+		iterPrim i = iterParser (fmap (Primitive) (A.take i))++{- parseHeaderEvent returns the asn1event header, the length parsed and the next parse state. -}+parseHeaderEvent :: Parser (Int, ASN1Event, ParseState)+parseHeaderEvent = do+	(lbytes, asn1header@(ASN1Header _ _ pc len)) <- parseHeader+	let ps = if pc+		-- constructed value(s)+		then case len of+			LenIndefinite -> PSConstructingEOC+			LenLong _ i   -> PSConstructing i+			LenShort i    -> PSConstructing i+		-- primitive value+		else case len of+			LenIndefinite -> error "cannot do indefinite primitive"+			LenLong _ i   -> PSPrimitive i+			LenShort i    -> PSPrimitive i+	return (lbytes, Header asn1header, ps)++{- parseHeader parse a asn1 header in an attoparsec context.+ - it returns the number of bytes parsed, the asn1event for this event -}+parseHeader :: Parser (Int, ASN1Header)+parseHeader = do+	(cl,pc,t1)      <- parseFirstWord <$> anyWord8+	(tagbytes, tag) <- if t1 == 0x1f then getTagLong else return (0, t1)+	(lenbytes, len) <- getLength+	return (1+tagbytes+lenbytes, ASN1Header cl tag pc len)++{- parse an header from a single bytestring. -}+getHeader :: ByteString -> Either ASN1Err ASN1Header+getHeader l = case parse parseHeader l of+	(Fail _ _ _) -> Left (ASN1ParsingFail "header")+	(Partial _)  -> Left (ASN1ParsingPartial)+	Done b r     -> if B.null b then Right (snd r) else Left ASN1ParsingPartial++{- 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)++{- when the first tag is 0x1f, the tag is in long form, where+ - we get bytes while the 7th bit is set. -}+getTagLong :: Parser (Int, ASN1Tag)+getTagLong = do+	t <- fromIntegral <$> anyWord8+	when (t == 0x80) $ error "not canonical encoding of tag"+	if testBit t 7+		then getNext 1 (clearBit t 7)+		else return (1, t)++	where getNext !blen !n = do+		t <- fromIntegral <$> anyWord8 		if testBit t 7-			then getNext (n `shiftL` 7 + clearBit t 7) False-			else return (n `shiftL` 7 + t)+			then getNext (blen + 1) (n `shiftL` 7 + clearBit t 7)+			else return (blen + 1, n `shiftL` 7 + t) +{- get the asn1 length which is either short form if 7th bit is not set,+ - indefinite form is the 7 bit is set and every other bits clear,+ - or long form otherwise, where the next bytes will represent the length+ -}+getLength :: Parser (Int, ASN1Length)+getLength = do+	l1 <- fromIntegral <$> anyWord8+	if testBit l1 7+		then case clearBit l1 7 of+			0   -> return (1, LenIndefinite)+			len -> do+				lw <- A.take len+				return (1+len, LenLong len $ uintbs lw)+		else+			return (1, 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 -> 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 -}-putTagNumberLong :: TagNumber -> Put-putTagNumberLong n = mapM_ putWord8 $ revSethighbits $ split7bits n+putTagLong :: ASN1Tag -> [Word8]+putTagLong n = revSethighbits $ split7bits n 	where 		revSethighbits :: [Word8] -> [Word8] 		revSethighbits []     = []@@ -128,145 +239,36 @@ 			| 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- - read bytes until the 8th bit is not set -}-getIdentifier :: GetErr Identifier-getIdentifier = do-	w <- geteWord8-	let cl =-		case (w `shiftR` 6) .&. 3 of-			0 -> Universal-			1 -> Application -			2 -> Context-			3 -> Private-			_ -> 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-	return (cl, pc, vencoded)--{- | putIdentifier encode an ASN1 Identifier into a marshalled value -}-putIdentifier :: Identifier -> Put-putIdentifier (cl, pc, val) = do-	let cli = case cl of-		Universal   -> 0-		Application -> 1-		Context     -> 2-		Private     -> 3-	let pcval = if pc then 0x20 else 0x00-	if val < 0x1f-		then-			putWord8 $ fromIntegral $ (cli `shiftL` 6) .|. pcval .|. val-		else do-			putWord8 $ fromIntegral $ (cli `shiftL` 6) .|. pcval .|. 0x1f-			putTagNumberLong val--{- | getLength get the ASN1 encoded length of an item.- - if less than 0x80 then it's encoded on 1 byte, otherwise- - the first byte is the number of bytes to read as the length.- - if the number of bytes is 0, then the length is indefinite,- - and the content length is bounded by an EOC -}-getLength :: GetErr ValLength-getLength = do-	l1 <- geteWord8-	if testBit l1 7-		then case fromIntegral (clearBit l1 7) of-			0   -> return LenIndefinite-			len -> do-				lw <- geteBytes len-				return $ LenLong len (fromIntegral $ snd $ uintOfBytes lw)-		else-			return $ LenShort $ fromIntegral l1- {- | putLength encode a length into a ASN1 length.  - see getLength for the encoding rules -}-putLength :: ValLength -> Put+putLength :: ASN1Length -> [Word8] putLength (LenShort i) 	| i < 0 || i > 0x7f = error "putLength: short length is not between 0x0 and 0x80"-	| otherwise         = putWord8 $ fromIntegral i-+	| otherwise         = [fromIntegral i] putLength (LenLong _ i) 	| i < 0     = error "putLength: long length is negative"-	| otherwise = putWord8 lenbytes >> mapM_ putWord8 lw+	| otherwise = lenbytes : lw 		where 			lw       = bytesOfUInt $ fromIntegral i 			lenbytes = fromIntegral (length lw .|. 0x80)-	-putLength (LenIndefinite) = putWord8 0x80--{- helper to getValue to build a constructed list of values when length is known -}-getValueConstructed :: CheckFn -> GetErr [Value]-getValueConstructed check = do-	remain <- liftGet remaining-	if remain > 0-		then liftM2 (:) (getValueCheck check) (getValueConstructed check)-		else return []--{- helper to getValue to build a constructed list of values when length is unknown -}-getValueConstructedUntilEOC :: CheckFn -> GetErr [Value]-getValueConstructedUntilEOC check = do-	o <- getValueCheck check-	case o of-		-- technically EOC should also match (Primitive B.empty) (LenShort 0)-		Value Universal 0 _ -> return []-		_                   -> liftM (o :) (getValueConstructedUntilEOC check)--getValueOfLength :: CheckFn -> Int -> Bool -> GetErr ValStruct-getValueOfLength check len pc = do-	b <- geteBytes len-	if pc-		then case runGetErr (getValueConstructed check) (L.fromChunks [b]) of-			Right x  -> return $ Constructed x-			Left err -> throwError err-		else-			return $ Primitive b--{- | getValueCheck decode an ASN1 value and check the values received through the check fn -}-getValueCheck :: CheckFn -> GetErr Value-getValueCheck check = do-	(tc, pc, tn) <- getIdentifier-	vallen <- getLength--	{- policy checker, if it returns an error, raise it -}-	case check (tc, pc, tn) vallen of-		Just err -> throwError err-		Nothing  -> return ()--	struct <- case vallen of-		LenIndefinite -> do-			unless pc $ throwError $ ASN1Misc "lenght indefinite not allowed with primitive"-			vs <- getValueConstructedUntilEOC check-			return $ Constructed vs-		(LenShort len)  -> getValueOfLength check len pc-		(LenLong _ len) -> getValueOfLength check len pc-	return $ Value tc tn struct--getValue :: GetErr Value-getValue = getValueCheck (\_ _ -> Nothing)--putValStruct :: ValStruct -> Put-putValStruct (Primitive x)   = putByteString x-putValStruct (Constructed l) = mapM_ putValue l--putValuePolicy :: (Value -> Int -> ValLength) -> Value -> Put-putValuePolicy policy v@(Value tc tn struct) = do-	let pc =-		case struct of-			Primitive _   -> False-			Constructed _ -> True-	putIdentifier (tc, pc, tn)-	let content = runPut (putValStruct struct)-	let len = fromIntegral $ L.length content -	let lenEncoded = policy v len-	putLength lenEncoded-	putLazyByteString content-	case lenEncoded of-		LenIndefinite -> putValue $ Value Universal 0x0 (Primitive B.empty)-		_             -> return ()+putLength (LenIndefinite) = [0x80] -{- | putValue encode an ASN1 value using the shortest definite length -}-putValue :: Value -> Put-putValue = putValuePolicy (\_ len -> if len < 0x80 then LenShort len else LenLong 0 len)+{-| write Bytes of events enumeratee -}+enumWriteBytes :: Monad m => Enumeratee ASN1Event ByteString m a+enumWriteBytes = checkDone $ \k -> k (Chunks []) >>== loop []+	where+		putEoc    = putHeader $ ASN1Header Universal 0 False (LenShort 0)+		loop eocs = checkDone $ go eocs+		go eocs k = E.head >>= \x -> case x of+			Nothing                ->+				if eocs == [] then k (Chunks []) >>== return else E.throwError ASN1WritingUnexpectedInputEOF+			Just (Header hdr@(ASN1Header _ _ True len)) ->+				k (Chunks [putHeader hdr]) >>== loop ((len == LenIndefinite) : eocs)+			Just (Header hdr)      -> k (Chunks [putHeader hdr]) >>== loop eocs+			Just (Primitive p)     -> k (Chunks [p]) >>== loop eocs+			Just ConstructionBegin -> k (Chunks []) >>== loop eocs+			Just ConstructionEnd   -> case eocs of+				[]         -> E.throwError ASN1WritingUnexpectedConstructionEnd+				True : tl  -> k (Chunks [putEoc]) >>== loop tl+				False : tl -> k (Chunks []) >>== loop tl

@@ -0,0 +1,52 @@+module Data.ASN1.Stream+	( ASN1(..)+	, ASN1ConstructionType(..)+	, getConstructedEnd+	) where++import Data.ASN1.Raw+import Data.Text.Lazy (Text)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as L++data ASN1ConstructionType =+	  Sequence+	| Set+	| Container ASN1Class ASN1Tag+	deriving (Show,Eq)++data ASN1 =+	  Boolean Bool+	| IntVal Integer+	| BitString Int L.ByteString+	| OctetString L.ByteString+	| Null+	| OID [Integer]+	| Real Double+	| Enumerated+	| UTF8String Text+	| NumericString L.ByteString+	| PrintableString Text+	| T61String L.ByteString+	| VideoTexString L.ByteString+	| IA5String Text+	| UTCTime (Int, Int, Int, Int, Int, Int, Bool)+	| GeneralizedTime (Int, Int, Int, Int, Int, Int, Bool)+	| GraphicString L.ByteString+	| VisibleString L.ByteString+	| GeneralString L.ByteString+	| UniversalString Text+	| CharacterString L.ByteString+	| BMPString Text+	| Other ASN1Class ASN1Tag ByteString+	| Start ASN1ConstructionType+	| End ASN1ConstructionType+	deriving (Show, Eq)++getConstructedEnd :: Int -> [ASN1] -> ([ASN1],[ASN1])+getConstructedEnd _ xs@[]                = (xs, xs)+getConstructedEnd i ((x@(Start _)):xs)   = let (yz, zs) = getConstructedEnd (i+1) xs in (x:yz,zs)+getConstructedEnd i ((x@(End _)):xs)+	| i == 0                         = ([], xs)+	| otherwise                      = let (ys, zs) = getConstructedEnd (i-1) xs in (x:ys,zs)+getConstructedEnd i (x:xs)               = let (ys, zs) = getConstructedEnd i xs in (x:ys,zs)

@@ -0,0 +1,106 @@+module Data.ASN1.Types+	( ASN1t(..)+	, ofStream+	, toStream+	) where++import qualified Data.ASN1.Stream as S+import qualified Data.ByteString.Lazy as L+import Data.ByteString (ByteString)+import Data.Text.Lazy (Text)+import Data.ASN1.Raw (ASN1Class, ASN1Tag)++data ASN1t =+	  Boolean Bool+	| IntVal Integer+	| BitString Int L.ByteString+	| OctetString L.ByteString+	| Null+	| OID [Integer]+	| Real Double+	| Enumerated+	| UTF8String Text+	| NumericString L.ByteString+	| PrintableString Text+	| T61String L.ByteString+	| VideoTexString L.ByteString+	| IA5String Text+	| UTCTime (Int, Int, Int, Int, Int, Int, Bool)+	| GeneralizedTime (Int, Int, Int, Int, Int, Int, Bool)+	| GraphicString L.ByteString+	| VisibleString L.ByteString+	| GeneralString L.ByteString+	| UniversalString Text+	| CharacterString L.ByteString+	| BMPString Text+	| Other ASN1Class ASN1Tag ByteString+	| Sequence [ASN1t]+	| Set [ASN1t]+	| Container ASN1Class ASN1Tag [ASN1t]+	deriving (Show, Eq)++ofStream :: [S.ASN1] -> [ASN1t]+ofStream []                        = []+ofStream (S.End _ : l)             = ofStream l++ofStream (S.Start ty : l)          =+	let (c, rest) = S.getConstructedEnd 0 l in+	(case ty of+		S.Sequence         -> Sequence (ofStream c)+		S.Set              -> Set (ofStream c)+		S.Container tc tag -> Container tc tag (ofStream c)+	) : ofStream rest++ofStream (S.Boolean b : l)         = Boolean b : ofStream l+ofStream (S.IntVal i : l)          = IntVal i : ofStream l+ofStream (S.BitString i bits : l)  = BitString i bits : ofStream l+ofStream (S.OctetString b : l)     = OctetString b : ofStream l+ofStream (S.Null : l)              = Null : ofStream l+ofStream (S.OID oid : l)           = OID oid : ofStream l+ofStream (S.Real d : l)            = Real d : ofStream l+ofStream (S.Enumerated : l)        = Enumerated : ofStream l +ofStream (S.UTF8String b : l)      = UTF8String b : ofStream l +ofStream (S.NumericString b : l)   = NumericString b : ofStream l +ofStream (S.PrintableString b : l) = PrintableString b : ofStream l +ofStream (S.T61String b : l)       = T61String b : ofStream l +ofStream (S.VideoTexString b : l)  = VideoTexString b : ofStream l +ofStream (S.IA5String b : l)       = IA5String b : ofStream l +ofStream (S.UTCTime t : l)         = UTCTime t : ofStream l +ofStream (S.GeneralizedTime t : l) = GeneralizedTime t : ofStream l +ofStream (S.GraphicString b : l)   = GraphicString b : ofStream l +ofStream (S.VisibleString b : l)   = VisibleString b : ofStream l +ofStream (S.GeneralString b : l)   = GeneralString b : ofStream l +ofStream (S.UniversalString b : l) = UniversalString b : ofStream l +ofStream (S.CharacterString b : l) = CharacterString b : ofStream l +ofStream (S.BMPString b : l)       = BMPString b : ofStream l +ofStream (S.Other c t b : l)       = Other c t b : ofStream l ++toStream :: [ASN1t] -> [S.ASN1]+toStream l = concatMap toStreamOne l+	where+		toStreamOne (Sequence s)          = ([S.Start S.Sequence] ++ toStream s ++ [S.End S.Sequence])+		toStreamOne (Set s)               = ([S.Start S.Set] ++ toStream s ++ [S.End S.Set])+		toStreamOne (Container tc tag s)  = ([S.Start (S.Container tc tag)] ++ toStream s ++ [S.End (S.Container tc tag)])+		toStreamOne (Boolean b)         = [S.Boolean b]+		toStreamOne (IntVal b)          = [S.IntVal b]+		toStreamOne (BitString i b)     = [S.BitString i b]+		toStreamOne (OctetString b)     = [S.OctetString b]+		toStreamOne (Null)              = [S.Null]+		toStreamOne (OID b)             = [S.OID b]+		toStreamOne (Real b)            = [S.Real b]+		toStreamOne (Enumerated)        = [S.Enumerated]+		toStreamOne (UTF8String b)      = [S.UTF8String b]+		toStreamOne (NumericString b)   = [S.NumericString b]+		toStreamOne (PrintableString b) = [S.PrintableString b]+		toStreamOne (T61String b)       = [S.T61String b]+		toStreamOne (VideoTexString b)  = [S.VideoTexString b]+		toStreamOne (IA5String b)       = [S.IA5String b]+		toStreamOne (UTCTime b)         = [S.UTCTime b]+		toStreamOne (GeneralizedTime b) = [S.GeneralizedTime b]+		toStreamOne (GraphicString b)   = [S.GraphicString b]+		toStreamOne (VisibleString b)   = [S.VisibleString b]+		toStreamOne (GeneralString b)   = [S.GeneralString b]+		toStreamOne (UniversalString b) = [S.UniversalString b]+		toStreamOne (CharacterString b) = [S.CharacterString b]+		toStreamOne (BMPString b)       = [S.BMPString b]+		toStreamOne (Other c t b)       = [S.Other c t b]

@@ -1,1 +1,4 @@-remove FIXMEs+- remove FIXMEs+- repair CER+- remove deprecated interface and deprecated asn1t types.+- improve testing

@@ -1,21 +1,70 @@+--{-# LANGUAGE FlexibleInstances, OverlappingInstances #-}+ import Test.QuickCheck import Text.Printf  import Data.ASN1.Raw-import Data.ASN1.DER (ASN1(..))+import Data.ASN1.Stream (ASN1(..), ASN1ConstructionType(..))+import Data.ASN1.Prim+import qualified Data.ASN1.Types as T (ASN1t(..)) import qualified Data.ASN1.DER as DER+import qualified Data.ASN1.BER as BER -import Data.Binary.Get-import Data.Binary.Put import Data.Word  import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.Text.Lazy as T+import qualified Data.Enumerator as E+import Data.Enumerator (($$))  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(0,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 [Integer] arbitraryOID = do 	i1  <- choose (0,2) :: Gen Integer@@ -24,11 +73,16 @@ 	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-		ws <- replicateM len (choose (0, 255) :: Gen Int)-		return $ B.pack $ map fromIntegral ws+		arbitraryBSsized len  instance Arbitrary L.ByteString where 	arbitrary = do@@ -42,22 +96,6 @@ 		ws <- replicateM len arbitrary 		return $ T.pack ws -instance Arbitrary TagClass where-	arbitrary = elements [ Universal, Application, Context, Private ]--arbitraryValueList = choose (0,20) >>= \len -> replicateM len (suchThat arbitrary (not . isConstructed))-	where-		isConstructed (Value _ _ (Constructed _)) = True-		isConstructed _                           = False--instance Arbitrary ValStruct where-	arbitrary = oneof-		[ liftM Primitive arbitrary-		, liftM Constructed arbitraryValueList ]--instance Arbitrary Value where-	arbitrary = liftM3 Value arbitrary (suchThat arbitrary (\i -> i > 0)) arbitrary- arbitraryTime = do 	y <- choose (1951, 2050) 	m <- choose (0, 11)@@ -70,9 +108,9 @@  arbitraryListASN1 = choose (0, 20) >>= \len -> replicateM len (suchThat arbitrary (not . aList)) 	where-		aList (Set _)      = True-		aList (Sequence _) = True-		aList _            = False+		aList (T.Set _)      = True+		aList (T.Sequence _) = True+		aList _              = False  arbitraryPrintString = do 	let printableString = (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ " ()+,-./:=?")@@ -85,8 +123,7 @@  instance Arbitrary ASN1 where 	arbitrary = oneof-		[ return EOC-		, liftM Boolean arbitrary+		[ liftM Boolean arbitrary 		, liftM IntVal arbitrary 		, liftM2 BitString (choose (0,7)) arbitrary 		, liftM OctetString arbitrary@@ -95,8 +132,6 @@ 		--, Real Double 		-- , return Enumerated 		, liftM UTF8String arbitrary-		, liftM Sequence arbitraryListASN1-		, liftM Set arbitraryListASN1 		, liftM NumericString arbitrary 		, liftM PrintableString arbitraryPrintString 		, liftM T61String arbitrary@@ -110,15 +145,59 @@ 		, liftM UniversalString arbitrary 		] -prop_value_marshalling_id :: Value -> Bool-prop_value_marshalling_id v = (getVal . putVal) v == Right v+instance Arbitrary T.ASN1t where+	arbitrary = oneof+		[ liftM T.Boolean arbitrary+		, liftM T.IntVal arbitrary+		, liftM2 T.BitString (choose (0,7)) arbitrary+		, liftM T.OctetString arbitrary+		, return T.Null+		, liftM T.OID arbitraryOID+		--, Real Double+		-- , return Enumerated+		, liftM T.UTF8String arbitrary+		, liftM T.Sequence arbitraryListASN1+		, liftM T.Set arbitraryListASN1+		, liftM T.NumericString arbitrary+		, liftM T.PrintableString arbitraryPrintString+		, liftM T.T61String arbitrary+		, liftM T.VideoTexString arbitrary+		, liftM T.IA5String arbitraryIA5String+		, liftM T.UTCTime arbitraryTime+		, liftM T.GeneralizedTime arbitraryTime+		, liftM T.GraphicString arbitrary+		, liftM T.VisibleString arbitrary+		, liftM T.GeneralString arbitrary+		, liftM T.UniversalString arbitrary+		]++prop_header_marshalling_id :: ASN1Header -> Bool+prop_header_marshalling_id v = (getHeader . putHeader) v == Right v++prop_event_marshalling_id :: ASN1Events -> Bool+prop_event_marshalling_id (ASN1Events e) =+	let r = runIdentity $ E.run (E.enumList 1 e $$ E.joinI $ enumWriteReadBytes $$ E.consume) in+	case r of+		Left _  -> False+		Right z -> e == z 	where-		getVal = runGetErr getValue-		putVal = runPut . putValue+		enumWriteReadBytes = \f -> E.joinI (enumWriteBytes $$ (enumReadBytes f)) -prop_asn1_marshalling_id :: ASN1 -> Bool-prop_asn1_marshalling_id v = (DER.decodeASN1 . DER.encodeASN1) v == Right v+prop_asn1_event_marshalling_id :: ASN1 -> Bool+prop_asn1_event_marshalling_id x =+	let r = runIdentity $ E.run (E.enumList 1 [x] $$ E.joinI $ enumWriteReadRaw $$ E.consume) in+	case r of+		Left _  -> False+		Right z -> [x] == z+	where+		enumWriteReadRaw = \f -> E.joinI (BER.enumWriteRaw $$ (BER.enumReadRaw f)) +prop_asn1_ber_marshalling_id :: T.ASN1t -> Bool+prop_asn1_ber_marshalling_id v = (BER.decodeASN1 . BER.encodeASN1) v == Right v++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@@ -129,5 +208,8 @@ run_test n t = putStr ("  " ++ n ++ " ... ") >> hFlush stdout >> quickCheckWith args t  main = do-	run_test "marshalling value = id" prop_value_marshalling_id-	run_test "marshalling asn1 = id" prop_asn1_marshalling_id+	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 BER type = id" prop_asn1_ber_marshalling_id+	run_test "marshalling asn1 DER type = id" prop_asn1_der_marshalling_id

@@ -1,7 +1,9 @@ Name:                asn1-data-Version:             0.3.0+Version:             0.4.0 Description:-    ASN1 data reader and writer in raw form with supports for high level forms of ASN1 (BER, CER and DER)+    ASN1 data reader and writer in raw form with supports for high level forms of ASN1 (BER, CER and DER).+    .+    All interfaces use the enumerator interface. License:             BSD3 License-file:        LICENSE Copyright:           Vincent Hanquez <vincent@snarc.org>@@ -22,14 +24,18 @@  Library   Build-Depends:     base >= 3 && < 7,-                     binary >= 0.5,                      bytestring,                      text >= 0.11,+                     enumerator >= 0.4 && < 0.5,+                     attoparsec >= 0.8 && < 0.9,+                     attoparsec-enumerator >= 0.2 && < 0.3,                      mtl   Exposed-modules:   Data.ASN1.BER                      Data.ASN1.CER                      Data.ASN1.DER                      Data.ASN1.Raw+                     Data.ASN1.Types+                     Data.ASN1.Stream   other-modules:     Data.ASN1.Prim                      Data.ASN1.Internal   ghc-options:       -Wall