asn1-data (empty) → 0.1
raw patch · 12 files changed
+984/−0 lines, 12 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, binary, bytestring, mtl
Files
- Data/ASN1/BER.hs +107/−0
- Data/ASN1/CER.hs +91/−0
- Data/ASN1/DER.hs +65/−0
- Data/ASN1/Internal.hs +45/−0
- Data/ASN1/Prim.hs +253/−0
- Data/ASN1/Raw.hs +267/−0
- LICENSE +27/−0
- README +0/−0
- Setup.hs +2/−0
- TODO +1/−0
- Tests.hs +81/−0
- asn1-data.cabal +45/−0
+ Data/ASN1/BER.hs view
@@ -0,0 +1,107 @@+-- |+-- Module : Data.ASN1.BER+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- A module containing ASN1 BER specification serialization/derialization tools+--+module Data.ASN1.BER (+ TagClass(..),+ ASN1(..),++ -- * BER interface when using directly Raw objects+ ofRaw,+ toRaw,++ -- * BER serial functions+ decodeASN1Get,+ decodeASN1,+ encodeASN1Put,+ encodeASN1+ ) where++import Data.ASN1.Raw+import Data.ASN1.Prim+import Data.Either+import Data.Binary.Get+import Data.Binary.Put+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as B++ofRaws :: [Value] -> Either ASN1Err [ASN1]+ofRaws x = if l == [] then Right r else Left $ ASN1Multiple l+ where+ (l, r) = partitionEithers $ map ofRaw x++ofRaw :: Value -> Either ASN1Err ASN1+ofRaw (Value Universal 0x0 (Primitive b)) = getEOC b+ofRaw (Value Universal 0x1 (Primitive b)) = getBoolean False b+ofRaw (Value Universal 0x2 (Primitive b)) = getInteger b+ofRaw (Value Universal 0x3 v) = getBitString v+ofRaw (Value Universal 0x4 v) = getOctetString v+ofRaw (Value Universal 0x5 (Primitive b)) = getNull b+ofRaw (Value Universal 0x6 (Primitive b)) = getOID b+ofRaw (Value Universal 0x7 (Primitive _)) = Left $ ASN1NotImplemented "Object Descriptor"+ofRaw (Value Universal 0x8 (Constructed _)) = Left $ ASN1NotImplemented "External"+ofRaw (Value Universal 0x9 (Primitive _)) = Left $ ASN1NotImplemented "real"+ofRaw (Value Universal 0xa (Primitive _)) = Left $ ASN1NotImplemented "enumerated"+ofRaw (Value Universal 0xb (Constructed _)) = Left $ ASN1NotImplemented "EMBEDDED PDV"+ofRaw (Value Universal 0xc v) = getUTF8String v+ofRaw (Value Universal 0xd (Primitive _)) = Left $ ASN1NotImplemented "RELATIVE-OID"+ofRaw (Value Universal 0x10 (Constructed l)) = either Left (Right . Sequence) $ ofRaws l+ofRaw (Value Universal 0x11 (Constructed l)) = either Left (Right . Set) $ ofRaws l+ofRaw (Value Universal 0x12 v) = getNumericString v+ofRaw (Value Universal 0x13 v) = getPrintableString v+ofRaw (Value Universal 0x14 v) = getT61String v+ofRaw (Value Universal 0x15 v) = getVideoTexString v+ofRaw (Value Universal 0x16 v) = getIA5String v+ofRaw (Value Universal 0x17 x) = getUTCTime x+ofRaw (Value Universal 0x18 x) = getGeneralizedTime x+ofRaw (Value Universal 0x19 _) = Left $ ASN1NotImplemented "x"+ofRaw (Value Universal 0x1a _) = Left $ ASN1NotImplemented "x"+ofRaw (Value Universal 0x1b _) = Left $ ASN1NotImplemented "x"+ofRaw (Value Universal 0x1c _) = Left $ ASN1NotImplemented "x"+ofRaw (Value Universal 0x1d _) = Left $ ASN1NotImplemented "CHARACTER STRING"+ofRaw (Value Universal 0x1e _) = Left $ ASN1NotImplemented "BMPString"+ofRaw (Value tc tn (Primitive b)) = Right $ Other tc tn (Left b)+ofRaw (Value tc tn (Constructed l)) = either Left (Right . Other tc tn . Right) $ ofRaws l++toRaw :: ASN1 -> Value+toRaw EOC = Value Universal 0x0 (Primitive B.empty)+toRaw (Boolean v) = Value Universal 0x1 (Primitive $ B.singleton (if v then 0xff else 0))+toRaw (IntVal i) = Value Universal 0x2 (putInteger i)+toRaw (BitString i bits) = Value Universal 0x3 (putBitString i bits)+toRaw (OctetString b) = Value Universal 0x4 (putString b)+toRaw Null = Value Universal 0x5 (Primitive $ B.empty)+toRaw (OID oid) = Value Universal 0x6 (putOID oid)+toRaw (Real f) = Value Universal 0x9 (Constructed []) -- not implemented+toRaw Enumerated = Value Universal 0xa (Constructed []) -- not implemented+toRaw (UTF8String b) = Value Universal 0xc (putString b)+toRaw (Sequence children) = Value Universal 0x10 (Constructed $ map toRaw children)+toRaw (Set children) = Value Universal 0x11 (Constructed $ map toRaw children)+toRaw (NumericString b) = Value Universal 0x12 (putString b)+toRaw (PrintableString b) = Value Universal 0x13 (putString b)+toRaw (T61String b) = Value Universal 0x14 (putString b)+toRaw (VideoTexString b) = Value Universal 0x15 (putString b)+toRaw (IA5String b) = Value Universal 0x16 (putString b)+toRaw (UTCTime time) = Value Universal 0x17 (putUTCTime time)+toRaw (GeneralizedTime time) = Value Universal 0x18 (putGeneralizedTime time)+toRaw (GraphicString b) = Value Universal 0x19 (putString b)+toRaw (VisibleString b) = Value Universal 0x1a (putString b)+toRaw (GeneralString b) = Value Universal 0x1b (putString b)+toRaw (UniversalString b) = Value Universal 0x1c (putString b)+toRaw (Other tc tn c) = Value tc tn (either Primitive (Constructed . map toRaw) c)++decodeASN1Get :: Get (Either ASN1Err ASN1)+decodeASN1Get = runGetErrInGet getValue >>= return . either Left ofRaw++decodeASN1 :: L.ByteString -> Either ASN1Err ASN1+decodeASN1 b = either Left ofRaw $ runGetErr getValue b++encodeASN1Put :: ASN1 -> Put+encodeASN1Put d = putValue $ toRaw d++encodeASN1 :: ASN1 -> L.ByteString+encodeASN1 = runPut . encodeASN1Put
+ Data/ASN1/CER.hs view
@@ -0,0 +1,91 @@+-- |+-- Module : Data.ASN1.CER+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- A module containing ASN1 CER specification serialization/derialization tools+--+module Data.ASN1.CER (+ TagClass(..),+ ASN1(..),++ -- * CER serial functions+ decodeASN1Get,+ decodeASN1,+ encodeASN1Put,+ encodeASN1+ ) where++import Data.ASN1.Raw+import Data.ASN1.Prim+import Data.Binary.Get+import Data.Binary.Put+import qualified Data.ASN1.BER as BER+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L++{- | check if the value is bounded by CER policies -}+check :: (TagClass, Bool, TagNumber) -> ValLength -> Maybe ASN1Err+check (_, _, _) _ = Nothing++{- | ofRaw same as BER.ofRAW but check some additional CER constraint. -}+ofRaw :: Value -> Either ASN1Err ASN1+ofRaw v = BER.ofRaw v+++{-+- 9.2 String encoding forms+string values shall be encoded with a primitive encoding if they would+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 :: (L.ByteString -> ASN1) -> L.ByteString -> ValStruct+putStringCER obj l =+ if L.length l > 1000+ then Constructed $ map (toRaw . obj) $ 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 ]++{- | toRaw create a CER encoded value ready -}+toRaw :: ASN1 -> Value+toRaw (BitString i bits) = Value Universal 0x3 (putBitString i bits)+toRaw (OctetString b) = Value Universal 0x4 (putStringCER OctetString b)+toRaw (UTF8String b) = Value Universal 0xc (putStringCER UTF8String b)+toRaw (NumericString b) = Value Universal 0x12 (putStringCER NumericString b)+toRaw (PrintableString b) = Value Universal 0x13 (putStringCER PrintableString b)+toRaw (T61String b) = Value Universal 0x14 (putStringCER T61String b)+toRaw (VideoTexString b) = Value Universal 0x15 (putStringCER VideoTexString b)+toRaw (IA5String b) = Value Universal 0x16 (putStringCER IA5String b)+toRaw (GraphicString b) = Value Universal 0x19 (putStringCER GraphicString b)+toRaw (VisibleString b) = Value Universal 0x1a (putStringCER VisibleString b)+toRaw (GeneralString b) = Value Universal 0x1b (putStringCER GeneralString b)+toRaw (UniversalString b) = Value Universal 0x1c (putStringCER UniversalString b)+toRaw v = BER.toRaw v++decodeASN1Get :: Get (Either ASN1Err ASN1)+decodeASN1Get = runGetErrInGet (getValueCheck check) >>= return . either Left ofRaw++decodeASN1 :: L.ByteString -> Either ASN1Err ASN1+decodeASN1 b = either Left ofRaw $ runGetErr (getValueCheck check) b++encodePolicyCER :: Value -> Int -> ValLength+encodePolicyCER (Value _ _ (Primitive _)) len+ | len < 0x80 = LenShort len+ | otherwise = LenLong 0 len+encodePolicyCER (Value _ _ (Constructed _)) _ = LenIndefinite++encodeASN1Put :: ASN1 -> Put+encodeASN1Put d = putValuePolicy encodePolicyCER $ toRaw d++encodeASN1 :: ASN1 -> L.ByteString+encodeASN1 = runPut . encodeASN1Put
+ Data/ASN1/DER.hs view
@@ -0,0 +1,65 @@+-- |+-- Module : Data.ASN1.DER+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- A module containing ASN1 DER specification serialization/derialization tools+--+module Data.ASN1.DER (+ TagClass(..),+ ASN1(..),++ -- * DER serialize functions+ decodeASN1Get,+ decodeASN1,+ encodeASN1Put,+ encodeASN1+ ) where++import Data.ASN1.Raw+import Data.ASN1.Prim+import Data.Binary.Get+import Data.Binary.Put+import Control.Monad (mplus)+import qualified Data.ASN1.BER as BER+import qualified Data.ByteString.Lazy as L++{- | Check if the length is the minimum possible and it's not indefinite -}+checkLength :: ValLength -> 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"++{- | check if the value type is correct -}+checkType :: TagClass -> TagNumber -> Maybe ASN1Err+checkType _ _ = Nothing++{- | check if the value is bounded by DER policies -}+check :: (TagClass, Bool, TagNumber) -> ValLength -> Maybe ASN1Err+check (tc,_,tn) vallen = checkLength vallen `mplus` checkType tc tn++{- | ofRaw same as BER.ofRAW but check some additional DER constraint. -}+ofRaw :: Value -> Either ASN1Err ASN1+ofRaw (Value Universal 0x1 (Primitive b)) = getBoolean True b+ofRaw v = BER.ofRaw v++{- | toRaw create a DER encoded value ready -}+toRaw :: ASN1 -> Value+toRaw = BER.toRaw++decodeASN1Get :: Get (Either ASN1Err ASN1)+decodeASN1Get = runGetErrInGet (getValueCheck check) >>= return . either Left ofRaw++decodeASN1 :: L.ByteString -> Either ASN1Err ASN1+decodeASN1 b = either Left BER.ofRaw $ runGetErr (getValueCheck check) b++encodeASN1Put :: ASN1 -> Put+encodeASN1Put d = putValue $ toRaw d++encodeASN1 :: ASN1 -> L.ByteString+encodeASN1 = runPut . encodeASN1Put
+ Data/ASN1/Internal.hs view
@@ -0,0 +1,45 @@+module Data.ASN1.Internal (+ uintOfBytes,+ intOfBytes,+ bytesOfUInt,+ bytesOfInt+ ) 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 = ints+ | i == 0 = [0]+ | otherwise = reverse $ plusOne $ reverse $ map complement $ ints+ where+ uints = bytesOfUInt (abs i)+ isNeg = testBit (head uints) 7+ ints = if isNeg then 0 : uints else uints+ plusOne [] = []+ plusOne (x:xs) = if x == 0xff then 0 : plusOne xs else (x+1) : xs
+ Data/ASN1/Prim.hs view
@@ -0,0 +1,253 @@+-- |+-- Module : Data.ASN1.Prim+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- Tools to read ASN1 primitive (e.g. boolean, int)+--++module Data.ASN1.Prim (+ -- | ASN1 high level algebraic type+ ASN1(..),++ -- | marshall an ASN1 type from a val struct or a bytestring+ getEOC,+ getBoolean,+ getInteger,+ getBitString,+ getOctetString,+ getUTF8String,+ getNumericString,+ getPrintableString,+ getT61String,+ getVideoTexString,+ getIA5String,+ getNull,+ getOID,+ getUTCTime,+ getGeneralizedTime,++ -- | marshall an ASN1 type to a bytestring+ putUTCTime,+ putGeneralizedTime,+ putInteger,+ putBitString,+ putString,+ putOID+ ) where++import Data.ASN1.Internal+import Data.ASN1.Raw+import Data.Bits+import Data.Word+import Data.Maybe (catMaybes)+import Data.List (unfoldr)+import Data.ByteString (ByteString)+import Data.Char (ord)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L++data ASN1 =+ EOC+ | Boolean Bool+ | IntVal Integer+ | BitString Int L.ByteString+ | OctetString L.ByteString+ | Null+ | OID [Integer]+ | Real Double+ | Enumerated+ | UTF8String L.ByteString+ | Sequence [ASN1]+ | Set [ASN1]+ | NumericString L.ByteString+ | PrintableString L.ByteString+ | T61String L.ByteString+ | VideoTexString L.ByteString+ | IA5String L.ByteString+ | 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 L.ByteString+ | Other TagClass TagNumber (Either ByteString [ASN1])+ deriving (Show, Eq)++getEOC :: ByteString -> Either ASN1Err ASN1+getEOC s =+ if B.length s == 0+ then Right $ EOC+ else Left $ ASN1Misc "EOC: data length not within bound"++getBoolean :: Bool -> ByteString -> Either ASN1Err 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"++{- | getInteger, parse a value bytestring and get the integer out of the two complement encoded bytes -}+getInteger :: ByteString -> Either ASN1Err ASN1+getInteger s+ | B.length s == 0 = Left $ ASN1Misc "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"+ else Right $ IntVal $ snd $ intOfBytes s+ where+ v1 = s `B.index` 0+ v2 = s `B.index` 1+++getBitString :: ValStruct -> Either ASN1Err ASN1+getBitString (Primitive 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 (fromIntegral toSkip') (L.fromChunks [xs])+ else Left $ ASN1Misc ("bitstring: skip number not within bound " ++ show toSkip' ++ " " ++ show s)++getBitString (Constructed _) = Left $ ASN1NotImplemented "bitstring"++getString :: (Either ByteString Value -> Maybe ASN1Err) -> ValStruct -> Either ASN1Err L.ByteString+getString check (Primitive s) =+ case check (Left s) of+ Nothing -> Right $ L.fromChunks [s]+ Just err -> Left err++getString check (Constructed l) =+ case catMaybes $ map (check . Right) l of+ [] -> Right $ L.fromChunks $ map catPrimitiveString l+ errs -> Left $ ASN1Multiple errs+ where+ catPrimitiveString (Value _ _ (Primitive b)) = b+ catPrimitiveString (Value _ _ (Constructed _)) = B.empty {- FIXME -}++getOctetString :: ValStruct -> Either ASN1Err ASN1+getOctetString = either Left (Right . OctetString) . getString (\_ -> Nothing)++getNumericString :: ValStruct -> Either ASN1Err ASN1+getNumericString = either Left (Right . NumericString) . getString (\_ -> Nothing)++getPrintableString :: ValStruct -> Either ASN1Err ASN1+getPrintableString = either Left (Right . PrintableString) . getString (\_ -> Nothing)++getUTF8String :: ValStruct -> Either ASN1Err ASN1+getUTF8String = either Left (Right . UTF8String) . getString (\_ -> Nothing)++getT61String :: ValStruct -> Either ASN1Err ASN1+getT61String = either Left (Right . T61String) . getString (\_ -> Nothing)++getVideoTexString :: ValStruct -> Either ASN1Err ASN1+getVideoTexString = either Left (Right . VideoTexString) . getString (\_ -> Nothing)++getIA5String :: ValStruct -> Either ASN1Err ASN1+getIA5String = either Left (Right . IA5String) . 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"++{- | return an OID -}+getOID :: ByteString -> Either ASN1Err 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++getUTCTime :: ValStruct -> Either ASN1Err ASN1+getUTCTime (Primitive s) =+ case B.unpack s of+ [y1, y2, m1, m2, d1, d2, h1, h2, mi1, mi2, s1, s2, z] ->+ let y = integerise y1 y2 in+ let year = 1900 + (if y <= 50 then y + 100 else y) in+ let month = integerise m1 m2 in+ let day = integerise d1 d2 in+ let hour = integerise h1 h2 in+ 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"+ where+ integerise a b = ((fromIntegral a) - (ord '0')) * 10 + ((fromIntegral b) - (ord '0'))++getUTCTime (Constructed _) = Left $ ASN1NotImplemented "utctime constructed"++getGeneralizedTime :: ValStruct -> Either ASN1Err ASN1+getGeneralizedTime (Primitive s) =+ case B.unpack s of+ [y1, y2, y3, y4, m1, m2, d1, d2, h1, h2, mi1, mi2, s1, s2, z] ->+ let year = (integerise y1 y2) * 100 + (integerise y3 y4) in+ let month = integerise m1 m2 in+ let day = integerise d1 d2 in+ let hour = integerise h1 h2 in+ 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"+ where+ integerise a b = ((fromIntegral a) - (ord '0')) * 10 + ((fromIntegral b) - (ord '0'))+getGeneralizedTime (Constructed _) = Left $ ASN1NotImplemented "generalizedtime constructed"++putTime :: Bool -> (Int, Int, Int, Int, Int, Int, Bool) -> ValStruct+putTime generalized (y,m,d,h,mi,s,z) =+ Primitive $ B.pack etime+ where+ etime =+ if generalized+ then [y1, y2, y3, y4, m1, m2, d1, d2, h1, h2, mi1, mi2, s1, s2, if z then 90 else 0 ]+ else [y3, y4, m1, m2, d1, d2, h1, h2, mi1, mi2, s1, s2, if z then 90 else 0 ]+ split2 n = (fromIntegral $ n `div` 10 + ord '0', fromIntegral $ n `mod` 10 + ord '0')+ ((y1,y2),(y3,y4)) = (split2 (y `div` 100), split2 (y `mod` 100))+ (m1, m2) = split2 m+ (d1, d2) = split2 d+ (h1, h2) = split2 h+ (mi1, mi2) = split2 mi+ (s1, s2) = split2 s++putUTCTime :: (Int, Int, Int, Int, Int, Int, Bool) -> ValStruct+putUTCTime time = putTime False time++putGeneralizedTime :: (Int, Int, Int, Int, Int, Int, Bool) -> ValStruct+putGeneralizedTime time = putTime True time++putInteger :: Integer -> ValStruct+putInteger i = Primitive $ B.pack $ bytesOfInt i++putBitString :: Int -> L.ByteString -> ValStruct+putBitString i bits = Primitive $ B.concat $ B.singleton (fromIntegral i) : L.toChunks bits++putString :: L.ByteString -> ValStruct+putString l = Primitive $ B.concat $ L.toChunks l++{- no enforce check that we oid1 is between [0..2] and oid2 is between [0..39] -}+putOID :: [Integer] -> ValStruct+putOID oids = Primitive $ B.pack $ eoid+ where+ (oid1:oid2:suboids) = oids+ eoidclass = fromIntegral (oid1 * 40 + oid2)+ ungroupSubOID x = unfoldr (\i -> if i == 0 then Nothing else Just (fromIntegral (i .&. 0x7f), i `shiftR` 7)) x+ setHighBits [] = []+ setHighBits [x] = [x]+ setHighBits (x:xs) = setBit x 7 : setHighBits xs+ subeoids = concatMap (setHighBits . reverse . ungroupSubOID) suboids+ eoid = eoidclass : subeoids
+ Data/ASN1/Raw.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- |+-- Module : Data.ASN1.Raw+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unknown+--+-- A module containing raw ASN1 serialization/derialization tools+--+module Data.ASN1.Raw (+ GetErr,+ runGetErr,+ runGetErrInGet,+ ASN1Err(..),+ CheckFn,+ TagClass(..),+ TagNumber,+ ValLength(..),+ ValStruct(..),+ Value(..),+ getValueCheck,+ getValue,+ putValuePolicy,+ putValue+ ) where++import Data.Bits+import Data.ASN1.Internal+import Data.Binary.Get+import Data.Binary.Put+import Data.ByteString (ByteString)+import Data.Word+import Control.Monad.Error+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L++data TagClass =+ Universal+ | Application+ | Context+ | Private+ deriving (Show, Eq)++data ValLength =+ LenShort Int -- | Short form with only one byte. length has to be < 127.+ | LenLong Int Int -- | Long form of N bytes+ | LenIndefinite -- | Length is indefinite expect an EOC in the stream to finish the type+ deriving (Show, Eq)++type TagNumber = Int+type TagConstructed = Bool+type Identifier = (TagClass, TagConstructed, TagNumber)++data ValStruct =+ Primitive ByteString -- | Primitive of a strict value+ | Constructed [Value] -- | Constructed of a list of values+ deriving (Show, Eq)++data Value = Value TagClass TagNumber ValStruct+ deriving (Show, Eq)++data ASN1Err =+ ASN1LengthDecodingLongContainsZero+ | ASN1PolicyFailed String String+ | ASN1NotImplemented String+ | ASN1Multiple [ASN1Err]+ | ASN1Misc String+ deriving (Show, Eq)++type CheckFn = (TagClass, Bool, TagNumber) -> ValLength -> Maybe ASN1Err++instance Error ASN1Err where+ noMsg = ASN1Misc ""+ strMsg = ASN1Misc++newtype GetErr a = GE { runGE :: ErrorT ASN1Err Get a }+ deriving (Monad, MonadError ASN1Err)++instance Functor GetErr where+ fmap f = GE . fmap f . runGE++runGetErr :: GetErr a -> L.ByteString -> Either ASN1Err a+runGetErr f b = runGet (runErrorT (runGE f)) b++runGetErrInGet :: GetErr a -> Get (Either ASN1Err a)+runGetErrInGet f = runErrorT (runGE f)++liftGet :: Get a -> GetErr a+liftGet = GE . lift++geteWord8 :: GetErr Word8+geteWord8 = liftGet getWord8++geteBytes :: Int -> GetErr ByteString+geteBytes = liftGet . getBytes++{- marshall helper for getIdentifier to unserialize long tag number -}+getTagNumberLong :: Bool -> GetErr TagNumber+getTagNumberLong nz = do+ t <- geteWord8+ let tval = fromIntegral (t .&. 0x7f)+ when (nz && tval == 0) $ error "long tag encoding failure: first value is 0"+ if (t .&. 0x80) > 0+ then do+ trest <- getTagNumberLong False+ return ((tval `shiftL` 7) + trest)+ else+ return tval++{- marshall helper for putIdentifier to serialize long tag number -}+putTagNumberLong :: TagNumber -> Put+putTagNumberLong i = do+ if i > 0x7f+ then do+ putWord8 $ fromIntegral (0x80 .|. (i .&. 0x7f))+ putTagNumberLong (i `shiftR` 7)+ else+ putWord8 $ fromIntegral (i .&. 0x7f)++{- | getIdentifier get an ASN1 encoded Identifier.+ - if the first 5 bytes value is less than 1f then it's encoded on 1 byte, otherwise+ - read bytes until the 8th bit is not set -}+getIdentifier :: GetErr Identifier+getIdentifier = do+ w <- geteWord8+ let cl =+ case (w `shiftR` 7) .&. 3 of+ 0 -> Universal+ 1 -> Application + 2 -> Context+ 3 -> Private+ _ -> Universal -- this cannot happens because of the .&. 3+ let pc = (w .&. 0x20) > 0+ let val = fromIntegral (w .&. 0x1f)+ vencoded <- if val < 0x1f then return val else getTagNumberLong True+ return $ (cl, pc, vencoded)++{- | putIdentifier encode an ASN1 Identifier into a marshalled value -}+putIdentifier :: Identifier -> Put+putIdentifier (cl, pc, val) = do+ let cli = case cl of+ Universal -> 0+ Application -> 1+ Context -> 2+ Private -> 3+ let pcval = if pc then 0x20 else 0x00+ if val < 0x1f+ then+ putWord8 $ fromIntegral $ (cli `shiftL` 7) .|. pcval .|. (val)+ else do+ putWord8 $ fromIntegral $ (cli `shiftL` 7) .|. pcval .|. 0x1f+ putTagNumberLong val++{- | getLength get the ASN1 encoded length of an item.+ - if less than 0x80 then it's encoded on 1 byte, otherwise+ - the first byte is the number of bytes to read as the length.+ - if the number of bytes is 0, then the length is indefinite,+ - and the content length is bounded by an EOC -}+getLength :: GetErr ValLength+getLength = do+ l1 <- geteWord8+ if testBit l1 7+ then do+ case fromIntegral (clearBit l1 7) of+ 0 -> return LenIndefinite+ len -> do+ lw <- geteBytes len+ return $ LenLong len (fromIntegral $ snd $ uintOfBytes lw)+ else+ return $ LenShort $ fromIntegral l1++{- | putLength encode a length into a ASN1 length.+ - see getLength for the encoding rules -}+putLength :: ValLength -> Put+putLength (LenShort i) = do+ when (i < 0 || i > 0x7f) (error "putLength: short length is not between 0x0 and 0x80")+ putWord8 (fromIntegral i)++putLength (LenLong _ i) = do+ when (i < 0) (error "putLength: long length is negative")+ let lw = bytesOfUInt $ fromIntegral i+ let lenbytes = fromIntegral (length lw .|. 0x80)+ putWord8 lenbytes+ mapM_ putWord8 lw+ +putLength (LenIndefinite) = putWord8 0x80++{- helper to getValue to build a constructed list of values when length is known -}+getValueConstructed :: CheckFn -> GetErr [Value]+getValueConstructed check = do+ remain <- liftGet $ remaining+ if remain > 0+ then do+ o <- getValueCheck check+ l <- getValueConstructed check+ return (o : l)+ else+ return []++{- helper to getValue to build a constructed list of values when length is unknown -}+getValueConstructedUntilEOC :: CheckFn -> GetErr [Value]+getValueConstructedUntilEOC check = do+ o <- getValueCheck check+ case o of+ -- technically EOC should also match (Primitive B.empty) (LenShort 0)+ Value Universal 0 _ -> return []+ _ -> do+ l <- getValueConstructedUntilEOC check+ return (o : l)++getValueOfLength :: CheckFn -> Int -> Bool -> GetErr ValStruct+getValueOfLength check len pc = do+ b <- geteBytes len+ case pc of+ True -> do+ case runGetErr (getValueConstructed check) (L.fromChunks [b]) of+ Right x -> return $ Constructed x+ Left err -> throwError err+ False -> return $ Primitive b++{- | getValueCheck decode an ASN1 value and check the values received through the check fn -}+getValueCheck :: CheckFn -> GetErr Value+getValueCheck check = do+ (tc, pc, tn) <- getIdentifier+ vallen <- getLength++ {- policy checker, if it returns an error, raise it -}+ case check (tc, pc, tn) vallen of+ Just err -> throwError err+ Nothing -> return ()++ struct <- case vallen of+ LenIndefinite -> do+ when (not pc) $ throwError $ ASN1Misc "lenght indefinite not allowed with primitive"+ vs <- getValueConstructedUntilEOC check+ return $ Constructed vs+ (LenShort len) -> getValueOfLength check len pc+ (LenLong _ len) -> getValueOfLength check len pc+ return $ Value tc tn struct++getValue :: GetErr Value+getValue = getValueCheck (\_ _ -> Nothing)++putValStruct :: ValStruct -> Put+putValStruct (Primitive x) = putByteString x+putValStruct (Constructed l) = mapM_ putValue l++putValuePolicy :: (Value -> Int -> ValLength) -> Value -> Put+putValuePolicy policy v@(Value tc tn struct) = do+ let pc =+ case struct of+ Primitive _ -> False+ Constructed _ -> True+ putIdentifier (tc, pc, tn)+ let content = runPut (putValStruct struct)+ let len = fromIntegral $ L.length content + let lenEncoded = policy v len+ putLength lenEncoded+ putLazyByteString content+ case lenEncoded of+ LenIndefinite -> putValue $ Value Universal 0x0 (Primitive B.empty)+ _ -> return ()++{- | putValue encode an ASN1 value using the shortest definite length -}+putValue :: Value -> Put+putValue = putValuePolicy (\_ len -> if len < 0x80 then LenShort len else LenLong 0 len)
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2010 Vincent Hanquez <vincent@snarc.org>++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.
+ README view
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ TODO view
@@ -0,0 +1,1 @@+remove FIXMEs
+ Tests.hs view
@@ -0,0 +1,81 @@+import Test.QuickCheck+import qualified Test.HUnit as Unit+import Test.HUnit ((~:), (~=?))+import Text.Printf+import Data.ASN1.Raw+import Data.ASN1.DER (ASN1(..))+import qualified Data.ASN1.DER as DER+import Data.Binary.Get+import Data.Binary.Put+import Data.Word+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L++mkSeq l = Value Universal 0x10 (Constructed l)+mkBool t = Value Universal 0x1 (Primitive $ B.pack [ if t then 0x1 else 0x0 ])+mkInt t = Value Universal 0x2 (Primitive $ B.pack [ t ])++famous_oids :: [[Integer]]+famous_oids =+ [ [2,1,2]+ , [1,38,53]+ , [2,24,840,24042,530,530]+ , [0,20,84,249,59342,53295392,325993252935]+ , [1,2,840,113549,1,1,1]+ ]++instance Arbitrary Value where+ arbitrary = elements [+ mkSeq [],+ mkSeq [ mkBool True, mkInt 124 ],+ mkSeq [ mkSeq [ mkBool True, mkInt 124 ], mkSeq [] ]+ ]+ coarbitrary (Value _ tn _) = variant tn++instance Arbitrary ASN1 where+ arbitrary = elements (+ [Boolean False,Boolean True,Null,EOC]+ ++ map IntVal ([0..512] ++ [10241024..10242048])+ ++ map OID famous_oids+ )+++getVal = either (const (Value Application (-1) (Constructed []))) id . runGetErr getValue+putVal = runPut . putValue++decodeASN1 = either (const EOC) id . DER.decodeASN1++prop_getput_value_id :: Value -> Bool+prop_getput_value_id v = (getVal . putVal) v == v++prop_getput_asn1_id :: ASN1 -> Bool+prop_getput_asn1_id v = (DER.decodeASN1 . DER.encodeASN1) v == Right v++tests =+ [ ("get.put value/id", test prop_getput_value_id)+ , ("get.put DER.ASN1/id", test prop_getput_asn1_id)+ ]++quickCheckMain = mapM_ (\(s,a) -> printf "%-25s: " s >> a) tests+++value_units :: [ (String, Value, [Word8]) ]+value_units = [+ ("empty Sequence", mkSeq [], [ 0x30, 0x0 ]),+ ("long Sequence", mkSeq (replicate 50 (mkBool True)), [ 0x30, 0x81, 150 ] ++ (concat $ replicate 50 [ 0x01, 0x1, 0x1 ]))+ ]++asn1_units :: [ (String, ASN1) ]+asn1_units =+ map (\oid -> ("OID " ++ show oid, OID oid)) famous_oids +++ []++utests :: [Unit.Test]+utests =+ map (\ (s, v, r) -> ("put " ++ s) ~: s ~: r ~=? (L.unpack $ putVal v)) value_units +++ map (\ (s, v, r) -> ("get " ++ s) ~: s ~: v ~=? (getVal $ L.pack r)) value_units +++ map (\ (s, v) -> ("decode/encode=id") ~: s ~: v ~=? (decodeASN1 . DER.encodeASN1) v) asn1_units++main = do+ Unit.runTestTT (Unit.TestList utests)+ quickCheckMain
+ asn1-data.cabal view
@@ -0,0 +1,45 @@+Name: asn1-data+Version: 0.1+Description:+ ASN1 data reader/writer in raw form with supports for high level forms of ASN1 (BER/CER/DER)+License: BSD3+License-file: LICENSE+Copyright: Vincent Hanquez <vincent@snarc.org>+Author: Vincent Hanquez <vincent@snarc.org>+Maintainer: Vincent Hanquez <vincent@snarc.org>+Synopsis: ASN1 data reader/writer in RAW/BER/DER/CER forms+Build-Type: Simple+Category: Data+stability: experimental+Cabal-Version: >=1.6+data-files: README, TODO+++Flag test+ Description: Build unit test+ Default: False++Library+ Build-Depends: base >= 3 && < 5,+ binary >= 0.5,+ bytestring,+ mtl+ Exposed-modules: Data.ASN1.BER+ Data.ASN1.CER+ Data.ASN1.DER+ Data.ASN1.Raw+ other-modules: Data.ASN1.Prim+ Data.ASN1.Internal+ ghc-options: -Wall++Executable Tests+ Main-Is: Tests.hs+ if flag(test)+ Buildable: True+ Build-depends: base >= 3 && < 5, HUnit, QuickCheck, bytestring+ else+ Buildable: False++source-repository head+ type: git+ location: git://github.com/vincenthz/hs-asn1-data