ASN1 0.0.1 → 0.0.1.1
raw patch · 9 files changed
+87/−2471 lines, 9 filesdep +containersdep +old-timedep +prettydep ~base
Dependencies added: containers, old-time, pretty
Dependency ranges changed: base
Files
- ASN1.cabal +82/−60
- AttributeCertificate.hs +0/−174
- BERTest.hs +0/−1214
- BERTest2.hs +0/−782
- Language/ASN1.hs +3/−3
- Language/ASN1/BER.hs +1/−1
- Language/ASN1/X509.hs +1/−0
- PKCS8Example.hs +0/−117
- X509Example.hs +0/−120
ASN1.cabal view
@@ -1,74 +1,96 @@ Name: ASN1-Version: 0.0.1+Version: 0.0.1.1 License: BSD3 Author: Dominic Steinitz-Maintainer: dominic.steinitz@blueyonder.co.uk+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.+Stability: Alpha+Category: Language+Homepage: http://www.haskell.org/asn1+Synopsis: ASN.1 support for Haskell 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+Build-type: Simple+Cabal-Version: >= 1.2 -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+flag small_base+ description: Choose the new smaller, split-up base package. -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+library+ extensions: FlexibleContexts,+ FlexibleInstances -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+ if flag(small_base)+ build-depends: base >= 3,+ containers,+ old-time,+ pretty+ else+ build-depends: base < 3 -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+ build-Depends: mtl,+ QuickCheck,+ HUnit,+ NewBinary + 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
@@ -1,174 +0,0 @@-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
@@ -1,1214 +0,0 @@-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
@@ -1,782 +0,0 @@-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
@@ -30,7 +30,7 @@ IA5String(..), DirectoryString(..), OID(..),- NULL,+ NULL(..), OctetString(..), BitString(..), SetOf(..),@@ -72,12 +72,12 @@ type Octet = Word8 data TagType = Universal | Application | Context | Private- deriving (Eq,Show, Enum)+ deriving (Eq,Show,Enum,Ord) type TagValue = Integer data TagPlicity = Implicit | Explicit- deriving (Eq,Show)+ deriving (Eq,Show,Ord) data AbsPrimType = AbsVisibleString | AbsPrintableString
Language/ASN1/BER.hs view
@@ -61,7 +61,7 @@ -- | Type check the abstract representation of a Tag Length Value -- against an ASN.1 type definition. -typeCheck :: TypeDefn -> Encoding -> IO (TypeDefn,Defaulted)+typeCheck :: (MonadError e m) => TypeDefn -> Encoding -> m (TypeDefn,Defaulted) typeCheck a b = do ((q,r),_) <- runStateT (tc a b) []
Language/ASN1/X509.hs view
@@ -23,6 +23,7 @@ AttributeTypeAndValue(..), RelativeDistinguishedName(..), CertificateVersion,+ Name(..), -- * Type classes -- * Function types time,
− PKCS8Example.hs
@@ -1,117 +0,0 @@-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)
− X509Example.hs
@@ -1,120 +0,0 @@-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)