Crypto-3.0.3: BERTest.hs
module Main(main) where
import Data.Char
import Data.Maybe
import Control.Monad.Error
import Control.Monad.State
import Codec.ASN1.BER
import Codec.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
-}