ContentsIndex
Codec.ASN1.ASN1
Portability non-portable
Stability experimental
Maintainer dominic.steinitz@blueyonder.co.uk
Contents
Type declarations
Example
Description
Provide Haskell types associated with some of the ASN.1 base types. The ASN.1, BER and other standards have been developed by the International Telecomunication Union (ITU) http://www.itu.int/ They can be downloaded for free from http://asn1.elibel.tm.fr/en/standards/. See also a layman's guide to a subset of ASN.1, BER and DER available at ftp://ftp.rsa.com/pub/pkcs/ascii/layman.asc.
Synopsis
newtype VisibleString = MkVisibleString String
newtype PrintableString = MkPrintableString String
data NULL = NULL
newtype OctetString = MkOctetString [Octet]
newtype BitString = MkBitString [Octet]
intToTwosBinComp :: Integral a => a -> [Word8]
twosBinCompToInt :: Integral a => [Word8] -> a
newtype Octet = MkOctet Word8
newtype OID = MkOID [Int]
newtype ASNEnum = MkASNEnum Int
class Encodable a where
encode :: a -> OctetStream
decode :: WrapMonad m => Handle -> m (Int, a)
data ASN
= forall a . (CF a, Encodable a, Show a) => Primitive' Tag a
| Constructed' Tag [ASN]
class ASNable a where
toASN :: TagOption -> a -> ASN
fromASN :: TagOption -> ASN -> a
data TagType
= Universal
| Application
| Context
| Private
data TagCons
= Primitive
| Constructed
data TagOption
= Implicit Tag
| NoTag
type Tag = (TagType, Int)
Type declarations
newtype VisibleString
Constructors
MkVisibleString String
Instances
CF VisibleString
CT VisibleString
Encodable VisibleString
ASNable VisibleString
Show VisibleString
newtype PrintableString
Constructors
MkPrintableString String
Instances
CF PrintableString
CT PrintableString
Encodable PrintableString
ASNable PrintableString
Show PrintableString
data NULL
Constructors
NULL
Instances
CF NULL
CT NULL
Encodable NULL
ASNable NULL
Eq NULL
Show NULL
newtype OctetString
Constructors
MkOctetString [Octet]
Instances
Show OctetString
CF OctetString
CT OctetString
Encodable OctetString
ASNable OctetString
Eq OctetString
newtype BitString
Constructors
MkBitString [Octet]
Instances
Show BitString
CF BitString
CT BitString
Encodable BitString
ASNable BitString
Eq BitString
intToTwosBinComp :: Integral a => a -> [Word8]
twosBinCompToInt :: Integral a => [Word8] -> a
newtype Octet
Constructors
MkOctet Word8
Instances
Show Octet
Eq Octet
newtype OID
Constructors
MkOID [Int]
Instances
CF OID
CT OID
Encodable OID
ASNable OID
Eq OID
Show OID
newtype ASNEnum
Constructors
MkASNEnum Int
Instances
CF ASNEnum
CT ASNEnum
Encodable ASNEnum
ASNable ASNEnum
Eq ASNEnum
Show ASNEnum
class Encodable a where
Methods
encode :: a -> OctetStream
decode :: WrapMonad m => Handle -> m (Int, a)
Instances
Encodable VisibleString
Encodable PrintableString
Encodable OctetString
Encodable BitString
Encodable NULL
Encodable Bool
Encodable OID
Encodable Int
Encodable Integer
Encodable ASNEnum
Encodable ASN
data ASN
Constructors
forall a . (CF a, Encodable a, Show a) => Primitive' Tag a
Constructed' Tag [ASN]
Instances
Show ASN
ASNable [ASN]
Encodable ASN
class ASNable a where
Methods
toASN :: TagOption -> a -> ASN
fromASN :: TagOption -> ASN -> a
Instances
ASNable VisibleString
ASNable PrintableString
ASNable OctetString
ASNable BitString
ASNable NULL
ASNable Bool
ASNable OID
ASNable Int
ASNable ASNEnum
ASNable Integer
ASNable [ASN]
ASNable RSAPrivateKey
ASNable Version
ASNable AlgorithmIdentifier
ASNable PrivateKeyInfo
data TagType
Constructors
Universal
Application
Context
Private
Instances
Eq TagType
Enum TagType
Show TagType
Read TagType
Ord TagType
data TagCons
Constructors
Primitive
Constructed
Instances
Eq TagCons
Enum TagCons
Show TagCons
data TagOption
Constructors
Implicit Tag
NoTag
type Tag = (TagType, Int)
Example

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))
Produced by Haddock version ADDOCK_VERSION