\documentclass{report} %include polycode.fmt \usepackage{listings} \usepackage{todonotes} \lstdefinelanguage{ASN1} { keywords={CHOICE, SEQUENCE, BEGIN, END, IMPLICIT, EXPLICIT, INTEGER, DEFINITIONS}, sensitive=false, morecomment=[s]{(--}{--)} } \lstnewenvironment{asn1}[1][] {\lstset{language=ASN1,captionpos=b,frame=single,basicstyle=\scriptsize,float,#1}} {} \newcommand{\bottom}{\perp} \newcommand{\INTEGER}{INTEGER} \begin{document} \title{A Formal and Executable Specification of the ASN.1 Packed Encoding Rules} \author{D. J. Russell \and D. J. Steinitz} \maketitle \tableofcontents \listoftodos \section{Introduction} ASN.1~\cite{PER} --- Abstract Syntax Notation --- is a large and complex specification for the abstract defininition of data for exchange between heterogeneous systems together with several concrete encodings~\cite{PER}. It is widely used, for example, to describe digital certificates, in third generation mobile telephony~\cite{3gpp.25.413} and in aviation~\cite{ACARS,ACARSInterop,FANS,ATN}. An example ASN.1 specification is shown in Figure~\ref{lst:ExampleASN1}. \begin{asn1}[caption={Example ASN.1},label=lst:ExampleASN1] FooBar {1 2 3 4 5 6} DEFINITIONS ::= BEGIN Type9 ::= CHOICE { element1 [0] IMPLICIT INTEGER, element2 [1] EXPLICIT CHOICE { subElement1 [3] IMPLICIT INTEGER, subElement2 [4] IMPLICIT INTEGER, subElement3 [5] IMPLICIT INTEGER }, element4 [2] IMPLICIT INTEGER } Type12 ::= CHOICE { c1 [0] IMPLICIT SEQUENCE { one INTEGER, two INTEGER }, c2 [1] IMPLICIT SEQUENCE { three INTEGER, four INTEGER } } END \end{asn1} In this paper we will present ASN.1 types and values using {\tt teletext} font and Haskell code and expressions using {\em italic} font. The paper includes the actual Haskell implementation of PER. Any code segments are separated from the main text of the paper by a newline. %include ASNTYPE.lhs In the following section we describe the Packed Encoding Rules (PER) as described in X.691. These are defined in the module {\em PER}. There are two versions of these rules, BASIC-PER and CANONICAL-PER. They both have two variants, UNALIGNED and ALIGNED. The later variant may require some bit padding to restore octet alignment. We have implemented the UNALIGNED variant of CANONICAL-PER. \section{Conventions} In order make the code more intelligible without using overlong identifiers, we adopt the following conventions: \begin{itemize} \item All encoding functions begin with ``e''. \item All decoding functions begin with ``d''. \item A part of an identifier ``Cons'' is short form for ``Constrained''. \item A part of an identifier ``Uncons'' is short form for ``Unconstrained''. \end{itemize} \section{UNALIGNED CANONICAL-PER} %if False \begin{code} {-# LANGUAGE MultiParamTypeClasses, GADTs, TypeOperators, EmptyDataDecls, FlexibleInstances, FlexibleContexts, GeneralizedNewtypeDeriving, ScopedTypeVariables, PatternGuards, DoRec, TypeSynonymInstances #-} {-# OPTIONS_GHC -fwarn-unused-binds -fwarn-unused-imports #-} {- -fwarn-incomplete-patterns -fwarn-unused-matches #-} \end{code} %endif The module uses the following modules: \begin{itemize} \item {\em ASNTYPE} since the encoding functions require ASN.1 type; \item {\em LatticeMod} in which some type classes are defined, including the type class {\tt Lattice}, which specifies a {\bf bounded lattice} and those types which have bounded lattice characteristics. This enables the overloading of various bounded lattice-related entities such as {\em top} and {\em bottom}. This module is described in section \ref{lattice}; \item {\em ConstraintGeneration} in which the constraint processing functions are defined. This is required since the top-level encoding functions take a list of constraints as input -- the serially applied constraints -- and require two constraints to represent the effective constraint (which is used in the generation of an encoding) and the actual constraint (which is used for validity testing). This module is described in section \ref{constraintGen}; \item {\em ASN1.PER.Integer} in which the functions {\em fromNonNegativeBinaryInteger'} and {\em from2sComplement'} are defined. These are used in the decoding of integers. Note that in Haskell the totality of a module is imported unless explicitly specified within parentheses; and \item several Haskell library modules some of which have been qualified with a shorter name which is then used as a prefix when any entity of these modules is used. \end{itemize} \begin{code} module PERWriter where import ASNTYPE import LatticeMod import ConstraintGeneration import Language.ASN1.PER.Integer ( fromNonNegativeBinaryInteger' , from2sComplement' ) import Data.List as L hiding (groupBy) import Data.Char import Control.Monad.Error import Control.Monad.Identity import Control.Monad.Writer {- FIXME: added IntegerAux and Word for encodeNonNegBinaryIntInOctets and h' -} import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.Binary.Strict.BitGet as BG import qualified Data.Binary.BitPut as BP import qualified Data.Binary.BitBuilder as BB import qualified Language.ASN1.PER.Integer as I import Data.Int import Control.Applicative \end{code} The top-level PER encoding function is called {\em encode}. The function takes three inputs: the type of value being encoded; a list of subtype constraints which represents the serially applied constraints and will be converted into an effective constraint in advance of encoding; and the value to be encoded. It has three distinct cases which address the various forms of an ASNType. \begin{itemize} \item The input is a builtin type value. The function {\em toPer} is called on this value. \item The input is a referenced type value. The reference is L.dropped and {\em encode} is recursively called on the value. \item The input is a constrained type value. The constraint is added to the list of constraints and the function is called again on the type being constrained. This recursion will continue until we reach a non-constrained type. The associated list of constraints will then include all of the seraily applied constraints. \end{itemize} The function {\em encode} returns a value of type {\em PERMonad ()}. This is a type that can deal with \begin{itemize} \item the output of an encoding; and \item error handling \end{itemize} In Haskell when we want to represent and manage computations such as writing output or handling errors we typcially use a {\em monadic} type. Haskell provides several commonly used monadic types such as \begin{itemize} \item the {\em Maybe} type for dealing with failure; \item the {\em IO} type for interaction with the user; and the \item list type for dealing with nondeterminism. \end{itemize} Each of these types (and other types) are members of the Haskell type class {\em Monad} which captures the behavioural requirements of a monad as a collection of operations supported by each of its member types. Haskell also provides monad transformers which combine existing monads to produce new monads with the characteristics of the component monads. Two such monad transformers are {\em ErrorT} which adds error handling capabilities to a monad, and {\em WriterT} which adds support for producing a stream of values. Thus the type {\em PERMonad} can produce a stream of values of type {\em BitStream} (the encoding type), and can handle errors of the type {\em ASNError}. This error type enables the categorisation of the various types of error. \begin{code} type PERMonad = WriterT BB.BitBuilder (ErrorT ASNError Identity) type UnPERMonad a = ErrorT ASNError BG.BitGet a data ASNError = ConstraintError String | BoundsError String | DecodeError String | ExtensionError String | OtherError String deriving Show instance Error ASNError where noMsg = OtherError "The impossible happened" encode :: ASNType a -> SerialSubtypeConstraints a -> a -> PERMonad () encode (BuiltinType t) cl v = toPER t v cl encode (ReferencedType r t) cl v = encode t cl v encode (ConstrainedType t c) cl v = encode t (c:cl) v decode :: ASNType a -> [ElementSetSpecs a] -> UnPERMonad a decode (BuiltinType t) cl = fromPER t cl decode (ConstrainedType t c) cl = decode t (c:cl) decode (ReferencedType r t) cl = decode t cl runDecode :: ASNType a -> B.ByteString -> a runDecode t bs = case BG.runBitGet bs (runErrorT (decode t [])) of Left s -> error s Right x -> case x of Left e -> error $ show e Right y -> y -- FIXME: B.pack . BL.unpack doesn't look right but I don't want to think about it now runEncode :: ASNType a -> a -> B.ByteString runEncode t v = case extractValue $ encode t [] v of Left e -> error $ show e Right ((), bb) -> B.pack $ BL.unpack $ BB.toLazyByteString bb \end{code} The function {\em toPER} L.takes an {\em ASNBuiltin} type, a value of the same builtin type and a list of subtype constraints, and encodes the value using PER. The first input is essential in determining the encoding algorithm to use. That is, it is a pointer to the appropriate encoding function for the value. For example, if the type is {\em INTEGER} then {\em eInteger} is called, and if it is a {\em CHOICE} type then {\em encodeChoice} is used. \begin{code} toPER :: ASNBuiltin a -> a -> SerialSubtypeConstraints a -> PERMonad () toPER NULL _ _ = tell BB.empty toPER INTEGER x cl = eInteger cl x toPER VISIBLESTRING x cl = encodeKMS cl x toPER PRINTABLESTRING x cl = encodeKMS cl x toPER NUMERICSTRING x cl = encodeKMS cl x toPER IA5STRING x cl = encodeKMS cl x toPER BMPSTRING x cl = encodeKMS cl x toPER UNIVERSALSTRING x cl = encodeKMS cl x toPER BOOLEAN x cl = encodeBool cl x toPER (ENUMERATED e) x cl = encodeEnum e cl x -- no PER-Visible constraints toPER (BITSTRING nbs) x cl = encodeBitstring nbs cl x toPER (OCTETSTRING) x cl = encodeOctetstring cl x toPER (SEQUENCE s) x cl = eSequence s x -- no PER-Visible constraints toPER (SEQUENCEOF s) x cl = eSequenceOf cl ((snd . splitName) s) x toPER (SET s) x cl = encodeSet s x -- no PER-Visible constraints toPER (CHOICE c) x cl = encodeChoice c x -- no PER-visible constraints toPER (SETOF s) x cl = encodeSetOf cl ((snd . splitName)s) x -- no PER-visible constraints toPER (TAGGED tag t) x cl = encode t cl x fromPER :: ASNBuiltin a -> [ElementSetSpecs a] -> UnPERMonad a fromPER t@INTEGER cl = dInteger cl -- FIXME: Why are we ignoring the constraints? fromPER t@(SEQUENCE s) cl = dSequence s \end{code} \section{COMPLETE ENCODING} {\em completeEncode} implements X.691 10.1. That is, it adds a single octet with all bits set to 0 to an empty encoding and leaves a non-empty encoding unchanged. \begin{code} completeEncode :: PERMonad () -> PERMonad () completeEncode m = {- X691REF: 10.1 -} let bs = extractValue m in case bs of {- X691REF: 10.1.3 with empty bit string -} (Right (f,s)) -> if BL.null $ BB.toLazyByteString s then tell $ BB.fromBits 8 (0x00::Int) else m {- X691REF: 10.1.3 with non-empty bit string -} x -> m \end{code} \section{ENCODING AN OPEN TYPE FIELD} {\em encodeOpen} encodes an open type value. It uses the function {\em extractValue} which L.takes a {\em PERMonad ()} value and returns either \begin{itemize} \item an error value; or \item a pair whose second element is the encoding value. \end{itemize} It also uses the function {\em encodeCase} which takes the extracted value and a function which acts on the bitstream included in it. If the extracted value indicates an error then the error is simply passed on. Othwerwise, the function is applied to the bitstream. \begin{code} encodeOpen :: ASNType a -> a -> PERMonad () encodeOpen t v {- X691REF: 10.2.1 -} = let x = extractValue (completeEncode $ encode t [] v) {- X691REF: 10.2.2 -} in encodeCase x encodeOctetsWithLength getByteString (Right (a,b)) = BB.toLazyByteString b getByteString x = error "Oops!" extractValue :: PERMonad () -> Either ASNError ((), BB.BitBuilder) extractValue = runIdentity . runErrorT . runWriterT encodeCase :: Either ASNError ((), BB.BitBuilder) -> (BL.ByteString -> PERMonad ()) -> PERMonad () encodeCase (Left s) _ = throwError s encodeCase x f = (f . getByteString) x \end{code} \section{ENCODING A LENGTH DETERMINANT} Several PER encodings require the encoding of a length determinant. If the item to be encoded is very large or, in the case of integer encoding, the number of bits produced by the encoding is very large, then some fragmenting may be required in which L.length and value encodings are interleaved. {\em encodeWithLength} is a higher order function which takes a constraint, an encoding function and a list of values (could be bits, octets or any ASN.1 type). The approach to encoding depends on whether the constraint imposes an upper bound which is less than 64K. If it does then no interleaving is required and the value is encoded with a L.length prefix if the upper bound differs from the lower bound, and with no L.length encoding otherwise. If the upper bound is at least 64K then {\em encodeUnconstrainedL.length} is called. The items are grouped first in 16k batches, and then in batches of 4. The input encoding function is then supplied as an input to the function {\em encodeUnconstrainedL.length} which manages the interleaving of L.length and value encodings -- it encodes the L.length and values of each batch and concatenates their resulting bitstreams together. Note the values are encoded using the input function. Note that {\em encodeWithL.length} is not used to encode {\bf normally small L.length} determinants (see X691: 10.9.3.4} which are only used with the bitmap that prefixes the extension addition values of a set or sequence type. \begin{code} encodeWithLength :: IntegerConstraint -> (t -> PERMonad ()) -> [t] -> PERMonad () encodeWithLength ic fun ls = if constrained ic && ub < k64 then {- X691REF: 10.9.4.1 -} if lb == ub then do tell BB.empty mapM_ fun ls else do toNonNegBinaryInteger (fromInteger (L.genericLength ls) - lb) (ub - lb) mapM_ fun ls else {- X691REF: 10.9.4.2 -} encodeUnconstrainedLength fun ls where lb = lower ic ub = upper ic k64 :: InfInteger k64 = 64 * 2^10 \end{code} {\em encodeUnconstrainedLength} is a higher order function which encodes a value with an unconstrained length i.e. it either has no upper bound on the size of the value, or the upper bound is at least 64k. The inputs are the value encoding function and the list of values to be encoded. If the L.length of the input value is less than 16K then the L.length is encoded followed by the value. Otherwise the auxiliary function {\em encodeUnconstrainedLengthAux} is called. This function manages the fragmenting of the input value into blocks of at most four 16K blocks. These are each encoded -- their block L.length followed by the encoding of the block of values -- and if the block contains four 16k blocks the process is repeated with the next block of 16K values. {\em lengthLessThan16K} encodes the length of a list of less than 16K values and {\em blockLen} encodes the L.length of a block (1 to 4). \begin{code} encodeUnconstrainedLength :: (b -> PERMonad ()) -> [b] -> PERMonad () encodeUnconstrainedLength encFun [] = lengthLessThan16K 0 {- FIXME: Is this only the case when there is at least 16k values? 10.9.3.8.3 See definition of encodeUnconstrainedLengthAux -} encodeUnconstrainedLength encFun xs | l < k16 {- X691REF: 10.9.3.6 AND 10.9.3.7 -} = do lengthLessThan16K l mapM_ encFun xs | otherwise {- X691REF: 10.9.3.8 -} = encodeUnconstrainedLengthAux encFun xs where l = L.genericLength xs encodeUnconstrainedLengthAux :: (b -> PERMonad ()) -> [b] -> PERMonad () encodeUnconstrainedLengthAux encFun [] = throwError (OtherError "Nothing to encode") encodeUnconstrainedLengthAux encFun xs | l == 4 && last16 == k16 = do blockLen 4 63 mapM_ (mapM_ encFun) x encodeUnconstrainedLength encFun (L.drop (64*(2^10)) xs) | otherwise = if last16 == k16 then do blockLen l 63 mapM_ (mapM_ encFun) x {- X691REF: Note associated with 10.9.3.8.3 -} lengthLessThan16K 0 else do blockLen (l-1) 63 mapM_ (mapM_ encFun) (init x) lengthLessThan16K ((L.genericLength.last) x) mapM_ encFun (last x) where (x:_) = (groupBy 4 . groupBy (16*(2^10))) $ xs l = L.genericLength x last16 = (L.genericLength . last) x k16 :: InfInteger k16 = 16*(2^10) groupBy :: Int -> [t] -> [[t]] groupBy n = L.unfoldr k where k [] = Nothing k p = Just (L.splitAt n p) lengthLessThan16K :: InfInteger -> PERMonad () lengthLessThan16K n | n <= 127 {- X691REF: 10.9.3.6 -} = do zeroBit toNonNegBinaryInteger n 127 | n < k16 {- X691REF: 10.9.3.7 -} = do oneBit zeroBit toNonNegBinaryInteger n (k16 - 1) | otherwise = throwError (BoundsError "Length is out of range.") blockLen :: InfInteger -> InfInteger -> PERMonad () blockLen x y = do oneBit oneBit toNonNegBinaryInteger x y noBit :: PERMonad () noBit = tell BB.empty zeroBit :: (MonadWriter BB.BitBuilder m) => m () zeroBit = tell $ BB.singleton False oneBit :: PERMonad () oneBit = tell $ BB.singleton True \end{code} \begin{code} -- FIXME: We should write this as an unfold rather than use primitive recursion decodeLargeLengthDeterminant :: (Integer -> t -> UnPERMonad B.ByteString) -> t -> UnPERMonad B.ByteString decodeLargeLengthDeterminant f t = do p <- lift BG.getBit if (not p) then do j <- lift $ BG.getLeftByteString 7 let l = fromNonNegativeBinaryInteger' 7 j f l t else do q <- lift BG.getBit if (not q) then do k <- lift $ BG.getLeftByteString 14 let m = fromNonNegativeBinaryInteger' 14 k f m t else do n <- lift $ BG.getLeftByteString 6 let fragSize = fromNonNegativeBinaryInteger' 6 n if fragSize <= 0 || fragSize > 4 then throwError (DecodeError (fragError ++ show fragSize)) else do frag <- f (fragSize * 16 * (2^10)) t rest <- decodeLargeLengthDeterminant f t return (B.append frag rest) where fragError = "Unable to decode with fragment size of " \end{code} \section{ENCODING THE BOOLEAN TYPE} \begin{code} {- FIXME: I think this is as good as it's worth doing for now -} {- Clearly we want to just say e.g. tell 1 -} {- Or do we. It is meant to return a bit-field value and not just a bit -} {- So the following whould be fine. -} encodeBool :: [SubtypeConstraint Bool] -> Bool -> PERMonad () encodeBool t x = tell $ BB.singleton x \end{code} \section{Stuff Used All Over but Which Needs Fixing} \todo{We normally stay in the monad and propogate any errors --- so make eitherExtensible redundant} \begin{code} eitherExtensible (Right v) = isExtensible v eitherExtensible _ = False eitherExtensible' :: MonadError ASNError m => Either String a -> m a eitherExtensible' (Right v) = return v eitherExtensible' (Left s) = throwError $ ConstraintError s evaluateConstraint' :: (Lattice a, Constraint a, Eq a, MonadError ASNError m) => (Element InfInteger -> Bool -> Either String (ExtensibleConstraint a)) -> Either String (ExtensibleConstraint a) -> [SubtypeConstraint InfInteger] -> m (ExtensibleConstraint a) evaluateConstraint' x y z = eitherExtensible' $ evaluateConstraint x y z \end{code} {\em toNonNegBinaryInteger} encodes an integer in the minimum number of bits required for the range specified by the constraint (assuming the range is at least 2). The value encoded is the offset from the lower bound of the constraint. \begin{code} toNonNegBinaryInteger :: InfInteger -> InfInteger -> PERMonad () toNonNegBinaryInteger (Val val) (Val range) = toNonNegBinaryIntegerAux val range where toNonNegBinaryIntegerAux :: Integer -> Integer -> PERMonad () toNonNegBinaryIntegerAux _ 0 = tell BB.empty toNonNegBinaryIntegerAux 0 w = toNonNegBinaryIntegerAux 0 (w `div` 2) >> zeroBit toNonNegBinaryIntegerAux n w = toNonNegBinaryIntegerAux (n `div` 2) (w `div` 2) >> (tell . BB.fromBits 1) n toNonNegBinaryInteger x y = throwError . OtherError $ "Cannot encode: " ++ show x ++ " in " ++ show y \end{code} \begin{code} encodeNonNegBinaryIntInOctets :: InfInteger -> PERMonad () encodeNonNegBinaryIntInOctets (Val x) = h 8 x where h p 0 = tell $ L.foldr BB.append BB.empty (L.replicate p (BB.singleton False)) h 0 n = h 7 (n `div` 2) >> (tell . BB.fromBits 1) n h p n = h (p - 1) (n `div` 2) >> (tell . BB.fromBits 1) n encodeNonNegBinaryIntInOctets y = throwError . OtherError $ "Cannot encode: " ++ show y \end{code} {\em encodeOctetsWithLength} encodes a collection of octets with unconstrained length. {\em encodeBitsWithLength} does the same except for a collection of bits. \begin{code} encodeOctetsWithLength :: BL.ByteString -> PERMonad () encodeOctetsWithLength bs = encodeUnconstrainedLength (tell . BB.fromBits 8) $ BL.unpack bs encodeBitsWithLength :: BitStream -> PERMonad () encodeBitsWithLength = encodeUnconstrainedLength (tell . BB.fromBits 1) \end{code} \begin{code} minBits :: Integer -> Integer minBits n = f n 0 where f 0 a = a f n a = f (n `div` 2) (a+1) \end{code} \todo[owner={Dan}]{Why do we have SubtypeConstraint? Isn't the right terminology ElementSetSpecs?} \begin{code} type ElementSetSpecs a = SubtypeConstraint a \end{code} \section{ENCODING THE INTEGER TYPE} \label{intEnc} \todo{This seems out of place} Note that if a constraint is serially applied to an extensible constraint then any extension additions of the extensible constraint are discarded (see X.680 Annex G.4.2.3). That is, the extensibility and extension additions of the effective constraint are determined only by the last constraint. We first define some helper functions to assist with checking whether a constraint is empty and, for \INTEGER constraints whether a value is in the range specified by the constraints. \begin{code} isEmptyConstraint, isNonEmptyConstraint :: (Eq t, Lattice t) => t -> Bool isEmptyConstraint x = x == bottom isNonEmptyConstraint x = x /= bottom \end{code} \begin{code} inRangeSingle :: InfInteger -> IntegerConstraint -> Bool inRangeSingle n c = n >= (lower c) && n <= (upper c) inRange :: InfInteger -> ValidIntegerConstraint -> Bool inRange n vc | Valid cs <- vc = or . map (inRangeSingle n) $ cs \end{code} We split the encoding of an \INTEGER\ into two cases depending on whether there are any constraints. \begin{code} eInteger :: [SubtypeConstraint InfInteger] -> InfInteger -> PERMonad () eInteger [] v = eUnconsInteger v eInteger cs v = eConsInteger cs v \end{code} We encode an unconstrained \INTEGER\ value as a 2's-complement-binary-integer in a minimum number of octets prefixed by an explicit length. \begin{code} eUnconsInteger :: InfInteger -> PERMonad () eUnconsInteger (Val x) = {- X691REF: 12.2.4 -} encodeOctetsWithLength . BP.runBitPut . I.to2sComplementM $ x eUnconsInteger v = throwError (BoundsError ("Cannot encode " ++ show v)) \end{code} We split the encoding of a constrained \INTEGER into two cases depending on whether the effective constraint is extensible. \begin{code} eConsInteger :: [SubtypeConstraint InfInteger] -> InfInteger -> PERMonad () eConsInteger cs v = do actualCon <- evaluateConstraint' pvIntegerElements top cs effectiveCon <- evaluateConstraint' pvIntegerElements top cs if isExtensible effectiveCon then {- X691REF: 12.1 -} eExtConsInteger actualCon effectiveCon v else {- X691REF: 12.2 -} encodeNonExtConsInt actualCon effectiveCon v \end{code} If the constraints are empty or the value to be encoded is not valid value of the constrained type then we throw an error otherwise we follow the encoding rules in Clause 12. \begin{code} encodeNonExtConsInt :: ExtensibleConstraint ValidIntegerConstraint -> ExtensibleConstraint IntegerConstraint -> InfInteger -> PERMonad () encodeNonExtConsInt actualCon effectiveCon n | isEmptyConstraint effRootCon = throwError (ConstraintError "Empty constraint") | isNonEmptyConstraint effRootCon && inRange n validRootCon = eRootConsInteger (constraintType effRootCon) n rootLower rootUpper | otherwise = throwError (BoundsError "Value out of range") where effRootCon = getRootConstraint effectiveCon validRootCon = getRootConstraint actualCon rootLower = lower effRootCon rootUpper = upper effRootCon eExtConsInteger :: ExtensibleConstraint ValidIntegerConstraint -> ExtensibleConstraint IntegerConstraint -> InfInteger -> PERMonad () eExtConsInteger actualCon effectiveCon n | isEmptyConstraint effRootCon && isEmptyConstraint effExtCon = throwError (ConstraintError "Empty constraint") | isNonEmptyConstraint effRootCon && inRange n validRootCon = do zeroBit eRootConsInteger (constraintType effRootCon) n rootLower rootUpper | isNonEmptyConstraint effExtCon && inRange n validExtCon = do {- X691REF: 12.1 -} oneBit eUnconsInteger n | otherwise = throwError (BoundsError "Value out of range") where effRootCon = getRootConstraint effectiveCon validRootCon = getRootConstraint actualCon effExtCon = getExtConstraint effectiveCon validExtCon = getExtConstraint actualCon rootLower = lower effRootCon rootUpper = upper effRootCon eRootConsInteger :: IntegerConstraintType -> InfInteger -> InfInteger -> InfInteger -> PERMonad () eRootConsInteger UnConstrained n _l _u = {- X691REF: 12.2.4 -} eUnconsInteger n eRootConsInteger SemiConstrained n l _u = {- X691REF: 12.2.3 -} eSemiConsInteger n l eRootConsInteger Constrained n l u = {- X691REF: 12.2.2 -} toNonNegBinaryInteger (n - l) (u - l) \end{code} We encode a semi-constrained integer as a non-negative-binary-integer of the difference between the value and the lower bound in the mininum number of octets prefixed by the length of the octets. \begin{code} eSemiConsInteger :: InfInteger -> InfInteger -> PERMonad () eSemiConsInteger x@(Val _) lb@(Val _) = encodeNonNegBinaryIntInOctets $ x - lb eSemiConsInteger x (Val _) = throwError . BoundsError $ "Cannot encode " ++ show x ++ "." eSemiConsInteger _ _ = throwError . ConstraintError $ "No lower bound." \end{code} We split the decoding of an \INTEGER\ into two cases depending on whether there are any constraints. \begin{code} dInteger :: [ElementSetSpecs InfInteger] -> UnPERMonad InfInteger dInteger [] = dConsInteger top undefined top dInteger cs = do effectiveCon <- evaluateConstraint' pvIntegerElements top cs let effRoot = getRootConstraint effectiveCon effExt = getExtConstraint effectiveCon dConsInteger effRoot (isExtensible effectiveCon) effExt \end{code} To decode an unconstrained \INTEGER\ , we parameterise {\em decodeLargeLengthDeterminant} by a function which ignores the second parameter chunking up the bits being read into groups of 8. \begin{code} dUnconInteger :: UnPERMonad Integer dUnconInteger = liftM from2sComplement' $ decodeLargeLengthDeterminant chunkBy8 undefined where chunkBy8 :: Integer -> a -> UnPERMonad B.ByteString chunkBy8 n _ = lift $ (flip (const (BG.getLeftByteString . fromIntegral . (*8)))) n undefined \end{code} \begin{code} dConsInteger :: IntegerConstraint -> Bool -> IntegerConstraint -> UnPERMonad InfInteger dConsInteger rc isExtensible ec = do let isRootConstraint = rc /= top isExtensionConstraint = ec /= top isEmptyConstraint = (not isRootConstraint) && (not isExtensionConstraint) tc = rc `ljoin` ec rootLower = let Val x = lower rc in x rootRange = let (Val x) = (upper rc) - (lower rc) + (Val 1) in x numOfRootBits = minBits rootRange dConsIntegerAux | isEmptyConstraint = do {- X691REF: 12.2.4 -} x <- dUnconInteger return (Val x) | isRootConstraint && isExtensionConstraint = do {- X691REF: 12.1 -} isExtension <- lift $ BG.getBit if isExtension then dExtConsInteger else dRootConsInteger | isRootConstraint && isExtensible = do {- X691REF: 12.1 -} isExtension <- lift $ BG.getBit if isExtension then throwError (ExtensionError "Extension for constraint not supported") else dRootConsInteger | isRootConstraint = dRootConsInteger | isExtensionConstraint = throwError (ConstraintError "Extension constraint without a root constraint") | otherwise = throwError (OtherError "Unexpected error decoding INTEGER") dExtConsInteger = do v <- dUnconInteger if (Val v) `inRangeSingle` tc then return (Val v) else throwError (BoundsError "Value not in extension constraint: could be invalid value or unsupported extension") dRootConsInteger = if rootRange <= 1 then {- X691REF: 12.2.1 -} return (Val rootLower) else do {- X691REF: 12.2.2 and 12.2.3 -} j <- lift $ BG.getLeftByteString (fromIntegral numOfRootBits) let v = rootLower + (fromNonNegativeBinaryInteger' numOfRootBits j) if (Val v) `inRangeSingle` rc then return (Val v) else throwError (BoundsError "Value not in root constraint") dConsIntegerAux \end{code} \section{ENCODING THE ENUMERATED TYPE} {\em encodeEnum} L.takes the defined enumeration type, the (possibly empty) list of serially applied constraints and the enumeration value. Since there are no PER-visible constraints, the constraints are used only to test the validity of the input enumeration. If the value is valid then the function {\em assignIndex} is applied to the enumeration type. This returns a pair whose first element indicates if an extension marker is present in the type, and whose second element is a list of indices assigned to the enumeration values. The index assigned to each enumeration value is determined by the enumeration number associated with each enumeration. These are either assigned explicitly when the enumeration is defined, or implicitly by the function {\em assignNumber}. {\tt assignIndex}, {\tt assignNumber} and their auxilliary functions are defined in the module {\tt ASNType} with the {\tt Enumerate} type. This is because they are used both in the encoding of an enumerate value, and in the generation of a constraint used to test the validity of an enumeration value. {\em encodeEnum} calls the auxiliary function {\em encodeEnumAux} which manages the various encoding cases. Its second input is the number of enumeration root values which is required since a root enumeration will be encoded as a constrained integer. Note that {\em encodeEnum} does not have a constraint input since there are no PER-visible enumerated type constraints. \begin{code} encodeEnum :: Enumerate -> SerialSubtypeConstraints Name -> Name -> PERMonad () encodeEnum e cs n = let (extensible,inds) = assignIndex e {- X691REF: 13.1 -} no = L.genericLength inds (b,p) = validEnum e n 0 in if b && (not . L.null) cs then let Just pos = p i = inds !! pos vc = evaluateConstraint (enumeratedElements e) (Right (ExtensibleConstraint top top False)) cs in if withinConstraint i vc then encodeEnumAux extensible no inds e n else throwError (BoundsError "Invalid enumeration") else if b then encodeEnumAux extensible no inds e n else throwError (OtherError "Invalid enumeration") withinConstraint i (Right (ExtensibleConstraint (EnumeratedConstraint ls) _ _)) = elem i ls withinConstraint i _ = False \end{code} {\em encodeEnumAux} is a recursive function which recurses through the enumeration value until it reaches the enumeration. If no extension marker is present then the enumeration is encoded using {\em toNonNegBinaryInteger}. If the marker is present and the enumeration is in the extension root then it is encoded as above but prefixed by 0. If the enumeration is not in the extension root then the encoding is passed to a second auxiliary function {\em encodeEnumExtAux}. This is also a recursive function which encodes an enumeration as a normally small non-negative integer using {\em encodeNSNNInt} prefixed by a 1. \begin{code} encodeEnumAux :: Bool -> Integer -> [Integer] -> Enumerate -> Name -> PERMonad () encodeEnumAux extensible no (f:r) (AddEnumeration ei es) n | getName ei == n = if not extensible then {- X691REF: 13.2 -} toNonNegBinaryInteger (fromInteger f) (fromInteger $ no - 1) else do {- X691REF: 13.2 -} zeroBit toNonNegBinaryInteger (fromInteger f) (fromInteger $ no - 1) | otherwise = encodeEnumAux extensible no r es n encodeEnumAux b no inds (EnumerationExtensionMarker ex) x = let el = noEnums ex in encodeEnumExtAux 0 el ex x encodeEnumAux _ _ _ _ _ = throwError (OtherError "No enumerated value!") encodeEnumExtAux :: Integer -> Integer -> Enumerate -> Name -> PERMonad () encodeEnumExtAux i l (AddEnumeration ei es) n | getName ei == n = do {- X691REF: 13.3 -} oneBit encodeNSNNInt i 0 | otherwise = encodeEnumExtAux (i+1) l es n encodeEnumExtAux i l _ _ = throwError (OtherError "No enumerated extension value!") \end{code} {\em encodeNSNNInt} encodes a normally small non-negative integer. \begin{code} encodeNSNNInt :: Integer -> Integer -> PERMonad () encodeNSNNInt n lb = if n <= 63 then do {- X691REF: 10.6.1 -} zeroBit toNonNegBinaryInteger (fromInteger n) (fromInteger 63) else do {- X691REF: 10.6.2 -} oneBit eSemiConsInteger (fromInteger n) (fromInteger lb) \end{code} \section{ENCODING THE REAL TYPE} {- FIXME: To do? -} \section{ENCODING THE BIT STRING TYPE} {\em encodeBitstring} L.takes the usual two inputs -- the list of serially applied constraints and the value to be encoded -- and an additional input, the named bits of type {\em NamedBits}. If the constraint list is empty the function {\em encodeUnconstrainedBitstring} is called. Otherwise, {\em encodeBitstringWithConstraint} is called. Note that there are two ways in which a BITSTRING type may have no PER-visible constraints. The first is when there are no constraints associated with the type. The second is when all of the serially applied constraints are non-PER visible. This is determined when generating the effective constraint for a type using the function {\em lSerialeffectiveCon} defined in the module {\em ConstraintGeneration}. \begin{code} encodeBitstring :: NamedBits -> [SubtypeConstraint BitString] -> BitString -> PERMonad () encodeBitstring nbs [] x = {- X691REF: 15.2 -} encodeUnconstrainedBitstring nbs x encodeBitstring nbs cs x = {- X691REF: 15.3 -} encodeBitstringWithConstraint nbs cs x \end{code} {\em encodeUnconstrainedBitstring} encodes the bitstring with a L.length determinant using {\em encodeBitsWithL.length}. If there are any named bits then trailing 0 bits are removed in advance of encoding. \begin{code} encodeUnconstrainedBitstring :: NamedBits -> BitString -> PERMonad () encodeUnconstrainedBitstring namedBits (BitString []) = return () -- tell [] encodeUnconstrainedBitstring namedBits (BitString bs) = let rem0 = if (not.L.null) namedBits then {- X691REF: 15.2 -} strip0s bs else bs in {- X691REF: 15.11 with ub unset -} encodeBitsWithLength rem0 strip0s :: BitStream -> BitStream strip0s [] = [] strip0s bs = if last bs == 0 then strip0s (init bs) else bs \end{code} {\em encodeBitstringWithConstraint} calls {\em encodeNonExtConsBitstring} if the constraint is not extensible. If it is extensible then {\em encodeExtConsBitstring} is called. They both L.take the effective constraint and actual constraint associated with the type as input. \begin{code} encodeBitstringWithConstraint :: NamedBits -> [SubtypeConstraint BitString] -> BitString -> PERMonad () encodeBitstringWithConstraint namedBits cs v = if (not extensible) then {- X691REF: 15.7 -} encodeNonExtConsBitstring namedBits actualCon effectiveCon v else {- X691REF: 15.6 -} encodeExtConsBitstring namedBits actualCon effectiveCon v where effectiveCon :: Either String (ExtensibleConstraint IntegerConstraint) effectiveCon = evaluateConstraint pvBitStringElements top cs actualCon :: Either String (ExtensibleConstraint ValidIntegerConstraint) actualCon = evaluateConstraint pvBitStringElements top cs extensible = eitherExtensible effectiveCon \end{code} {\em encodeNonExtConsBitstring} has to deal with three cases. \begin{itemize} \item There are no PER-visible constraints. The function {\em encodeUnconstrainedBitstring} is called. \item The constraint is empty and thus no values can be encoded. Note that this means that there is a PER-visible size constraint that has no values. An appropriate error is thrown. \item There is a PER-visible constraint. The function {\em encodeConstrainedBitstring} is called. \end{itemize} \begin{code} encodeNonExtConsBitstring :: NamedBits -> Either String (ExtensibleConstraint ValidIntegerConstraint) -> Either String (ExtensibleConstraint IntegerConstraint) -> BitString -> PERMonad () encodeNonExtConsBitstring nbs _ (Right (ExtensibleConstraint (IntegerConstraint NegInf PosInf) _ _)) (BitString vs) = {- X691REF: 15.11 with ub unset -} encodeUnconstrainedBitstring nbs (BitString vs) encodeNonExtConsBitstring nbs (Right ok) (Right vsc) (BitString vs) | isEmptyConstraint rc = throwError (ConstraintError "Empty constraint") | otherwise = {- X691REF: 15.8 - 15.11 -} encodeConstrainedBitstring [] nbs l u vrc vs where rc = getRootConstraint vsc l = lower rc u = upper rc vrc = getRootConstraint ok \end{code} {\em encodeExtConsBitstring} has to deal with three cases. \begin{itemize} \item There are no PER-visible constraints. The function {\em encodeUnconstrainedBitstring} is called. \item The constraint is empty and thus no values can be encoded. Note that this means that there is a PER-visible size constraint that has no values. An appropriate error is thrown. \item There is a PER-visible constraint. The function {\em encodeConstrainedBitstring} is called with the prefix bit set to 0. If this results in an error (the value cannot satisfy the constraint root) then {\em encodeNonExtRootBitstring} is called. The Haskell library function {\em catchError} manages the error/non-error cases. \end{itemize} \begin{code} encodeExtConsBitstring :: NamedBits -> Either String (ExtensibleConstraint ValidIntegerConstraint) -> Either String (ExtensibleConstraint IntegerConstraint) -> BitString -> PERMonad() encodeExtConsBitstring nbs _ (Right (ExtensibleConstraint (IntegerConstraint NegInf PosInf) (IntegerConstraint NegInf PosInf) _)) (BitString vs) = {- X691REF: 15.11 with ub unset -} encodeUnconstrainedBitstring nbs (BitString vs) encodeExtConsBitstring nbs (Right ok) (Right vsc) (BitString vs) | isEmptyConstraint rc = throwError (ConstraintError "Empty constraint") | otherwise = do catchError ({- X691REF: 15.6 within root -} encodeConstrainedBitstring [0] nbs l u vrc vs) (\err -> do {- X691REF: 15.6 not in root -} encodeNonExtRootBitstring nbs rc ec vec vs) where rc = getRootConstraint vsc l = lower rc u = upper rc ec = getExtConstraint vsc vrc = getRootConstraint ok vec = getExtConstraint ok \end{code} {\em encodeConstrainedBitstring} L.takes a prefix bit as the first input and has two list-pattern based cases. The first case has an empty list as its second argument indicating that there are no named bits. The second case uses the pattern {\em (b:rs)} to indicate that there is at least one named bit. Note that X.691 15.8 states that if a bitstring is constrained to be of zero L.length then it shall not be encoded. It is not clear whether this means that a bitstring with no L.length is not encoded, or if any bitstring associated with a bitstring type with a zero-L.length constraint is not encoded. We have implemented it using the former case. That is, the bitstring must satisfy the constraint (up to the removal of trailing 0 bits as described in X.691 15.3). \begin{code} type PrefixBit = BitStream encodeConstrainedBitstring :: PrefixBit -> NamedBits -> InfInteger -> InfInteger -> ValidIntegerConstraint -> BitStream -> PERMonad () encodeConstrainedBitstring pb bs l u (Valid vrc) xs | L.null bs && not (inSizeRange xs vrc) = throwError (BoundsError "Size out of range") | (not . L.null) bs && lxs > u && (L.take (fromInteger n) . L.reverse) xs /= L.take (fromInteger n) zeros = throwError (OtherError "Last value is not 0") | L.null bs && inSizeRange xs vrc = encodeConBS pb l u xs | otherwise {- X691REF: 15.3 -} = let nxs = namedBitsEdit l u xs in encodeConBS pb l u nxs where lxs = L.genericLength xs Val n = (lxs - u) \end{code} {\em inSizeRange} is a predicate that tests whether a value satisfies a size constraint. The L.length of the value is tested against the actual constraint -- possibly a non-contiguous set of values -- and not against the effective constraint. {\em namedBitsEdit} applies the necessary pruning of or appending of 0s to a bitstring to produce a minimal size value that satisfies the constraint associated with the type. This is only applied when the BIT STRING type has associated named bits. \begin{code} inSizeRange :: [b] -> [IntegerConstraint] -> Bool inSizeRange _ [] = False inSizeRange p qs = inSizeRangeAux qs where l = L.genericLength p inSizeRangeAux (x:rs) = l >= (lower x) && l <= (upper x) || inSizeRangeAux rs inSizeRangeAux [] = False namedBitsEdit :: InfInteger -> InfInteger -> BitStream -> BitStream namedBitsEdit l u xs = let lxs = L.genericLength xs in if lxs < l then add0s (l-lxs) xs else if lxs > u then rem0s (lxs-u) l xs else rem0s' l xs add0s :: InfInteger -> BitStream -> BitStream add0s (Val n) xs = xs ++ L.take (fromInteger n) zeros zeros :: BitStream zeros = [0,0..] putBitstream (a:xs) = (tell . BB.fromBits 1) a >> putBitstream xs putBitstream [] = noBit \end{code} \todo{Should we use higher order functions here rather than recursion?} \begin{code} rem0s :: InfInteger -> InfInteger -> BitStream -> BitStream rem0s (Val 0) l xs = rem0s' l xs rem0s (Val n) l xs = rem0s (Val (n - 1)) l (init xs) rem0s' :: InfInteger -> BitStream -> BitStream rem0s' l xs = if L.genericLength xs > l && last xs == 0 then rem0s' l (init xs) else xs \end{code} {\em encodeConBS} applies one of X.691 15.8-15.11. Note that in the last case of {\em encodeConBS} the lower bound of the constraint is ignored. This is because the lower bound does not affect these L.length encodings (X.691 10.9.3.5 Note). \begin{code} encodeConBS :: PrefixBit -> InfInteger -> InfInteger -> BitStream -> PERMonad () encodeConBS pb l u xs = if u == 0 then {- X691REF: 15.8 -} do putBitstream pb noBit else if u == l && u <= 65536 then {- X691REF: 15.9 and 15.10 -} do putBitstream pb putBitstream xs else if u <= 65536 then {- X691REF: 15.11 (ub set) -} do putBitstream pb toNonNegBinaryInteger ((fromInteger . L.genericLength $ xs) - l) (u - l) putBitstream xs else {- X691REF: 15.11 (ub unset) -} do putBitstream pb encodeBitsWithLength xs \end{code} {\em encodeNonExtRootBitstring} is similar to {\em encodeExtRootBitstring} but needs the extension constraint and encodes the L.length of the bitstring as a semi-constrained whole number with the lower bound set to zero as specified by X.691 15.11 and the note associated with X.691 10.9.3.5. Note that when pre-processing the bitstring in the named bits case, the upper and lower bound of the constraint is generated from the union of the root and non-root constraint using our {\em Lattice} class function {\em ljoin}. The {\em Lattice class}, related classes and class instantiations are defined in the module {\em LatticeMod}. \begin{code} encodeNonExtRootBitstring :: NamedBits -> IntegerConstraint -> IntegerConstraint -> ValidIntegerConstraint -> BitStream -> PERMonad () encodeNonExtRootBitstring [] rc ec (Valid erc) xs | inSizeRange xs erc = do oneBit encodeBitsWithLength xs | otherwise = throwError (BoundsError "Size out of range") encodeNonExtRootBitstring nbs rc ec (Valid erc) xs = let nc = rc `ljoin` ec l = lower nc u = upper nc in do oneBit encodeBitsWithLength (namedBitsEdit l u xs) \end{code} \section{ENCODING THE OCTETSTRING TYPE} {\em encodeOctetstring} L.takes the usual two inputs -- the list of serially applied constraints and the value to be encoded. If the constraint list is empty the function {\em encodeUnconstrainedOctetstring} is called. Otherwise, {\em encodeOctetstringWithConstraint} is called. Note that there are two ways in which a OCTETSTRING type may have no PER-visible constraints. The first is when there are no constraints associated with the type. The second is when all of the serially applied constraints are non-PER visible since a non-PER visible complete constraint is ignored. This is determined when generating the effective constraint for a type using the function {\em lSerialeffectiveCon} defined in the module {\em ConstraintGeneration}. \begin{code} encodeOctetstring :: [SubtypeConstraint OctetString] -> OctetString -> PERMonad () encodeOctetstring [] x = {- X691REF: 16.8 with ub unset -} encodeUnconstrainedOctetstring x encodeOctetstring cs x = {- X691REF: 16.3 -} encodeOctetstringWithConstraint cs x \end{code} {\em encodeUnconstrainedOctetstring} encodes an unconstrained octetstring, It uses {\em encodeUnconstrainedL.length} -- which manages the interleaving of L.length encoding with value encoding for values with an unconstrained L.length - whose first input {\em encodeOctet} converts a {\em Word8} representation of an octet to a list of bits representation. \begin{code} encodeUnconstrainedOctetstring :: OctetString -> PERMonad () encodeUnconstrainedOctetstring (OctetString xs) = encodeUnconstrainedLength encodeOctet xs encodeOctet :: Octet -> PERMonad () encodeOctet x = toNonNegBinaryInteger (fromIntegral x) 255 \end{code} If the constraint is not extensible then {\em encodeNonExtConsOctetstring} is called. If it is extensible then {\em encodeExtConsOctetstring} is called. They both L.take the effective constraint and actual constraint associated with the type as input. \begin{code} encodeOctetstringWithConstraint :: [SubtypeConstraint OctetString] -> OctetString -> PERMonad () encodeOctetstringWithConstraint cs v = if (not extensible) then {- X691REF: 16.4 -} encodeNonExtConsOctetstring actualCon effectiveCon v else {- X691REF: 16.3 -} encodeExtConsOctetstring actualCon effectiveCon v where effectiveCon :: Either String (ExtensibleConstraint IntegerConstraint) effectiveCon = evaluateConstraint pvOctetStringElements top cs actualCon :: Either String (ExtensibleConstraint ValidIntegerConstraint) actualCon = evaluateConstraint pvOctetStringElements top cs extensible = eitherExtensible effectiveCon \end{code} {\em encodeNonExtConsOctetstring} has to deal with three cases. \begin{itemize} \item There are no PER-visible constraints. The function {\em encodeUnconstrainedBitstring} is called. \item The constraint is empty and thus no values can be encoded. Note that this means that there is a PER-visible size constraint that has no values. An appropriate error is thrown. \item There is a PER-visible constraint. The function {\em encodeConstrainedOctetstring} is called. \end{itemize} \begin{code} encodeNonExtConsOctetstring :: Either String (ExtensibleConstraint ValidIntegerConstraint) -> Either String (ExtensibleConstraint IntegerConstraint) -> OctetString -> PERMonad () encodeNonExtConsOctetstring _ (Right (ExtensibleConstraint (IntegerConstraint NegInf PosInf) _ _)) (OctetString vs) = {- X691REF: 16.8 with ub unset -} encodeUnconstrainedOctetstring (OctetString vs) encodeNonExtConsOctetstring (Right ok) (Right vsc) (OctetString vs) | isEmptyConstraint rc = throwError (ConstraintError "Empty constraint") | otherwise = {- X691REF: 16.5 - 16.8 -} encodeConstrainedOctetstring [] l u vrc vs where rc = getRootConstraint vsc l = lower rc u = upper rc vrc = getRootConstraint ok \end{code} {\em encodeExtConsOctetstring} has to deal with three cases. \begin{itemize} \item There are no PER-visible constraints. The function {\em encodeUnconstrainedOctetstring} is called. \item The constraint is empty and thus no values can be encoded. Note that this means that there is a PER-visible size constraint that has no values. An appropriate error is thrown. \item There is a PER-visible constraint. The function {\em encodeConstrainedOctetstring} is called with the prefix bit set to 0. If this results in an error (the value cannot satisfy the constraint root) then {\em encodeExtConstrainedOctetstring} is called and the prefix bit is set to 1. The function Haskell library function {\em catchError} manages the error/non-error cases. \end{itemize} \begin{code} encodeExtConsOctetstring :: Either String (ExtensibleConstraint ValidIntegerConstraint) -> Either String (ExtensibleConstraint IntegerConstraint) -> OctetString -> PERMonad() encodeExtConsOctetstring _ (Right (ExtensibleConstraint (IntegerConstraint NegInf PosInf) (IntegerConstraint NegInf PosInf) _)) vs = {- X691REF: 16.8 with ub unset -} encodeUnconstrainedOctetstring vs encodeExtConsOctetstring (Right ok) (Right vsc) (OctetString vs) | isEmptyConstraint rc = throwError (ConstraintError "Empty constraint") | otherwise = do catchError (do {- X691REF: 16.3 within root -} encodeConstrainedOctetstring [0] l u vrc vs) (\err -> do {- X691REF: 16.3 not in root -} encodeNonExtRootConOctetstring rc ec vec vs) where rc = getRootConstraint vsc l = lower rc u = upper rc ec = getExtConstraint vsc vrc = getRootConstraint ok vec = getExtConstraint ok \end{code} {\em encodeConstrainedOctetstring} first checks if the value satisfies the constraint. Note that X.691 16.5 states that if an octetstring is constrained to be of zero L.length then it shall not be encoded. It is not clear whether this means that an octetstring with no L.length is not encoded, or if any octetstring associated with a bitstring type with a zero-L.length constraint is not encoded. We have implemented it using the former case. That is, the octetstring must satisfy the constraint. Note that with UNALIGNED PER if the upper bound of a constraint is greater or equal to 64K then the encoding of the L.length determinant is the same as it would be for an unconstrained L.length (X691: 10.9.4.2 Note). {\em encodeOctetsWithL.length} which encodes octets with an unconstrained L.length is used for this case. \begin{code} encodeConstrainedOctetstring :: PrefixBit -> InfInteger -> InfInteger -> ValidIntegerConstraint -> OctetStream -> PERMonad () encodeConstrainedOctetstring pb l u (Valid vrc) xs | inSizeRange xs vrc = let exs = encodeOctets xs in if u == 0 then {- X691REF: 16.5 -} return () else if u == l && u <= 65536 then {- X691REF: 16.6 and 16.7 -} exs else if u <= 65536 then {- X691REF: 16.8 (ub set) -} let ev = extractValue $ exs in do encodeEitherOctet ev l u exs else {- X691REF: 16.8 (ub unset) -} let ev = extractValue $ exs in encodeCase ev encodeOctetsWithLength | otherwise = throwError (BoundsError "Size out of range") encodeEitherOctet (Left s) l u = throwError s encodeEitherOctet (Right ((),bs)) l u = toNonNegBinaryInteger ((fromInteger . toInteger . BL.length . BB.toLazyByteString $ bs) - l) (u - l) encodeOctets :: OctetStream -> PERMonad () encodeOctets (x:xs) = mapM_ encodeOctet (x:xs) encodeOctets [] = return () encodeNonExtRootConOctetstring :: IntegerConstraint -> IntegerConstraint -> ValidIntegerConstraint -> OctetStream -> PERMonad () encodeNonExtRootConOctetstring rc ec (Valid erc) xs | inSizeRange xs erc = let ev = extractValue $ encodeOctets xs in do oneBit encodeCase ev encodeOctetsWithLength | otherwise = throwError (BoundsError "Size out of range") \end{code} \section{ENCODING THE SEQUENCE TYPE} {\em eSequence} has only two inputs - the type and value - since a sequence has no PER-visible constraints. It calls an auxiliary function {\em eSequenceAux} which requires two further inputs which indicate the extensibility of the type and existence of extension additions (represented as a pair of boolean values), and hosts the bits which indicate the presence or otherwise of optional or default values. {\em eSequenceAux} is a recursive function that recurses over the structure of a sequence and returns a value of type {\em PERMonad (OptDefBits, BitStream -> BitStream)}. This is a monadic value that outputs (the encoding) bits and returns a pair of values -- the optional or default value indicator bits and a function which adds the appropriate prefix to the output that indicates whether the encoded value is extensible and has any extension additions, and the optional/default indicator bits. {\em eSequenceAux} has several cases to deal with that match the various components of a sequence -- mandatory, optional, default, extension marker and so on -- and returns a pair whose second component is the function {\em completeSequenceBits} which adds a prefix to the output bits including the extension bit if required and the bits which describe the presence or otherwise of optional or default values. Each root component is encoded as required using {\em encode}. Note that the extension indicator is initally set to {\em (False, False)}. The first element is converted to {\em True} when an extension marker is reached and {\em eSequenceAuxExt} is called. It returns a value of type {\em PERMonad ((ExtAndUsed, ExtBits, OptDefBits, PERMonad (OptDefBits, BitStream -> BitStream)))}. That is, it is a monadic value that writes (the encoding) bitstream and returns 4 values in a 4-tuple. These are: \begin{itemize} \item an updated extension indicator reflecting whether any extension additions exist in the value; \item a bitstream representing the existence or otherwise of extension additions; \item a bitstream representing the existence or otherwise of optional or default components; and \item a monadic value which is the result of applying {\em eSequenceAux} to the remainder of the sequence once the extension additions have been terminated. This is indicated by another extension marker or simply by the end of the sequence. \end{itemize} Since we need to output root value encodings before extension addition encodings, we need to run the returned {\em eSequenceAux} monad in advance of outputing the extension addition encoding bits. This is achieved by using the {\em MonadWriter} function {\em censor} which applies a function to the output of a monad in advance of outputting. Here we apply the Haskell built-in function {\tt const} which simply returns its first argument -- in this case the empty list {\em []}. Now since this function is applied lazily the monad can run without producing output but returning the monad that we require. We then run the returned monad and then run the extension addition monad again but this time apply a function to add the required preamble to the extension addition encoding bits using the function {\em addExtensionAdditionPreamble}. Note also that the encoding of a {\em COMPONENTS OF} item is managed by {\em eSequenceAuxCO}. This monadic function outputs the encoding bits and returns the optional/default bits to be used in the generation of the encoding preamble. \begin{code} -- FIXME: We should make these newtypes type OptDefBits = BitStream type ExtBits = BitStream -- FIXME: This should really be empty in a separate module and then we can import it as -- FIXME: e.g. BS.empty emptyBitStream :: BitStream emptyBitStream = [] -- FIXME: Ditto emptySubTypeConstraints :: SerialSubtypeConstraints a emptySubTypeConstraints = [] data Ext = Ext | NotExt deriving Eq data Used = Used | NotUsed deriving Eq type ExtAndUsed = (Ext, Used) eSequence :: Sequence a -> a -> PERMonad () eSequence s v = do _odbs <- pass $ eSequenceAux NotExt NotUsed emptyBitStream s v return () -- FIXME: Eugh pattern match failure here selectOutput (Right (a,b)) = b selectOutput (Left s) = error $ show s \end{code} \todo[owner={Dan}]{It seems strange to have {\em NotExt} and {\em ExtensionMarker} to encode 18.8.} \begin{code} eSequenceAux :: Ext -> Used -> OptDefBits -> Sequence a -> a -> PERMonad (OptDefBits, BB.BitBuilder -> BB.BitBuilder) eSequenceAux ext used optDef EmptySequence Empty = return (optDef, completeSequenceBits (ext, used) optDef) eSequenceAux NotExt _ optDefBits (ExtensionMarker as) xs = do rec (b, eb, _, pm) <- censor (BB.append extRoot . BB.append extAddPreamble) $ eSequenceAuxExt (Ext, NotUsed) optDefBits emptyBitStream as xs {- X691REF: 18.8 -} ((), extAddPreamble) <- censor (const BB.empty) $ listen $ addExtensionAdditionPreamble eb {- X691REF: 18.2 -} ((od2, _), extRoot) <- pass ((,) <$> (listen pm) <*> (pure $ const BB.empty)) eSequenceAux (fst b) (snd b) od2 EmptySequence Empty eSequenceAux Ext used optDefBits (ExtensionMarker as) xs = eSequenceAux Ext used optDefBits as xs eSequenceAux e u od (AddComponent (ComponentsOf (BuiltinType (SEQUENCE s))) as) (x:*:xs) = do od2 <- eSequenceAuxCO [] s x -- FIXME: A list looks like the wrong type for putting things at the end eSequenceAux e u (od ++ od2) as xs eSequenceAux e u od (AddComponent (ComponentsOf (ReferencedType n t)) as) (x:*:xs) = eSequenceAux e u od (AddComponent (ComponentsOf t) as) (x:*:xs) eSequenceAux e u od (AddComponent (ComponentsOf (ConstrainedType t c)) as) (x:*:xs) = eSequenceAux e u od (AddComponent (ComponentsOf t) as) (x:*:xs) eSequenceAux e u od (AddComponent (MandatoryComponent (NamedType t a)) as) (x:*:xs) = do encode a emptySubTypeConstraints x eSequenceAux e u od as xs eSequenceAux e u od (AddComponent (ExtensionComponent (NamedType t a)) as) (Nothing:*:xs) = eSequenceAux e u od as xs eSequenceAux b1 b2 od (AddComponent (ExtensionComponent (NamedType t a)) as) (Just x:*:xs) = eSequenceAux b1 Used od as xs eSequenceAux e u od (AddComponent (OptionalComponent (NamedType _ a)) as) (Nothing:*:xs) = {- X691REF: 18.2 with optional component not present -} eSequenceAux e u (od ++ [0]) as xs eSequenceAux e u od (AddComponent (OptionalComponent (NamedType t a)) as) (Just x:*:xs) = do {- X691REF: 18.2 with optional component present -} encode a emptySubTypeConstraints x eSequenceAux e u (od ++ [1]) as xs eSequenceAux e u od (AddComponent (DefaultComponent (NamedType t a) d) as) (Nothing:*:xs) = {- X691REF: 18.2 with default value -} {- X691REF: 18.5 with default value (CANONICAL-PER) -} eSequenceAux e u (od ++ [0]) as xs eSequenceAux e u od (AddComponent (DefaultComponent (NamedType t a) d) as) (Just x:*:xs) = do {- X691REF: 18.2 with non-default value -} encode a emptySubTypeConstraints x eSequenceAux e u (od ++ [1]) as xs eSequenceAux extension _ optDef (ExtensionAdditionGroup _ _ as) (x:*:xs) = eSequenceAux extension Used optDef as xs \end{code} completeSequenceBits changed so that the collection of optional/default bits are implemented using Data.Seq. \begin{code} completeSequenceBits :: ExtAndUsed -> BitStream -> BB.BitBuilder -> BB.BitBuilder completeSequenceBits (extensible, extensionAdditionPresent) odb bs | extensible == NotExt = BB.append (fragment odb) bs | extensionAdditionPresent == Used {- X691REF: 18.1 with extension additions present -} {- X691REF: 18.2 -} = BB.append (BB.singleton True) $ BB.append (fragment odb) bs | otherwise {- X691REF: 18.1 with no extenion additions present -} {- X691REF: 18.2 -} = BB.append (BB.singleton False) $ BB.append (fragment odb) bs where {- X691REF: 18.3 -} fragment ls | L.length ls < 64 * 2^10 = toBitBuilder ls | otherwise = let Right ((),b) = extractValue $ encodeUnconstrainedLength (tell . BB.fromBits 1) ls in b toBitBuilder (f:r) = BB.append (BB.fromBits 1 f) (toBitBuilder r) toBitBuilder [] = BB.empty \end{code} \begin{code} eSequenceAuxExt :: ExtAndUsed -> OptDefBits -> ExtBits -> Sequence a -> a -> PERMonad ((ExtAndUsed, ExtBits, OptDefBits, PERMonad (OptDefBits, BB.BitBuilder -> BB.BitBuilder))) eSequenceAuxExt b odb eb (AddComponent (ExtensionComponent (NamedType t a)) as) (Nothing:*:xs) = {- X691REF: 18.7 with extension addition absent -} eSequenceAuxExt b odb (eb ++ [0]) as xs eSequenceAuxExt (b1,b2) odb eb (AddComponent (ExtensionComponent (NamedType t a)) as) (Just x:*:xs) = do {- X691REF: 18.7 with extension addition present -} {- X691REF: 18.9 with ComponentType extension -} encodeOpen a x eSequenceAuxExt (b1,Used) odb (eb ++ [1]) as xs eSequenceAuxExt b odb eb (AddComponent (OptionalComponent (NamedType t a)) as) (Nothing:*:xs) = {- X691REF: 18.7 with extension addition absent -} eSequenceAuxExt b odb (eb ++ [0]) as xs eSequenceAuxExt (b1,b2) odb eb (AddComponent (OptionalComponent (NamedType t a)) as) (Just x:*:xs) = do {- X691REF: 18.7 with extension addition present -} {- X691REF: 18.9 with ComponentType extension -} encodeOpen a x eSequenceAuxExt (b1,Used) odb (eb ++ [1]) as xs eSequenceAuxExt b odb eb (ExtensionAdditionGroup _ a as) (Nothing:*:xs) = {- X691REF: 18.7 with extension addition absent -} eSequenceAuxExt b odb (eb ++ [0]) as xs eSequenceAuxExt (b1,b2) odb eb (ExtensionAdditionGroup _ a as) (Just x:*:xs) = do {- X691REF: 18.7 with extension addition present -} {- X691REF: 18.9 with ExtensionAdditionGroup extension -} encodeOpen (BuiltinType (SEQUENCE (makeSequence a))) x eSequenceAuxExt (b1, Used) odb (eb ++ [1]) as xs eSequenceAuxExt b odb eb (ExtensionMarker as) xs = return (b, eb, odb, eSequenceAux (fst b) (snd b) odb as xs) eSequenceAuxExt b odb eb EmptySequence Empty = return (b, eb, odb, eSequenceAux (fst b) (snd b) odb EmptySequence Empty) eSequenceAuxExt b odb eb _ _ = throwError (OtherError "Inappropriate component!") \end{code} If the extension bit list is empty then there is no extension addition preamble (X691 section 18.6). \begin{code} addExtensionAdditionPreamble :: OptDefBits -> PERMonad () addExtensionAdditionPreamble [] = do noBit addExtensionAdditionPreamble ap = let la = genericLength ap in if la <= 64 then do {- X691REF: 10.9.3.4 when n <= 64-} zeroBit toNonNegBinaryInteger (la - 1) 63 tell (toBitBuilder ap) else do {- X691REF: 10.9.3.4 when n > 64-} oneBit encodeNonNegBinaryIntInOctets la tell (toBitBuilder ap) \end{code} When encoding a ComponentsOf component, we simply extract and encode the root components of the type. \begin{code} eSequenceAuxCO :: OptDefBits -> Sequence a -> a -> PERMonad OptDefBits eSequenceAuxCO odb EmptySequence _ = return odb eSequenceAuxCO odb (ExtensionMarker as) xs = eSequenceAuxCO odb as xs eSequenceAuxCO odb (AddComponent (ComponentsOf (BuiltinType (SEQUENCE s))) as) (x:*:xs) = do odb2 <- eSequenceAuxCO [] s x eSequenceAuxCO (odb ++ odb2) as xs eSequenceAuxCO odb (AddComponent (ComponentsOf _) as) (x:*:xs) = throwError (OtherError "COMPONENTS OF can only be applied to a SEQUENCE") eSequenceAuxCO odb (AddComponent (MandatoryComponent (NamedType t a)) as) (x:*:xs) = do encode a [] x eSequenceAuxCO odb as xs eSequenceAuxCO odb (AddComponent (ExtensionComponent (NamedType t a)) as) (_:*:xs) = eSequenceAuxCO odb as xs eSequenceAuxCO odb (AddComponent (OptionalComponent (NamedType t a)) as) (Nothing:*:xs) = eSequenceAuxCO (odb ++ [0]) as xs eSequenceAuxCO odb (AddComponent (OptionalComponent (NamedType t a)) as) (Just x:*:xs) = do encode a [] x eSequenceAuxCO (odb ++ [1]) as xs eSequenceAuxCO odb (AddComponent (DefaultComponent (NamedType t a) d) as) (Nothing:*:xs) = eSequenceAuxCO (odb ++ [0]) as xs eSequenceAuxCO odb (AddComponent (DefaultComponent (NamedType t a) d) as) (Just x:*:xs) = do encode a [] x eSequenceAuxCO (odb ++ [1]) as xs eSequenceAuxCO odb (ExtensionAdditionGroup _ _ as) (x:*:xs) = eSequenceAuxCO odb as xs \end{code} \begin{code} dSequence :: Sequence a -> UnPERMonad a dSequence s = do ps <- lift $ bitMask (l s) dSequenceAux ps s l :: Integral n => Sequence a -> n l EmptySequence = 0 l (AddComponent (MandatoryComponent _) ts) = l ts l (AddComponent (OptionalComponent _) ts) = 1 + (l ts) bitMask n = sequence $ L.take n $ repeat $ BG.getBit type BitMap = [Bool] -- FIXME: We don't yet seem to handle e.g. OptionalComponent dSequenceAux :: BitMap -> Sequence a -> UnPERMonad a -- FIXME: Ignoring the bit map doesn't look right - it's probably an error if it's not empty dSequenceAux _ EmptySequence = return Empty dSequenceAux bitmap (AddComponent (MandatoryComponent (NamedType _ t)) ts) = do x <- decode t [] xs <- dSequenceAux bitmap ts return (x :*: xs) \end{code} \section{ENCODING THE SEQUENCE-OF TYPE} {\em eSequenceOf} takes three inputs, the usual two inputs -- the list of serially applied constraints and the value to be encoded -- and the type of the components. This is required as input to the {\em encode} function which encodes each component of the SEQUENCEOF. If the constraint list is empty the function {\em encodeUnconstrainedSequenceOf} is called. Otherwise, {\em eSequenceOfWithConstraint} is called. Note that there are two ways in which a SEQUENCEOF type may have no PER-visible constraints. The first is when there are no constraints associated with the type. The second is when all of the serially applied constraints are non-PER visible. This is determined when generating the effective constraint for a type using the function {\em lSerialeffectiveCon} defined in the module {\em ConstraintGeneration}. Note that a SEQUENCEOF value is represented as a Haskell list of components. The PER-visible SIZE constraint is applied to the number of elements in the list. \begin{code} eSequenceOf :: [SubtypeConstraint [a]] -> ASNType a -> [a] -> PERMonad () eSequenceOf [] t x = {- X691REF: 19.6 with ub unset -} encodeUnconstrainedSequenceOf t x eSequenceOf cl t x = eSequenceOfWithConstraint t cl x \end{code} {\em encodeUnconstrainedSequenceOf} encodes an unconstrained SEQUENCEOF value by adding a length determinant to the encoding of the SEQUENCEOF components. This may of course involve fragmentation. \begin{code} encodeUnconstrainedSequenceOf :: ASNType a -> [a] -> PERMonad () encodeUnconstrainedSequenceOf t xs = encodeUnconstrainedLength (encode t []) xs \end{code} {\em eSequenceOfWithConstraint} calls {\em encodeNonExtConsSequenceOf} if the constraint is not extensible. If it is extensible then {\em encodeExtConsSequenceOf} is called. They both take the effective constraint and actual constraint associated with the type as input. \begin{code} eSequenceOfWithConstraint :: ASNType a -> [SubtypeConstraint [a]] -> [a] -> PERMonad () eSequenceOfWithConstraint t cs v = if (not extensible) then encodeNonExtConsSequenceOf t actualCon effectiveCon v else {- X691REF: 19.4 -} encodeExtConsSequenceOf t actualCon effectiveCon v where effectiveCon :: Either String (ExtensibleConstraint IntegerConstraint) effectiveCon = evaluateConstraint pvSequenceOfElements top cs actualCon :: Either String (ExtensibleConstraint ValidIntegerConstraint) actualCon = evaluateConstraint pvSequenceOfElements top cs extensible = eitherExtensible effectiveCon \end{code} {\em encodeNonExtConsSequenceOf} has to deal with three cases. \begin{itemize} \item There are no PER-visible constraints. The function {\em encodeUnconstrainedSequenceOf} is called. \item The constraint is empty and thus no values can be encoded. Note that this means that there is a PER-visible size constraint that has no values. An appropriate error is thrown. \item There is a PER-visible constraint. The function {\em encodeConstrainedSequenceOf} is called. \end{itemize} \begin{code} encodeNonExtConsSequenceOf :: ASNType a -> Either String (ExtensibleConstraint ValidIntegerConstraint) -> Either String (ExtensibleConstraint IntegerConstraint) -> [a] -> PERMonad () encodeNonExtConsSequenceOf t _ (Right (ExtensibleConstraint (IntegerConstraint NegInf PosInf) _ _)) vs = {- X691REF: 19.6 with ub unset -} encodeUnconstrainedSequenceOf t vs encodeNonExtConsSequenceOf t (Right ok) (Right vsc) vs | isEmptyConstraint rc = throwError (ConstraintError "Empty constraint") | otherwise = {- X691REF: 19.5 - 19.6 -} encodeConstrainedSequenceOf t [] l u vrc vs where rc = getRootConstraint vsc l = lower rc u = upper rc vrc = getRootConstraint ok \end{code} {\em encodeExtConsSequenceOf} has to deal with three cases. \begin{itemize} \item There are no PER-visible constraints. The function {\em encodeUnconstrainedSequenceOf} is called. \item The constraint is empty and thus no values can be encoded. Note that this means that there is a PER-visible size constraint that has no values. An appropriate error is thrown. \item There is a PER-visible constraint. The function {\em encodeConstrainedSequenceOf} is called with the prefix bit set to 0. If this results in an error (the value cannot satisfy the constraint root) then {\em encodeExtConstrainedSequenceOf} is called and the prefix bit is set to 1. The function Haskell library function {\em catchError} manages the error/non-error cases. \end{itemize} \begin{code} encodeExtConsSequenceOf :: ASNType a -> Either String (ExtensibleConstraint ValidIntegerConstraint) -> Either String (ExtensibleConstraint IntegerConstraint) -> [a] -> PERMonad() encodeExtConsSequenceOf t _ (Right (ExtensibleConstraint (IntegerConstraint NegInf PosInf) (IntegerConstraint NegInf PosInf) _)) vs = {- X691REF: 19.6 with ub unset -} encodeUnconstrainedSequenceOf t vs encodeExtConsSequenceOf t (Right ok) (Right vsc) vs | isEmptyConstraint rc = throwError (ConstraintError "Empty constraint") | otherwise = do catchError (do {- X691REF: 19.4 within root -} encodeConstrainedSequenceOf t [0] l u vrc vs) (\err -> do {- X691REF: 19.4 not in root -} encodeNonExtRootConSequenceOf t rc ec vec vs) where rc = getRootConstraint vsc l = lower rc u = upper rc ec = getExtConstraint vsc vrc = getRootConstraint ok vec = getExtConstraint ok \end{code} {\em encodeConstrainedSequenceOf} first checks if the value satisfies the constraint. Note that with UNALIGNED PER if the upper bound of a constraint is greater or equal to 64K then the encoding of the length determinant is the same as it would be for an unconstrained length (X691: 10.9.4.2 Note). \begin{code} encodeConstrainedSequenceOf :: ASNType a -> PrefixBit -> InfInteger -> InfInteger -> ValidIntegerConstraint -> [a] -> PERMonad () encodeConstrainedSequenceOf t pb l u (Valid vrc) xs | inSizeRange xs vrc = if u == l && u <= 65536 then {- X691REF: 19.5 -} do tell $ toBitBuilder pb mapM_ (encode t []) xs else if u <= 65536 then {- X691REF: 19.6 with ub set -} do tell $ toBitBuilder pb toNonNegBinaryInteger ((fromInteger . genericLength $ xs) - l) (u - l) mapM_ (encode t []) xs else {- X691REF: 19.6 with ub unset -} do tell $ toBitBuilder pb encodeUnconstrainedSequenceOf t xs | otherwise = throwError (BoundsError "Size out of range") encodeNonExtRootConSequenceOf :: ASNType a -> IntegerConstraint -> IntegerConstraint -> ValidIntegerConstraint -> [a] -> PERMonad () encodeNonExtRootConSequenceOf t rc ec (Valid erc) xs | inSizeRange xs erc = do oneBit encodeUnconstrainedSequenceOf t xs | otherwise = throwError (BoundsError "Size out of range") \end{code} \section{ENCODING THE SET TYPE} {\em encodeSet} encodes a SET value. In common with a SEQUENCE, a SET has no PER-visible constraints and thus the encoding function has only two inputs: the type of the set to be encoded represented as a sequence, and the value to be encoded. The encoding of a set is similar to that of a sequence except that the root components are encoded in order of their tags. We therefore cannot output each root component encoding in the order they appear in the set value, but instead, must store the monadic encode value, typically of the form {\em encode a [] x}, in a list, which are then ordered by tag value, and then run in this order. That is, the encoding bits are only output after the ordering of the components. This behaviour is managed by the auxiliary function {\em encodeSetAux} which is similar to {\em eSequenceAux} except that the second input is a list of pairs of \begin{itemize} \item tag information and \item a pair of optional/default bit with the monadic encode value \end{itemize} instead of simply a list of optional/default bits. Here each optional/default bit is of the type {\em Maybe Int} to allow for non-optional/default components for which the entry will be {\em Nothing}. Note that we call {\tt eSquenceAux} at the end of the {\tt ExtensionMarker} case, since {\tt encodeSetAux} is applied to the empty case when the monad returned by {\tt encodeSetAuxExt (Ext, NotUsed) ms [] as xs} is run. \begin{code} encodeSet :: Sequence a -> a -> PERMonad () encodeSet s v = do odb <- pass $ encodeSetAux (NotExt, NotUsed) [] s v return () encodeSetAux :: ExtAndUsed -> [(TagInfo, (Maybe Int, PERMonad ()))] -> Sequence a -> a -> PERMonad (OptDefBits, BB.BitBuilder -> BB.BitBuilder) encodeSetAux eu ms EmptySequence Empty = let sms = L.sortBy firstItem ms firstItem m n | fst m < fst n = LT | fst m == fst n = EQ | otherwise = GT odb = L.map (\(Just x) -> x) $ L.filter (/= Nothing) $ L.map (fst . snd) sms mds = L.map (snd . snd) sms in do {- FIXME run monads in the right order and create optdefbits-} mapM_ id mds return (odb, completeSequenceBits eu odb) encodeSetAux (extensible, b) ms (ExtensionMarker as) xs | extensible == NotExt = let m = encodeSetAuxExt (Ext, NotUsed) ms [] as xs in do (b, eb,pm) <- censor (const BB.empty) m (od2,f) <- pm {- X691REF: 18.8 -} censor (BB.append (selectOutput . extractValue $ addExtensionAdditionPreamble eb)) m eSequenceAux (fst b) (snd b) od2 EmptySequence Empty | otherwise = encodeSetAux (extensible,b) ms as xs encodeSetAux eu ms (AddComponent (ComponentsOf (BuiltinType (SEQUENCE s))) as) (x:*:xs) = do ms2 <- encodeSetAuxCO [] s x encodeSetAux eu (ms ++ ms2) as xs encodeSetAux eu ms (AddComponent (ComponentsOf (ReferencedType n t)) as) (x:*:xs) = encodeSetAux eu ms (AddComponent (ComponentsOf t) as) (x:*:xs) encodeSetAux eu ms (AddComponent (ComponentsOf (ConstrainedType t c)) as) (x:*:xs) = encodeSetAux eu ms (AddComponent (ComponentsOf t) as) (x:*:xs) encodeSetAux eu ms (AddComponent (MandatoryComponent (NamedType t a)) as) (x:*:xs) = encodeSetAux eu (ms ++ [(getTI a, (Nothing, encode a [] x))]) as xs encodeSetAux eu ms (AddComponent (ExtensionComponent (NamedType t a)) as) (Nothing:*:xs) = encodeSetAux eu ms as xs encodeSetAux (b1,b2) ms (AddComponent (ExtensionComponent (NamedType t a)) as) (Just x:*:xs) = encodeSetAux (b1, Used) ms as xs encodeSetAux eu ms (AddComponent (OptionalComponent (NamedType t a)) as) (Nothing:*:xs) = {- X691REF: 18.2 with optional component not present -} encodeSetAux eu (ms ++ [(getTI a, (Just 0, noBit))]) as xs encodeSetAux eu ms (AddComponent (OptionalComponent (NamedType t a)) as) (Just x:*:xs) = {- X691REF: 18.2 with optional component present -} encodeSetAux eu (ms ++ [(getTI a, (Just 1, encode a [] x))]) as xs encodeSetAux eu ms (AddComponent (DefaultComponent (NamedType t a) d) as) (Nothing:*:xs) = {- X691REF: 18.2 with default value -} {- X691REF: 18.5 with default value (CANONICAL_PER) -} encodeSetAux eu (ms ++ [(getTI a, (Just 0, noBit))]) as xs encodeSetAux eu ms (AddComponent (DefaultComponent (NamedType t a) d) as) (Just x:*:xs) = {- X691REF: 18.2 with default component present -} encodeSetAux eu (ms ++ [(getTI a, (Just 1, encode a [] x))]) as xs encodeSetAux (b1,b2) ms (ExtensionAdditionGroup _ _ as) (x:*:xs) = encodeSetAux (b1,Used) ms as xs encodeSetAuxExt :: ExtAndUsed -> [(TagInfo, (Maybe Int, PERMonad ()))] -> ExtBits -> Sequence a -> a -> PERMonad ((ExtAndUsed, ExtBits, PERMonad (OptDefBits, BB.BitBuilder -> BB.BitBuilder))) encodeSetAuxExt b ms eb (AddComponent (ExtensionComponent (NamedType t a)) as) (Nothing:*:xs) = {- X691REF: 18.7 with extension addition absent -} encodeSetAuxExt b ms (eb ++ [0]) as xs encodeSetAuxExt (b1,b2) ms eb (AddComponent (ExtensionComponent (NamedType t a)) as) (Just x:*:xs) = do {- X691REF: 18.7 with extension addition present -} {- X691REF: 18.9 with ComponentType extension -} encodeOpen a x encodeSetAuxExt (b1,Used) ms (eb ++ [1]) as xs encodeSetAuxExt b ms eb (AddComponent (OptionalComponent (NamedType t a)) as) (Nothing:*:xs) = {- X691REF: 18.7 with extension addition absent -} encodeSetAuxExt b ms (eb ++ [0]) as xs encodeSetAuxExt (b1,b2) ms eb (AddComponent (OptionalComponent (NamedType t a)) as) (Just x:*:xs) = do {- X691REF: 18.7 with extension addition present -} {- X691REF: 18.9 with ComponentType extension -} encodeOpen a x encodeSetAuxExt (b1,Used) ms (eb ++ [1]) as xs encodeSetAuxExt b ms eb (ExtensionAdditionGroup _ a as) (Nothing:*:xs) = {- X691REF: 18.7 with extension addition absent -} encodeSetAuxExt b ms (eb ++ [0]) as xs encodeSetAuxExt (b1,b2) ms eb (ExtensionAdditionGroup _ a as) (Just x:*:xs) = do {- X691REF: 18.7 with extension addition present -} {- X691REF: 18.9 with ExtensionAdditionGroup extension -} encodeOpen (BuiltinType (SEQUENCE (makeSequence a))) x encodeSetAuxExt (b1, Used) ms (eb ++ [1]) as xs encodeSetAuxExt b ms eb (ExtensionMarker as) xs = return (b, eb, encodeSetAux b ms as xs) encodeSetAuxExt b ms eb EmptySequence Empty = return (b, eb, encodeSetAux b ms EmptySequence Empty) encodeSetAuxExt b odb eb _ _ = throwError (OtherError "Inappropriate component!") \end{code} When encoding a ComponentsOf component, we simply extract and encode the root components of the type. \begin{code} encodeSetAuxCO :: [(TagInfo, (Maybe Int, PERMonad ()))] -> Sequence a -> a -> PERMonad [(TagInfo, (Maybe Int, PERMonad ()))] encodeSetAuxCO ms EmptySequence _ = return ms encodeSetAuxCO ms (ExtensionMarker as) xs = encodeSetAuxCO ms as xs encodeSetAuxCO ms (AddComponent (ComponentsOf (BuiltinType (SEQUENCE s))) as) (x:*:xs) = do ms2 <- encodeSetAuxCO [] s x encodeSetAuxCO (ms ++ ms2) as xs encodeSetAuxCO odb (AddComponent (ComponentsOf _) as) (x:*:xs) = throwError (OtherError "COMPONENTS OF can only be applied to a SEQUENCE") encodeSetAuxCO ms (AddComponent (MandatoryComponent (NamedType t a)) as) (x:*:xs) = encodeSetAuxCO (ms ++ [(getTI a, (Nothing, encode a [] x))]) as xs encodeSetAuxCO odb (AddComponent (ExtensionComponent (NamedType t a)) as) (_:*:xs) = encodeSetAuxCO odb as xs encodeSetAuxCO ms (AddComponent (OptionalComponent (NamedType t a)) as) (Nothing:*:xs) = encodeSetAuxCO (ms ++ [(getTI a, (Just 0, noBit))]) as xs encodeSetAuxCO ms (AddComponent (OptionalComponent (NamedType t a)) as) (Just x:*:xs) = encodeSetAuxCO (ms ++ [(getTI a, (Just 1, encode a [] x))]) as xs encodeSetAuxCO ms (AddComponent (DefaultComponent (NamedType t a) d) as) (Nothing:*:xs) = encodeSetAuxCO (ms ++ [(getTI a, (Just 0, noBit))]) as xs encodeSetAuxCO ms (AddComponent (DefaultComponent (NamedType t a) d) as) (Just x:*:xs) = encodeSetAuxCO (ms ++ [(getTI a, (Just 1, encode a [] x))]) as xs encodeSetAuxCO ms (ExtensionAdditionGroup _ _ as) (x:*:xs) = encodeSetAuxCO ms as xs \end{code} \section{ENCODING THE SET-OF TYPE} SET-OF types are encoded as SEQUENCE-OF types except that CANONICAL-PER requires that the component values of a SET-OF type are encoded in ascending order of their same-length encodings. That is, each encoding is converted to a integral multiple of octet encoding by appending with 0 bits, and then these are converted to the same length as the longest encoding by appending 0-octets. \begin{code} encodeSetOf :: [SubtypeConstraint [a]] -> ASNType a -> [a] -> PERMonad () encodeSetOf [] t x = {- X691REF: 19.6 with ub unset -} encodeUnconstrainedSetOf t x encodeSetOf cl t x = encodeSetOfWithConstraint t cl x encodeUnconstrainedSetOf :: ASNType a -> [a] -> PERMonad () encodeUnconstrainedSetOf t xs = do {- X691REF: 21.1 -} ols <- orderedSetOf t xs encodeUnconstrainedLength tell ols \end{code} The function {\em orderedSetOf} orders the component value encodings as required by X691: 21.1. \begin{code} orderedSetOf :: ASNType a -> [a] -> PERMonad [BB.BitBuilder] orderedSetOf t ls = let els = map (selectOutput . extractValue . encode t []) ls -- pls = map padBits els -- nls = zipWith (++) els pls nls = map BB.toLazyByteString els long = maximum (map BL.length nls) xls = map (\x -> appendZeroes (long - (BL.length x))BL.empty) nls ols = L.zip (L.zipWith BL.append nls xls) els in return (L.map snd (L.sortBy order ols)) {- padBits :: BB.BitBuilder -> BB.BitBuilder padBits enc = let le = length enc bts = le `mod` 8 pad = if bts == 0 then [] else take (8-bts) [0,0..] in pad -} appendZeroes :: Int64 -> BL.ByteString -> BL.ByteString appendZeroes i bs = if i == 0 then bs else appendZeroes (i-1) (BL.append bs zero) zero :: BL.ByteString zero = BL.singleton 0 order :: (BL.ByteString, BB.BitBuilder) -> (BL.ByteString, BB.BitBuilder) -> Ordering order (f,s) (x,y) | f < x = LT | f == x = EQ | otherwise = GT \end{code} {\em encodeSetOfWithConstraint} calls {\em encodeNonExtConsSetOf} if the constraint is not extensible. If it is extensible then {\em encodeExtConsSetOf} is called. They both take the effective constraint and actual constraint associated with the type as input. \begin{code} encodeSetOfWithConstraint :: ASNType a -> [SubtypeConstraint [a]] -> [a] -> PERMonad () encodeSetOfWithConstraint t cs v = if (not extensible) then encodeNonExtConsSetOf t actualCon effectiveCon v else {- X691REF: 19.4 -} encodeExtConsSetOf t actualCon effectiveCon v where effectiveCon :: Either String (ExtensibleConstraint IntegerConstraint) effectiveCon = evaluateConstraint pvSequenceOfElements top cs actualCon :: Either String (ExtensibleConstraint ValidIntegerConstraint) actualCon = evaluateConstraint pvSequenceOfElements top cs extensible = eitherExtensible effectiveCon \end{code} {\em encodeNonExtConsSetOf} has to deal with three cases. \begin{itemize} \item There are no PER-visible constraints. The function {\em encodeUnconstrainedSetOf} is called. \item The constraint is empty and thus no values can be encoded. Note that this means that there is a PER-visible size constraint that has no values. An appropriate error is thrown. \item There is a PER-visible constraint. The function {\em encodeConstrainedSetOf} is called. \end{itemize} \begin{code} encodeNonExtConsSetOf :: ASNType a -> Either String (ExtensibleConstraint ValidIntegerConstraint) -> Either String (ExtensibleConstraint IntegerConstraint) -> [a] -> PERMonad () encodeNonExtConsSetOf t _ (Right (ExtensibleConstraint (IntegerConstraint NegInf PosInf) _ _)) vs = {- X691REF: 19.6 with ub unset -} encodeUnconstrainedSetOf t vs encodeNonExtConsSetOf t (Right ok) (Right vsc) vs | isEmptyConstraint rc = throwError (ConstraintError "Empty constraint") | otherwise = {- X691REF: 19.5 - 19.6 -} encodeConstrainedSetOf t [] l u vrc vs where rc = getRootConstraint vsc l = lower rc u = upper rc vrc = getRootConstraint ok \end{code} {\em encodeExtConsSetOf} has to deal with three cases. \begin{itemize} \item There are no PER-visible constraints. The function {\em encodeUnconstrainedSetOf} is called. \item The constraint is empty and thus no values can be encoded. Note that this means that there is a PER-visible size constraint that has no values. An appropriate error is thrown. \item There is a PER-visible constraint. The function {\em encodeConstrainedSetOf} is called with the prefix bit set to 0. If this results in an error (the value cannot satisfy the constraint root) then {\em encodeExtConstrainedSetOf} is called and the prefix bit is set to 1. The function Haskell library function {\em catchError} manages the error/non-error cases. \end{itemize} \begin{code} encodeExtConsSetOf :: ASNType a -> Either String (ExtensibleConstraint ValidIntegerConstraint) -> Either String (ExtensibleConstraint IntegerConstraint) -> [a] -> PERMonad() encodeExtConsSetOf t _ (Right (ExtensibleConstraint (IntegerConstraint NegInf PosInf) (IntegerConstraint NegInf PosInf) _)) vs = {- X691REF: 19.6 with ub unset -} encodeUnconstrainedSetOf t vs encodeExtConsSetOf t (Right ok) (Right vsc) vs | isEmptyConstraint rc = throwError (ConstraintError "Empty constraint") | otherwise = do catchError (do {- X691REF: 19.4 within root -} encodeConstrainedSetOf t [0] l u vrc vs) (\err -> do {- X691REF: 19.4 not in root -} encodeNonExtRootConSetOf t rc ec vec vs) where rc = getRootConstraint vsc l = lower rc u = upper rc ec = getExtConstraint vsc vrc = getRootConstraint ok vec = getExtConstraint ok \end{code} {\em encodeConstrainedSetOf} first checks if the value satisfies the constraint. Note that with UNALIGNED PER if the upper bound of a constraint is greater or equal to 64K then the encoding of the length determinant is the same as it would be for an unconstrained length (X691: 10.9.4.2 Note). \begin{code} encodeConstrainedSetOf :: ASNType a -> PrefixBit -> InfInteger -> InfInteger -> ValidIntegerConstraint -> [a] -> PERMonad () encodeConstrainedSetOf t pb l u (Valid vrc) xs | inSizeRange xs vrc = if u == l && u <= 65536 then {- X691REF: 19.5 -} do tell $ toBitBuilder pb ols <- orderedSetOf t xs mapM_ tell ols else if u <= 65536 then {- X691REF: 19.6 with ub set -} do tell $ toBitBuilder pb toNonNegBinaryInteger ((fromInteger . genericLength $ xs) - l) (u - l) {- X691REF: 21.1 -} ols <- orderedSetOf t xs mapM_ tell ols else {- X691REF: 19.6 with ub unset -} do tell $ toBitBuilder pb encodeUnconstrainedSetOf t xs | otherwise = throwError (BoundsError "Size out of range") encodeNonExtRootConSetOf :: ASNType a -> IntegerConstraint -> IntegerConstraint -> ValidIntegerConstraint -> [a] -> PERMonad () encodeNonExtRootConSetOf t rc ec (Valid erc) xs | inSizeRange xs erc = do oneBit encodeUnconstrainedSetOf t xs | otherwise = throwError (BoundsError "Size out of range") \end{code} \section{ENCODING THE CHOICE TYPE} {\em encodeChoice} encodes CHOICE values. It is not dissimilar to {\em encodeSet} in that the possible choice components must be assigned an index based on their canonical ordering. This index, which starts from 0, prefixes the value encoding and is absent if there is only a single choice. \begin{code} encodeChoice :: Choice a -> ExactlyOne a SelectionMade -> PERMonad () encodeChoice c x = let (b,(r,e)) = getCTags True ([],[]) c {- X691REF: 22.2 -} ids = assignIndices (r,e) in encodeChoiceAux (b,ids) c x type ChoiceRootIndices = [Int] type ChoiceExtIndices = [Int] assignIndices :: (ChoiceRootTags, ChoiceExtTags) -> (ChoiceRootIndices, ChoiceExtIndices) assignIndices (r,e) = let ri = indices r re = indices e in (ri,re) indices :: Ord a => [a] -> [Int] indices xs = let sxs = L.sort xs in map (\(Just x) -> x) (indices' xs sxs) indices' :: Eq a => [a] -> [a] -> [Maybe Int] indices' [] sxs = [] indices' (f:r) sxs = (elemIndex f sxs : indices' r sxs) \end{code} The auxilliary function {\em encodeChoiceAux} manages the various choice cases. The cases are: \begin{itemize} \item if no choice is chosen as indicated by the constructor {\em EmptyChoice} then an error is thrown; \item an extension marker results in the function {\em encodeChoiceExtAux} being called. This deals with a choice that is not chosen from the extension root; \item if a root option is not chosen then the function {\em encodeChoiceAux'} is called. This indicates that there is at least two root options and thus the index must be encoded; \item if the first root option is chosen and there is only one root index as indicated by the Haskell singleton list {\em [f]}, then the choice index is not encoded. The encoding of the choice value is prefixed by a {\em 0} bit is the type is extensible; \item an extension addition group suggests an erroneous CHOICE type since this can only appear after an extension marker. \end{itemize} The function {\em encodeChoiceAux'} is similar to {\em encodeChoiceAux} except that there is not single root choice case. \begin{code} type NoExtension = Bool encodeChoiceAux :: (NoExtension, (ChoiceRootIndices, ChoiceExtIndices)) -> Choice a -> ExactlyOne a n -> PERMonad () encodeChoiceAux ids EmptyChoice _ = throwError (OtherError "No choice value!") encodeChoiceAux ids (ChoiceExtensionMarker as) xs = encodeChoiceExtAux ids as xs encodeChoiceAux (b,(f:r,e)) (ChoiceOption a as) (AddNoValue x xs) = let l = genericLength r in encodeChoiceAux' l (b,(r,e)) as xs encodeChoiceAux (b, ([f],e)) (ChoiceOption (NamedType t a) as) (AddAValue x xs) = do if b then {- X691REF: 22.4, 22.5 and 22.7 -} zeroBit else {- X691REF: 22.4 and 22.6 -} return () encode a [] x encodeChoiceAux ids@(b, ((f:g:r),e)) (ChoiceOption (NamedType t a) as) (AddAValue x xs) = do if b then {- X691REF: 22.5 and 22.7 -} zeroBit else {- X691REF: 22.6 -} oneBit -- tell [] toNonNegBinaryInteger (fromInteger . toInteger $ f) (fromInteger . genericLength $ g:r) encode a [] x encodeChoiceAux _ (ChoiceExtensionAdditionGroup _ _ ) _ = throwError (OtherError "Impossible case: EXTENSION ADDITION GROUP only appears in an extension.") encodeChoiceAux' :: Integer -> (NoExtension, (ChoiceRootIndices, ChoiceExtIndices)) -> Choice a -> ExactlyOne a n -> PERMonad () encodeChoiceAux' l ids EmptyChoice _ = throwError (OtherError "No choice value!") encodeChoiceAux' l ids (ChoiceExtensionMarker as) xs = encodeChoiceExtAux ids as xs encodeChoiceAux' l (b,(f:r,e)) (ChoiceOption a as) (AddNoValue x xs) = encodeChoiceAux' l (b,(r,e)) as xs encodeChoiceAux' l (b, (f:r,e)) (ChoiceOption (NamedType t a) as) (AddAValue x xs) = do tell $ BB.singleton b toNonNegBinaryInteger (fromInteger . toInteger $ f) (fromInteger l) encode a [] x encodeChoiceAux' _ _ (ChoiceExtensionAdditionGroup _ _ ) _ = throwError (OtherError "Impossible case: EXTENSION ADDITION GROUP only appears in an extension.") \end{code} The function {\em encodeChoiceExtAux} processes values that are not in the extension root of a CHOICE type. It is similar to {\em encodeChoiceAux} except that: \begin{itemize} \item an extension addition group is a valid component and results in its components being processed; \item if the chosen value is in the extension then the choice index is encoded as a normally small non-negative integer, the value is encoded as an open type value, and these encodings are prefixed by a single {\em 1} bit. \end{itemize} \begin{code} encodeChoiceExtAux :: (NoExtension, (ChoiceRootIndices, ChoiceExtIndices)) -> Choice a -> (ExactlyOne a n) -> PERMonad () encodeChoiceExtAux ids EmptyChoice _ = throwError (OtherError "No choice value!") encodeChoiceExtAux ids(ChoiceExtensionMarker as) xs = encodeChoiceAux ids as xs encodeChoiceExtAux ids (ChoiceExtensionAdditionGroup _ as) xs = encodeChoiceExtAux' ids as xs encodeChoiceExtAux (b,(r, (f:e))) (ChoiceOption a as) (AddNoValue x xs) = encodeChoiceExtAux (b, (r,e)) as xs encodeChoiceExtAux (b,(r, (f:e))) (ChoiceOption (NamedType t a) as) (AddAValue x xs) = do {- X691REF: 22.5 and 22.8 -} oneBit encodeNSNNInt (toInteger f) 0 encodeOpen a x encodeChoiceExtAux' :: (NoExtension, (ChoiceRootIndices, ChoiceExtIndices)) -> Choice' a -> (ExactlyOne a n) -> PERMonad () encodeChoiceExtAux' ids EmptyChoice' _ = throwError (OtherError "No choice value!") encodeChoiceExtAux' ids ChoiceExtensionMarker' _ = throwError (OtherError "No choice value!") encodeChoiceExtAux' (b,(r, (f:e))) (ChoiceOption' a as) (AddNoValue x xs) = encodeChoiceExtAux' (b, (r,e)) as xs encodeChoiceExtAux' (b,(r, (f:e))) (ChoiceOption' (NamedType t a) as) (AddAValue x xs) = do {- X691REF: 22.5 and 22.8 -} oneBit encodeNSNNInt (toInteger f) 0 encodeOpen a x \end{code} \section{ENCODING THE RESTRICTED CHARACTER STRING TYPES} There are two categories of restricted character string types -- known-multiplier character strings and others. We have currently only implemented the known-multiplier category. {\em encodeKMS} takes the usual two inputs -- the list of serially applied constraints and the value to be encoded. If the constraint list is empty the function {\em encodeUnconstrainedKMS} is called. Otherwise, {\em encodeKMSWithConstraint} is called. Note that there are two ways in which a known-multiplier string type may have no PER-visible constraints. The first is when there are no constraints associated with the type. The second is when all of the serially applied constraints are non-PER visible since a non-PER visible complete constraint is ignored. This is determined when generating the effective constraint for a type using the function {\em lSerialeffectiveCon} defined in the module {\em ConstraintGeneration}. Note that {\em encodeKMS} is a constrained polymorphic type that applies to a set of known-multiplier string types. Each is a member of three type classes: \begin{itemize} \item {\em Eq} so that there values can be tested for equality; \item {\em RS} a type class of restricted string types defined in the module {\em LatticeMod}. It include methods to access the string from a restricted value and vice versa; and \item {\em Lattice} a type class also defined in {\em LatticeMod}. It specifies all of the behavioural requirements of a {\bf bounded lattice} such as join and meet operations and a greatest ({\em top}) and least ({\em bottom}) element. Note that each type will have its own greatest element which is the complete set of possible values as defined in X.691 27.5.3. \end{itemize} \begin{code} encodeKMS :: (Eq a, RS a, Lattice a) => SerialSubtypeConstraints a -> a -> PERMonad () encodeKMS [] x = {- X691REF: 27.5.1 with no permitted alphabet constraint -} encodeUnconstrainedKMS x encodeKMS cs x = encodeKMSWithConstraint cs x c11 :: Either String (ExtensibleConstraint (ResStringConstraint VisibleString IntegerConstraint)) c11 = evaluateSingleConstraint False pvKnownMultiplierElements extCon3 c12 :: Either String (ExtensibleConstraint (ResStringConstraint VisibleString IntegerConstraint)) c12 = evaluateSingleConstraint False pvKnownMultiplierElements pac1 pac1 :: SubtypeConstraint VisibleString pac1 = RootOnly (UnionSet (UnionMark ( NoUnion (NoIntersection (ElementConstraint (SZ (SC (RootOnly (UnionSet ( NoUnion (NoIntersection (ElementConstraint (V (R (1,5))))))))))))) (NoIntersection (ElementConstraint (P (FR (RootOnly (UnionSet ( NoUnion (NoIntersection (ElementConstraint (S (SV (VisibleString "dan")))))))))))))) extCon :: SubtypeConstraint VisibleString extCon = RootOnly (UnionSet ( NoUnion (NoIntersection (ElementConstraint (P (FR (NonEmptyExtension (UnionSet ( NoUnion (NoIntersection (ElementConstraint (S (SV (VisibleString "ABC"))))))) (UnionSet ( NoUnion (NoIntersection (ElementConstraint (S (SV (VisibleString "0123456789")))))))))))))) extCon3 :: SubtypeConstraint VisibleString extCon3 = RootOnly (UnionSet ( NoUnion (NoIntersection (ElementConstraint (P (FR (RootOnly (UnionSet ( NoUnion (NoIntersection (ElementConstraint (S (SV (VisibleString "ABC")))))))))))))) extCon2 :: SubtypeConstraint VisibleString extCon2 = RootOnly (ComplementSet (EXCEPT (P (FR (NonEmptyExtension (UnionSet ( NoUnion (NoIntersection (ElementConstraint (S (SV (VisibleString "ABC"))))))) (UnionSet ( NoUnion (NoIntersection (ElementConstraint (S (SV (VisibleString "0123456789")))))))))))) \end{code} {\em encodeUnconstrainedKMS} encodes an unconstrained known-multiplier type value. If the string is formed of characters from the required type then it calls {\em encodeKMString}. The test is done by the function {\em isOKString}. \begin{code} encodeUnconstrainedKMS :: (Eq a, RS a, Lattice a) => a -> PERMonad () encodeUnconstrainedKMS vs | isOKString vs top = encodeKMString vs | otherwise = throwError (BoundsError "Invalid value!") isOKString :: RS a => a -> a -> Bool isOKString x y = elems (getString x) (getString y) elems :: Eq a => [a] -> [a] -> Bool elems xs ys = all (flip elem ys) xs \end{code} {\em encodeKMString} encodes a known-multiplier string with unconstrained length and a permitted-alphabet constraint of the whole type. {\em encodeKMPermAlph} encodes each character in a string based on the rules specified in X.691 27.5.2 and 27.5.4. Since the permitted-alphabet constraint is the entire alphabet we use the {\em LatticeMod} entity {\em top} which represents the greatest element of the particular known-multiplier string type -- the entire alphabet. \begin{code} encodeKMString :: (RS a, Lattice a) => a -> PERMonad () encodeKMString vs = let t = getTop vs in {- X691REF: 27.5.7 -} encodeWithLength top (encodeKMPermAlph (getString t)) (getString vs) getTop :: (RS a, Lattice a) => a -> a getTop m = top encodeKMPermAlph :: String -> Char -> PERMonad () encodeKMPermAlph p c = {- X691REF: 27.5.2 and 27.5.4 -} let sp = L.sort p lp = genericLength p b = minExp 2 0 lp mp = maximum p in if ord mp < 2^b -1 then {- X691REF: 27.5.4 (a) -} encodeCharInBits lp c else {- X691REF: 27.5.4 (b) -} let v = (genericLength . findV c) sp l = fromInteger $ lp-1 in toNonNegBinaryInteger v l minExp :: (Num a, Integral b, Ord a) => a -> b -> a -> b minExp n e p = if n^e < p then minExp n (e+1) p else e \end{code} Each character is encoded by {\em encodeCharInBits} which encodes the Unicode value of the character in the required number of bits. This is achieved by converting a character to its Unicode value and then encoding the number as a constrained integer using {\em toNonNegBinaryInteger}. \begin{code} encodeCharInBits :: Integer -> Char -> PERMonad () encodeCharInBits i c = toNonNegBinaryInteger (fromInteger . fromIntegral . ord $ c) (fromInteger i) \end{code} {\em encodeKMSWithConstraint} calls {\em encodeNonExtConsKMS} if the constraint is not extensible and the input is valid (for the particular known-multiplier string). If it is extensible and the input is valid then {\em encodeExtConsKMS} is called. They both take the effective constraint and actual constraint associated with the type as input. \begin{code} encodeKMSWithConstraint :: (Eq a, RS a, Lattice a) => SerialSubtypeConstraints a -> a -> PERMonad () encodeKMSWithConstraint cs vs | isOKString vs top && not extensible = encodeNonExtConsKMS (effectiveCon cs) (actualCon cs) vs | isOKString vs top = {- X691REF: 27.4 -} encodeExtConsKMS (effectiveCon cs) (actualCon cs) vs | otherwise = throwError (BoundsError "Invalid value!") where extensible = eitherExtensible (effectiveCon cs) effectiveCon :: (RS a, Lattice a, Eq a) => SerialSubtypeConstraints a -> Either String (ExtensibleConstraint (ResStringConstraint a IntegerConstraint)) effectiveCon cs = let t = ResStringConstraint top top tp = ExtensibleConstraint t t False tpp = Right tp in evaluateConstraint pvKnownMultiplierElements tpp cs actualCon :: (RS a, Lattice a, Eq a) => SerialSubtypeConstraints a -> Either String (ExtensibleConstraint (ResStringConstraint a ValidIntegerConstraint)) actualCon cs = let t = ResStringConstraint top top tp = ExtensibleConstraint t t False tpp = Right tp in evaluateConstraint pvKnownMultiplierElements tpp cs \end{code} {\em encodeNonExtConsKMS} has several cases: \begin{itemize} \item if there is no valid effective constraint (signalled by a {\em Left} value) then an error indicating this problem is thrown; \item if the constraint is empty then an error is thrown since the constraint can never be satisfied; \item if the constraint is a mixture of a size and permitted alphabet constraint and both are satisfied by the input value then {\em encodeSizeAndPAConsKMS} is called; \item if the constraint is only a permitted alphabet constraint then {\em encodePAConsKMS} is called; \item if the constraint is only a size constraint then {\em encodeSizeConsKMS} is called; \item if there is no PER-visible constraint (such as an extensible permitted alphabet constraint) then the value is unconstrained and {\em encodeUnconstrainedLMS} is called; \item otherwise the input value does not satisfy the constraint and an error is thrown. \end{itemize} \begin{code} encodeNonExtConsKMS :: (RS a, Eq a, Lattice a) => Either String (ExtensibleConstraint (ResStringConstraint a IntegerConstraint)) -> Either String (ExtensibleConstraint (ResStringConstraint a ValidIntegerConstraint)) -> a -> PERMonad () encodeNonExtConsKMS (Left s) _ _ = throwError (OtherError s) encodeNonExtConsKMS (Right vsc) (Right ok) vs | isEmptyConstraint rc = throwError (ConstraintError "Empty constraint") | not noSizeConstraint && not noPAConstraint && inPA pac && inSizeRange (getString vs) oksc = encodeSizeAndPAConsKMS l u pac vs | noSizeConstraint && not noPAConstraint && inPA pac = encodePAConsKMS pac vs | noPAConstraint && not noSizeConstraint && inSizeRange (getString vs) oksc = encodeSizeConsKMS l u vs | noPAConstraint && noSizeConstraint = encodeUnconstrainedKMS vs | otherwise = throwError (BoundsError "Value out of range") where rc = getRootConstraint vsc okrc = getRootConstraint ok sc = getSizeConstraint rc Valid oksc = getSizeConstraint okrc pac = getPAConstraint rc noSizeConstraint = sc == top noPAConstraint = pac == top inPA x = elems (getString vs) (getString x) l = lower sc u = upper sc \end{code} {\em encodeExtConsKMS} has several cases: \begin{itemize} \item if there is no valid effective constraint (signalled by a {\em Left} value) then an error indicating this problem is thrown; \item if the constraint is empty then an error is thrown since the constraint can never be satisfied; \item if the constraint is a mixture of a size and permitted alphabet constraint and both are satisfied by the input value then {\em encodeSizeAndPAConsKMS} is called; \item if the constraint is only a permitted alphabet constraint then {\em encodePAConsKMS} is called; \item if the constraint is only a size constraint then {\em encodeSizeConsKMS} is called; \item otherwise the input value does not satisfy the constraint and an error is thrown. \end{itemize} \begin{code} encodeExtConsKMS :: (RS a, Eq a, Lattice a) => Either String (ExtensibleConstraint (ResStringConstraint a IntegerConstraint)) -> Either String (ExtensibleConstraint (ResStringConstraint a ValidIntegerConstraint)) -> a -> PERMonad () encodeExtConsKMS (Left s) _ _ = throwError (OtherError s) encodeExtConsKMS (Right vsc) (Right ok) vs | isEmptyConstraint rc = throwError (ConstraintError "Empty constraint") | otherwise = do catchError (do {- X691REF: 19.4 within root -} encodeConstrainedKMS [0] l u pc vrc vs) (\err -> do {- X691REF: 19.4 not in root -} encodeNonExtRootConKMS rc ec vrc vec vs) where rc = getRootConstraint vsc ec = getExtConstraint vsc vrc = getRootConstraint ok vec = getExtConstraint ok rsc = getSizeConstraint rc pc = getPAConstraint rc l = lower rsc u = upper rsc encodeConstrainedKMS :: (RS a, Eq a, Lattice a) => PrefixBit -> InfInteger -> InfInteger -> a -> ResStringConstraint a ValidIntegerConstraint -> a -> PERMonad () encodeConstrainedKMS pb l u pc vrc vs | noRootSizeConstraint && inPA pc = do tell $ toBitBuilder pb encodePAConsKMS pc vs | noRootPAConstraint && inSizeRange (getString vs) vrsc = do tell $ toBitBuilder pb encodeSizeConsKMS l u vs | inPA pc && inSizeRange (getString vs) vrsc = do tell $ toBitBuilder pb encodeSizeAndPAConsKMS l u pc vs | otherwise = throwError (BoundsError "Value out of range") where Valid vrsc = getSizeConstraint vrc noRootSizeConstraint = l == NegInf && u == PosInf noRootPAConstraint = pc == top inPA x = elems (getString vs) (getString x) {- FIXME check top here -} encodePAConsKMS :: (RS a) => a -> a -> PERMonad () encodePAConsKMS rcs1 rcs2 = encodeWithLength top (encodeKMPermAlph (getString rcs1)) (getString rcs2) encodeSizeConsKMS :: (RS a, Lattice a) => InfInteger -> InfInteger -> a -> PERMonad () encodeSizeConsKMS l u v | range == 1 && u < 65536 = mapM_ (encodeKMPermAlph (getString t)) x | u >= 65536 = encodeKMString v | otherwise = let Val r = range Val v = l in do toNonNegBinaryInteger (fromInteger $ genericLength x - v) (fromInteger $ r - 1) mapM_ (encodeKMPermAlph (getString t)) x where t = getTop v range = u - l + 1 x = getString v encodeSizeAndPAConsKMS :: (RS a) => InfInteger -> InfInteger -> a -> a -> PERMonad () encodeSizeAndPAConsKMS l u rcs v | range == 1 && u < 65536 = mapM_ (encodeKMPermAlph (getString rcs)) x | u >= 65536 = encodePAConsKMS rcs v | otherwise = let Val r = range Val v = l in do toNonNegBinaryInteger (fromInteger $ genericLength x - v) (fromInteger $ r - 1) mapM_ (encodeKMPermAlph (getString rcs)) x where range = u - l + 1 x = getString v encodeNonExtRootConKMS :: (RS a, Eq a, Lattice a) => ResStringConstraint a IntegerConstraint -> ResStringConstraint a IntegerConstraint -> ResStringConstraint a ValidIntegerConstraint -> ResStringConstraint a ValidIntegerConstraint -> a -> PERMonad () encodeNonExtRootConKMS rc ec okrc okec vs | (not noRootSizeConstraint && inSizeRange (getString vs) okrsc && noRootPAConstraint && not noExtPAConstraint && inPA epac) || (not noRootSizeConstraint && inSizeRange (getString vs) okrsc && not noRootPAConstraint && not noExtPAConstraint && not (inPA epac) && inPA expac) || (not noExtSizeConstraint && inSizeRange (getString vs) okesc && not noRootPAConstraint && inPA rpac) || (not noExtSizeConstraint && inSizeRange (getString vs) okesc && noRootPAConstraint && not noExtPAConstraint && inPA epac) || (not noExtSizeConstraint && inSizeRange (getString vs) okesc && not noRootPAConstraint && not noExtPAConstraint && not (inPA epac) && inPA expac) || (noRootSizeConstraint && noExtSizeConstraint && ((noRootPAConstraint && not noExtPAConstraint && inPA epac) || (not noRootPAConstraint && not noExtPAConstraint && not (inPA epac) && inPA expac))) = do oneBit -- tell [1] encodePAConsKMS top vs | noRootPAConstraint && noExtPAConstraint && inSizeRange (getString vs) okesc = do oneBit -- tell [1] encodeKMString vs | otherwise = throwError (BoundsError "Value out of range") where Valid okesc = getSizeConstraint okec Valid okrsc = getSizeConstraint okrc rsc = getSizeConstraint rc rpac = getPAConstraint rc esc = getSizeConstraint ec epac = getPAConstraint ec concStrs :: RS a => ResStringConstraint a i -> ResStringConstraint a i -> a concStrs rc ec = let r = (getString . getPAConstraint) rc e = (getString . getPAConstraint) ec in makeString (r++e) expac = concStrs rc ec noRootSizeConstraint = rsc == top noRootPAConstraint = rpac == top noExtSizeConstraint = esc == top noExtPAConstraint = epac == top inPA x = elems (getString vs) (getString x) \end{code} 27.5.4 Encoding of a RESTRICTED CHARACTER STRING with a permitted alphabet constraint. \begin{code} -- The first two cases are described in X.691 27.5.6 and 25.5.7 -- and the last case by 10.9 Note 3. \end{code} Clause 38.8 in X680 encoding based on canonical ordering of restricted character string characters \begin{code} canEnc b sp [] = return () -- tell [] canEnc b sp (f:r) = let v = (genericLength . findV f) sp in do toNonNegBinaryInteger v b canEnc b sp r findV m [] = [] findV m (a:rs) = if m == a then [] else a : findV m rs \end{code} \end{document}