-- |
-- Module      : Data.ASN1.Serialize
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : unknown
--
module Data.ASN1.Serialize (getHeader, putHeader) where

import qualified Data.ByteString as B
import Data.ASN1.Get
import Data.ASN1.Internal
import Data.ASN1.Types
import Data.ASN1.Types.Lowlevel
import Data.Bits
import Data.Word
import Control.Applicative ((<$>))
import Control.Monad

-- | parse an ASN1 header
getHeader :: Get ASN1Header
getHeader :: Get ASN1Header
getHeader = do
    (ASN1Class
cl,Bool
pc,ASN1Tag
t1) <- Word8 -> (ASN1Class, Bool, ASN1Tag)
parseFirstWord (Word8 -> (ASN1Class, Bool, ASN1Tag))
-> Get Word8 -> Get (ASN1Class, Bool, ASN1Tag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8
    ASN1Tag
tag        <- if ASN1Tag
t1 ASN1Tag -> ASN1Tag -> Bool
forall a. Eq a => a -> a -> Bool
== ASN1Tag
0x1f then Get ASN1Tag
getTagLong else ASN1Tag -> Get ASN1Tag
forall (m :: * -> *) a. Monad m => a -> m a
return ASN1Tag
t1
    ASN1Length
len        <- Get ASN1Length
getLength
    ASN1Header -> Get ASN1Header
forall (m :: * -> *) a. Monad m => a -> m a
return (ASN1Header -> Get ASN1Header) -> ASN1Header -> Get ASN1Header
forall a b. (a -> b) -> a -> b
$ ASN1Class -> ASN1Tag -> Bool -> ASN1Length -> ASN1Header
ASN1Header ASN1Class
cl ASN1Tag
tag Bool
pc ASN1Length
len

-- | Parse the first word of an header
parseFirstWord :: Word8 -> (ASN1Class, Bool, ASN1Tag)
parseFirstWord :: Word8 -> (ASN1Class, Bool, ASN1Tag)
parseFirstWord Word8
w = (ASN1Class
cl,Bool
pc,ASN1Tag
t1)
  where cl :: ASN1Class
cl = ASN1Tag -> ASN1Class
forall a. Enum a => ASN1Tag -> a
toEnum (ASN1Tag -> ASN1Class) -> ASN1Tag -> ASN1Class
forall a b. (a -> b) -> a -> b
$ Word8 -> ASN1Tag
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> ASN1Tag) -> Word8 -> ASN1Tag
forall a b. (a -> b) -> a -> b
$ (Word8
w Word8 -> ASN1Tag -> Word8
forall a. Bits a => a -> ASN1Tag -> a
`shiftR` ASN1Tag
6)
        pc :: Bool
pc = Word8 -> ASN1Tag -> Bool
forall a. Bits a => a -> ASN1Tag -> Bool
testBit Word8
w ASN1Tag
5
        t1 :: ASN1Tag
t1 = Word8 -> ASN1Tag
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
w Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x1f)

{- when the first tag is 0x1f, the tag is in long form, where
 - we get bytes while the 7th bit is set. -}
getTagLong :: Get ASN1Tag
getTagLong :: Get ASN1Tag
getTagLong = do
    ASN1Tag
t <- Word8 -> ASN1Tag
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> ASN1Tag) -> Get Word8 -> Get ASN1Tag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8
    Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ASN1Tag
t ASN1Tag -> ASN1Tag -> Bool
forall a. Eq a => a -> a -> Bool
== ASN1Tag
0x80) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$ String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"non canonical encoding of long tag"
    if ASN1Tag -> ASN1Tag -> Bool
forall a. Bits a => a -> ASN1Tag -> Bool
testBit ASN1Tag
t ASN1Tag
7
        then ASN1Tag -> Get ASN1Tag
forall b. (Num b, Bits b) => b -> Get b
loop (ASN1Tag -> ASN1Tag -> ASN1Tag
forall a. Bits a => a -> ASN1Tag -> a
clearBit ASN1Tag
t ASN1Tag
7)
        else ASN1Tag -> Get ASN1Tag
forall (m :: * -> *) a. Monad m => a -> m a
return ASN1Tag
t
  where loop :: b -> Get b
loop b
n = do
            b
t <- Word8 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> b) -> Get Word8 -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8
            if b -> ASN1Tag -> Bool
forall a. Bits a => a -> ASN1Tag -> Bool
testBit b
t ASN1Tag
7
                then b -> Get b
loop (b
n b -> ASN1Tag -> b
forall a. Bits a => a -> ASN1Tag -> a
`shiftL` ASN1Tag
7 b -> b -> b
forall a. Num a => a -> a -> a
+ b -> ASN1Tag -> b
forall a. Bits a => a -> ASN1Tag -> a
clearBit b
t ASN1Tag
7)
                else b -> Get b
forall (m :: * -> *) a. Monad m => a -> m a
return (b
n b -> ASN1Tag -> b
forall a. Bits a => a -> ASN1Tag -> a
`shiftL` ASN1Tag
7 b -> b -> b
forall a. Num a => a -> a -> a
+ b
t)


{- get the asn1 length which is either short form if 7th bit is not set,
 - indefinite form is the 7 bit is set and every other bits clear,
 - or long form otherwise, where the next bytes will represent the length
 -}
getLength :: Get ASN1Length
getLength :: Get ASN1Length
getLength = do
    ASN1Tag
l1 <- Word8 -> ASN1Tag
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> ASN1Tag) -> Get Word8 -> Get ASN1Tag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8
    if ASN1Tag -> ASN1Tag -> Bool
forall a. Bits a => a -> ASN1Tag -> Bool
testBit ASN1Tag
l1 ASN1Tag
7
        then case ASN1Tag -> ASN1Tag -> ASN1Tag
forall a. Bits a => a -> ASN1Tag -> a
clearBit ASN1Tag
l1 ASN1Tag
7 of
            ASN1Tag
0   -> ASN1Length -> Get ASN1Length
forall (m :: * -> *) a. Monad m => a -> m a
return ASN1Length
LenIndefinite
            ASN1Tag
len -> do
                ByteString
lw <- ASN1Tag -> Get ByteString
getBytes ASN1Tag
len
                ASN1Length -> Get ASN1Length
forall (m :: * -> *) a. Monad m => a -> m a
return (ASN1Tag -> ASN1Tag -> ASN1Length
LenLong ASN1Tag
len (ASN1Tag -> ASN1Length) -> ASN1Tag -> ASN1Length
forall a b. (a -> b) -> a -> b
$ ByteString -> ASN1Tag
uintbs ByteString
lw)
        else
            ASN1Length -> Get ASN1Length
forall (m :: * -> *) a. Monad m => a -> m a
return (ASN1Tag -> ASN1Length
LenShort ASN1Tag
l1)
  where
        {- uintbs return the unsigned int represented by the bytes -}
        uintbs :: ByteString -> ASN1Tag
uintbs = (ASN1Tag -> Word8 -> ASN1Tag) -> ASN1Tag -> ByteString -> ASN1Tag
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
B.foldl (\ASN1Tag
acc Word8
n -> (ASN1Tag
acc ASN1Tag -> ASN1Tag -> ASN1Tag
forall a. Bits a => a -> ASN1Tag -> a
`shiftL` ASN1Tag
8) ASN1Tag -> ASN1Tag -> ASN1Tag
forall a. Num a => a -> a -> a
+ Word8 -> ASN1Tag
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n) ASN1Tag
0

-- | putIdentifier encode an ASN1 Identifier into a marshalled value
putHeader :: ASN1Header -> B.ByteString
putHeader :: ASN1Header -> ByteString
putHeader (ASN1Header ASN1Class
cl ASN1Tag
tag Bool
pc ASN1Length
len) = [ByteString] -> ByteString
B.concat
    [ Word8 -> ByteString
B.singleton Word8
word1
    , if ASN1Tag
tag ASN1Tag -> ASN1Tag -> Bool
forall a. Ord a => a -> a -> Bool
< ASN1Tag
0x1f then ByteString
B.empty else ByteString
tagBS
    , ByteString
lenBS]
  where cli :: Word8
cli   = Word8 -> ASN1Tag -> Word8
forall a. Bits a => a -> ASN1Tag -> a
shiftL (ASN1Tag -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ASN1Tag -> Word8) -> ASN1Tag -> Word8
forall a b. (a -> b) -> a -> b
$ ASN1Class -> ASN1Tag
forall a. Enum a => a -> ASN1Tag
fromEnum ASN1Class
cl) ASN1Tag
6
        pcval :: Word8
pcval = Word8 -> ASN1Tag -> Word8
forall a. Bits a => a -> ASN1Tag -> a
shiftL (if Bool
pc then Word8
0x1 else Word8
0x0) ASN1Tag
5
        tag0 :: Word8
tag0  = if ASN1Tag
tag ASN1Tag -> ASN1Tag -> Bool
forall a. Ord a => a -> a -> Bool
< ASN1Tag
0x1f then ASN1Tag -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ASN1Tag
tag else Word8
0x1f
        word1 :: Word8
word1 = Word8
cli Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
pcval Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
tag0
        lenBS :: ByteString
lenBS = [Word8] -> ByteString
B.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ ASN1Length -> [Word8]
putLength ASN1Length
len
        tagBS :: ByteString
tagBS = ASN1Tag -> ByteString
forall i. (Bits i, Integral i) => i -> ByteString
putVarEncodingIntegral ASN1Tag
tag

{- | putLength encode a length into a ASN1 length.
 - see getLength for the encoding rules -}
putLength :: ASN1Length -> [Word8]
putLength :: ASN1Length -> [Word8]
putLength (LenShort ASN1Tag
i)
    | ASN1Tag
i ASN1Tag -> ASN1Tag -> Bool
forall a. Ord a => a -> a -> Bool
< ASN1Tag
0 Bool -> Bool -> Bool
|| ASN1Tag
i ASN1Tag -> ASN1Tag -> Bool
forall a. Ord a => a -> a -> Bool
> ASN1Tag
0x7f = String -> [Word8]
forall a. HasCallStack => String -> a
error String
"putLength: short length is not between 0x0 and 0x80"
    | Bool
otherwise         = [ASN1Tag -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ASN1Tag
i]
putLength (LenLong ASN1Tag
_ ASN1Tag
i)
    | ASN1Tag
i ASN1Tag -> ASN1Tag -> Bool
forall a. Ord a => a -> a -> Bool
< ASN1Tag
0     = String -> [Word8]
forall a. HasCallStack => String -> a
error String
"putLength: long length is negative"
    | Bool
otherwise = Word8
lenbytes Word8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
: [Word8]
lw
        where
            lw :: [Word8]
lw       = Integer -> [Word8]
bytesOfUInt (Integer -> [Word8]) -> Integer -> [Word8]
forall a b. (a -> b) -> a -> b
$ ASN1Tag -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ASN1Tag
i
            lenbytes :: Word8
lenbytes = ASN1Tag -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word8] -> ASN1Tag
forall (t :: * -> *) a. Foldable t => t a -> ASN1Tag
length [Word8]
lw ASN1Tag -> ASN1Tag -> ASN1Tag
forall a. Bits a => a -> a -> a
.|. ASN1Tag
0x80)
putLength (ASN1Length
LenIndefinite) = [Word8
0x80]