{-# LANGUAGE FlexibleContexts #-}

-- |
-- Module      :  Network.Ethereum.Account.Safe
-- Copyright   :  Aleksandr Krupenkin 2016-2024
-- License     :  Apache-2.0
--
-- Maintainer  :  mail@akru.me
-- Stability   :  experimental
-- Portability :  unportable
--
-- Safe sending of Ethereum transaction.
--

module Network.Ethereum.Account.Safe where

import           Control.Concurrent                (threadDelay)
import           Control.Monad.IO.Class            (liftIO)
import           Control.Monad.Trans               (lift)
import           Data.ByteArray.HexString          (HexString)

import           Network.Ethereum.Account.Class    (Account (send))
import           Network.Ethereum.Account.Internal (updateReceipt)
import qualified Network.Ethereum.Api.Eth          as Eth
import           Network.Ethereum.Api.Types        (TxReceipt (receiptBlockNumber))
import           Network.Ethereum.Contract.Method  (Method)
import           Network.JsonRpc.TinyClient        (JsonRpc)

-- | Safe version of 'send' function of 'Account' typeclass
-- Waiting for some blocks of transaction confirmation before return
safeSend :: (Account p t, JsonRpc m, Method args, Monad (t m))
         => Integer
         -- ^ Confirmation in blocks
         -> args
         -- ^ Contract method arguments
         -> t m (Either HexString TxReceipt)
         -- ^ Receipt of the sent transaction, or transaction data in case of a timeout
safeSend :: forall p (t :: (* -> *) -> * -> *) (m :: * -> *) args.
(Account p t, JsonRpc m, Method args, Monad (t m)) =>
Integer -> args -> t m (Either HexString TxReceipt)
safeSend Integer
b args
a = m (Either HexString TxReceipt) -> t m (Either HexString TxReceipt)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either HexString TxReceipt)
 -> t m (Either HexString TxReceipt))
-> (Either HexString TxReceipt -> m (Either HexString TxReceipt))
-> Either HexString TxReceipt
-> t m (Either HexString TxReceipt)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxReceipt -> m TxReceipt)
-> Either HexString TxReceipt -> m (Either HexString TxReceipt)
forall {m :: * -> *} {t} {b} {a}.
Monad m =>
(t -> m b) -> Either a t -> m (Either a b)
withReceipt TxReceipt -> m TxReceipt
forall {m :: * -> *}. JsonRpc m => TxReceipt -> m TxReceipt
waiting (Either HexString TxReceipt -> t m (Either HexString TxReceipt))
-> t m (Either HexString TxReceipt)
-> t m (Either HexString TxReceipt)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< args -> t m (Either HexString TxReceipt)
forall a (t :: (* -> *) -> * -> *) (m :: * -> *) args.
(Account a t, JsonRpc m, Method args) =>
args -> t m (Either HexString TxReceipt)
forall (m :: * -> *) args.
(JsonRpc m, Method args) =>
args -> t m (Either HexString TxReceipt)
send args
a
  where
    withReceipt :: (t -> m b) -> Either a t -> m (Either a b)
withReceipt t -> m b
f Either a t
receiptOrTx =
        case Either a t
receiptOrTx of
            Left a
tx       -> Either a b -> m (Either a b)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a b -> m (Either a b)) -> Either a b -> m (Either a b)
forall a b. (a -> b) -> a -> b
$ a -> Either a b
forall a b. a -> Either a b
Left a
tx
            Right t
receipt -> b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> m b -> m (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> m b
f t
receipt

    waiting :: TxReceipt -> m TxReceipt
waiting TxReceipt
receipt =
        case TxReceipt -> Maybe Quantity
receiptBlockNumber TxReceipt
receipt of
            Maybe Quantity
Nothing -> do
                IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
1000000
                TxReceipt -> m TxReceipt
waiting (TxReceipt -> m TxReceipt) -> m TxReceipt -> m TxReceipt
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TxReceipt -> m TxReceipt
forall {m :: * -> *}. JsonRpc m => TxReceipt -> m TxReceipt
updateReceipt TxReceipt
receipt
            Just Quantity
bn -> do
                Quantity
current <- m Quantity
forall (m :: * -> *). JsonRpc m => m Quantity
Eth.blockNumber
                if Quantity
current Quantity -> Quantity -> Quantity
forall a. Num a => a -> a -> a
- Quantity
bn Quantity -> Quantity -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer -> Quantity
forall a. Num a => Integer -> a
fromInteger Integer
b
                    then TxReceipt -> m TxReceipt
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return TxReceipt
receipt
                    else do IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
1000000
                            TxReceipt -> m TxReceipt
waiting TxReceipt
receipt

-- | Count block confirmation to keep secure
-- According to Vitalik post
-- https://blog.ethereum.org/2015/09/14/on-slow-and-fast-block-times/
safeConfirmations :: Integer
safeConfirmations :: Integer
safeConfirmations = Integer
10