asn1-data 0.6.1.3 → 0.7.2
raw patch · 20 files changed
Files
- Data/ASN1/BER.hs +0/−245
- Data/ASN1/BinaryEncoding.hs +97/−0
- Data/ASN1/BinaryEncoding/Parse.hs +156/−0
- Data/ASN1/BinaryEncoding/Raw.hs +31/−0
- Data/ASN1/BinaryEncoding/Writer.hs +40/−0
- Data/ASN1/BitArray.hs +7/−0
- Data/ASN1/CER.hs +0/−64
- Data/ASN1/DER.hs +0/−187
- Data/ASN1/Encoding.hs +50/−0
- Data/ASN1/Get.hs +197/−0
- Data/ASN1/Internal.hs +33/−27
- Data/ASN1/Object.hs +20/−0
- Data/ASN1/Parse.hs +84/−0
- Data/ASN1/Prim.hs +61/−56
- Data/ASN1/Raw.hs +0/−266
- Data/ASN1/Serialize.hs +94/−0
- Data/ASN1/Stream.hs +59/−51
- Data/ASN1/Types.hs +58/−98
- Tests.hs +109/−171
- asn1-data.cabal +18/−15
− Data/ASN1/BER.hs
@@ -1,245 +0,0 @@--- |--- Module : Data.ASN1.BER--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ A module containing ASN1 BER specification serialization/derialization tools----module Data.ASN1.BER- ( ASN1Class(..)- , ASN1(..)- , ASN1ConstructionType(..)-- -- * enumeratee to transform between ASN1 and raw- , enumReadRawRepr- , enumReadRaw- , enumWriteRaw-- -- * enumeratee to transform between ASN1 and bytes- , enumReadBytes- , enumWriteBytes-- -- * iterate over common representation to an ASN1 stream- , iterateFile- , iterateByteString- , iterateByteStringRepr- , iterateEvents- , iterateEventsRepr-- -- * BER serialize functions- , decodeASN1EventsRepr- , decodeASN1Events- , encodeASN1Events-- , decodeASN1Stream- , decodeASN1StreamRepr- , encodeASN1Stream-- -- * BER serialize functions, deprecated- , decodeASN1- , decodeASN1s- , encodeASN1- , encodeASN1s- ) where--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 Control.Monad.Identity-import Control.Exception--import qualified Data.ByteString.Lazy as L-import Data.ByteString (ByteString)--import Data.Enumerator.Binary (enumFile)-import Data.Enumerator (Iteratee(..), Enumeratee, ($$), (>>==))-import qualified Data.Enumerator as E-import qualified Data.Enumerator.List as EL--decodeConstruction :: ASN1Header -> ASN1ConstructionType-decodeConstruction (ASN1Header Universal 0x10 _ _) = Sequence-decodeConstruction (ASN1Header Universal 0x11 _ _) = Set-decodeConstruction (ASN1Header c t _ _) = Container c t--{- | enumerate from 'Raw.ASN1Event' to an 'ASN1Repr' (ASN1 augmented by a list of raw asn1 events)- -}-enumReadRawRepr :: Monad m => Enumeratee Raw.ASN1Event ASN1Repr m a-enumReadRawRepr = E.checkDone $ \k -> k (E.Chunks []) >>== loop []- where- loop l = E.checkDone $ go l- go l k = EL.head >>= \x -> case x of- Nothing -> if l == [] then k (E.Chunks []) >>== return else E.throwError (Raw.ASN1ParsingPartial)- Just el -> p l k el-- {- on construction end, we pop the list context -}- p l k Raw.ConstructionEnd = k (E.Chunks [head l]) >>== loop (tail l)-- {- on header with construction, we pop the next element in the enumerator and- - expect a ConstructionBegin. the list context is prepended by the new construction -}- p l k el@(Raw.Header hdr@(ASN1Header _ _ True _)) = EL.head >>= \z -> case z of- Just el2@Raw.ConstructionBegin ->- let ctype = decodeConstruction hdr in- k (E.Chunks [(Start ctype, [el,el2])]) >>== loop ((End ctype,[Raw.ConstructionEnd]) : l)- Just _ -> E.throwError (Raw.ASN1ParsingFail "expecting construction")- Nothing -> E.throwError (Raw.ASN1ParsingFail "expecting construction, got EOF")-- {- on header with primtive, we pop the next element in the enumerator and- - expect a Primitive -}- p l k el@(Raw.Header hdr@(ASN1Header _ _ False _)) = EL.head >>= \z -> case z of- Just el2@(Raw.Primitive prim) ->- let (Right pr) = decodePrimitive hdr prim in- k (E.Chunks [(pr, [el,el2])]) >>== loop l- Just _ -> E.throwError (Raw.ASN1ParsingFail "expecting primitive")- Nothing -> E.throwError (Raw.ASN1ParsingFail "expecting primitive, got EOF")-- p _ _ _ = E.throwError (Raw.ASN1ParsingFail "boundary not a header")--{- | enumeratee from 'Raw.ASN1Event to 'ASN1'- -- - it's the enumerator equivalent:- - @enumReadRaw = map fst . enumReadRawRepr@- -}-enumReadRaw :: Monad m => Enumeratee Raw.ASN1Event ASN1 m a-enumReadRaw = \f -> E.joinI (enumReadRawRepr $$ (E.map fst f))--{- | 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))--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 = EL.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-- 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-- 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)-- isStart (Start _) = True- isStart _ = False- isEnd (End _) = True- isEnd _ = False---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--{-| 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))--{-| enumReadBytes is an enumeratee converting from bytestring to ASN1- it transforms chunks of bytestring into chunks of ASN1 objects -}-enumReadBytesRepr :: Monad m => Enumeratee ByteString ASN1Repr m a-enumReadBytesRepr = \f -> E.joinI (Raw.enumReadBytes $$ (enumReadRawRepr f))--{-| 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))--{-| 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)--{-| iterate over a bytestring using a list enumerator over each chunks -}-iterateByteStringRepr :: Monad m => L.ByteString -> Iteratee ASN1Repr m a -> m (Either SomeException a)-iterateByteStringRepr bs p = E.run (E.enumList 1 (L.toChunks bs) $$ E.joinI $ enumReadBytesRepr $$ p)--{-| iterate over asn1 events using a list enumerator over each chunks -}-iterateEvents :: Monad m => [Raw.ASN1Event] -> Iteratee ASN1 m a -> m (Either SomeException a)-iterateEvents evs p = E.run (E.enumList 8 evs $$ E.joinI $ enumReadRaw $$ p)--{-| iterate over asn1 events using a list enumerator over each chunks -}-iterateEventsRepr :: Monad m => [Raw.ASN1Event] -> Iteratee ASN1Repr m a -> m (Either SomeException a)-iterateEventsRepr evs p = E.run (E.enumList 8 evs $$ E.joinI $ enumReadRawRepr $$ p)--{- helper to transform a Someexception from the enumerator to an ASN1Err if possible -}-wrapASN1Err :: Either SomeException a -> Either ASN1Err a-wrapASN1Err (Left err) = Left (maybe (ASN1ParsingFail $ show err) id $ fromException err)-wrapASN1Err (Right x) = Right x--{-| decode a list of raw ASN1Events into a stream of ASN1 types -}-decodeASN1Events :: [Raw.ASN1Event] -> Either ASN1Err [ASN1]-decodeASN1Events evs = wrapASN1Err $ runIdentity (iterateEvents evs EL.consume)--{-| decode a list of raw ASN1Events into a stream of ASN1Repr types -}-decodeASN1EventsRepr :: [Raw.ASN1Event] -> Either ASN1Err [ASN1Repr]-decodeASN1EventsRepr evs = wrapASN1Err $ runIdentity (iterateEventsRepr evs EL.consume)--{-| decode a lazy bytestring as an ASN1 stream -}-decodeASN1Stream :: L.ByteString -> Either ASN1Err [ASN1]-decodeASN1Stream l = wrapASN1Err $ runIdentity (iterateByteString l EL.consume)--{-| decode a lazy bytestring as an ASN1repr stream -}-decodeASN1StreamRepr :: L.ByteString -> Either ASN1Err [ASN1Repr]-decodeASN1StreamRepr l = wrapASN1Err $ runIdentity (iterateByteStringRepr l EL.consume)--{-| encode an ASN1 Stream as raw ASN1 Events -}-encodeASN1Events :: [ASN1] -> Either ASN1Err [Raw.ASN1Event]-encodeASN1Events o = wrapASN1Err $ runIdentity run- where run = E.run (E.enumList 8 o $$ E.joinI $ enumWriteRaw $$ EL.consume)--{-| encode an ASN1 Stream as lazy bytestring -}-encodeASN1Stream :: [ASN1] -> Either ASN1Err L.ByteString-encodeASN1Stream l = either Left (Right . L.fromChunks) $ wrapASN1Err $ runIdentity run- where run = E.run (E.enumList 1 l $$ E.joinI $ enumWriteBytes $$ EL.consume)--{-# DEPRECATED decodeASN1s "use stream types with decodeASN1Stream" #-}-decodeASN1s :: L.ByteString -> Either ASN1Err [ASN1t]-decodeASN1s = either (Left) (Right . ofStream) . decodeASN1Stream--{-# DEPRECATED decodeASN1 "use stream types with decodeASN1Stream" #-}-decodeASN1 :: L.ByteString -> Either ASN1Err ASN1t-decodeASN1 = either (Left) (Right . head . ofStream) . decodeASN1Stream--{-# DEPRECATED encodeASN1s "use stream types with encodeASN1Stream" #-}-encodeASN1s :: [ASN1t] -> L.ByteString-encodeASN1s s = case encodeASN1Stream $ toStream s of- Left err -> error $ show err- Right x -> x--{-# DEPRECATED encodeASN1 "use stream types with encodeASN1Stream" #-}-encodeASN1 :: ASN1t -> L.ByteString-encodeASN1 s = case encodeASN1Stream $ toStream [s] of- Left err -> error $ show err- Right x -> x
+ Data/ASN1/BinaryEncoding.hs view
@@ -0,0 +1,97 @@+-- |+-- Module : Data.ASN1.BinaryEncoding+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- A module containing ASN1 BER and DER specification encoding/decoding.+--+{-# LANGUAGE EmptyDataDecls #-}+module Data.ASN1.BinaryEncoding+ ( BER(..)+ , DER(..)+ ) where++import Data.ASN1.Stream+import Data.ASN1.Types+import Data.ASN1.Encoding+import Data.ASN1.BinaryEncoding.Parse+import Data.ASN1.BinaryEncoding.Writer+import Data.ASN1.Prim+import qualified Control.Exception as E++-- | Basic Encoding Rules (BER)+data BER = BER++-- | Distinguished Encoding Rules (DER)+data DER = DER++instance ASN1DecodingRepr BER where+ decodeASN1Repr _ lbs = decodeEventASN1Repr (const Nothing) `fmap` parseLBS lbs++instance ASN1Decoding BER where+ decodeASN1 _ lbs = (map fst . decodeEventASN1Repr (const Nothing)) `fmap` parseLBS lbs++instance ASN1DecodingRepr DER where+ decodeASN1Repr _ lbs = decodeEventASN1Repr checkDER `fmap` parseLBS lbs++instance ASN1Decoding DER where+ decodeASN1 _ lbs = (map fst . decodeEventASN1Repr checkDER) `fmap` parseLBS lbs++instance ASN1Encoding DER where+ encodeASN1 _ l = toLazyByteString $ encodeToRaw l++decodeConstruction :: ASN1Header -> ASN1ConstructionType+decodeConstruction (ASN1Header Universal 0x10 _ _) = Sequence+decodeConstruction (ASN1Header Universal 0x11 _ _) = Set+decodeConstruction (ASN1Header c t _ _) = Container c t++decodeEventASN1Repr :: (ASN1Header -> Maybe ASN1Error) -> [ASN1Event] -> [ASN1Repr]+decodeEventASN1Repr checkHeader l = loop [] l+ where loop _ [] = []+ loop acc (h@(Header hdr@(ASN1Header _ _ True _)):ConstructionBegin:xs) =+ let ctype = decodeConstruction hdr in+ case checkHeader hdr of+ Nothing -> (Start ctype,[h,ConstructionBegin]) : loop (ctype:acc) xs+ Just err -> E.throw err+ loop acc (h@(Header hdr@(ASN1Header _ _ False _)):p@(Primitive prim):xs) =+ case checkHeader hdr of+ Nothing -> case decodePrimitive hdr prim of+ Left err -> E.throw err+ Right obj -> (obj, [h,p]) : loop acc xs+ Just err -> E.throw err+ loop (ctype:acc) (ConstructionEnd:xs) = (End ctype, [ConstructionEnd]) : loop acc xs+ loop _ (x:_) = E.throw $ StreamUnexpectedSituation (show x)++-- | DER header need to be all of finite size and of minimum possible size.+checkDER :: ASN1Header -> Maybe ASN1Error+checkDER (ASN1Header _ _ _ len) = checkLength len+ where checkLength :: ASN1Length -> Maybe ASN1Error+ checkLength LenIndefinite = Just $ PolicyFailed "DER" "indefinite length not allowed"+ checkLength (LenShort _) = Nothing+ checkLength (LenLong n i)+ | n == 1 && i < 0x80 = Just $ PolicyFailed "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 $ PolicyFailed "DER" "long length is not shortest"++encodeToRaw :: [ASN1] -> [ASN1Event]+encodeToRaw = concatMap writeTree . mkTree+ where writeTree (p@(Start _),children) = snd $ encodeConstructed p children+ writeTree (p,_) = snd $ encodePrimitive p++ mkTree [] = []+ mkTree (x@(Start _):xs) =+ let (tree, r) = spanEnd 0 xs+ in (x,tree):mkTree r+ mkTree (p:xs) = (p,[]) : mkTree xs++ spanEnd :: Int -> [ASN1] -> ([ASN1], [ASN1])+ spanEnd _ [] = ([], [])+ spanEnd 0 (x@(End _):xs) = ([x], xs)+ spanEnd lvl (x:xs) = case x of+ Start _ -> let (ys, zs) = spanEnd (lvl+1) xs in (x:ys, zs)+ End _ -> let (ys, zs) = spanEnd (lvl-1) xs in (x:ys, zs)+ _ -> let (ys, zs) = spanEnd lvl xs in (x:ys, zs)
+ Data/ASN1/BinaryEncoding/Parse.hs view
@@ -0,0 +1,156 @@+-- |+-- Module : Data.ASN1.BinaryEncoding.Parse+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- Generic parsing facility for ASN1.+--+module Data.ASN1.BinaryEncoding.Parse+ (+ -- * incremental parsing interfaces+ runParseState+ , isParseDone+ , newParseState+ , ParseState+ , ParseCursor+ -- * simple parsing interfaces+ , parseLBS+ , parseBS+ ) where++import Control.Arrow (first)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.ASN1.Types+import Data.ASN1.Get+import Data.ASN1.Serialize+import Data.Word+import Data.Maybe (fromJust)++-- | nothing means the parser stop this construction on+-- an ASN1 end tag, otherwise specify the position+-- where the construction terminate.+type ConstructionEndAt = Maybe Word64++data ParseExpect = ExpectHeader (Maybe (B.ByteString -> Result ASN1Header))+ | ExpectPrimitive Word64 (Maybe (B.ByteString -> Result ByteString))++type ParsePosition = Word64++-- | represent the parsing state of an ASN1 stream.+data ParseState = ParseState [ConstructionEndAt] ParseExpect ParsePosition++-- | create a new empty parse state. position is 0+newParseState :: ParseState+newParseState = ParseState [] (ExpectHeader Nothing) 0++isEOC :: ASN1Header -> Bool+isEOC (ASN1Header cl t _ _) = cl == Universal && t == 0++asn1LengthToConst :: ASN1Length -> Maybe Word64+asn1LengthToConst (LenShort n) = Just $ fromIntegral n+asn1LengthToConst (LenLong _ n) = Just $ fromIntegral n+asn1LengthToConst LenIndefinite = Nothing++-- in the future, drop this for the `mplus` with Either.+mplusEither :: Either b a -> (a -> Either b c) -> Either b c+mplusEither (Left e) _ = Left e+mplusEither (Right e) f = f e++-- | Represent the events and state thus far.+type ParseCursor = ([ASN1Event], ParseState)++-- | run incrementally the ASN1 parser on a bytestring.+-- the result can be either an error, or on success a list+-- of events, and the new parsing state.+runParseState :: ParseState -- ^ parser state+ -> ByteString -- ^ input data as bytes+ -> Either ASN1Error ParseCursor+runParseState = loop+ where+ loop iniState bs+ | B.null bs = terminateAugment (([], iniState), bs) `mplusEither` (Right . fst)+ | otherwise = go iniState bs `mplusEither` terminateAugment+ `mplusEither` \((evs, newState), nbs) -> loop newState nbs+ `mplusEither` (Right . first (evs ++))++ terminateAugment ret@((evs, ParseState stackEnd pe pos), r) =+ case stackEnd of+ Just endPos:xs+ | pos > endPos -> Left StreamConstructionWrongSize+ | pos == endPos -> terminateAugment ((evs ++ [ConstructionEnd], ParseState xs pe pos), r)+ | otherwise -> Right ret + _ -> Right ret++ -- go get one element (either a primitive or a header) from the bytes+ -- and returns the new cursor and the remaining byte.+ go :: ParseState -> ByteString -> Either ASN1Error (ParseCursor, ByteString)+ go (ParseState stackEnd (ExpectHeader cont) pos) bs =+ case runGetHeader cont pos bs of+ Fail s -> Left $ ParsingHeaderFail s+ Partial f -> Right (([], ParseState stackEnd (ExpectHeader $ Just f) pos), B.empty)+ Done hdr nPos remBytes+ | isEOC hdr -> case stackEnd of+ [] -> Left StreamUnexpectedEOC+ Just _:_ -> Left StreamUnexpectedEOC+ Nothing:newStackEnd -> Right ( ( [ConstructionEnd]+ , ParseState newStackEnd (ExpectHeader Nothing) nPos)+ , remBytes)+ | otherwise -> case hdr of+ (ASN1Header _ _ True len) ->+ let nEnd = (nPos +) `fmap` asn1LengthToConst len+ in Right ( ( [Header hdr,ConstructionBegin]+ , ParseState (nEnd:stackEnd) (ExpectHeader Nothing) nPos)+ , remBytes)+ (ASN1Header _ _ False LenIndefinite) -> Left StreamInfinitePrimitive+ (ASN1Header _ _ False len) ->+ let pLength = fromJust $ asn1LengthToConst len+ in if pLength == 0+ then Right ( ( [Header hdr,Primitive B.empty]+ , ParseState stackEnd (ExpectHeader Nothing) nPos)+ , remBytes)+ else Right ( ( [Header hdr]+ , ParseState stackEnd (ExpectPrimitive pLength Nothing) nPos)+ , remBytes)+ go (ParseState stackEnd (ExpectPrimitive len cont) pos) bs =+ case runGetPrimitive cont len pos bs of+ Fail _ -> error "primitive parsing failed"+ Partial f -> Right (([], ParseState stackEnd (ExpectPrimitive len $ Just f) pos), B.empty)+ Done p nPos remBytes -> Right (([Primitive p], ParseState stackEnd (ExpectHeader Nothing) nPos), remBytes)++ runGetHeader Nothing = \pos -> runGetPos pos getHeader+ runGetHeader (Just f) = const f++ runGetPrimitive Nothing n = \pos -> runGetPos pos (getBytes $ fromIntegral n)+ runGetPrimitive (Just f) _ = const f++-- | when no more input is available, it's important to check that the parser is+-- in a finish state too.+isParseDone :: ParseState -> Bool+isParseDone (ParseState [] (ExpectHeader Nothing) _) = True+isParseDone _ = False++-- | Parse one lazy bytestring and returns on success all ASN1 events associated.+parseLBS :: L.ByteString -> Either ASN1Error [ASN1Event]+parseLBS lbs = foldrEither process ([], newParseState) (L.toChunks lbs) `mplusEither` onSuccess+ where + onSuccess (allEvs, finalState)+ | isParseDone finalState = Right $ concat $ reverse allEvs+ | otherwise = Left ParsingPartial++ process :: ([[ASN1Event]], ParseState) -> ByteString -> Either ASN1Error ([[ASN1Event]], ParseState)+ process (pevs, cState) bs = runParseState cState bs `mplusEither` \(es, cState') -> Right (es : pevs, cState')++ foldrEither :: (a -> ByteString -> Either ASN1Error a) -> a -> [ByteString] -> Either ASN1Error a+ foldrEither _ acc [] = Right acc+ foldrEither f acc (x:xs) = f acc x `mplusEither` \nacc -> foldrEither f nacc xs++-- | Parse one strict bytestring and returns on success all ASN1 events associated.+parseBS :: ByteString -> Either ASN1Error [ASN1Event]+parseBS bs = runParseState newParseState bs `mplusEither` onSuccess+ where onSuccess (evs, pstate)+ | isParseDone pstate = Right evs+ | otherwise = Left ParsingPartial
+ Data/ASN1/BinaryEncoding/Raw.hs view
@@ -0,0 +1,31 @@+-- |+-- Module : Data.ASN1.BinaryEncoding.Raw+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- Raw encoding of binary format (BER/DER/CER)+--+module Data.ASN1.BinaryEncoding.Raw+ (+ -- * types+ ASN1Header(..)+ , ASN1Class(..)+ , ASN1Tag+ , ASN1Length(..)+ , ASN1Event(..)++ -- * parser+ , parseLBS+ , parseBS++ -- * writer+ , toLazyByteString+ , toByteString++ ) where++import Data.ASN1.BinaryEncoding.Parse+import Data.ASN1.BinaryEncoding.Writer+import Data.ASN1.Types
+ Data/ASN1/BinaryEncoding/Writer.hs view
@@ -0,0 +1,40 @@+-- |+-- Module : Data.ASN1.BinaryEncoding.Writer+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- Serialize events for streaming.+--+module Data.ASN1.BinaryEncoding.Writer+ ( toByteString+ , toLazyByteString+ ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.ASN1.Types+import Data.ASN1.Serialize+import Data.Serialize.Put (runPut)++-- | transform a list of ASN1 Events into a strict bytestring+toByteString :: [ASN1Event] -> ByteString+toByteString = B.concat . L.toChunks . toLazyByteString++-- | transform a list of ASN1 Events into a lazy bytestring+toLazyByteString :: [ASN1Event] -> L.ByteString+toLazyByteString evs = L.fromChunks $ loop [] evs+ where loop _ [] = []+ loop acc (x@(Header (ASN1Header _ _ pc len)):xs) = toBs x : loop (if pc then (len == LenIndefinite):acc else acc) xs+ loop acc (ConstructionEnd:xs) = case acc of+ [] -> error "malformed stream: end before construction"+ (True:r) -> toBs ConstructionEnd : loop r xs+ (False:r) -> loop r xs+ loop acc (x:xs) = toBs x : loop acc xs++ toBs (Header hdr) = runPut $ putHeader hdr+ toBs (Primitive bs) = bs+ toBs ConstructionBegin = B.empty+ toBs ConstructionEnd = B.empty
Data/ASN1/BitArray.hs view
@@ -1,3 +1,10 @@+-- |+-- Module : Data.ASN1.BitArray+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+-- {-# LANGUAGE DeriveDataTypeable #-} module Data.ASN1.BitArray ( BitArray(..)
− Data/ASN1/CER.hs
@@ -1,64 +0,0 @@--- |--- Module : Data.ASN1.CER--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ A module containing ASN1 CER specification serialization/derialization tools----module Data.ASN1.CER- ( ASN1Class(..)- , ASN1(..)-- -- * CER serial functions- , decodeASN1s- , encodeASN1s- , decodeASN1- , encodeASN1- ) where--import Data.ASN1.Raw-import Data.ASN1.Prim-import Data.ASN1.Types (ASN1t)-import qualified Data.ASN1.BER as BER-import qualified Data.ByteString.Lazy as L--{--- 9.2 String encoding forms-string values shall be encoded with a primitive encoding if they would-require no more than 1000 contents octets, and as a constructed encoding otherwise.-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- then Constructed $ map (Value Universal tn . (Primitive . B.concat . L.toChunks)) $ repack1000 l- else Primitive $ B.concat $ L.toChunks l- where- repack1000 x =- if L.length x > 1000- then - let (x1, x2) = L.splitAt 1000 x in- x1 : repack1000 x2- else- [ x ]--}--{-# DEPRECATED decodeASN1s "use stream types with decodeASN1Stream" #-}-decodeASN1s :: L.ByteString -> Either ASN1Err [ASN1t]-decodeASN1s = BER.decodeASN1s--{-# DEPRECATED decodeASN1 "use stream types with decodeASN1Stream" #-}-decodeASN1 :: L.ByteString -> Either ASN1Err ASN1t-decodeASN1 = BER.decodeASN1--{-# DEPRECATED encodeASN1s "use stream types with encodeASN1Stream" #-}-encodeASN1s :: [ASN1t] -> L.ByteString-encodeASN1s = BER.encodeASN1s--{-# DEPRECATED encodeASN1 "use stream types with encodeASN1Stream" #-}-encodeASN1 :: ASN1t -> L.ByteString-encodeASN1 = BER.encodeASN1
− Data/ASN1/DER.hs
@@ -1,187 +0,0 @@--- |--- Module : Data.ASN1.DER--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ A module containing ASN1 DER specification serialization/derialization tools----module Data.ASN1.DER- ( ASN1Class(..)- , ASN1(..)- , ASN1ConstructionType(..)-- -- * enumeratee to transform between ASN1 and raw- , enumReadRawRepr- , enumReadRaw- , enumWriteRaw-- -- * enumeratee to transform between ASN1 and bytes- , enumReadBytes- , enumReadBytesRepr- , enumWriteBytes-- -- * iterate over common representation to an ASN1 stream- , iterateFile- , iterateByteString- , iterateByteStringRepr- , iterateEvents- , iterateEventsRepr-- -- * DER serialize functions- , decodeASN1EventsRepr- , decodeASN1Events- , encodeASN1Events-- , decodeASN1Stream- , decodeASN1StreamRepr- , encodeASN1Stream-- -- * DER serialize functions, deprecated- , decodeASN1- , decodeASN1s- , encodeASN1- , encodeASN1s- ) where--import Data.ASN1.Raw (ASN1Class(..), ASN1Length(..), ASN1Header(..), ASN1Event(..), ASN1Err(..))-import qualified Data.ASN1.Raw as Raw--import Data.ASN1.Prim-import Data.ASN1.Stream (ASN1Repr)-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.Binary (enumFile)-import qualified Data.Enumerator as E-import qualified Data.Enumerator.List as EL--{- | Check if the length is the minimum possible and it's not indefinite -}-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"--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 = EL.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--{- | 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)--{- | enumReadRawRepr is an enumeratee from raw events to asn1repr -}-enumReadRawRepr :: Monad m => Enumeratee Raw.ASN1Event ASN1Repr m a-enumReadRawRepr = \f -> E.joinI (checkRawDER $$ BER.enumReadRawRepr f)--{- | enumWriteRaw is an enumeratee from asn1 to raw events -}-enumWriteRaw :: Monad m => Enumeratee ASN1 Raw.ASN1Event m a-enumWriteRaw = BER.enumWriteRaw--{-| 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))--{-| enumReadBytes is an enumeratee converting from bytestring to ASN1- it transforms chunks of bytestring into chunks of ASN1 objects -}-enumReadBytesRepr :: Monad m => Enumeratee ByteString ASN1Repr m a-enumReadBytesRepr = \f -> E.joinI (Raw.enumReadBytes $$ (enumReadRawRepr f))--{-| 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))--{-| 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)--{-| iterate over a bytestring using a list enumerator over each chunks -}-iterateByteStringRepr :: Monad m => L.ByteString -> Iteratee ASN1Repr m a -> m (Either SomeException a)-iterateByteStringRepr bs p = E.run (E.enumList 1 (L.toChunks bs) $$ E.joinI $ enumReadBytesRepr $$ p)--{-| iterate over asn1 events using a list enumerator over each chunks -}-iterateEvents :: Monad m => [Raw.ASN1Event] -> Iteratee ASN1 m a -> m (Either SomeException a)-iterateEvents evs p = E.run (E.enumList 8 evs $$ E.joinI $ enumReadRaw $$ p)--{-| iterate over asn1 events using a list enumerator over each chunks -}-iterateEventsRepr :: Monad m => [Raw.ASN1Event] -> Iteratee ASN1Repr m a -> m (Either SomeException a)-iterateEventsRepr evs p = E.run (E.enumList 8 evs $$ E.joinI $ enumReadRawRepr $$ p)--{- helper to transform a Someexception from the enumerator to an ASN1Err if possible -}-wrapASN1Err :: Either SomeException a -> Either ASN1Err a-wrapASN1Err (Left err) = Left (maybe (ASN1ParsingFail $ show err) id $ fromException err)-wrapASN1Err (Right x) = Right x--{-| decode a list of raw ASN1Events into a stream of ASN1 types -}-decodeASN1Events :: [Raw.ASN1Event] -> Either ASN1Err [ASN1]-decodeASN1Events evs = wrapASN1Err $ runIdentity (iterateEvents evs EL.consume)--{-| decode a list of raw ASN1Events into a stream of ASN1Repr types -}-decodeASN1EventsRepr :: [Raw.ASN1Event] -> Either ASN1Err [ASN1Repr]-decodeASN1EventsRepr evs = wrapASN1Err $ runIdentity (iterateEventsRepr evs EL.consume)--{-| decode a lazy bytestring as an ASN1 stream -}-decodeASN1Stream :: L.ByteString -> Either ASN1Err [ASN1]-decodeASN1Stream l = wrapASN1Err $ runIdentity (iterateByteString l EL.consume)--{-| decode a lazy bytestring as an ASN1repr stream -}-decodeASN1StreamRepr :: L.ByteString -> Either ASN1Err [ASN1Repr]-decodeASN1StreamRepr l = wrapASN1Err $ runIdentity (iterateByteStringRepr l EL.consume)--{-| encode an ASN1 Stream as raw ASN1 Events -}-encodeASN1Events :: [ASN1] -> Either ASN1Err [Raw.ASN1Event]-encodeASN1Events o = wrapASN1Err $ runIdentity run- where run = E.run (E.enumList 8 o $$ E.joinI $ enumWriteRaw $$ EL.consume)--{-| encode an ASN1 Stream as lazy bytestring -}-encodeASN1Stream :: [ASN1] -> Either ASN1Err L.ByteString-encodeASN1Stream l = either Left (Right . L.fromChunks) $ wrapASN1Err $ runIdentity run- where run = E.run (E.enumList 1 l $$ E.joinI $ enumWriteBytes $$ EL.consume)--{-# DEPRECATED decodeASN1s "use stream types with decodeASN1Stream" #-}-decodeASN1s :: L.ByteString -> Either ASN1Err [ASN1t]-decodeASN1s = either (Left) (Right . ofStream) . decodeASN1Stream--{-# DEPRECATED decodeASN1 "use stream types with decodeASN1Stream" #-}-decodeASN1 :: L.ByteString -> Either ASN1Err ASN1t-decodeASN1 = either (Left) (Right . head . ofStream) . decodeASN1Stream--{-# DEPRECATED encodeASN1s "use stream types with encodeASN1Stream" #-}-encodeASN1s :: [ASN1t] -> L.ByteString-encodeASN1s s = case encodeASN1Stream $ toStream s of- Left err -> error $ show err- Right x -> x--{-# DEPRECATED encodeASN1 "use stream types with encodeASN1Stream" #-}-encodeASN1 :: ASN1t -> L.ByteString-encodeASN1 s = case encodeASN1Stream $ toStream [s] of- Left err -> error $ show err- Right x -> x
+ Data/ASN1/Encoding.hs view
@@ -0,0 +1,50 @@+-- |+-- Module : Data.ASN1.Encoding+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+module Data.ASN1.Encoding+ (+ -- * generic class for decoding and encoding stream+ ASN1Decoding(..)+ , ASN1DecodingRepr(..)+ , ASN1Encoding(..)+ -- * strict bytestring version+ , decodeASN1'+ , decodeASN1Repr'+ , encodeASN1'+ ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.ASN1.Stream+import Data.ASN1.Types++-- | Describe an ASN1 decoding, that transform a bytestream into an asn1stream+class ASN1Decoding a where+ -- | decode a lazy bytestring into an ASN1 stream+ decodeASN1 :: a -> L.ByteString -> Either ASN1Error [ASN1]++-- | transition class.+class ASN1DecodingRepr a where+ -- | decode a lazy bytestring into an ASN1 stream+ decodeASN1Repr :: a -> L.ByteString -> Either ASN1Error [ASN1Repr]++-- | Describe an ASN1 encoding, that transform an asn1stream into a bytestream+class ASN1Encoding a where+ -- | encode a stream into a lazy bytestring+ encodeASN1 :: a -> [ASN1] -> L.ByteString+ +-- | decode a strict bytestring into an ASN1 stream+decodeASN1' :: ASN1Decoding a => a -> B.ByteString -> Either ASN1Error [ASN1]+decodeASN1' encoding bs = decodeASN1 encoding $ L.fromChunks [bs]++-- | decode a strict bytestring into an ASN1Repr stream+decodeASN1Repr' :: ASN1DecodingRepr a => a -> B.ByteString -> Either ASN1Error [ASN1Repr]+decodeASN1Repr' encoding bs = decodeASN1Repr encoding $ L.fromChunks [bs]++-- | encode a stream into a strict bytestring+encodeASN1' :: ASN1Encoding a => a -> [ASN1] -> B.ByteString+encodeASN1' encoding = B.concat . L.toChunks . encodeASN1 encoding
+ Data/ASN1/Get.hs view
@@ -0,0 +1,197 @@+-- |+-- Module : Data.ASN1.Get+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- Simple get module with really simple accessor for ASN1.+--+-- Original code is pulled from the Get module from cereal+-- which is covered by:+-- Copyright : Lennart Kolmodin, Galois Inc. 2009+-- License : BSD3-style (see LICENSE)+--+-- The original code has been tailored and reduced to only cover the useful+-- case for asn1 and augmented by a position.+--+{-# LANGUAGE Rank2Types #-}+module Data.ASN1.Get+ ( Result(..)+ , Input+ , Get+ , runGetPos+ , runGet+ , getBytes+ , getBytesCopy+ , getWord8+ ) where++import Control.Applicative (Applicative(..),Alternative(..))+import Control.Monad (ap,MonadPlus(..))+import Data.Maybe (fromMaybe)+import Foreign++import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B++-- | The result of a parse.+data Result r = Fail String+ -- ^ The parse failed. The 'String' is the+ -- message describing the error, if any.+ | Partial (B.ByteString -> Result r)+ -- ^ Supply this continuation with more input so that+ -- the parser can resume. To indicate that no more+ -- input is available, use an 'B.empty' string.+ | Done r Position B.ByteString+ -- ^ The parse succeeded. The 'B.ByteString' is the+ -- input that had not yet been consumed (if any) when+ -- the parse succeeded.++instance Show r => Show (Result r) where+ show (Fail msg) = "Fail " ++ show msg+ show (Partial _) = "Partial _"+ show (Done r pos bs) = "Done " ++ show r ++ " " ++ show pos ++ " " ++ show bs++instance Functor Result where+ fmap _ (Fail msg) = Fail msg+ fmap f (Partial k) = Partial (fmap f . k)+ fmap f (Done r p bs) = Done (f r) p bs++type Input = B.ByteString+type Buffer = Maybe B.ByteString++type Failure r = Input -> Buffer -> More -> Position -> String -> Result r+type Success a r = Input -> Buffer -> More -> Position -> a -> Result r+type Position = Word64++-- | Have we read all available input?+data More = Complete+ | Incomplete (Maybe Int)+ deriving (Eq)++-- | The Get monad is an Exception and State monad.+newtype Get a = Get+ { unGet :: forall r. Input -> Buffer -> More -> Position -> Failure r -> Success a r -> Result r }++append :: Buffer -> Buffer -> Buffer+append l r = B.append `fmap` l <*> r+{-# INLINE append #-}++bufferBytes :: Buffer -> B.ByteString+bufferBytes = fromMaybe B.empty+{-# INLINE bufferBytes #-}++instance Functor Get where+ fmap p m =+ Get $ \s0 b0 m0 p0 kf ks ->+ let ks' s1 b1 m1 p1 a = ks s1 b1 m1 p1 (p a)+ in unGet m s0 b0 m0 p0 kf ks'++instance Applicative Get where+ pure = return+ (<*>) = ap++instance Alternative Get where+ empty = failDesc "empty"+ (<|>) = mplus++-- Definition directly from Control.Monad.State.Strict+instance Monad Get where+ return a = Get $ \ s0 b0 m0 p0 _ ks -> ks s0 b0 m0 p0 a++ m >>= g = Get $ \s0 b0 m0 p0 kf ks ->+ let ks' s1 b1 m1 p1 a = unGet (g a) s1 b1 m1 p1 kf ks+ in unGet m s0 b0 m0 p0 kf ks'++ fail = failDesc++instance MonadPlus Get where+ mzero = failDesc "mzero"+ mplus a b =+ Get $ \s0 b0 m0 p0 kf ks ->+ let kf' _ b1 m1 p1 _ = unGet b (s0 `B.append` bufferBytes b1)+ (b0 `append` b1) m1 p1 kf ks+ in unGet a s0 (Just B.empty) m0 p0 kf' ks++------------------------------------------------------------------------++put :: Position -> B.ByteString -> Get ()+put pos s = Get (\_ b0 m p0 _ k -> k s b0 m (p0+pos) ())+{-# INLINE put #-}++finalK :: B.ByteString -> t -> t1 -> Position -> r -> Result r+finalK s _ _ p a = Done a p s++failK :: Failure a+failK _ _ _ p s = Fail (show p ++ ":" ++ s)++-- | Run the Get monad applies a 'get'-based parser on the input ByteString+runGetPos :: Position -> Get a -> B.ByteString -> Result a+runGetPos pos m str = unGet m str Nothing (Incomplete Nothing) pos failK finalK+{-# INLINE runGetPos #-}++runGet :: Get a -> B.ByteString -> Result a+runGet = runGetPos 0+{-# INLINE runGet #-}++-- | If at least @n@ bytes of input are available, return the current+-- input, otherwise fail.+ensure :: Int -> Get B.ByteString+ensure n = n `seq` Get $ \ s0 b0 m0 p0 kf ks ->+ if B.length s0 >= n+ then ks s0 b0 m0 p0 s0+ else unGet (demandInput >> ensureRec n) s0 b0 m0 p0 kf ks+{-# INLINE ensure #-}++-- | If at least @n@ bytes of input are available, return the current+-- input, otherwise fail.+ensureRec :: Int -> Get B.ByteString+ensureRec n = Get $ \s0 b0 m0 p0 kf ks ->+ if B.length s0 >= n+ then ks s0 b0 m0 p0 s0+ else unGet (demandInput >> ensureRec n) s0 b0 m0 p0 kf ks++-- | Immediately demand more input via a 'Partial' continuation+-- result.+demandInput :: Get ()+demandInput = Get $ \s0 b0 m0 p0 kf ks ->+ case m0 of+ Complete -> kf s0 b0 m0 p0 "too few bytes"+ Incomplete mb -> Partial $ \s ->+ if B.null s+ then kf s0 b0 m0 p0 "too few bytes"+ else let update l = l - B.length s+ s1 = s0 `B.append` s+ b1 = b0 `append` Just s+ in ks s1 b1 (Incomplete (update `fmap` mb)) p0 ()++failDesc :: String -> Get a+failDesc err = Get (\s0 b0 m0 p0 kf _ -> kf s0 b0 m0 p0 ("Failed reading: " ++ err))++------------------------------------------------------------------------+-- Utility with ByteStrings++-- | An efficient 'get' method for strict ByteStrings. Fails if fewer+-- than @n@ bytes are left in the input. This function creates a fresh+-- copy of the underlying bytes.+getBytesCopy :: Int -> Get B.ByteString+getBytesCopy n = do+ bs <- getBytes n+ return $! B.copy bs++------------------------------------------------------------------------+-- Helpers++-- | Pull @n@ bytes from the input, as a strict ByteString.+getBytes :: Int -> Get B.ByteString+getBytes n = do+ s <- ensure n+ put (fromIntegral n) $ B.unsafeDrop n s+ return $ B.unsafeTake n s++getWord8 :: Get Word8+getWord8 = do+ s <- ensure 1+ put 1 $ B.unsafeTail s+ return $ B.unsafeHead s
Data/ASN1/Internal.hs view
@@ -1,10 +1,17 @@+-- |+-- Module : Data.ASN1.Internal+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+-- module Data.ASN1.Internal- ( uintOfBytes- , intOfBytes- , bytesOfUInt- , bytesOfInt- , putVarEncodingIntegral- ) where+ ( uintOfBytes+ , intOfBytes+ , bytesOfUInt+ , bytesOfInt+ , putVarEncodingIntegral+ ) where import Data.Word import Data.Bits@@ -18,31 +25,30 @@ --bytesOfUInt i = B.unfoldr (\x -> if x == 0 then Nothing else Just (fromIntegral (x .&. 0xff), x `shiftR` 8)) i bytesOfUInt :: Integer -> [Word8] bytesOfUInt x = reverse (list x)- where- list i = if i <= 0xff then [fromIntegral i] else (fromIntegral i .&. 0xff) : list (i `shiftR` 8)+ where list i = if i <= 0xff then [fromIntegral i] else (fromIntegral i .&. 0xff) : list (i `shiftR` 8) {- | intOfBytes returns the number of bytes in the list and the represented integer by a two's completement list of bytes -} intOfBytes :: ByteString -> (Int, Integer) intOfBytes b- | B.length b == 0 = (0, 0)- | otherwise = (len, if isNeg then -(maxIntLen - v + 1) else v)- where- (len, v) = uintOfBytes b- maxIntLen = 2 ^ (8 * len) - 1- isNeg = testBit (B.head b) 7+ | B.length b == 0 = (0, 0)+ | otherwise = (len, if isNeg then -(maxIntLen - v + 1) else v)+ where+ (len, v) = uintOfBytes b+ maxIntLen = 2 ^ (8 * len) - 1+ isNeg = testBit (B.head b) 7 {- | bytesOfInt convert an integer into a two's completemented list of bytes -} bytesOfInt :: Integer -> [Word8] bytesOfInt i- | i > 0 = if testBit (head uints) 7 then 0 : uints else uints- | i == 0 = [0]- | otherwise = if testBit (head nints) 7 then nints else 0xff : nints- where- uints = bytesOfUInt (abs i)- nints = reverse $ plusOne $ reverse $ map complement $ uints- plusOne [] = [1]- plusOne (x:xs) = if x == 0xff then 0 : plusOne xs else (x+1) : xs+ | i > 0 = if testBit (head uints) 7 then 0 : uints else uints+ | i == 0 = [0]+ | otherwise = if testBit (head nints) 7 then nints else 0xff : nints+ where+ uints = bytesOfUInt (abs i)+ 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.@@ -57,8 +63,8 @@ -} 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+ 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
+ Data/ASN1/Object.hs view
@@ -0,0 +1,20 @@+-- |+-- Module : Data.ASN1.Object+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+module Data.ASN1.Object+ ( ASN1Object(..)+ ) where++import Data.ASN1.Stream++-- | an object that can be marshalled from and to ASN1+class ASN1Object a where+ -- | transform an object into an ASN1 stream.+ toASN1 :: a -> [ASN1]+ -- | returns either an object along the remaining ASN1 stream,+ -- or an error.+ fromASN1 :: [ASN1] -> Either String (a, [ASN1])
+ Data/ASN1/Parse.hs view
@@ -0,0 +1,84 @@+-- |+-- Module : Data.ASN1.Parse+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Data.ASN1.Parse+ ( ParseASN1+ , runParseASN1State+ , runParseASN1+ , onNextContainer+ , onNextContainerMaybe+ , getNextContainer+ , getNextContainerMaybe+ , getNext+ , hasNext+ ) where++import Data.ASN1.Stream+import Control.Monad.State+import Control.Monad.Error+import Control.Applicative (Applicative, (<$>))++-- | Parse ASN1 Monad+newtype ParseASN1 a = P { runP :: ErrorT String (State [ASN1]) a }+ deriving (Applicative, Functor, Monad, MonadError String)++-- | run the parse monad over a stream and returns the result and the remaining ASN1 Stream.+runParseASN1State :: ParseASN1 a -> [ASN1] -> Either String (a,[ASN1])+runParseASN1State f s =+ case runState (runErrorT (runP f)) s of+ (Left err, _) -> Left err+ (Right r, l) -> Right (r,l)++-- | run the parse monad over a stream and returns the result.+runParseASN1 :: ParseASN1 a -> [ASN1] -> Either String a+runParseASN1 f s = either Left (Right . fst) $ runParseASN1State f s++-- | get next element from the stream+getNext :: ParseASN1 ASN1+getNext = do+ list <- P (lift get)+ case list of+ [] -> throwError "empty"+ (h:l) -> P (lift (put l)) >> return h++-- | get next container of specified type and return all its elements+getNextContainer :: ASN1ConstructionType -> ParseASN1 [ASN1]+getNextContainer ty = do+ list <- P (lift get)+ case list of+ [] -> throwError "empty"+ (h:l) | h == Start ty -> do let (l1, l2) = getConstructedEnd 0 l+ P (lift $ put l2) >> return l1+ | otherwise -> throwError "not an expected container"+++-- | run a function of the next elements of a container of specified type+onNextContainer :: ASN1ConstructionType -> ParseASN1 a -> ParseASN1 a+onNextContainer ty f = getNextContainer ty >>= either throwError return . runParseASN1 f++-- | just like getNextContainer, except it doesn't throw an error if the container doesn't exists.+getNextContainerMaybe :: ASN1ConstructionType -> ParseASN1 (Maybe [ASN1])+getNextContainerMaybe ty = do+ list <- P (lift get)+ case list of+ [] -> return Nothing+ (h:l) | h == Start ty -> do let (l1, l2) = getConstructedEnd 0 l+ P (lift $ put l2) >> return (Just l1)+ | otherwise -> return Nothing++-- | just like onNextContainer, except it doens't throw an error if the container doesn't exists.+onNextContainerMaybe :: ASN1ConstructionType -> ParseASN1 a -> ParseASN1 (Maybe a)+onNextContainerMaybe ty f = do+ n <- getNextContainerMaybe ty+ case n of+ Just l -> either throwError (return . Just) $ runParseASN1 f l+ Nothing -> return Nothing++-- | returns if there's more elements in the stream.+hasNext :: ParseASN1 Bool+hasNext = not . null <$> P (lift get)
Data/ASN1/Prim.hs view
@@ -55,9 +55,11 @@ ) where import Data.ASN1.Internal-import Data.ASN1.Raw import Data.ASN1.Stream import Data.ASN1.BitArray+import Data.ASN1.Types+import Data.ASN1.Serialize+import Data.Serialize.Put (runPut) import Data.Bits import Data.Word import Data.List (unfoldr)@@ -69,6 +71,8 @@ import qualified Data.Text.Lazy as T import Data.Text.Lazy.Encoding (decodeASCII, decodeUtf8, decodeUtf32BE, encodeUtf8, encodeUtf32BE) +import Control.Applicative+ encodeUCS2BE :: Text -> L.ByteString encodeUCS2BE t = L.pack $ concatMap (\c -> let (d,m) = (fromEnum c) `divMod` 256 in [fromIntegral d,fromIntegral m] ) $ T.unpack t@@ -152,7 +156,7 @@ 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])+ (B.length (runPut $ putHeader hdr) + blen, [Header hdr, Primitive b]) where makeLength len | len < 0x80 = LenShort len@@ -182,7 +186,7 @@ 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+ let tlen = B.length (runPut $ putHeader h) + clen in (tlen, Header h : ConstructionBegin : events ++ [ConstructionEnd]) encodeConstructed _ _ = error "not a start node"@@ -193,7 +197,7 @@ | otherwise = LenLong (nbBytes i) i where nbBytes nb = if nb > 255 then 1 + nbBytes (nb `div` 256) else 1 -type ASN1Ret = Either ASN1Err ASN1+type ASN1Ret = Either ASN1Error ASN1 decodePrimitive :: ASN1Header -> B.ByteString -> ASN1Ret decodePrimitive (ASN1Header Universal 0x1 _ _) p = getBoolean False p@@ -202,13 +206,13 @@ 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 0x7 _ _) _ = Left $ TypeNotImplemented "Object Descriptor"+decodePrimitive (ASN1Header Universal 0x8 _ _) _ = Left $ TypeNotImplemented "External"+decodePrimitive (ASN1Header Universal 0x9 _ _) _ = Left $ TypeNotImplemented "real"+decodePrimitive (ASN1Header Universal 0xa _ _) _ = Left $ TypeNotImplemented "enumerated"+decodePrimitive (ASN1Header Universal 0xb _ _) _ = Left $ TypeNotImplemented "EMBEDDED PDV" decodePrimitive (ASN1Header Universal 0xc _ _) p = getUTF8String p-decodePrimitive (ASN1Header Universal 0xd _ _) _ = Left $ ASN1NotImplemented "RELATIVE-OID"+decodePrimitive (ASN1Header Universal 0xd _ _) _ = Left $ TypeNotImplemented "RELATIVE-OID" decodePrimitive (ASN1Header Universal 0x10 _ _) _ = error "sequence not a primitive" decodePrimitive (ASN1Header Universal 0x11 _ _) _ = error "set not a primitive" decodePrimitive (ASN1Header Universal 0x12 _ _) p = getNumericString p@@ -227,89 +231,90 @@ decodePrimitive (ASN1Header tc tag _ _) p = Right $ Other tc tag p -getBoolean :: Bool -> ByteString -> Either ASN1Err ASN1+getBoolean :: Bool -> ByteString -> Either ASN1Error ASN1 getBoolean isDer s = if B.length s == 1- then- case B.head s of- 0 -> Right (Boolean False)- 0xff -> Right (Boolean True)- _ -> if isDer then Left $ ASN1PolicyFailed "DER" "boolean value not canonical" else Right (Boolean True)- else Left $ ASN1Misc "boolean: length not within bound"+ then case B.head s of+ 0 -> Right (Boolean False)+ 0xff -> Right (Boolean True)+ _ -> if isDer then Left $ PolicyFailed "DER" "boolean value not canonical" else Right (Boolean True)+ else Left $ TypeDecodingFailed "boolean: length not within bound" {- | getInteger, parse a value bytestring and get the integer out of the two complement encoded bytes -}-getInteger :: ByteString -> Either ASN1Err ASN1+getInteger :: ByteString -> Either ASN1Error ASN1 getInteger s- | B.length s == 0 = Left $ ASN1Misc "integer: null encoding"+ | B.length s == 0 = Left $ TypeDecodingFailed "integer: null encoding" | B.length s == 1 = Right $ IntVal $ snd $ intOfBytes s | otherwise = if (v1 == 0xff && testBit v2 7) || (v1 == 0x0 && (not $ testBit v2 7))- then Left $ ASN1Misc "integer: not shortest encoding"+ then Left $ TypeDecodingFailed "integer: not shortest encoding" else Right $ IntVal $ snd $ intOfBytes s where v1 = s `B.index` 0 v2 = s `B.index` 1 -getBitString :: ByteString -> Either ASN1Err ASN1+getBitString :: ByteString -> Either ASN1Error 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 if toSkip' >= 0 && toSkip' <= 7 then Right $ BitString $ toBitArray (L.fromChunks [xs]) (fromIntegral toSkip')- else Left $ ASN1Misc ("bitstring: skip number not within bound " ++ show toSkip' ++ " " ++ show s)+ else Left $ TypeDecodingFailed ("bitstring: skip number not within bound " ++ show toSkip' ++ " " ++ show s) -getString :: (ByteString -> Maybe ASN1Err) -> ByteString -> Either ASN1Err L.ByteString+getString :: (ByteString -> Maybe ASN1Error) -> ByteString -> Either ASN1Error L.ByteString getString check s = case check s of Nothing -> Right $ L.fromChunks [s] Just err -> Left err -getOctetString :: ByteString -> Either ASN1Err ASN1-getOctetString = either Left (Right . OctetString) . getString (\_ -> Nothing)+getOctetString :: ByteString -> Either ASN1Error ASN1+getOctetString = (OctetString <$>) . getString (\_ -> Nothing) -getNumericString :: ByteString -> Either ASN1Err ASN1-getNumericString = either Left (Right . NumericString) . getString (\_ -> Nothing)+getNumericString :: ByteString -> Either ASN1Error ASN1+getNumericString = (NumericString <$>) . getString (\_ -> Nothing) -getPrintableString :: ByteString -> Either ASN1Err ASN1-getPrintableString = either Left (Right . PrintableString . T.unpack . decodeASCII) . getString (\_ -> Nothing)+getPrintableString :: ByteString -> Either ASN1Error ASN1+getPrintableString = (PrintableString . T.unpack . decodeASCII <$>) . getString (\_ -> Nothing) -getUTF8String :: ByteString -> Either ASN1Err ASN1-getUTF8String = either Left (Right . UTF8String . T.unpack . decodeUtf8) . getString (\_ -> Nothing)+getUTF8String :: ByteString -> Either ASN1Error ASN1+getUTF8String = (UTF8String . T.unpack . decodeUtf8 <$>) . getString (\_ -> Nothing) -getT61String :: ByteString -> Either ASN1Err ASN1-getT61String = either Left (Right . T61String . T.unpack . decodeASCII) . getString (\_ -> Nothing)+getT61String :: ByteString -> Either ASN1Error ASN1+getT61String = (T61String . T.unpack . decodeASCII <$>) . getString (\_ -> Nothing) -getVideoTexString :: ByteString -> Either ASN1Err ASN1-getVideoTexString = either Left (Right . VideoTexString) . getString (\_ -> Nothing)+getVideoTexString :: ByteString -> Either ASN1Error ASN1+getVideoTexString = (VideoTexString <$>) . getString (\_ -> Nothing) -getIA5String :: ByteString -> Either ASN1Err ASN1-getIA5String = either Left (Right . IA5String . T.unpack . decodeASCII) . getString (\_ -> Nothing)+getIA5String :: ByteString -> Either ASN1Error ASN1+getIA5String = (IA5String . T.unpack . decodeASCII <$>) . getString (\_ -> Nothing) -getGraphicString :: ByteString -> Either ASN1Err ASN1-getGraphicString = either Left (Right . GraphicString) . getString (\_ -> Nothing)+getGraphicString :: ByteString -> Either ASN1Error ASN1+getGraphicString = (GraphicString <$>) . getString (\_ -> Nothing) -getVisibleString :: ByteString -> Either ASN1Err ASN1-getVisibleString = either Left (Right . VisibleString) . getString (\_ -> Nothing)+getVisibleString :: ByteString -> Either ASN1Error ASN1+getVisibleString = (VisibleString <$>) . getString (\_ -> Nothing) -getGeneralString :: ByteString -> Either ASN1Err ASN1-getGeneralString = either Left (Right . GeneralString) . getString (\_ -> Nothing)+getGeneralString :: ByteString -> Either ASN1Error ASN1+getGeneralString = (GeneralString <$>) . getString (\_ -> Nothing) -getUniversalString :: ByteString -> Either ASN1Err ASN1-getUniversalString = either Left (Right . UniversalString . T.unpack . decodeUtf32BE) . getString (\_ -> Nothing)+getUniversalString :: ByteString -> Either ASN1Error ASN1+getUniversalString = (UniversalString . T.unpack . decodeUtf32BE <$>) . getString (\_ -> Nothing) -getCharacterString :: ByteString -> Either ASN1Err ASN1-getCharacterString = either Left (Right . CharacterString) . getString (\_ -> Nothing)+getCharacterString :: ByteString -> Either ASN1Error ASN1+getCharacterString = (CharacterString <$>) . getString (\_ -> Nothing) -getBMPString :: ByteString -> Either ASN1Err ASN1-getBMPString = either Left (Right . BMPString . T.unpack . decodeUCS2BE) . getString (\_ -> Nothing)+getBMPString :: ByteString -> Either ASN1Error ASN1+getBMPString = (BMPString . T.unpack . decodeUCS2BE <$>) . 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"+getNull :: ByteString -> Either ASN1Error ASN1+getNull s+ | B.length s == 0 = Right Null+ | otherwise = Left $ TypeDecodingFailed "Null: data length not within bound" {- | return an OID -}-getOID :: ByteString -> Either ASN1Err ASN1+getOID :: ByteString -> Either ASN1Error ASN1 getOID s = Right $ OID $ (fromIntegral (x `div` 40) : fromIntegral (x `mod` 40) : groupOID xs) where (x:xs) = B.unpack s@@ -327,7 +332,7 @@ spanSubOIDbound (a:as) = if testBit a 7 then (clearBit a 7 : ys, zs) else ([a], as) where (ys, zs) = spanSubOIDbound as -getUTCTime :: ByteString -> Either ASN1Err ASN1+getUTCTime :: ByteString -> Either ASN1Error ASN1 getUTCTime s = case B.unpack s of [y1, y2, m1, m2, d1, d2, h1, h2, mi1, mi2, s1, s2, z] ->@@ -339,11 +344,11 @@ let minute = integerise mi1 mi2 in let second = integerise s1 s2 in Right $ UTCTime (year, month, day, hour, minute, second, z == 90)- _ -> Left $ ASN1Misc "utctime unexpected format"+ _ -> Left $ TypeDecodingFailed "utctime unexpected format" where integerise a b = ((fromIntegral a) - (ord '0')) * 10 + ((fromIntegral b) - (ord '0')) -getGeneralizedTime :: ByteString -> Either ASN1Err ASN1+getGeneralizedTime :: ByteString -> Either ASN1Error ASN1 getGeneralizedTime s = case B.unpack s of [y1, y2, y3, y4, m1, m2, d1, d2, h1, h2, mi1, mi2, s1, s2, z] ->@@ -354,7 +359,7 @@ let minute = integerise mi1 mi2 in let second = integerise s1 s2 in Right $ GeneralizedTime (year, month, day, hour, minute, second, z == 90)- _ -> Left $ ASN1Misc "utctime unexpected format"+ _ -> Left $ TypeDecodingFailed "utctime unexpected format" where integerise a b = ((fromIntegral a) - (ord '0')) * 10 + ((fromIntegral b) - (ord '0'))
− Data/ASN1/Raw.hs
@@ -1,266 +0,0 @@-{-# LANGUAGE BangPatterns, DeriveDataTypeable #-}--- |--- Module : Data.ASN1.Raw--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unknown------ A module containing raw ASN1 serialization/derialization tools-----module Data.ASN1.Raw- (- -- * ASN1 definitions- ASN1Class(..)- , ASN1Tag- , ASN1Length(..)- , ASN1Header(..)- , ASN1Err(..)- -- * Enumerator events- , ASN1Event(..)- , iterateFile- , iterateByteString- , enumReadBytes- , enumWriteBytes- , toBytes- -- * serialize asn1 headers- , getHeader- , putHeader- ) where--import Data.Enumerator hiding (head, length, map)-import qualified Data.Enumerator as E-import qualified Data.Enumerator.List as EL-import Data.Enumerator.Binary (enumFile)-import Data.Attoparsec.Enumerator-import Data.Attoparsec-import qualified Data.Attoparsec as A-import Data.ByteString (ByteString)-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.Monad.Identity-import Control.Applicative ((<|>), (<$>))--data ASN1Class =- Universal- | Application- | Context- | Private- deriving (Show,Eq,Ord,Enum)--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)--data ASN1Header = ASN1Header !ASN1Class !ASN1Tag !Bool !ASN1Length- 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- | ASN1ParsingPartial- | ASN1ParsingFail String- deriving (Typeable, Show, Eq)--instance Exception ASN1Err--{-| 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))--{-| 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))--{- parse state machine -}-data ParseState =- PSPrimitive Int- | PSConstructing Int- | PSConstructingEOC--{-| 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]- )-- go (n:cs) (PSPrimitive i:pss) k =- iterPrim i >>= (\e -> k (Chunks [e]) >>== loop (n+i:cs) pss)-- 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)- )-- 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-- eofCheck k _ Nothing = k (Chunks []) >>== return- eofCheck _ f (Just x) = f $! x-- iterDesc :: Monad m => Iteratee ByteString m (Maybe (Int, ASN1Event, ParseState))- iterDesc = iterParser ((endOfInput >> return Nothing) <|> fmap Just parseHeaderEvent)-- 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 (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.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 -}-putLength :: ASN1Length -> [Word8]-putLength (LenShort i)- | i < 0 || i > 0x7f = error "putLength: short length is not between 0x0 and 0x80"- | otherwise = [fromIntegral i]-putLength (LenLong _ i)- | i < 0 = error "putLength: long length is negative"- | otherwise = lenbytes : lw- where- lw = bytesOfUInt $ fromIntegral i- lenbytes = fromIntegral (length lw .|. 0x80)-putLength (LenIndefinite) = [0x80]--{-| 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 = EL.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--toBytes :: [ASN1Event] -> L.ByteString-toBytes evs = case runIdentity (run (enumList 8 evs $$ joinI (enumWriteBytes $$ EL.consume))) of- Left err -> error $ show err- Right l -> L.fromChunks l
+ Data/ASN1/Serialize.hs view
@@ -0,0 +1,94 @@+-- |+-- Module : Data.ASN1.Serialize+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+module Data.ASN1.Serialize (getHeader, putHeader) where++import qualified Data.ByteString as B+import Data.Serialize.Put+import Data.ASN1.Get+import Data.ASN1.Internal+import Data.ASN1.Types+import Data.Bits+import Data.Word+import Control.Applicative ((<$>))+import Control.Monad++-- | parse an ASN1 header+getHeader :: Get ASN1Header+getHeader = do+ (cl,pc,t1) <- parseFirstWord <$> getWord8+ tag <- if t1 == 0x1f then getTagLong else return t1+ len <- getLength+ return $ ASN1Header cl tag pc len++-- | 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 :: Get ASN1Tag+getTagLong = do+ t <- fromIntegral <$> getWord8+ when (t == 0x80) $ error "not canonical encoding of tag"+ if testBit t 7+ then loop (clearBit t 7)+ else return t+ where loop n = do+ t <- fromIntegral <$> getWord8+ if testBit t 7+ then loop (n `shiftL` 7 + clearBit t 7)+ else return (n `shiftL` 7 + t)+++{- 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 :: Get ASN1Length+getLength = do+ l1 <- fromIntegral <$> getWord8+ if testBit l1 7+ then case clearBit l1 7 of+ 0 -> return LenIndefinite+ len -> do+ lw <- getBytes len+ return (LenLong len $ uintbs lw)+ else+ return (LenShort l1)+ where+ {- uintbs return the unsigned int represented by the bytes -}+ uintbs = B.foldl (\acc n -> (acc `shiftL` 8) + fromIntegral n) 0++-- | putIdentifier encode an ASN1 Identifier into a marshalled value+putHeader :: ASN1Header -> Put+putHeader (ASN1Header cl tag pc len) = do+ putWord8 word1+ unless (tag < 0x1f) $ putByteString $ putVarEncodingIntegral tag+ putByteString $ B.pack $ putLength len+ 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++{- | putLength encode a length into a ASN1 length.+ - see getLength for the encoding rules -}+putLength :: ASN1Length -> [Word8]+putLength (LenShort i)+ | i < 0 || i > 0x7f = error "putLength: short length is not between 0x0 and 0x80"+ | otherwise = [fromIntegral i]+putLength (LenLong _ i)+ | i < 0 = error "putLength: long length is negative"+ | otherwise = lenbytes : lw+ where+ lw = bytesOfUInt $ fromIntegral i+ lenbytes = fromIntegral (length lw .|. 0x80)+putLength (LenIndefinite) = [0x80]
Data/ASN1/Stream.hs view
@@ -1,49 +1,58 @@+-- |+-- Module : Data.ASN1.Stream+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+-- module Data.ASN1.Stream- ( ASN1(..)- , ASN1Repr- , ASN1ConstructionType(..)- , getConstructedEnd- , getConstructedEndRepr- ) where+ ( ASN1(..)+ , ASN1Class(..)+ , ASN1Tag+ , ASN1Repr+ , ASN1ConstructionType(..)+ , getConstructedEnd+ , getConstructedEndRepr+ ) where -import Data.ASN1.Raw import Data.ASN1.BitArray+import Data.ASN1.Types import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L -data ASN1ConstructionType =- Sequence- | Set- | Container ASN1Class ASN1Tag- deriving (Show,Eq)+-- | Define the type of container+data ASN1ConstructionType = Sequence+ | Set+ | Container ASN1Class ASN1Tag+ deriving (Show,Eq) -data ASN1 =- Boolean Bool- | IntVal Integer- | BitString BitArray- | OctetString L.ByteString- | Null- | OID [Integer]- | Real Double- | Enumerated- | UTF8String String- | NumericString L.ByteString- | PrintableString String- | T61String String- | VideoTexString L.ByteString- | IA5String String- | 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 String- | CharacterString L.ByteString- | BMPString String- | Other ASN1Class ASN1Tag ByteString- | Start ASN1ConstructionType- | End ASN1ConstructionType- deriving (Show, Eq)+-- | Define high level ASN1 object.+data ASN1 = Boolean Bool+ | IntVal Integer+ | BitString BitArray+ | OctetString L.ByteString+ | Null+ | OID [Integer]+ | Real Double+ | Enumerated+ | UTF8String String+ | NumericString L.ByteString+ | PrintableString String+ | T61String String+ | VideoTexString L.ByteString+ | IA5String String+ | 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 String+ | CharacterString L.ByteString+ | BMPString String+ | Other ASN1Class ASN1Tag ByteString+ | Start ASN1ConstructionType+ | End ASN1ConstructionType+ deriving (Show, Eq) {- associate a list of asn1 event with an ASN1 type. - it's sometimes required to know the exact byte sequence leading to an ASN1 type:@@ -54,20 +63,19 @@ getConstructedEnd _ 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)+ | 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) getConstructedEndRepr :: [ASN1Repr] -> ([ASN1Repr],[ASN1Repr]) getConstructedEndRepr = g- where- g [] = ([], [])- g (x@(Start _,_):xs) = let (ys, zs) = getEnd 1 xs in (x:ys, zs)- g (x:xs) = ([x],xs)+ where g [] = ([], [])+ g (x@(Start _,_):xs) = let (ys, zs) = getEnd 1 xs in (x:ys, zs)+ g (x:xs) = ([x],xs) - getEnd :: Int -> [ASN1Repr] -> ([ASN1Repr],[ASN1Repr])- getEnd _ [] = ([], [])- getEnd 0 xs = ([], xs)- getEnd i ((x@(Start _, _)):xs) = let (ys, zs) = getEnd (i+1) xs in (x:ys,zs)- getEnd i ((x@(End _, _)):xs) = let (ys, zs) = getEnd (i-1) xs in (x:ys,zs)- getEnd i (x:xs) = let (ys, zs) = getEnd i xs in (x:ys,zs)+ getEnd :: Int -> [ASN1Repr] -> ([ASN1Repr],[ASN1Repr])+ getEnd _ [] = ([], [])+ getEnd 0 xs = ([], xs)+ getEnd i ((x@(Start _, _)):xs) = let (ys, zs) = getEnd (i+1) xs in (x:ys,zs)+ getEnd i ((x@(End _, _)):xs) = let (ys, zs) = getEnd (i-1) xs in (x:ys,zs)+ getEnd i (x:xs) = let (ys, zs) = getEnd i xs in (x:ys,zs)
Data/ASN1/Types.hs view
@@ -1,106 +1,66 @@+-- |+-- Module : Data.ASN1.Types+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns #-} module Data.ASN1.Types- ( ASN1t(..)- , ofStream- , toStream- ) where+ (+ -- * Raw types+ ASN1Class(..)+ , ASN1Tag+ , ASN1Length(..)+ , ASN1Header(..)+ -- * Errors types+ , ASN1Error(..)+ -- * Events types+ , ASN1Event(..)+ ) where -import Data.ASN1.BitArray-import qualified Data.ASN1.Stream as S-import qualified Data.ByteString.Lazy as L+import Control.Exception (Exception)+import Data.Typeable import Data.ByteString (ByteString)-import Data.ASN1.Raw (ASN1Class, ASN1Tag) -data ASN1t =- Boolean Bool- | IntVal Integer- | BitString BitArray- | OctetString L.ByteString- | Null- | OID [Integer]- | Real Double- | Enumerated- | UTF8String String- | NumericString L.ByteString- | PrintableString String- | T61String String- | VideoTexString L.ByteString- | IA5String String- | 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 String- | CharacterString L.ByteString- | BMPString String- | Other ASN1Class ASN1Tag ByteString- | Sequence [ASN1t]- | Set [ASN1t]- | Container ASN1Class ASN1Tag [ASN1t]- deriving (Show, Eq)+-- | Element class+data ASN1Class = Universal+ | Application+ | Context+ | Private+ deriving (Show,Eq,Ord,Enum) -ofStream :: [S.ASN1] -> [ASN1t]-ofStream [] = []-ofStream (S.End _ : l) = ofStream l+-- | ASN1 Tag+type ASN1Tag = Int -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+-- | ASN1 Length with all different formats+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) -ofStream (S.Boolean b : l) = Boolean b : ofStream l-ofStream (S.IntVal i : l) = IntVal i : ofStream l-ofStream (S.BitString bits : l) = BitString 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 +-- | ASN1 Header with the class, tag, constructed flag and length.+data ASN1Header = ASN1Header !ASN1Class !ASN1Tag !Bool !ASN1Length+ deriving (Show,Eq) -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 b) = [S.BitString 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]+-- | represent one event from an asn1 data stream+data ASN1Event = Header ASN1Header -- ^ ASN1 Header+ | Primitive !ByteString -- ^ Primitive+ | ConstructionBegin -- ^ Constructed value start+ | ConstructionEnd -- ^ Constructed value end+ deriving (Show,Eq)++-- | Possible errors during parsing operations+data ASN1Error = StreamUnexpectedEOC -- ^ Unexpected EOC in the stream.+ | StreamInfinitePrimitive -- ^ Invalid primitive with infinite length in a stream.+ | StreamConstructionWrongSize -- ^ A construction goes over the size specified in the header.+ | StreamUnexpectedSituation String -- ^ An unexpected situation has come up parsing an ASN1 event stream.+ | ParsingHeaderFail String -- ^ Parsing an invalid header.+ | ParsingPartial -- ^ Parsing is not finished, there is construction unended.+ | TypeNotImplemented String -- ^ Decoding of a type that is not implemented. Contribution welcome.+ | TypeDecodingFailed String -- ^ Decoding of a knowed type failed.+ | PolicyFailed String String -- ^ Policy failed including the name of the policy and the reason.+ deriving (Typeable, Show, Eq)++instance Exception ASN1Error
Tests.hs view
@@ -4,244 +4,182 @@ import Text.Printf -import Data.ASN1.Raw+import Data.Serialize.Put (runPut)+import Data.ASN1.Get (runGet, Result(..)) import Data.ASN1.BitArray 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.ASN1.Serialize+import Data.ASN1.BinaryEncoding.Parse+import Data.ASN1.BinaryEncoding.Writer+import Data.ASN1.BinaryEncoding+import Data.ASN1.Encoding+import Data.ASN1.Types import Data.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 qualified Data.Enumerator.List as EL-import Data.Enumerator (($$)) import Control.Monad import Control.Monad.Identity import System.IO instance Arbitrary ASN1Class where- arbitrary = elements [ Universal, Application, Context, Private ]-+ 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+ 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)+arbitraryTag = choose(1,10000) instance Arbitrary ASN1Header where- arbitrary = liftM4 ASN1Header arbitrary arbitraryTag arbitrary arbitrary+ 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])+ 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+ show (ASN1Events x) = show x instance Arbitrary ASN1Events where- arbitrary = arbitraryEvents+ arbitrary = arbitraryEvents 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)-+ i1 <- choose (0,2) :: Gen Integer+ i2 <- choose (0,39) :: Gen Integer+ ran <- choose (0,30) :: Gen Int+ l <- replicateM ran (suchThat arbitrary (\i -> i > 0))+ return (i1:i2:l) arbitraryBSsized :: Int -> Gen B.ByteString arbitraryBSsized len = do- ws <- replicateM len (choose (0, 255) :: Gen Int)- return $ B.pack $ map fromIntegral ws+ ws <- replicateM len (choose (0, 255) :: Gen Int)+ return $ B.pack $ map fromIntegral ws instance Arbitrary B.ByteString where- arbitrary = do- len <- choose (0, 529) :: Gen Int- arbitraryBSsized len+ arbitrary = do+ len <- choose (0, 529) :: Gen Int+ arbitraryBSsized len 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+ arbitrary = do+ len <- choose (0, 529) :: Gen Int+ ws <- replicateM len (choose (0, 255) :: Gen Int)+ return $ L.pack $ map fromIntegral ws instance Arbitrary T.Text where- arbitrary = do- len <- choose (0, 529) :: Gen Int- ws <- replicateM len arbitrary- return $ T.pack ws+ arbitrary = do+ len <- choose (0, 529) :: Gen Int+ ws <- replicateM len arbitrary+ return $ T.pack ws instance Arbitrary BitArray where- arbitrary = do- bs <- arbitrary- --w <- choose (0,7) :: Gen Int- return $ toBitArray bs 0+ arbitrary = do+ bs <- arbitrary+ --w <- choose (0,7) :: Gen Int+ return $ toBitArray bs 0 arbitraryTime = do- y <- choose (1951, 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)--arbitraryListASN1 = choose (0, 20) >>= \len -> replicateM len (suchThat arbitrary (not . aList))- where- aList (T.Set _) = True- aList (T.Sequence _) = True- aList _ = False+ y <- choose (1951, 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) arbitraryPrintString = do- let printableString = (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ " ()+,-./:=?")- x <- replicateM 21 (elements printableString)- return $ x+ let printableString = (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ " ()+,-./:=?")+ x <- replicateM 21 (elements printableString)+ return $ x arbitraryIA5String = do- x <- replicateM 21 (elements $ map toEnum [0..127])- return $ x+ x <- replicateM 21 (elements $ map toEnum [0..127])+ return $ x instance Arbitrary ASN1 where- arbitrary = oneof- [ liftM Boolean arbitrary- , liftM IntVal arbitrary- , liftM BitString arbitrary- , liftM OctetString arbitrary- , return Null- , liftM OID arbitraryOID- --, Real Double- -- , return Enumerated- , liftM UTF8String arbitrary- , liftM NumericString arbitrary- , liftM PrintableString arbitraryPrintString- , liftM T61String arbitraryIA5String- , liftM VideoTexString arbitrary- , liftM IA5String arbitraryIA5String- , liftM UTCTime arbitraryTime- , liftM GeneralizedTime arbitraryTime- , liftM GraphicString arbitrary- , liftM VisibleString arbitrary- , liftM GeneralString arbitrary- , liftM BMPString arbitrary- , liftM UniversalString arbitrary- ]+ arbitrary = oneof+ [ liftM Boolean arbitrary+ , liftM IntVal arbitrary+ , liftM BitString arbitrary+ , liftM OctetString arbitrary+ , return Null+ , liftM OID arbitraryOID+ --, Real Double+ -- , return Enumerated+ , liftM UTF8String arbitrary+ , liftM NumericString arbitrary+ , liftM PrintableString arbitraryPrintString+ , liftM T61String arbitraryIA5String+ , liftM VideoTexString arbitrary+ , liftM IA5String arbitraryIA5String+ , liftM UTCTime arbitraryTime+ , liftM GeneralizedTime arbitraryTime+ , liftM GraphicString arbitrary+ , liftM VisibleString arbitrary+ , liftM GeneralString arbitrary+ , liftM BMPString arbitrary+ , liftM UniversalString arbitrary+ ] newtype ASN1s = ASN1s [ASN1] instance Show ASN1s where- show (ASN1s x) = show x+ show (ASN1s x) = show x instance Arbitrary ASN1s where- arbitrary = do- x <- choose (0,5) :: Gen Int- z <- case x of- 4 -> makeList Sequence- 3 -> makeList Set- _ -> resize 2 $ listOf1 arbitrary- return $ ASN1s z- where- makeList str = do- (ASN1s l) <- arbitrary- return ([Start str] ++ l ++ [End str])--instance Arbitrary T.ASN1t where- arbitrary = oneof- [ liftM T.Boolean arbitrary- , liftM T.IntVal arbitrary- , liftM T.BitString 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 arbitraryIA5String- , 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- ]+ arbitrary = do+ x <- choose (0,5) :: Gen Int+ z <- case x of+ 4 -> makeList Sequence+ 3 -> makeList Set+ _ -> resize 2 $ listOf1 arbitrary+ return $ ASN1s z+ where+ makeList str = do+ (ASN1s l) <- arbitrary+ return ([Start str] ++ l ++ [End str]) prop_header_marshalling_id :: ASN1Header -> Bool-prop_header_marshalling_id v = (getHeader . putHeader) v == Right v+prop_header_marshalling_id v = (ofDone $ runGet getHeader $ runPut (putHeader v)) == Right v+ where ofDone (Done r _ _) = Right r+ ofDone _ = Left "not done" prop_event_marshalling_id :: ASN1Events -> Bool-prop_event_marshalling_id (ASN1Events e) =- let r = runIdentity $ E.run (E.enumList 1 e $$ E.joinI $ enumWriteReadBytes $$ EL.consume) in- case r of- Left _ -> False- Right z -> e == z- where- enumWriteReadBytes = \f -> E.joinI (enumWriteBytes $$ (enumReadBytes f))--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 $$ EL.consume) in- case r of- Left _ -> False- Right z -> [x] == z- where- enumWriteReadRaw = \f -> E.joinI (BER.enumWriteRaw $$ (BER.enumReadRaw f))--prop_asn1_event_repr_id :: ASN1s -> Bool-prop_asn1_event_repr_id (ASN1s l) =- case BER.encodeASN1Events l of- Left _ -> False- Right events -> case BER.decodeASN1EventsRepr events of- Left _ -> False- Right l2repr -> map fst l2repr == l && concat (map snd l2repr) == events--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+prop_event_marshalling_id (ASN1Events e) = (parseLBS $ toLazyByteString e) == Right e +prop_asn1_der_marshalling_id v = (decodeASN1 DER . encodeASN1 DER) v == Right v 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- ]+ [ testProperty "Header" prop_header_marshalling_id+ , testProperty "Event" prop_event_marshalling_id+ , testProperty "DER" prop_asn1_der_marshalling_id+ ] main = defaultMain [marshallingTests]
asn1-data.cabal view
@@ -1,20 +1,18 @@ Name: asn1-data-Version: 0.6.1.3+Version: 0.7.2 Description:- 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.+ ASN1 data reader and writer in raw form with supports for high level forms of ASN1 (BER, and DER). License: BSD3 License-file: LICENSE Copyright: Vincent Hanquez <vincent@snarc.org> Author: Vincent Hanquez <vincent@snarc.org> Maintainer: Vincent Hanquez <vincent@snarc.org>-Synopsis: ASN1 data reader and writer in RAW, BER, DER and CER forms+Synopsis: ASN1 data reader and writer in RAW, BER and DER forms Build-Type: Simple Category: Data stability: experimental Cabal-Version: >=1.6-Homepage: http://github.com/vincenthz/hs-asn1-data+Homepage: https://github.com/vincenthz/hs-asn1/tree/master/data data-files: README, TODO @@ -26,19 +24,23 @@ Build-Depends: base >= 3 && < 5 , bytestring , text >= 0.11- , enumerator >= 0.4.5 && < 0.5- , attoparsec >= 0.8 && < 0.11- , attoparsec-enumerator >= 0.2 && < 0.4 , mtl- Exposed-modules: Data.ASN1.BER- Data.ASN1.CER- Data.ASN1.DER- Data.ASN1.Raw- Data.ASN1.BitArray+ , cereal++ Exposed-modules: Data.ASN1.BitArray Data.ASN1.Types+ Data.ASN1.BinaryEncoding+ Data.ASN1.BinaryEncoding.Raw+ Data.ASN1.Encoding Data.ASN1.Stream+ Data.ASN1.Parse+ Data.ASN1.Object other-modules: Data.ASN1.Prim+ Data.ASN1.BinaryEncoding.Parse+ Data.ASN1.BinaryEncoding.Writer Data.ASN1.Internal+ Data.ASN1.Serialize+ Data.ASN1.Get ghc-options: -Wall Executable Tests@@ -56,4 +58,5 @@ source-repository head type: git- location: git://github.com/vincenthz/hs-asn1-data+ location: https://github.com/vincenthz/hs-asn1-data+ subdir: data