This example program takes a modified version of the example in Annex A
of X.690 (ISO 8825-1) and demonstrates how to produce Haskell types
and encoding and decoding functions for each type.
Here's the ASN.1.
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 {} }
ChildInformation ::= SEQUENCE
{ name Name,
dateOfBirth [0] Date}
Name ::= [APPLICATION 1] IMPLICIT SEQUENCE
{givenName VisibleString,
initial VisibleString,
familyName VisibleString}
EmployeeNumber ::= [APPLICATION 2] IMPLICIT INTEGER
Date ::= [APPLICATION 3] IMPLICIT VisibleString -- YYYYMMDD
And here is the corresponding Haskell.
module Main(main) where
import Char
import IO
import Control.Monad.State
import List
import Codec.ASN1.ASN1
newtype Date = MkDate VisibleString
deriving Show
instance ASNable Date where
toASN NoTag (MkDate d) = toASN (Implicit (Application,3)) d
toASN tag (MkDate d) = toASN tag d
fromASN t x =
let (u,e1,e2) =
case t of
NoTag ->
((Application,3),
"fromASN: invalid application primitive tag for Date",
"fromASN: invalid constructed tag for Date")
(Implicit v) ->
(v,
"fromASN: invalid implicit primitive tag for Date",
"fromASN: invalid implicit constructed tag for Date") in
f u x e1 e2
where
f t x errMsg1 errMsg2 =
case x of
Primitive' t' v ->
if t == t'
-- VisibleString normally has the Universal tag 26.
-- Decode it as an OctetString, encode it with the
-- expected tag and then properly decode it.
then let (y::OctetString) = fromASN (Implicit t) x
z = map (chr . fromIntegral) $
encode $ toASN (Implicit (Universal,26)) y
((_,(u::ASN)),_) = runState (decode stdin) z
(v::VisibleString) = fromASN NoTag u in
MkDate v
else error (errMsg1 ++ "\n" ++ "Expected " ++ show t ++ " actual " ++ show t')
otherwise ->
error errMsg2
newtype EmployeeNumber = MkEmployeeNumber Integer
deriving Show
instance ASNable EmployeeNumber where
toASN NoTag (MkEmployeeNumber n) =
toASN (Implicit (Application,2)) n
toASN tag (MkEmployeeNumber n) =
toASN tag n
fromASN t x =
let (u,e1,e2) =
case t of
NoTag ->
((Application,2),
"fromASN: invalid application primitive tag for EmployeeNumber",
"fromASN: invalid constructed tag for EmployeeNumber")
(Implicit v) ->
(v,
"fromASN: invalid implicit primitive tag for EmployeeNumber",
"fromASN: invalid implicit constructed tag for EmployeeNumber") in
f u x e1 e2
where
f t x errMsg1 errMsg2 =
case x of
Primitive' t' v ->
if t == t'
-- Integer normally has the Universal tag 2.
-- Decode it as an OctetString, encode it with the
-- expected tag and then properly decode it.
then let (y::OctetString) = fromASN (Implicit t) x
z = map (chr . fromIntegral) $
encode $ toASN (Implicit (Universal,2)) y
((_,(u::ASN)),_) = runState (decode stdin) z
(v::Integer) = fromASN NoTag u in
MkEmployeeNumber v
else error (errMsg1 ++ "\n" ++ "Expected " ++ show t ++ " actual " ++ show t')
otherwise ->
error errMsg2
data Name =
MkName {
givenName :: VisibleString,
initial :: VisibleString,
familyName :: VisibleString }
deriving Show
instance ASNable Name where
toASN NoTag n =
toASN (Implicit (Application,1)) [toASN NoTag (givenName n),
toASN NoTag (initial n),
toASN NoTag (familyName n)]
toASN tag n =
toASN tag [toASN NoTag $ givenName n,
toASN NoTag $ initial n,
toASN NoTag $ familyName n]
fromASN t x =
let (u,e1,e2,e3) =
case t of
NoTag ->
((Application,1),
"fromASN: invalid application constructed tag for Name",
"fromASN: invalid primitive tag for Name",
"fromASN: invalid number of components for Name")
(Implicit v) ->
(v,
"fromASN: invalid implicit constructed tag for Name",
"fromASN: invalid implicit primitive tag for Name",
"fromASN: invalid number of components for Name") in
f u x e1 e2 e3
where
f t x errMsg1 errMsg2 errMsg3 =
case x of
Constructed' t' v ->
if t == t'
then case v of
[b1,b2,b3] ->
let gn = fromASN NoTag b1
i = fromASN NoTag b2
fn = fromASN NoTag b3 in
MkName {givenName = gn, initial = i, familyName = fn}
otherwise ->
error errMsg3
else error (errMsg1 ++ "\n" ++ "Expected " ++ show t ++ " actual " ++ show t')
otherwise ->
error errMsg2
data ChildInformation =
MkChildInformation {
name :: Name,
dateOfBirth ::Date }
deriving Show
instance ASNable ChildInformation where
toASN t c =
case t of
NoTag ->
Constructed' (Universal,16) bs
Implicit tag ->
Constructed' tag bs
where
bs = [toASN NoTag (name c),
toASN (Implicit (Context,1)) (dateOfBirth c)]
fromASN t x =
let (u,e1,e2,e3) =
case t of
NoTag ->
((Universal,16),
"fromASN: invalid universal constructed tag for ChildInformation",
"fromASN: invalid primitive tag for ChildInformation",
"fromASN: invalid number of components for ChildInformation")
(Implicit v) ->
(v,
"fromASN: invalid implicit constructed tag for ChildInformation",
"fromASN: invalid implicit primitive tag for ChildInformation",
"fromASN: invalid number of components for ChildInformation") in
f u x e1 e2 e3
where
f t x errMsg1 errMsg2 errMsg3 =
case x of
Constructed' t' v ->
if t == t'
then case v of
[b1,b2] ->
let dob = fromASN (Implicit (Context,1)) b2
nm = fromASN NoTag b1 in
MkChildInformation {dateOfBirth = dob, name = nm}
otherwise ->
error errMsg3
else error (errMsg1 ++ "\n" ++ "Expected " ++ show t ++ " actual " ++ show t')
otherwise ->
error errMsg2
data PersonnelRecord =
MkPersonnelRecord {
name_1 :: Name,
title :: VisibleString,
number :: EmployeeNumber,
dateOfHire :: Date,
nameOfSpouse :: Name,
children :: [ChildInformation] }
deriving Show
instance ASNable PersonnelRecord where
toASN t p =
case t of
NoTag ->
Constructed' (Application,0) bs
Implicit tag ->
Constructed' tag bs
where
bs = [toASN NoTag (name_1 p),
toASN (Implicit (Context,0)) (title p),
toASN NoTag (number p),
toASN (Implicit (Context,1)) (dateOfHire p),
toASN (Implicit (Context,2)) (nameOfSpouse p),
toASN (Implicit (Context,3)) (map (toASN NoTag) (children p))]
fromASN t x =
let (u,e1,e2,e3) =
case t of
NoTag ->
((Application,0),
"fromASN: invalid application constructed tag for PersonnelRecord",
"fromASN: invalid primitive tag for PersonnelRecord",
"fromASN: invalid number of components for PersonnelRecord")
(Implicit v) ->
(v,
"fromASN: invalid implicit constructed tag for PersonnelRecord",
"fromASN: invalid implicit primitive tag for PersonnelRecord",
"fromASN: invalid number of components for PersonnelRecord") in
f u x e1 e2 e3
where
f t x errMsg1 errMsg2 errMsg3 =
case x of
Constructed' t' v ->
if t == t'
then case v of
[b1,b2,b3,b4,b5,b6] ->
let nm = fromASN NoTag b1
-- VisibleString normally has the Universal tag 26.
-- Decode it as an OctetString and then encode it with the
-- expected tag and then properly decode it.
tio :: OctetString
tio = fromASN (Implicit (Context,0)) b2
tie = map (chr . fromIntegral) $
encode $ toASN (Implicit (Universal,26)) tio
((_,(tia::ASN)),_) = runState (decode stdin) tie
ti = fromASN NoTag tia
en = fromASN NoTag b3
doh = fromASN (Implicit (Context,1)) b4
nos = fromASN (Implicit (Context,2)) b5
as = fromASN (Implicit (Context,3)) b6
cs = map (fromASN NoTag) as in
MkPersonnelRecord { name_1 = nm,
title = ti,
number = en,
dateOfHire = doh,
nameOfSpouse = nos,
children = cs }
otherwise ->
error errMsg3
else error (errMsg1 ++ "\n" ++ "Expected " ++ show t ++ " actual " ++ show t')
otherwise ->
error errMsg2
name1 = MkName { givenName = MkVisibleString "John",
initial = MkVisibleString "P",
familyName = MkVisibleString "Smith" }
name2 = MkName { givenName = MkVisibleString "Mary",
initial = MkVisibleString "T",
familyName = MkVisibleString "Smith" }
name3 = MkName { givenName = MkVisibleString "Ralph",
initial = MkVisibleString "T",
familyName = MkVisibleString "Smith" }
name4 = MkName { givenName = MkVisibleString "Susan",
initial = MkVisibleString "B",
familyName = MkVisibleString "Jones" }
date1 = MkDate (MkVisibleString "19710917")
date2 = MkDate (MkVisibleString "19571111")
date3 = MkDate (MkVisibleString "19590717")
employeeNumber1 = MkEmployeeNumber 51
child1 = MkChildInformation { name = name3,
dateOfBirth = date2 }
child2 = MkChildInformation { name = name4,
dateOfBirth = date3 }
personnelRecord1 = MkPersonnelRecord { name_1 = name1,
title = MkVisibleString "Director",
number = employeeNumber1,
dateOfHire = date1,
nameOfSpouse = name2,
children = [child1,child2] }
encodedPR = map (chr . fromIntegral) $ encode $ toASN NoTag personnelRecord1
-- Decoding can either be done using a state monad or the IO monad - see below.
-- stdin is a dummy file handle so that the overloaded function decode can be used
-- with either monad.
unASNedAndDecodedPR :: (PersonnelRecord,String)
unASNedAndDecodedPR = runState (do (m,y) <- decode stdin; return $ fromASN NoTag y) encodedPR
main =
do ofh <- openFile "tst.txt" WriteMode
hPutStr ofh encodedPR
hClose ofh
ifh <- openFile "tst.txt" ReadMode
(m,y) <- decode ifh
putStrLn (show ((fromASN NoTag y)::PersonnelRecord))
|
