asn1-encoding-0.9.4/0000755000000000000000000000000012727175623012354 5ustar0000000000000000asn1-encoding-0.9.4/asn1-encoding.cabal0000644000000000000000000000374012727175623015772 0ustar0000000000000000Name: asn1-encoding Version: 0.9.4 Synopsis: ASN1 data reader and writer in RAW, BER and DER forms Description: 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@snarc.org Category: Data stability: experimental Build-Type: Simple Cabal-Version: >=1.10 Homepage: http://github.com/vincenthz/hs-asn1 Library Exposed-modules: Data.ASN1.Error Data.ASN1.BinaryEncoding Data.ASN1.BinaryEncoding.Raw Data.ASN1.Encoding Data.ASN1.Stream 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 Build-Depends: base >= 3 && < 5 , bytestring , hourglass >= 0.2.6 , asn1-types >= 0.3.0 && < 0.4 ghc-options: -Wall -fwarn-tabs Default-Language: Haskell2010 Test-Suite tests-asn1-encoding type: exitcode-stdio-1.0 hs-source-dirs: tests . Main-Is: Tests.hs Build-depends: base >= 3 && < 7 , bytestring , text , mtl , tasty , tasty-quickcheck , asn1-types , asn1-encoding , hourglass ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures Default-Language: Haskell2010 source-repository head type: git location: git://github.com/vincenthz/hs-asn1 subdir: asn1-encoding asn1-encoding-0.9.4/LICENSE0000644000000000000000000000273112727175623013364 0ustar0000000000000000Copyright (c) 2010-2013 Vincent Hanquez All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. asn1-encoding-0.9.4/Setup.hs0000644000000000000000000000005612727175623014011 0ustar0000000000000000import Distribution.Simple main = defaultMain asn1-encoding-0.9.4/Data/0000755000000000000000000000000012727175623013225 5ustar0000000000000000asn1-encoding-0.9.4/Data/ASN1/0000755000000000000000000000000012727175623013727 5ustar0000000000000000asn1-encoding-0.9.4/Data/ASN1/BinaryEncoding.hs0000644000000000000000000001002712727175623017156 0ustar0000000000000000-- | -- 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.Types.Lowlevel import Data.ASN1.Error 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) asn1-encoding-0.9.4/Data/ASN1/Encoding.hs0000644000000000000000000000340312727175623016011 0ustar0000000000000000-- | -- 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 import Data.ASN1.Error -- | 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 asn1-encoding-0.9.4/Data/ASN1/Error.hs0000644000000000000000000000260612727175623015360 0ustar0000000000000000-- | -- Module : Data.ASN1.Error -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE BangPatterns #-} module Data.ASN1.Error ( -- * Errors types ASN1Error(..) ) where import Control.Exception (Exception) import Data.Typeable -- | 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 asn1-encoding-0.9.4/Data/ASN1/Get.hs0000644000000000000000000001432412727175623015006 0ustar0000000000000000-- | -- 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 -- | 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 | n <= 0 = return B.empty | otherwise = do s <- ensure n let (b1, b2) = B.splitAt n s put (fromIntegral n) b2 return b1 getWord8 :: Get Word8 getWord8 = do s <- ensure 1 case B.uncons s of Nothing -> error "getWord8: ensure internal error" Just (h,b2) -> put 1 b2 >> return h asn1-encoding-0.9.4/Data/ASN1/Internal.hs0000644000000000000000000000521012727175623016035 0ustar0000000000000000-- | -- Module : Data.ASN1.Internal -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Data.ASN1.Internal ( uintOfBytes , intOfBytes , bytesOfUInt , bytesOfInt , putVarEncodingIntegral ) where import Data.Word import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as B {- | uintOfBytes returns the number of bytes and the unsigned integer represented by the bytes -} uintOfBytes :: ByteString -> (Int, Integer) uintOfBytes b = (B.length b, B.foldl (\acc n -> (acc `shiftL` 8) + fromIntegral n) 0 b) --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) {- | 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 {- | 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 {- ASN1 often uses a particular kind of 7-bit encoding of integers like in the case of long tags or encoding of integer component of OID's. Use this function for such an encoding. Assumes a positive integer. Here is the description of the algorithm of the above encoding: 1. The integer is chunked up into 7-bit groups. Each of these 7bit chunks are encoded as a single octet. 2. All the octets except the last one has its 8th bit set. -} putVarEncodingIntegral :: (Bits i, Integral i) => i -> ByteString putVarEncodingIntegral i = B.reverse $ B.unfoldr genOctets (i,True) where genOctets (x,first) | x > 0 = let out = fromIntegral (x .&. 0x7F) .|. (if first then 0 else 0x80) in Just (out, (shiftR x 7, False)) | otherwise = Nothing asn1-encoding-0.9.4/Data/ASN1/Object.hs0000644000000000000000000000046312727175623015474 0ustar0000000000000000-- | -- Module : Data.ASN1.Object -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Data.ASN1.Object {-# DEPRECATED "Use Data.ASN1.Types instead" #-} ( ASN1Object(..) ) where import Data.ASN1.Types asn1-encoding-0.9.4/Data/ASN1/Prim.hs0000644000000000000000000003665112727175623015205 0ustar0000000000000000-- | -- Module : Data.ASN1.Prim -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- -- Tools to read ASN1 primitive (e.g. boolean, int) -- {-# LANGUAGE ViewPatterns #-} module Data.ASN1.Prim ( -- * ASN1 high level algebraic type ASN1(..) , ASN1ConstructionType(..) , encodeHeader , encodePrimitiveHeader , encodePrimitive , decodePrimitive , encodeConstructed , encodeList , encodeOne , mkSmallestLength -- * marshall an ASN1 type from a val struct or a bytestring , getBoolean , getInteger , getBitString , getOctetString , getNull , getOID , getTime -- * marshall an ASN1 type to a bytestring , putTime , putInteger , putBitString , putString , putOID ) where import Data.ASN1.Internal import Data.ASN1.Stream import Data.ASN1.BitArray import Data.ASN1.Types import Data.ASN1.Types.Lowlevel import Data.ASN1.Error import Data.ASN1.Serialize import Data.Bits import Data.Word import Data.List (unfoldr) import Data.ByteString (ByteString) import Data.Char (ord, isDigit) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Data.Hourglass import Control.Applicative import Control.Arrow (first) encodeHeader :: Bool -> ASN1Length -> ASN1 -> ASN1Header encodeHeader pc len (Boolean _) = ASN1Header Universal 0x1 pc len encodeHeader pc len (IntVal _) = ASN1Header Universal 0x2 pc len encodeHeader pc len (BitString _) = ASN1Header Universal 0x3 pc len encodeHeader pc len (OctetString _) = ASN1Header Universal 0x4 pc len encodeHeader pc len Null = ASN1Header Universal 0x5 pc len encodeHeader pc len (OID _) = ASN1Header Universal 0x6 pc len encodeHeader pc len (Real _) = ASN1Header Universal 0x9 pc len encodeHeader pc len (Enumerated _) = ASN1Header Universal 0xa pc len encodeHeader pc len (ASN1String cs) = ASN1Header Universal (characterStringType $ characterEncoding cs) pc len where characterStringType UTF8 = 0xc characterStringType Numeric = 0x12 characterStringType Printable = 0x13 characterStringType T61 = 0x14 characterStringType VideoTex = 0x15 characterStringType IA5 = 0x16 characterStringType Graphic = 0x19 characterStringType Visible = 0x1a characterStringType General = 0x1b characterStringType UTF32 = 0x1c characterStringType Character = 0x1d characterStringType BMP = 0x1e encodeHeader pc len (ASN1Time TimeUTC _ _) = ASN1Header Universal 0x17 pc len encodeHeader pc len (ASN1Time TimeGeneralized _ _) = ASN1Header Universal 0x18 pc len encodeHeader pc len (Start Sequence) = ASN1Header Universal 0x10 pc len encodeHeader pc len (Start Set) = ASN1Header Universal 0x11 pc len encodeHeader pc len (Start (Container tc tag)) = ASN1Header tc tag pc len encodeHeader pc len (Other tc tag _) = ASN1Header tc tag pc len encodeHeader _ _ (End _) = error "this should not happen" encodePrimitiveHeader :: ASN1Length -> ASN1 -> ASN1Header encodePrimitiveHeader = encodeHeader False encodePrimitiveData :: ASN1 -> ByteString encodePrimitiveData (Boolean b) = B.singleton (if b then 0xff else 0) encodePrimitiveData (IntVal i) = putInteger i encodePrimitiveData (BitString bits) = putBitString bits encodePrimitiveData (OctetString b) = putString b encodePrimitiveData Null = B.empty encodePrimitiveData (OID oidv) = putOID oidv encodePrimitiveData (Real _) = B.empty -- not implemented encodePrimitiveData (Enumerated i) = putInteger $ fromIntegral i encodePrimitiveData (ASN1String cs) = getCharacterStringRawData cs encodePrimitiveData (ASN1Time ty ti tz) = putTime ty ti tz encodePrimitiveData (Other _ _ b) = b encodePrimitiveData o = error ("not a primitive " ++ show o) encodePrimitive :: ASN1 -> (Int, [ASN1Event]) encodePrimitive a = let b = encodePrimitiveData a blen = B.length b len = makeLength blen hdr = encodePrimitiveHeader len a in (B.length (putHeader hdr) + blen, [Header hdr, Primitive b]) where makeLength len | len < 0x80 = LenShort len | otherwise = LenLong (nbBytes len) len nbBytes nb = if nb > 255 then 1 + nbBytes (nb `div` 256) else 1 encodeOne :: ASN1 -> (Int, [ASN1Event]) encodeOne (Start _) = error "encode one cannot do start" encodeOne t = encodePrimitive t encodeList :: [ASN1] -> (Int, [ASN1Event]) encodeList [] = (0, []) encodeList (End _:xs) = encodeList xs encodeList (t@(Start _):xs) = let (ys, zs) = getConstructedEnd 0 xs (llen, lev) = encodeList zs (len, ev) = encodeConstructed t ys in (llen + len, ev ++ lev) encodeList (x:xs) = let (llen, lev) = encodeList xs (len, ev) = encodeOne x in (llen + len, ev ++ lev) encodeConstructed :: ASN1 -> [ASN1] -> (Int, [ASN1Event]) encodeConstructed c@(Start _) children = (tlen, Header h : ConstructionBegin : events ++ [ConstructionEnd]) where (clen, events) = encodeList children len = mkSmallestLength clen h = encodeHeader True len c tlen = B.length (putHeader h) + clen encodeConstructed _ _ = error "not a start node" mkSmallestLength :: Int -> ASN1Length mkSmallestLength i | i < 0x80 = LenShort i | otherwise = LenLong (nbBytes i) i where nbBytes nb = if nb > 255 then 1 + nbBytes (nb `div` 256) else 1 type ASN1Ret = Either ASN1Error ASN1 decodePrimitive :: ASN1Header -> B.ByteString -> ASN1Ret decodePrimitive (ASN1Header Universal 0x1 _ _) p = getBoolean False p decodePrimitive (ASN1Header Universal 0x2 _ _) p = getInteger p decodePrimitive (ASN1Header Universal 0x3 _ _) p = getBitString p decodePrimitive (ASN1Header Universal 0x4 _ _) p = getOctetString p decodePrimitive (ASN1Header Universal 0x5 _ _) p = getNull p decodePrimitive (ASN1Header Universal 0x6 _ _) p = getOID p decodePrimitive (ASN1Header Universal 0x7 _ _) _ = Left $ TypeNotImplemented "Object Descriptor" decodePrimitive (ASN1Header Universal 0x8 _ _) _ = Left $ TypeNotImplemented "External" decodePrimitive (ASN1Header Universal 0x9 _ _) _ = Left $ TypeNotImplemented "real" decodePrimitive (ASN1Header Universal 0xa _ _) p = getEnumerated p decodePrimitive (ASN1Header Universal 0xb _ _) _ = Left $ TypeNotImplemented "EMBEDDED PDV" decodePrimitive (ASN1Header Universal 0xc _ _) p = getCharacterString UTF8 p 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 = getCharacterString Numeric p decodePrimitive (ASN1Header Universal 0x13 _ _) p = getCharacterString Printable p decodePrimitive (ASN1Header Universal 0x14 _ _) p = getCharacterString T61 p decodePrimitive (ASN1Header Universal 0x15 _ _) p = getCharacterString VideoTex p decodePrimitive (ASN1Header Universal 0x16 _ _) p = getCharacterString IA5 p decodePrimitive (ASN1Header Universal 0x17 _ _) p = getTime TimeUTC p decodePrimitive (ASN1Header Universal 0x18 _ _) p = getTime TimeGeneralized p decodePrimitive (ASN1Header Universal 0x19 _ _) p = getCharacterString Graphic p decodePrimitive (ASN1Header Universal 0x1a _ _) p = getCharacterString Visible p decodePrimitive (ASN1Header Universal 0x1b _ _) p = getCharacterString General p decodePrimitive (ASN1Header Universal 0x1c _ _) p = getCharacterString UTF32 p decodePrimitive (ASN1Header Universal 0x1d _ _) p = getCharacterString Character p decodePrimitive (ASN1Header Universal 0x1e _ _) p = getCharacterString BMP p decodePrimitive (ASN1Header tc tag _ _) p = Right $ Other tc tag p 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 $ 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 ASN1Error ASN1 {-# INLINE getInteger #-} getInteger s = IntVal <$> getIntegerRaw "integer" s {- | getEnumerated, parse an enumerated value the same way that integer values are parsed. -} getEnumerated :: ByteString -> Either ASN1Error ASN1 {-# INLINE getEnumerated #-} getEnumerated s = Enumerated <$> getIntegerRaw "enumerated" s {- | According to X.690 section 8.4 integer and enumerated values should be encoded the same way. -} getIntegerRaw :: String -> ByteString -> Either ASN1Error Integer getIntegerRaw typestr s | B.length s == 0 = Left . TypeDecodingFailed $ typestr ++ ": null encoding" | B.length s == 1 = Right $ snd $ intOfBytes s | otherwise = if (v1 == 0xff && testBit v2 7) || (v1 == 0x0 && (not $ testBit v2 7)) then Left . TypeDecodingFailed $ typestr ++ ": not shortest encoding" else Right $ snd $ intOfBytes s where v1 = s `B.index` 0 v2 = s `B.index` 1 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 xs (fromIntegral toSkip') else Left $ TypeDecodingFailed ("bitstring: skip number not within bound " ++ show toSkip' ++ " " ++ show s) getCharacterString :: ASN1StringEncoding -> ByteString -> Either ASN1Error ASN1 getCharacterString encoding bs = Right $ ASN1String (ASN1CharacterString encoding bs) getOctetString :: ByteString -> Either ASN1Error ASN1 getOctetString = Right . OctetString 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 ASN1Error ASN1 getOID s = Right $ OID $ (fromIntegral (x `div` 40) : fromIntegral (x `mod` 40) : groupOID xs) where (x:xs) = B.unpack s groupOID :: [Word8] -> [Integer] groupOID = map (foldl (\acc n -> (acc `shiftL` 7) + fromIntegral n) 0) . groupSubOID groupSubOIDHelper [] = Nothing groupSubOIDHelper l = Just $ spanSubOIDbound l groupSubOID :: [Word8] -> [[Word8]] groupSubOID = unfoldr groupSubOIDHelper spanSubOIDbound [] = ([], []) spanSubOIDbound (a:as) = if testBit a 7 then (clearBit a 7 : ys, zs) else ([a], as) where (ys, zs) = spanSubOIDbound as getTime :: ASN1TimeType -> ByteString -> Either ASN1Error ASN1 getTime timeType bs | hasNonASCII bs = decodingError "contains non ASCII characters" | otherwise = case timeParseE format (BC.unpack bs) of -- BC.unpack is safe as we check ASCIIness first Left _ -> case timeParseE formatNoSeconds (BC.unpack bs) of Left _ -> decodingError ("cannot convert string " ++ BC.unpack bs) Right r -> parseRemaining r Right r -> parseRemaining r where parseRemaining r = case parseTimezone $ parseMs $ first adjustUTC r of Left err -> decodingError err Right (dt', tz) -> Right $ ASN1Time timeType dt' tz adjustUTC dt@(DateTime (Date y m d) tod) | timeType == TimeGeneralized = dt | y > 2050 = DateTime (Date (y - 100) m d) tod | otherwise = dt formatNoSeconds = init format format | timeType == TimeGeneralized = 'Y':'Y':baseFormat | otherwise = baseFormat baseFormat = "YYMMDDHMIS" parseMs (dt,s) = case s of '.':s' -> let (ns, r) = first toNano $ spanToLength 3 isDigit s' in (dt { dtTime = (dtTime dt) { todNSec = ns } }, r) _ -> (dt,s) parseTimezone (dt,s) = case s of '+':s' -> Right (dt, parseTimezoneFormat id s') '-':s' -> Right (dt, parseTimezoneFormat ((-1) *) s') 'Z':[] -> Right (dt, Just timezone_UTC) "" -> Right (dt, Nothing) _ -> Left ("unknown timezone format: " ++ s) parseTimezoneFormat transform s | length s == 4 = Just $ toTz $ toInt $ fst $ spanToLength 4 isDigit s | otherwise = Nothing where toTz z = let (h,m) = z `divMod` 100 in TimezoneOffset $ transform (h * 60 + m) toNano :: String -> NanoSeconds toNano l = fromIntegral (toInt l * order * 1000000) where len = length l order = case len of 1 -> 100 2 -> 10 3 -> 1 _ -> 1 spanToLength :: Int -> (Char -> Bool) -> String -> (String, String) spanToLength len p l = loop 0 l where loop i z | i >= len = ([], z) | otherwise = case z of [] -> ([], []) x:xs -> if p x then let (r1,r2) = loop (i+1) xs in (x:r1, r2) else ([], z) toInt :: String -> Int toInt = foldl (\acc w -> acc * 10 + (ord w - ord '0')) 0 decodingError reason = Left $ TypeDecodingFailed ("time format invalid for " ++ show timeType ++ " : " ++ reason) hasNonASCII = maybe False (const True) . B.find (\c -> c > 0x7f) -- FIXME need msec printed putTime :: ASN1TimeType -> DateTime -> Maybe TimezoneOffset -> ByteString putTime ty dt mtz = BC.pack etime where etime | ty == TimeUTC = timePrint "YYMMDDHMIS" dt ++ tzStr | otherwise = timePrint "YYYYMMDDHMIS" dt ++ msecStr ++ tzStr msecStr = [] tzStr = case mtz of Nothing -> "" Just tz | tz == timezone_UTC -> "Z" | otherwise -> show tz putInteger :: Integer -> ByteString putInteger i = B.pack $ bytesOfInt i putBitString :: BitArray -> ByteString putBitString (BitArray n bits) = B.concat [B.singleton (fromIntegral i),bits] where i = (8 - (n `mod` 8)) .&. 0x7 putString :: ByteString -> ByteString putString l = l {- no enforce check that oid1 is between [0..2] and oid2 is between [0..39] -} putOID :: [Integer] -> ByteString putOID oids = case oids of (oid1:oid2:suboids) -> let eoidclass = fromIntegral (oid1 * 40 + oid2) subeoids = B.concat $ map encode suboids in B.cons eoidclass subeoids _ -> error ("invalid OID format " ++ show oids) where encode x | x == 0 = B.singleton 0 | otherwise = putVarEncodingIntegral x asn1-encoding-0.9.4/Data/ASN1/Serialize.hs0000644000000000000000000000625612727175623016223 0ustar0000000000000000-- | -- 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.ASN1.Get import Data.ASN1.Internal import Data.ASN1.Types import Data.ASN1.Types.Lowlevel 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 -> B.ByteString putHeader (ASN1Header cl tag pc len) = B.concat [ B.singleton word1 , if tag < 0x1f then B.empty else tagBS , lenBS] 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 lenBS = B.pack $ putLength len tagBS = putVarEncodingIntegral tag {- | 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] asn1-encoding-0.9.4/Data/ASN1/Stream.hs0000644000000000000000000000316712727175623015525 0ustar0000000000000000-- | -- Module : Data.ASN1.Stream -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Data.ASN1.Stream ( ASN1Repr , getConstructedEnd , getConstructedEndRepr ) where import Data.ASN1.Types import Data.ASN1.Types.Lowlevel {- 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: - eg: cryptographic signature -} type ASN1Repr = (ASN1, [ASN1Event]) getConstructedEnd :: Int -> [ASN1] -> ([ASN1],[ASN1]) 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) 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) 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) asn1-encoding-0.9.4/Data/ASN1/BinaryEncoding/0000755000000000000000000000000012727175623016622 5ustar0000000000000000asn1-encoding-0.9.4/Data/ASN1/BinaryEncoding/Parse.hs0000644000000000000000000001755012727175623020240 0ustar0000000000000000-- | -- 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.Error import Data.ASN1.Types import Data.ASN1.Types.Lowlevel 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. -- -- * the stack of constructed elements. -- * the next expected type. -- * the position in the 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 [] -> Right (([], ParseState [] (ExpectHeader Nothing) nPos), remBytes) 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 asn1-encoding-0.9.4/Data/ASN1/BinaryEncoding/Raw.hs0000644000000000000000000000120312727175623017703 0ustar0000000000000000-- | -- 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 import Data.ASN1.Types.Lowlevel asn1-encoding-0.9.4/Data/ASN1/BinaryEncoding/Writer.hs0000644000000000000000000000275712727175623020445 0ustar0000000000000000-- | -- 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.Lowlevel import Data.ASN1.Serialize -- | 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) = putHeader hdr toBs (Primitive bs) = bs toBs ConstructionBegin = B.empty toBs ConstructionEnd = B.empty asn1-encoding-0.9.4/tests/0000755000000000000000000000000012727175623013516 5ustar0000000000000000asn1-encoding-0.9.4/tests/Tests.hs0000644000000000000000000001574412727175623015167 0ustar0000000000000000import Test.Tasty.QuickCheck import Test.Tasty import Control.Applicative import Data.ASN1.Get (runGet, Result(..)) import Data.ASN1.BitArray import Data.ASN1.Prim 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.ASN1.Types.Lowlevel import Data.Hourglass import qualified Data.ByteString as B import Control.Monad instance Arbitrary ASN1Class where arbitrary = elements [ Universal, Application, Context, Private ] instance Arbitrary ASN1Length where arbitrary = do c <- choose (0,2) :: Gen Int case c of 0 -> liftM LenShort (choose (0,0x79)) 1 -> do nb <- choose (0x80,0x1000) return $ mkSmallestLength nb _ -> return LenIndefinite where nbBytes nb = if nb > 255 then 1 + nbBytes (nb `div` 256) else 1 arbitraryDefiniteLength :: Gen ASN1Length arbitraryDefiniteLength = arbitrary `suchThat` (\l -> l /= LenIndefinite) arbitraryTag :: Gen ASN1Tag arbitraryTag = choose(1,10000) instance Arbitrary ASN1Header where arbitrary = liftM4 ASN1Header arbitrary arbitraryTag arbitrary arbitrary arbitraryEvents :: Gen ASN1Events arbitraryEvents = do hdr@(ASN1Header _ _ _ len) <- liftM4 ASN1Header arbitrary arbitraryTag (return False) arbitraryDefiniteLength let blen = case len of LenLong _ x -> x LenShort x -> x _ -> 0 pr <- liftM Primitive (arbitraryBSsized blen) return (ASN1Events [Header hdr, pr]) newtype ASN1Events = ASN1Events [ASN1Event] instance Show ASN1Events where show (ASN1Events x) = show x instance Arbitrary ASN1Events where arbitrary = arbitraryEvents arbitraryOID :: Gen OID 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) arbitraryBSsized :: Int -> Gen B.ByteString arbitraryBSsized len = do ws <- replicateM len (choose (0, 255) :: Gen Int) return $ B.pack $ map fromIntegral ws instance Arbitrary B.ByteString where arbitrary = do len <- choose (0, 529) :: Gen Int arbitraryBSsized len instance Arbitrary BitArray where arbitrary = do bs <- arbitrary w <- choose (0,7) :: Gen Int return $ toBitArray bs w instance Arbitrary Date where arbitrary = do y <- choose (1951, 2050) m <- elements [ January .. December] d <- choose (1, 30) return $ normalizeDate $ Date y m d normalizeDate :: Date -> Date normalizeDate origDate | y < 1951 = normalizeDate (Date (y + 50) m d) | otherwise = normalizedDate where normalizedDate@(Date y m d) = timeConvert (timeConvert origDate :: Elapsed) instance Arbitrary TimeOfDay where arbitrary = do h <- choose (0, 23) mi <- choose (0, 59) se <- choose (0, 59) nsec <- return 0 return $ TimeOfDay (Hours h) (Minutes mi) (Seconds se) nsec instance Arbitrary DateTime where arbitrary = DateTime <$> arbitrary <*> arbitrary instance Arbitrary TimezoneOffset where arbitrary = elements [ timezone_UTC, TimezoneOffset 60, TimezoneOffset 120, TimezoneOffset (-360) ] instance Arbitrary Elapsed where arbitrary = Elapsed . Seconds <$> arbitrary instance Arbitrary ASN1TimeType where arbitrary = elements [TimeUTC, TimeGeneralized] instance Arbitrary ASN1StringEncoding where arbitrary = elements [UTF8, Numeric, Printable, T61, VideoTex, IA5, Graphic, Visible, General, UTF32, BMP] arbitraryPrintString encoding = do let printableString = (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ " ()+,-./:=?") asn1CharacterString encoding <$> replicateM 21 (elements printableString) arbitraryBS encoding = ASN1CharacterString encoding . B.pack <$> replicateM 7 (choose (0,0xff)) arbitraryIA5String = asn1CharacterString IA5 <$> replicateM 21 (choose (toEnum 0,toEnum 127)) arbitraryUCS2 :: Gen ASN1CharacterString arbitraryUCS2 = asn1CharacterString BMP <$> replicateM 12 (choose (toEnum 0,toEnum 0xffff)) arbitraryUnicode :: ASN1StringEncoding -> Gen ASN1CharacterString arbitraryUnicode e = asn1CharacterString e <$> replicateM 35 (choose (toEnum 0,toEnum 0x10ffff)) instance Arbitrary ASN1CharacterString where arbitrary = oneof [ arbitraryUnicode UTF8 , arbitraryUnicode UTF32 , arbitraryUCS2 , arbitraryPrintString Numeric , arbitraryPrintString Printable , arbitraryBS T61 , arbitraryBS VideoTex , arbitraryIA5String , arbitraryPrintString Graphic , arbitraryPrintString Visible , arbitraryPrintString General ] 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 , ASN1String <$> arbitrary , ASN1Time <$> arbitrary <*> arbitrary <*> arbitrary ] newtype ASN1s = ASN1s [ASN1] instance Show ASN1s where 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]) prop_header_marshalling_id :: ASN1Header -> Bool prop_header_marshalling_id v = (ofDone $ runGet getHeader $ 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) = (parseLBS $ toLazyByteString e) == Right e prop_asn1_der_marshalling_id v = (decodeASN1 DER . encodeASN1 DER) v `assertEq` Right v where assertEq got expected | got /= expected = error ("got: " ++ show got ++ " expected: " ++ show expected) | otherwise = True marshallingTests = testGroup "Marshalling" [ testProperty "Header" prop_header_marshalling_id , testProperty "Event" prop_event_marshalling_id , testProperty "DER" prop_asn1_der_marshalling_id ] main = defaultMain $ testGroup "asn1-encoding" [marshallingTests]