{-# 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
, 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
| Integer !Int64
| OctetString {-# UNPACK #-} !Bytes
| BitString !Word8 {-# UNPACK #-} !Bytes
| Null
| ObjectIdentifier !Oid
| Utf8String {-# UNPACK #-} !TS.ShortText
| PrintableString {-# UNPACK #-} !TS.ShortText
| UtcTime !Int64
| Constructed !(SmallArray Value)
| Unresolved {-# UNPACK #-} !Bytes
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)
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
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)
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
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"
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