diff --git a/Data/ASN1/BER.hs b/Data/ASN1/BER.hs --- a/Data/ASN1/BER.hs +++ b/Data/ASN1/BER.hs @@ -7,19 +7,19 @@ -- -- A module containing ASN1 BER specification serialization/derialization tools -- -module Data.ASN1.BER ( - TagClass(..), - ASN1(..), +module Data.ASN1.BER + ( TagClass(..) + , ASN1(..) -- * BER interface when using directly Raw objects - ofRaw, - toRaw, + , ofRaw + , toRaw -- * BER serial functions - decodeASN1Get, - decodeASN1, - encodeASN1Put, - encodeASN1 + , decodeASN1Get + , decodeASN1 + , encodeASN1Put + , encodeASN1 ) where import Data.ASN1.Raw @@ -59,12 +59,12 @@ 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 Universal 0x19 x) = getGraphicString x +ofRaw (Value Universal 0x1a x) = getVisibleString x +ofRaw (Value Universal 0x1b x) = getGeneralString x +ofRaw (Value Universal 0x1c x) = getUniversalString x +ofRaw (Value Universal 0x1d x) = getCharacterString x +ofRaw (Value Universal 0x1e x) = getBMPString x ofRaw (Value tc tn (Primitive b)) = Right $ Other tc tn (Left b) ofRaw (Value tc tn (Constructed l)) = either Left (Right . Other tc tn . Right) $ ofRaws l @@ -74,7 +74,7 @@ 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 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 @@ -92,16 +92,18 @@ 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 (CharacterString b) = Value Universal 0x1d (putString b) +toRaw (BMPString b) = Value Universal 0x1e (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 +decodeASN1Get = either Left ofRaw `fmap` runGetErrInGet getValue decodeASN1 :: L.ByteString -> Either ASN1Err ASN1 -decodeASN1 b = either Left ofRaw $ runGetErr getValue b +decodeASN1 = either Left ofRaw . runGetErr getValue encodeASN1Put :: ASN1 -> Put -encodeASN1Put d = putValue $ toRaw d +encodeASN1Put = putValue . toRaw encodeASN1 :: ASN1 -> L.ByteString encodeASN1 = runPut . encodeASN1Put diff --git a/Data/ASN1/CER.hs b/Data/ASN1/CER.hs --- a/Data/ASN1/CER.hs +++ b/Data/ASN1/CER.hs @@ -7,15 +7,15 @@ -- -- A module containing ASN1 CER specification serialization/derialization tools -- -module Data.ASN1.CER ( - TagClass(..), - ASN1(..), +module Data.ASN1.CER + ( TagClass(..) + , ASN1(..) -- * CER serial functions - decodeASN1Get, - decodeASN1, - encodeASN1Put, - encodeASN1 + , decodeASN1Get + , decodeASN1 + , encodeASN1Put + , encodeASN1 ) where import Data.ASN1.Raw diff --git a/Data/ASN1/DER.hs b/Data/ASN1/DER.hs --- a/Data/ASN1/DER.hs +++ b/Data/ASN1/DER.hs @@ -7,15 +7,15 @@ -- -- A module containing ASN1 DER specification serialization/derialization tools -- -module Data.ASN1.DER ( - TagClass(..), - ASN1(..), +module Data.ASN1.DER + ( TagClass(..) + , ASN1(..) -- * DER serialize functions - decodeASN1Get, - decodeASN1, - encodeASN1Put, - encodeASN1 + , decodeASN1Get + , decodeASN1 + , encodeASN1Put + , encodeASN1 ) where import Data.ASN1.Raw diff --git a/Data/ASN1/Prim.hs b/Data/ASN1/Prim.hs --- a/Data/ASN1/Prim.hs +++ b/Data/ASN1/Prim.hs @@ -8,34 +8,41 @@ -- Tools to read ASN1 primitive (e.g. boolean, int) -- -module Data.ASN1.Prim ( +module Data.ASN1.Prim + ( -- * ASN1 high level algebraic type - ASN1(..), + 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, + , getEOC + , getBoolean + , getInteger + , getBitString + , getOctetString + , getUTF8String + , getNumericString + , getPrintableString + , getT61String + , getVideoTexString + , getIA5String + , getNull + , getOID + , getUTCTime + , getGeneralizedTime + , getGraphicString + , getVisibleString + , getGeneralString + , getUniversalString + , getCharacterString + , getBMPString -- * marshall an ASN1 type to a bytestring - putUTCTime, - putGeneralizedTime, - putInteger, - putBitString, - putString, - putOID + , putUTCTime + , putGeneralizedTime + , putInteger + , putBitString + , putString + , putOID ) where import Data.ASN1.Internal @@ -73,6 +80,8 @@ | VisibleString L.ByteString | GeneralString L.ByteString | UniversalString L.ByteString + | CharacterString L.ByteString + | BMPString L.ByteString | Other TagClass TagNumber (Either ByteString [ASN1]) deriving (Show, Eq) @@ -151,6 +160,24 @@ getIA5String :: ValStruct -> Either ASN1Err ASN1 getIA5String = either Left (Right . IA5String) . getString (\_ -> Nothing) + +getGraphicString :: ValStruct -> Either ASN1Err ASN1 +getGraphicString = either Left (Right . GraphicString) . getString (\_ -> Nothing) + +getVisibleString :: ValStruct -> Either ASN1Err ASN1 +getVisibleString = either Left (Right . VisibleString) . getString (\_ -> Nothing) + +getGeneralString :: ValStruct -> Either ASN1Err ASN1 +getGeneralString = either Left (Right . GeneralString) . getString (\_ -> Nothing) + +getUniversalString :: ValStruct -> Either ASN1Err ASN1 +getUniversalString = either Left (Right . UniversalString) . getString (\_ -> Nothing) + +getCharacterString :: ValStruct -> Either ASN1Err ASN1 +getCharacterString = either Left (Right . CharacterString) . getString (\_ -> Nothing) + +getBMPString :: ValStruct -> Either ASN1Err ASN1 +getBMPString = either Left (Right . BMPString) . 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" diff --git a/Data/ASN1/Raw.hs b/Data/ASN1/Raw.hs --- a/Data/ASN1/Raw.hs +++ b/Data/ASN1/Raw.hs @@ -8,21 +8,25 @@ -- -- 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 +module Data.ASN1.Raw + ( GetErr + -- * get structure + , runGetErr + , runGetErrInGet + -- * ASN1 definitions + , ASN1Err(..) + , CheckFn + , TagClass(..) + , TagNumber + , ValLength(..) + , ValStruct(..) + , Value(..) + -- * get value from a Get structure + , getValueCheck + , getValue + -- * put value in a Put structure + , putValuePolicy + , putValue ) where import Data.Bits @@ -81,10 +85,10 @@ fmap f = GE . fmap f . runGE runGetErr :: GetErr a -> L.ByteString -> Either ASN1Err a -runGetErr f b = runGet (runErrorT (runGE f)) b +runGetErr = runGet . runErrorT . runGE runGetErrInGet :: GetErr a -> Get (Either ASN1Err a) -runGetErrInGet f = runErrorT (runGE f) +runGetErrInGet = runErrorT . runGE liftGet :: Get a -> GetErr a liftGet = GE . lift @@ -96,27 +100,27 @@ 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 +getTagNumberLong :: GetErr TagNumber +getTagNumberLong = getNext 0 True + where getNext n nz = do + t <- fromIntegral `fmap` geteWord8 + when (nz && t == 0x80) $ throwError ASN1LengthDecodingLongContainsZero + if testBit t 7 + then getNext (n `shiftL` 7 + clearBit t 7) False + else return (n `shiftL` 7 + t) {- 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) +putTagNumberLong n = mapM_ putWord8 $ revSethighbits $ split7bits n + where + revSethighbits :: [Word8] -> [Word8] + revSethighbits [] = [] + revSethighbits (x:xs) = reverse $ (x : map (\i -> setBit i 7) xs) + split7bits i + | i == 0 = [] + | i <= 0x7f = [ fromIntegral i ] + | otherwise = fromIntegral (i .&. 0x7f) : split7bits (i `shiftR` 7) + {- | getIdentifier get an ASN1 encoded Identifier. - if the first 5 bytes value is less than 1f then it's encoded on 1 byte, otherwise @@ -125,7 +129,7 @@ getIdentifier = do w <- geteWord8 let cl = - case (w `shiftR` 7) .&. 3 of + case (w `shiftR` 6) .&. 3 of 0 -> Universal 1 -> Application 2 -> Context @@ -133,8 +137,8 @@ _ -> 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) + vencoded <- if val < 0x1f then return val else getTagNumberLong + return (cl, pc, vencoded) {- | putIdentifier encode an ASN1 Identifier into a marshalled value -} putIdentifier :: Identifier -> Put @@ -147,9 +151,9 @@ let pcval = if pc then 0x20 else 0x00 if val < 0x1f then - putWord8 $ fromIntegral $ (cli `shiftL` 7) .|. pcval .|. (val) + putWord8 $ fromIntegral $ (cli `shiftL` 6) .|. pcval .|. val else do - putWord8 $ fromIntegral $ (cli `shiftL` 7) .|. pcval .|. 0x1f + putWord8 $ fromIntegral $ (cli `shiftL` 6) .|. pcval .|. 0x1f putTagNumberLong val {- | getLength get the ASN1 encoded length of an item. @@ -161,7 +165,7 @@ getLength = do l1 <- geteWord8 if testBit l1 7 - then do + then case fromIntegral (clearBit l1 7) of 0 -> return LenIndefinite len -> do @@ -189,7 +193,7 @@ {- helper to getValue to build a constructed list of values when length is known -} getValueConstructed :: CheckFn -> GetErr [Value] getValueConstructed check = do - remain <- liftGet $ remaining + remain <- liftGet remaining if remain > 0 then do o <- getValueCheck check @@ -212,12 +216,13 @@ getValueOfLength :: CheckFn -> Int -> Bool -> GetErr ValStruct getValueOfLength check len pc = do b <- geteBytes len - case pc of - True -> do + if pc + then case runGetErr (getValueConstructed check) (L.fromChunks [b]) of Right x -> return $ Constructed x Left err -> throwError err - False -> return $ Primitive b + else + return $ Primitive b {- | getValueCheck decode an ASN1 value and check the values received through the check fn -} getValueCheck :: CheckFn -> GetErr Value @@ -232,7 +237,7 @@ struct <- case vallen of LenIndefinite -> do - when (not pc) $ throwError $ ASN1Misc "lenght indefinite not allowed with primitive" + unless pc $ throwError $ ASN1Misc "lenght indefinite not allowed with primitive" vs <- getValueConstructedUntilEOC check return $ Constructed vs (LenShort len) -> getValueOfLength check len pc diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -1,81 +1,117 @@ 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 ]) +import Control.Monad +import System.IO -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] - ] +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) -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 B.ByteString where + arbitrary = do + len <- choose (0, 529) :: Gen Int + ws <- replicateM len (choose (0, 255) :: Gen Int) + return $ B.pack $ map fromIntegral ws -instance Arbitrary ASN1 where - arbitrary = elements ( - [Boolean False,Boolean True,Null,EOC] - ++ map IntVal ([0..512] ++ [10241024..10242048]) - ++ map OID famous_oids - ) +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 +instance Arbitrary TagClass where + arbitrary = elements [ Universal, Application, Context, Private ] -getVal = either (const (Value Application (-1) (Constructed []))) id . runGetErr getValue -putVal = runPut . putValue +arbitraryValueList = choose (0,20) >>= \len -> replicateM len (suchThat arbitrary (not . isConstructed)) + where + isConstructed (Value _ _ (Constructed _)) = True + isConstructed _ = False -decodeASN1 = either (const EOC) id . DER.decodeASN1 +instance Arbitrary ValStruct where + arbitrary = oneof + [ liftM Primitive arbitrary + , liftM Constructed arbitraryValueList ] -prop_getput_value_id :: Value -> Bool -prop_getput_value_id v = (getVal . putVal) v == v +instance Arbitrary Value where + arbitrary = liftM3 Value arbitrary (suchThat arbitrary (\i -> i > 0)) arbitrary -prop_getput_asn1_id :: ASN1 -> Bool -prop_getput_asn1_id v = (DER.decodeASN1 . DER.encodeASN1) v == Right v +arbitraryTime = do + y <- choose (1950, 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) -tests = - [ ("get.put value/id", test prop_getput_value_id) - , ("get.put DER.ASN1/id", test prop_getput_asn1_id) - ] +arbitraryListASN1 = choose (0, 20) >>= \len -> replicateM len (suchThat arbitrary (not . aList)) + where + aList (Set _) = True + aList (Sequence _) = True + aList _ = False -quickCheckMain = mapM_ (\(s,a) -> printf "%-25s: " s >> a) tests +instance Arbitrary ASN1 where + arbitrary = oneof + [ return EOC + , liftM Boolean arbitrary + , liftM IntVal arbitrary + , liftM2 BitString (choose (0,7)) arbitrary + , liftM OctetString arbitrary + , return Null + , liftM OID arbitraryOID + --, Real Double + -- , return Enumerated + , liftM UTF8String arbitrary + , liftM Sequence arbitraryListASN1 + , liftM Set arbitraryListASN1 + , liftM NumericString arbitrary + , liftM PrintableString arbitrary + , liftM T61String arbitrary + , liftM VideoTexString arbitrary + , liftM IA5String arbitrary + , liftM UTCTime arbitraryTime + , liftM GeneralizedTime arbitraryTime + , liftM GraphicString arbitrary + , liftM VisibleString arbitrary + , liftM GeneralString arbitrary + , liftM UniversalString arbitrary + ] +prop_value_marshalling_id :: Value -> Bool +prop_value_marshalling_id v = (getVal . putVal) v == Right v + where + getVal = runGetErr getValue + putVal = runPut . putValue -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 ])) - ] +prop_asn1_marshalling_id :: ASN1 -> Bool +prop_asn1_marshalling_id v = (DER.decodeASN1 . DER.encodeASN1) v == Right v -asn1_units :: [ (String, ASN1) ] -asn1_units = - map (\oid -> ("OID " ++ show oid, OID oid)) famous_oids ++ - [] +args = Args + { replay = Nothing + , maxSuccess = 500 + , maxDiscard = 2000 + , maxSize = 500 + } -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 +run_test n t = putStr (" " ++ n ++ " ... ") >> hFlush stdout >> quickCheckWith args t main = do - Unit.runTestTT (Unit.TestList utests) - quickCheckMain + run_test "marshalling value = id" prop_value_marshalling_id + run_test "marshalling asn1 = id" prop_asn1_marshalling_id diff --git a/asn1-data.cabal b/asn1-data.cabal --- a/asn1-data.cabal +++ b/asn1-data.cabal @@ -1,5 +1,5 @@ Name: asn1-data -Version: 0.1.1 +Version: 0.2 Description: ASN1 data reader/writer in raw form with supports for high level forms of ASN1 (BER/CER/DER) License: BSD3 @@ -36,7 +36,7 @@ Main-Is: Tests.hs if flag(test) Buildable: True - Build-depends: base >= 3 && < 5, HUnit, QuickCheck, bytestring + Build-depends: base >= 3 && < 5, HUnit, QuickCheck >= 2, bytestring else Buildable: False