summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDominicSteinitz <>2008-06-22 10:41:52 (GMT)
committerLuite Stegeman <luite@luite.com>2008-06-22 10:41:52 (GMT)
commit3979e6691fbf6df690b22947866679c09c0bdcb9 (patch)
tree4c55f5d788a80df84247f85614cbfed57eac65cc
parenta949de7b185d1890cd8e8d94377469a6e231bfe6 (diff)
version 0.0.1.1HEAD0.0.1.1master
-rw-r--r--ASN1.cabal142
-rw-r--r--AttributeCertificate.hs174
-rw-r--r--BERTest.hs1214
-rw-r--r--BERTest2.hs782
-rw-r--r--Language/ASN1.hs6
-rw-r--r--Language/ASN1/BER.hs2
-rw-r--r--Language/ASN1/X509.hs1
-rw-r--r--PKCS8Example.hs117
-rw-r--r--X509Example.hs120
9 files changed, 87 insertions, 2471 deletions
diff --git a/ASN1.cabal b/ASN1.cabal
index dbbe445..0b31975 100644
--- a/ASN1.cabal
+++ b/ASN1.cabal
@@ -1,74 +1,96 @@
Name: ASN1
-Version: 0.0.1
+Version: 0.0.1.1
License: BSD3
Author: Dominic Steinitz
-Maintainer: dominic.steinitz@blueyonder.co.uk
+Maintainer: dominic.steinitz@blueyonder.co.uk
Copyright: Dominic Steinitz 2003 - 2007
-Stability: Alpha
-Category: Language
-Homepage: http://www.haskell.org/asn1
-Synopsis: General ASN.1 support.
+Stability: Alpha
+Category: Language
+Homepage: http://www.haskell.org/asn1
+Synopsis: ASN.1 support for Haskell
Description: Enough ASN.1 suppport for X.509
identity and attribute certificates, PKCS8, PKCS1v15.
Only the Basic Encoding Rules (BER) are supported.
-Build-Depends: base, mtl, QuickCheck, HUnit, NewBinary
-Ghc-options: -fglasgow-exts
-Exposed-Modules: Language.ASN1
- Language.ASN1.BER
- Language.ASN1.InformationFramework
- Language.ASN1.TLV
- Language.ASN1.X509
- Language.ASN1.X509.AttributeCertificateDefinitions
- Language.ASN1.PKCS1v15
- Language.ASN1.PKCS8
- Language.ASN1.Utils
- Language.ASN1.Raw
+Build-type: Simple
+Cabal-Version: >= 1.2
-Executable: BERTest
-Main-Is: BERTest.hs
-Ghc-options: -fglasgow-exts
-Other-modules: Language.ASN1
- Language.ASN1.BER
+flag small_base
+ description: Choose the new smaller, split-up base package.
-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
+library
+ extensions: FlexibleContexts,
+ FlexibleInstances
-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
+ if flag(small_base)
+ build-depends: base >= 3,
+ containers,
+ old-time,
+ pretty
+ else
+ build-depends: base < 3
-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
+ build-Depends: mtl,
+ QuickCheck,
+ HUnit,
+ NewBinary
+ Exposed-Modules: Language.ASN1
+ Language.ASN1.BER
+ Language.ASN1.InformationFramework
+ Language.ASN1.TLV
+ Language.ASN1.X509
+ Language.ASN1.X509.AttributeCertificateDefinitions
+ Language.ASN1.PKCS1v15
+ Language.ASN1.PKCS8
+ Language.ASN1.Utils
+ Language.ASN1.Raw
+-- Executable: BERTest
+-- Main-Is: BERTest.hs
+-- Ghc-options: -fglasgow-exts
+-- Other-modules: Language.ASN1
+-- Language.ASN1.BER
+--
+-- Executable: BERTest2
+-- Main-Is: BERTest2.hs
+-- Ghc-options: -fglasgow-exts
+-- Other-modules: Language.ASN1
+-- Language.ASN1.BER
+-- Language.ASN1.X509
+-- Language.ASN1.InformationFramework
+-- Language.ASN1.X509.AttributeCertificateDefinitions
+-- Language.ASN1.TLV
+--
+-- Executable: X509Example
+-- Main-Is: X509Example.hs
+-- Ghc-options: -fglasgow-exts
+-- Other-modules: Language.ASN1.BER
+-- Language.ASN1
+-- Language.ASN1.TLV
+-- Language.ASN1.X509
+-- Language.ASN1.Utils
+--
+-- Executable: PKCS8Example
+-- Main-Is: PKCS8Example.hs
+-- Ghc-options: -fglasgow-exts
+-- Other-modules: Language.ASN1.BER
+-- Language.ASN1
+-- Language.ASN1.TLV
+-- Language.ASN1.PKCS8
+-- Language.ASN1.X509
+--
+-- Executable: AttributeCertificate
+-- Main-Is: AttributeCertificate.hs
+-- Ghc-options: -fglasgow-exts
+-- Other-modules: Language.ASN1.BER
+-- Language.ASN1
+-- Language.ASN1.X509
+-- Language.ASN1.InformationFramework
+-- Language.ASN1.X509.AttributeCertificateDefinitions
+-- Language.ASN1.Utils
+-- Language.ASN1.TLV
+-- Language.ASN1.Raw
+--
+--
+--
diff --git a/AttributeCertificate.hs b/AttributeCertificate.hs
deleted file mode 100644
index d10ef6e..0000000
--- a/AttributeCertificate.hs
+++ /dev/null
@@ -1,174 +0,0 @@
-module Main(main) where
-
-import Data.Char
-import Data.Maybe
-import Control.Monad.Error
-import Control.Monad.State
-import Language.ASN1.BER
-import Language.ASN1
-import Language.ASN1.X509
-import Language.ASN1.InformationFramework
-import Language.ASN1.X509.AttributeCertificateDefinitions
-import Test.HUnit
-import System.IO
-import System.Environment
-import System.Console.GetOpt
-import Language.ASN1.Utils
-import Language.ASN1.TLV
-import NewBinary.Binary
-import Text.PrettyPrint
-import Language.ASN1.Raw
-
-instance PP AttributeCertificate where
- pp ac =
- (label' "AttributeCertificateInfo". pp . attributeCertificateInfo1 $ ac)
- $$
- (label' "AlgorithmIdentifier" . pp . algorithmIdentifier2 $ ac)
- $$
- (label' "Encrypted" . pp . encrypted $ ac)
-
-instance PP AttributeCertificateInfo where
- pp aci =
- (label "Version" . pp . version1 $ aci)
- $$
- (label' "Holder" . pp . holder1 $ aci)
- $$
- (label' "AttCertIssuer" . pp . issuer2 $ aci)
- $$
- (label' "AlgorithmIdentifier" . pp . signature1 $ aci)
- $$
- (label' "CertificateSerialNumber" . pp . serialNumber1 $ aci)
- $$
- (label' "CertificateValidity" . pp . attrCertValidityPeriod $ aci)
- $$
- (label' "Attributes" . pp . attributes $ aci)
-
-label :: String -> Doc -> Doc
-label s d = text s <> colon <> space <> d
-
-hangingLabel :: String -> Int -> Doc -> Doc
-hangingLabel s n d = hang (text s <> colon <> space) n d
-
-label' s d = hangingLabel s 3 d
-
-class PP a where
- pp :: a -> Doc
-
-instance PP GeneralName where
- pp gn =
- case gn of
- Rfc822Name x -> text "Rfc822Name"
- DNSName x -> text "DNSName"
- DirectoryName x -> pp x
- UnifromResourceIdentifier x -> text "UniformResourceIdentifier"
- IPAddress x -> text "IPAddress"
- RegisteredID x -> text "RegisteredID"
-
-instance PP a => PP [a] where
- pp xs = vcat (map pp xs)
-
-instance PP a => PP (Maybe a) where
- pp Nothing = text "Nothing"
- pp (Just x) = pp x
-
-instance PP Holder where
- pp = pp . entityName
-
-instance PP AttCertIssuer where
- pp aci =
- (label "IssuerName" . pp . issuerName $ aci)
- $$
- (label' "BaseCertificateID" . pp . baseCertificateID $ aci)
-
-instance PP IssuerSerial where
- pp is =
- (label "Issuer" . pp . issuer1 $ is)
- $$
- (label "CertificateSerialNumber" . pp . serial $ is)
-
-instance PP AlgorithmIdentifier where
- pp ai =
- (label "Algorithm" . pp . algorithm1 $ ai)
- $$
- (label "Parameters" . pp . parameters1 $ ai)
-
-instance PP NULL where
- pp _ = text "NULL"
-
-instance PP Integer where
- pp = integer
-
-instance PP BitString where
- pp (BitString bs) = hexdump 16 bs
-
-instance PP HolderGeneralNames where
- pp (HolderGeneralNames x) = pp x
-
-instance PP GeneralNames where
- pp (GeneralNames xs) = pp xs
-
-instance PP VisibleString where
- pp (VisibleString x) = text x
-
-instance PP PrintableString where
- pp (PrintableString x) = text x
-
-instance PP IA5String where
- pp (IA5String x) = text x
-
-instance PP DirectoryString where
- pp (VS x) = pp x
- pp (PS x) = pp x
- pp (IA x) = pp x
-
-instance PP AttributeTypeAndValue where
- pp x =
- (pp . type1 $ x) <> space <> (pp . value $ x)
-
-instance PP Attribute where
- pp x =
- (pp . attributeType $ x) <> space <> (pp . attributeValues $ x)
-
-instance PP AttributeValue where
- pp (AVPS x) = pp x
-
-instance PP OID where
- pp x = text . show $ x
-
-instance PP a => PP (SetOf a) where
- pp (SetOf x) = pp x
-
-instance PP RelativeDistinguishedName where
- pp (RelativeDistinguishedName x) = pp x
-
-instance PP RDNSequence where
- pp (RDNSequence x) = pp x
-
-instance PP Name where
- pp (Name x) = pp x
-
-instance PP AttCertValidityPeriod where
- pp x =
- (label "NotBeforeTime" . pp . notBeforeTime $ x)
- $$
- (label "NotAfterTime" . pp . notAfterTime $ x)
-
-instance PP GeneralizedTime where
- pp (GeneralizedTime x) = pp x
-
-test1 fileName =
- do h <- openFile fileName ReadMode
- bin <- openBinIO_ h
- (l,x) <- tlvIO bin
- (w,y) <- typeCheck attributeCertificate x
- let (_ ::= c) = w
- let d = (decode c (Just y))::(Maybe AttributeCertificate)
- putStrLn (render . pp . fromJust $ d)
- putStrLn "Success"
-
-main =
- do progName <- getProgName
- args <- getArgs
- if length args /= 1
- then putStrLn ("Usage: " ++ progName ++ " <fileName>")
- else test1 (args!!0)
diff --git a/BERTest.hs b/BERTest.hs
deleted file mode 100644
index df563ff..0000000
--- a/BERTest.hs
+++ /dev/null
@@ -1,1214 +0,0 @@
-module Main(main) where
-
-import Data.Char
-import Data.Maybe
-import Control.Monad.Error
-import Control.Monad.State
-import Language.ASN1.BER
-import Language.ASN1
-import Test.HUnit
-
-{-
-Some of the ASN.1 definitions are taken from various standards and
-these are annotated with references. The other ASN.1 definitions
-have been created specifically to check decoding. These have been
-checked using the on-line tool, Asnp, available at
-
-http://asn1.elibel.tm.fr/en/tools/asnp/index.htm
-
-Notes: Definitions using ANY DEFINED BY have to be checked with -1990
-option. Asnp was developed in Objective Caml.
--}
-
-expectSuccess testName asnType berValue expectedAbsValue =
- TestCase $
- do (w,x) <- typeCheck asnType berValue
- let (_ ::= c) = w
- d = decode c (Just x)
- (Just y) = d
- assertEqual testName expectedAbsValue y
-
-expectFailure testName asnType berValue expectedError =
- TestCase $
- do x <- (do y <- typeCheck asnType berValue
- return "Unexpected successful typechecking")
- `catchError` (\e -> return $ show e)
- assertEqual testName x expectedError
-
-{-
-Some tagged value tests. See 8.14.3 of X.690 (ISO 8825-1).
-
-Type1 ::= VisibleString
-Type2 ::= [APPLICATION 3] IMPLICIT Type1
-Type3 ::= [2] Type2
-Type4 ::= [APPLICATION 7] IMPLICIT Type3
-Type5 ::= [2] IMPLICIT Type2
--}
-
-type1' = modName "Type1" absVisibleString
-
-type Type1 = VisibleString
-
-jones1 = Primitive Universal 26 5 [0x4a,0x6f,0x6e,0x65,0x73]
-
-decodedJones1 = VisibleString "Jones"
-
-tagTest1 = expectSuccess "Type1" type1' jones1 decodedJones1
-
-type2 = "Type2" ::= AbsRef Application 3 Implicit type1'
-
-data Type2 = Type2 VisibleString
- deriving (Eq,Show)
-
-instance Encode Type2 where
- decode a b =
- do x <- decode a b
- return $ Type2 x
-
-jones2 = Primitive Application 3 5 [0x4a,0x6f,0x6e,0x65,0x73]
-
-decodedJones2 = Type2 decodedJones1
-
-tagTest2 = expectSuccess "Type2" type2 jones2 decodedJones2
-
-type3 = "Type3" ::= AbsRef Context 2 Explicit type2
-
-data Type3 = Type3 Type2
- deriving (Eq,Show)
-
-instance Encode Type3 where
- decode a b =
- do y <- b
- let a' = absRefedType a
- b' = (encodedDefComps y)!!0
- x <- decode a' b'
- return $ Type3 x
-
-jones3 = Constructed Context 2 7 [jones2]
-
-decodedJones3 = Type3 decodedJones2
-
-tagTest3 = expectSuccess "Type3" type3 jones3 decodedJones3
-
-type4 = "Type4" ::= AbsRef Application 7 Implicit type3
-
-jones4 = Constructed Application 7 7 [jones2]
-
-data Type4 = Type4 Type3
- deriving (Eq,Show)
-
-instance Encode Type4 where
- decode a b =
- do x <- decode a b
- return $ Type4 x
-
-decodedJones4 = Type4 decodedJones3
-
-tagTest4 = expectSuccess "Type4" type4 jones4 decodedJones4
-
-{-
-Some tests for OPTIONAL components.
--}
-
-{-
-Journey ::=
- SEQUENCE {
- origin IA5String,
- stop1 [0] IA5String OPTIONAL,
- stop2 [1] IA5String OPTIONAL,
- destination IA5String
- }
--}
-
-journey =
- "Journey" ::=
- AbsSeq Universal 16 Implicit [
- Regular (Just "origin" :>: (Nothing :@: absIA5String)),
- Optional (Just "stop1" :>: (Just 0 :@: absIA5String)),
- Optional (Just "stop2" :>: (Just 1 :@: absIA5String)),
- Regular (Just "destination" :>: (Nothing :@: absIA5String))
- ]
-
-j1 =
- Constructed Universal 16 24 [
- Primitive Universal 22 3 [97,97,98],
- Primitive Context 0 3 [99,100,101],
- Primitive Context 1 3 [102,103,104],
- Primitive Universal 22 3 [97,97,98]
- ]
-
-j2 =
- Constructed Universal 16 24 [
- Primitive Universal 22 3 [97,97,98],
- Primitive Context 1 3 [102,103,104],
- Primitive Universal 22 3 [97,97,98]
- ]
-
-data Journey =
- Journey {
- origin :: IA5String,
- stop1 :: Maybe IA5String,
- stop2 :: Maybe IA5String,
- destination :: IA5String
- }
- deriving (Eq,Show)
-
-instance Encode Journey where
- decode a b =
- do x <- b
- let as = absSeqComponents a
- bs = encodedDefComps x
- return $
- Journey {
- origin = fromJust (decode (as!!0) (bs!!0)),
- stop1 = do decode (as!!1) (bs!!1),
- stop2 = do decode (as!!2) (bs!!2),
- destination = fromJust (decode (as!!3) (bs!!3))
- }
-
-decodedJ1 =
- Journey {
- origin = IA5String "aab",
- stop1 = Just $ IA5String "cde",
- stop2 = Just $ IA5String "fgh",
- destination = IA5String "aab"
- }
-
-decodedJ2 =
- Journey {
- origin = IA5String "aab",
- stop1 = Nothing,
- stop2 = Just $ IA5String "fgh",
- destination = IA5String "aab"
- }
-
-journeyTest1 =
- expectSuccess "Journey1" journey j1 decodedJ1
-
-journeyTest2 =
- expectSuccess "Journey2" journey j2 decodedJ2
-
-{-
-Odyssey ::= SEQUENCE {
- start Journey,
- trip1 [0] Journey OPTIONAL,
- trip2 [1] Journey OPTIONAL,
- trip3 [2] Journey OPTIONAL,
- end Journey
- }
--}
-
-odyssey =
- "Odyssey" ::=
- AbsSeq Universal 16 Implicit [
- Regular (Just "start" :>: (Nothing :@: journey)),
- Optional (Just "trip1" :>: (Just 0 :@: journey)),
- Optional (Just "trip2" :>: (Just 1 :@: journey)),
- Optional (Just "trip3" :>: (Just 2 :@: journey)),
- Regular (Just "end" :>: (Nothing :@: journey))
- ]
-
-prej1 = [
- Primitive Universal 22 3 [97,97,98],
- Primitive Context 0 3 [99,100,101],
- Primitive Context 1 3 [102,103,104],
- Primitive Universal 22 3 [97,97,98]
- ]
-
-o1 =
- Constructed Universal 16 130 [
- j1,
- Constructed Context 0 26 prej1,
- Constructed Context 1 26 prej1,
- Constructed Context 2 26 prej1,
- j1
- ]
-
-o2 =
- Constructed Universal 16 52 [
- j1,
- j1
- ]
-
-data Odyssey =
- Odyssey {
- start :: Journey,
- trip1 :: Maybe Journey,
- trip2 :: Maybe Journey,
- trip3 :: Maybe Journey,
- end :: Journey
- }
- deriving (Eq,Show)
-
-instance Encode Odyssey where
- decode a b =
- do x <- b
- let as = absSeqComponents a
- bs = encodedDefComps x
- return $
- Odyssey {
- start = fromJust (decode (as!!0) (bs!!0)),
- trip1 = do decode (as!!1) (bs!!1),
- trip2 = do decode (as!!2) (bs!!2),
- trip3 = do decode (as!!3) (bs!!3),
- end = fromJust (decode (as!!4) (bs!!4))
- }
-
-decodedO1 =
- Odyssey {
- start = decodedJ1,
- trip1 = Just decodedJ1,
- trip2 = Just decodedJ1,
- trip3 = Just decodedJ1,
- end = decodedJ1
- }
-
-decodedO2 =
- Odyssey {
- start = decodedJ1,
- trip1 = Nothing,
- trip2 = Nothing,
- trip3 = Nothing,
- end = decodedJ1
- }
-
-odysseyTest1 =
- expectSuccess "Odyssey1" odyssey o1 decodedO1
-
-odysseyTest2 =
- expectSuccess "Odyssey2" odyssey o2 decodedO2
-
-{-
-FunnyOptional ::=
- SEQUENCE {
- perhaps [0] IA5String OPTIONAL
- }
--}
-
-funnyOptional =
- "FunnyOptional" ::=
- AbsSeq Universal 16 Implicit [
- Optional (Just "perhaps" :>: (Just 0 :@: absIA5String))
- ]
-
-fo1 =
- Constructed Universal 16 7 [
- Primitive Context 0 3 [97,97,98]
- ]
-
-fo2 = Constructed Universal 16 0 []
-
-data FunnyOptional =
- FunnyOptional {
- perhaps :: Maybe IA5String
- }
- deriving (Eq,Show)
-
-instance Encode FunnyOptional where
- decode a b =
- do x <- b
- let as = absSeqComponents a
- bs = encodedDefComps x
- return $
- FunnyOptional {
- perhaps = do decode (as!!0) (bs!!0)
- }
-
-decodedFO1 =
- FunnyOptional {
- perhaps = Just $ IA5String "aab"
- }
-
-funnyOptionalTest1 =
- expectSuccess "FunnyOptional1" funnyOptional fo1 decodedFO1
-
-decodedFO2 =
- FunnyOptional {
- perhaps = Nothing
- }
-
-funnyOptionalTest2 =
- expectSuccess "FunnyOptional2" funnyOptional fo2 decodedFO2
-
-
-{-
-Some ANY DEFINED BY tests. See the former versions of the ASN.1
-standards, X.208 and X.209, sometimes referred to as ASN.1:1988 or
-ASN.1:1990. This was used in some definitions of X.509 certificates,
-for example:
-
-AlgorithmIdentifier ::= SEQUENCE {
- algorithm OBJECT IDENTIFIER,
- parameters ANY DEFINED BY algorithm OPTIONAL }
- -- contains a value of the type
- -- registered for use with the
- -- algorithm object identifier value
--}
-
-{-
-TextBook = SEQUENCE
- {
- author PrintableString,
- citationType OID,
- reference ANY DEFINED BY CitationType
- }
--}
-
-textBook =
- "TextBook" ::=
- AbsSeq Universal 16 Implicit
- [Regular (Just "author" :>: (Nothing :@: absPrintableString)),
- Regular (Just "citationType" :>: (Nothing :@: absOID)),
- AnyDefBy 1]
-
-data TextBook =
- TextBook {
- author :: PrintableString,
- citationType :: OID,
- reference :: PrintableString
- }
- deriving (Eq,Show)
-
-instance Encode TextBook where
- decode a b =
- do x <- b
- let as = absSeqComponents a
- bs = encodedDefComps x
- return $
- TextBook {
- author = fromJust $ decode (as!!0) (bs!!0),
- citationType = fromJust $ decode (as!!1) (bs!!1),
- reference = fromJust $ decode (as!!2) (bs!!2)
- }
-
-encodedPrintableString1 =
- Primitive Universal 19 5 [104,101,108,108,111]
-
-encodedPrintableString2 =
- Primitive Universal 19 5 [105,101,108,108,111]
-
-encodedPrintableString3 =
- Primitive Universal 19 5 [106,101,108,108,111]
-
-encodedPrintableString4 =
- Primitive Universal 19 5 [107,101,108,108,111]
-
-encodedOID1 = Primitive Universal 6 3 [85,4,7]
-
-encodedTextBook1 =
- Constructed Universal 16 13 [
- encodedPrintableString1,
- encodedOID1
- ]
-
-decodedTextBook1 =
- "user error (Checking AnyDefBy 1: insufficient components)"
-
-encodedTextBook2 =
- Constructed Universal 16 13 [
- encodedPrintableString1,
- encodedOID1,
- encodedPrintableString2
- ]
-
-decodedTextBook2 =
- TextBook {
- author = PrintableString "hello",
- citationType = OID [2,5,4,7],
- reference = PrintableString "iello"
- }
-
-encodedTextBook3 =
- Constructed Universal 16 13 [
- encodedPrintableString3,
- encodedOID1,
- encodedPrintableString4
- ]
-
-decodedTextBook3 =
- TextBook {
- author = PrintableString "jello",
- citationType = OID [2,5,4,7],
- reference = PrintableString "kello"
- }
-
-textBookTest1 =
- expectFailure "TextBook1" textBook encodedTextBook1 decodedTextBook1
-
-textBookTest2 =
- expectSuccess "TextBook2" textBook encodedTextBook2 decodedTextBook2
-
-textBookTest3 =
- expectSuccess "TextBook3" textBook encodedTextBook3 decodedTextBook3
-
-library =
- "Library" ::=
- AbsSeq Universal 16 Implicit
- [Regular (Just "first" :>: (Nothing :@: textBook)),
- Regular (Just "second" :>: (Nothing :@: textBook))]
-
-data Library =
- Library {
- first :: TextBook,
- second :: TextBook
- }
- deriving (Eq,Show)
-
-instance Encode Library where
- decode a b =
- do x <- b
- let as = absSeqComponents a
- bs = encodedDefComps x
- return $
- Library {
- first = fromJust $ decode (as!!0) (bs!!0),
- second = fromJust $ decode (as!!1) (bs!!1)
- }
-
-encodedLibrary =
- Constructed Universal 16 28 [encodedTextBook2,encodedTextBook3]
-
-decodedLibrary =
- Library {
- first = decodedTextBook2,
- second = decodedTextBook3
- }
-
-libraryTest =
- expectSuccess "Library1" library encodedLibrary decodedLibrary
-
-v1 = Primitive Universal 26 5 [104,101,108,108,111] -- Valid
-v2 = Primitive Universal 26 5 [103,101,108,108,111] -- Valid
-v3 = Primitive Universal 26 5 [31,101,108,108,111] -- Not valid VisibleString
-
-expectedv1 = VisibleString "hello"
-expectedv2 = VisibleString "gello"
-expectedv3 =
- "user error (Checking \"VisibleString\": type not compatible " ++
- "with values [31,101,108,108,111])"
-
-visibleStringTest1 =
- expectSuccess "VisibleString1" absVisibleString v1 expectedv1
-
-visibleStringTest2 =
- expectSuccess "VisibleString2" absVisibleString v2 expectedv2
-
-visibleStringTest3 =
- expectFailure "VisibleString3" absVisibleString v3 expectedv3
-
-{-
-A modified version of the example in Annex A of X.690 (ISO 8825-1).
--}
-
-{-
-Name ::= [APPLICATION 1] IMPLICIT SEQUENCE
- {givenName VisibleString,
- initial VisibleString,
- familyName VisibleString}
--}
-
-name =
- "Name" ::=
- AbsSeq Application 1 Implicit [
- Regular (Just "givenName" :>: (Nothing :@: absVisibleString)),
- Regular (Just "initial" :>: (Nothing :@: absVisibleString)),
- Regular (Just "familyName" :>: (Nothing :@: absVisibleString))
- ]
-
-data Name = Name {givenName :: VisibleString,
- initial :: VisibleString,
- familyName :: VisibleString}
- deriving (Eq,Show)
-
-instance Encode Name where
- decode a b =
- do x <- b
- let as = absSeqComponents a
- bs = encodedDefComps x
- return $
- Name {
- givenName = fromJust $ decode (as!!0) (bs!!0),
- initial = fromJust $ decode (as!!1) (bs!!1),
- familyName = fromJust $ decode (as!!2) (bs!!2)
- }
-
-n1 = Constructed Application 1 14 [v1,v2] -- Invalid number
- -- of components
-
-n2 = Constructed Application 1 14 [v1] -- Invalid number
- -- of components
-
-n3 = Constructed Application 1 14 [] -- Invalid number
- -- of components
-
-n4 = Constructed Application 1 14 [v1,v2,v1] -- Valid
-
-n5 = Constructed Application 1 14 [v1,v2,v3] -- Invalid component
-
-expectedn1 =
- "user error (Checking Regular (Just \"familyName\" :>: " ++
- "(Nothing :@: (\"VisibleString\" ::= " ++
- "AbsBasePrim Universal 26 AbsVisibleString))): " ++
- "insufficient components)"
-
-nameTest1 =
- expectFailure "Name1" name n1 expectedn1
-
-expectedn2 =
- "user error (Checking Regular (Just \"initial\" :>: " ++
- "(Nothing :@: (\"VisibleString\" ::= " ++
- "AbsBasePrim Universal 26 AbsVisibleString))): " ++
- "insufficient components)"
-
-nameTest2 =
- expectFailure "Name2" name n2 expectedn2
-
-expectedn3 =
- "user error (Checking Regular (Just \"givenName\" :>: " ++
- "(Nothing :@: (\"VisibleString\" ::= " ++
- "AbsBasePrim Universal 26 AbsVisibleString))): " ++
- "insufficient components)"
-
-nameTest3 =
- expectFailure "Name3" name n3 expectedn3
-
-expectedn4 =
- Name {
- givenName = VisibleString "hello",
- initial = VisibleString "gello",
- familyName = VisibleString "hello"
- }
-
-nameTest4 =
- expectSuccess "Name4" name n4 expectedn4
-
-expectedn5 =
- "user error (Checking \"VisibleString\": " ++
- "type not compatible with values [31,101,108,108,111])"
-
-nameTest5 =
- expectFailure "Name5" name n5 expectedn5
-
-{-
-EmployeeNumber ::= [APPLICATION 2] IMPLICIT INTEGER
--}
-
-employeeNumber =
- "EmployeeNumber" ::= AbsRef Application 2 Implicit absInteger
-
-data EmployeeNumber = EmployeeNumber Integer
- deriving (Eq,Show)
-
-instance Encode EmployeeNumber where
- decode a b =
- do x <- decode a b
- return $ EmployeeNumber x
-
-en1 = Primitive Application 2 1 [0x33]
-
-decodedEN1 = EmployeeNumber 51
-
-enTest1 =
- expectSuccess "EmployeeNumber1" employeeNumber en1 decodedEN1
-
-{-
-Date ::= [APPLICATION 3] IMPLICIT VisibleString -- YYYYMMDD
--}
-
-date = "Date" ::=
- AbsRef Application 3 Implicit absVisibleString
-
-data Date = Date VisibleString
- deriving (Eq,Show)
-
-instance Encode Date where
- decode a b =
- do x <- decode a b
- return $ Date x
-
-b = "30/03/2003 19:37:34 GMT"
-a = "30/03/2004 19:37:34 GMT"
-
-nb = map (fromIntegral . ord) b
-na = map (fromIntegral . ord) a
-
-d1 = Constructed Application 3 7 [Primitive Universal 23 23 na] -- Invalid
-d2 = Primitive Application 3 6 nb -- Valid
-
-expectedD1 =
- "user error (Checking \"Date\": " ++
- "expected PRIMITIVE Tag found CONSTRUCTED Tag\n" ++
- "\"Date\" ::= AbsBasePrim Application 3 AbsVisibleString\n" ++
- show d1 ++ ")"
-
-decodedD2 = Date $ VisibleString b
-
-dateTest1 =
- expectFailure "Date1" date d1 expectedD1
-
-dateTest2 =
- expectSuccess "Date2" date d2 decodedD2
-
-{-
-ChildInformation ::= SEQUENCE
- { name Name,
- dateOfBirth [0] Date}
--}
-
-childInformation =
- "ChildInformation" ::=
- AbsSeq Universal 16 Implicit [
- Regular (Just "name" :>: (Nothing :@: name)),
- Regular (Just "dateOfBirth" :>: (Just 0 :@: date))
- ]
-
-data ChildInformation =
- ChildInformation { name1 :: Name,
- dateOfBirth :: Date }
- deriving (Eq,Show)
-
-instance Encode ChildInformation where
- decode a b =
- do x <- b
- let as = absSeqComponents a
- bs = encodedDefComps x
- return $
- ChildInformation {
- name1 = fromJust $ decode (as!!0) (bs!!0),
- dateOfBirth = fromJust $ decode (as!!1) (bs!!1)
- }
-
-ci1 = Constructed Universal 16 28
- [n4,Primitive Context 0 6 nb]
-
-expectedCI1 =
- ChildInformation {
- name1 = expectedn4,
- dateOfBirth = decodedD2
- }
-
-ciTest1 =
- expectSuccess "ChildInformation1" childInformation ci1 expectedCI1
-
-{-
-PersonnelRecord ::= [APPLICATION 0] IMPLICIT SEQUENCE {
- name Name,
- title [0] VisibleString,
- number EmployeeNumber,
- dateOfHire [1] Date,
- nameOfSpouse [2] Name,
- children [3] IMPLICIT
- SEQUENCE OF ChildInformation DEFAULT {} }
--}
-
-personnelRecord =
- "PersonnelRecord" ::=
- AbsSeq Application 0 Implicit [
- Regular (Just "name" :>: (Nothing :@: name)),
- Regular (Just "title" :>: (Just 0 :@: absVisibleString)),
- Regular (Just "number" :>: (Nothing :@: employeeNumber)),
- Regular (Just "dateOfHire" :>: (Just 1 :@: date)),
- Regular (Just "nameOfSpouse" :>: (Just 2 :@: name)),
- Regular (
- Just "children" :>: (
- Just 3 :@: (
- "SEQUENCE OF ChildInformation" ::=
- AbsSeqOf Universal 16 Implicit childInformation
- )
- )
- )
- ]
-
-data PersonnelRecord =
- PersonnelRecord {name2 :: Name,
- title :: VisibleString,
- number :: EmployeeNumber,
- dateOfHire :: Date,
- nameOfSpouse :: Name,
- children :: [ChildInformation]}
- deriving (Eq,Show)
-
-instance Encode PersonnelRecord where
- decode a b =
- do x <- b
- let as = absSeqComponents a
- bs = encodedDefComps x
- return $
- PersonnelRecord {
- name2 = fromJust $ decode (as!!0) (bs!!0),
- title = fromJust $ decode (as!!1) (bs!!1),
- number = fromJust $ decode (as!!2) (bs!!2),
- dateOfHire = fromJust $ decode (as!!3) (bs!!3),
- nameOfSpouse = fromJust $ decode (as!!4) (bs!!4),
- children = fromJust $ decode (as!!5) (bs!!5)}
-
-pr1 =
- Constructed Application 0 23 [
- n4,
- Primitive Context 0 5 [104,101,108,108,111],
- en1,
- Primitive Context 1 6 nb,
- Constructed Context 2 14 [v1,v2,v1],
- Constructed Context 3 30 [ci1]
--- Constructed Context 3 18 [Constructed Universal 16 16 [ci1]]
- ]
-
-decodedpr1 =
- PersonnelRecord {
- name2 = expectedn4,
- title = expectedv1,
- number = decodedEN1,
- dateOfHire = decodedD2,
- nameOfSpouse = expectedn4,
- children = [expectedCI1]
- }
-
-prTest1 =
- expectSuccess "PersonnelRecord1" personnelRecord pr1 decodedpr1
-
-taggedRecord =
- "PersonnelRecord" ::=
- AbsSeq Application 0 Implicit [
- Regular (Just "name" :>: (Nothing :@: name)),
- Regular (Just "nameOfSpouse" :>: (Just 2 :@: name))
- ]
-
-tr1 =
- Constructed Application 0 23 [
- n4,
- Constructed Context 2 14 [v1,v2,v1]
- ]
-
-taggedRecord1 =
- "PersonnelRecord" ::=
- AbsSeq Application 0 Implicit [
- Regular (Just "name" :>: (Nothing :@: name)),
- Regular (Just "title" :>: (Just 0 :@: absVisibleString)),
- Regular (Just "number" :>: (Nothing :@: employeeNumber)),
- Regular (Just "dateOfHire" :>: (Just 1 :@: date)),
- Regular (Just "nameOfSpouse" :>: (Just 2 :@: name)),
- Regular (Just "another" :>: (Just 3 :@: name))
- ]
-
-tr2 =
- Constructed Application 0 23 [
- n4,
- Primitive Context 0 5 [104,101,108,108,111],
- en1,
- Primitive Context 1 6 nb,
- Constructed Context 2 14 [v1,v2,v1],
- Constructed Context 3 14 [v1,v2,v1]
- ]
-
-taggedRecord2 =
- "PersonnelRecord" ::=
- AbsSeq Application 0 Implicit [
- Regular (Just "name" :>: (Nothing :@: name)),
- Regular (
- Just "children" :>: (
- Just 3 :@: (
- "SEQUENCE OF ChildInformation" ::=
- AbsSeqOf Universal 16 Implicit childInformation
- )
- )
- )
- ]
-
-tr3 =
- Constructed Application 0 23 [
- n4,
- Constructed Context 3 18 [Constructed Universal 16 16 [ci1]]
- ]
-
-taggedRecord3 =
- "TaggedRecord3" ::=
- AbsSeq Application 0 Implicit [
- Regular (
- Just "children" :>: (
- Just 3 :@: (
- "SEQUENCE OF ChildInformation" ::=
- AbsSeqOf Universal 16 Implicit childInformation
- )
- )
- )
- ]
-
-tr4 =
- Constructed Application 0 23 [
- Constructed Context 3 18 [Constructed Universal 16 16 [ci1]]
- ]
-
-sequenceOfChildInformation =
- "SEQUENCE OF ChildInformation" ::=
- AbsSeqOf Universal 16 Implicit childInformation
-
-soci1 = Constructed Universal 16 30 [ci1]
-
-tr5 =
- Constructed Application 0 32 [
- Constructed Context 3 30 [ci1]
- ]
-
-taggedRecord4 =
- "TaggedRecord3" ::=
- AbsSeq Application 0 Implicit [
- Regular (Just "children" :>: (Just 3 :@: sequenceOfChildInformation))
- ]
-
-{-
- Choice1 ::= CHOICE {
- z1 [0] EmployeeNumber,
- z2 [1] EmployeeNumber,
- z3 [2] EmployeeNumber
- }
- A ::= CHOICE {
- b B,
- c C
- }
- B ::= CHOICE {
- d [0] NULL,
- e [1] NULL
- }
- C ::= CHOICE {
- f [2] NULL,
- g [3] NULL
- }
--}
-
-choice1 =
- "Choice1" ::=
- AbsChoice [
- (Implicit, Just "z1" :>: (Just 0 :@: employeeNumber)),
- (Implicit, Just "z2" :>: (Just 1 :@: employeeNumber)),
- (Implicit, Just "z3" :>: (Just 2 :@: employeeNumber))
- ]
-
-c1 = Primitive Context 0 1 [0x33]
-c2 = Primitive Context 1 1 [0x33]
-c3 = Primitive Context 2 1 [0x33]
-c4 = Primitive Context 3 1 [0x33]
-
-decodedC1 = Z1 (EmployeeNumber' 51)
-decodedC2 = Z2 (EmployeeNumber' 51)
-decodedC3 = Z3 (EmployeeNumber' 51)
-
-data Choice1 =
- Z1 EmployeeNumber' |
- Z2 EmployeeNumber' |
- Z3 EmployeeNumber'
- deriving (Eq,Show)
-
-instance Encode Choice1 where
- decode a b =
- do x <- b
- let t = defaultedTagValue x
- case t of
- 0 -> do foo <- decode a b
- return $ Z1 foo
- 1 -> do foo <- decode a b
- return $ Z2 foo
- 2 -> do foo <- decode a b
- return $ Z3 foo
-
-{-
-EmployeeNumber ::= [APPLICATION 2] IMPLICIT INTEGER
--}
-
-employeeNumber' =
- "EmployeeNumber" ::= AbsRef Application 2 Implicit absInteger
-
-data EmployeeNumber' = EmployeeNumber' Integer
- deriving (Eq,Show)
-
-instance Encode EmployeeNumber' where
- decode a b =
- do x <- decode a b
- return $ EmployeeNumber' x
-
-tChoice11 =
- expectSuccess "Choice1" choice1 c1 decodedC1
-
-choice2 =
- "A" ::=
- AbsChoice [
- (Implicit, Just "b" :>: (Nothing :@: choice3)),
- (Implicit, Just "c" :>: (Nothing :@: choice4))
- ]
-
-data Choice2 =
- B Choice3 |
- C Choice4
- deriving (Eq,Show)
-
-instance Encode Choice2 where
- decode a b =
- do x <- b
- let t = defaultedTagValue x
- f t
- | t `elem` [0,1] =
- do foo <- decode a b
- return $ B foo
- | t `elem` [2,3] =
- do foo <- decode a b
- return $ C foo
- f t
-
-decodedCBD = B decodedCD
-decodedCBE = B decodedCE
-
-tChoice21 =
- expectSuccess "Choice2BD" choice2 c1 decodedCBD
-
-tChoice22 =
- expectSuccess "Choice2BE" choice2 c2 decodedCBE
-
-choice3 =
- "B" ::=
- AbsChoice [
- (Implicit, Just "d" :>: (Just 0 :@: employeeNumber)),
- (Implicit, Just "e" :>: (Just 1 :@: employeeNumber))
- ]
-
-decodedCD = D (EmployeeNumber' 51)
-decodedCE = E (EmployeeNumber' 51)
-
-data Choice3 =
- D EmployeeNumber' |
- E EmployeeNumber'
- deriving (Eq,Show)
-
-instance Encode Choice3 where
- decode a b =
- do x <- b
- let t = defaultedTagValue x
- case t of
- 0 -> do foo <- decode a b
- return $ D foo
- 1 -> do foo <- decode a b
- return $ E foo
-
-tChoice31 =
- expectSuccess "Choice3D" choice3 c1 decodedCD
-
-tChoice32 =
- expectSuccess "Choice3E" choice3 c2 decodedCE
-
-choice4 =
- "C" ::=
- AbsChoice [
- (Implicit, Just "f" :>: (Just 2 :@: employeeNumber)),
- (Implicit, Just "g" :>: (Just 3 :@: employeeNumber))
- ]
-
-decodedCF = F (EmployeeNumber' 51)
-decodedCG = G (EmployeeNumber' 51)
-
-data Choice4 =
- F EmployeeNumber' |
- G EmployeeNumber'
- deriving (Eq,Show)
-
-instance Encode Choice4 where
- decode a b =
- do x <- b
- let t = defaultedTagValue x
- case t of
- 2 -> do foo <- decode a b
- return $ F foo
- 3 -> do foo <- decode a b
- return $ G foo
-
-tChoice43 =
- expectSuccess "Choice4F" choice4 c3 decodedCF
-
-tChoice44 =
- expectSuccess "Choice4G" choice2 c4 decodedCG
-
-{-
-NoTags ::= CHOICE {
- myInt INTEGER,
- myIA5 IA5String
- }
--}
-
-noTags =
- "NoTags" ::=
- AbsChoice [
- (Implicit, Just "myInt" :>: (Nothing :@: absInteger)),
- (Implicit, Just "myIA5" :>: (Nothing :@: absIA5String))
- ]
-
-nt1 = Primitive Universal 2 1 [0x33]
-nt2 = Primitive Universal 22 1 [0x33]
-nt3 = Primitive Universal 3 1 [0x33]
-nt4 = Primitive Universal 23 1 [0x33]
-
-decodedNT1 = MyInt 51
-decodedNT2 = MyIA5 (IA5String "3")
-
-data NoTags =
- MyInt Integer |
- MyIA5 IA5String
- deriving (Eq,Show)
-
-instance Encode NoTags where
- decode a b =
- do x <- b
- let t = defaultedTagValue x
- f t
- | t `elem` [2] =
- do foo <- decode a b
- return $ MyInt foo
- | t `elem` [22] =
- do foo <- decode a b
- return $ MyIA5 foo
- f t
-
-tNoTags1 =
- expectSuccess "NoTags1" noTags nt1 decodedNT1
-
-tNoTags2 =
- expectSuccess "NoTags2" noTags nt2 decodedNT2
-
-{-
- ExplicitChoice ::= CHOICE {
- x1 [0] EXPLICIT EmployeeNumber,
- x2 [1] EXPLICIT EmployeeNumber,
- x3 [2] EXPLICIT EmployeeNumber
- }
--}
-
-explicitChoice =
- "ExplicitChoice" ::=
- AbsChoice [
- (Explicit, Just "z1" :>: (Just 0 :@: employeeNumber)),
- (Explicit, Just "z2" :>: (Just 1 :@: employeeNumber)),
- (Explicit, Just "z3" :>: (Just 2 :@: employeeNumber))
- ]
-
-ec1 = Constructed Context 0 3 [en1]
-ec2 = Constructed Context 1 3 [en1]
-ec3 = Constructed Context 2 3 [en1]
-ec4 = Constructed Context 3 3 [en1]
-
-foo e =
- do (w,x) <- typeCheck explicitChoice e
- putStrLn (show x)
- putStrLn (show w)
- let (_ ::= c) = w
- d = decode c (Just x)
- (Just y) = d::(Maybe ExplicitChoice)
- putStrLn (show y)
-
-
-data ExplicitChoice =
- X1 EmployeeNumber |
- X2 EmployeeNumber |
- X3 EmployeeNumber
- deriving (Eq,Show)
-
-instance Encode ExplicitChoice where
- decode a b =
- do x <- b
- let t = defaultedTagValue x
- a' = absRefedType a
- b' = (encodedDefComps x)!!0
- foo <- decode a' b'
- case t of
- 0 -> return (X1 foo)
- 1 -> return (X2 foo)
- 2 -> return (X3 foo)
-
-{-
-We can't put this in a test yet as w does not return something
-that can be decoded mechanically. It needs more investigation but
-is probably because EXPLICIT doesn't get handled correctly either
-for CHOICE or SEQUENCE.
--}
-
-version = modName "Version" absInteger
-
-type Version = Integer
-
-certificateVersion =
- "version" ::= AbsRef Context 0 Explicit version
-
-data CertificateVersion =
- CertificateVersion Version
- deriving (Eq,Show)
-
-instance Encode CertificateVersion where
- decode a b =
- do y <- b
- let a' = absRefedType a
- b' = (encodedDefComps y)!!0
- x <- decode a' b'
- return $ CertificateVersion x
-
-
-ver1 =
- Constructed Universal 16 17 [
- Constructed Context 0 3 [
- Primitive Universal 2 1 [2]
- ],
- Primitive Universal 2 10 [25,139,17,209,63,154,143,254,105,160]
- ]
-
-ver2 =
- Constructed Context 0 3 [
- Primitive Universal 2 1 [2]
- ]
-
-decodedVer2 = CertificateVersion 2
-
-bar =
- do (w,x) <- typeCheck certificateVersion ver2
- putStrLn (show x)
- putStrLn (show w)
- let (_ ::= c) = w
- d = decode c (Just x)
- (Just y) = d::(Maybe CertificateVersion)
- putStrLn (show y)
-
-tVer1 = expectSuccess "Version1" certificateVersion ver2 decodedVer2
-
-tests =
- TestList [
- tagTest1, tagTest2, tagTest3, tagTest4,
- textBookTest1, textBookTest2, textBookTest3, libraryTest,
- visibleStringTest1, visibleStringTest2, visibleStringTest3,
- nameTest1, nameTest2, nameTest3, nameTest4, nameTest5,
- enTest1, dateTest1, dateTest2, ciTest1,
- prTest1, journeyTest1, journeyTest2, odysseyTest1,
- odysseyTest2, funnyOptionalTest1, funnyOptionalTest2,
- tChoice11, tChoice31, tChoice32, tChoice43, tChoice44,
- tChoice21, tChoice22, tNoTags1, tNoTags2, tVer1
- ]
-
-main = runTestTT tests
-
-{-
-051217083900
-
-Three (at least) things to think about.
-
-1. Real errors in choice. At the moment, all errors get treated
-as a trigger to try the next alternative.
-
-2. Typechecking a reference returns the abstract BER representation
-of the referenced element. Should this be the whole element?
-
-3. SEQUENCE elements can be IMPLICIT or EXPLICIT. Currently all are
- treated as IMPLICIT because of
-
-k (Regular (mn :>: (tv :@: td)):as) (bv:bvs) =
- do foo <- lift $ case tv of
- Nothing ->
- tc td bv
- Just v ->
- case mn of
- Nothing ->
- tc ("" ::= AbsRef Context v Implicit td) bv
- Just name ->
- tc (name ::= AbsRef Context v Implicit td) bv
--}
diff --git a/BERTest2.hs b/BERTest2.hs
deleted file mode 100644
index b879a4d..0000000
--- a/BERTest2.hs
+++ /dev/null
@@ -1,782 +0,0 @@
-module Main(main) where
-
-import Data.Char
-import Data.Maybe
-import Control.Monad.Error
-import Control.Monad.State
-import Language.ASN1.BER
-import Language.ASN1
-import Language.ASN1.X509
-import Language.ASN1.InformationFramework(
- generalNames,
- GeneralNames,
- rdnSequence,
- RDNSequence(..),
- GeneralName(..),
- GeneralNames(..),
- Name(..)
- )
-import Language.ASN1.X509.AttributeCertificateDefinitions (
- AttributeCertificate,
- attributeCertificate,
- Holder(..),
- holder,
- holder',
- HolderGeneralNames(..),
- holderGeneralNames,
- AttCertIssuer(..),
- attCertIssuer,
- IssuerSerial(..),
- issuerSerial,
- Attribute(..),
- attribute,
- AttributeValue(..)
- )
-import Test.HUnit
-import System.IO
-import System.Environment
-import System.Console.GetOpt
--- import Codec.Utils
-import Language.ASN1.TLV
-import NewBinary.Binary
-
-expectSuccess testName asnType berValue expectedAbsValue =
- TestCase $
- do (w,x) <- typeCheck' asnType berValue
- let (_ ::= c) = w
- d = decode c (Just x)
- (Just y) = d
- assertEqual testName expectedAbsValue y
-
-expectFailure testName asnType berValue expectedError =
- TestCase $
- do x <- (do y <- typeCheck' asnType berValue
- return "Unexpected successful typechecking")
- `catchError` (\e -> return $ show e)
- assertEqual testName x expectedError
-
-testHolder=
- Constructed Universal 16 56 [
- Constructed Context 1 54 [
- Constructed Context 4 52 [
- Constructed Universal 16 50 [
- Constructed Universal 17 11 [
- Constructed Universal 16 9 [
- Primitive Universal 6 3 [85,4,6],
- Primitive Universal 19 2 [85,75]
- ]
- ],
- Constructed Universal 17 17 [
- Constructed Universal 16 15 [
- Primitive Universal 6 3 [85,4,7],
- Primitive Universal 19 8 [75,105,110,103,115,116,111,110]
- ]
- ],
- Constructed Universal 17 16 [
- Constructed Universal 16 14 [
- Primitive Universal 6 3 [85,4,3],
- Primitive Universal 19 7 [68,111,109,105,110,105,99]
- ]
- ]
- ]
- ]
- ]
- ]
-
-decodedHolder =
- Holder {
- entityName = Just (
- HolderGeneralNames (
- decodedGNs
- )
- )
- }
-
-tHolder =
- expectSuccess "Holder" holder' testHolder decodedHolder
-
-testGNs =
- Constructed Universal 16 54 [
- Constructed Context 4 52 [
- Constructed Universal 16 50 [
- Constructed Universal 17 11 [
- Constructed Universal 16 9 [
- Primitive Universal 6 3 [85,4,6],
- Primitive Universal 19 2 [85,75]
- ]
- ],
- Constructed Universal 17 17 [
- Constructed Universal 16 15 [
- Primitive Universal 6 3 [85,4,7],
- Primitive Universal 19 8 [75,105,110,103,115,116,111,110]
- ]
- ],
- Constructed Universal 17 16 [
- Constructed Universal 16 14 [
- Primitive Universal 6 3 [85,4,3],
- Primitive Universal 19 7 [68,111,109,105,110,105,99]
- ]
- ]
- ]
- ]
- ]
-
-decodedGNs =
- GeneralNames [
- DirectoryName (
- Name (
- RDNSequence [
- RelativeDistinguishedName (
- SetOf [
- AttributeTypeAndValue {
- type1 = OID [2,5,4,6],
- value = PS (PrintableString "UK")
- }
- ]
- ),
- RelativeDistinguishedName (
- SetOf [
- AttributeTypeAndValue {
- type1 = OID [2,5,4,7],
- value = PS (PrintableString "Kingston")
- }
- ]
- ),
- RelativeDistinguishedName (
- SetOf [
- AttributeTypeAndValue {
- type1 = OID [2,5,4,3],
- value = PS (PrintableString "Dominic")
- }
- ]
- )
- ]
- )
- )
- ]
-
-foo =
- do (w,x) <- typeCheck' generalNames testGNs
- putStrLn (show x)
- putStrLn (show w)
-
-tGeneralNames =
- expectSuccess "GeneralNames" generalNames testGNs decodedGNs
-
-testRDNS =
- Constructed Universal 16 50 [
- Constructed Universal 17 11 [
- Constructed Universal 16 9 [
- Primitive Universal 6 3 [85,4,6],
- Primitive Universal 19 2 [85,75]
- ]
- ],
- Constructed Universal 17 17 [
- Constructed Universal 16 15 [
- Primitive Universal 6 3 [85,4,7],
- Primitive Universal 19 8 [75,105,110,103,115,116,111,110]
- ]
- ],
- Constructed Universal 17 16 [
- Constructed Universal 16 14 [
- Primitive Universal 6 3 [85,4,3],
- Primitive Universal 19 7 [68,111,109,105,110,105,99]
- ]
- ]
- ]
-
-decodedRDNS =
- RDNSequence [
- RelativeDistinguishedName (
- SetOf [
- AttributeTypeAndValue {
- type1 = OID [2,5,4,6],
- value = PS (PrintableString "UK")
- }
- ]
- ),
- RelativeDistinguishedName (
- SetOf [
- AttributeTypeAndValue {
- type1 = OID [2,5,4,7],
- value = PS (PrintableString "Kingston")
- }
- ]
- ),
- RelativeDistinguishedName (
- SetOf [
- AttributeTypeAndValue {
- type1 = OID [2,5,4,3],
- value = PS (PrintableString "Dominic")
- }
- ]
- )
- ]
-
-tRDNSequence =
- expectSuccess "RDNSequence" rdnSequence testRDNS decodedRDNS
-
-testHGNs =
- Constructed Context 1 17 [
- Constructed Context 4 15 [
- Constructed Universal 16 13 [
- Constructed Universal 17 11 [
- Constructed Universal 16 9 [
- Primitive Universal 6 3 [85,4,6],
- Primitive Universal 19 2 [85,75]
- ]
- ]
- ]
- ]
- ]
-
-testHGNs' =
- Constructed Context 1 54 [
- Constructed Context 4 52 [
- Constructed Universal 16 50 [
- Constructed Universal 17 11 [
- Constructed Universal 16 9 [
- Primitive Universal 6 3 [85,4,6],
- Primitive Universal 19 2 [85,75]
- ]
- ],
- Constructed Universal 17 17 [
- Constructed Universal 16 15 [
- Primitive Universal 6 3 [85,4,7],
- Primitive Universal 19 8 [75,105,110,103,115,116,111,110]
- ]
- ],
- Constructed Universal 17 16 [
- Constructed Universal 16 14 [
- Primitive Universal 6 3 [85,4,3],
- Primitive Universal 19 7 [68,111,109,105,110,105,99]
- ]
- ]
- ]
- ]
- ]
-
-decodedHGNs =
- HolderGeneralNames (
- GeneralNames [
- DirectoryName (
- Name (
- RDNSequence [
- RelativeDistinguishedName (
- SetOf [
- AttributeTypeAndValue {
- type1 = OID [2,5,4,6],
- value = PS (PrintableString "UK")
- }
- ]
- )
- ]
- )
- )
- ]
- )
-
-tHGNs =
- expectSuccess "HGNs" holderGeneralNames testHGNs decodedHGNs
-
-decodedHGNs' =
- HolderGeneralNames (
- decodedGNs
- )
-
-tHGNs' =
- expectSuccess "HGNs'" holderGeneralNames testHGNs' decodedHGNs'
-
-testACI =
- Constructed Context 0 124 [
- Constructed Universal 16 63 [
- Constructed Context 4 61 [
- Constructed Universal 16 59 [
- Constructed Universal 17 11 [
- Constructed Universal 16 9 [
- Primitive Universal 6 3 [85,4,6],
- Primitive Universal 19 2 [71,66]
- ]
- ],
- Constructed Universal 17 15 [
- Constructed Universal 16 13 [
- Primitive Universal 6 3 [85,4,10],
- Primitive Universal 19 6 [80,69,82,77,73,83]
- ]
- ],
- Constructed Universal 17 27 [
- Constructed Universal 16 25 [
- Primitive Universal 6 3 [85,4,3],
- Primitive Universal 19 18 [
- 65,32,80,101,114,109,105,115,32,84,101,115,
- 116,32,85,115,101,114
- ]
- ]
- ]
- ]
- ]
- ],
- Constructed Context 0 57 [
- Constructed Universal 16 52 [
- Constructed Context 4 50 [
- Constructed Universal 16 48 [
- Constructed Universal 17 11 [
- Constructed Universal 16 9 [
- Primitive Universal 6 3 [85,4,6],
- Primitive Universal 19 2 [71,66]
- ]
- ],
- Constructed Universal 17 15 [
- Constructed Universal 16 13 [
- Primitive Universal 6 3 [85,4,10],
- Primitive Universal 19 6 [80,69,82,77,73,83]
- ]
- ],
- Constructed Universal 17 16 [
- Constructed Universal 16 14 [
- Primitive Universal 6 3 [85,4,3],
- Primitive Universal 19 7 [82,111,111,116,32,67,65]
- ]
- ]
- ]
- ]
- ],
- Primitive Universal 2 1 [3]
- ]
- ]
-
-decodedACI =
- AttCertIssuer {
- issuerName = Just (
- GeneralNames [
- DirectoryName (
- Name (
- RDNSequence [
- RelativeDistinguishedName (
- SetOf [
- AttributeTypeAndValue {
- type1 = OID [2,5,4,6],
- value = PS (PrintableString "GB")
- }
- ]
- ),
- RelativeDistinguishedName (
- SetOf [
- AttributeTypeAndValue {
- type1 = OID [2,5,4,10],
- value = PS (PrintableString "PERMIS")
- }
- ]
- ),
- RelativeDistinguishedName (
- SetOf [
- AttributeTypeAndValue {
- type1 = OID [2,5,4,3],
- value = PS (PrintableString "A Permis Test User")
- }
- ]
- )
- ]
- )
- )
- ]
- ),
- baseCertificateID = Just (
- IssuerSerial {
- issuer1 = GeneralNames [
- DirectoryName (
- Name (
- RDNSequence [
- RelativeDistinguishedName (
- SetOf [
- AttributeTypeAndValue {
- type1 = OID [2,5,4,6],
- value = PS (PrintableString "GB")
- }
- ]
- ),
- RelativeDistinguishedName (
- SetOf [
- AttributeTypeAndValue {
- type1 = OID [2,5,4,10],
- value = PS (PrintableString "PERMIS")
- }
- ]
- ),
- RelativeDistinguishedName (
- SetOf [
- AttributeTypeAndValue {
- type1 = OID [2,5,4,3],
- value = PS (PrintableString "Root CA")
- }
- ]
- )
- ]
- )
- )
- ],
- serial = 3,
- issuerID = Nothing
- }
- )
- }
-
-tACI =
- expectSuccess "ACI" attCertIssuer testACI decodedACI
-
-testACI1 =
- Constructed Context 0 124 [
- Constructed Universal 16 63 [
- Constructed Context 4 61 [
- Constructed Universal 16 59 [
- Constructed Universal 17 11 [
- Constructed Universal 16 9 [
- Primitive Universal 6 3 [85,4,6],
- Primitive Universal 19 2 [71,66]
- ]
- ]
- ]
- ]
- ],
- Constructed Context 0 57 [
- Constructed Universal 16 52 [
- Constructed Context 4 50 [
- Constructed Universal 16 48 [
- Constructed Universal 17 11 [
- Constructed Universal 16 9 [
- Primitive Universal 6 3 [85,4,6],
- Primitive Universal 19 2 [71,66]
- ]
- ]
- ]
- ]
- ],
- Primitive Universal 2 1 [3]
- ]
- ]
-
-decodedACI1 =
- AttCertIssuer {
- issuerName = Just (
- GeneralNames [
- DirectoryName (
- Name (
- RDNSequence [
- RelativeDistinguishedName (
- SetOf [
- AttributeTypeAndValue {
- type1 = OID [2,5,4,6],
- value = PS (PrintableString "GB")
- }
- ]
- )
- ]
- )
- )
- ]
- ),
- baseCertificateID = Just (
- IssuerSerial {
- issuer1 = GeneralNames [
- DirectoryName (
- Name (
- RDNSequence [
- RelativeDistinguishedName (
- SetOf [
- AttributeTypeAndValue {
- type1 = OID [2,5,4,6],
- value = PS (PrintableString "GB")
- }
- ]
- )
- ]
- )
- )
- ],
- serial = 3,
- issuerID = Nothing
- }
- )
- }
-
-tACI1 =
- expectSuccess "ACI1" attCertIssuer testACI1 decodedACI1
-
-
-testACI2 =
- Constructed Context 0 124 [
- Constructed Context 0 57 [
- Constructed Universal 16 52 [
- Constructed Context 4 50 [
- Constructed Universal 16 48 [
- Constructed Universal 17 11 [
- Constructed Universal 16 9 [
- Primitive Universal 6 3 [85,4,6],
- Primitive Universal 19 2 [71,66]
- ]
- ]
- ]
- ]
- ],
- Primitive Universal 2 1 [3]
- ]
- ]
-
-decodedACI2 =
- AttCertIssuer {
- issuerName = Nothing,
- baseCertificateID = Just (
- IssuerSerial {
- issuer1 = GeneralNames [
- DirectoryName (
- Name (
- RDNSequence [
- RelativeDistinguishedName (
- SetOf [
- AttributeTypeAndValue {
- type1 = OID [2,5,4,6],
- value = PS (PrintableString "GB")
- }
- ]
- )
- ]
- )
- )
- ],
- serial = 3,
- issuerID = Nothing
- }
- )
- }
-
-tACI2 =
- expectSuccess "ACI2" attCertIssuer testACI2 decodedACI2
-
-testIssuerSerial =
- Constructed Universal 16 57 [
- Constructed Universal 16 52 [
- Constructed Context 4 50 [
- Constructed Universal 16 48 [
- Constructed Universal 17 11 [
- Constructed Universal 16 9 [
- Primitive Universal 6 3 [85,4,6],
- Primitive Universal 19 2 [71,66]
- ]
- ]
- ]
- ]
- ],
- Primitive Universal 2 1 [3]
- ]
-
-decodedIssuerSerial =
- IssuerSerial {
- issuer1 = GeneralNames [
- DirectoryName (
- Name (
- RDNSequence [
- RelativeDistinguishedName (
- SetOf [
- AttributeTypeAndValue {
- type1 = OID [2,5,4,6],
- value = PS (PrintableString "GB")
- }
- ]
- )
- ]
- )
- )
- ],
- serial = 3,
- issuerID = Nothing
- }
-
-tIssuerSerial =
- expectSuccess "IssuerSerial" issuerSerial testIssuerSerial decodedIssuerSerial
-
-setOfAny = [
- 0x30,0x17,0x06,0x0A,0x09,0x92,0x26,0x89,
- 0x93,0xF2,0x2C,0x64,0x01,0x01,0x31,0x09,
- 0x13,0x07,0x44,0x6F,0x6D,0x69,0x6E,0x69,
- 0x63
- ]
-
-decodedSetOfAny =
- Attribute {
- attributeType = OID [0,9,2342,19200300,100,1,1],
- attributeValues = SetOf [AVPS (PrintableString "Dominic")]
- }
-
-tSetOfAny =
- let (_,e) = tlv (map fromInteger setOfAny) in
- expectSuccess "SetOfAny" attribute e decodedSetOfAny
-
-typeCheck' :: TypeDefn -> Encoding -> IO (TypeDefn,Defaulted)
-
-{-
-typeCheck' a b =
- do ((q,r),_) <- runStateT (tc a b) []
- return (q,r)
--}
-
-typeCheck' = typeCheck
-
-{-
-TextBook = SEQUENCE {
- author PrintableString,
- citationType OID,
- reference ANY DEFINED BY citationType
- }
--}
-
-textBook =
- "TextBook" ::=
- AbsSeq Universal 16 Implicit
- [Regular (Just "author" :>: (Nothing :@: absPrintableString)),
- Regular (Just "citationType" :>: (Nothing :@: absOID)),
- AnyDefBy 1]
-
-data TextBook =
- TextBook {
- author :: PrintableString,
- citationType :: OID,
- reference :: Reference
- }
- deriving (Eq,Show)
-
-instance Encode TextBook where
- decode a b =
- do x <- b
- let as = absSeqComponents a
- bs = encodedDefComps x
- return $
- TextBook {
- author = fromJust $ decode (as!!0) (bs!!0),
- citationType = fromJust $ decode (as!!1) (bs!!1),
- reference = fromJust $ decode (as!!2) (bs!!2)
- }
-
-data Reference = ReferencePS PrintableString
- deriving (Eq,Show)
-
-instance Encode Reference where
- decode a@(AbsBasePrim _ _ AbsPrintableString) b =
- do x <- decode a b
- return (ReferencePS x)
- decode a b =
- error (show a ++ "\n" ++ show b)
-
-encodedPrintableString1 =
- Primitive Universal 19 5 [104,101,108,108,111]
-
-encodedPrintableString2 =
- Primitive Universal 19 5 [105,101,108,108,111]
-
-encodedOID1 = Primitive Universal 6 3 [85,4,7]
-
-encodedTextBook2 =
- Constructed Universal 16 13 [
- encodedPrintableString1,
- encodedOID1,
- encodedPrintableString2
- ]
-
-decodedTextBook =
- TextBook {
- author = PrintableString "hello",
- citationType = OID [2,5,4,7],
- reference = ReferencePS (PrintableString "iello")
- }
-
-tTextBook =
- expectSuccess "TextBook" textBook encodedTextBook2 decodedTextBook
-
-{-
-CollectionEntry = SEQUENCE
- {
- entry TextBook,
- category PrintableString,
- catagoriser PrintableString,
- catType OID,
- catNumber ANY DEFINED BY catType
- }
--}
-
-collection =
- "Collection" ::=
- AbsSeq Universal 16 Implicit [
- Regular (Just "entry" :>: (Nothing :@: textBook)),
- Regular (Just "category" :>: (Nothing :@: absPrintableString)),
- Regular (Just "catagoriser" :>: (Nothing :@: absPrintableString)),
- Regular (Just "catType" :>: (Nothing :@: absOID)),
- AnyDefBy 3
- ]
-
-data Collection =
- Collection {
- entry :: TextBook,
- category :: PrintableString,
- categoriser :: PrintableString,
- catType :: OID,
- catNumber :: CatNumber
- }
- deriving (Eq,Show)
-
-instance Encode Collection where
- decode a b =
- do x <- b
- let as = absSeqComponents a
- bs = encodedDefComps x
- return $
- Collection {
- entry = fromJust $ decode (as!!0) (bs!!0),
- category = fromJust $ decode (as!!1) (bs!!1),
- categoriser = fromJust $ decode (as!!2) (bs!!2),
- catType = fromJust $ decode (as!!3) (bs!!3),
- catNumber = fromJust $ decode (as!!4) (bs!!4)
- }
-
-data CatNumber = CatNumberPS PrintableString
- deriving (Eq,Show)
-
-instance Encode CatNumber where
- decode a@(AbsBasePrim _ _ AbsPrintableString) b =
- do x <- decode a b
- return (CatNumberPS x)
- decode a b =
- error (show a ++ "\n" ++ show b)
-
-encodedCollection =
- Constructed Universal 16 30 [
- encodedTextBook2,
- encodedPrintableString2,
- encodedPrintableString2,
- encodedOID1,
- encodedPrintableString1
- ]
-
-decodedCollection =
- Collection {
- entry = TextBook {
- author = PrintableString "hello",
- citationType = OID [2,5,4,7],
- reference = ReferencePS (PrintableString "iello")
- },
- category = PrintableString "iello",
- categoriser = PrintableString "iello",
- catType = OID [2,5,4,7],
- catNumber = CatNumberPS (PrintableString "hello")
- }
-
-tCollection =
- expectSuccess "Collection" collection encodedCollection decodedCollection
-
-tests =
- TestList [
- tRDNSequence, tGeneralNames, tHolder, tHGNs,
- tHGNs', tACI, tACI1, tACI2,
- tIssuerSerial, tSetOfAny, tTextBook, tCollection
- ]
-
-main = runTestTT tests
-
diff --git a/Language/ASN1.hs b/Language/ASN1.hs
index 31688bf..9047e63 100644
--- a/Language/ASN1.hs
+++ b/Language/ASN1.hs
@@ -30,7 +30,7 @@ module Language.ASN1 (
IA5String(..),
DirectoryString(..),
OID(..),
- NULL,
+ NULL(..),
OctetString(..),
BitString(..),
SetOf(..),
@@ -72,12 +72,12 @@ import Data.Word
type Octet = Word8
data TagType = Universal | Application | Context | Private
- deriving (Eq,Show, Enum)
+ deriving (Eq,Show,Enum,Ord)
type TagValue = Integer
data TagPlicity = Implicit | Explicit
- deriving (Eq,Show)
+ deriving (Eq,Show,Ord)
data AbsPrimType = AbsVisibleString
| AbsPrintableString
diff --git a/Language/ASN1/BER.hs b/Language/ASN1/BER.hs
index 08eefc2..ff09f44 100644
--- a/Language/ASN1/BER.hs
+++ b/Language/ASN1/BER.hs
@@ -61,7 +61,7 @@ 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 :: (MonadError e m) => TypeDefn -> Encoding -> m (TypeDefn,Defaulted)
typeCheck a b =
do ((q,r),_) <- runStateT (tc a b) []
diff --git a/Language/ASN1/X509.hs b/Language/ASN1/X509.hs
index 06e9bee..c8fe3d1 100644
--- a/Language/ASN1/X509.hs
+++ b/Language/ASN1/X509.hs
@@ -23,6 +23,7 @@ module Language.ASN1.X509 (
AttributeTypeAndValue(..),
RelativeDistinguishedName(..),
CertificateVersion,
+ Name(..),
-- * Type classes
-- * Function types
time,
diff --git a/PKCS8Example.hs b/PKCS8Example.hs
deleted file mode 100644
index a44dc0d..0000000
--- a/PKCS8Example.hs
+++ /dev/null
@@ -1,117 +0,0 @@
-module Main(main) where
-
-import System.IO
-import System.Environment
-import Control.Monad.Error
-import Control.Monad.State
-import Data.Maybe
-import Data.List (
- unfoldr,
- intersperse
- )
-import Numeric (
- showHex
- )
-import NewBinary.Binary
-import Language.ASN1.Utils (
- toOctets
- )
-import Language.ASN1.BER
-import Language.ASN1
-import Language.ASN1.TLV
-import Language.ASN1.PKCS8
-import Language.ASN1.X509 (
- algorithm1,
- parameters1
- )
-import Text.PrettyPrint
-
-pp pki rsapk =
- render (
- ppLabelString "Version" (show (version2 pki))
- $$
- ppLabelDoc "Private Key Algorithm" algid
- $$
- ppLabelDoc "Private Key" rs
- )
- where
- algid =
- ppLabelString "Algorithm" (show (algorithm1 al))
- $$
- ppLabelString "Parameters" (show (parameters1 al))
- al = privateKeyAlgorithm pki
- rs = ppLabelString "Version" (show (version1 rsapk))
- $$
- mod
- $$
- ppLabelDoc "Public Exponent" puE
- $$
- ppLabelDoc "Private Exponent" prE
- $$
- ppLabelDoc "Prime 1" p1
- $$
- ppLabelDoc "Prime 2" p2
- $$
- ppLabelDoc "Exponent 1" e1
- $$
- ppLabelDoc "Exponent 2" e2
- $$
- ppLabelDoc "Coefficient" co
- bar = map (map sh) (split 16 (toOctets 256 (modulus rsapk)))
- sh x | x < 16 = showHex x "0"
- | otherwise = showHex x ""
- split :: Int -> [a] -> [[a]]
- split n xs = unfoldr (g n) xs
- g :: Int -> [a] -> Maybe ([a],[a])
- g n y
- | length y == 0 = Nothing
- | otherwise = Just (splitAt n y)
- mods1 :: [[Doc]]
- mods1 = map (intersperse colon) (map (map text) bar)
- mods2 :: [Doc]
- mods2 = map hcat mods1
- mod = ppLabelDoc "Modulus" (vcat mods2)
- puE = hexify (publicExponent rsapk)
- prE = hexify (privateExponent rsapk)
- p1 = hexify (prime1 rsapk)
- p2 = hexify (prime2 rsapk)
- e1 = hexify (exponent1 rsapk)
- e2 = hexify (exponent2 rsapk)
- co = hexify (coefficient rsapk)
- hexify :: Integral a => a -> Doc
- hexify n =
- let bar = map (map sh) (split 16 (toOctets 256 n))
- foo = map (intersperse colon) (map (map text) bar)
- baz = vcat (map hcat foo)
- in baz
-
-ppLabelString :: String -> String -> Doc
-ppLabelString l x =
- text l <> colon <> space <> (text x)
-
-ppLabelDoc :: String -> Doc -> Doc
-ppLabelDoc l d =
- text l <> colon
- $$
- nest 3 d
-
-test fileName =
- do h <- openFile fileName ReadMode
- bin <- openBinIO_ h
- (l,x) <- tlvIO bin
- (w,y) <- typeCheck privateKeyInfo x
- let (_ ::= c) = w
- pk = (decode c (Just y))::(Maybe PrivateKeyInfo)
- (OctetString xs) = privateKey1 $ fromJust pk
- (l',x') = tlv xs
- (v,z) <- typeCheck rsaPrivateKey x'
- let (_ ::= e) = v
- rsapk = (decode e (Just z))::(Maybe RSAPrivateKey)
- putStrLn (pp (fromJust pk) (fromJust rsapk))
-
-main =
- do progName <- getProgName
- args <- getArgs
- if length args /= 1
- then putStrLn ("Usage: " ++ progName ++ " <fileName>")
- else test (args!!0)
diff --git a/X509Example.hs b/X509Example.hs
deleted file mode 100644
index 0f67a6f..0000000
--- a/X509Example.hs
+++ /dev/null
@@ -1,120 +0,0 @@
-module Main(main) where
-
-import System.IO
-import System.Environment
-import Control.Monad.Error
-import Data.Maybe
-import Data.List
-import Numeric
-import NewBinary.Binary
-import Language.ASN1.BER
-import Language.ASN1
-import Language.ASN1.TLV
-import Language.ASN1.X509
-import Language.ASN1.Utils
-import Text.PrettyPrint
-import Control.Monad.State
-
-pp :: SignedCertificate -> RSAPublicKey -> String
-pp sc rsapk =
- render (
- ppLabelString "Version" (show (version3 (certificate1 sc)))
- $$
- ppLabelString "Serial Number" (show (serialNumber (certificate1 sc)))
- $$
- ppLabelDoc "Algorithm Identifier" algid
- $$
- ppLabelDoc "Issuer" iss
- $$
- ppLabelDoc "Validity" valid
- $$
- ppLabelDoc "Subject" sub
- $$
- ppLabelDoc "Subject Public Key Info" kk
- )
- where
- algid =
- ppLabelString "Algorithm"
- (show (algorithm1 (signature (certificate1 sc))))
- $$
- ppLabelString "Parameters"
- (show (parameters1 (signature (certificate1 sc))))
- iss = vcat (rdns issuer)
- sub = vcat (rdns subject)
- rdns select = (
- (map (\x -> (text (show (fst x)) <>
- space <>
- text (unDirectoryString (snd x))))) .
- (map (\x -> (type1 (head x),value (head x)))) .
- (map unSetOf) .
- (map unRelativeDistinguishedName) .
- unName .
- select .
- certificate1
- ) sc
- valid =
- ppLabelString "NotBefore" nb
- $$
- ppLabelString "NotAfter" na
- nb = unVisibleString (unTime (notBefore (validity1 (certificate1 sc))))
- na = unVisibleString (unTime (notAfter (validity1 (certificate1 sc))))
- ki = subjectPublicKeyInfo2 (certificate1 sc)
- al = algorithm2 ki
- kj = subjectPublicKeyInfo1 ki
- algid1 =
- ppLabelString "Algorithm" (show (algorithm1 al))
- $$
- ppLabelString "Parameters" (show (parameters1 al))
- kk = ppLabelDoc "Algorithm" algid1
- $$
- ppLabelDoc "Subject Public Key Info" spki
- spki = mod $$ exp
- exp = ppLabelString "Exponent" (show (publicExponent1 rsapk))
- bar = map (map sh) (split 16 (toOctets 256 (modulus1 rsapk)))
- sh x | x < 16 = showHex x "0"
- | otherwise = showHex x ""
- split :: Int -> [a] -> [[a]]
- split n xs = unfoldr (g n) xs
- g :: Int -> [a] -> Maybe ([a],[a])
- g n y
- | length y == 0 = Nothing
- | otherwise = Just (splitAt n y)
- mods1 :: [[Doc]]
- mods1 = map (intersperse colon) (map (map text) bar)
- mods2 :: [Doc]
- mods2 = map hcat mods1
- mod = ppLabelDoc "Modulus" (vcat mods2)
-
-ppLabelString :: String -> String -> Doc
-ppLabelString l x =
- text l <> colon <> space <> (text x)
-
-ppLabelDoc :: String -> Doc -> Doc
-ppLabelDoc l d =
- text l <> colon
- $$
- nest 3 d
-
-test fileName =
- do h <- openFile fileName ReadMode
- bin <- openBinIO_ h
- (l,x) <- tlvIO bin
- (w,y) <- typeCheck signedCertificate x
- let (_ ::= c) = w
- let d = (decode c (Just y))::(Maybe SignedCertificate)
- let d1 = certificate1 (fromJust d)
- let d2 = subjectPublicKeyInfo2 d1
- let d3 = subjectPublicKeyInfo1 d2
- let (BitString e) = d3
- let (l',x') = tlv e
- (w',y') <- typeCheck rsaPublicKey x'
- let (_ ::= r) = w'
- let s = (decode r (Just y'))::(Maybe RSAPublicKey)
- putStrLn (pp (fromJust d) (fromJust s))
-
-main =
- do progName <- getProgName
- args <- getArgs
- if length args /= 1
- then putStrLn ("Usage: " ++ progName ++ " <fileName>")
- else test (args!!0)