{-# 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-2021
-- 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
order    :: Int64
    , EncodedValue -> Maybe Int64
offset   :: Maybe Int64
    , EncodedValue -> Put
encoding :: Put
    }

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

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

combineEncodedValues :: [EncodedValue] -> Put
combineEncodedValues :: [EncodedValue] -> Put
combineEncodedValues [EncodedValue]
encodings =
  let sortedEs :: [EncodedValue]
sortedEs = Int64 -> [EncodedValue] -> [EncodedValue]
adjust Int64
headsOffset ([EncodedValue] -> [EncodedValue])
-> [EncodedValue] -> [EncodedValue]
forall a b. (a -> b) -> a -> b
$ [EncodedValue] -> [EncodedValue]
forall a. Ord a => [a] -> [a]
L.sort [EncodedValue]
encodings
      encodings' :: [EncodedValue]
encodings' = Int64 -> [EncodedValue] -> [EncodedValue] -> [EncodedValue]
addTailOffsets Int64
headsOffset [] [EncodedValue]
sortedEs
  in let heads :: Put
heads = (Put -> EncodedValue -> Put) -> Put -> [EncodedValue] -> Put
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Put
acc EncodedValue{Int64
Maybe Int64
Put
encoding :: Put
offset :: Maybe Int64
order :: Int64
encoding :: EncodedValue -> Put
offset :: EncodedValue -> Maybe Int64
order :: EncodedValue -> Int64
..} -> case Maybe Int64
offset of
                          Maybe Int64
Nothing -> Put
acc Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> Put
encoding
                          Just Int64
o  -> Put
acc 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
o)
                      ) Put
forall a. Monoid a => a
mempty [EncodedValue]
encodings'
         tails :: Put
tails = (Put -> EncodedValue -> Put) -> Put -> [EncodedValue] -> Put
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Put
acc EncodedValue{Int64
Maybe Int64
Put
encoding :: Put
offset :: Maybe Int64
order :: Int64
encoding :: EncodedValue -> Put
offset :: EncodedValue -> Maybe Int64
order :: EncodedValue -> Int64
..} -> case Maybe Int64
offset of
                          Maybe Int64
Nothing -> Put
acc
                          Just Int64
_  -> Put
acc Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> Put
encoding
                      ) Put
forall a. Monoid a => a
mempty [EncodedValue]
encodings'
      in Put
heads Put -> Put -> Put
forall a. Semigroup a => a -> a -> a
<> Put
tails
  where
    adjust :: Int64 -> [EncodedValue] -> [EncodedValue]
    adjust :: Int64 -> [EncodedValue] -> [EncodedValue]
adjust Int64
n = (EncodedValue -> EncodedValue) -> [EncodedValue] -> [EncodedValue]
forall a b. (a -> b) -> [a] -> [b]
map (\EncodedValue
ev -> EncodedValue
ev {offset :: Maybe Int64
offset = Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
(+) Int64
n (Int64 -> Int64) -> Maybe Int64 -> Maybe Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EncodedValue -> Maybe Int64
offset EncodedValue
ev})
    addTailOffsets :: Int64 -> [EncodedValue] -> [EncodedValue] -> [EncodedValue]
    addTailOffsets :: Int64 -> [EncodedValue] -> [EncodedValue] -> [EncodedValue]
addTailOffsets Int64
init' [EncodedValue]
acc [EncodedValue]
es = case [EncodedValue]
es of
      [] -> [EncodedValue] -> [EncodedValue]
forall a. [a] -> [a]
reverse [EncodedValue]
acc
      (EncodedValue
e : [EncodedValue]
tail') -> case EncodedValue -> Maybe Int64
offset EncodedValue
e of
        Maybe Int64
Nothing -> Int64 -> [EncodedValue] -> [EncodedValue] -> [EncodedValue]
addTailOffsets Int64
init' (EncodedValue
e EncodedValue -> [EncodedValue] -> [EncodedValue]
forall a. a -> [a] -> [a]
: [EncodedValue]
acc) [EncodedValue]
tail'
        Just Int64
_  -> Int64 -> [EncodedValue] -> [EncodedValue] -> [EncodedValue]
addTailOffsets Int64
init' (EncodedValue
e EncodedValue -> [EncodedValue] -> [EncodedValue]
forall a. a -> [a] -> [a]
: [EncodedValue]
acc) (Int64 -> [EncodedValue] -> [EncodedValue]
adjust (ByteString -> Int64
LBS.length (ByteString -> Int64)
-> (EncodedValue -> ByteString) -> EncodedValue -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPutLazy (Put -> ByteString)
-> (EncodedValue -> Put) -> EncodedValue -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EncodedValue -> Put
encoding (EncodedValue -> Int64) -> EncodedValue -> Int64
forall a b. (a -> b) -> a -> b
$ EncodedValue
e) [EncodedValue]
tail')
    headsOffset :: Int64
    headsOffset :: Int64
headsOffset = (Int64 -> EncodedValue -> Int64)
-> Int64 -> [EncodedValue] -> Int64
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Int64
acc EncodedValue
e -> case EncodedValue -> Maybe Int64
offset EncodedValue
e of
                                Maybe Int64
Nothing -> Int64
acc Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ (ByteString -> Int64
LBS.length (ByteString -> Int64)
-> (EncodedValue -> ByteString) -> EncodedValue -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPutLazy (Put -> ByteString)
-> (EncodedValue -> Put) -> EncodedValue -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EncodedValue -> Put
encoding (EncodedValue -> Int64) -> EncodedValue -> Int64
forall a b. (a -> b) -> a -> b
$ EncodedValue
e)
                                Just Int64
_ -> Int64
acc Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
32
                            ) Int64
0 [EncodedValue]
encodings

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) =
        if Proxy b -> Bool
forall a. AbiType a => Proxy a -> Bool
isDynamic (Proxy b
forall k (t :: k). Proxy t
Proxy :: Proxy b)
        then [EncodedValue] -> NP I xs -> [EncodedValue]
forall a. AbiData a => [EncodedValue] -> a -> [EncodedValue]
_serialize (EncodedValue
dynEncoding  EncodedValue -> [EncodedValue] -> [EncodedValue]
forall a. a -> [a] -> [a]
: [EncodedValue]
encoded) NP I xs
a
        else [EncodedValue] -> NP I xs -> [EncodedValue]
forall a. AbiData a => [EncodedValue] -> a -> [EncodedValue]
_serialize (EncodedValue
staticEncoding EncodedValue -> [EncodedValue] -> [EncodedValue]
forall a. a -> [a] -> [a]
: [EncodedValue]
encoded) NP I xs
a
      where
        staticEncoding :: EncodedValue
staticEncoding = EncodedValue :: Int64 -> Maybe Int64 -> Put -> EncodedValue
EncodedValue { encoding :: Put
encoding = Putter x
forall a. AbiPut a => Putter a
abiPut x
b
                                      , offset :: Maybe Int64
offset = Maybe Int64
forall a. Maybe a
Nothing
                                      , order :: Int64
order = Int64
1 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ (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 (t :: * -> *) a. Foldable t => t a -> Int
L.length ([EncodedValue] -> Int64) -> [EncodedValue] -> Int64
forall a b. (a -> b) -> a -> b
$ [EncodedValue]
encoded)
                                      }
        dynEncoding :: EncodedValue
dynEncoding = EncodedValue :: Int64 -> Maybe Int64 -> Put -> EncodedValue
EncodedValue { encoding :: Put
encoding = Putter x
forall a. AbiPut a => Putter a
abiPut x
b
                                   , offset :: Maybe Int64
offset = Int64 -> Maybe Int64
forall a. a -> Maybe a
Just Int64
0
                                   , order :: Int64
order = Int64
1 Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ (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 (t :: * -> *) a. Foldable t => t a -> Int
L.length ([EncodedValue] -> Int64) -> [EncodedValue] -> Int64
forall a b. (a -> b) -> a -> b
$ [EncodedValue]
encoded)
                                   }

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 (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 (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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return a
x