diff --git a/Data/ASN1/BER.hs b/Data/ASN1/BER.hs --- a/Data/ASN1/BER.hs +++ b/Data/ASN1/BER.hs @@ -17,18 +17,26 @@ -- * BER serial functions , decodeASN1Get + , decodeASN1State , decodeASN1 + , decodeASN1s , encodeASN1Put + , encodeASN1sPut , encodeASN1 + , encodeASN1s ) where +import Data.Int import Data.ASN1.Raw import Data.ASN1.Prim import Data.Either import Data.Binary.Get import Data.Binary.Put +import Control.Monad (liftM) +import Control.Monad.Error (throwError) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as B +import Data.Text.Lazy.Encoding (encodeUtf8, encodeUtf32BE) ofRaws :: [Value] -> Either ASN1Err [ASN1] ofRaws x = if l == [] then Right r else Left $ ASN1Multiple l @@ -76,34 +84,50 @@ 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 (Real _) = Value Universal 0x9 (Constructed []) -- not implemented toRaw Enumerated = Value Universal 0xa (Constructed []) -- not implemented -toRaw (UTF8String b) = Value Universal 0xc (putString b) +toRaw (UTF8String b) = Value Universal 0xc (putString $ encodeUtf8 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 (PrintableString b) = Value Universal 0x13 (putString $ encodeUtf8 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 (IA5String b) = Value Universal 0x16 (putString $ encodeUtf8 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 (UniversalString b) = Value Universal 0x1c (putString $ encodeUtf32BE b) toRaw (CharacterString b) = Value Universal 0x1d (putString b) -toRaw (BMPString b) = Value Universal 0x1e (putString b) +toRaw (BMPString b) = Value Universal 0x1e (putString $ encodeUCS2BE b) toRaw (Other tc tn c) = Value tc tn (either Primitive (Constructed . map toRaw) c) decodeASN1Get :: Get (Either ASN1Err ASN1) decodeASN1Get = either Left ofRaw `fmap` runGetErrInGet getValue +decodeASN1State :: L.ByteString -> Either ASN1Err (ASN1, L.ByteString, Int64) +decodeASN1State b = + runGetErrState (getValue >>= either throwError return . ofRaw) b 0 + decodeASN1 :: L.ByteString -> Either ASN1Err ASN1 decodeASN1 = either Left ofRaw . runGetErr getValue +decodeASN1s :: L.ByteString -> Either ASN1Err [ASN1] +decodeASN1s = loop where + loop z = case decodeASN1State z of + Left err -> throwError err + Right (v, rest, _) -> if L.length rest > 0 then liftM (v :) (loop rest) else return [v] + encodeASN1Put :: ASN1 -> Put encodeASN1Put = putValue . toRaw +encodeASN1sPut :: [ASN1] -> Put +encodeASN1sPut = mapM_ encodeASN1Put + encodeASN1 :: ASN1 -> L.ByteString encodeASN1 = runPut . encodeASN1Put + +encodeASN1s :: [ASN1] -> L.ByteString +encodeASN1s = runPut . encodeASN1sPut diff --git a/Data/ASN1/CER.hs b/Data/ASN1/CER.hs --- a/Data/ASN1/CER.hs +++ b/Data/ASN1/CER.hs @@ -25,6 +25,7 @@ import qualified Data.ASN1.BER as BER import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L +import Data.Text.Lazy.Encoding (encodeUtf8, encodeUtf32BE) {- | check if the value is bounded by CER policies -} check :: (TagClass, Bool, TagNumber) -> ValLength -> Maybe ASN1Err @@ -42,10 +43,10 @@ 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 = +putStringCER :: Int -> L.ByteString -> ValStruct +putStringCER tn l = if L.length l > 1000 - then Constructed $ map (toRaw . obj) $ repack1000 l + then Constructed $ map (Value Universal tn . (Primitive . B.concat . L.toChunks)) $ repack1000 l else Primitive $ B.concat $ L.toChunks l where repack1000 x = @@ -59,17 +60,18 @@ {- | 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 (OctetString b) = Value Universal 0x4 (putStringCER 0x4 b) +toRaw (UTF8String b) = Value Universal 0xc (putStringCER 0xc (encodeUtf8 b)) +toRaw (NumericString b) = Value Universal 0x12 (putStringCER 0x12 b) +toRaw (PrintableString b) = Value Universal 0x13 (putStringCER 0x13 (encodeUtf8 b)) +toRaw (T61String b) = Value Universal 0x14 (putStringCER 0x14 b) +toRaw (VideoTexString b) = Value Universal 0x15 (putStringCER 0x15 b) +toRaw (IA5String b) = Value Universal 0x16 (putStringCER 0x16 (encodeUtf8 b)) +toRaw (GraphicString b) = Value Universal 0x19 (putStringCER 0x19 b) +toRaw (VisibleString b) = Value Universal 0x1a (putStringCER 0x1a b) +toRaw (GeneralString b) = Value Universal 0x1b (putStringCER 0x1b b) +toRaw (UniversalString b) = Value Universal 0x1c (putStringCER 0x1c (encodeUtf32BE b)) +toRaw (BMPString b) = Value Universal 0x1e (putStringCER 0x1e (encodeUCS2BE b)) toRaw v = BER.toRaw v decodeASN1Get :: Get (Either ASN1Err ASN1) diff --git a/Data/ASN1/DER.hs b/Data/ASN1/DER.hs --- a/Data/ASN1/DER.hs +++ b/Data/ASN1/DER.hs @@ -13,16 +13,22 @@ -- * DER serialize functions , decodeASN1Get + , decodeASN1State , decodeASN1 + , decodeASN1s , encodeASN1Put + , encodeASN1sPut , encodeASN1 + , encodeASN1s ) where +import Data.Int import Data.ASN1.Raw import Data.ASN1.Prim import Data.Binary.Get import Data.Binary.Put -import Control.Monad (mplus) +import Control.Monad (mplus, liftM) +import Control.Monad.Error (throwError) import qualified Data.ASN1.BER as BER import qualified Data.ByteString.Lazy as L @@ -55,11 +61,27 @@ decodeASN1Get :: Get (Either ASN1Err ASN1) decodeASN1Get = runGetErrInGet (getValueCheck check) >>= return . either Left ofRaw +decodeASN1State :: L.ByteString -> Either ASN1Err (ASN1, L.ByteString, Int64) +decodeASN1State b = + runGetErrState (getValueCheck check >>= either throwError return . BER.ofRaw) b 0 + decodeASN1 :: L.ByteString -> Either ASN1Err ASN1 decodeASN1 b = either Left BER.ofRaw $ runGetErr (getValueCheck check) b +decodeASN1s :: L.ByteString -> Either ASN1Err [ASN1] +decodeASN1s = loop where + loop z = case decodeASN1State z of + Left err -> throwError err + Right (v, rest, _) -> if L.length rest > 0 then liftM (v :) (loop rest) else return [v] + encodeASN1Put :: ASN1 -> Put encodeASN1Put d = putValue $ toRaw d +encodeASN1sPut :: [ASN1] -> Put +encodeASN1sPut = mapM_ encodeASN1Put + encodeASN1 :: ASN1 -> L.ByteString encodeASN1 = runPut . encodeASN1Put + +encodeASN1s :: [ASN1] -> L.ByteString +encodeASN1s = runPut . encodeASN1sPut diff --git a/Data/ASN1/Prim.hs b/Data/ASN1/Prim.hs --- a/Data/ASN1/Prim.hs +++ b/Data/ASN1/Prim.hs @@ -43,6 +43,7 @@ , putBitString , putString , putOID + , encodeUCS2BE ) where import Data.ASN1.Internal @@ -55,6 +56,9 @@ import Data.Char (ord) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as T +import Data.Text.Lazy.Encoding (decodeASCII, decodeUtf8, decodeUtf32BE) data ASN1 = EOC @@ -66,25 +70,41 @@ | OID [Integer] | Real Double | Enumerated - | UTF8String L.ByteString + | UTF8String Text | Sequence [ASN1] | Set [ASN1] | NumericString L.ByteString - | PrintableString L.ByteString + | PrintableString Text | T61String L.ByteString | VideoTexString L.ByteString - | IA5String L.ByteString + | IA5String Text | 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 + | UniversalString Text | CharacterString L.ByteString - | BMPString L.ByteString + | BMPString Text | Other TagClass TagNumber (Either ByteString [ASN1]) deriving (Show, Eq) +encodeUCS2BE :: Text -> L.ByteString +encodeUCS2BE t = + L.pack $ concatMap (\c -> let (d,m) = (fromEnum c) `divMod` 256 in [fromIntegral m,fromIntegral d] ) $ T.unpack t + +decodeUCS2BE :: L.ByteString -> Text +decodeUCS2BE l = T.pack $ loop l + where + loop x + | L.null x = [] + | otherwise = + let (h, r) = L.splitAt 2 l in + case L.unpack h of + [a,b] -> (toEnum $ (fromIntegral a) + (fromIntegral b) * 256) : loop r + _ -> loop r + + getEOC :: ByteString -> Either ASN1Err ASN1 getEOC s = if B.length s == 0 @@ -147,10 +167,10 @@ getNumericString = either Left (Right . NumericString) . getString (\_ -> Nothing) getPrintableString :: ValStruct -> Either ASN1Err ASN1 -getPrintableString = either Left (Right . PrintableString) . getString (\_ -> Nothing) +getPrintableString = either Left (Right . PrintableString . decodeASCII) . getString (\_ -> Nothing) getUTF8String :: ValStruct -> Either ASN1Err ASN1 -getUTF8String = either Left (Right . UTF8String) . getString (\_ -> Nothing) +getUTF8String = either Left (Right . UTF8String . decodeUtf8) . getString (\_ -> Nothing) getT61String :: ValStruct -> Either ASN1Err ASN1 getT61String = either Left (Right . T61String) . getString (\_ -> Nothing) @@ -159,7 +179,7 @@ getVideoTexString = either Left (Right . VideoTexString) . getString (\_ -> Nothing) getIA5String :: ValStruct -> Either ASN1Err ASN1 -getIA5String = either Left (Right . IA5String) . getString (\_ -> Nothing) +getIA5String = either Left (Right . IA5String . decodeASCII) . getString (\_ -> Nothing) getGraphicString :: ValStruct -> Either ASN1Err ASN1 getGraphicString = either Left (Right . GraphicString) . getString (\_ -> Nothing) @@ -171,13 +191,13 @@ getGeneralString = either Left (Right . GeneralString) . getString (\_ -> Nothing) getUniversalString :: ValStruct -> Either ASN1Err ASN1 -getUniversalString = either Left (Right . UniversalString) . getString (\_ -> Nothing) +getUniversalString = either Left (Right . UniversalString . decodeUtf32BE) . 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) +getBMPString = either Left (Right . BMPString . decodeUCS2BE) . getString (\_ -> Nothing) getNull :: ByteString -> Either ASN1Err ASN1 getNull s = if B.length s == 0 then Right Null else Left $ ASN1Misc "Null: data length not within bound" diff --git a/Data/ASN1/Raw.hs b/Data/ASN1/Raw.hs --- a/Data/ASN1/Raw.hs +++ b/Data/ASN1/Raw.hs @@ -12,6 +12,7 @@ ( GetErr -- * get structure , runGetErr + , runGetErrState , runGetErrInGet -- * ASN1 definitions , ASN1Err(..) @@ -30,6 +31,7 @@ ) where import Data.Bits +import Data.Int import Data.ASN1.Internal import Data.Binary.Get import Data.Binary.Put @@ -86,6 +88,12 @@ runGetErr :: GetErr a -> L.ByteString -> Either ASN1Err a runGetErr = runGet . runErrorT . runGE + +runGetErrState :: GetErr a -> L.ByteString -> Int64 -> Either ASN1Err (a, L.ByteString, Int64) +runGetErrState g l o = + case runGetState (runErrorT $ runGE g) l o of + (Left err, _, _) -> Left err + (Right v, datarem, parsed) -> Right (v, datarem, parsed) runGetErrInGet :: GetErr a -> Get (Either ASN1Err a) runGetErrInGet = runErrorT . runGE diff --git a/Tests.hs b/Tests.hs --- a/Tests.hs +++ b/Tests.hs @@ -11,6 +11,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L +import qualified Data.Text.Lazy as T import Control.Monad import System.IO @@ -35,6 +36,12 @@ ws <- replicateM len (choose (0, 255) :: Gen Int) return $ L.pack $ map fromIntegral ws +instance Arbitrary T.Text where + arbitrary = do + len <- choose (0, 529) :: Gen Int + ws <- replicateM len arbitrary + return $ T.pack ws + instance Arbitrary TagClass where arbitrary = elements [ Universal, Application, Context, Private ] @@ -67,6 +74,15 @@ aList (Sequence _) = True aList _ = False +arbitraryPrintString = do + let printableString = (['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ " ()+,-./:=?") + x <- replicateM 21 (elements printableString) + return $ T.pack x + +arbitraryIA5String = do + x <- replicateM 21 (elements $ map toEnum [0..127]) + return $ T.pack x + instance Arbitrary ASN1 where arbitrary = oneof [ return EOC @@ -82,10 +98,10 @@ , liftM Sequence arbitraryListASN1 , liftM Set arbitraryListASN1 , liftM NumericString arbitrary - , liftM PrintableString arbitrary + , liftM PrintableString arbitraryPrintString , liftM T61String arbitrary , liftM VideoTexString arbitrary - , liftM IA5String arbitrary + , liftM IA5String arbitraryIA5String , liftM UTCTime arbitraryTime , liftM GeneralizedTime arbitraryTime , liftM GraphicString arbitrary @@ -103,7 +119,7 @@ prop_asn1_marshalling_id :: ASN1 -> Bool prop_asn1_marshalling_id v = (DER.decodeASN1 . DER.encodeASN1) v == Right v -args = Args +args = stdArgs { replay = Nothing , maxSuccess = 500 , maxDiscard = 2000 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.2.2 +Version: 0.3.0 Description: ASN1 data reader and writer in raw form with supports for high level forms of ASN1 (BER, CER and DER) License: BSD3 @@ -24,6 +24,7 @@ Build-Depends: base >= 3 && < 7, binary >= 0.5, bytestring, + text >= 0.11, mtl Exposed-modules: Data.ASN1.BER Data.ASN1.CER