{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE TypeInType          #-}
{-# LANGUAGE TypeOperators       #-}

-- |
-- Module      :  Data.Solidity.Abi.Generic
-- Copyright   :  Aleksandr Krupenkin 2016-2024
-- License     :  Apache-2.0
--
-- Maintainer  :  mail@akru.me
-- Stability   :  experimental
-- Portability :  noportable
--
-- This module is internal, the purpose is to define helper classes and functions
-- to assist in encoding and decoding Solidity types for function calls and events.
-- The user of this library should have no need to use this directly in application code.
--

module Data.Solidity.Abi.Generic () where

import qualified Data.ByteString.Lazy   as LBS
import           Data.Int               (Int64)
import qualified Data.List              as L
import           Data.Proxy             (Proxy (..))
import           Data.Serialize         (Get, Put)
import           Data.Serialize.Get     (bytesRead, lookAheadE, skip)
import           Data.Serialize.Put     (runPutLazy)
import           Generics.SOP           (I (..), NP (..), NS (..), SOP (..))

import           Data.Solidity.Abi      (AbiGet (..), AbiPut (..), AbiType (..),
                                         GenericAbiGet (..), GenericAbiPut (..))
import           Data.Solidity.Prim.Int (getWord256, putWord256)

data EncodedValue = EncodedValue
    { EncodedValue -> Int64
evOrder                 :: Int64
    , EncodedValue -> Bool
evIsDynamic             :: Bool
    , EncodedValue -> Put
evEncoding              :: Put
    , EncodedValue -> Int64
evEncodingLengthInBytes :: Int64 -- cache
    }

instance Eq EncodedValue where
  EncodedValue
ev1 == :: EncodedValue -> EncodedValue -> Bool
== EncodedValue
ev2 = EncodedValue -> Int64
evOrder EncodedValue
ev1 Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== EncodedValue -> Int64
evOrder EncodedValue
ev2

instance Ord EncodedValue where
  compare :: EncodedValue -> EncodedValue -> Ordering
compare EncodedValue
ev1 EncodedValue
ev2 = EncodedValue -> Int64
evOrder EncodedValue
ev1 Int64 -> Int64 -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` EncodedValue -> Int64
evOrder EncodedValue
ev2

-- from https://docs.soliditylang.org/en/v0.8.12/abi-spec.html#examples
--
-- if Ti is static:
--   head(X(i)) = enc(X(i)) and tail(X(i)) = "" (the empty string)
-- otherwise, i.e. if Ti is dynamic:
--   head(X(i)) = enc(len( head(X(1)) ... head(X(k)) tail(X(1)) ... tail(X(i-1)) )) tail(X(i)) = enc(X(i))
combineEncodedValues :: [EncodedValue] -> Put
combineEncodedValues :: [EncodedValue] -> Put
combineEncodedValues [EncodedValue]
encodings =
  let sortedEncodings :: [EncodedValue]
sortedEncodings = [EncodedValue] -> [EncodedValue]
forall a. Ord a => [a] -> [a]
L.sort [EncodedValue]
encodings

      wordLengthInBytes :: Int64
      wordLengthInBytes :: Int64
wordLengthInBytes = Int64
32

      headsOffsetInBytes :: Int64
      headsOffsetInBytes :: Int64
headsOffsetInBytes = (Int64 -> Int64 -> Int64) -> Int64 -> [Int64] -> Int64
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
(+) Int64
0 ([Int64] -> Int64) -> [Int64] -> Int64
forall a b. (a -> b) -> a -> b
$ (EncodedValue -> Int64) -> [EncodedValue] -> [Int64]
forall a b. (a -> b) -> [a] -> [b]
map (\EncodedValue{Bool
Int64
Put
evOrder :: EncodedValue -> Int64
evIsDynamic :: EncodedValue -> Bool
evEncoding :: EncodedValue -> Put
evEncodingLengthInBytes :: EncodedValue -> Int64
evOrder :: Int64
evIsDynamic :: Bool
evEncoding :: Put
evEncodingLengthInBytes :: Int64
..} -> if Bool
evIsDynamic then Int64
wordLengthInBytes else Int64
evEncodingLengthInBytes) [EncodedValue]
encodings

      heads :: Put
heads = (Put, Int64) -> Put
forall a b. (a, b) -> a
fst ((Put, Int64) -> Put) -> (Put, Int64) -> Put
forall a b. (a -> b) -> a -> b
$ ((Put, Int64) -> EncodedValue -> (Put, Int64))
-> (Put, Int64) -> [EncodedValue] -> (Put, Int64)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
        (\(Put
accumulator, Int64
lengthOfPreviousDynamicValues) EncodedValue{Bool
Int64
Put
evOrder :: EncodedValue -> Int64
evIsDynamic :: EncodedValue -> Bool
evEncoding :: EncodedValue -> Put
evEncodingLengthInBytes :: EncodedValue -> Int64
evOrder :: Int64
evIsDynamic :: Bool
evEncoding :: Put
evEncodingLengthInBytes :: Int64
..} -> if Bool
evIsDynamic
            then ( Put
accumulator Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> Putter Word256
putWord256 (Int64 -> Word256
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word256) -> Int64 -> Word256
forall a b. (a -> b) -> a -> b
$ Int64
headsOffsetInBytes Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
lengthOfPreviousDynamicValues)
                 , Int64
lengthOfPreviousDynamicValues Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
evEncodingLengthInBytes
                 )
            else ( Put
accumulator Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> Put
evEncoding
                 , Int64
lengthOfPreviousDynamicValues
                 )
        )
        (Put
forall a. Monoid a => a
mempty, Int64
0)
        [EncodedValue]
sortedEncodings
      tails :: Put
tails = (EncodedValue -> Put) -> [EncodedValue] -> Put
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
        (\EncodedValue{Bool
Int64
Put
evOrder :: EncodedValue -> Int64
evIsDynamic :: EncodedValue -> Bool
evEncoding :: EncodedValue -> Put
evEncodingLengthInBytes :: EncodedValue -> Int64
evOrder :: Int64
evIsDynamic :: Bool
evEncoding :: Put
evEncodingLengthInBytes :: Int64
..} -> if Bool
evIsDynamic
            then Put
evEncoding
            else Put
forall a. Monoid a => a
mempty
        )
        [EncodedValue]
sortedEncodings
      in Put
heads Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> Put
tails
  where

-- aIsDynamic is a variable because of https://github.com/airalab/hs-web3/pull/129#issuecomment-1074045478
-- TODO: call the `isDynamic` function in the `mkEncodedValue` function
mkEncodedValue :: (AbiType a, AbiPut a) => [EncodedValue] -> a -> Bool -> EncodedValue
mkEncodedValue :: forall a.
(AbiType a, AbiPut a) =>
[EncodedValue] -> a -> Bool -> EncodedValue
mkEncodedValue [EncodedValue]
otherEncodedArray a
a Bool
aIsDynamic =
  let encoding :: Put
encoding = Putter a
forall a. AbiPut a => Putter a
abiPut a
a
  in EncodedValue
  { evEncoding :: Put
evEncoding              = Put
encoding
  , evOrder :: Int64
evOrder                 = Integer -> Int64
forall a. Num a => Integer -> a
fromInteger (Integer -> Int64)
-> ([EncodedValue] -> Integer) -> [EncodedValue] -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer)
-> ([EncodedValue] -> Int) -> [EncodedValue] -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [EncodedValue] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
L.length ([EncodedValue] -> Int64) -> [EncodedValue] -> Int64
forall a b. (a -> b) -> a -> b
$ [EncodedValue]
otherEncodedArray
  , evIsDynamic :: Bool
evIsDynamic             = Bool
aIsDynamic
  , evEncodingLengthInBytes :: Int64
evEncodingLengthInBytes = Put -> Int64
lengthInBytes Put
encoding
  }
  where
  lengthInBytes :: Put -> Int64
  lengthInBytes :: Put -> Int64
lengthInBytes Put
e = ByteString -> Int64
LBS.length (ByteString -> Int64) -> (Put -> ByteString) -> Put -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPutLazy (Put -> Int64) -> Put -> Int64
forall a b. (a -> b) -> a -> b
$ Put
e

class AbiData a where
    _serialize :: [EncodedValue] -> a -> [EncodedValue]

instance AbiData (NP f '[]) where
    _serialize :: [EncodedValue] -> NP f '[] -> [EncodedValue]
_serialize [EncodedValue]
encoded NP f '[]
_ = [EncodedValue]
encoded

instance (AbiType b, AbiPut b, AbiData (NP I as)) => AbiData (NP I (b : as)) where
    _serialize :: [EncodedValue] -> NP I (b : as) -> [EncodedValue]
_serialize [EncodedValue]
encoded (I x
b :* NP I xs
a) = [EncodedValue] -> NP I xs -> [EncodedValue]
forall a. AbiData a => [EncodedValue] -> a -> [EncodedValue]
_serialize ([EncodedValue] -> x -> Bool -> EncodedValue
forall a.
(AbiType a, AbiPut a) =>
[EncodedValue] -> a -> Bool -> EncodedValue
mkEncodedValue [EncodedValue]
encoded x
b (Proxy b -> Bool
forall a. AbiType a => Proxy a -> Bool
isDynamic (Proxy b
forall {k} (t :: k). Proxy t
Proxy :: Proxy b)) EncodedValue -> [EncodedValue] -> [EncodedValue]
forall a. a -> [a] -> [a]
: [EncodedValue]
encoded) NP I xs
a

instance AbiData (NP f as) => GenericAbiPut (SOP f '[as]) where
    gAbiPut :: Putter (SOP f '[as])
gAbiPut (SOP (Z NP f x
a)) = [EncodedValue] -> Put
combineEncodedValues ([EncodedValue] -> Put) -> [EncodedValue] -> Put
forall a b. (a -> b) -> a -> b
$ [EncodedValue] -> NP f x -> [EncodedValue]
forall a. AbiData a => [EncodedValue] -> a -> [EncodedValue]
_serialize [] NP f x
a
    gAbiPut SOP f '[as]
_           = [Char] -> Put
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible branch"

instance GenericAbiGet (NP f '[]) where
    gAbiGet :: Get (NP f '[])
gAbiGet = NP f '[] -> Get (NP f '[])
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return NP f '[]
forall {k} (a :: k -> *). NP a '[]
Nil

instance (AbiGet a, GenericAbiGet (NP I as)) => GenericAbiGet (NP I (a : as)) where
    gAbiGet :: Get (NP I (a : as))
gAbiGet = I a -> NP I as -> NP I (a : as)
forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
(:*) (I a -> NP I as -> NP I (a : as))
-> Get (I a) -> Get (NP I as -> NP I (a : as))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> I a
forall a. a -> I a
I (a -> I a) -> Get a -> Get (I a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get a
forall a. AbiGet a => Get a
factorParser) Get (NP I as -> NP I (a : as))
-> Get (NP I as) -> Get (NP I (a : as))
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (NP I as)
forall a. GenericAbiGet a => Get a
gAbiGet

instance GenericAbiGet (NP f as) => GenericAbiGet (SOP f '[as]) where
    gAbiGet :: Get (SOP f '[as])
gAbiGet = NS (NP f) '[as] -> SOP f '[as]
forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP (NS (NP f) '[as] -> SOP f '[as])
-> (NP f as -> NS (NP f) '[as]) -> NP f as -> SOP f '[as]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP f as -> NS (NP f) '[as]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (NP f as -> SOP f '[as]) -> Get (NP f as) -> Get (SOP f '[as])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (NP f as)
forall a. GenericAbiGet a => Get a
gAbiGet

factorParser :: forall a . AbiGet a => Get a
factorParser :: forall a. AbiGet a => Get a
factorParser
  | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Proxy a -> Bool
forall a. AbiType a => Proxy a -> Bool
isDynamic (Proxy a
forall {k} (t :: k). Proxy t
Proxy :: Proxy a) = Get a
forall a. AbiGet a => Get a
abiGet
  | Bool
otherwise = do
        Int
dataOffset <- Word256 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word256 -> Int) -> Get Word256 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word256
getWord256
        Int
currentOffset <- Get Int
bytesRead
        Left a
x <- Get (Either a Any) -> Get (Either a Any)
forall a b. Get (Either a b) -> Get (Either a b)
lookAheadE (Get (Either a Any) -> Get (Either a Any))
-> Get (Either a Any) -> Get (Either a Any)
forall a b. (a -> b) -> a -> b
$ do
            Int -> Get ()
skip (Int
dataOffset Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
currentOffset)
            a -> Either a Any
forall a b. a -> Either a b
Left (a -> Either a Any) -> Get a -> Get (Either a Any)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get a
forall a. AbiGet a => Get a
abiGet
        a -> Get a
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x