{-# language BangPatterns #-}
{-# language BinaryLiterals #-}
{-# language DerivingStrategies #-}
{-# language LambdaCase #-}
{-# language MagicHash #-}
{-# language MultiWayIf #-}
{-# language NamedFieldPuns #-}
{-# language NumericUnderscores #-}
{-# language PatternSynonyms #-}
{-# language RankNTypes #-}
{-# language TypeApplications #-}
{-# language UnboxedTuples #-}

module Asn.Ber
  ( Value(..)
  , Contents(..)
  , Class(..)
  , decode
  , decodeInteger
  , decodeOctetString
  , decodeNull
  , decodeObjectId
  , decodeUtf8String
  , decodePrintableString
    -- * Constructed Patterns
  , pattern Set
  , pattern Sequence
  ) where

import Asn.Oid (Oid(..))
import Control.Monad (when)
import Data.Bits ((.&.),(.|.),testBit,unsafeShiftR,unsafeShiftL,complement)
import Data.Bytes (Bytes)
import Data.Bytes.Parser (Parser)
import Data.ByteString.Short.Internal (ShortByteString(SBS))
import Data.Int (Int64)
import Data.Primitive (SmallArray)
import Data.Word (Word8,Word32)
import GHC.Exts (Int(I#))
import GHC.ST (ST(ST))

import qualified Data.Bytes as Bytes
import qualified Data.Bytes.Parser as P
import qualified Data.Bytes.Parser.Base128 as Base128
import qualified Data.Primitive as PM
import qualified Data.Text.Short as TS
import qualified Data.Text.Short.Unsafe as TS
import qualified GHC.Exts as Exts

data Value = Value
  { Value -> Class
tagClass :: !Class
  , Value -> Word32
tagNumber :: !Word32
  , Value -> Contents
contents :: !Contents
  }
  deriving stock (Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
Show)
  deriving stock (Value -> Value -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c== :: Value -> Value -> Bool
Eq)

data Contents
  = Integer !Int64
    -- ^ Tag number: @0x02@
  | OctetString {-# UNPACK #-} !Bytes
    -- ^ Tag number: @0x04@
  | BitString !Word8 {-# UNPACK #-} !Bytes
    -- ^ Tag number: @0x03@. Has padding bit count and raw bytes.
  | Null
    -- ^ Tag number: @0x05@
  | ObjectIdentifier !Oid
    -- ^ Tag number: @0x06@
  | Utf8String {-# UNPACK #-} !TS.ShortText
    -- ^ Tag number: @0x0C@
  | PrintableString {-# UNPACK #-} !TS.ShortText
    -- ^ Tag number: @0x13@
  | UtcTime
    -- ^ Tag number: @0x17@
  | Constructed !(SmallArray Value)
    -- ^ Constructed value contents in concatenation order.
    -- The class and tag are held in `Value`.
  | Unresolved {-# UNPACK #-} !Bytes
    -- ^ Values that require information about interpreting application,
    -- context-specific, or private tag.
  deriving stock (Int -> Contents -> ShowS
[Contents] -> ShowS
Contents -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Contents] -> ShowS
$cshowList :: [Contents] -> ShowS
show :: Contents -> String
$cshow :: Contents -> String
showsPrec :: Int -> Contents -> ShowS
$cshowsPrec :: Int -> Contents -> ShowS
Show)
  deriving stock (Contents -> Contents -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Contents -> Contents -> Bool
$c/= :: Contents -> Contents -> Bool
== :: Contents -> Contents -> Bool
$c== :: Contents -> Contents -> Bool
Eq)

pattern Sequence :: Word32
pattern $bSequence :: Word32
$mSequence :: forall {r}. Word32 -> ((# #) -> r) -> ((# #) -> r) -> r
Sequence = 0x10

pattern Set :: Word32
pattern $bSet :: Word32
$mSet :: forall {r}. Word32 -> ((# #) -> r) -> ((# #) -> r) -> r
Set = 0x11

data Class
  = Universal
  | Application
  | ContextSpecific
  | Private
  deriving stock (Class -> Class -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Class -> Class -> Bool
$c/= :: Class -> Class -> Bool
== :: Class -> Class -> Bool
$c== :: Class -> Class -> Bool
Eq,Int -> Class -> ShowS
[Class] -> ShowS
Class -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Class] -> ShowS
$cshowList :: [Class] -> ShowS
show :: Class -> String
$cshow :: Class -> String
showsPrec :: Int -> Class -> ShowS
$cshowsPrec :: Int -> Class -> ShowS
Show)

decode :: Bytes -> Either String Value
decode :: Bytes -> Either String Value
decode = forall e a. (forall s. Parser e s a) -> Bytes -> Either e a
P.parseBytesEither forall s. Parser String s Value
parser

decodePayload :: (forall s. Word -> Parser String s a) -> Bytes -> Either String a
decodePayload :: forall a.
(forall s. Word -> Parser String s a) -> Bytes -> Either String a
decodePayload forall s. Word -> Parser String s a
k Bytes
bs =
  let len :: Word
len = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Word (Bytes -> Int
Bytes.length Bytes
bs)
   in forall e a. (forall s. Parser e s a) -> Bytes -> Either e a
P.parseBytesEither (forall s. Word -> Parser String s a
k Word
len) Bytes
bs

decodeInteger :: Bytes -> Either String Int64
decodeInteger :: Bytes -> Either String Int64
decodeInteger = forall a.
(forall s. Word -> Parser String s a) -> Bytes -> Either String a
decodePayload forall s. Word -> Parser String s Int64
integerPayload

decodeOctetString :: Bytes -> Either String Bytes
decodeOctetString :: Bytes -> Either String Bytes
decodeOctetString = forall a.
(forall s. Word -> Parser String s a) -> Bytes -> Either String a
decodePayload forall s. Word -> Parser String s Bytes
octetStringPayload

decodeNull :: Bytes -> Either String ()
decodeNull :: Bytes -> Either String ()
decodeNull = forall a.
(forall s. Word -> Parser String s a) -> Bytes -> Either String a
decodePayload forall s. Word -> Parser String s ()
nullPayload

decodeObjectId :: Bytes -> Either String Oid
decodeObjectId :: Bytes -> Either String Oid
decodeObjectId = forall a.
(forall s. Word -> Parser String s a) -> Bytes -> Either String a
decodePayload forall s. Word -> Parser String s Oid
objectIdentifierPayload

decodeUtf8String :: Bytes -> Either String TS.ShortText
decodeUtf8String :: Bytes -> Either String ShortText
decodeUtf8String = forall a.
(forall s. Word -> Parser String s a) -> Bytes -> Either String a
decodePayload forall s. Word -> Parser String s ShortText
utf8StringPayload

decodePrintableString :: Bytes -> Either String TS.ShortText
decodePrintableString :: Bytes -> Either String ShortText
decodePrintableString = forall a.
(forall s. Word -> Parser String s a) -> Bytes -> Either String a
decodePayload forall s. Word -> Parser String s ShortText
printableStringPayload

takeLength :: Parser String s Word
takeLength :: forall s. Parser String s Word
takeLength = do
  Word8
w <- forall e s. e -> Parser e s Word8
P.any String
"tried to take the length"
  case forall a. Bits a => a -> Int -> Bool
testBit Word8
w Int
7 of
    Bool
False -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w)
    Bool
True -> do
      let go :: t -> Word -> Parser String s Word
go !t
n !Word
acc = case t
n of
            t
0 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Word
acc
            t
_ -> if Word
acc forall a. Ord a => a -> a -> Bool
< Word
16_000_000
              then do
                Word8
x <- forall e s. e -> Parser e s Word8
P.any String
"while taking length, ran out of bytes"
                let acc' :: Word
acc' = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Word Word8
x forall a. Num a => a -> a -> a
+ (Word
acc forall a. Num a => a -> a -> a
* Word
256)
                t -> Word -> Parser String s Word
go (t
n forall a. Num a => a -> a -> a
- t
1) Word
acc'
              else forall e s a. e -> Parser e s a
P.fail String
"that is a giant length, bailing out"
      forall {t} {s}. (Eq t, Num t) => t -> Word -> Parser String s Word
go (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Word Word8
w forall a. Bits a => a -> a -> a
.&. Word
0b01111111) Word
0

objectIdentifier :: Parser String s Contents
objectIdentifier :: forall s. Parser String s Contents
objectIdentifier = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Oid -> Contents
ObjectIdentifier forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Word -> Parser String s Oid
objectIdentifierPayload forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s. Parser String s Word
takeLength

objectIdentifierPayload :: Word -> Parser String s Oid
objectIdentifierPayload :: forall s. Word -> Parser String s Oid
objectIdentifierPayload Word
len = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word
len forall a. Ord a => a -> a -> Bool
< Word
1) (forall e s a. e -> Parser e s a
P.fail String
"oid must have length of at least 1")
  forall e s a. e -> e -> Int -> Parser e s a -> Parser e s a
P.delimit String
"oid not enough bytes" String
"oid leftovers" (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
len) forall a b. (a -> b) -> a -> b
$ do
    Word8
w0 <- forall e s. e -> Parser e s Word8
P.any String
"oid expecting first byte"
    let (Word8
v1, Word8
v2) = forall a. Integral a => a -> a -> (a, a)
quotRem Word8
w0 Word8
40
        initialSize :: Int
initialSize = Int
12
    MutablePrimArray s Word32
buf0 <- forall s a e. ST s a -> Parser e s a
P.effect (forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
PM.newPrimArray Int
initialSize)
    forall s a e. ST s a -> Parser e s a
P.effect forall a b. (a -> b) -> a -> b
$ do
      forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
PM.writePrimArray MutablePrimArray s Word32
buf0 Int
0 (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Word32 Word8
v1)
      forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
PM.writePrimArray MutablePrimArray s Word32
buf0 Int
1 (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Word32 Word8
v2)
    let go :: Int -> Int -> MutablePrimArray s Word32 -> Parser String s Oid
go !Int
ix !Int
sz !MutablePrimArray s Word32
buf = forall e s. Parser e s Bool
P.isEndOfInput forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Bool
True -> do
            PrimArray Word32
res <- forall s a e. ST s a -> Parser e s a
P.effect forall a b. (a -> b) -> a -> b
$ do
              forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a -> Int -> m ()
PM.shrinkMutablePrimArray MutablePrimArray s Word32
buf Int
ix
              forall (m :: * -> *) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
PM.unsafeFreezePrimArray MutablePrimArray s Word32
buf
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrimArray Word32 -> Oid
Oid PrimArray Word32
res)
          Bool
False -> if Int
ix forall a. Ord a => a -> a -> Bool
< Int
sz
            then do
              Word32
w <- forall e s. e -> Parser e s Word32
Base128.word32 String
"bad oid fragment"
              forall s a e. ST s a -> Parser e s a
P.effect (forall a (m :: * -> *).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
PM.writePrimArray MutablePrimArray s Word32
buf Int
ix Word32
w)
              Int -> Int -> MutablePrimArray s Word32 -> Parser String s Oid
go (Int
ix forall a. Num a => a -> a -> a
+ Int
1) Int
sz MutablePrimArray s Word32
buf
            else do
              let newSz :: Int
newSz = Int
sz forall a. Num a => a -> a -> a
* Int
2
              MutablePrimArray s Word32
newBuf <- forall s a e. ST s a -> Parser e s a
P.effect forall a b. (a -> b) -> a -> b
$ do
                MutablePrimArray s Word32
newBuf <- forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
PM.newPrimArray Int
newSz
                forall (m :: * -> *) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> MutablePrimArray (PrimState m) a -> Int -> Int -> m ()
PM.copyMutablePrimArray MutablePrimArray s Word32
newBuf Int
0 MutablePrimArray s Word32
buf Int
0 Int
sz
                forall (f :: * -> *) a. Applicative f => a -> f a
pure MutablePrimArray s Word32
newBuf
              Int -> Int -> MutablePrimArray s Word32 -> Parser String s Oid
go Int
ix Int
newSz MutablePrimArray s Word32
newBuf
    forall {s}.
Int -> Int -> MutablePrimArray s Word32 -> Parser String s Oid
go Int
2 Int
initialSize MutablePrimArray s Word32
buf0


unresolved :: Parser String s Contents
unresolved :: forall s. Parser String s Contents
unresolved = do
  Word
n <- forall s. Parser String s Word
takeLength
  Bytes
bs <- forall e s. e -> Int -> Parser e s Bytes
P.take String
"while decoding unresolved contents, not enough bytes" (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bytes -> Contents
Unresolved Bytes
bs)

constructed :: Parser String s Contents
constructed :: forall s. Parser String s Contents
constructed = do
  Word
n <- forall s. Parser String s Word
takeLength
  forall e s a. e -> e -> Int -> Parser e s a -> Parser e s a
P.delimit String
"constructed not enough bytes" String
"constructed leftovers" (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n) forall a b. (a -> b) -> a -> b
$ do
    let initialSize :: Int
initialSize = Int
8
    SmallMutableArray s Value
buf0 <- forall s a e. ST s a -> Parser e s a
P.effect (forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
PM.newSmallArray Int
initialSize forall a. a
errorThunk)
    let go :: Int -> Int -> SmallMutableArray s Value -> Parser String s Contents
go !Int
ix !Int
sz !SmallMutableArray s Value
buf = forall e s. Parser e s Bool
P.isEndOfInput forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Bool
True -> do
            SmallArray Value
res <- forall s a e. ST s a -> Parser e s a
P.effect forall a b. (a -> b) -> a -> b
$ do
              SmallMutableArray s Value
buf' <- forall s a.
SmallMutableArray s a -> Int -> ST s (SmallMutableArray s a)
resizeSmallMutableArray SmallMutableArray s Value
buf Int
ix
              forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> m (SmallArray a)
PM.unsafeFreezeSmallArray SmallMutableArray s Value
buf'
            forall (f :: * -> *) a. Applicative f => a -> f a
pure (SmallArray Value -> Contents
Constructed SmallArray Value
res)
          Bool
False -> if Int
ix forall a. Ord a => a -> a -> Bool
< Int
sz
            then do
              Value
v <- forall s. Parser String s Value
parser
              forall s a e. ST s a -> Parser e s a
P.effect (forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a -> Int -> a -> m ()
PM.writeSmallArray SmallMutableArray s Value
buf Int
ix Value
v)
              Int -> Int -> SmallMutableArray s Value -> Parser String s Contents
go (Int
ix forall a. Num a => a -> a -> a
+ Int
1) Int
sz SmallMutableArray s Value
buf
            else do
              let newSz :: Int
newSz = Int
sz forall a. Num a => a -> a -> a
* Int
2
              SmallMutableArray s Value
newBuf <- forall s a e. ST s a -> Parser e s a
P.effect forall a b. (a -> b) -> a -> b
$ do
                SmallMutableArray s Value
newBuf <- forall (m :: * -> *) a.
PrimMonad m =>
Int -> a -> m (SmallMutableArray (PrimState m) a)
PM.newSmallArray Int
newSz forall a. a
errorThunk
                forall (m :: * -> *) a.
PrimMonad m =>
SmallMutableArray (PrimState m) a
-> Int -> SmallMutableArray (PrimState m) a -> Int -> Int -> m ()
PM.copySmallMutableArray SmallMutableArray s Value
newBuf Int
0 SmallMutableArray s Value
buf Int
0 Int
sz
                forall (f :: * -> *) a. Applicative f => a -> f a
pure SmallMutableArray s Value
newBuf
              Int -> Int -> SmallMutableArray s Value -> Parser String s Contents
go Int
ix Int
newSz SmallMutableArray s Value
newBuf
    forall {s}.
Int -> Int -> SmallMutableArray s Value -> Parser String s Contents
go Int
0 Int
initialSize SmallMutableArray s Value
buf0

resizeSmallMutableArray :: PM.SmallMutableArray s a -> Int -> ST s (PM.SmallMutableArray s a)
resizeSmallMutableArray :: forall s a.
SmallMutableArray s a -> Int -> ST s (SmallMutableArray s a)
resizeSmallMutableArray (PM.SmallMutableArray SmallMutableArray# s a
x) (I# Int#
i) =
  forall s a. STRep s a -> ST s a
ST (\State# s
s -> (# forall d a. SmallMutableArray# d a -> Int# -> State# d -> State# d
Exts.shrinkSmallMutableArray# SmallMutableArray# s a
x Int#
i State# s
s, forall s a. SmallMutableArray# s a -> SmallMutableArray s a
PM.SmallMutableArray SmallMutableArray# s a
x #))

errorThunk :: a
{-# noinline errorThunk #-}
errorThunk :: forall a. a
errorThunk = forall a. String -> a
errorWithoutStackTrace String
"Asn.Ber: implementation mistake"

utf8String :: Parser String s Contents
utf8String :: forall s. Parser String s Contents
utf8String = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShortText -> Contents
Utf8String forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Word -> Parser String s ShortText
utf8StringPayload forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s. Parser String s Word
takeLength

utf8StringPayload :: Word -> Parser String s TS.ShortText
utf8StringPayload :: forall s. Word -> Parser String s ShortText
utf8StringPayload Word
len = do
  Bytes
bs <- forall e s. e -> Int -> Parser e s Bytes
P.take String
"while decoding UTF-8 string, not enough bytes" (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
len)
  case ShortByteString -> Maybe ShortText
TS.fromShortByteString (ByteArray -> ShortByteString
ba2sbs (Bytes -> ByteArray
Bytes.toByteArrayClone Bytes
bs)) of
    Maybe ShortText
Nothing -> forall e s a. e -> Parser e s a
P.fail String
"found non-UTF-8 byte sequences in printable string"
    Just ShortText
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ShortText
r


printableString :: Parser String s Contents
printableString :: forall s. Parser String s Contents
printableString = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShortText -> Contents
PrintableString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Word -> Parser String s ShortText
printableStringPayload forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s. Parser String s Word
takeLength

printableStringPayload :: Word -> Parser String s TS.ShortText
printableStringPayload :: forall s. Word -> Parser String s ShortText
printableStringPayload Word
len = do
  Bytes
bs <- forall e s. e -> Int -> Parser e s Bytes
P.take String
"while decoding printable string, not enough bytes" (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
len)
  if (Word8 -> Bool) -> Bytes -> Bool
Bytes.all Word8 -> Bool
isPrintable Bytes
bs
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! ByteArray -> ShortText
ba2stUnsafe forall a b. (a -> b) -> a -> b
$! Bytes -> ByteArray
Bytes.toByteArrayClone Bytes
bs
    else forall e s a. e -> Parser e s a
P.fail String
"found non-printable characters in printable string"

isPrintable :: Word8 -> Bool
isPrintable :: Word8 -> Bool
isPrintable = \case
  Word8
0x20 -> Bool
True
  Word8
0x27 -> Bool
True
  Word8
0x28 -> Bool
True
  Word8
0x29 -> Bool
True
  Word8
0x2B -> Bool
True
  Word8
0x2C -> Bool
True
  Word8
0x2D -> Bool
True
  Word8
0x2E -> Bool
True
  Word8
0x2F -> Bool
True
  Word8
0x3A -> Bool
True
  Word8
0x3D -> Bool
True
  Word8
0x3F -> Bool
True
  Word8
w | Word8
w forall a. Ord a => a -> a -> Bool
>= Word8
0x41 Bool -> Bool -> Bool
&& Word8
w forall a. Ord a => a -> a -> Bool
<= Word8
0x5A -> Bool
True
  Word8
w | Word8
w forall a. Ord a => a -> a -> Bool
>= Word8
0x61 Bool -> Bool -> Bool
&& Word8
w forall a. Ord a => a -> a -> Bool
<= Word8
0x7A -> Bool
True
  Word8
w | Word8
w forall a. Ord a => a -> a -> Bool
>= Word8
0x30 Bool -> Bool -> Bool
&& Word8
w forall a. Ord a => a -> a -> Bool
<= Word8
0x39 -> Bool
True
  Word8
_ -> Bool
False

octetString :: Parser String s Contents
octetString :: forall s. Parser String s Contents
octetString = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bytes -> Contents
OctetString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Word -> Parser String s Bytes
octetStringPayload forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s. Parser String s Word
takeLength

octetStringPayload :: Word -> Parser String s Bytes
octetStringPayload :: forall s. Word -> Parser String s Bytes
octetStringPayload Word
len = do
  forall e s. e -> Int -> Parser e s Bytes
P.take String
"while decoding octet string, not enough bytes" (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
len)

-- The whole bit string thing is kind of janky, but SNMP does not use
-- it, so it is not terribly important.
bitString :: Parser String s Contents
bitString :: forall s. Parser String s Contents
bitString = do
  Word
n <- forall s. Parser String s Word
takeLength
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word
n forall a. Ord a => a -> a -> Bool
< Word
1) (forall e s a. e -> Parser e s a
P.fail String
"bitstring must have length of at least 1")
  Word8
padding <- forall e s. e -> Parser e s Word8
P.any String
"expected a padding bit count"
  Bytes
bs <- forall e s. e -> Int -> Parser e s Bytes
P.take String
"while decoding octet string, not enough bytes" (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
n forall a. Num a => a -> a -> a
- Word
1))
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word8 -> Bytes -> Contents
BitString Word8
padding Bytes
bs)

integer :: Parser String s Contents
integer :: forall s. Parser String s Contents
integer = forall s. Parser String s Word
takeLength forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Word
0 -> forall e s a. e -> Parser e s a
P.fail String
"integers must have non-zero length"
  Word
n | Word
n forall a. Ord a => a -> a -> Bool
<= Word
8 -> Int64 -> Contents
Integer forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. Word -> Parser String s Int64
integerPayload Word
n
    | Bool
otherwise -> do
      -- TODO parse bignums
      forall e s a. e -> Parser e s a
P.fail (forall a. Show a => a -> String
show Word
n forall a. [a] -> [a] -> [a]
++ String
"-octet integer is too large to store in an Int64")

integerPayload :: Word -> Parser String s Int64
integerPayload :: forall s. Word -> Parser String s Int64
integerPayload Word
len = do
  Bytes
content <- forall e s. e -> Int -> Parser e s Bytes
P.take String
"while decoding integer, not enough bytes" (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
len)
  -- There are not zero-length integer encodings in BER, and we guared
  -- against this above, so taking the head with unsafeIndex is safe.
  let isNegative :: Bool
isNegative = forall a. Bits a => a -> Int -> Bool
testBit (Bytes -> Int -> Word8
Bytes.unsafeIndex Bytes
content Int
0) Int
7
      loopBody :: Int64 -> Word8 -> Int64
loopBody Int64
acc Word8
b = (Int64
acc forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
8) forall a. Bits a => a -> a -> a
.|. forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Int64 Word8
b
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Bool
isNegative
    then forall a. (a -> Word8 -> a) -> a -> Bytes -> a
Bytes.foldl' Int64 -> Word8 -> Int64
loopBody (forall a. Bits a => a -> a
complement Int64
0) Bytes
content
    else forall a. (a -> Word8 -> a) -> a -> Bytes -> a
Bytes.foldl' Int64 -> Word8 -> Int64
loopBody Int64
0 Bytes
content

-- TODO: write this
utcTime :: Parser String s Contents
utcTime :: forall s. Parser String s Contents
utcTime = do
  Word
n <- forall s. Parser String s Word
takeLength
  Bytes
_ <- forall e s. e -> Int -> Parser e s Bytes
P.take String
"while decoding utctime, not enough bytes" (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Contents
UtcTime

nullParser :: Parser String s Contents
nullParser :: forall s. Parser String s Contents
nullParser = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. a -> b -> a
const Contents
Null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Word -> Parser String s ()
nullPayload forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s. Parser String s Word
takeLength

nullPayload :: Word -> Parser String s ()
nullPayload :: forall s. Word -> Parser String s ()
nullPayload Word
0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
nullPayload Word
len = forall e s a. e -> Parser e s a
P.fail (String
"expecting null contents to have length zero, got " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word
len)


classFromUpperBits :: Word8 -> Class
classFromUpperBits :: Word8 -> Class
classFromUpperBits Word8
w = case forall a. Bits a => a -> Int -> a
unsafeShiftR Word8
w Int
6 of
  Word8
0 -> Class
Universal
  Word8
1 -> Class
Application
  Word8
2 -> Class
ContextSpecific
  Word8
_ -> Class
Private

parser :: Parser String s Value
parser :: forall s. Parser String s Value
parser = do
  Word8
b <- forall e s. e -> Parser e s Word8
P.any String
"expected tag byte"
  let tagClass :: Class
tagClass = Word8 -> Class
classFromUpperBits Word8
b
      isConstructed :: Bool
isConstructed = forall a. Bits a => a -> Int -> Bool
testBit Word8
b Int
5
  Word32
tagNumber <- case Word8
b forall a. Bits a => a -> a -> a
.&. Word8
0b00011111 of
        Word8
31 -> forall e s. e -> Parser e s Word32
Base128.word32 String
"bad big tag"
        Word8
num -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Word32 Word8
num
  Contents
contents <- if
    | Class
Universal <- Class
tagClass
    , Bool -> Bool
not Bool
isConstructed
    -> case Word32
tagNumber of
      Word32
0x13 -> forall s. Parser String s Contents
printableString
      Word32
0x02 -> forall s. Parser String s Contents
integer
      Word32
0x03 -> forall s. Parser String s Contents
bitString
      Word32
0x04 -> forall s. Parser String s Contents
octetString
      Word32
0x05 -> forall s. Parser String s Contents
nullParser
      Word32
0x06 -> forall s. Parser String s Contents
objectIdentifier
      Word32
0x0C -> forall s. Parser String s Contents
utf8String
      Word32
0x17 -> forall s. Parser String s Contents
utcTime
      Word32
_ -> forall e s a. e -> Parser e s a
P.fail (String
"unrecognized universal primitive tag number " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word32
tagNumber)
    | Bool
isConstructed -> forall s. Parser String s Contents
constructed
    | Bool
otherwise -> forall s. Parser String s Contents
unresolved
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Value{Class
tagClass :: Class
tagClass :: Class
tagClass, Word32
tagNumber :: Word32
tagNumber :: Word32
tagNumber, Contents
contents :: Contents
contents :: Contents
contents}

ba2stUnsafe :: PM.ByteArray -> TS.ShortText
ba2stUnsafe :: ByteArray -> ShortText
ba2stUnsafe (PM.ByteArray ByteArray#
x) = ShortByteString -> ShortText
TS.fromShortByteStringUnsafe (ByteArray# -> ShortByteString
SBS ByteArray#
x)

ba2sbs :: PM.ByteArray -> ShortByteString
ba2sbs :: ByteArray -> ShortByteString
ba2sbs (PM.ByteArray ByteArray#
x) = ByteArray# -> ShortByteString
SBS ByteArray#
x