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