diff --git a/Data/ASN1/BER.hs b/Data/ASN1/BER.hs deleted file mode 100644 --- a/Data/ASN1/BER.hs +++ /dev/null @@ -1,245 +0,0 @@ --- | --- Module : Data.ASN1.BER --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Data/ASN1/BinaryEncoding.hs b/Data/ASN1/BinaryEncoding.hs new file mode 100644 --- /dev/null +++ b/Data/ASN1/BinaryEncoding.hs @@ -0,0 +1,97 @@ +-- | +-- Module : Data.ASN1.BinaryEncoding +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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) diff --git a/Data/ASN1/BinaryEncoding/Parse.hs b/Data/ASN1/BinaryEncoding/Parse.hs new file mode 100644 --- /dev/null +++ b/Data/ASN1/BinaryEncoding/Parse.hs @@ -0,0 +1,156 @@ +-- | +-- Module : Data.ASN1.BinaryEncoding.Parse +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Data/ASN1/BinaryEncoding/Raw.hs b/Data/ASN1/BinaryEncoding/Raw.hs new file mode 100644 --- /dev/null +++ b/Data/ASN1/BinaryEncoding/Raw.hs @@ -0,0 +1,31 @@ +-- | +-- Module : Data.ASN1.BinaryEncoding.Raw +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Data/ASN1/BinaryEncoding/Writer.hs b/Data/ASN1/BinaryEncoding/Writer.hs new file mode 100644 --- /dev/null +++ b/Data/ASN1/BinaryEncoding/Writer.hs @@ -0,0 +1,40 @@ +-- | +-- Module : Data.ASN1.BinaryEncoding.Writer +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Data/ASN1/BitArray.hs b/Data/ASN1/BitArray.hs --- a/Data/ASN1/BitArray.hs +++ b/Data/ASN1/BitArray.hs @@ -1,3 +1,10 @@ +-- | +-- Module : Data.ASN1.BitArray +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unknown +-- {-# LANGUAGE DeriveDataTypeable #-} module Data.ASN1.BitArray ( BitArray(..) diff --git a/Data/ASN1/CER.hs b/Data/ASN1/CER.hs deleted file mode 100644 --- a/Data/ASN1/CER.hs +++ /dev/null @@ -1,64 +0,0 @@ --- | --- Module : Data.ASN1.CER --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Data/ASN1/DER.hs b/Data/ASN1/DER.hs deleted file mode 100644 --- a/Data/ASN1/DER.hs +++ /dev/null @@ -1,187 +0,0 @@ --- | --- Module : Data.ASN1.DER --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Data/ASN1/Encoding.hs b/Data/ASN1/Encoding.hs new file mode 100644 --- /dev/null +++ b/Data/ASN1/Encoding.hs @@ -0,0 +1,50 @@ +-- | +-- Module : Data.ASN1.Encoding +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Data/ASN1/Get.hs b/Data/ASN1/Get.hs new file mode 100644 --- /dev/null +++ b/Data/ASN1/Get.hs @@ -0,0 +1,197 @@ +-- | +-- Module : Data.ASN1.Get +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Data/ASN1/Internal.hs b/Data/ASN1/Internal.hs --- a/Data/ASN1/Internal.hs +++ b/Data/ASN1/Internal.hs @@ -1,10 +1,17 @@ +-- | +-- Module : Data.ASN1.Internal +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Data/ASN1/Object.hs b/Data/ASN1/Object.hs new file mode 100644 --- /dev/null +++ b/Data/ASN1/Object.hs @@ -0,0 +1,20 @@ +-- | +-- Module : Data.ASN1.Object +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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]) diff --git a/Data/ASN1/Parse.hs b/Data/ASN1/Parse.hs new file mode 100644 --- /dev/null +++ b/Data/ASN1/Parse.hs @@ -0,0 +1,84 @@ +-- | +-- Module : Data.ASN1.Parse +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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) diff --git a/Data/ASN1/Prim.hs b/Data/ASN1/Prim.hs --- a/Data/ASN1/Prim.hs +++ b/Data/ASN1/Prim.hs @@ -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')) diff --git a/Data/ASN1/Raw.hs b/Data/ASN1/Raw.hs deleted file mode 100644 --- a/Data/ASN1/Raw.hs +++ /dev/null @@ -1,266 +0,0 @@ -{-# LANGUAGE BangPatterns, DeriveDataTypeable #-} --- | --- Module : Data.ASN1.Raw --- License : BSD-style --- Maintainer : Vincent Hanquez --- 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 diff --git a/Data/ASN1/Serialize.hs b/Data/ASN1/Serialize.hs new file mode 100644 --- /dev/null +++ b/Data/ASN1/Serialize.hs @@ -0,0 +1,94 @@ +-- | +-- Module : Data.ASN1.Serialize +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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] diff --git a/Data/ASN1/Stream.hs b/Data/ASN1/Stream.hs --- a/Data/ASN1/Stream.hs +++ b/Data/ASN1/Stream.hs @@ -1,49 +1,58 @@ +-- | +-- Module : Data.ASN1.Stream +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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) diff --git a/Data/ASN1/Types.hs b/Data/ASN1/Types.hs --- a/Data/ASN1/Types.hs +++ b/Data/ASN1/Types.hs @@ -1,106 +1,66 @@ +-- | +-- Module : Data.ASN1.Types +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -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] diff --git a/asn1-data.cabal b/asn1-data.cabal --- a/asn1-data.cabal +++ b/asn1-data.cabal @@ -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 Author: Vincent Hanquez Maintainer: Vincent Hanquez -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