-- SPDX-FileCopyrightText: 2021 Tocqueville Group
-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA
-- SPDX-License-Identifier: LicenseRef-MIT-obsidian-systems

{-# OPTIONS_HADDOCK not-home #-}

-- | Defines binary encoding primitives which mimic Tezos' binary encoding.
module Morley.Micheline.Binary.Internal
  ( module Morley.Micheline.Binary.Internal
  ) where

import Control.Exception (assert)
import Data.Binary.Builder qualified as Bi
import Data.Binary.Get qualified as Bi
import Data.Bits (Bits, bit, setBit, shift, testBit, zeroBits, (.&.), (.|.))
import Data.ByteString.Lazy qualified as LBS
import Data.Text.Encoding qualified as TE
import Unsafe qualified (fromIntegral)

newtype DynamicSize a = DynamicSize { forall a. DynamicSize a -> a
unDynamicSize :: a }

-------------------------------------------------
-- Encode
-------------------------------------------------

buildWord8 :: Word8 -> Bi.Builder
buildWord8 :: Word8 -> Builder
buildWord8 = Word8 -> Builder
Bi.singleton

buildByteString :: ByteString -> Bi.Builder
buildByteString :: ByteString -> Builder
buildByteString = ByteString -> Builder
Bi.fromByteString

buildInteger :: Integer -> Bi.Builder
buildInteger :: Integer -> Builder
buildInteger Integer
n =
  let signBit :: Word8
signBit = if Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then Int -> Word8
forall a. Bits a => Int -> a
bit Int
6 else Word8
forall a. Bits a => a
zeroBits
      ab :: Integer
ab = Integer -> Integer
forall a. Num a => a -> a
abs Integer
n
  in
    -- Refer to: https://gitlab.com/obsidian.systems/tezos-bake-monitor-lib/-/blob/2cf12e53072bcd966d471430ead25f597db5e23f/tezos-bake-monitor-lib/src/Tezos/Common/Binary.hs#L122
    if Integer
ab Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0x40 then Word8 -> Builder
Bi.singleton (forall a b.
(?callStack::CallStack, Integral a, Integral b) =>
a -> b
Unsafe.fromIntegral @Integer @Word8 Integer
ab Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
signBit)
    else Word8 -> Builder
Bi.singleton (forall a b.
(?callStack::CallStack, Integral a, Integral b) =>
a -> b
Unsafe.fromIntegral @Integer @Word8 (Integer
ab Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
0x3f) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
signBit Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Int -> Word8
forall a. Bits a => Int -> a
bit Int
7) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Integer -> Builder
forall a. (Integral a, Bits a) => Int -> a -> Builder
writeZ (Int
-6) Integer
ab

writeZ :: forall a. (Integral a, Bits a) => Int -> a -> Bi.Builder
writeZ :: forall a. (Integral a, Bits a) => Int -> a -> Builder
writeZ Int
offset a
n =
  if a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< Int -> a
forall a. Bits a => Int -> a
bit (Int
7 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
offset) then Word8 -> Builder
Bi.singleton (Word8 -> Builder) -> Word8 -> Builder
forall a b. (a -> b) -> a -> b
$ forall a b.
(?callStack::CallStack, Integral a, Integral b) =>
a -> b
Unsafe.fromIntegral @a @Word8 (a -> Word8) -> a -> Word8
forall a b. (a -> b) -> a -> b
$ a
n a -> Int -> a
forall a. Bits a => a -> Int -> a
`shift` Int
offset
    else Word8 -> Builder
Bi.singleton (forall a b.
(?callStack::CallStack, Integral a, Integral b) =>
a -> b
Unsafe.fromIntegral @a @Word8 (((a
n a -> Int -> a
forall a. Bits a => a -> Int -> a
`shift` Int
offset) a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x7f) a -> Int -> a
forall a. Bits a => a -> Int -> a
`setBit` Int
7)) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> a -> Builder
forall a. (Integral a, Bits a) => Int -> a -> Builder
writeZ (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
7) a
n

-- | Build a binary representation of a Zarith natural. This function is
-- partial, only defined for nonnegative 'Integer's.
--
-- The reason it's not defined to accept a 'Natural' is mostly to avoid
-- 'fromIntegral'/'toInteger' conversions at the use sites, since
-- not all libraries, notably @cryptonite@, support 'Natural'.
buildNatural :: Integer -> Bi.Builder
buildNatural :: Integer -> Builder
buildNatural Integer
n = Bool -> Builder -> Builder
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0) (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$
  if Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0x80 then Word8 -> Builder
Bi.singleton (forall a b.
(?callStack::CallStack, Integral a, Integral b) =>
a -> b
Unsafe.fromIntegral @Integer @Word8 Integer
n)
  else Word8 -> Builder
Bi.singleton (forall a b.
(?callStack::CallStack, Integral a, Integral b) =>
a -> b
Unsafe.fromIntegral @Integer @Word8 (Integer
n Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
0xff) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Int -> Word8
forall a. Bits a => Int -> a
bit Int
7) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Integer -> Builder
forall a. (Integral a, Bits a) => Int -> a -> Builder
writeZ (Int
-7) Integer
n

buildDynamic :: (a -> Bi.Builder) -> (DynamicSize a) -> Bi.Builder
buildDynamic :: forall a. (a -> Builder) -> DynamicSize a -> Builder
buildDynamic a -> Builder
build (DynamicSize a
x) =
  let b :: Builder
b = a -> Builder
build a
x
  in Word32 -> Builder
Bi.putWord32be (forall a b.
(?callStack::CallStack, Integral a, Integral b) =>
a -> b
Unsafe.fromIntegral @Int64 @Word32 (Int64 -> Word32) -> Int64 -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
LBS.length (ByteString -> Int64) -> ByteString -> Int64
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Bi.toLazyByteString Builder
b) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b

buildText :: Text -> Bi.Builder
buildText :: Text -> Builder
buildText Text
n =
  ByteString -> Builder
buildByteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TE.encodeUtf8 Text
n

-------------------------------------------------
-- Decode
-------------------------------------------------

getInteger :: Bi.Get Integer
getInteger :: Get Integer
getInteger = do
  Word8
b <- Get Word8
Bi.getWord8
  Integer
n <- if Word8
b Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
7 then Int -> Integer -> Get Integer
forall a. (Integral a, Bits a) => Int -> a -> Get a
readZ Int
6 (Word8 -> Integer
forall a b. (Integral a, Integral b, CheckIntSubType a b) => a -> b
fromIntegral (Word8 -> Integer) -> Word8 -> Integer
forall a b. (a -> b) -> a -> b
$ Word8
b Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x3f) else Integer -> Get Integer
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word8 -> Integer
forall a b. (Integral a, Integral b, CheckIntSubType a b) => a -> b
fromIntegral (Word8 -> Integer) -> Word8 -> Integer
forall a b. (a -> b) -> a -> b
$ Word8
b Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x3f)
  pure $ if Word8
b Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
6 then Integer -> Integer
forall a. Num a => a -> a
negate Integer
n else Integer
n

getNatural :: Bi.Get Integer
getNatural :: Get Integer
getNatural = do
  Word8
b <- Get Word8
Bi.getWord8
  if Word8
b Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
7 then Int -> Integer -> Get Integer
forall a. (Integral a, Bits a) => Int -> a -> Get a
readZ Int
7 (Word8 -> Integer
forall a b. (Integral a, Integral b, CheckIntSubType a b) => a -> b
fromIntegral (Word8 -> Integer) -> Word8 -> Integer
forall a b. (a -> b) -> a -> b
$ Word8
b Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x7f) else Integer -> Get Integer
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word8 -> Integer
forall a b. (Integral a, Integral b, CheckIntSubType a b) => a -> b
fromIntegral (Word8 -> Integer) -> Word8 -> Integer
forall a b. (a -> b) -> a -> b
$ Word8
b Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x7f)

readZ :: forall a. (Integral a, Bits a) => Int -> a -> Bi.Get a
readZ :: forall a. (Integral a, Bits a) => Int -> a -> Get a
readZ Int
offset a
n = do
  Word8
b <- Get Word8
Bi.getWord8
  Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Word8
b Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0) Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
&& (Int
offset Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$ String -> Get ()
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"trailing zero"
  let n' :: a
n' = (forall a b.
(?callStack::CallStack, Integral a, Integral b) =>
a -> b
Unsafe.fromIntegral @Word8 @a (Word8
b Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x7f) a -> Int -> a
forall a. Bits a => a -> Int -> a
`shift` Int
offset) a -> a -> a
forall a. Bits a => a -> a -> a
.|. a
n
  if Word8
b Word8 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
7 then Int -> a -> Get a
forall a. (Integral a, Bits a) => Int -> a -> Get a
readZ (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
7) a
n' else a -> Get a
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
n'

getDynamic :: (Bi.Get a) -> (Bi.Get (DynamicSize a))
getDynamic :: forall a. Get a -> Get (DynamicSize a)
getDynamic Get a
getter = do
  Int
len <- forall a b.
(?callStack::CallStack, Integral a, Integral b) =>
a -> b
Unsafe.fromIntegral @Word32 @Int (Word32 -> Int) -> Get Word32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
Bi.getWord32be
  a -> DynamicSize a
forall a. a -> DynamicSize a
DynamicSize (a -> DynamicSize a) -> Get a -> Get (DynamicSize a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get a -> Get a
forall a. Int -> Get a -> Get a
Bi.isolate Int
len Get a
getter

{-# ANN getText ("HLint: ignore Redundant fmap" :: Text) #-}
getText :: Bi.Get Text
getText :: Get Text
getText =
  (ByteString -> Either UnicodeException Text)
-> Get ByteString -> Get (Either UnicodeException Text)
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Either UnicodeException Text
decodeUtf8' Get ByteString
getByteString Get (Either UnicodeException Text)
-> (Either UnicodeException Text -> Get Text) -> Get Text
forall a b. Get a -> (a -> Get b) -> Get b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Left UnicodeException
err -> String -> Get Text
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get Text) -> String -> Get Text
forall a b. (a -> b) -> a -> b
$ UnicodeException -> String
forall b a. (PrettyShow a, Show a, IsString b) => a -> b
show UnicodeException
err
    Right Text
answer -> Text -> Get Text
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
answer

getByteString :: Bi.Get ByteString
getByteString :: Get ByteString
getByteString =
  ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> Get ByteString -> Get ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
Bi.getRemainingLazyByteString