-- Copyright (c) 2018-2019  Herbert Valerio Riedel <hvr@gnu.org>
--
--  This file is free software: you may copy, redistribute and/or modify it
--  under the terms of the GNU General Public License as published by the
--  Free Software Foundation, either version 2 of the License, or (at your
--  option) any later version.
--
--  This file is distributed in the hope that it will be useful, but
--  WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program (see `LICENSE`).  If not, see
--  <https://www.gnu.org/licenses/old-licenses/gpl-2.0.html>.

{-# 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.Int.Subtypes

import           Data.Binary       as Bin
import           Data.Binary.Get   as Bin
import           Data.Binary.Put   as Bin

data TagPC
  = Primitive
  | Constructed
  deriving (Int -> TagPC
TagPC -> Int
TagPC -> [TagPC]
TagPC -> TagPC
TagPC -> TagPC -> [TagPC]
TagPC -> TagPC -> TagPC -> [TagPC]
(TagPC -> TagPC)
-> (TagPC -> TagPC)
-> (Int -> TagPC)
-> (TagPC -> Int)
-> (TagPC -> [TagPC])
-> (TagPC -> TagPC -> [TagPC])
-> (TagPC -> TagPC -> [TagPC])
-> (TagPC -> TagPC -> TagPC -> [TagPC])
-> Enum TagPC
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: TagPC -> TagPC -> TagPC -> [TagPC]
$cenumFromThenTo :: TagPC -> TagPC -> TagPC -> [TagPC]
enumFromTo :: TagPC -> TagPC -> [TagPC]
$cenumFromTo :: TagPC -> TagPC -> [TagPC]
enumFromThen :: TagPC -> TagPC -> [TagPC]
$cenumFromThen :: TagPC -> TagPC -> [TagPC]
enumFrom :: TagPC -> [TagPC]
$cenumFrom :: TagPC -> [TagPC]
fromEnum :: TagPC -> Int
$cfromEnum :: TagPC -> Int
toEnum :: Int -> TagPC
$ctoEnum :: Int -> TagPC
pred :: TagPC -> TagPC
$cpred :: TagPC -> TagPC
succ :: TagPC -> TagPC
$csucc :: TagPC -> TagPC
Enum,TagPC -> TagPC -> Bool
(TagPC -> TagPC -> Bool) -> (TagPC -> TagPC -> Bool) -> Eq TagPC
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TagPC -> TagPC -> Bool
$c/= :: TagPC -> TagPC -> Bool
== :: TagPC -> TagPC -> Bool
$c== :: TagPC -> TagPC -> Bool
Eq,Int -> TagPC -> ShowS
[TagPC] -> ShowS
TagPC -> String
(Int -> TagPC -> ShowS)
-> (TagPC -> String) -> ([TagPC] -> ShowS) -> Show TagPC
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TagPC] -> ShowS
$cshowList :: [TagPC] -> ShowS
show :: TagPC -> String
$cshow :: TagPC -> String
showsPrec :: Int -> TagPC -> ShowS
$cshowsPrec :: Int -> TagPC -> ShowS
Show)

data EncodingRule
  = BER
  | CER
  | DER
  deriving EncodingRule -> EncodingRule -> Bool
(EncodingRule -> EncodingRule -> Bool)
-> (EncodingRule -> EncodingRule -> Bool) -> Eq EncodingRule
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EncodingRule -> EncodingRule -> Bool
$c/= :: EncodingRule -> EncodingRule -> Bool
== :: EncodingRule -> EncodingRule -> Bool
$c== :: EncodingRule -> EncodingRule -> Bool
Eq

isolate64 :: Word64 -> Get a -> Get a
isolate64 :: Word64 -> Get a -> Get a
isolate64 sz64 :: Word64
sz64 act :: Get a
act
  | Just sz :: Int
sz <- Word64 -> Maybe Int
forall a b.
(Integral a, Integral b, Bits a, Bits b) =>
a -> Maybe b
intCastMaybe Word64
sz64 = Int -> Get a -> Get a
forall a. Int -> Get a -> Get a
Bin.isolate Int
sz Get a
act
  | Bool
otherwise = String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "isolate64: exceeding supported limits"

type TL = (Tag, TagPC, Maybe Word64)

getTagLength :: EncodingRule -> Get (Maybe TL)
getTagLength :: EncodingRule -> Get (Maybe TL)
getTagLength r :: EncodingRule
r = do
  Bool
eof <- Get Bool
isEmpty

  if Bool
eof
    then Maybe TL -> Get (Maybe TL)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe TL
forall a. Maybe a
Nothing
    else TL -> Maybe TL
forall a. a -> Maybe a
Just (TL -> Maybe TL) -> Get TL -> Get (Maybe TL)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      (t :: Tag
t,pc :: TagPC
pc) <- EncodingRule -> Get (Tag, TagPC)
getTag EncodingRule
r
      Maybe Word64
l <- Bool -> Get (Maybe Word64)
getLength (EncodingRule
r EncodingRule -> EncodingRule -> Bool
forall a. Eq a => a -> a -> Bool
/= EncodingRule
BER)

      case (EncodingRule
r,Maybe Word64
l,TagPC
pc) of
        (_,Nothing,Primitive)    -> String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "indefinite length not allowed for primitive encoding"
        (DER,Nothing,_)          -> String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "indefinite length encoding not allowed by DER"
        (CER,Just _,Constructed) -> String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "definite length not allowed for constructed encoding by CER"
        _                        -> () -> Get ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      TL -> Get TL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tag
t,TagPC
pc,Maybe Word64
l)

putTagLength :: TL -> PutM Word64
putTagLength :: TL -> PutM Word64
putTagLength (_,Primitive,Nothing) = String -> PutM Word64
forall a. HasCallStack => String -> a
error "indefinite length not allowed for primitive encoding"
putTagLength (t :: Tag
t,pc :: TagPC
pc,msz :: Maybe Word64
msz)            = Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
(+) (Word64 -> Word64 -> Word64)
-> PutM Word64 -> PutM (Word64 -> Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tag -> TagPC -> PutM Word64
putTag Tag
t TagPC
pc PutM (Word64 -> Word64) -> PutM Word64 -> PutM Word64
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Word64 -> PutM Word64
putLength Maybe Word64
msz

getTag :: EncodingRule -> Get (Tag, TagPC)
getTag :: EncodingRule -> Get (Tag, TagPC)
getTag _ = do
  Word8
b0 <- Get Word8
getWord8
  let !pc :: TagPC
pc = if Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word8
b0 5 then TagPC
Constructed else TagPC
Primitive
      n0 :: Word8
n0 = Word8
b0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x1f

  !Word64
tn <- case Word8
n0 of
          0x1f -> Get Word64
getXTagNum -- long-form tag-number
          _    -> Word64 -> Get Word64
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word8 -> Word64
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast Word8
n0)

  case Word8
b0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0xc0 of
    0x00 -> (Tag, TagPC) -> Get (Tag, TagPC)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> Tag
Universal   Word64
tn, TagPC
pc)
    0x40 -> (Tag, TagPC) -> Get (Tag, TagPC)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> Tag
Application Word64
tn, TagPC
pc)
    0x80 -> (Tag, TagPC) -> Get (Tag, TagPC)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> Tag
Contextual  Word64
tn, TagPC
pc)
    0xc0 -> (Tag, TagPC) -> Get (Tag, TagPC)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> Tag
Private     Word64
tn, TagPC
pc)
    _    -> String -> Get (Tag, TagPC)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "the impossible happened"

putTag :: Tag -> TagPC -> PutM Word64
putTag :: Tag -> TagPC -> PutM Word64
putTag t :: Tag
t pc :: TagPC
pc = do
  Bool -> PutM () -> PutM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Tag -> Word64
tagNum Tag
t Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= 31) (PutM () -> PutM ()) -> PutM () -> PutM ()
forall a b. (a -> b) -> a -> b
$ String -> PutM ()
forall a. HasCallStack => String -> a
error "putTag: FIXME"

  let w8_cls :: Word8
w8_cls = case Tag
t of
                 Universal   _ -> 0x00
                 Application _ -> 0x40
                 Contextual  _ -> 0x80
                 Private     _ -> 0xc0

      w8_pc :: Word8
w8_pc  = case TagPC
pc of
                 Constructed -> 0x20
                 Primitive   -> 0x00

      w8_tn :: Word8
w8_tn  = Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Tag -> Word64
tagNum Tag
t)

  Word8 -> PutM ()
putWord8 (Word8
w8_cls Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
w8_pc Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
w8_tn)
  Word64 -> PutM Word64
forall (f :: * -> *) a. Applicative f => a -> f a
pure 1

getXTagNum :: Get Word64
getXTagNum :: Get Word64
getXTagNum = do
    (more0 :: Bool
more0,n0 :: Word8
n0) <- Get (Bool, Word8)
getWord7
    let n0' :: Word64
n0' = Word8 -> Word64
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast Word8
n0

    Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
n0' Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== 0) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
      String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "lower 7 bits of the first subsequent tag-number octet shall not all be zero"

    if Bool
more0
      then Word64 -> Get Word64
go Word64
n0'
      else Word64 -> Get Word64
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
n0'

  where
    go :: Word64 -> Get Word64
    go :: Word64 -> Get Word64
go !Word64
acc = do
      (mo :: Bool
mo,o7 :: Word8
o7) <- Get (Bool, Word8)
getWord7
      let acc' :: Word64
acc' = (Word64
acc Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` 7) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word8 -> Word64
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast Word8
o7

      Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
acc Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= 0x0200000000000000) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
        String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "tag number exceeds 64bit range" -- TODO: investigate whether there's ASN.1 schemas requiring larger tag-numbers

      if Bool
mo
        then Word64 -> Get Word64
go Word64
acc'
        else Word64 -> Get Word64
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> Get Word64) -> Word64 -> Get Word64
forall a b. (a -> b) -> a -> b
$! Word64
acc'

getWord7 :: Get (Bool,Word8)
getWord7 :: Get (Bool, Word8)
getWord7 = do
  Word8
x <- Get Word8
getWord8
  let n :: Word8
n = Word8
x Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. 0x7f
      more :: Bool
more = Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
n
  (Bool, Word8) -> Get (Bool, Word8)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
more, Word8
n)

getLength :: Bool -> Get (Maybe Word64) -- 'Nothing' denotes indefinite
getLength :: Bool -> Get (Maybe Word64)
getLength minimal :: Bool
minimal = do
    (Bool, Word8)
xb7 <- Get (Bool, Word8)
getWord7
    case (Bool, Word8)
xb7 of
      -- definite short-form
      (False,n :: Word8
n)   -> Maybe Word64 -> Get (Maybe Word64)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Word64 -> Get (Maybe Word64))
-> Maybe Word64 -> Get (Maybe Word64)
forall a b. (a -> b) -> a -> b
$! Word64 -> Maybe Word64
forall a. a -> Maybe a
Just (Word64 -> Maybe Word64) -> Word64 -> Maybe Word64
forall a b. (a -> b) -> a -> b
$! Word8 -> Word64
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast Word8
n

      -- indefinite
      (True,0)    -> Maybe Word64 -> Get (Maybe Word64)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Word64
forall a. Maybe a
Nothing

      -- reserved
      (True,0x7f) -> String -> Get (Maybe Word64)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "length octet with reserved value 0xff encountered"

      -- definite long-form
      (True,sz :: Word8
sz)   -> Word64 -> Maybe Word64
forall a. a -> Maybe a
Just (Word64 -> Maybe Word64) -> Get Word64 -> Get (Maybe Word64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> Word64 -> Get Word64
go Word8
sz 0
  where
    go :: Word8 -> Word64 -> Get Word64
    go :: Word8 -> Word64 -> Get Word64
go 0 acc :: Word64
acc
      | Bool
minimal, Word64
acc Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< 0x1f  = String -> Get Word64
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "length not encoded minimally"
      | Bool
otherwise            = Word64 -> Get Word64
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
acc
    go sz :: Word8
sz acc :: Word64
acc = do
      Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
acc Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= 0x0100000000000000) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
        String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "length exceeds 64bit quantity"

      Word8
x <- Get Word8
getWord8

      let acc' :: Word64
acc' = (Word64
acc Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftL` 8) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word8 -> Word64
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast Word8
x
      Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
minimal Bool -> Bool -> Bool
&& Word64
acc Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&& Word8
x Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
        String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "length not encoded minimally"

      Word8 -> Word64 -> Get Word64
go (Word8
szWord8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
-1) Word64
acc'

putLength :: Maybe Word64 -> PutM Word64
putLength :: Maybe Word64 -> PutM Word64
putLength Nothing = Word8 -> PutM ()
putWord8 0x80 PutM () -> PutM Word64 -> PutM Word64
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Word64 -> PutM Word64
forall (f :: * -> *) a. Applicative f => a -> f a
pure 1
putLength (Just sz :: Word64
sz)
  | Word64
sz Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< 0x80 = Word8 -> PutM ()
putWord8 (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
sz) PutM () -> PutM Word64 -> PutM Word64
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Word64 -> PutM Word64
forall (f :: * -> *) a. Applicative f => a -> f a
pure 1
  | Bool
otherwise = do
      let w8s :: [Word8]
w8s = Word64 -> [Word8]
splitWord64 Word64
sz
          n :: Int
n   = [Word8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
w8s

      Word8 -> PutM ()
putWord8 (0x80 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
      (Word8 -> PutM ()) -> [Word8] -> PutM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Word8 -> PutM ()
putWord8 [Word8]
w8s
      Word64 -> PutM Word64
forall (f :: * -> *) a. Applicative f => a -> f a
pure (1 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)

asPrimitive :: (Word64 -> Get x) -> TL -> Get x
asPrimitive :: (Word64 -> Get x) -> TL -> Get x
asPrimitive _ (_,_,Nothing)         = String -> Get x
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "indefinite length not allowed"
asPrimitive _ (_,Constructed,_)     = String -> Get x
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "must be primitive"
asPrimitive f :: Word64 -> Get x
f (_,Primitive,Just sz :: Word64
sz) = Word64 -> Get x
f Word64
sz

----------------------------------------------------------------------------

getInt24be :: Get Int32
getInt24be :: Get Int32
getInt24be = do
  Int8
hi <- Get Int8
getInt8
  Word16
lo <- Get Word16
getWord16be
  Int32 -> Get Int32
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int32 -> Get Int32) -> Int32 -> Get Int32
forall a b. (a -> b) -> a -> b
$! (Int8 -> Int32
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast Int8
hi Int32 -> Int -> Int32
forall a. Bits a => a -> Int -> a
`shiftL` 16) Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
+ Word16 -> Int32
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast Word16
lo

getInt40be :: Get Int64
getInt40be :: Get Int64
getInt40be = do
  Int8
hi <- Get Int8
getInt8
  Word32
lo <- Get Word32
getWord32be
  Int64 -> Get Int64
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int64 -> Get Int64) -> Int64 -> Get Int64
forall a b. (a -> b) -> a -> b
$! (Int8 -> Int64
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast Int8
hi Int64 -> Int -> Int64
forall a. Bits a => a -> Int -> a
`shiftL` 32) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Word32 -> Int64
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast Word32
lo

getInt48be :: Get Int64
getInt48be :: Get Int64
getInt48be = do
  Int16
hi <- Get Int16
getInt16be
  Word32
lo <- Get Word32
getWord32be
  Int64 -> Get Int64
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int64 -> Get Int64) -> Int64 -> Get Int64
forall a b. (a -> b) -> a -> b
$! (Int16 -> Int64
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast Int16
hi Int64 -> Int -> Int64
forall a. Bits a => a -> Int -> a
`shiftL` 32) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Word32 -> Int64
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast Word32
lo

getInt56be :: Get Int64
getInt56be :: Get Int64
getInt56be = do
  Int32
hi <- Get Int32
getInt24be
  Word32
lo <- Get Word32
getWord32be
  Int64 -> Get Int64
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int64 -> Get Int64) -> Int64 -> Get Int64
forall a b. (a -> b) -> a -> b
$! (Int32 -> Int64
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast Int32
hi Int64 -> Int -> Int64
forall a. Bits a => a -> Int -> a
`shiftL` 32) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Word32 -> Int64
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast Word32
lo


getVarInt64 :: Word64 -> Get Int64
getVarInt64 :: Word64 -> Get Int64
getVarInt64 = \case
  0 -> String -> Get Int64
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "invalid zero-sized INTEGER"
  1 -> Int8 -> Int64
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast (Int8 -> Int64) -> Get Int8 -> Get Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int8
getInt8
  2 -> Int16 -> Int64
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast (Int16 -> Int64) -> Get Int16 -> Get Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int16
getInt16be
  3 -> Int32 -> Int64
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast (Int32 -> Int64) -> Get Int32 -> Get Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int32
getInt24be
  4 -> Int32 -> Int64
forall a b.
(Integral a, Integral b, IsIntSubType a b ~ 'True) =>
a -> b
intCast (Int32 -> Int64) -> Get Int32 -> Get Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int32
getInt32be
  5 ->             Get Int64
getInt40be
  6 ->             Get Int64
getInt48be
  7 ->             Get Int64
getInt56be
  8 ->             Get Int64
getInt64be
  _ -> String -> Get Int64
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "INTEGER too large for type"

getVarInteger :: Word64 -> Get Integer
getVarInteger :: Word64 -> Get Integer
getVarInteger sz :: Word64
sz
  | Word64
sz Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
<= 8 = Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64 -> Integer) -> Get Int64 -> Get Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word64 -> Get Int64
getVarInt64 Word64
sz
  | Bool
otherwise = String -> Get Integer
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "unsupported INTEGER size" -- FIXME/TODO

putVarInt64 :: Int64 -> PutM Word64
putVarInt64 :: Int64 -> PutM Word64
putVarInt64 i :: Int64
i = do
    (Word8 -> PutM ()) -> [Word8] -> PutM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Word8 -> PutM ()
Bin.putWord8 [Word8]
w8s
    Word64 -> PutM Word64
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word64) -> Int -> Word64
forall a b. (a -> b) -> a -> b
$ [Word8] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word8]
w8s)
  where
    w8s :: [Word8]
w8s = Int64 -> [Word8]
splitInt64 Int64
i


putVarInteger :: Integer -> PutM Word64
putVarInteger :: Integer -> PutM Word64
putVarInteger j :: Integer
j
  | Just i :: Int64
i <- Integer -> Maybe Int64
forall a b.
(Integral a, Integral b, Bits a, Bits b) =>
a -> Maybe b
intCastMaybe Integer
j = Int64 -> PutM Word64
putVarInt64 Int64
i
  | Bool
otherwise = String -> PutM Word64
forall a. HasCallStack => String -> a
error "putVarInteger: FIXME"

splitInt64 :: Int64 -> [Word8]
splitInt64 :: Int64 -> [Word8]
splitInt64 i :: Int64
i
  | Int64
i Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
>= 0x80 = Int64 -> Bool -> [Word8] -> [Word8]
forall t a.
(Num a, Integral t, Bits t, Ord a) =>
t -> Bool -> [a] -> [a]
goP Int64
i Bool
False []
  | Int64
i Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< -0x80 = Int64 -> Bool -> [Word8] -> [Word8]
forall t a.
(Num a, Integral t, Bits t, Ord a) =>
t -> Bool -> [a] -> [a]
goN Int64
i Bool
True  []
  | Bool
otherwise = [Int64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i]
  where
    goP :: t -> Bool -> [a] -> [a]
goP 0 False acc :: [a]
acc = [a]
acc
    goP 0 True  acc :: [a]
acc = 0x00 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc
    goP j :: t
j _  acc :: [a]
acc = t -> Bool -> [a] -> [a]
goP (t
j t -> Int -> t
forall a. Bits a => a -> Int -> a
`shiftR` 8) (a
w8 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= 0x80) (a
w8 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc)
      where w8 :: a
w8 = t -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (t
j t -> t -> t
forall a. Bits a => a -> a -> a
.&. 0xff)

    goN :: t -> Bool -> [a] -> [a]
goN (-1) True  acc :: [a]
acc = [a]
acc
    goN (-1) False acc :: [a]
acc = 0xff a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc
    goN j :: t
j _        acc :: [a]
acc = t -> Bool -> [a] -> [a]
goN (t
j t -> Int -> t
forall a. Bits a => a -> Int -> a
`shiftR` 8) (a
w8 a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= 0x80) (a
w8 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc)
      where w8 :: a
w8 = t -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (t
j t -> t -> t
forall a. Bits a => a -> a -> a
.&. 0xff)


splitWord64 :: Word64 -> [Word8]
splitWord64 :: Word64 -> [Word8]
splitWord64 i :: Word64
i
  | Word64
i Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> 0xff  = Word64 -> [Word8] -> [Word8]
forall t a. (Integral t, Num a, Bits t) => t -> [a] -> [a]
go Word64
i []
  | Bool
otherwise = [Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i]
  where
    go :: t -> [a] -> [a]
go 0 acc :: [a]
acc = [a]
acc
    go j :: t
j acc :: [a]
acc = t -> [a] -> [a]
go (t
j t -> Int -> t
forall a. Bits a => a -> Int -> a
`shiftR` 8) (a
w8 a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc)
      where w8 :: a
w8 = t -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (t
j t -> t -> t
forall a. Bits a => a -> a -> a
.&. 0xff)


----------------------------------------------------------------------------

-- | ASN.1 Tag
data Tag = Universal   { Tag -> Word64
tagNum :: !Word64 }
         | Application { tagNum :: !Word64 }
         | Contextual  { tagNum :: !Word64 }
         | Private     { tagNum :: !Word64 }
         deriving (Tag -> Tag -> Bool
(Tag -> Tag -> Bool) -> (Tag -> Tag -> Bool) -> Eq Tag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tag -> Tag -> Bool
$c/= :: Tag -> Tag -> Bool
== :: Tag -> Tag -> Bool
$c== :: Tag -> Tag -> Bool
Eq,Eq Tag
Eq Tag =>
(Tag -> Tag -> Ordering)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Bool)
-> (Tag -> Tag -> Tag)
-> (Tag -> Tag -> Tag)
-> Ord Tag
Tag -> Tag -> Bool
Tag -> Tag -> Ordering
Tag -> Tag -> Tag
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Tag -> Tag -> Tag
$cmin :: Tag -> Tag -> Tag
max :: Tag -> Tag -> Tag
$cmax :: Tag -> Tag -> Tag
>= :: Tag -> Tag -> Bool
$c>= :: Tag -> Tag -> Bool
> :: Tag -> Tag -> Bool
$c> :: Tag -> Tag -> Bool
<= :: Tag -> Tag -> Bool
$c<= :: Tag -> Tag -> Bool
< :: Tag -> Tag -> Bool
$c< :: Tag -> Tag -> Bool
compare :: Tag -> Tag -> Ordering
$ccompare :: Tag -> Tag -> Ordering
$cp1Ord :: Eq Tag
Ord)

instance Show Tag where
  show :: Tag -> String
show = \case
     Universal n :: Word64
n   -> "[UNIVERSAL "   String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ "]"
     Application n :: Word64
n -> "[APPLICATION " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ "]"
     Contextual n :: Word64
n  -> "["             String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ "]"
     Private n :: Word64
n     -> "[PRIVATE "     String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ "]"

----------------------------------------------------------------------------

-- | Type-level promoted 'Tag'
data TagK = UNIVERSAL   Nat
          | APPLICATION Nat
          | CONTEXTUAL  Nat
          | PRIVATE     Nat

class KnownTag (tag :: TagK) where
  tagVal :: Proxy tag -> Tag

instance forall n . (KnownNat n, IsBelowMaxBound n (IntBaseType Word64) ~ 'True) => KnownTag ('UNIVERSAL n) where
  tagVal :: Proxy ('UNIVERSAL n) -> Tag
tagVal _ = Word64 -> Tag
Universal (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word64) -> Integer -> Word64
forall a b. (a -> b) -> a -> b
$ Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n))

instance forall n . (KnownNat n, IsBelowMaxBound n (IntBaseType Word64) ~ 'True) => KnownTag ('APPLICATION n) where
  tagVal :: Proxy ('APPLICATION n) -> Tag
tagVal _ = Word64 -> Tag
Application (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word64) -> Integer -> Word64
forall a b. (a -> b) -> a -> b
$ Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n))

instance forall n . (KnownNat n, IsBelowMaxBound n (IntBaseType Word64) ~ 'True) => KnownTag ('CONTEXTUAL n) where
  tagVal :: Proxy ('CONTEXTUAL n) -> Tag
tagVal _ = Word64 -> Tag
Contextual (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word64) -> Integer -> Word64
forall a b. (a -> b) -> a -> b
$ Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n))

instance forall n . (KnownNat n, IsBelowMaxBound n (IntBaseType Word64) ~ 'True) => KnownTag ('PRIVATE n) where
  tagVal :: Proxy ('PRIVATE n) -> Tag
tagVal _ = Word64 -> Tag
Private (Integer -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Word64) -> Integer -> Word64
forall a b. (a -> b) -> a -> b
$ Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy :: Proxy n))

----------------------------------------------------------------------------