{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Data.ASN1.Prim
( TagPC(..)
, TL
, Tag(..)
, TagK(..), KnownTag(..)
, EncodingRule(..)
, isolate64
, putTagLength
, getTagLength
, getVarInt64
, putVarInt64
, asPrimitive
, getVarInteger
, putVarInteger
) where
import Common
import Data.Binary as Bin
import Data.Binary.Get as Bin
import Data.Binary.Put as Bin
data TagPC
= Primitive
| Constructed
deriving (Enum,Eq,Show)
data EncodingRule
= BER
| CER
| DER
deriving Eq
isolate64 :: Word64 -> Get a -> Get a
isolate64 sz64 act
| Just sz <- intCastMaybe sz64 = Bin.isolate sz act
| otherwise = fail "isolate64: exceeding supported limits"
type TL = (Tag, TagPC, Maybe Word64)
getTagLength :: EncodingRule -> Get (Maybe TL)
getTagLength r = do
eof <- isEmpty
if eof
then pure Nothing
else Just <$> do
(t,pc) <- getTag r
l <- getLength (r /= BER)
case (r,l,pc) of
(_,Nothing,Primitive) -> fail "indefinite length not allowed for primitive encoding"
(DER,Nothing,_) -> fail "indefinite length encoding not allowed by DER"
(CER,Just _,Constructed) -> fail "definite length not allowed for constructed encoding by CER"
_ -> pure ()
pure (t,pc,l)
putTagLength :: TL -> PutM Word64
putTagLength (_,Primitive,Nothing) = error "indefinite length not allowed for primitive encoding"
putTagLength (t,pc,msz) = (+) <$> putTag t pc <*> putLength msz
getTag :: EncodingRule -> Get (Tag, TagPC)
getTag _ = do
b0 <- getWord8
let !pc = if testBit b0 5 then Constructed else Primitive
n0 = b0 .&. 0x1f
!tn <- case n0 of
0x1f -> getXTagNum
_ -> pure (fromIntegral n0)
case b0 .&. 0xc0 of
0x00 -> pure (Universal tn, pc)
0x40 -> pure (Application tn, pc)
0x80 -> pure (Contextual tn, pc)
0xc0 -> pure (Private tn, pc)
_ -> fail "the impossible happened"
putTag :: Tag -> TagPC -> PutM Word64
putTag t pc = do
when (tagNum t >= 31) $ error "putTag: FIXME"
let w8_cls = case t of
Universal _ -> 0x00
Application _ -> 0x40
Contextual _ -> 0x80
Private _ -> 0xc0
w8_pc = case pc of
Constructed -> 0x20
Primitive -> 0x00
w8_tn = fromIntegral (tagNum t)
putWord8 (w8_cls .|. w8_pc .|. w8_tn)
pure 1
getXTagNum :: Get Word64
getXTagNum = do
(more0,n0) <- getWord7
let n0' = fromIntegral n0
when (n0' == 0) $
fail "lower 7 bits of the first subsequent tag-number octet shall not all be zero"
if more0
then go n0'
else pure n0'
where
go :: Word64 -> Get Word64
go !acc = do
(mo,o7) <- getWord7
let acc' = (acc `shiftL` 7) .|. fromIntegral o7
when (acc >= 0x0200000000000000) $
fail "tag number exceeds 64bit range"
if mo
then go acc'
else pure $! acc'
getWord7 :: Get (Bool,Word8)
getWord7 = do
x <- getWord8
let n = x .&. 0x7f
more = x /= n
pure (more, n)
getLength :: Bool -> Get (Maybe Word64)
getLength minimal = do
xb7 <- getWord7
case xb7 of
(False,n) -> pure $! Just $! fromIntegral n
(True,0) -> pure Nothing
(True,0x7f) -> fail "length octet with reserved value 0xff encountered"
(True,sz) -> Just <$> go sz 0
where
go :: Word8 -> Word64 -> Get Word64
go 0 acc
| minimal, acc < 0x1f = fail "length not encoded minimally"
| otherwise = pure acc
go sz acc = do
when (acc >= 0x0100000000000000) $
fail "length exceeds 64bit quantity"
x <- getWord8
let acc' = (acc `shiftL` 8) .|. fromIntegral x
when (minimal && acc == 0 && x == 0) $
fail "length not encoded minimally"
go (sz-1) acc'
putLength :: Maybe Word64 -> PutM Word64
putLength Nothing = putWord8 0x80 *> pure 1
putLength (Just sz)
| sz < 0x80 = putWord8 (fromIntegral sz) *> pure 1
| otherwise = do
let w8s = splitWord64 sz
n = length w8s
putWord8 (0x80 + fromIntegral n)
mapM_ putWord8 w8s
pure (1 + fromIntegral n)
asPrimitive :: (Word64 -> Get x) -> TL -> Get x
asPrimitive _ (_,_,Nothing) = fail "indefinite length not allowed"
asPrimitive _ (_,Constructed,_) = fail "must be primitive"
asPrimitive f (_,Primitive,Just sz) = f sz
getInt24be :: Get Int32
getInt24be = do
hi <- getInt8
lo <- getWord16be
pure $! (fromIntegral hi `shiftL` 16) + fromIntegral lo
getInt40be :: Get Int64
getInt40be = do
hi <- getInt8
lo <- getWord32be
pure $! (fromIntegral hi `shiftL` 32) + fromIntegral lo
getInt48be :: Get Int64
getInt48be = do
hi <- getInt16be
lo <- getWord32be
pure $! (fromIntegral hi `shiftL` 32) + fromIntegral lo
getInt56be :: Get Int64
getInt56be = do
hi <- getInt24be
lo <- getWord32be
pure $! (fromIntegral hi `shiftL` 32) + fromIntegral lo
getVarInt64 :: Word64 -> Get Int64
getVarInt64 = \case
0 -> fail "invalid zero-sized INTEGER"
1 -> fromIntegral <$> getInt8
2 -> fromIntegral <$> getInt16be
3 -> fromIntegral <$> getInt24be
4 -> fromIntegral <$> getInt32be
5 -> getInt40be
6 -> getInt48be
7 -> getInt56be
8 -> getInt64be
_ -> fail "INTEGER too large for type"
getVarInteger :: Word64 -> Get Integer
getVarInteger sz
| sz <= 8 = toInteger <$> getVarInt64 sz
| otherwise = fail "INTEGER: FIXME/TODO"
putVarInt64 :: Int64 -> PutM Word64
putVarInt64 i = do
mapM_ Bin.putWord8 w8s
pure (fromIntegral $ length w8s)
where
w8s = splitInt64 i
putVarInteger :: Integer -> PutM Word64
putVarInteger j
| Just i <- intCastMaybe j = putVarInt64 i
| otherwise = error "putVarInteger: FIXME"
splitInt64 :: Int64 -> [Word8]
splitInt64 i
| i >= 0x80 = goP i False []
| i < -0x80 = goN i True []
| otherwise = [fromIntegral i]
where
goP 0 False acc = acc
goP 0 True acc = 0x00 : acc
goP j _ acc = goP (j `shiftR` 8) (w8 >= 0x80) (w8 : acc)
where w8 = fromIntegral (j .&. 0xff)
goN (-1) True acc = acc
goN (-1) False acc = 0xff : acc
goN j _ acc = goN (j `shiftR` 8) (w8 >= 0x80) (w8 : acc)
where w8 = fromIntegral (j .&. 0xff)
splitWord64 :: Word64 -> [Word8]
splitWord64 i
| i > 0xff = go i []
| otherwise = [fromIntegral i]
where
go 0 acc = acc
go j acc = go (j `shiftR` 8) (w8 : acc)
where w8 = fromIntegral (j .&. 0xff)
data Tag = Universal { tagNum :: !Word64 }
| Application { tagNum :: !Word64 }
| Contextual { tagNum :: !Word64 }
| Private { tagNum :: !Word64 }
deriving (Eq,Ord)
instance Show Tag where
show = \case
Universal n -> "[UNIVERSAL " ++ show n ++ "]"
Application n -> "[APPLICATION " ++ show n ++ "]"
Contextual n -> "[" ++ show n ++ "]"
Private n -> "[PRIVATE " ++ show n ++ "]"
data TagK = UNIVERSAL Nat
| APPLICATION Nat
| CONTEXTUAL Nat
| PRIVATE Nat
class KnownTag (tag :: TagK) where
tagVal :: Proxy tag -> Tag
instance forall n . (KnownNat n) => KnownTag ('UNIVERSAL n) where
tagVal _ = Universal (fromIntegral $ natVal (Proxy :: Proxy n))
instance forall n . (KnownNat n) => KnownTag ('APPLICATION n) where
tagVal _ = Application (fromIntegral $ natVal (Proxy :: Proxy n))
instance forall n . (KnownNat n) => KnownTag ('CONTEXTUAL n) where
tagVal _ = Contextual (fromIntegral $ natVal (Proxy :: Proxy n))
instance forall n . (KnownNat n) => KnownTag ('PRIVATE n) where
tagVal _ = Private (fromIntegral $ natVal (Proxy :: Proxy n))