diff --git a/ASN1.cabal b/ASN1.cabal new file mode 100644 --- /dev/null +++ b/ASN1.cabal @@ -0,0 +1,74 @@ +Name: ASN1 +Version: 0.0.1 +License: BSD3 +Author: Dominic Steinitz +Maintainer: dominic.steinitz@blueyonder.co.uk +Copyright: Dominic Steinitz 2003 - 2007 +Stability: Alpha +Category: Language +Homepage: http://www.haskell.org/asn1 +Synopsis: General ASN.1 support. +Description: Enough ASN.1 suppport for X.509 + identity and attribute certificates, PKCS8, PKCS1v15. + Only the Basic Encoding Rules (BER) are supported. +Build-Depends: base, mtl, QuickCheck, HUnit, NewBinary +Ghc-options: -fglasgow-exts +Exposed-Modules: Language.ASN1 + Language.ASN1.BER + Language.ASN1.InformationFramework + Language.ASN1.TLV + Language.ASN1.X509 + Language.ASN1.X509.AttributeCertificateDefinitions + Language.ASN1.PKCS1v15 + Language.ASN1.PKCS8 + Language.ASN1.Utils + Language.ASN1.Raw + +Executable: BERTest +Main-Is: BERTest.hs +Ghc-options: -fglasgow-exts +Other-modules: Language.ASN1 + Language.ASN1.BER + +Executable: BERTest2 +Main-Is: BERTest2.hs +Ghc-options: -fglasgow-exts +Other-modules: Language.ASN1 + Language.ASN1.BER + Language.ASN1.X509 + Language.ASN1.InformationFramework + Language.ASN1.X509.AttributeCertificateDefinitions + Language.ASN1.TLV + +Executable: X509Example +Main-Is: X509Example.hs +Ghc-options: -fglasgow-exts +Other-modules: Language.ASN1.BER + Language.ASN1 + Language.ASN1.TLV + Language.ASN1.X509 + Language.ASN1.Utils + +Executable: PKCS8Example +Main-Is: PKCS8Example.hs +Ghc-options: -fglasgow-exts +Other-modules: Language.ASN1.BER + Language.ASN1 + Language.ASN1.TLV + Language.ASN1.PKCS8 + Language.ASN1.X509 + +Executable: AttributeCertificate +Main-Is: AttributeCertificate.hs +Ghc-options: -fglasgow-exts +Other-modules: Language.ASN1.BER + Language.ASN1 + Language.ASN1.X509 + Language.ASN1.InformationFramework + Language.ASN1.X509.AttributeCertificateDefinitions + Language.ASN1.Utils + Language.ASN1.TLV + Language.ASN1.Raw + + + diff --git a/AttributeCertificate.hs b/AttributeCertificate.hs new file mode 100644 --- /dev/null +++ b/AttributeCertificate.hs @@ -0,0 +1,174 @@ +module Main(main) where + +import Data.Char +import Data.Maybe +import Control.Monad.Error +import Control.Monad.State +import Language.ASN1.BER +import Language.ASN1 +import Language.ASN1.X509 +import Language.ASN1.InformationFramework +import Language.ASN1.X509.AttributeCertificateDefinitions +import Test.HUnit +import System.IO +import System.Environment +import System.Console.GetOpt +import Language.ASN1.Utils +import Language.ASN1.TLV +import NewBinary.Binary +import Text.PrettyPrint +import Language.ASN1.Raw + +instance PP AttributeCertificate where + pp ac = + (label' "AttributeCertificateInfo". pp . attributeCertificateInfo1 $ ac) + $$ + (label' "AlgorithmIdentifier" . pp . algorithmIdentifier2 $ ac) + $$ + (label' "Encrypted" . pp . encrypted $ ac) + +instance PP AttributeCertificateInfo where + pp aci = + (label "Version" . pp . version1 $ aci) + $$ + (label' "Holder" . pp . holder1 $ aci) + $$ + (label' "AttCertIssuer" . pp . issuer2 $ aci) + $$ + (label' "AlgorithmIdentifier" . pp . signature1 $ aci) + $$ + (label' "CertificateSerialNumber" . pp . serialNumber1 $ aci) + $$ + (label' "CertificateValidity" . pp . attrCertValidityPeriod $ aci) + $$ + (label' "Attributes" . pp . attributes $ aci) + +label :: String -> Doc -> Doc +label s d = text s <> colon <> space <> d + +hangingLabel :: String -> Int -> Doc -> Doc +hangingLabel s n d = hang (text s <> colon <> space) n d + +label' s d = hangingLabel s 3 d + +class PP a where + pp :: a -> Doc + +instance PP GeneralName where + pp gn = + case gn of + Rfc822Name x -> text "Rfc822Name" + DNSName x -> text "DNSName" + DirectoryName x -> pp x + UnifromResourceIdentifier x -> text "UniformResourceIdentifier" + IPAddress x -> text "IPAddress" + RegisteredID x -> text "RegisteredID" + +instance PP a => PP [a] where + pp xs = vcat (map pp xs) + +instance PP a => PP (Maybe a) where + pp Nothing = text "Nothing" + pp (Just x) = pp x + +instance PP Holder where + pp = pp . entityName + +instance PP AttCertIssuer where + pp aci = + (label "IssuerName" . pp . issuerName $ aci) + $$ + (label' "BaseCertificateID" . pp . baseCertificateID $ aci) + +instance PP IssuerSerial where + pp is = + (label "Issuer" . pp . issuer1 $ is) + $$ + (label "CertificateSerialNumber" . pp . serial $ is) + +instance PP AlgorithmIdentifier where + pp ai = + (label "Algorithm" . pp . algorithm1 $ ai) + $$ + (label "Parameters" . pp . parameters1 $ ai) + +instance PP NULL where + pp _ = text "NULL" + +instance PP Integer where + pp = integer + +instance PP BitString where + pp (BitString bs) = hexdump 16 bs + +instance PP HolderGeneralNames where + pp (HolderGeneralNames x) = pp x + +instance PP GeneralNames where + pp (GeneralNames xs) = pp xs + +instance PP VisibleString where + pp (VisibleString x) = text x + +instance PP PrintableString where + pp (PrintableString x) = text x + +instance PP IA5String where + pp (IA5String x) = text x + +instance PP DirectoryString where + pp (VS x) = pp x + pp (PS x) = pp x + pp (IA x) = pp x + +instance PP AttributeTypeAndValue where + pp x = + (pp . type1 $ x) <> space <> (pp . value $ x) + +instance PP Attribute where + pp x = + (pp . attributeType $ x) <> space <> (pp . attributeValues $ x) + +instance PP AttributeValue where + pp (AVPS x) = pp x + +instance PP OID where + pp x = text . show $ x + +instance PP a => PP (SetOf a) where + pp (SetOf x) = pp x + +instance PP RelativeDistinguishedName where + pp (RelativeDistinguishedName x) = pp x + +instance PP RDNSequence where + pp (RDNSequence x) = pp x + +instance PP Name where + pp (Name x) = pp x + +instance PP AttCertValidityPeriod where + pp x = + (label "NotBeforeTime" . pp . notBeforeTime $ x) + $$ + (label "NotAfterTime" . pp . notAfterTime $ x) + +instance PP GeneralizedTime where + pp (GeneralizedTime x) = pp x + +test1 fileName = + do h <- openFile fileName ReadMode + bin <- openBinIO_ h + (l,x) <- tlvIO bin + (w,y) <- typeCheck attributeCertificate x + let (_ ::= c) = w + let d = (decode c (Just y))::(Maybe AttributeCertificate) + putStrLn (render . pp . fromJust $ d) + putStrLn "Success" + +main = + do progName <- getProgName + args <- getArgs + if length args /= 1 + then putStrLn ("Usage: " ++ progName ++ " ") + else test1 (args!!0) diff --git a/BERTest.hs b/BERTest.hs new file mode 100644 --- /dev/null +++ b/BERTest.hs @@ -0,0 +1,1214 @@ +module Main(main) where + +import Data.Char +import Data.Maybe +import Control.Monad.Error +import Control.Monad.State +import Language.ASN1.BER +import Language.ASN1 +import Test.HUnit + +{- +Some of the ASN.1 definitions are taken from various standards and +these are annotated with references. The other ASN.1 definitions +have been created specifically to check decoding. These have been +checked using the on-line tool, Asnp, available at + +http://asn1.elibel.tm.fr/en/tools/asnp/index.htm + +Notes: Definitions using ANY DEFINED BY have to be checked with -1990 +option. Asnp was developed in Objective Caml. +-} + +expectSuccess testName asnType berValue expectedAbsValue = + TestCase $ + do (w,x) <- typeCheck asnType berValue + let (_ ::= c) = w + d = decode c (Just x) + (Just y) = d + assertEqual testName expectedAbsValue y + +expectFailure testName asnType berValue expectedError = + TestCase $ + do x <- (do y <- typeCheck asnType berValue + return "Unexpected successful typechecking") + `catchError` (\e -> return $ show e) + assertEqual testName x expectedError + +{- +Some tagged value tests. See 8.14.3 of X.690 (ISO 8825-1). + +Type1 ::= VisibleString +Type2 ::= [APPLICATION 3] IMPLICIT Type1 +Type3 ::= [2] Type2 +Type4 ::= [APPLICATION 7] IMPLICIT Type3 +Type5 ::= [2] IMPLICIT Type2 +-} + +type1' = modName "Type1" absVisibleString + +type Type1 = VisibleString + +jones1 = Primitive Universal 26 5 [0x4a,0x6f,0x6e,0x65,0x73] + +decodedJones1 = VisibleString "Jones" + +tagTest1 = expectSuccess "Type1" type1' jones1 decodedJones1 + +type2 = "Type2" ::= AbsRef Application 3 Implicit type1' + +data Type2 = Type2 VisibleString + deriving (Eq,Show) + +instance Encode Type2 where + decode a b = + do x <- decode a b + return $ Type2 x + +jones2 = Primitive Application 3 5 [0x4a,0x6f,0x6e,0x65,0x73] + +decodedJones2 = Type2 decodedJones1 + +tagTest2 = expectSuccess "Type2" type2 jones2 decodedJones2 + +type3 = "Type3" ::= AbsRef Context 2 Explicit type2 + +data Type3 = Type3 Type2 + deriving (Eq,Show) + +instance Encode Type3 where + decode a b = + do y <- b + let a' = absRefedType a + b' = (encodedDefComps y)!!0 + x <- decode a' b' + return $ Type3 x + +jones3 = Constructed Context 2 7 [jones2] + +decodedJones3 = Type3 decodedJones2 + +tagTest3 = expectSuccess "Type3" type3 jones3 decodedJones3 + +type4 = "Type4" ::= AbsRef Application 7 Implicit type3 + +jones4 = Constructed Application 7 7 [jones2] + +data Type4 = Type4 Type3 + deriving (Eq,Show) + +instance Encode Type4 where + decode a b = + do x <- decode a b + return $ Type4 x + +decodedJones4 = Type4 decodedJones3 + +tagTest4 = expectSuccess "Type4" type4 jones4 decodedJones4 + +{- +Some tests for OPTIONAL components. +-} + +{- +Journey ::= + SEQUENCE { + origin IA5String, + stop1 [0] IA5String OPTIONAL, + stop2 [1] IA5String OPTIONAL, + destination IA5String + } +-} + +journey = + "Journey" ::= + AbsSeq Universal 16 Implicit [ + Regular (Just "origin" :>: (Nothing :@: absIA5String)), + Optional (Just "stop1" :>: (Just 0 :@: absIA5String)), + Optional (Just "stop2" :>: (Just 1 :@: absIA5String)), + Regular (Just "destination" :>: (Nothing :@: absIA5String)) + ] + +j1 = + Constructed Universal 16 24 [ + Primitive Universal 22 3 [97,97,98], + Primitive Context 0 3 [99,100,101], + Primitive Context 1 3 [102,103,104], + Primitive Universal 22 3 [97,97,98] + ] + +j2 = + Constructed Universal 16 24 [ + Primitive Universal 22 3 [97,97,98], + Primitive Context 1 3 [102,103,104], + Primitive Universal 22 3 [97,97,98] + ] + +data Journey = + Journey { + origin :: IA5String, + stop1 :: Maybe IA5String, + stop2 :: Maybe IA5String, + destination :: IA5String + } + deriving (Eq,Show) + +instance Encode Journey where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + Journey { + origin = fromJust (decode (as!!0) (bs!!0)), + stop1 = do decode (as!!1) (bs!!1), + stop2 = do decode (as!!2) (bs!!2), + destination = fromJust (decode (as!!3) (bs!!3)) + } + +decodedJ1 = + Journey { + origin = IA5String "aab", + stop1 = Just $ IA5String "cde", + stop2 = Just $ IA5String "fgh", + destination = IA5String "aab" + } + +decodedJ2 = + Journey { + origin = IA5String "aab", + stop1 = Nothing, + stop2 = Just $ IA5String "fgh", + destination = IA5String "aab" + } + +journeyTest1 = + expectSuccess "Journey1" journey j1 decodedJ1 + +journeyTest2 = + expectSuccess "Journey2" journey j2 decodedJ2 + +{- +Odyssey ::= SEQUENCE { + start Journey, + trip1 [0] Journey OPTIONAL, + trip2 [1] Journey OPTIONAL, + trip3 [2] Journey OPTIONAL, + end Journey + } +-} + +odyssey = + "Odyssey" ::= + AbsSeq Universal 16 Implicit [ + Regular (Just "start" :>: (Nothing :@: journey)), + Optional (Just "trip1" :>: (Just 0 :@: journey)), + Optional (Just "trip2" :>: (Just 1 :@: journey)), + Optional (Just "trip3" :>: (Just 2 :@: journey)), + Regular (Just "end" :>: (Nothing :@: journey)) + ] + +prej1 = [ + Primitive Universal 22 3 [97,97,98], + Primitive Context 0 3 [99,100,101], + Primitive Context 1 3 [102,103,104], + Primitive Universal 22 3 [97,97,98] + ] + +o1 = + Constructed Universal 16 130 [ + j1, + Constructed Context 0 26 prej1, + Constructed Context 1 26 prej1, + Constructed Context 2 26 prej1, + j1 + ] + +o2 = + Constructed Universal 16 52 [ + j1, + j1 + ] + +data Odyssey = + Odyssey { + start :: Journey, + trip1 :: Maybe Journey, + trip2 :: Maybe Journey, + trip3 :: Maybe Journey, + end :: Journey + } + deriving (Eq,Show) + +instance Encode Odyssey where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + Odyssey { + start = fromJust (decode (as!!0) (bs!!0)), + trip1 = do decode (as!!1) (bs!!1), + trip2 = do decode (as!!2) (bs!!2), + trip3 = do decode (as!!3) (bs!!3), + end = fromJust (decode (as!!4) (bs!!4)) + } + +decodedO1 = + Odyssey { + start = decodedJ1, + trip1 = Just decodedJ1, + trip2 = Just decodedJ1, + trip3 = Just decodedJ1, + end = decodedJ1 + } + +decodedO2 = + Odyssey { + start = decodedJ1, + trip1 = Nothing, + trip2 = Nothing, + trip3 = Nothing, + end = decodedJ1 + } + +odysseyTest1 = + expectSuccess "Odyssey1" odyssey o1 decodedO1 + +odysseyTest2 = + expectSuccess "Odyssey2" odyssey o2 decodedO2 + +{- +FunnyOptional ::= + SEQUENCE { + perhaps [0] IA5String OPTIONAL + } +-} + +funnyOptional = + "FunnyOptional" ::= + AbsSeq Universal 16 Implicit [ + Optional (Just "perhaps" :>: (Just 0 :@: absIA5String)) + ] + +fo1 = + Constructed Universal 16 7 [ + Primitive Context 0 3 [97,97,98] + ] + +fo2 = Constructed Universal 16 0 [] + +data FunnyOptional = + FunnyOptional { + perhaps :: Maybe IA5String + } + deriving (Eq,Show) + +instance Encode FunnyOptional where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + FunnyOptional { + perhaps = do decode (as!!0) (bs!!0) + } + +decodedFO1 = + FunnyOptional { + perhaps = Just $ IA5String "aab" + } + +funnyOptionalTest1 = + expectSuccess "FunnyOptional1" funnyOptional fo1 decodedFO1 + +decodedFO2 = + FunnyOptional { + perhaps = Nothing + } + +funnyOptionalTest2 = + expectSuccess "FunnyOptional2" funnyOptional fo2 decodedFO2 + + +{- +Some ANY DEFINED BY tests. See the former versions of the ASN.1 +standards, X.208 and X.209, sometimes referred to as ASN.1:1988 or +ASN.1:1990. This was used in some definitions of X.509 certificates, +for example: + +AlgorithmIdentifier ::= SEQUENCE { + algorithm OBJECT IDENTIFIER, + parameters ANY DEFINED BY algorithm OPTIONAL } + -- contains a value of the type + -- registered for use with the + -- algorithm object identifier value +-} + +{- +TextBook = SEQUENCE + { + author PrintableString, + citationType OID, + reference ANY DEFINED BY CitationType + } +-} + +textBook = + "TextBook" ::= + AbsSeq Universal 16 Implicit + [Regular (Just "author" :>: (Nothing :@: absPrintableString)), + Regular (Just "citationType" :>: (Nothing :@: absOID)), + AnyDefBy 1] + +data TextBook = + TextBook { + author :: PrintableString, + citationType :: OID, + reference :: PrintableString + } + deriving (Eq,Show) + +instance Encode TextBook where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + TextBook { + author = fromJust $ decode (as!!0) (bs!!0), + citationType = fromJust $ decode (as!!1) (bs!!1), + reference = fromJust $ decode (as!!2) (bs!!2) + } + +encodedPrintableString1 = + Primitive Universal 19 5 [104,101,108,108,111] + +encodedPrintableString2 = + Primitive Universal 19 5 [105,101,108,108,111] + +encodedPrintableString3 = + Primitive Universal 19 5 [106,101,108,108,111] + +encodedPrintableString4 = + Primitive Universal 19 5 [107,101,108,108,111] + +encodedOID1 = Primitive Universal 6 3 [85,4,7] + +encodedTextBook1 = + Constructed Universal 16 13 [ + encodedPrintableString1, + encodedOID1 + ] + +decodedTextBook1 = + "user error (Checking AnyDefBy 1: insufficient components)" + +encodedTextBook2 = + Constructed Universal 16 13 [ + encodedPrintableString1, + encodedOID1, + encodedPrintableString2 + ] + +decodedTextBook2 = + TextBook { + author = PrintableString "hello", + citationType = OID [2,5,4,7], + reference = PrintableString "iello" + } + +encodedTextBook3 = + Constructed Universal 16 13 [ + encodedPrintableString3, + encodedOID1, + encodedPrintableString4 + ] + +decodedTextBook3 = + TextBook { + author = PrintableString "jello", + citationType = OID [2,5,4,7], + reference = PrintableString "kello" + } + +textBookTest1 = + expectFailure "TextBook1" textBook encodedTextBook1 decodedTextBook1 + +textBookTest2 = + expectSuccess "TextBook2" textBook encodedTextBook2 decodedTextBook2 + +textBookTest3 = + expectSuccess "TextBook3" textBook encodedTextBook3 decodedTextBook3 + +library = + "Library" ::= + AbsSeq Universal 16 Implicit + [Regular (Just "first" :>: (Nothing :@: textBook)), + Regular (Just "second" :>: (Nothing :@: textBook))] + +data Library = + Library { + first :: TextBook, + second :: TextBook + } + deriving (Eq,Show) + +instance Encode Library where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + Library { + first = fromJust $ decode (as!!0) (bs!!0), + second = fromJust $ decode (as!!1) (bs!!1) + } + +encodedLibrary = + Constructed Universal 16 28 [encodedTextBook2,encodedTextBook3] + +decodedLibrary = + Library { + first = decodedTextBook2, + second = decodedTextBook3 + } + +libraryTest = + expectSuccess "Library1" library encodedLibrary decodedLibrary + +v1 = Primitive Universal 26 5 [104,101,108,108,111] -- Valid +v2 = Primitive Universal 26 5 [103,101,108,108,111] -- Valid +v3 = Primitive Universal 26 5 [31,101,108,108,111] -- Not valid VisibleString + +expectedv1 = VisibleString "hello" +expectedv2 = VisibleString "gello" +expectedv3 = + "user error (Checking \"VisibleString\": type not compatible " ++ + "with values [31,101,108,108,111])" + +visibleStringTest1 = + expectSuccess "VisibleString1" absVisibleString v1 expectedv1 + +visibleStringTest2 = + expectSuccess "VisibleString2" absVisibleString v2 expectedv2 + +visibleStringTest3 = + expectFailure "VisibleString3" absVisibleString v3 expectedv3 + +{- +A modified version of the example in Annex A of X.690 (ISO 8825-1). +-} + +{- +Name ::= [APPLICATION 1] IMPLICIT SEQUENCE + {givenName VisibleString, + initial VisibleString, + familyName VisibleString} +-} + +name = + "Name" ::= + AbsSeq Application 1 Implicit [ + Regular (Just "givenName" :>: (Nothing :@: absVisibleString)), + Regular (Just "initial" :>: (Nothing :@: absVisibleString)), + Regular (Just "familyName" :>: (Nothing :@: absVisibleString)) + ] + +data Name = Name {givenName :: VisibleString, + initial :: VisibleString, + familyName :: VisibleString} + deriving (Eq,Show) + +instance Encode Name where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + Name { + givenName = fromJust $ decode (as!!0) (bs!!0), + initial = fromJust $ decode (as!!1) (bs!!1), + familyName = fromJust $ decode (as!!2) (bs!!2) + } + +n1 = Constructed Application 1 14 [v1,v2] -- Invalid number + -- of components + +n2 = Constructed Application 1 14 [v1] -- Invalid number + -- of components + +n3 = Constructed Application 1 14 [] -- Invalid number + -- of components + +n4 = Constructed Application 1 14 [v1,v2,v1] -- Valid + +n5 = Constructed Application 1 14 [v1,v2,v3] -- Invalid component + +expectedn1 = + "user error (Checking Regular (Just \"familyName\" :>: " ++ + "(Nothing :@: (\"VisibleString\" ::= " ++ + "AbsBasePrim Universal 26 AbsVisibleString))): " ++ + "insufficient components)" + +nameTest1 = + expectFailure "Name1" name n1 expectedn1 + +expectedn2 = + "user error (Checking Regular (Just \"initial\" :>: " ++ + "(Nothing :@: (\"VisibleString\" ::= " ++ + "AbsBasePrim Universal 26 AbsVisibleString))): " ++ + "insufficient components)" + +nameTest2 = + expectFailure "Name2" name n2 expectedn2 + +expectedn3 = + "user error (Checking Regular (Just \"givenName\" :>: " ++ + "(Nothing :@: (\"VisibleString\" ::= " ++ + "AbsBasePrim Universal 26 AbsVisibleString))): " ++ + "insufficient components)" + +nameTest3 = + expectFailure "Name3" name n3 expectedn3 + +expectedn4 = + Name { + givenName = VisibleString "hello", + initial = VisibleString "gello", + familyName = VisibleString "hello" + } + +nameTest4 = + expectSuccess "Name4" name n4 expectedn4 + +expectedn5 = + "user error (Checking \"VisibleString\": " ++ + "type not compatible with values [31,101,108,108,111])" + +nameTest5 = + expectFailure "Name5" name n5 expectedn5 + +{- +EmployeeNumber ::= [APPLICATION 2] IMPLICIT INTEGER +-} + +employeeNumber = + "EmployeeNumber" ::= AbsRef Application 2 Implicit absInteger + +data EmployeeNumber = EmployeeNumber Integer + deriving (Eq,Show) + +instance Encode EmployeeNumber where + decode a b = + do x <- decode a b + return $ EmployeeNumber x + +en1 = Primitive Application 2 1 [0x33] + +decodedEN1 = EmployeeNumber 51 + +enTest1 = + expectSuccess "EmployeeNumber1" employeeNumber en1 decodedEN1 + +{- +Date ::= [APPLICATION 3] IMPLICIT VisibleString -- YYYYMMDD +-} + +date = "Date" ::= + AbsRef Application 3 Implicit absVisibleString + +data Date = Date VisibleString + deriving (Eq,Show) + +instance Encode Date where + decode a b = + do x <- decode a b + return $ Date x + +b = "30/03/2003 19:37:34 GMT" +a = "30/03/2004 19:37:34 GMT" + +nb = map (fromIntegral . ord) b +na = map (fromIntegral . ord) a + +d1 = Constructed Application 3 7 [Primitive Universal 23 23 na] -- Invalid +d2 = Primitive Application 3 6 nb -- Valid + +expectedD1 = + "user error (Checking \"Date\": " ++ + "expected PRIMITIVE Tag found CONSTRUCTED Tag\n" ++ + "\"Date\" ::= AbsBasePrim Application 3 AbsVisibleString\n" ++ + show d1 ++ ")" + +decodedD2 = Date $ VisibleString b + +dateTest1 = + expectFailure "Date1" date d1 expectedD1 + +dateTest2 = + expectSuccess "Date2" date d2 decodedD2 + +{- +ChildInformation ::= SEQUENCE + { name Name, + dateOfBirth [0] Date} +-} + +childInformation = + "ChildInformation" ::= + AbsSeq Universal 16 Implicit [ + Regular (Just "name" :>: (Nothing :@: name)), + Regular (Just "dateOfBirth" :>: (Just 0 :@: date)) + ] + +data ChildInformation = + ChildInformation { name1 :: Name, + dateOfBirth :: Date } + deriving (Eq,Show) + +instance Encode ChildInformation where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + ChildInformation { + name1 = fromJust $ decode (as!!0) (bs!!0), + dateOfBirth = fromJust $ decode (as!!1) (bs!!1) + } + +ci1 = Constructed Universal 16 28 + [n4,Primitive Context 0 6 nb] + +expectedCI1 = + ChildInformation { + name1 = expectedn4, + dateOfBirth = decodedD2 + } + +ciTest1 = + expectSuccess "ChildInformation1" childInformation ci1 expectedCI1 + +{- +PersonnelRecord ::= [APPLICATION 0] IMPLICIT SEQUENCE { + name Name, + title [0] VisibleString, + number EmployeeNumber, + dateOfHire [1] Date, + nameOfSpouse [2] Name, + children [3] IMPLICIT + SEQUENCE OF ChildInformation DEFAULT {} } +-} + +personnelRecord = + "PersonnelRecord" ::= + AbsSeq Application 0 Implicit [ + Regular (Just "name" :>: (Nothing :@: name)), + Regular (Just "title" :>: (Just 0 :@: absVisibleString)), + Regular (Just "number" :>: (Nothing :@: employeeNumber)), + Regular (Just "dateOfHire" :>: (Just 1 :@: date)), + Regular (Just "nameOfSpouse" :>: (Just 2 :@: name)), + Regular ( + Just "children" :>: ( + Just 3 :@: ( + "SEQUENCE OF ChildInformation" ::= + AbsSeqOf Universal 16 Implicit childInformation + ) + ) + ) + ] + +data PersonnelRecord = + PersonnelRecord {name2 :: Name, + title :: VisibleString, + number :: EmployeeNumber, + dateOfHire :: Date, + nameOfSpouse :: Name, + children :: [ChildInformation]} + deriving (Eq,Show) + +instance Encode PersonnelRecord where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + PersonnelRecord { + name2 = fromJust $ decode (as!!0) (bs!!0), + title = fromJust $ decode (as!!1) (bs!!1), + number = fromJust $ decode (as!!2) (bs!!2), + dateOfHire = fromJust $ decode (as!!3) (bs!!3), + nameOfSpouse = fromJust $ decode (as!!4) (bs!!4), + children = fromJust $ decode (as!!5) (bs!!5)} + +pr1 = + Constructed Application 0 23 [ + n4, + Primitive Context 0 5 [104,101,108,108,111], + en1, + Primitive Context 1 6 nb, + Constructed Context 2 14 [v1,v2,v1], + Constructed Context 3 30 [ci1] +-- Constructed Context 3 18 [Constructed Universal 16 16 [ci1]] + ] + +decodedpr1 = + PersonnelRecord { + name2 = expectedn4, + title = expectedv1, + number = decodedEN1, + dateOfHire = decodedD2, + nameOfSpouse = expectedn4, + children = [expectedCI1] + } + +prTest1 = + expectSuccess "PersonnelRecord1" personnelRecord pr1 decodedpr1 + +taggedRecord = + "PersonnelRecord" ::= + AbsSeq Application 0 Implicit [ + Regular (Just "name" :>: (Nothing :@: name)), + Regular (Just "nameOfSpouse" :>: (Just 2 :@: name)) + ] + +tr1 = + Constructed Application 0 23 [ + n4, + Constructed Context 2 14 [v1,v2,v1] + ] + +taggedRecord1 = + "PersonnelRecord" ::= + AbsSeq Application 0 Implicit [ + Regular (Just "name" :>: (Nothing :@: name)), + Regular (Just "title" :>: (Just 0 :@: absVisibleString)), + Regular (Just "number" :>: (Nothing :@: employeeNumber)), + Regular (Just "dateOfHire" :>: (Just 1 :@: date)), + Regular (Just "nameOfSpouse" :>: (Just 2 :@: name)), + Regular (Just "another" :>: (Just 3 :@: name)) + ] + +tr2 = + Constructed Application 0 23 [ + n4, + Primitive Context 0 5 [104,101,108,108,111], + en1, + Primitive Context 1 6 nb, + Constructed Context 2 14 [v1,v2,v1], + Constructed Context 3 14 [v1,v2,v1] + ] + +taggedRecord2 = + "PersonnelRecord" ::= + AbsSeq Application 0 Implicit [ + Regular (Just "name" :>: (Nothing :@: name)), + Regular ( + Just "children" :>: ( + Just 3 :@: ( + "SEQUENCE OF ChildInformation" ::= + AbsSeqOf Universal 16 Implicit childInformation + ) + ) + ) + ] + +tr3 = + Constructed Application 0 23 [ + n4, + Constructed Context 3 18 [Constructed Universal 16 16 [ci1]] + ] + +taggedRecord3 = + "TaggedRecord3" ::= + AbsSeq Application 0 Implicit [ + Regular ( + Just "children" :>: ( + Just 3 :@: ( + "SEQUENCE OF ChildInformation" ::= + AbsSeqOf Universal 16 Implicit childInformation + ) + ) + ) + ] + +tr4 = + Constructed Application 0 23 [ + Constructed Context 3 18 [Constructed Universal 16 16 [ci1]] + ] + +sequenceOfChildInformation = + "SEQUENCE OF ChildInformation" ::= + AbsSeqOf Universal 16 Implicit childInformation + +soci1 = Constructed Universal 16 30 [ci1] + +tr5 = + Constructed Application 0 32 [ + Constructed Context 3 30 [ci1] + ] + +taggedRecord4 = + "TaggedRecord3" ::= + AbsSeq Application 0 Implicit [ + Regular (Just "children" :>: (Just 3 :@: sequenceOfChildInformation)) + ] + +{- + Choice1 ::= CHOICE { + z1 [0] EmployeeNumber, + z2 [1] EmployeeNumber, + z3 [2] EmployeeNumber + } + A ::= CHOICE { + b B, + c C + } + B ::= CHOICE { + d [0] NULL, + e [1] NULL + } + C ::= CHOICE { + f [2] NULL, + g [3] NULL + } +-} + +choice1 = + "Choice1" ::= + AbsChoice [ + (Implicit, Just "z1" :>: (Just 0 :@: employeeNumber)), + (Implicit, Just "z2" :>: (Just 1 :@: employeeNumber)), + (Implicit, Just "z3" :>: (Just 2 :@: employeeNumber)) + ] + +c1 = Primitive Context 0 1 [0x33] +c2 = Primitive Context 1 1 [0x33] +c3 = Primitive Context 2 1 [0x33] +c4 = Primitive Context 3 1 [0x33] + +decodedC1 = Z1 (EmployeeNumber' 51) +decodedC2 = Z2 (EmployeeNumber' 51) +decodedC3 = Z3 (EmployeeNumber' 51) + +data Choice1 = + Z1 EmployeeNumber' | + Z2 EmployeeNumber' | + Z3 EmployeeNumber' + deriving (Eq,Show) + +instance Encode Choice1 where + decode a b = + do x <- b + let t = defaultedTagValue x + case t of + 0 -> do foo <- decode a b + return $ Z1 foo + 1 -> do foo <- decode a b + return $ Z2 foo + 2 -> do foo <- decode a b + return $ Z3 foo + +{- +EmployeeNumber ::= [APPLICATION 2] IMPLICIT INTEGER +-} + +employeeNumber' = + "EmployeeNumber" ::= AbsRef Application 2 Implicit absInteger + +data EmployeeNumber' = EmployeeNumber' Integer + deriving (Eq,Show) + +instance Encode EmployeeNumber' where + decode a b = + do x <- decode a b + return $ EmployeeNumber' x + +tChoice11 = + expectSuccess "Choice1" choice1 c1 decodedC1 + +choice2 = + "A" ::= + AbsChoice [ + (Implicit, Just "b" :>: (Nothing :@: choice3)), + (Implicit, Just "c" :>: (Nothing :@: choice4)) + ] + +data Choice2 = + B Choice3 | + C Choice4 + deriving (Eq,Show) + +instance Encode Choice2 where + decode a b = + do x <- b + let t = defaultedTagValue x + f t + | t `elem` [0,1] = + do foo <- decode a b + return $ B foo + | t `elem` [2,3] = + do foo <- decode a b + return $ C foo + f t + +decodedCBD = B decodedCD +decodedCBE = B decodedCE + +tChoice21 = + expectSuccess "Choice2BD" choice2 c1 decodedCBD + +tChoice22 = + expectSuccess "Choice2BE" choice2 c2 decodedCBE + +choice3 = + "B" ::= + AbsChoice [ + (Implicit, Just "d" :>: (Just 0 :@: employeeNumber)), + (Implicit, Just "e" :>: (Just 1 :@: employeeNumber)) + ] + +decodedCD = D (EmployeeNumber' 51) +decodedCE = E (EmployeeNumber' 51) + +data Choice3 = + D EmployeeNumber' | + E EmployeeNumber' + deriving (Eq,Show) + +instance Encode Choice3 where + decode a b = + do x <- b + let t = defaultedTagValue x + case t of + 0 -> do foo <- decode a b + return $ D foo + 1 -> do foo <- decode a b + return $ E foo + +tChoice31 = + expectSuccess "Choice3D" choice3 c1 decodedCD + +tChoice32 = + expectSuccess "Choice3E" choice3 c2 decodedCE + +choice4 = + "C" ::= + AbsChoice [ + (Implicit, Just "f" :>: (Just 2 :@: employeeNumber)), + (Implicit, Just "g" :>: (Just 3 :@: employeeNumber)) + ] + +decodedCF = F (EmployeeNumber' 51) +decodedCG = G (EmployeeNumber' 51) + +data Choice4 = + F EmployeeNumber' | + G EmployeeNumber' + deriving (Eq,Show) + +instance Encode Choice4 where + decode a b = + do x <- b + let t = defaultedTagValue x + case t of + 2 -> do foo <- decode a b + return $ F foo + 3 -> do foo <- decode a b + return $ G foo + +tChoice43 = + expectSuccess "Choice4F" choice4 c3 decodedCF + +tChoice44 = + expectSuccess "Choice4G" choice2 c4 decodedCG + +{- +NoTags ::= CHOICE { + myInt INTEGER, + myIA5 IA5String + } +-} + +noTags = + "NoTags" ::= + AbsChoice [ + (Implicit, Just "myInt" :>: (Nothing :@: absInteger)), + (Implicit, Just "myIA5" :>: (Nothing :@: absIA5String)) + ] + +nt1 = Primitive Universal 2 1 [0x33] +nt2 = Primitive Universal 22 1 [0x33] +nt3 = Primitive Universal 3 1 [0x33] +nt4 = Primitive Universal 23 1 [0x33] + +decodedNT1 = MyInt 51 +decodedNT2 = MyIA5 (IA5String "3") + +data NoTags = + MyInt Integer | + MyIA5 IA5String + deriving (Eq,Show) + +instance Encode NoTags where + decode a b = + do x <- b + let t = defaultedTagValue x + f t + | t `elem` [2] = + do foo <- decode a b + return $ MyInt foo + | t `elem` [22] = + do foo <- decode a b + return $ MyIA5 foo + f t + +tNoTags1 = + expectSuccess "NoTags1" noTags nt1 decodedNT1 + +tNoTags2 = + expectSuccess "NoTags2" noTags nt2 decodedNT2 + +{- + ExplicitChoice ::= CHOICE { + x1 [0] EXPLICIT EmployeeNumber, + x2 [1] EXPLICIT EmployeeNumber, + x3 [2] EXPLICIT EmployeeNumber + } +-} + +explicitChoice = + "ExplicitChoice" ::= + AbsChoice [ + (Explicit, Just "z1" :>: (Just 0 :@: employeeNumber)), + (Explicit, Just "z2" :>: (Just 1 :@: employeeNumber)), + (Explicit, Just "z3" :>: (Just 2 :@: employeeNumber)) + ] + +ec1 = Constructed Context 0 3 [en1] +ec2 = Constructed Context 1 3 [en1] +ec3 = Constructed Context 2 3 [en1] +ec4 = Constructed Context 3 3 [en1] + +foo e = + do (w,x) <- typeCheck explicitChoice e + putStrLn (show x) + putStrLn (show w) + let (_ ::= c) = w + d = decode c (Just x) + (Just y) = d::(Maybe ExplicitChoice) + putStrLn (show y) + + +data ExplicitChoice = + X1 EmployeeNumber | + X2 EmployeeNumber | + X3 EmployeeNumber + deriving (Eq,Show) + +instance Encode ExplicitChoice where + decode a b = + do x <- b + let t = defaultedTagValue x + a' = absRefedType a + b' = (encodedDefComps x)!!0 + foo <- decode a' b' + case t of + 0 -> return (X1 foo) + 1 -> return (X2 foo) + 2 -> return (X3 foo) + +{- +We can't put this in a test yet as w does not return something +that can be decoded mechanically. It needs more investigation but +is probably because EXPLICIT doesn't get handled correctly either +for CHOICE or SEQUENCE. +-} + +version = modName "Version" absInteger + +type Version = Integer + +certificateVersion = + "version" ::= AbsRef Context 0 Explicit version + +data CertificateVersion = + CertificateVersion Version + deriving (Eq,Show) + +instance Encode CertificateVersion where + decode a b = + do y <- b + let a' = absRefedType a + b' = (encodedDefComps y)!!0 + x <- decode a' b' + return $ CertificateVersion x + + +ver1 = + Constructed Universal 16 17 [ + Constructed Context 0 3 [ + Primitive Universal 2 1 [2] + ], + Primitive Universal 2 10 [25,139,17,209,63,154,143,254,105,160] + ] + +ver2 = + Constructed Context 0 3 [ + Primitive Universal 2 1 [2] + ] + +decodedVer2 = CertificateVersion 2 + +bar = + do (w,x) <- typeCheck certificateVersion ver2 + putStrLn (show x) + putStrLn (show w) + let (_ ::= c) = w + d = decode c (Just x) + (Just y) = d::(Maybe CertificateVersion) + putStrLn (show y) + +tVer1 = expectSuccess "Version1" certificateVersion ver2 decodedVer2 + +tests = + TestList [ + tagTest1, tagTest2, tagTest3, tagTest4, + textBookTest1, textBookTest2, textBookTest3, libraryTest, + visibleStringTest1, visibleStringTest2, visibleStringTest3, + nameTest1, nameTest2, nameTest3, nameTest4, nameTest5, + enTest1, dateTest1, dateTest2, ciTest1, + prTest1, journeyTest1, journeyTest2, odysseyTest1, + odysseyTest2, funnyOptionalTest1, funnyOptionalTest2, + tChoice11, tChoice31, tChoice32, tChoice43, tChoice44, + tChoice21, tChoice22, tNoTags1, tNoTags2, tVer1 + ] + +main = runTestTT tests + +{- +051217083900 + +Three (at least) things to think about. + +1. Real errors in choice. At the moment, all errors get treated +as a trigger to try the next alternative. + +2. Typechecking a reference returns the abstract BER representation +of the referenced element. Should this be the whole element? + +3. SEQUENCE elements can be IMPLICIT or EXPLICIT. Currently all are + treated as IMPLICIT because of + +k (Regular (mn :>: (tv :@: td)):as) (bv:bvs) = + do foo <- lift $ case tv of + Nothing -> + tc td bv + Just v -> + case mn of + Nothing -> + tc ("" ::= AbsRef Context v Implicit td) bv + Just name -> + tc (name ::= AbsRef Context v Implicit td) bv +-} diff --git a/BERTest2.hs b/BERTest2.hs new file mode 100644 --- /dev/null +++ b/BERTest2.hs @@ -0,0 +1,782 @@ +module Main(main) where + +import Data.Char +import Data.Maybe +import Control.Monad.Error +import Control.Monad.State +import Language.ASN1.BER +import Language.ASN1 +import Language.ASN1.X509 +import Language.ASN1.InformationFramework( + generalNames, + GeneralNames, + rdnSequence, + RDNSequence(..), + GeneralName(..), + GeneralNames(..), + Name(..) + ) +import Language.ASN1.X509.AttributeCertificateDefinitions ( + AttributeCertificate, + attributeCertificate, + Holder(..), + holder, + holder', + HolderGeneralNames(..), + holderGeneralNames, + AttCertIssuer(..), + attCertIssuer, + IssuerSerial(..), + issuerSerial, + Attribute(..), + attribute, + AttributeValue(..) + ) +import Test.HUnit +import System.IO +import System.Environment +import System.Console.GetOpt +-- import Codec.Utils +import Language.ASN1.TLV +import NewBinary.Binary + +expectSuccess testName asnType berValue expectedAbsValue = + TestCase $ + do (w,x) <- typeCheck' asnType berValue + let (_ ::= c) = w + d = decode c (Just x) + (Just y) = d + assertEqual testName expectedAbsValue y + +expectFailure testName asnType berValue expectedError = + TestCase $ + do x <- (do y <- typeCheck' asnType berValue + return "Unexpected successful typechecking") + `catchError` (\e -> return $ show e) + assertEqual testName x expectedError + +testHolder= + Constructed Universal 16 56 [ + Constructed Context 1 54 [ + Constructed Context 4 52 [ + Constructed Universal 16 50 [ + Constructed Universal 17 11 [ + Constructed Universal 16 9 [ + Primitive Universal 6 3 [85,4,6], + Primitive Universal 19 2 [85,75] + ] + ], + Constructed Universal 17 17 [ + Constructed Universal 16 15 [ + Primitive Universal 6 3 [85,4,7], + Primitive Universal 19 8 [75,105,110,103,115,116,111,110] + ] + ], + Constructed Universal 17 16 [ + Constructed Universal 16 14 [ + Primitive Universal 6 3 [85,4,3], + Primitive Universal 19 7 [68,111,109,105,110,105,99] + ] + ] + ] + ] + ] + ] + +decodedHolder = + Holder { + entityName = Just ( + HolderGeneralNames ( + decodedGNs + ) + ) + } + +tHolder = + expectSuccess "Holder" holder' testHolder decodedHolder + +testGNs = + Constructed Universal 16 54 [ + Constructed Context 4 52 [ + Constructed Universal 16 50 [ + Constructed Universal 17 11 [ + Constructed Universal 16 9 [ + Primitive Universal 6 3 [85,4,6], + Primitive Universal 19 2 [85,75] + ] + ], + Constructed Universal 17 17 [ + Constructed Universal 16 15 [ + Primitive Universal 6 3 [85,4,7], + Primitive Universal 19 8 [75,105,110,103,115,116,111,110] + ] + ], + Constructed Universal 17 16 [ + Constructed Universal 16 14 [ + Primitive Universal 6 3 [85,4,3], + Primitive Universal 19 7 [68,111,109,105,110,105,99] + ] + ] + ] + ] + ] + +decodedGNs = + GeneralNames [ + DirectoryName ( + Name ( + RDNSequence [ + RelativeDistinguishedName ( + SetOf [ + AttributeTypeAndValue { + type1 = OID [2,5,4,6], + value = PS (PrintableString "UK") + } + ] + ), + RelativeDistinguishedName ( + SetOf [ + AttributeTypeAndValue { + type1 = OID [2,5,4,7], + value = PS (PrintableString "Kingston") + } + ] + ), + RelativeDistinguishedName ( + SetOf [ + AttributeTypeAndValue { + type1 = OID [2,5,4,3], + value = PS (PrintableString "Dominic") + } + ] + ) + ] + ) + ) + ] + +foo = + do (w,x) <- typeCheck' generalNames testGNs + putStrLn (show x) + putStrLn (show w) + +tGeneralNames = + expectSuccess "GeneralNames" generalNames testGNs decodedGNs + +testRDNS = + Constructed Universal 16 50 [ + Constructed Universal 17 11 [ + Constructed Universal 16 9 [ + Primitive Universal 6 3 [85,4,6], + Primitive Universal 19 2 [85,75] + ] + ], + Constructed Universal 17 17 [ + Constructed Universal 16 15 [ + Primitive Universal 6 3 [85,4,7], + Primitive Universal 19 8 [75,105,110,103,115,116,111,110] + ] + ], + Constructed Universal 17 16 [ + Constructed Universal 16 14 [ + Primitive Universal 6 3 [85,4,3], + Primitive Universal 19 7 [68,111,109,105,110,105,99] + ] + ] + ] + +decodedRDNS = + RDNSequence [ + RelativeDistinguishedName ( + SetOf [ + AttributeTypeAndValue { + type1 = OID [2,5,4,6], + value = PS (PrintableString "UK") + } + ] + ), + RelativeDistinguishedName ( + SetOf [ + AttributeTypeAndValue { + type1 = OID [2,5,4,7], + value = PS (PrintableString "Kingston") + } + ] + ), + RelativeDistinguishedName ( + SetOf [ + AttributeTypeAndValue { + type1 = OID [2,5,4,3], + value = PS (PrintableString "Dominic") + } + ] + ) + ] + +tRDNSequence = + expectSuccess "RDNSequence" rdnSequence testRDNS decodedRDNS + +testHGNs = + Constructed Context 1 17 [ + Constructed Context 4 15 [ + Constructed Universal 16 13 [ + Constructed Universal 17 11 [ + Constructed Universal 16 9 [ + Primitive Universal 6 3 [85,4,6], + Primitive Universal 19 2 [85,75] + ] + ] + ] + ] + ] + +testHGNs' = + Constructed Context 1 54 [ + Constructed Context 4 52 [ + Constructed Universal 16 50 [ + Constructed Universal 17 11 [ + Constructed Universal 16 9 [ + Primitive Universal 6 3 [85,4,6], + Primitive Universal 19 2 [85,75] + ] + ], + Constructed Universal 17 17 [ + Constructed Universal 16 15 [ + Primitive Universal 6 3 [85,4,7], + Primitive Universal 19 8 [75,105,110,103,115,116,111,110] + ] + ], + Constructed Universal 17 16 [ + Constructed Universal 16 14 [ + Primitive Universal 6 3 [85,4,3], + Primitive Universal 19 7 [68,111,109,105,110,105,99] + ] + ] + ] + ] + ] + +decodedHGNs = + HolderGeneralNames ( + GeneralNames [ + DirectoryName ( + Name ( + RDNSequence [ + RelativeDistinguishedName ( + SetOf [ + AttributeTypeAndValue { + type1 = OID [2,5,4,6], + value = PS (PrintableString "UK") + } + ] + ) + ] + ) + ) + ] + ) + +tHGNs = + expectSuccess "HGNs" holderGeneralNames testHGNs decodedHGNs + +decodedHGNs' = + HolderGeneralNames ( + decodedGNs + ) + +tHGNs' = + expectSuccess "HGNs'" holderGeneralNames testHGNs' decodedHGNs' + +testACI = + Constructed Context 0 124 [ + Constructed Universal 16 63 [ + Constructed Context 4 61 [ + Constructed Universal 16 59 [ + Constructed Universal 17 11 [ + Constructed Universal 16 9 [ + Primitive Universal 6 3 [85,4,6], + Primitive Universal 19 2 [71,66] + ] + ], + Constructed Universal 17 15 [ + Constructed Universal 16 13 [ + Primitive Universal 6 3 [85,4,10], + Primitive Universal 19 6 [80,69,82,77,73,83] + ] + ], + Constructed Universal 17 27 [ + Constructed Universal 16 25 [ + Primitive Universal 6 3 [85,4,3], + Primitive Universal 19 18 [ + 65,32,80,101,114,109,105,115,32,84,101,115, + 116,32,85,115,101,114 + ] + ] + ] + ] + ] + ], + Constructed Context 0 57 [ + Constructed Universal 16 52 [ + Constructed Context 4 50 [ + Constructed Universal 16 48 [ + Constructed Universal 17 11 [ + Constructed Universal 16 9 [ + Primitive Universal 6 3 [85,4,6], + Primitive Universal 19 2 [71,66] + ] + ], + Constructed Universal 17 15 [ + Constructed Universal 16 13 [ + Primitive Universal 6 3 [85,4,10], + Primitive Universal 19 6 [80,69,82,77,73,83] + ] + ], + Constructed Universal 17 16 [ + Constructed Universal 16 14 [ + Primitive Universal 6 3 [85,4,3], + Primitive Universal 19 7 [82,111,111,116,32,67,65] + ] + ] + ] + ] + ], + Primitive Universal 2 1 [3] + ] + ] + +decodedACI = + AttCertIssuer { + issuerName = Just ( + GeneralNames [ + DirectoryName ( + Name ( + RDNSequence [ + RelativeDistinguishedName ( + SetOf [ + AttributeTypeAndValue { + type1 = OID [2,5,4,6], + value = PS (PrintableString "GB") + } + ] + ), + RelativeDistinguishedName ( + SetOf [ + AttributeTypeAndValue { + type1 = OID [2,5,4,10], + value = PS (PrintableString "PERMIS") + } + ] + ), + RelativeDistinguishedName ( + SetOf [ + AttributeTypeAndValue { + type1 = OID [2,5,4,3], + value = PS (PrintableString "A Permis Test User") + } + ] + ) + ] + ) + ) + ] + ), + baseCertificateID = Just ( + IssuerSerial { + issuer1 = GeneralNames [ + DirectoryName ( + Name ( + RDNSequence [ + RelativeDistinguishedName ( + SetOf [ + AttributeTypeAndValue { + type1 = OID [2,5,4,6], + value = PS (PrintableString "GB") + } + ] + ), + RelativeDistinguishedName ( + SetOf [ + AttributeTypeAndValue { + type1 = OID [2,5,4,10], + value = PS (PrintableString "PERMIS") + } + ] + ), + RelativeDistinguishedName ( + SetOf [ + AttributeTypeAndValue { + type1 = OID [2,5,4,3], + value = PS (PrintableString "Root CA") + } + ] + ) + ] + ) + ) + ], + serial = 3, + issuerID = Nothing + } + ) + } + +tACI = + expectSuccess "ACI" attCertIssuer testACI decodedACI + +testACI1 = + Constructed Context 0 124 [ + Constructed Universal 16 63 [ + Constructed Context 4 61 [ + Constructed Universal 16 59 [ + Constructed Universal 17 11 [ + Constructed Universal 16 9 [ + Primitive Universal 6 3 [85,4,6], + Primitive Universal 19 2 [71,66] + ] + ] + ] + ] + ], + Constructed Context 0 57 [ + Constructed Universal 16 52 [ + Constructed Context 4 50 [ + Constructed Universal 16 48 [ + Constructed Universal 17 11 [ + Constructed Universal 16 9 [ + Primitive Universal 6 3 [85,4,6], + Primitive Universal 19 2 [71,66] + ] + ] + ] + ] + ], + Primitive Universal 2 1 [3] + ] + ] + +decodedACI1 = + AttCertIssuer { + issuerName = Just ( + GeneralNames [ + DirectoryName ( + Name ( + RDNSequence [ + RelativeDistinguishedName ( + SetOf [ + AttributeTypeAndValue { + type1 = OID [2,5,4,6], + value = PS (PrintableString "GB") + } + ] + ) + ] + ) + ) + ] + ), + baseCertificateID = Just ( + IssuerSerial { + issuer1 = GeneralNames [ + DirectoryName ( + Name ( + RDNSequence [ + RelativeDistinguishedName ( + SetOf [ + AttributeTypeAndValue { + type1 = OID [2,5,4,6], + value = PS (PrintableString "GB") + } + ] + ) + ] + ) + ) + ], + serial = 3, + issuerID = Nothing + } + ) + } + +tACI1 = + expectSuccess "ACI1" attCertIssuer testACI1 decodedACI1 + + +testACI2 = + Constructed Context 0 124 [ + Constructed Context 0 57 [ + Constructed Universal 16 52 [ + Constructed Context 4 50 [ + Constructed Universal 16 48 [ + Constructed Universal 17 11 [ + Constructed Universal 16 9 [ + Primitive Universal 6 3 [85,4,6], + Primitive Universal 19 2 [71,66] + ] + ] + ] + ] + ], + Primitive Universal 2 1 [3] + ] + ] + +decodedACI2 = + AttCertIssuer { + issuerName = Nothing, + baseCertificateID = Just ( + IssuerSerial { + issuer1 = GeneralNames [ + DirectoryName ( + Name ( + RDNSequence [ + RelativeDistinguishedName ( + SetOf [ + AttributeTypeAndValue { + type1 = OID [2,5,4,6], + value = PS (PrintableString "GB") + } + ] + ) + ] + ) + ) + ], + serial = 3, + issuerID = Nothing + } + ) + } + +tACI2 = + expectSuccess "ACI2" attCertIssuer testACI2 decodedACI2 + +testIssuerSerial = + Constructed Universal 16 57 [ + Constructed Universal 16 52 [ + Constructed Context 4 50 [ + Constructed Universal 16 48 [ + Constructed Universal 17 11 [ + Constructed Universal 16 9 [ + Primitive Universal 6 3 [85,4,6], + Primitive Universal 19 2 [71,66] + ] + ] + ] + ] + ], + Primitive Universal 2 1 [3] + ] + +decodedIssuerSerial = + IssuerSerial { + issuer1 = GeneralNames [ + DirectoryName ( + Name ( + RDNSequence [ + RelativeDistinguishedName ( + SetOf [ + AttributeTypeAndValue { + type1 = OID [2,5,4,6], + value = PS (PrintableString "GB") + } + ] + ) + ] + ) + ) + ], + serial = 3, + issuerID = Nothing + } + +tIssuerSerial = + expectSuccess "IssuerSerial" issuerSerial testIssuerSerial decodedIssuerSerial + +setOfAny = [ + 0x30,0x17,0x06,0x0A,0x09,0x92,0x26,0x89, + 0x93,0xF2,0x2C,0x64,0x01,0x01,0x31,0x09, + 0x13,0x07,0x44,0x6F,0x6D,0x69,0x6E,0x69, + 0x63 + ] + +decodedSetOfAny = + Attribute { + attributeType = OID [0,9,2342,19200300,100,1,1], + attributeValues = SetOf [AVPS (PrintableString "Dominic")] + } + +tSetOfAny = + let (_,e) = tlv (map fromInteger setOfAny) in + expectSuccess "SetOfAny" attribute e decodedSetOfAny + +typeCheck' :: TypeDefn -> Encoding -> IO (TypeDefn,Defaulted) + +{- +typeCheck' a b = + do ((q,r),_) <- runStateT (tc a b) [] + return (q,r) +-} + +typeCheck' = typeCheck + +{- +TextBook = SEQUENCE { + author PrintableString, + citationType OID, + reference ANY DEFINED BY citationType + } +-} + +textBook = + "TextBook" ::= + AbsSeq Universal 16 Implicit + [Regular (Just "author" :>: (Nothing :@: absPrintableString)), + Regular (Just "citationType" :>: (Nothing :@: absOID)), + AnyDefBy 1] + +data TextBook = + TextBook { + author :: PrintableString, + citationType :: OID, + reference :: Reference + } + deriving (Eq,Show) + +instance Encode TextBook where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + TextBook { + author = fromJust $ decode (as!!0) (bs!!0), + citationType = fromJust $ decode (as!!1) (bs!!1), + reference = fromJust $ decode (as!!2) (bs!!2) + } + +data Reference = ReferencePS PrintableString + deriving (Eq,Show) + +instance Encode Reference where + decode a@(AbsBasePrim _ _ AbsPrintableString) b = + do x <- decode a b + return (ReferencePS x) + decode a b = + error (show a ++ "\n" ++ show b) + +encodedPrintableString1 = + Primitive Universal 19 5 [104,101,108,108,111] + +encodedPrintableString2 = + Primitive Universal 19 5 [105,101,108,108,111] + +encodedOID1 = Primitive Universal 6 3 [85,4,7] + +encodedTextBook2 = + Constructed Universal 16 13 [ + encodedPrintableString1, + encodedOID1, + encodedPrintableString2 + ] + +decodedTextBook = + TextBook { + author = PrintableString "hello", + citationType = OID [2,5,4,7], + reference = ReferencePS (PrintableString "iello") + } + +tTextBook = + expectSuccess "TextBook" textBook encodedTextBook2 decodedTextBook + +{- +CollectionEntry = SEQUENCE + { + entry TextBook, + category PrintableString, + catagoriser PrintableString, + catType OID, + catNumber ANY DEFINED BY catType + } +-} + +collection = + "Collection" ::= + AbsSeq Universal 16 Implicit [ + Regular (Just "entry" :>: (Nothing :@: textBook)), + Regular (Just "category" :>: (Nothing :@: absPrintableString)), + Regular (Just "catagoriser" :>: (Nothing :@: absPrintableString)), + Regular (Just "catType" :>: (Nothing :@: absOID)), + AnyDefBy 3 + ] + +data Collection = + Collection { + entry :: TextBook, + category :: PrintableString, + categoriser :: PrintableString, + catType :: OID, + catNumber :: CatNumber + } + deriving (Eq,Show) + +instance Encode Collection where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + Collection { + entry = fromJust $ decode (as!!0) (bs!!0), + category = fromJust $ decode (as!!1) (bs!!1), + categoriser = fromJust $ decode (as!!2) (bs!!2), + catType = fromJust $ decode (as!!3) (bs!!3), + catNumber = fromJust $ decode (as!!4) (bs!!4) + } + +data CatNumber = CatNumberPS PrintableString + deriving (Eq,Show) + +instance Encode CatNumber where + decode a@(AbsBasePrim _ _ AbsPrintableString) b = + do x <- decode a b + return (CatNumberPS x) + decode a b = + error (show a ++ "\n" ++ show b) + +encodedCollection = + Constructed Universal 16 30 [ + encodedTextBook2, + encodedPrintableString2, + encodedPrintableString2, + encodedOID1, + encodedPrintableString1 + ] + +decodedCollection = + Collection { + entry = TextBook { + author = PrintableString "hello", + citationType = OID [2,5,4,7], + reference = ReferencePS (PrintableString "iello") + }, + category = PrintableString "iello", + categoriser = PrintableString "iello", + catType = OID [2,5,4,7], + catNumber = CatNumberPS (PrintableString "hello") + } + +tCollection = + expectSuccess "Collection" collection encodedCollection decodedCollection + +tests = + TestList [ + tRDNSequence, tGeneralNames, tHolder, tHGNs, + tHGNs', tACI, tACI1, tACI2, + tIssuerSerial, tSetOfAny, tTextBook, tCollection + ] + +main = runTestTT tests + diff --git a/Language/ASN1.hs b/Language/ASN1.hs new file mode 100644 --- /dev/null +++ b/Language/ASN1.hs @@ -0,0 +1,331 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.ASN1 +-- Copyright : (c) Dominic Steinitz 2005 - 2007 +-- License : BSD3 +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : portable +-- +-- Typecheck and decode an abstract BER representations (as, for +-- example, produced by Codec.ASN1.TLV). +-- +----------------------------------------------------------------------------- + +module Language.ASN1 ( + -- * Types + TagType(..), + TagValue, + TagPlicity(..), + AbsPrimType(..), + AbstractType(..), + TypeDefn(..), + TaggedType(..), + NamedType(..), + ComponentType(..), + -- * Haskell Equivalences of Base ASN.1 Types + VisibleString(..), + PrintableString(..), + IA5String(..), + DirectoryString(..), + OID(..), + NULL, + OctetString(..), + BitString(..), + SetOf(..), + -- * Modifiers and Accessor Functions + modName, + getAbsType, + modTagType, + modTagVal, + absRefedType, + absSeqComponents, + absSeqOfType, + absSetOfType, + namedTypeAbstract, + unVisibleString, + unDirectoryString, + unSetOf, + -- * Base ASN.1 Type Definitions + absVisibleString, + absPrintableString, + absIA5String, + absInteger, + absOID, + absNull, + absOctetString, + absBitString, + -- * Auxilliary ASN.1 Type Definitions + commonName, + organizationUnitName, + emailAddress, + domainComponent, + -- * Association Table of Types and OIDs + oids + ) where + +import Data.Char +import qualified Data.Map as Map +-- import Codec.Utils +import Data.Word +type Octet = Word8 + +data TagType = Universal | Application | Context | Private + deriving (Eq,Show, Enum) + +type TagValue = Integer + +data TagPlicity = Implicit | Explicit + deriving (Eq,Show) + +data AbsPrimType = AbsVisibleString + | AbsPrintableString + | AbsIA5String + | AbsBool + | AbsInteger + | AbsOID + | AbsNull + | AbsOctetString + | AbsBitString + deriving (Eq,Show) + +data AbstractType = AbsBasePrim TagType TagValue AbsPrimType + | AbsRef TagType TagValue TagPlicity TypeDefn + | AbsSeq TagType TagValue TagPlicity [ComponentType] + | AbsSeqOf TagType TagValue TagPlicity TypeDefn + | AbsSetOf TagType TagValue TagPlicity TypeDefn + | AbsChoice [(TagPlicity,NamedType)] + | AbsAnyDefBy ComponentIndex + deriving (Eq,Show) + +data TaggedType = Maybe TagValue :@: TypeDefn + deriving (Eq,Show) + +data NamedType = Maybe String :>: TaggedType + deriving (Eq,Show) + +{- +For now. We should probably replace [Octet] by an existential type +and know how to encode it rather than forcing the user to encode it +by hand for a specific encoding. +-} + +{- +Also for now, we will hand code the Component Index. +-} + +type ComponentIndex = Int + +data ComponentType = Regular NamedType + | Optional NamedType + | Default NamedType [Octet] + | AnyDefBy ComponentIndex + deriving (Eq,Show) + +data TypeDefn = String ::= AbstractType + deriving (Eq,Show) + +class Tagged a where + modTagVal :: Maybe TagValue -> a -> a + modTagType :: TagType -> a -> a + +instance Tagged AbstractType where + modTagVal x a@(AbsBasePrim tt tv at) = + case x of + Nothing -> a + Just y -> AbsBasePrim tt y at + modTagVal x a@(AbsRef tt tv tp at) = + case x of + Nothing -> a + Just y -> AbsRef tt y tp at + modTagVal x a@(AbsSeq tt tv tp as) = + case x of + Nothing -> a + Just y -> AbsSeq tt y tp as + modTagVal x a@(AbsSeqOf tt y tp td) = + case x of + Nothing -> a + Just y -> AbsSeqOf tt y tp td + modTagVal x a@(AbsChoice tpnts) = + case x of + Nothing -> a + Just y -> let tps = map fst tpnts + nts = map snd tpnts + mts = map (modTagVal x) nts + in AbsChoice $ zip tps mts + modTagType x a@(AbsBasePrim tt tv at) = + AbsBasePrim x tv at + modTagType x a@(AbsRef tt tv tp at) = + AbsRef x tv tp at + modTagType x a@(AbsSeq tt tv tp as) = + AbsSeq x tv tp as + modTagType x a@(AbsSeqOf tt tv tp td) = + AbsSeqOf x tv tp td + modTagType x a@(AbsChoice tpnts) = + let tps = map fst tpnts + nts = map snd tpnts + mts = map (modTagType x) nts + in AbsChoice $ zip tps mts + +instance Tagged TypeDefn where + modTagVal x (n ::= t) = n ::= (modTagVal x t) + modTagType x (n ::= t) = n ::= (modTagType x t) + +instance Tagged NamedType where + modTagVal x (n :>: t) = n :>: (modTagVal x t) + modTagType x (n :>: t) = n :>: (modTagType x t) + +instance Tagged TaggedType where + modTagVal x (_ :@: t) = x :@: t + modTagType x (v :@: t) = v :@: (modTagType x t) + +-- | Create a new type definition from an existing one. + +modName :: String -> TypeDefn -> TypeDefn +modName x (_ ::= at) = (x ::= at) + +getAbsType :: TypeDefn -> AbstractType +getAbsType (_ ::= t) = t + +-- | Get the components of a SEQUENCE. + +absSeqComponents :: AbstractType -> [AbstractType] +absSeqComponents (AbsSeq _ _ _ as) = ats + where ats = map f as + f (Regular (_ :>: (_ :@: (_ ::= x)))) = x + f (Optional (_ :>: (_ :@: (_ ::= x)))) = x + f (Default (_ :>: (_ :@: (_ ::= x))) _) = x + f (AnyDefBy n) = AbsAnyDefBy n + +-- | Get the component of the SEQUENCE OF. + +absSeqOfType :: AbstractType -> AbstractType +absSeqOfType (AbsSeqOf _ _ _ (_ ::= x)) = x + +-- | Get the component of the SET OF. + +absSetOfType :: AbstractType -> AbstractType +absSetOfType (AbsSetOf _ _ _ (_ ::= x)) = x + +-- | Get the component of a referenced type. + +absRefedType :: AbstractType -> AbstractType +absRefedType (AbsRef _ _ _ (_ ::= x)) = x + +namedTypeAbstract :: NamedType -> AbstractType +namedTypeAbstract (_ :>: (_ :@: (_ ::= x))) = x + +data VisibleString = VisibleString String + deriving (Eq,Show) + +unVisibleString :: VisibleString -> String +unVisibleString (VisibleString x) = x + +data PrintableString = PrintableString String + deriving (Eq,Show) + +data IA5String = IA5String String + deriving (Eq,Show) + +data DirectoryString = VS VisibleString + | PS PrintableString + | IA IA5String + deriving (Eq,Show) + +unDirectoryString :: DirectoryString -> String +unDirectoryString (PS (PrintableString x)) = x +unDirectoryString (VS (VisibleString x)) = x +unDirectoryString (IA (IA5String x)) = x + +newtype OID = OID [Integer] + deriving (Eq, Show, Ord) + +data NULL = NULL + deriving (Eq, Show) + +data OctetString = OctetString [Octet] + deriving (Eq,Show) + +data BitString = BitString [Octet] + deriving (Eq,Show) + +data SetOf a = SetOf [a] + deriving (Eq,Show) + +unSetOf :: SetOf a -> [a] +unSetOf (SetOf x) = x + +absVisibleString :: TypeDefn +absVisibleString = + "VisibleString" ::= AbsBasePrim Universal 26 AbsVisibleString + +absPrintableString :: TypeDefn +absPrintableString = + "PrintableString" ::= AbsBasePrim Universal 19 AbsPrintableString + +absIA5String :: TypeDefn +absIA5String = + "IA5String" ::= AbsBasePrim Universal 22 AbsIA5String + +absInteger :: TypeDefn +absInteger = + "Integer" ::= AbsBasePrim Universal 2 AbsInteger + +absOID :: TypeDefn +absOID = + "OID" ::= AbsBasePrim Universal 6 AbsOID + +absNull :: TypeDefn +absNull = + "NULL" ::= AbsBasePrim Universal 5 AbsNull + +absOctetString :: TypeDefn +absOctetString = + "OCTET STRING" ::= AbsBasePrim Universal 4 AbsOctetString + +absBitString :: TypeDefn +absBitString = + "BIT STRING" ::= AbsBasePrim Universal 3 AbsBitString + +commonName :: TypeDefn +commonName = modName "CommonName" absPrintableString + +countryName :: TypeDefn +countryName = modName "CountryName" absPrintableString + +localityName :: TypeDefn +localityName = modName "LocalityName" absPrintableString + +organization :: TypeDefn +organization = modName "Organization" absPrintableString + +organizationUnitName :: TypeDefn +organizationUnitName = modName "OrganizationUnitName" absPrintableString + +emailAddress :: TypeDefn +emailAddress = modName "EmailAddress" absIA5String + +domainComponent :: TypeDefn +domainComponent = modName "DomainComponent" absIA5String + +userId :: TypeDefn +userId = modName "UserId" absPrintableString + +exemptionRole :: TypeDefn +exemptionRole = modName "exemptionRole" absPrintableString + +oids :: Map.Map OID TypeDefn + +oids = + Map.fromList [ + (OID [2,5,4,3],commonName), + (OID [2,5,4,6],countryName), + (OID [2,5,4,7],localityName), + (OID [2,5,4,10],organization), + (OID [2,5,4,11],organizationUnitName), + (OID [1,2,840,113549,1,9,1],emailAddress), + (OID [0,9,2342,19200300,100,1,25],domainComponent), + (OID [0,9,2342,19200300,100,1,1],userId), + (OID [1,2,826,0,1,3344810,1,1,23],exemptionRole) + ] diff --git a/Language/ASN1/BER.hs b/Language/ASN1/BER.hs new file mode 100644 --- /dev/null +++ b/Language/ASN1/BER.hs @@ -0,0 +1,556 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.ASN1.BER +-- Copyright : (c) Dominic Steinitz 2005 - 2007 +-- License : BSD3 +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : portable +-- +-- Typecheck and decode BER representations as produced by +-- Language.ASN1.TLV +-- +----------------------------------------------------------------------------- + +module Language.ASN1.BER ( + -- * Types + Encoding(..), + Defaulted(..), + Length, + -- * Type classes + Encode(..), + -- * Function types + encodedComponents, + encodedDefComps, + defaultedTagValue, + typeCheck, + replaceRef + ) where + +import Data.Char +import Data.Bits +import Data.List +import qualified Data.Map as Map +import Control.Monad.Error +import Control.Monad.State +import Language.ASN1.Utils +import Language.ASN1 + +type Length = Integer +type PrimitiveValue = [Octet] + +data Encoding = Primitive TagType TagValue Length PrimitiveValue + | Constructed TagType TagValue Length [Encoding] + deriving (Eq,Show) + +data Defaulted = DefPrim TagType TagValue Length PrimitiveValue + | DefCons TagType TagValue Length [Maybe Defaulted] + deriving (Eq,Show) + +encodedComponents :: Encoding -> [Encoding] +encodedComponents (Constructed _ _ _ es) = es + +encodedDefComps :: Defaulted -> [Maybe Defaulted] +encodedDefComps (DefCons _ _ _ es) = es + +defaultedTagValue :: Defaulted -> TagValue +defaultedTagValue (DefPrim _ t _ _) = t +defaultedTagValue (DefCons _ t _ _) = t + +-- | Type check the abstract representation of a Tag Length Value +-- against an ASN.1 type definition. + +typeCheck :: TypeDefn -> Encoding -> IO (TypeDefn,Defaulted) + +typeCheck a b = + do ((q,r),_) <- runStateT (tc a b) [] + return (q,r) + +tc :: (MonadState [Maybe Encoding] m, MonadError e m) => + TypeDefn -> Encoding -> m (TypeDefn,Defaulted) + +tc a@(n ::= AbsBasePrim att atv at) b@(Primitive btt btv l bv) + | att /= btt = tagMismatch n att btt + | atv /= btv = tagValMismatch n atv btv + | not $ bv `compatibleWith` at = + fail ("Checking " ++ (show n) ++ ": " ++ + "type not compatible with values " ++ (show bv)) + | otherwise = return $ (a,DefPrim btt btv l bv) + +tc a@(n ::= AbsBasePrim att atv at) b@(Constructed btt btv _ bv) + = fail ("Checking " ++ (show n) ++ ": " ++ + "expected PRIMITIVE Tag found CONSTRUCTED Tag" ++ + "\n" ++ (show a) ++ "\n" ++ (show b)) + +-- See x.690 8.14.2 & 8.14.3 + +tc (n ::= AbsRef att atv atp at) b@(Primitive btt btv _ bv) + | atp == Explicit = + fail ("Checking " ++ (show n) ++ ": " ++ + "expected IMPLICIT Tag found PRIMITIVE type") + | att /= btt = tagMismatch n att btt + | atv /= btv = tagValMismatch n atv btv + | otherwise = tc a b + where a = modName n $ modTagType att $ modTagVal (Just atv) at + +tc a'@(n ::= AbsRef att atv atp at) b@(Constructed btt btv bl bvs) + | att /= btt = tagMismatch n att btt + | atv /= btv = tagValMismatch n atv btv + | otherwise = + case atp of + Implicit -> + tc a b + Explicit -> + if null bvs + then fail "unable to match empty value" + else do (w,x) <- tc at (bvs!!0) + let u = DefCons btt btv bl [Just x] + v = n ::= AbsRef att atv atp w + return $ (v,u) + where a = modName n $ modTagType att $ modTagVal (Just atv) at + +tc (n ::= AbsSeq _ _ _ _) (Primitive _ _ _ _) = + constructionMismatch n "SEQUENCE" "PRIMITIVE" + +tc a@(n ::= AbsSeq att atv atp as) b@(Constructed btt btv l bvs) + | att /= btt = tagMismatch n att btt + | atv /= btv = tagValMismatch n atv btv + | otherwise = + do ((tas,tbvs),s) <- runStateT (k as bvs) [] + return ((n ::= AbsSeq att atv atp tas),(DefCons btt btv l tbvs)) + +tc (n ::= AbsSeqOf _ _ _ _) (Primitive _ _ _ _) = + constructionMismatch n "SEQUENCE OF" "PRIMITIVE" + +tc a@(n ::= AbsSeqOf att atv Implicit td) b@(Constructed btt btv l bvs) + | att /= btt = tagMismatch n att btt + | atv /= btv = tagValMismatch n atv btv + | otherwise = do ds <- sequence $ zipWith tc (repeat td) bvs + let tbvs = map snd ds + ttd = if null ds then td else head $ map fst ds + return (n ::= AbsSeqOf att atv Implicit ttd,DefCons btt btv l (map Just tbvs)) + +tc (n ::= AbsSetOf _ _ _ _) (Primitive _ _ _ _) = + constructionMismatch n "SET OF" "PRIMITIVE" + +tc (n ::= AbsSetOf att atv Implicit td) (Constructed btt btv l bvs) + | att /= btt = tagMismatch n att btt + | atv /= btv = tagValMismatch n atv btv + | otherwise = do ds <- sequence $ zipWith tc (repeat td) bvs + let tbvs = map snd ds + ttd = if null ds then td else head $ map fst ds + return (n ::= AbsSetOf att atv Implicit ttd,DefCons btt btv l (map Just tbvs)) + +tc (n ::= AbsAnyDefBy i) b = + do s <- get + let t = reverse s + if ((t!!i) == Nothing) + then fail ("Checking " ++ (show n) ++ ": " ++ + "no optional value present in ANY DEFINED BY") + else do let (Just x) = t!!i + (_,y) <- tc absOID x + let u = (decode (getAbsType absOID) (Just y))::(Maybe OID) + (Just u') = u + v = Map.lookup u' oids + if v == Nothing + then fail ("Checking " ++ (show n) ++ ": " ++ + (show u) ++ " not supported") + else do let (Just w) = v + foo <- tc w b + return foo + +tc (n ::= AbsChoice tpnts) b = + foldr ignoreErr + (fail (choiceFailMsg n b)) + (map ((flip choiceAux) b) tpnts) + +ignoreErr :: MonadError e m => m a -> m a -> m a +ignoreErr m n = m `catchError` (\_ -> n) + +choiceFailMsg n b = + "Checking " ++ + (show n) ++ + ": " ++ + "no CHOICE alternative matches " ++ + (show b) + +choiceAux :: (MonadState [Maybe Encoding] m, MonadError e m) => + (TagPlicity,NamedType) -> Encoding -> m (TypeDefn,Defaulted) +-- TypeDefn -> Encoding -> m (TypeDefn,Defaulted) + +choiceAux (tp,nt) b = + do let (mn :>: (mt :@: td)) = nt + case mn of + Nothing -> + fail ("expected identifier " ++ + "(beginning with a lower-case letter): " ++ + "this identifier is mandatory since ASN.1:1994") + Just n -> + case tp of + Implicit -> + case mt of + Nothing -> + tc (modName n td) b + Just t -> + tc (modName n $ modTagType Context $ modTagVal mt td) b + Explicit -> + case mt of + Nothing -> + fail "tag expected before EXPLICIT" + Just t -> + tc (n ::= AbsRef Context t Explicit td) b + +k :: (MonadState [Maybe Encoding] m, MonadError e m) => + [ComponentType] -> [Encoding] -> + StateT [Maybe Encoding] m ([ComponentType],[Maybe Defaulted]) + +k [] [] = return ([],[]) + +k [] _ = return ([],[]) + +k ((a@(Regular _)):_) [] = + fail ("Checking " ++ (show a) ++ ": " ++ "insufficient components") + +k (a@(AnyDefBy n):as) [] = + fail ("Checking " ++ (show a) ++ ": " ++ "insufficient components") + +k a@(Optional _:_) [] = return (a,[Nothing]) + +k (Default _ _:_) [] = fail "To be fixed" + +k (Regular (mn :>: (tv :@: td)):as) (bv:bvs) = + do s <- get + let inner = + do put s + case tv of + Nothing -> + tc td bv + Just v -> + case mn of +-- 29/01/05 082427 Consider replacing Maybe String by String. +-- If there is no name then it's the empty String "". + Nothing -> + tc ("" ::= AbsRef Context v Implicit td) bv + Just name -> + tc (name ::= AbsRef Context v Implicit td) bv + (ttd,tbv) <- lift $ inner + let tct = Regular (mn :>: (tv :@: ttd)) + put (Just bv:s) + (tcts,tbvs) <- k as bvs + return (tct:tcts,(Just tbv):tbvs) + +k (a@(Optional (mn :>: (tv :@: td))):as) b@(bv:bvs) = +-- For the moment. We don't want to catch all errors. For example, +-- if we get an eof error then it should be propogated. + do s <- get + let inner = + do put s + case tv of + Nothing -> + tc td bv + Just v -> + case mn of +-- 29/01/05 082427 Consider replacing Maybe String by String. +-- If there is no name then it's the empty String "". + Nothing -> + tc ("" ::= AbsRef Context v Implicit td) bv + Just name -> + tc (name ::= AbsRef Context v Implicit td) bv + maybeOption <- + (do foo <- lift $ inner + return (Just foo)) `catchError` + (\_ -> return Nothing) + case maybeOption of + Nothing -> + do put (Nothing:s) + (tcts,tbvs) <- k as b + return (a:tcts,Nothing:tbvs) + Just (ttd,tbv) -> + do s <- get + put (Just bv:s) + (tcts,tbvs) <- k as bvs + let tct = Optional (mn :>: (tv :@: ttd)) + return (tct:tcts,(Just tbv):tbvs) + +k (a@(Default (mn :>: (tv :@: td)) _):as) b@(bv:bvs) = +-- For the moment. We don't want to catch all errors. For example, +-- if we get an eof error then it should be propogated. + do s <- get + let inner = + do put s + case tv of + Nothing -> + tc td bv + Just v -> + case mn of +-- 29/01/05 082427 Consider replacing Maybe String by String. +-- If there is no name then it's the empty String "". + Nothing -> + tc ("" ::= AbsRef Context v Implicit td) bv + Just name -> + tc (name ::= AbsRef Context v Implicit td) bv + maybeOption <- + (do foo <- lift $ inner + return (Just foo)) `catchError` + (\_ -> return Nothing) + case maybeOption of + Nothing -> + do put (Nothing:s) -- This is wrong. We should insert the default. + (tcts,tbvs) <- k as b + return (a:tcts,Nothing:tbvs) + Just (ttd,tbv) -> + do s <- get + put (Just bv:s) + (tcts,tbvs) <- k as bvs + let tct = Optional (mn :>: (tv :@: ttd)) + return (tct:tcts,(Just tbv):tbvs) + +k ((AnyDefBy n):as) (bv:bvs) = + do s <- get + if ((s!!n) == Nothing) + then fail ("Checking " ++ (show n) ++ ": " ++ + "no optional value present in ANY DEFINED BY") + else do let (Just x) = (reverse s)!!n + (_,y) <- lift $ tc absOID x + let u = decode (getAbsType absOID) (Just y) + (Just u') = u + v = Map.lookup u' oids + if v == Nothing + then fail ("Checking " ++ (show n) ++ ": " ++ + (show u) ++ " not supported") + else do let (Just w) = v + (ttd,tbv) <- lift $ tc w bv + s <- get + put (Just bv:s) + (tcts,tbvs) <- k as bvs + -- We didn't capture all the relevant + -- information in the AnyDefBy constructor + -- so this is all we can do for the moment. + let tct = Regular (Nothing :>: (Nothing :@: ttd)) + return (tct:tcts,(Just tbv):tbvs) + +compatibleWith :: PrimitiveValue -> AbsPrimType -> Bool +compatibleWith pv AbsVisibleString = + all (flip elem visibleOctets) pv +compatibleWith pv AbsPrintableString = + all (flip elem printableOctets) pv +compatibleWith pv AbsIA5String = + all (flip elem ia5Octets) pv +compatibleWith pv AbsBool = + length pv == 1 +compatibleWith pv AbsInteger = + if length pv > 1 + then not ((pv!!0 == 0xff && (testBit (pv!!1) msb)) || + (pv!!0 == 0x00 && (not (testBit (pv!!1) msb)))) + else length pv == 1 +compatibleWith pv AbsOID = not $ null pv +compatibleWith pv AbsOctetString = True +compatibleWith pv AbsBitString = True +compatibleWith pv AbsNull = null pv + +ia5Octets :: [Octet] +ia5Octets = [0..127] + +visibleOctets :: [Octet] +visibleOctets = map fromIntegral [ord ' '..ord '~'] + +printableOctets :: [Octet] +printableOctets = + map (fromIntegral . ord) printableString + +printableString = + ['A'..'Z'] ++ + ['0'..'9'] ++ + [' '] ++ + ['a'..'z'] ++ + ['\''] ++ + ['('] ++ + [')'] ++ + ['+'] ++ + [','] ++ + ['-'] ++ + ['.'] ++ + ['/'] ++ + [':'] ++ + ['='] ++ + ['?'] + +tagMismatch n a b = + fail ("Checking " ++ (show n) ++ ": " ++ + "expected tag type " ++ (show a) ++ " " ++ + "found tag type " ++ (show b)) + +tagValMismatch n a b = + fail ("Checking " ++ (show n) ++ ": " ++ + "expected tag value " ++ (show a) ++ " " ++ + "found tag value " ++ (show b)) + +constructionMismatch n sa sb = + fail ("Checking " ++ (show n) ++ ": " ++ + "unable to match " ++ sa ++ " with " ++ sb) + +decodeMismatch a b = + fail ("Panic: unable to decode " ++ (show b) ++ " with " ++ (show a)) + +class Encode a where + decode :: AbstractType -> Maybe Defaulted -> Maybe a + +instance Encode VisibleString where + decode a{-@(AbsBasePrim _ _ AbsVisibleString)-} b = + case a of + AbsBasePrim _ _ AbsVisibleString -> + do x <- b + case x of + DefPrim _ _ _ bv -> + return $ VisibleString $ map (chr . fromIntegral) bv + _ -> + decodeMismatch a b + _ -> + error (show a) + +instance Encode PrintableString where + decode a@(AbsBasePrim _ _ AbsPrintableString) b = + do x <- b + case x of + DefPrim _ _ _ bv -> + return $ PrintableString $ map (chr . fromIntegral) bv + _ -> + decodeMismatch a b + +instance Encode IA5String where + decode a@(AbsBasePrim _ _ AbsIA5String) b = + do x <- b + case x of + DefPrim _ _ _ bv -> + return $ IA5String $ map (chr . fromIntegral) bv + _ -> + decodeMismatch a b + +instance Encode DirectoryString where + decode a@(AbsBasePrim _ _ AbsIA5String) b = + do x <- decode a b + return (IA x) + decode a@(AbsBasePrim _ _ AbsPrintableString) b = + do x <- decode a b + return (PS x) + decode a@(AbsBasePrim _ _ AbsVisibleString) b = + do x <- decode a b + return (VS x) + +instance Encode Bool where + decode a@(AbsBasePrim _ _ AbsBool) b = + do x <- b + case x of + DefPrim _ _ _ bv -> + case bv of + [0x00] -> return False + otherwise -> return True + _ -> + decodeMismatch a b + +instance Encode Integer where + decode a@(AbsBasePrim _ _ AbsInteger) b = + do x <- b + case x of + DefPrim _ _ _ bv -> + return (fromTwosComp bv) + _ -> + decodeMismatch a b + +instance Encode OctetString where + decode a@(AbsBasePrim _ _ AbsOctetString) b = + do x <- b + case x of + DefPrim _ _ _ bv -> + return $ OctetString bv + _ -> + decodeMismatch a b + +instance Encode BitString where + decode a@(AbsBasePrim _ _ AbsBitString) b = + do x <- b + case x of + DefPrim _ _ _ bv -> + return $ BitString (tail bv) +-- For now. Typechecking will have to ensure this is valid. + _ -> + decodeMismatch a b + +instance Encode a => Encode (SetOf a) where + decode a b = + do d <- b + let bs = encodedDefComps d + cs <- f a' bs + return $ SetOf cs + where a' = absSetOfType a + f x ys = + case ys of + [] -> + return $ [] + (z:zs) -> + do u <- decode x z + us <- f x zs + return $ (u:us) + +instance Encode a => Encode [a] where + decode a b = + do d <- b + let bs = encodedDefComps d + cs <- f a' bs + return cs + where a' = absSeqOfType a + f x ys = + case ys of + [] -> + return $ [] + (z:zs) -> + do u <- decode x z + us <- f x zs + return $ (u:us) + +instance Encode OID where + decode a@(AbsBasePrim _ _ AbsOID) b = + do x <- b + case x of + DefPrim _ _ _ bv -> + return $ decodeOIDAux bv + _ -> + decodeMismatch a b + +decodeOIDAux (x:xs) = + OID $ ((fromIntegral x) `div` 40):((fromIntegral x) `mod` 40):ys + where + ys = map fromIntegral $ + map (fromOctets (2^oidBitsPerOctet)) $ + (map . map) (flip clearBit oidBitsPerOctet) (subIds xs) + subIds :: [Octet] -> [[Octet]] + subIds = unfoldr getSubId + getSubId :: [Octet] -> Maybe ([Octet], [Octet]) + getSubId [] = Nothing + getSubId xs = Just $ span' endOfSubId xs + endOfSubId = not . (flip testBit oidBitsPerOctet) + +oidBitsPerOctet = 7 :: Int + +span' :: (a -> Bool) -> [a] -> ([a],[a]) +span' p [] + = ([],[]) +span' p xs@(x:xs') + | p x = ([x],xs') + | otherwise = (x:ys,zs) + where (ys,zs) = span' p xs' + +replaceRef :: AbstractType -> + [AbstractType] -> + [Maybe Defaulted] -> + AbstractType +replaceRef a as bs = + case a of + AbsAnyDefBy n -> u + where + oidat = decode (as!!n) (bs!!n) + (Just oidat') = oidat + t = Map.lookup oidat' oids + (Just (_ ::= u)) = t + _ -> a diff --git a/Language/ASN1/InformationFramework.hs b/Language/ASN1/InformationFramework.hs new file mode 100644 --- /dev/null +++ b/Language/ASN1/InformationFramework.hs @@ -0,0 +1,155 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.ASN1.InformationFramework +-- Copyright : (c) Dominic Steinitz 2006 +-- License : BSD3 +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- Definitions to allow the typechecking of (BER) encodings of definitions from +-- InformationFramework {joint-iso-itu-t(2) ds(5) module(1) informationFramework(1) 3} +-- and +-- functions to extract information from encodings of them. +-- +-- See +-- +----------------------------------------------------------------------------- + +module Language.ASN1.InformationFramework ( +-- * Type declarations + GeneralName(..), + GeneralNames(..), + Name(..), + RDNSequence(..), +-- * Function declarations + generalName, + generalNames, + name, + rdnSequence, + unRDNSequence + ) where + +import Language.ASN1 +import Language.ASN1.BER +import Language.ASN1.X509 ( + relativeDistinguishedName, + RelativeDistinguishedName + ) + +{- +GeneralNames ::= SEQUENCE SIZE (1..MAX) OF GeneralName + +GeneralName ::= CHOICE { + otherName [0] INSTANCE OF OTHER-NAME, + rfc822Name [1] IA5String, + dNSName [2] IA5String, + x400Address [3] ORAddress, + directoryName [4] Name, + ediPartyName [5] EDIPartyName, + uniformResourceIdentifier [6] IA5String, + iPAddress [7] OCTET STRING, + registeredID [8] OBJECT IDENTIFIER + } + +-- naming data types +Name ::= CHOICE { + -- only one possibility for now + rdnSequence RDNSequence + } + +RDNSequence ::= SEQUENCE OF RelativeDistinguishedName +-} + +generalName :: TypeDefn +generalName = + "GeneralName" ::= + AbsChoice [ +-- (Explicit, Just "otherName" :>: [0] INSTANCE OF OTHER-NAME), + (Explicit, Just "rfc822Name" :>: (Just 1 :@: absIA5String)), + (Explicit, Just "dNSName" :>: (Just 2 :@: absIA5String)), +-- (Explicit, Just "x400Address" :>: [3] ORAddress), + (Explicit, Just "directoryName" :>: (Just 4 :@: name)), +-- (Explicit, Just "ediPartyName" :>: [5] :@: EDIPartyName), + (Explicit, Just "uniformResourceIdentifier" :>: + (Just 6 :@: absIA5String)), + (Explicit, Just "iPAddress" :>: (Just 7 :@: absOctetString)), + (Explicit, Just "registeredID" :>: (Just 8 :@: absOID)) + ] + +data GeneralName = + Rfc822Name IA5String | + DNSName IA5String | + DirectoryName Name | + UnifromResourceIdentifier IA5String | + IPAddress OctetString | + RegisteredID OID + deriving (Eq,Show) + +instance Encode GeneralName where + decode a b = + do x <- b + let t = defaultedTagValue x + bs = encodedDefComps x + a' = absRefedType a + b' = (encodedDefComps x)!! 0 + case t of + 1 -> do foo <- decode a' b' + return $ Rfc822Name foo + 2 -> do foo <- decode a' b' + return $ DNSName foo + 4 -> do foo <- decode a' b' + return $ DirectoryName foo + 6 -> do foo <- decode a' b' + return $ UnifromResourceIdentifier foo + 7 -> do foo <- decode a' b' + return $ IPAddress foo + 8 -> do foo <- decode a' b' + return $ RegisteredID foo + +generalNames :: TypeDefn +generalNames = + "GeneralNames" ::= + AbsSeqOf Universal 16 Implicit generalName + +data GeneralNames = GeneralNames [GeneralName] + deriving (Eq,Show) + +instance Encode GeneralNames where + decode a b = + do x <- decode a b + return (GeneralNames x) + +name :: TypeDefn +name = + "Name" ::= + AbsChoice [(Implicit,Just "rdnSequence" :>: (Nothing :@: rdnSequence))] + +data Name= Name RDNSequence + deriving (Eq,Show) + +instance Encode Name where + decode a b = + do x <- b + let t = defaultedTagValue x + case t of + 16 -> do foo <- decode a b + return $ Name foo + +rdnSequence :: TypeDefn +rdnSequence = + "RDNSequence" ::= + AbsSeqOf Universal 16 Implicit relativeDistinguishedName + +data RDNSequence = RDNSequence [RelativeDistinguishedName] + deriving (Eq,Show) + +unRDNSequence :: RDNSequence -> [RelativeDistinguishedName] +unRDNSequence (RDNSequence x) = x + +instance Encode RDNSequence where + decode a b = + do x <- decode a b + return (RDNSequence x) + diff --git a/Language/ASN1/PKCS1v15.hs b/Language/ASN1/PKCS1v15.hs new file mode 100644 --- /dev/null +++ b/Language/ASN1/PKCS1v15.hs @@ -0,0 +1,103 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.ASN1.PKCS1v15 +-- Copyright : (c) Dominic Steinitz 2005 - 2007 +-- License : BSD3 +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : portable +-- +-- Functions and types to allow the encoding and decoding of the +-- RSA PKCS1v1.5 +-- signature scheme. See +-- ( and +-- ) for +-- further information. +----------------------------------------------------------------------------- + +module Language.ASN1.PKCS1v15( + -- * Type Declarations + DigestInfo(..), + DigestAlgorithm, + -- * Function Declarations + encode, + decode, + digestInfo, + digestAlgorithm + ) where + +import Data.Maybe +-- import Codec.Utils (Octet) +import Data.Word +import Language.ASN1 +import qualified Language.ASN1.BER as BER +import Language.ASN1.X509 (algorithmIdentifier,AlgorithmIdentifier) + +type Octet = Word8 + +-- | Not yet implemented. + +encode :: [Octet] -> [Octet] + +encode xs = error "tbd" + +-- | Take an encoded message and return the decoded message provided all the +-- conditions in the specification are met. + +decode :: [Octet] -> Maybe [Octet] +decode encoded = + if decodeError + then Nothing + else (Just m) + where + (x0,t0) = splitAt 1 encoded + (x1,t1) = splitAt 1 t0 + (ps,t2) = span (==0xff) t1 + (x3,m) = splitAt 1 t2 + decodeError = + and [ + x0 /= [0x00], + x1 /= [0x02], + x3 /= [0x00], + length ps < 8 + ] + +{- +DigestInfo ::= SEQUENCE { + digestAlgorithm DigestAlgorithm, + digest OCTET STRING +} +-} + +digestInfo = + "DigestInfo" ::= + AbsSeq Universal 16 Implicit [ + Regular (Just "digestAlgorithm" :>: (Nothing :@: + digestAlgorithm)), + Regular (Just "digest" :>: (Nothing :@: + absOctetString)) + ] + +data DigestInfo = + DigestInfo { + digestAlgorithm1 :: DigestAlgorithm, + digest :: OctetString + } + deriving (Eq,Show) + +instance BER.Encode DigestInfo where + decode a b = + do x <- b + let as = absSeqComponents a + bs = BER.encodedDefComps x + return $ + DigestInfo { + digestAlgorithm1 = fromJust $ BER.decode (as!!0) (bs!!0), + digest = fromJust $ BER.decode (as!!1) (bs!!1) + } + +digestAlgorithm = + modName "DigestAlgorithm" algorithmIdentifier + +type DigestAlgorithm = AlgorithmIdentifier diff --git a/Language/ASN1/PKCS8.hs b/Language/ASN1/PKCS8.hs new file mode 100644 --- /dev/null +++ b/Language/ASN1/PKCS8.hs @@ -0,0 +1,265 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.ASN1.PKCS8 +-- Copyright : (c) Dominic Steinitz 2003 - 2007 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- Definitions to allow the typechecking of a PKCS8 private key and +-- functions to extract information from it. +-- +-- See . +-- +----------------------------------------------------------------------------- + +module Language.ASN1.PKCS8 ( +-- * Type declarations + RSAPrivateKey(..), + PrivateKeyInfo(..), +-- * Function declarations + rsaPrivateKey, + privateKeyInfo + ) where + +import Data.Maybe +import Language.ASN1 +import Language.ASN1.BER +import Language.ASN1.X509 ( + algorithmIdentifier, + AlgorithmIdentifier, + attributeTypeAndValue, + AttributeTypeAndValue + ) + +{- +See http://www.zvon.org/tmRFC/RFC3447/Output/index.html 10.1.2. A.1.2 +RSA private key syntax: + +RSAPrivateKey ::= SEQUENCE { + version Version, + modulus INTEGER, -- n + publicExponent INTEGER, -- e + privateExponent INTEGER, -- d + prime1 INTEGER, -- p + prime2 INTEGER, -- q + exponent1 INTEGER, -- d mod (p-1) + exponent2 INTEGER, -- d mod (q-1) + coefficient INTEGER, -- (inverse of q) mod p + otherPrimeInfos OtherPrimeInfos OPTIONAL + } +-} + +rsaPrivateKey :: TypeDefn +rsaPrivateKey = + "RSAPrivateKey" ::= + AbsSeq Universal 16 Implicit + [Regular (Just "version" :>: (Nothing :@: version)), + Regular (Just "modulus" :>: (Nothing :@: absInteger)), + Regular (Just "publicExponent" :>: (Nothing :@: absInteger)), + Regular (Just "privateExponent" :>: (Nothing :@: absInteger)), + Regular (Just "prime1" :>: (Nothing :@: absInteger)), + Regular (Just "prime2" :>: (Nothing :@: absInteger)), + Regular (Just "exponent1" :>: (Nothing :@: absInteger)), + Regular (Just "exponent2" :>: (Nothing :@: absInteger)), + Regular (Just "coefficient" :>: (Nothing :@: absInteger))] + +data RSAPrivateKey = + RSAPrivateKey { + version1 :: Integer, + modulus :: Integer, -- n + publicExponent :: Integer, -- e + privateExponent :: Integer, -- d + prime1 :: Integer, -- p + prime2 :: Integer, -- q + exponent1 :: Integer, -- d mod (p-1) + exponent2 :: Integer, -- d mod (q-1) + coefficient :: Integer -- (inverse of q) mod p + } + deriving Show + +instance Encode RSAPrivateKey where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + as' = map (\x -> replaceRef x as bs) as + version = fromJust $ decode (as'!!0) (bs!!0) + modulus = fromJust $ decode (as'!!1) (bs!!1) + publicExponent = fromJust $ decode (as'!!2) (bs!!2) + privateExponent = fromJust $ decode (as'!!3) (bs!!3) + prime1 = fromJust $ decode (as'!!4) (bs!!4) + prime2 = fromJust $ decode (as'!!5) (bs!!5) + exponent1 = fromJust $ decode (as'!!6) (bs!!6) + exponent2 = fromJust $ decode (as'!!7) (bs!!7) + coefficient = fromJust $ decode (as'!!8) (bs!!8) + return $ + RSAPrivateKey { + version1 = version, + modulus = modulus, + publicExponent = publicExponent, + privateExponent = privateExponent, + prime1 = prime1, + prime2 = prime2, + exponent1 = exponent1, + exponent2 = exponent2, + coefficient = coefficient} + +version = modName "Version" absInteger + +type Version = Integer + +{- +PrivateKey ::= OCTET STRING +-} + +privateKey = modName "PrivateKey" absOctetString + +type PrivateKey = OctetString + +{- +Attributes ::= SET OF Attribute +-} + +attributes = + "Attributes" ::= AbsSetOf Universal 16 Implicit attributeTypeAndValue + +type Attributes = SetOf AttributeTypeAndValue + +{- +PrivateKeyInfo ::= SEQUENCE { + version Version, + privateKeyAlgorithm AlgorithmIdentifier {{PrivateKeyAlgorithms}}, + privateKey PrivateKey, + attributes [0] Attributes OPTIONAL + } +-} + +privateKeyInfo :: TypeDefn +privateKeyInfo = + "privateKeyInfo" ::= + AbsSeq Universal 16 Implicit [ + Regular (Just "version" :>: (Nothing :@: version)), + Regular ( + Just "privateKeyAlgorithm" :>: (Nothing :@: algorithmIdentifier) + ), + Regular (Just "privateKey" :>: (Nothing :@: privateKey)), + Optional (Just "attributes" :>: (Nothing :@: attributes)) + ] + +data PrivateKeyInfo = + PrivateKeyInfo { + version2 :: Version, + privateKeyAlgorithm :: AlgorithmIdentifier, + privateKey1 :: PrivateKey, + attributes1 :: Maybe Attributes + } + deriving Show + +instance Encode PrivateKeyInfo where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + as' = map (\x -> replaceRef x as bs) as + version = fromJust $ decode (as'!!0) (bs!!0) + privateKeyAlgorithm = fromJust $ decode (as'!!1) (bs!!1) + privateKey = fromJust $ decode (as'!!2) (bs!!2) + attributes = decode (as'!!3) (bs!!3) + return $ + PrivateKeyInfo { + version2 = version, + privateKeyAlgorithm = privateKeyAlgorithm, + privateKey1 = privateKey, + attributes1 = attributes + } + +{- +type Algorithm = OID + +-- | This will do for now. DSA has some parameters which are more complicated +-- than this but since we plan to do RSA initially and this has NULL parameters +-- then anything will do to get us going. + +type Parameters = Int + +-- | The parameters will only ever be Nothing as this implementation +-- only supports RSA and this has no parameters. So even if the parameters +-- are non-NULL, fromASN will not fail but will ignore them. + +data AlgorithmIdentifier = + MkAlgorithmIdentifier { + algorithm :: Algorithm, + parameters :: Maybe Parameters } + deriving Show + +data PrivateKeyInfo = + MkPrivateKeyInfo { + version1 :: Version, + privateKeyAlgorithm :: AlgorithmIdentifier, + privateKey :: RSAPrivateKey } + deriving Show + +{- +We are "overloading" Version. It is defined in + +ftp://ftp.rsasecurity.com/pub/pkcs/pkcs-8/pkcs-8v1_2.asn: + +Version ::= INTEGER {v1(0)} (v1,...) + +and also in + +http://www.zvon.org/tmRFC/RFC3447/Output/index.html 10.1.2: + +Version ::= INTEGER { two-prime(0), multi(1) } + +although for the latter +definition we represent two-prime in Haskell as V1 and do not support +multi. +-} + +{- +We assume: + +Algorithm ::= OID + +although the situation is far more complicated. +See http://www.zvon.org/tmRFC/RFC2898/Output/chapter12.html. +-} + +algorithm = modName "Algorithm" absOID + +type Algorithm = OID + +{- +We assume: + +Parameters ::= NULL + +although the situation is far more complicated. +See http://www.zvon.org/tmRFC/RFC2898/Output/chapter12.html. +-} + +parameters = modName "Parameters" absNull + +type Parameters = NULL + +{- +See http://www.itu.int/ITU-T/asn1/database/itu-t/x/x509/1997/AuthenticationFramework.html#AuthenticationFramework.AlgorithmIdentifier. + +For now, the parameters will only ever be Nothing as this implementation +only supports RSA and this has no parameters. If the parameters +are non-NULL, we will report an error. + +See http://www.zvon.org/tmRFC/RFC3447/Output/index.html 10.1. A.1 RSA key representation: + +"The parameters field associated with this OID in a value of type AlgorithmIdentifier shall have a value of type NULL" +-} + +{- +See ftp://ftp.rsasecurity.com/pub/pkcs/pkcs-8/pkcs-8v1_2.asn. +-} + +-} diff --git a/Language/ASN1/Raw.hs b/Language/ASN1/Raw.hs new file mode 100644 --- /dev/null +++ b/Language/ASN1/Raw.hs @@ -0,0 +1,49 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.ASN1.Raw +-- Copyright : (c) Dominic Steinitz 2007 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : portable +-- +----------------------------------------------------------------------------- + +module Language.ASN1.Raw( + hexdump, + hexdumpBy, + ) where + +import Data.List +import Language.ASN1.Utils +import Numeric +import Text.PrettyPrint + +split :: Int -> [a] -> [[a]] +split n xs = unfoldr (g n) xs + +g :: Int -> [a] -> Maybe ([a],[a]) +g n [] = Nothing +g n y = Just (splitAt n y) + +sh x | x < 16 = '0':(showHex x "") + | otherwise = showHex x "" + +type OctetsPerLine = Int + +hexdump :: OctetsPerLine -> [Octet] -> Doc +hexdump n = + vcat . + map hcat . + map (intersperse colon) . + map (map (text . sh)) . + split n + +hexdumpBy :: String -> OctetsPerLine -> [Octet] -> Doc +hexdumpBy s n = + vcat . + map hcat . + map (intersperse (text s)) . + map (map (text . sh)) . + split n diff --git a/Language/ASN1/TLV.hs b/Language/ASN1/TLV.hs new file mode 100644 --- /dev/null +++ b/Language/ASN1/TLV.hs @@ -0,0 +1,185 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.ASN1.TLV +-- Copyright : (c) Dominic Steinitz 2005 - 2007 +-- License : BSD3 +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : portable +-- +-- Decode binary BER into abstract an abstract representation of tag, +-- length and value ensuring that the lengths are consistent. +-- +----------------------------------------------------------------------------- + +module Language.ASN1.TLV ( + -- * Types + + -- * Function types, + tlv, + tlvIO + ) where +import Data.Bits +import Control.Exception +import Control.Monad.State +import Control.Monad.Error +import System.IO.Error +import qualified NewBinary.Binary as B (BinHandle, getBits, getByte) +import Language.ASN1.BER +import Language.ASN1.Utils + +-- The bit decoder will (by design) never lie about lengths +-- because it can check these. It may lie (if that's what it's being +-- told) about numbers of components because it can't check these +-- without having the ASN.1 definitions. + +{- +041120 125723 +When interpreting the bits into tag-length-value form, +remember to keep track of where things are. + +041120 161608 +We'll need isEOFBin or to catch exceptions. + +041121 151059 +As decoding to tag length value is monadic and then so it +decoding to the ASN.1 at some point we'll need to interleave +actions. + +080105 082425 +tlv should report an error if there are any Octets left over. +-} + +tlv :: [Octet] -> (Length,Encoding) +tlv xs = let ((l,e),_) = runState (tlv_ undefined) (xs,0::Offset) in (l,e) + +tlvIO :: BinHandle -> IO (Length, Encoding) +tlvIO = tlv_ + +tlv_ bin = + do tagValueVal <- getBits bin 5 + tagConstructionVal <- getBits bin 1 + tagTypeVal <- getBits bin 2 + let tagType = toEnum $ fromIntegral tagTypeVal + tagValue = fromIntegral tagValueVal + if tagValue /= 31 + then do (ll,l) <- getLength bin + f 1 tagConstructionVal + tagType tagValue ll l + else do xs <- getTagOctets bin + let longform = + fromIntegral (fromOctets 128 xs) + (ll,l) <- getLength bin + f (fromIntegral $ length xs) tagConstructionVal + tagType longform ll l + where f tl tcv tt tv ll l = + if tcv == 0 + then do xs <- getOctets bin l + let x = Primitive tt tv l xs + return (tl+ll+l,x) + else do ys <- tlvs_ bin l + let x = Constructed tt tv l ys + return (tl+ll+l,x) + +tlvs_ bin curLen + | curLen < 0 = fail "Codec.ASN1.TLV.tlvs_: trying to decode a negative number of octets" + | curLen == 0 = return [] + | otherwise = do (l,x) <- tlv_ bin + ys <- tlvs_ bin (curLen-l) + return (x:ys) + +getTagOctets bin = + do x <- getByte bin + if not (testBit x msb) + then return [x] + else do xs <- getTagOctets bin + return ((clearBit x msb):xs) + +-- Need to think about testing. Here are some links: + +-- http://www.eeye.com/html/Research/Advisories/AD20040210.html +-- http://www.galois.com/files/HCSS-04-ASN.1.pdf +-- http://www.larmouth.demon.co.uk/tutorials/tagging/sld003.htm + + +getLength bin = + do x <- getByte bin + let isShort = not (testBit x msb) + shortform = fromIntegral x + length = fromIntegral (clearBit x msb) in + if x == 0x80 + then error "Indefinite length not supported" + else if isShort + then return (1,shortform) + else do xs <- getOctets bin length + let longform = fromOctets 256 xs in + return (length+1,longform) + +getOctets bin l = + if l <= 0 + then return [] + else do x <- getByte bin + xs <- getOctets bin (l-1) + return (x:xs) + +type BinHandle = B.BinHandle + +type NumBits = Int + +class Binary m where + getBits :: BinHandle -> NumBits -> m Octet + getByte :: BinHandle -> m Octet + +instance Binary IO where + getBits = B.getBits + getByte = B.getByte + +type Offset = Int + +instance Binary (State ([Octet],Offset)) where + getBits = getBits' + getByte = getByte' + +{- +getBits is never exported and does not need to be general. We know +we will only ever use it at an Octet boundary and we will never cross +an Octet boundary. +-} + +getBits' :: MonadState ([Octet],Offset) m => BinHandle -> NumBits -> m Octet +getBits' _ n = + do (xs,offset) <- get + if null xs + then throw (IOException $ + mkIOError eofErrorType + "Codec.ASN1.TLV.getBits" + Nothing Nothing) + else do let r = select offset n (head xs) + m = bitSize r + if offset + n < m + then put (xs,offset + n) + else put (tail xs,0) + return r + +select :: Offset -> NumBits -> Octet -> Octet +select offset n x = + clearBits n p $ shiftR x offset + where p = bitSize n + +clearBits :: Bits a => Int -> Int -> a -> a +clearBits = bits clearBit + +bits :: Enum b => (a -> b -> a) -> b -> b -> a -> a +bits f m n = foldr (.) id (map (\i -> flip f i) [m..n]) + +getByte' :: MonadState ([Octet],Offset) m => BinHandle -> m Octet +getByte' _ = + do (xs,offset) <- get + if null xs + then throw (IOException $ + mkIOError eofErrorType + "Codec.ASN1.TLV.getByte" + Nothing Nothing) + else do put (tail xs,offset) + return (head xs) diff --git a/Language/ASN1/Utils.hs b/Language/ASN1/Utils.hs new file mode 100644 --- /dev/null +++ b/Language/ASN1/Utils.hs @@ -0,0 +1,103 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.ASN1.Utils +-- Copyright : (c) Dominic Steinitz 2007 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : portable +-- +-- Utilities for coding and decoding. +-- +----------------------------------------------------------------------------- + +module Language.ASN1.Utils ( + -- * Types and Constants + Octet, + msb, + -- * Octet Conversion Functions + fromTwosComp, toTwosComp, + toOctets, fromOctets, + i2osp + ) where + +import Data.Word +import Data.Bits + +powersOf n = 1 : (map (*n) (powersOf n)) + +toBase x = + map fromIntegral . + reverse . + map (flip mod x) . + takeWhile (/=0) . + iterate (flip div x) + +-- | Take a number a convert it to base n as a list of octets. + +toOctets :: (Integral a, Integral b) => a -> b -> [Octet] +toOctets n x = (toBase n . fromIntegral) x + +-- | The basic type for encoding and decoding. + +type Octet = Word8 + +-- | The most significant bit of an 'Octet'. + +msb :: Int +msb = bitSize (undefined::Octet) - 1 + +-- | Take a list of octets (a number expressed in base n) and convert it +-- to a number. + +fromOctets :: (Integral a, Integral b) => a -> [Octet] -> b +fromOctets n x = + fromIntegral $ + sum $ + zipWith (*) (powersOf n) (reverse (map fromIntegral x)) + +-- | Take the length of the required number of octets and convert the +-- number to base 256 padding it out to the required length. If the +-- required length is less than the number of octets of the converted +-- number then return the converted number. NB this is different from +-- the standard +-- but mimics how replicate behaves. + +i2osp :: Integral a => Int -> a -> [Octet] +i2osp l y = + pad ++ z + where + pad = replicate (l - unPaddedLen) (0x00::Octet) + z = toOctets 256 y + unPaddedLen = length z + +-- | Convert from twos complement. + +fromTwosComp :: Integral a => [Octet] -> a +fromTwosComp x = conv x + where conv [] = 0 + conv w@(x:xs) = if (testBit x msb) + then neg w + else pos w + neg w@(x:xs) = let z=(clearBit x msb):xs in + fromIntegral((fromOctets 256 z)- + (128*(256^((length w)-1)))) + pos w = fromIntegral(fromOctets 256 w) + +toTwosComp :: Integral a => a -> [Octet] +toTwosComp x + | x < 0 = reverse . plusOne . reverse . (map complement) $ u + | x == 0 = [0x00] + | otherwise = u + where z@(y:ys) = toBase 256 (abs x) + u = if testBit y msb + then 0x00:z + else z + +plusOne :: [Octet] -> [Octet] +plusOne [] = [1] +plusOne (x:xs) = + if x == 0xff + then 0x00:(plusOne xs) + else (x+1):xs diff --git a/Language/ASN1/X509.hs b/Language/ASN1/X509.hs new file mode 100644 --- /dev/null +++ b/Language/ASN1/X509.hs @@ -0,0 +1,465 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.ASN1.X509 +-- Copyright : (c) Dominic Steinitz 2005 - 2007 +-- License : BSD3 +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : portable +-- +-- Definitions to allow the typechecking of an X.509 +-- certificate and functions to extract information from it. +-- +----------------------------------------------------------------------------- + +module Language.ASN1.X509 ( + -- * Types + Certificate(..), + SignedCertificate(..), + SubjectPublicKeyInfo(..), + RSAPublicKey(..), + AlgorithmIdentifier(..), + AttributeTypeAndValue(..), + RelativeDistinguishedName(..), + CertificateVersion, + -- * Type classes + -- * Function types + time, + validity, + attributeTypeAndValue, + relativeDistinguishedName, + algorithmIdentifier, + signedCertificate, + rsaPublicKey, + certificate, + certificate', +-- certificateVersion, +-- algorithm1, +-- parameters1, +-- validity1, + notBefore, + notAfter, +-- type1, +-- value, + unName, + unTime, + unRelativeDistinguishedName +) where +import System.Time +import Data.Maybe +import Language.ASN1.BER +import Language.ASN1 + +{- +CertificateSerialNumber ::= INTEGER +-} + +certificateSerialNumber = modName "CertificateSerialNumber" absInteger + +type CertificateSerialNumber = Integer + +{- +AttributeTypeAndValue ::= + SEQUENCE { + type OBJECT IDENTIFIER, + value ANY DEFINED by type + } +-} + +attributeTypeAndValue :: TypeDefn +attributeTypeAndValue = + "AttributeTypeAndValue" ::= + AbsSeq Universal 16 Implicit + [Regular (Just "type" :>: (Nothing :@: absOID)), + AnyDefBy 0] + +data AttributeTypeAndValue = + AttributeTypeAndValue { type1 :: OID, + value :: DirectoryString} + deriving (Eq,Show) + +instance Encode AttributeTypeAndValue where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + AttributeTypeAndValue { + type1 = fromJust $ decode (as!!0) (bs!!0), + value = fromJust $ decode (as!!1) (bs!!1) + } + +{- +RelativeDistinguishedName ::= + SET OF AttributeTypeAndValue +-} + +relativeDistinguishedName :: TypeDefn +relativeDistinguishedName = + "RelativeDistinguishedName" ::= + AbsSetOf Universal 17 Implicit attributeTypeAndValue + +data RelativeDistinguishedName = + RelativeDistinguishedName (SetOf AttributeTypeAndValue) + deriving (Eq,Show) + +unRelativeDistinguishedName :: + RelativeDistinguishedName -> SetOf AttributeTypeAndValue +unRelativeDistinguishedName (RelativeDistinguishedName x) = x + +instance Encode RelativeDistinguishedName where + decode a b = + do x <- decode a b + return (RelativeDistinguishedName x) + +{- +Name ::= SEQUENCE OF RelativeDistnguishedName +-} + +name = + "Name" ::= + AbsSeqOf Universal 16 Implicit relativeDistinguishedName + +data Name = Name [RelativeDistinguishedName] + deriving (Eq,Show) + +unName :: Name -> [RelativeDistinguishedName] +unName (Name x) = x + +instance Encode Name where + decode a b = + do x <- decode a b + return (Name x) + +{- +Validity ::= + SEQUENCE {notBefore Time, + notAfter Time + } +-} + +validity :: TypeDefn +validity = + "Validity" ::= + AbsSeq Universal 16 Implicit + [Regular (Just "notBefore" :>: (Nothing :@: time)), + Regular (Just "notAfter" :>: (Nothing :@: time))] + +data Validity = + Validity { + notBefore :: Time, -- CalendarTime + notAfter :: Time -- CalendarTime + } + deriving (Eq,Show) + +instance Encode Validity where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + Validity { + notBefore = fromJust $ decode (as!!0) (bs!!0), + notAfter = fromJust $ decode (as!!1) (bs!!1) + } + +{- +Time ::= + CHOICE {utcTime UTCTime, + generalizedTime GeneralizedTime + } +-} + +time :: TypeDefn +time = + "Time" ::= AbsRef Universal 23 Implicit absVisibleString + +data Time = Time VisibleString + deriving (Eq,Show) + +unTime :: Time -> VisibleString +unTime (Time x) = x + +instance Encode Time where + decode a b = + do x <- decode a b + return $ Time x + +{- +SubjectPublicKeyInfo ::= + SEQUENCE { + algorithm AlgorithmIdentifier, + subjectPublicKey BIT STRING + } +-} + +subjectPublicKeyInfo = + "SubjectPublicKeyInfo" ::= + AbsSeq Universal 16 Implicit + [Regular (Just "algorithm" :>: (Nothing :@: algorithmIdentifier)), + Regular (Just "subjectPublicKeyInfo" :>: (Nothing :@: absBitString))] + +data SubjectPublicKeyInfo = + SubjectPublicKeyInfo { + algorithm2 :: AlgorithmIdentifier, + subjectPublicKeyInfo1 :: BitString + } + deriving (Eq,Show) + +instance Encode SubjectPublicKeyInfo where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + SubjectPublicKeyInfo { + algorithm2 = fromJust $ decode (as!!0) (bs!!0), + subjectPublicKeyInfo1 = fromJust $ decode (as!!1) (bs!!1) + } + +{- +Certificate ::= + SEQUENCE { + version [0] Version DEFAULT v1, + serialNumber CertificateSerialNumber, + signature AlgorithmIdentifier, + issuer Name, + validity Validity, + subject Name, + subjectPublicKeyInfo SubjectPublicKeyInfo, + issuerUniqueIdentifier [1] IMPLICIT UniqueIdentifier OPTIONAL, + -- if present, version shall be v2 or v3 + subjectUniqueIdentifier [2] IMPLICIT UniqueIdentifier OPTIONAL, + -- if present, version shall be v2 or v3 + extensions [3] Extensions OPTIONAL + -- If present, version shall be v3 + } +-} + +certificate = + "Certificate" ::= + AbsSeq Universal 16 Implicit + [Default (Just "version" :>: + ((Just 0) :@: version)) [030200], + Regular (Just "serialNumber" :>: + (Nothing :@: certificateSerialNumber)), + Regular (Just "signature" :>: + (Nothing :@: algorithmIdentifier)), + Regular (Just "issuer" :>: + (Nothing :@: name)), + Regular (Just "validity" :>: + (Nothing :@: validity)), + Regular (Just "subject" :>: + (Nothing :@: name)), + Regular (Just "subjectPublicKeyInfo" :>: + (Nothing :@: subjectPublicKeyInfo))] + +{- +We don't handle IMPLICIT / EXPLICIT correctly on ComponentTypes of +SEQUENCE so we have to invent a new intermediate type to get over +the problem here until it is fixed in the main ASN1 module. + +CertificateVersion ::= + [1] EXPLICIT Version +-} + +certificateVersion = + "version" ::= AbsRef Context 0 Explicit version + +certificate' = + "Certificate" ::= + AbsSeq Universal 16 Implicit + [Default (Nothing :>: + (Nothing :@: certificateVersion)) [030200], + Regular (Just "serialNumber" :>: + (Nothing :@: certificateSerialNumber)), + Regular (Just "signature" :>: + (Nothing :@: algorithmIdentifier)), + Regular (Just "issuer" :>: + (Nothing :@: name)), + Regular (Just "validity" :>: + (Nothing :@: validity)), + Regular (Just "subject" :>: + (Nothing :@: name)), + Regular (Just "subjectPublicKeyInfo" :>: + (Nothing :@: subjectPublicKeyInfo))] + +data CertificateVersion = + CertificateVersion Version + deriving (Eq,Show) + +instance Encode CertificateVersion where + decode a b = + do y <- b + let a' = absRefedType a + b' = (encodedDefComps y)!!0 + x <- decode a' b' + return $ CertificateVersion x + +certificateVersionToVersion :: CertificateVersion -> Version +certificateVersionToVersion (CertificateVersion x) = x + +data Certificate = + Certificate { + version3 :: Version, + serialNumber :: CertificateSerialNumber, + signature :: AlgorithmIdentifier, + issuer :: Name, + validity1 :: Validity, + subject :: Name, + subjectPublicKeyInfo2 :: SubjectPublicKeyInfo + } + deriving (Eq,Show) + +instance Encode Certificate where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + version = certificateVersionToVersion $ + fromJust $ decode (as!!0) (bs!!0) + serialNumber = fromJust $ decode (as!!1) (bs!!1) + signature = fromJust $ decode (as!!2) (bs!!2) + issuer = fromJust $ decode (as!!3) (bs!!3) + validity = fromJust $ decode (as!!4) (bs!!4) + subject = fromJust $ decode (as!!5) (bs!!5) + subjectPublicKeyInfo = fromJust $ decode (as!!6) (bs!!6) + return $ + Certificate { + version3 = version, + serialNumber = serialNumber, + signature = signature, + issuer = issuer, + validity1 = validity, + subject = subject, + subjectPublicKeyInfo2 = subjectPublicKeyInfo + } + +signedCertificate :: TypeDefn +signedCertificate = + "SignedCertificate" ::= + AbsSeq Universal 16 Implicit + [Regular (Nothing :>: (Nothing :@: certificate')), + Regular (Nothing :>: (Nothing :@: algorithmIdentifier)), + Regular (Nothing :>: (Nothing :@: absBitString))] + +data SignedCertificate = + SignedCertificate { + certificate1 :: Certificate, + algorithmIdentifier1 :: AlgorithmIdentifier, + octetString :: BitString + } + deriving (Eq,Show) + +instance Encode SignedCertificate where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + SignedCertificate { + certificate1 = fromJust $ decode (as!!0) (bs!!0), + algorithmIdentifier1 = fromJust $ decode (as!!1) (bs!!1), + octetString = fromJust $ decode (as!!2) (bs!!2) + } + +{- +RSAPublicKey ::= SEQUENCE { + modulus INTEGER, -- n + publicExponent INTEGER -- e +} +-} + +rsaPublicKey :: TypeDefn +rsaPublicKey = + "RSAPublicKey" ::= + AbsSeq Universal 16 Implicit [ + Regular (Just "modulus" :>: (Nothing :@: absInteger)), + Regular (Just "publicExponent" :>: (Nothing :@: absInteger)) + ] + +data RSAPublicKey = + RSAPublicKey { + modulus1 :: Integer, + publicExponent1 :: Integer + } + deriving (Eq,Show) + +instance Encode RSAPublicKey where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + RSAPublicKey { + modulus1 = fromJust $ decode (as!!0) (bs!!0), + publicExponent1 = fromJust $ decode (as!!1) (bs!!1) + } + +version = modName "Version" absInteger + +type Version = Integer + +{- +We assume: + +Algorithm ::= OID + +although the situation is far more complicated. +See http://www.zvon.org/tmRFC/RFC2898/Output/chapter12.html. +-} + +algorithm = modName "Algorithm" absOID + +type Algorithm = OID + +{- +We assume: + +Parameters ::= NULL + +although the situation is far more complicated. +See http://www.zvon.org/tmRFC/RFC2898/Output/chapter12.html. +-} + +parameters = modName "Parameters" absNull + +type Parameters = NULL + +{- +See http://www.itu.int/ITU-T/asn1/database/itu-t/x/x509/1997/AuthenticationFramework.html#AuthenticationFramework.AlgorithmIdentifier. + +For now, the parameters will only ever be Nothing as this implementation +only supports RSA and this has no parameters. If the parameters +are non-NULL, we will report an error. + +See http://www.zvon.org/tmRFC/RFC3447/Output/index.html 10.1. A.1 RSA key representation: + +"The parameters field associated with this OID in a value of type AlgorithmIdentifier shall have a value of type NULL" +-} + +algorithmIdentifier :: TypeDefn +algorithmIdentifier = + "AlgorithmIdentifier" ::= + AbsSeq Universal 16 Implicit + [Regular (Just "algorithm" :>: (Nothing :@: algorithm)), + Regular (Just "parameters" :>: (Nothing :@: parameters))] + +data AlgorithmIdentifier = + AlgorithmIdentifier { + algorithm1 :: Algorithm, + parameters1 :: Maybe Parameters } + deriving (Eq,Show) + +instance Encode AlgorithmIdentifier where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + AlgorithmIdentifier { + algorithm1 = fromJust $ decode (as!!0) (bs!!0), + parameters1 = Nothing + } + diff --git a/Language/ASN1/X509/AttributeCertificateDefinitions.hs b/Language/ASN1/X509/AttributeCertificateDefinitions.hs new file mode 100644 --- /dev/null +++ b/Language/ASN1/X509/AttributeCertificateDefinitions.hs @@ -0,0 +1,483 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.ASN1.X509.InformationFramework +-- Copyright : (c) Dominic Steinitz 2006 - 2007 +-- License : BSD3 +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : non-portable +-- +-- Definitions to allow the typechecking of (BER) encodings of definitions from +-- AttributeCertificateDefinitions {joint-iso-itu-t ds(5) module(1) +-- attributeCertificateDefinitions(32) 5} +-- and +-- functions to extract information from encodings of them. +-- +-- See +-- +----------------------------------------------------------------------------- + +module Language.ASN1.X509.AttributeCertificateDefinitions ( +-- * Type declarations + AttributeCertificate(..), + AttributeCertificateInfo(..), + Holder(..), + HolderGeneralNames(..), + AttCertIssuer(..), + IssuerSerial(..), + Attribute(..), + AttributeValue(..), + AttCertValidityPeriod(..), + GeneralizedTime(..), +-- * Function declarations + attributeCertificate, + holder, + holder', + holderGeneralNames, + attCertIssuer, + issuerSerial, + attribute + ) where + +import Language.ASN1 +import Language.ASN1.BER +import Data.Maybe( + fromJust + ) +import Language.ASN1.X509 ( + algorithmIdentifier, + AlgorithmIdentifier + ) +import Language.ASN1.InformationFramework ( + generalNames, + GeneralNames + ) + +{- +AttributeCertificate ::= SIGNED {AttributeCertificateInfo} + +AttributeCertificate ::= SEQUENCE { + attributeCertificateInfo AttributeCertificateInfo, + algorithmIdentifier AlgorithmIdentifier, + encrypted BIT STRING + } + +AttributeCertificateInfo ::= SEQUENCE { + version AttCertVersion, --version is v2 + holder Holder, + issuer AttCertIssuer, + signature AlgorithmIdentifier, + serialNumber CertificateSerialNumber, + attrCertValidityPeriod AttCertValidityPeriod, + attributes SEQUENCE OF Attribute, + issuerUniqueID UniqueIdentifier OPTIONAL, + extensions Extensions OPTIONAL + } + +AttCertVersion ::= INTEGER { v2(1) } +-} + +attributeCertificate :: TypeDefn +attributeCertificate = + "attributeCertificate" ::= + AbsSeq Universal 16 Implicit + [Regular (Nothing :>: (Nothing :@: attributeCertificateInfo)), + Regular (Nothing :>: (Nothing :@: algorithmIdentifier)), + Regular (Nothing :>: (Nothing :@: absBitString))] + +attributeCertificateInfo :: TypeDefn +attributeCertificateInfo = + "attributeCertificateInfo" ::= + AbsSeq Universal 16 Implicit [ + Regular (Just "version" :>: (Nothing :@: version)), + Regular (Just "holder" :>: (Nothing :@: holder')), + Regular (Just "issuer" :>: (Nothing :@: attCertIssuer)), + Regular (Just "signature" :>: + (Nothing :@: algorithmIdentifier)), + Regular (Just "serialNumber" :>: + (Nothing :@: certificateSerialNumber)), + Regular (Just "attrCertValidityPeriod" :>: + (Nothing :@: attCertValidityPeriod)), + Regular (Just "attributes" :>: + (Nothing :@: ( + "SEQUENCE OF Attribute" ::= + AbsSeqOf Universal 16 Implicit attribute + ) + ) + ) + ] + +data AttributeCertificate = + AttributeCertificate { + attributeCertificateInfo1 :: AttributeCertificateInfo, + algorithmIdentifier2 :: AlgorithmIdentifier, + encrypted :: BitString + } deriving (Eq,Show) + +instance Encode AttributeCertificate where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + AttributeCertificate { + attributeCertificateInfo1 = fromJust $ decode (as!!0) (bs!!0), + algorithmIdentifier2 = fromJust $ decode (as!!1) (bs!!1), + encrypted = fromJust $ decode (as!!2) (bs!!2) + } + +data AttributeCertificateInfo = + AttributeCertificateInfo { + version1 :: Version, + holder1 :: Holder, + issuer2 :: AttCertIssuer, + signature1 :: AlgorithmIdentifier, + serialNumber1 :: CertificateSerialNumber, + attrCertValidityPeriod :: AttCertValidityPeriod, + attributes :: [Attribute] + } deriving (Eq,Show) + +instance Encode AttributeCertificateInfo where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + AttributeCertificateInfo { + version1 = fromJust $ decode (as!!0) (bs!!0), + holder1 = fromJust $ decode (as!!1) (bs!!1), + issuer2 = fromJust $ decode (as!!2) (bs!!2), + signature1 = fromJust $ decode (as!!3) (bs!!3), + serialNumber1 = fromJust $ decode (as!!4) (bs!!4), + attrCertValidityPeriod = fromJust $ decode (as!!5) (bs!!5), + attributes = fromJust $ decode (as!!6) (bs!!6) + } + +type Version = Integer + +version = modName "Version" absInteger + +{- +Holder ::= SEQUENCE { + baseCertificateID [0] IssuerSerial OPTIONAL, + -- the issuer and serial number of the holder's Public Key Certificate + entityName [1] GeneralNames OPTIONAL, + -- the name of the entity or role + objectDigestInfo [2] ObjectDigestInfo OPTIONAL + --used to directly authenticate the holder, e.g. an executable + --at least one of baseCertificateID, entityName or objectDigestInfo + -- shall be present + } +-} + +holder = + "Holder" ::= + AbsSeq Universal 16 Implicit + [Optional (Just "entityName" :>: (Just 1 :@: generalNames))] + +holder' = + "Holder" ::= + AbsSeq Universal 16 Implicit + [Optional (Nothing :>: (Nothing :@: holderGeneralNames))] + +{- +We don't handle IMPLICIT / EXPLICIT correctly on ComponentTypes of +SEQUENCE so we have to invent a new intermediate type to get over +the problem here until it is fixed in the main ASN1 module. + +HolderGeneralNames ::= + [1] IMPLICIT GeneralNames +-} + +holderGeneralNames = + "entityName" ::= AbsRef Context 1 Implicit generalNames + +data HolderGeneralNames = + HolderGeneralNames GeneralNames + deriving (Eq,Show) + +instance Encode HolderGeneralNames where + decode a b = + do x <- decode a b + return $ HolderGeneralNames x + +data Holder = + Holder { + entityName :: Maybe HolderGeneralNames + } + deriving (Eq,Show) + +instance Encode Holder where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + Holder { + entityName = decode (as!!0) (bs!!0) + } + +{- +AttCertIssuer ::= [0] SEQUENCE { + issuerName GeneralNames OPTIONAL, + baseCertificateID [0] IssuerSerial OPTIONAL, + objectDigestInfo [1] ObjectDigestInfo OPTIONAL + } +-- At least one component shall be present + ( WITH COMPONENTS { ..., issuerName PRESENT } | + WITH COMPONENTS { ..., baseCertificateID PRESENT } | + WITH COMPONENTS { ..., objectDigestInfo PRESENT } ) +-} + +attCertIssuer :: TypeDefn +attCertIssuer = + "attCertIssuer" ::= + AbsSeq Context 0 Implicit + [Optional (Just "issuerName" :>: + (Nothing :@: generalNames)), + Optional (Just "baseCertificateID" :>: + (Just 0 :@: issuerSerial)) +{- +051218140100 + +For now. Since with the PERMIS attribute certificate, we know +that we will get an issuerName, we don't have to support this yet +and ObjectDigestInfo is a) more work and b) contains ENUMERATED +which we don't support yet even though it's not hard so to do. + + Optional (Just "objectDigestInfo" :>: + (Just 1 :@: objectDigestInfo)) +-} + ] + +data AttCertIssuer = + AttCertIssuer { + issuerName :: Maybe GeneralNames, + baseCertificateID :: Maybe IssuerSerial + } + deriving (Eq,Show) + +instance Encode AttCertIssuer where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + AttCertIssuer { + issuerName = decode (as!!0) (bs!!0), + baseCertificateID = decode (as!!1) (bs!!1) + } + +{- +IssuerSerial ::= SEQUENCE { + issuer GeneralNames, + serial CertificateSerialNumber, + issuerUID UniqueIdentifier OPTIONAL + } +-} + +issuerSerial = + "IssuerSerial" ::= + AbsSeq Universal 16 Implicit [ + Regular (Just "issuer" :>: (Nothing :@: generalNames)), + Regular (Just "serial" :>: (Nothing :@: certificateSerialNumber)), + Optional (Just "issuerUID" :>: (Nothing :@: uniqueIdentifier)) + ] + +data IssuerSerial = + IssuerSerial { + issuer1 :: GeneralNames, + serial :: CertificateSerialNumber, + issuerID :: Maybe UniqueIdentifier + } + deriving (Eq,Show) + +instance Encode IssuerSerial where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + IssuerSerial { + issuer1 = fromJust $ decode (as!!0) (bs!!0), + serial = fromJust $ decode (as!!1) (bs!!1), + issuerID = decode (as!!2) (bs!!2) + } + +{- +CertificateSerialNumber ::= INTEGER +-} + +certificateSerialNumber = + modName "CertificateSerialNumber" absInteger + +type CertificateSerialNumber = Integer + +{- +AttCertValidityPeriod ::= SEQUENCE { + notBeforeTime GeneralizedTime, + notAfterTime GeneralizedTime + } +-} + +attCertValidityPeriod :: TypeDefn +attCertValidityPeriod = + "Validity" ::= + AbsSeq Universal 16 Implicit + [Regular (Just "notBeforeTime" :>: (Nothing :@: generalizedTime)), + Regular (Just "notAfterTime" :>: (Nothing :@: generalizedTime))] + +data AttCertValidityPeriod = + AttCertValidityPeriod { + notBeforeTime :: GeneralizedTime, + notAfterTime :: GeneralizedTime + } + deriving (Eq,Show) + +instance Encode AttCertValidityPeriod where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + AttCertValidityPeriod { + notBeforeTime = fromJust $ decode (as!!0) (bs!!0), + notAfterTime = fromJust $ decode (as!!1) (bs!!1) + } + +{- +This is really from X.680. + +GeneralizedTime ::= [UNIVERSAL 24] IMPLICIT VisibleString +-} + +generalizedTime :: TypeDefn +generalizedTime = + "Time" ::= AbsRef Universal 24 Implicit absVisibleString + +data GeneralizedTime = GeneralizedTime VisibleString + deriving (Eq,Show) + +instance Encode GeneralizedTime where + decode a b = + do x <- decode a b + return $ GeneralizedTime x + +{- +This is really from + +SelectedAttributeTypes { + joint-iso-itu-t ds(5) module(1) selectedAttributeTypes (5) 4 + } + +UniqueIdentifier ::= BIT STRING + +WARNING: typechecking BIT STRING is a kludge and may not work for this. +-} + +uniqueIdentifier = + modName "UniqueIdentifier" absBitString + +type UniqueIdentifier = BitString + +{- +This is invalid ASN.1 even though it comes from +RFC 3281. + +Attribute ::= SEQUENCE { + type AttributeType, + values SET OF AttributeValue + -- at least one value is required + } + +AttributeType ::= OBJECT IDENTIFIER + +AttributeValue ::= ANY DEFINED BY AttributeType + +This is also invalid but it should be easy to support +typechecking of it. + +Attribute ::= SEQUENCE { + type AttributeType, + values SET OF ANY DEFINED BY type, + -- at least one value is required + } + +The "real" definition is from + +InformationFramework +{joint-iso-itu-t(2) ds(5) module(1) informationFramework(1) 3} +has a different definition: + +Attribute ::= SEQUENCE { + type + ATTRIBUTE.&id({SupportedAttributes}), + values + SET SIZE (0..MAX) OF + ATTRIBUTE.&Type({SupportedAttributes}{@type}), + valuesWithContext + SET SIZE (1..MAX) OF + SEQUENCE { + value ATTRIBUTE.&Type({SupportedAttributes}{@type}), + contextList SET SIZE (1..MAX) OF Context} OPTIONAL + } + +Thus we won't support valuesWithContext. Should they be present, +they will be ignored. +-} + +{- +attribute :: TypeDefn +attribute = + "Attribute" ::= + AbsSeq Universal 16 Implicit + [Regular (Just "type" :>: (Nothing :@: absOID)), + AnyDefBy 0] +-} + +attribute :: TypeDefn +attribute = + "Attribute" ::= + AbsSeq Universal 16 Implicit [ + Regular (Just "type" :>: (Nothing :@: absOID)), + Regular ( + Just "values" :>: ( + Nothing :@: ( + "SET OF AttributeValue" ::= + AbsSetOf Universal 17 Implicit ( + "ANY DEFINED BY type" ::= AbsAnyDefBy 0 + ) + ) + ) + ) + ] + +data Attribute = + Attribute { + attributeType :: OID, + attributeValues :: SetOf AttributeValue + } + deriving (Eq,Show) + +instance Encode Attribute where + decode a b = + do x <- b + let as = absSeqComponents a + bs = encodedDefComps x + return $ + Attribute { + attributeType = fromJust $ decode (as!!0) (bs!!0), + attributeValues = fromJust $ decode (as!!1) (bs!!1) + } + +data AttributeValue = AVPS PrintableString + deriving (Eq,Show) + +instance Encode AttributeValue where + decode a@(AbsBasePrim _ _ AbsPrintableString) b = + do x <- decode a b + return (AVPS x) + decode a b = + error (show a ++ "\n" ++ show b) + diff --git a/PKCS8Example.hs b/PKCS8Example.hs new file mode 100644 --- /dev/null +++ b/PKCS8Example.hs @@ -0,0 +1,117 @@ +module Main(main) where + +import System.IO +import System.Environment +import Control.Monad.Error +import Control.Monad.State +import Data.Maybe +import Data.List ( + unfoldr, + intersperse + ) +import Numeric ( + showHex + ) +import NewBinary.Binary +import Language.ASN1.Utils ( + toOctets + ) +import Language.ASN1.BER +import Language.ASN1 +import Language.ASN1.TLV +import Language.ASN1.PKCS8 +import Language.ASN1.X509 ( + algorithm1, + parameters1 + ) +import Text.PrettyPrint + +pp pki rsapk = + render ( + ppLabelString "Version" (show (version2 pki)) + $$ + ppLabelDoc "Private Key Algorithm" algid + $$ + ppLabelDoc "Private Key" rs + ) + where + algid = + ppLabelString "Algorithm" (show (algorithm1 al)) + $$ + ppLabelString "Parameters" (show (parameters1 al)) + al = privateKeyAlgorithm pki + rs = ppLabelString "Version" (show (version1 rsapk)) + $$ + mod + $$ + ppLabelDoc "Public Exponent" puE + $$ + ppLabelDoc "Private Exponent" prE + $$ + ppLabelDoc "Prime 1" p1 + $$ + ppLabelDoc "Prime 2" p2 + $$ + ppLabelDoc "Exponent 1" e1 + $$ + ppLabelDoc "Exponent 2" e2 + $$ + ppLabelDoc "Coefficient" co + bar = map (map sh) (split 16 (toOctets 256 (modulus rsapk))) + sh x | x < 16 = showHex x "0" + | otherwise = showHex x "" + split :: Int -> [a] -> [[a]] + split n xs = unfoldr (g n) xs + g :: Int -> [a] -> Maybe ([a],[a]) + g n y + | length y == 0 = Nothing + | otherwise = Just (splitAt n y) + mods1 :: [[Doc]] + mods1 = map (intersperse colon) (map (map text) bar) + mods2 :: [Doc] + mods2 = map hcat mods1 + mod = ppLabelDoc "Modulus" (vcat mods2) + puE = hexify (publicExponent rsapk) + prE = hexify (privateExponent rsapk) + p1 = hexify (prime1 rsapk) + p2 = hexify (prime2 rsapk) + e1 = hexify (exponent1 rsapk) + e2 = hexify (exponent2 rsapk) + co = hexify (coefficient rsapk) + hexify :: Integral a => a -> Doc + hexify n = + let bar = map (map sh) (split 16 (toOctets 256 n)) + foo = map (intersperse colon) (map (map text) bar) + baz = vcat (map hcat foo) + in baz + +ppLabelString :: String -> String -> Doc +ppLabelString l x = + text l <> colon <> space <> (text x) + +ppLabelDoc :: String -> Doc -> Doc +ppLabelDoc l d = + text l <> colon + $$ + nest 3 d + +test fileName = + do h <- openFile fileName ReadMode + bin <- openBinIO_ h + (l,x) <- tlvIO bin + (w,y) <- typeCheck privateKeyInfo x + let (_ ::= c) = w + pk = (decode c (Just y))::(Maybe PrivateKeyInfo) + (OctetString xs) = privateKey1 $ fromJust pk + (l',x') = tlv xs + (v,z) <- typeCheck rsaPrivateKey x' + let (_ ::= e) = v + rsapk = (decode e (Just z))::(Maybe RSAPrivateKey) + putStrLn (pp (fromJust pk) (fromJust rsapk)) + +main = + do progName <- getProgName + args <- getArgs + if length args /= 1 + then putStrLn ("Usage: " ++ progName ++ " ") + else test (args!!0) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +module Main where +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/X509Example.hs b/X509Example.hs new file mode 100644 --- /dev/null +++ b/X509Example.hs @@ -0,0 +1,120 @@ +module Main(main) where + +import System.IO +import System.Environment +import Control.Monad.Error +import Data.Maybe +import Data.List +import Numeric +import NewBinary.Binary +import Language.ASN1.BER +import Language.ASN1 +import Language.ASN1.TLV +import Language.ASN1.X509 +import Language.ASN1.Utils +import Text.PrettyPrint +import Control.Monad.State + +pp :: SignedCertificate -> RSAPublicKey -> String +pp sc rsapk = + render ( + ppLabelString "Version" (show (version3 (certificate1 sc))) + $$ + ppLabelString "Serial Number" (show (serialNumber (certificate1 sc))) + $$ + ppLabelDoc "Algorithm Identifier" algid + $$ + ppLabelDoc "Issuer" iss + $$ + ppLabelDoc "Validity" valid + $$ + ppLabelDoc "Subject" sub + $$ + ppLabelDoc "Subject Public Key Info" kk + ) + where + algid = + ppLabelString "Algorithm" + (show (algorithm1 (signature (certificate1 sc)))) + $$ + ppLabelString "Parameters" + (show (parameters1 (signature (certificate1 sc)))) + iss = vcat (rdns issuer) + sub = vcat (rdns subject) + rdns select = ( + (map (\x -> (text (show (fst x)) <> + space <> + text (unDirectoryString (snd x))))) . + (map (\x -> (type1 (head x),value (head x)))) . + (map unSetOf) . + (map unRelativeDistinguishedName) . + unName . + select . + certificate1 + ) sc + valid = + ppLabelString "NotBefore" nb + $$ + ppLabelString "NotAfter" na + nb = unVisibleString (unTime (notBefore (validity1 (certificate1 sc)))) + na = unVisibleString (unTime (notAfter (validity1 (certificate1 sc)))) + ki = subjectPublicKeyInfo2 (certificate1 sc) + al = algorithm2 ki + kj = subjectPublicKeyInfo1 ki + algid1 = + ppLabelString "Algorithm" (show (algorithm1 al)) + $$ + ppLabelString "Parameters" (show (parameters1 al)) + kk = ppLabelDoc "Algorithm" algid1 + $$ + ppLabelDoc "Subject Public Key Info" spki + spki = mod $$ exp + exp = ppLabelString "Exponent" (show (publicExponent1 rsapk)) + bar = map (map sh) (split 16 (toOctets 256 (modulus1 rsapk))) + sh x | x < 16 = showHex x "0" + | otherwise = showHex x "" + split :: Int -> [a] -> [[a]] + split n xs = unfoldr (g n) xs + g :: Int -> [a] -> Maybe ([a],[a]) + g n y + | length y == 0 = Nothing + | otherwise = Just (splitAt n y) + mods1 :: [[Doc]] + mods1 = map (intersperse colon) (map (map text) bar) + mods2 :: [Doc] + mods2 = map hcat mods1 + mod = ppLabelDoc "Modulus" (vcat mods2) + +ppLabelString :: String -> String -> Doc +ppLabelString l x = + text l <> colon <> space <> (text x) + +ppLabelDoc :: String -> Doc -> Doc +ppLabelDoc l d = + text l <> colon + $$ + nest 3 d + +test fileName = + do h <- openFile fileName ReadMode + bin <- openBinIO_ h + (l,x) <- tlvIO bin + (w,y) <- typeCheck signedCertificate x + let (_ ::= c) = w + let d = (decode c (Just y))::(Maybe SignedCertificate) + let d1 = certificate1 (fromJust d) + let d2 = subjectPublicKeyInfo2 d1 + let d3 = subjectPublicKeyInfo1 d2 + let (BitString e) = d3 + let (l',x') = tlv e + (w',y') <- typeCheck rsaPublicKey x' + let (_ ::= r) = w' + let s = (decode r (Just y'))::(Maybe RSAPublicKey) + putStrLn (pp (fromJust d) (fromJust s)) + +main = + do progName <- getProgName + args <- getArgs + if length args /= 1 + then putStrLn ("Usage: " ++ progName ++ " ") + else test (args!!0)