{-# 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 Chronos
import qualified Data.Bytes as Bytes
import qualified Data.Bytes.Parser as P
import qualified Data.Bytes.Parser.Latin as Latin
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
  = Boolean !Bool
    -- ^ Tag number: @0x01@
  | 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 !Int64
    -- ^ Tag number: @0x17@. Number of seconds since the epoch.
    -- The following guidance is inspired by RFC 5280:
    --
    -- * A two-digit year greater than or equal to 50 is interpreted
    --   as 19XX, and a two-digit year less than 50 is intepreted
    --   as 20XX.
    -- * Everything is converted to Zulu time zone. Unlike RFC 5280,
    --   we do not require Zulu, but we convert everything to it.
    -- * When seconds are absent, we treat the timestamp as one where
    --   the seconds are zero. That is, we understand 2303252359Z as
    --   2023-03-25T23:59:00Z.
  | 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"
  if Word8
padding forall a. Ord a => a -> a -> Bool
>= Word8
8
    then forall e s a. e -> Parser e s a
P.fail String
"bitstring has more than 7 padding bits"
    else do
      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)

boolean :: Parser String s Contents
boolean :: forall s. Parser String s Contents
boolean = forall s. Parser String s Word
takeLength forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Word
1 -> do
    Word8
w <- forall e s. e -> Parser e s Word8
P.any String
"expected boolean payload"
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Bool -> Contents
Boolean forall a b. (a -> b) -> a -> b
$ case Word8
w of
      Word8
0 -> Bool
False
      Word8
_ -> Bool
True
  Word
_ -> forall e s a. e -> Parser e s a
P.fail String
"boolean length must be 1 byte"

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
len <- 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
"utctime not enough bytes" String
"utctime leftovers" (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
len) forall a b. (a -> b) -> a -> b
$ do
    !Int
year0 <- forall e s. e -> Parser e s Int
twoDigits String
"utctime year digit problem"
    let !year :: Int
year = if Int
year0 forall a. Ord a => a -> a -> Bool
>= Int
50 then Int
1900 forall a. Num a => a -> a -> a
+ Int
year0 else Int
2000 forall a. Num a => a -> a -> a
+ Int
year0
    !Int
month <- forall e s. e -> Parser e s Int
twoDigits String
"utctime month digit problem"
    !Int
day <- forall e s. e -> Parser e s Int
twoDigits String
"utctime day digit problem"
    !Int
hour <- forall e s. e -> Parser e s Int
twoDigits String
"utctime hour digit problem"
    !Int
minute <- forall e s. e -> Parser e s Int
twoDigits String
"utctime minute digit problem"
    -- Offset must be provided in seconds.
    let finishWithoutSeconds :: Int64 -> f Contents
finishWithoutSeconds !Int64
offset = case Int -> Int -> Int -> Int -> Int -> Int -> Time
Chronos.timeFromYmdhms Int
year Int
month Int
day Int
hour Int
minute Int
0 of
          Chronos.Time Int64
ns -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! Int64 -> Contents
UtcTime (Int64
offset forall a. Num a => a -> a -> a
+ forall a. Integral a => a -> a -> a
div Int64
ns Int64
1_000_000_000)
    let finishWithSeconds :: Int64 -> Int -> f Contents
finishWithSeconds !Int64
offset !Int
seconds = case Int -> Int -> Int -> Int -> Int -> Int -> Time
Chronos.timeFromYmdhms Int
year Int
month Int
day Int
hour Int
minute Int
seconds of
          Chronos.Time Int64
ns -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! Int64 -> Contents
UtcTime (Int64
offset forall a. Num a => a -> a -> a
+ forall a. Integral a => a -> a -> a
div Int64
ns Int64
1_000_000_000)
    forall e s. Parser e s (Maybe Char)
Latin.peek forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe Char
Nothing -> forall {f :: * -> *}. Applicative f => Int64 -> f Contents
finishWithoutSeconds Int64
0
      Just Char
c -> case Char
c of
        Char
'Z' -> do
          Word8
_ <- forall e s. e -> Parser e s Word8
P.any String
"utctime impossible"
          forall {f :: * -> *}. Applicative f => Int64 -> f Contents
finishWithoutSeconds Int64
0
        Char
'+' -> do
          Word8
_ <- forall e s. e -> Parser e s Word8
P.any String
"utctime impossible"
          !Int
offsetHour <- forall e s. e -> Parser e s Int
twoDigits String
"utctime offset hour digit problem"
          !Int
offsetMinute <- forall e s. e -> Parser e s Int
twoDigits String
"utctime offset minute digit problem"
          let !offset :: Int64
offset = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Int64 (forall a. Num a => a -> a
negate (Int
60 forall a. Num a => a -> a -> a
* (Int
60 forall a. Num a => a -> a -> a
* Int
offsetHour forall a. Num a => a -> a -> a
+ Int
offsetMinute)))
          forall {f :: * -> *}. Applicative f => Int64 -> f Contents
finishWithoutSeconds Int64
offset
        Char
'-' -> do
          Word8
_ <- forall e s. e -> Parser e s Word8
P.any String
"utctime impossible"
          !Int
offsetHour <- forall e s. e -> Parser e s Int
twoDigits String
"utctime offset hour digit problem"
          !Int
offsetMinute <- forall e s. e -> Parser e s Int
twoDigits String
"utctime offset minute digit problem"
          let !offset :: Int64
offset = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Int64 (Int
60 forall a. Num a => a -> a -> a
* (Int
60 forall a. Num a => a -> a -> a
* Int
offsetHour forall a. Num a => a -> a -> a
+ Int
offsetMinute))
          forall {f :: * -> *}. Applicative f => Int64 -> f Contents
finishWithoutSeconds Int64
offset
        Char
_ | Char
c forall a. Ord a => a -> a -> Bool
>= Char
'0', Char
c forall a. Ord a => a -> a -> Bool
<= Char
'9' -> do
              Int
seconds <- forall e s. e -> Parser e s Int
twoDigits String
"utctime seconds digit problem"
              forall e s. Parser e s (Maybe Char)
Latin.peek forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe Char
Nothing -> forall {f :: * -> *}. Applicative f => Int64 -> Int -> f Contents
finishWithSeconds Int64
0 Int
seconds
                Just Char
d -> case Char
d of
                  Char
'Z' -> do
                    Word8
_ <- forall e s. e -> Parser e s Word8
P.any String
"utctime impossible"
                    forall {f :: * -> *}. Applicative f => Int64 -> Int -> f Contents
finishWithSeconds Int64
0 Int
seconds
                  Char
'+' -> do
                    Word8
_ <- forall e s. e -> Parser e s Word8
P.any String
"utctime impossible"
                    !Int
offsetHour <- forall e s. e -> Parser e s Int
twoDigits String
"utctime offset hour digit problem"
                    !Int
offsetMinute <- forall e s. e -> Parser e s Int
twoDigits String
"utctime offset minute digit problem"
                    let !offset :: Int64
offset = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Int64 (forall a. Num a => a -> a
negate (Int
60 forall a. Num a => a -> a -> a
* (Int
60 forall a. Num a => a -> a -> a
* Int
offsetHour forall a. Num a => a -> a -> a
+ Int
offsetMinute)))
                    forall {f :: * -> *}. Applicative f => Int64 -> Int -> f Contents
finishWithSeconds Int64
offset Int
seconds
                  Char
'-' -> do
                    Word8
_ <- forall e s. e -> Parser e s Word8
P.any String
"utctime impossible"
                    !Int
offsetHour <- forall e s. e -> Parser e s Int
twoDigits String
"utctime offset hour digit problem"
                    !Int
offsetMinute <- forall e s. e -> Parser e s Int
twoDigits String
"utctime offset minute digit problem"
                    let !offset :: Int64
offset = forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Int64 (Int
60 forall a. Num a => a -> a -> a
* (Int
60 forall a. Num a => a -> a -> a
* Int
offsetHour forall a. Num a => a -> a -> a
+ Int
offsetMinute))
                    forall {f :: * -> *}. Applicative f => Int64 -> Int -> f Contents
finishWithSeconds Int64
offset Int
seconds
                  Char
_ -> forall e s a. e -> Parser e s a
P.fail String
"utctime unexpected byte after seconds"
        Char
_ -> forall e s a. e -> Parser e s a
P.fail String
"utctime unexpected byte after minute"

twoDigits :: e -> Parser e s Int
{-# inline twoDigits #-}
twoDigits :: forall e s. e -> Parser e s Int
twoDigits e
e = do
  Word8
w0 <- forall e s. e -> Parser e s Word8
P.any e
e
  Int
w0' <- if Word8
w0 forall a. Ord a => a -> a -> Bool
>= Word8
0x30 Bool -> Bool -> Bool
&& Word8
w0 forall a. Ord a => a -> a -> Bool
<= Word8
0x39
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Int Word8
w0 forall a. Num a => a -> a -> a
- Int
0x30)
    else forall e s a. e -> Parser e s a
P.fail e
e
  Word8
w1 <- forall e s. e -> Parser e s Word8
P.any e
e
  Int
w1' <- if Word8
w1 forall a. Ord a => a -> a -> Bool
>= Word8
0x30 Bool -> Bool -> Bool
&& Word8
w1 forall a. Ord a => a -> a -> Bool
<= Word8
0x39
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Int Word8
w1 forall a. Num a => a -> a -> a
- Int
0x30)
    else forall e s a. e -> Parser e s a
P.fail e
e
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
w0' forall a. Num a => a -> a -> a
* Int
10 forall a. Num a => a -> a -> a
+ Int
w1')

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
0x01 -> forall s. Parser String s Contents
boolean
      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