ASN1 (empty) → 0.0.1
raw patch · 17 files changed
+5181/−0 lines, 17 filesdep +HUnitdep +NewBinarydep +QuickCheckbuild-type:Customsetup-changed
Dependencies added: HUnit, NewBinary, QuickCheck, base, mtl
Files
- ASN1.cabal +74/−0
- AttributeCertificate.hs +174/−0
- BERTest.hs +1214/−0
- BERTest2.hs +782/−0
- Language/ASN1.hs +331/−0
- Language/ASN1/BER.hs +556/−0
- Language/ASN1/InformationFramework.hs +155/−0
- Language/ASN1/PKCS1v15.hs +103/−0
- Language/ASN1/PKCS8.hs +265/−0
- Language/ASN1/Raw.hs +49/−0
- Language/ASN1/TLV.hs +185/−0
- Language/ASN1/Utils.hs +103/−0
- Language/ASN1/X509.hs +465/−0
- Language/ASN1/X509/AttributeCertificateDefinitions.hs +483/−0
- PKCS8Example.hs +117/−0
- Setup.hs +5/−0
- X509Example.hs +120/−0
+ ASN1.cabal view
@@ -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+++
+ AttributeCertificate.hs view
@@ -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 ++ " <fileName>")+ else test1 (args!!0)
+ BERTest.hs view
@@ -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+-}
+ BERTest2.hs view
@@ -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+
+ Language/ASN1.hs view
@@ -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)+ ]
+ Language/ASN1/BER.hs view
@@ -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
+ Language/ASN1/InformationFramework.hs view
@@ -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 <http://www.itu.int/ITU-T/asn1/database/itu-t/x/x501/2005/InformationFramework.html>+--+-----------------------------------------------------------------------------++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)+
+ Language/ASN1/PKCS1v15.hs view
@@ -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 +-- (<ftp://ftp.rsasecurity.com/pub/pkcs/pkcs-1/pkcs-1v2-1.pdf> and+-- <ftp://ftp.rsasecurity.com/pub/pkcs/ascii/pkcs-1.asc>) 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
+ Language/ASN1/PKCS8.hs view
@@ -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 <http://www.rsasecurity.com/rsalabs/pkcs/pkcs-8/>.+--+-----------------------------------------------------------------------------++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.+-}++-}
+ Language/ASN1/Raw.hs view
@@ -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
+ Language/ASN1/TLV.hs view
@@ -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)
+ Language/ASN1/Utils.hs view
@@ -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 <ftp://ftp.rsasecurity.com/pub/pkcs/pkcs-1/pkcs-1v2-1.pdf>+-- 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
+ Language/ASN1/X509.hs view
@@ -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+ }+
+ Language/ASN1/X509/AttributeCertificateDefinitions.hs view
@@ -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 <http://www.itu.int/ITU-T/asn1/database/itu-t/x/x509/2005/AttributeCertificateDefinitions.html>+--+-----------------------------------------------------------------------------++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)+
+ PKCS8Example.hs view
@@ -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 ++ " <fileName>")+ else test (args!!0)
+ Setup.hs view
@@ -0,0 +1,5 @@+module Main where+import Distribution.Simple++main :: IO ()+main = defaultMain
+ X509Example.hs view
@@ -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 ++ " <fileName>")+ else test (args!!0)