-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

module Morley.Client.Util
  ( epNameToTezosEp
  , extractAddressesFromValue
  , disableAlphanetWarning
  -- * @runContract@
  , runContract
  , RunContractParameters(..)
  , runContractParameters
  , withBalance
  , withAmount
  , withSender
  , withSource
  , withLevel
  , withNow

  -- * @octez-client@ password-related helpers
  , scrubbedBytesToString
  , readScrubbedBytes
  ) where

import Control.Lens (makeLensesFor)
import Data.ByteArray (ScrubbedBytes, convert)
import Data.ByteString qualified as BS (getLine)
import Data.Constraint ((\\))
import Generics.SYB (everything, mkQ)
import System.Environment (setEnv)

import Morley.AsRPC (AsRPC, rpcStorageScopeEvi)
import Morley.Client.RPC.Class
import Morley.Client.RPC.Getters
import Morley.Client.RPC.Types
import Morley.Micheline
import Morley.Michelson.Text
import Morley.Michelson.Typed (HasNoOp, untypeValue)
import Morley.Michelson.Typed qualified as T
import Morley.Michelson.Typed.Entrypoints (EpAddress(..), parseEpAddress)
import Morley.Michelson.Untyped (InternalByteString(..), Value, Value'(..))
import Morley.Michelson.Untyped.Entrypoints (EpName(..), pattern DefEpName)
import Morley.Tezos.Address
import Morley.Tezos.Core (Mutez, Timestamp(..), zeroMutez)
import Morley.Util.Exception as E (throwLeft)

-- | Sets the environment variable for disabling @octez-client@'s
-- "not a mainnet" warning
disableAlphanetWarning :: IO ()
disableAlphanetWarning :: IO ()
disableAlphanetWarning = String -> String -> IO ()
setEnv String
"TEZOS_CLIENT_UNSAFE_DISABLE_DISCLAIMER" String
"YES"

-- | Convert 'EpName' to the textual representation used by RPC and @octez-client@.
epNameToTezosEp :: EpName -> Text
epNameToTezosEp :: EpName -> Text
epNameToTezosEp = \case
  EpName
DefEpName -> Text
"default"
  EpName
epName -> EpName -> Text
unEpName EpName
epName

-- | Extract all addresses value from given untyped 'Value'.
--
-- Note that it returns all values that can be used as an address.
-- However, some of fetched values can never be used as an address.
extractAddressesFromValue :: Value -> [Address]
extractAddressesFromValue :: Value -> [Address]
extractAddressesFromValue Value
val =
  ([Address] -> [Address] -> [Address])
-> GenericQ [Address] -> GenericQ [Address]
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything [Address] -> [Address] -> [Address]
forall a. Semigroup a => a -> a -> a
(<>) ([Address] -> (Value -> [Address]) -> a -> [Address]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ [] Value -> [Address]
fetchAddress) Value
val
  where
    fetchAddress :: Value -> [Address]
    fetchAddress :: Value -> [Address]
fetchAddress = \case
      ValueString MText
s -> case Text -> Either ParseEpAddressError EpAddress
parseEpAddress (MText -> Text
unMText MText
s) of
        Right EpAddress
addr -> [EpAddress -> Address
eaAddress EpAddress
addr]
        Left ParseEpAddressError
_ -> []
      ValueBytes (InternalByteString ByteString
b) -> case ByteString -> Either ParseAddressRawError Address
parseAddressRaw ByteString
b of
        Right Address
addr -> [Address
addr]
        Left ParseAddressRawError
_ -> []
      Value
_ -> []

-- | A structure with all the parameters for 'runContract'
data RunContractParameters cp st = RunContractParameters
  { forall (cp :: T) (st :: T).
RunContractParameters cp st -> Contract cp st
rcpContract :: T.Contract cp st
  , forall (cp :: T) (st :: T). RunContractParameters cp st -> Value
rcpParameter :: Value
  -- ^ The parameter value should have the same "structure" as @cp@, except it _may_ also have big_map IDs.
  -- E.g. if the contract's parameter is @pair (big_map string string) (big_map string string)@,
  -- then 'rcpParameter' may be one of:
  --
  -- * @pair (big_map string string) (big_map string string)@
  -- * @pair nat (big_map string string)@
  -- * @pair (big_map string string) nat@
  -- * @pair nat nat@
  --
  -- ... where @nat@ represents a big_map ID.
  , forall (cp :: T) (st :: T). RunContractParameters cp st -> Value
rcpStorage :: Value
  -- ^ The storage value should have the same "structure" as @st@, except it _may_ also have big_map IDs.
  -- See the documentation of 'rcpParameter'.
  , forall (cp :: T) (st :: T). RunContractParameters cp st -> Mutez
rcpBalance :: Mutez
  , forall (cp :: T) (st :: T).
RunContractParameters cp st -> Maybe Timestamp
rcpNow :: Maybe Timestamp
  , forall (cp :: T) (st :: T).
RunContractParameters cp st -> Maybe Natural
rcpLevel :: Maybe Natural
  , forall (cp :: T) (st :: T). RunContractParameters cp st -> Mutez
rcpAmount :: Mutez
  , forall (cp :: T) (st :: T).
RunContractParameters cp st -> Maybe ImplicitAddress
rcpSender :: Maybe ImplicitAddress
  , forall (cp :: T) (st :: T).
RunContractParameters cp st -> Maybe ImplicitAddress
rcpSource :: Maybe ImplicitAddress
  }

-- | Initializes the parameters for `runContract` with sensible defaults.
--
-- Use the @with*@ lenses to set any optional parameters.
runContractParameters
  :: (HasNoOp cp, HasNoOp st)
  => T.Contract cp st -> T.Value cp -> T.Value st
  -> RunContractParameters cp st
runContractParameters :: forall (cp :: T) (st :: T).
(HasNoOp cp, HasNoOp st) =>
Contract cp st
-> Value cp -> Value st -> RunContractParameters cp st
runContractParameters Contract cp st
contract Value cp
cp Value st
st =
  RunContractParameters :: forall (cp :: T) (st :: T).
Contract cp st
-> Value
-> Value
-> Mutez
-> Maybe Timestamp
-> Maybe Natural
-> Mutez
-> Maybe ImplicitAddress
-> Maybe ImplicitAddress
-> RunContractParameters cp st
RunContractParameters
    { rcpContract :: Contract cp st
rcpContract = Contract cp st
contract
    , rcpParameter :: Value
rcpParameter = Value cp -> Value
forall (t :: T). HasNoOp t => Value' Instr t -> Value
untypeValue Value cp
cp
    , rcpStorage :: Value
rcpStorage = Value st -> Value
forall (t :: T). HasNoOp t => Value' Instr t -> Value
untypeValue Value st
st
    , rcpBalance :: Mutez
rcpBalance = Mutez
zeroMutez
    , rcpAmount :: Mutez
rcpAmount = Mutez
zeroMutez
    , rcpNow :: Maybe Timestamp
rcpNow = Maybe Timestamp
forall a. Maybe a
Nothing
    , rcpLevel :: Maybe Natural
rcpLevel = Maybe Natural
forall a. Maybe a
Nothing
    , rcpSender :: Maybe ImplicitAddress
rcpSender = Maybe ImplicitAddress
forall a. Maybe a
Nothing
    , rcpSource :: Maybe ImplicitAddress
rcpSource = Maybe ImplicitAddress
forall a. Maybe a
Nothing
    }

makeLensesFor
  [ ("rcpBalance", "withBalance")
  , ("rcpAmount", "withAmount")
  , ("rcpSender", "withSender")
  , ("rcpSource", "withSource")
  , ("rcpLevel", "withLevel")
  , ("rcpNow", "withNow")
  ]
  ''RunContractParameters

-- | Run contract with given parameter and storage and get new storage without
-- injecting anything to the chain.
runContract
  :: forall cp st m. (HasTezosRpc m, T.StorageScope st)
  => RunContractParameters cp st -> m (AsRPC (T.Value st))
runContract :: forall (cp :: T) (st :: T) (m :: * -> *).
(HasTezosRpc m, StorageScope st) =>
RunContractParameters cp st -> m (AsRPC (Value st))
runContract RunContractParameters{Maybe Natural
Maybe Timestamp
Maybe ImplicitAddress
Mutez
Contract cp st
Value
rcpSource :: Maybe ImplicitAddress
rcpSender :: Maybe ImplicitAddress
rcpAmount :: Mutez
rcpLevel :: Maybe Natural
rcpNow :: Maybe Timestamp
rcpBalance :: Mutez
rcpStorage :: Value
rcpParameter :: Value
rcpContract :: Contract cp st
rcpSource :: forall (cp :: T) (st :: T).
RunContractParameters cp st -> Maybe ImplicitAddress
rcpSender :: forall (cp :: T) (st :: T).
RunContractParameters cp st -> Maybe ImplicitAddress
rcpAmount :: forall (cp :: T) (st :: T). RunContractParameters cp st -> Mutez
rcpLevel :: forall (cp :: T) (st :: T).
RunContractParameters cp st -> Maybe Natural
rcpNow :: forall (cp :: T) (st :: T).
RunContractParameters cp st -> Maybe Timestamp
rcpBalance :: forall (cp :: T) (st :: T). RunContractParameters cp st -> Mutez
rcpStorage :: forall (cp :: T) (st :: T). RunContractParameters cp st -> Value
rcpParameter :: forall (cp :: T) (st :: T). RunContractParameters cp st -> Value
rcpContract :: forall (cp :: T) (st :: T).
RunContractParameters cp st -> Contract cp st
..} = do
  BlockConstants
headConstants <- BlockId -> m BlockConstants
forall (m :: * -> *). HasTezosRpc m => BlockId -> m BlockConstants
getBlockConstants BlockId
HeadId
  let args :: RunCode
args = RunCode :: Expression
-> Expression
-> Expression
-> TezosMutez
-> TezosMutez
-> Text
-> Maybe TezosNat
-> Maybe TezosNat
-> Maybe ImplicitAddress
-> Maybe ImplicitAddress
-> RunCode
RunCode
        { rcScript :: Expression
rcScript = Contract cp st -> Expression
forall a. ToExpression a => a -> Expression
toExpression Contract cp st
rcpContract
        , rcStorage :: Expression
rcStorage = Value -> Expression
forall a. ToExpression a => a -> Expression
toExpression Value
rcpStorage
        , rcInput :: Expression
rcInput = Value -> Expression
forall a. ToExpression a => a -> Expression
toExpression Value
rcpParameter
        , rcAmount :: TezosMutez
rcAmount = Mutez -> TezosMutez
TezosMutez Mutez
rcpAmount
        , rcBalance :: TezosMutez
rcBalance = Mutez -> TezosMutez
TezosMutez Mutez
rcpBalance
        , rcChainId :: Text
rcChainId = BlockConstants -> Text
bcChainId BlockConstants
headConstants
        , rcNow :: Maybe TezosNat
rcNow = Maybe Timestamp
rcpNow Maybe Timestamp -> (Timestamp -> TezosNat) -> Maybe TezosNat
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Natural -> TezosNat
forall a. a -> StringEncode a
StringEncode (Natural -> TezosNat)
-> (Timestamp -> Natural) -> Timestamp -> TezosNat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> Natural
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Natural)
-> (Timestamp -> POSIXTime) -> Timestamp -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Timestamp -> POSIXTime
unTimestamp
        , rcLevel :: Maybe TezosNat
rcLevel = Natural -> TezosNat
forall a. a -> StringEncode a
StringEncode (Natural -> TezosNat) -> Maybe Natural -> Maybe TezosNat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Natural
rcpLevel
        -- Note: assigning source=sender and payer=source may seem like a bug, but it's not.
        -- For some reason, the /run_code uses a different naming scheme.
        -- What this endpoint calls 'source' is actually the address that will be returned by the `SENDER` instruction.
        -- See details here: https://gitlab.com/tezos/tezos/-/issues/710
        , rcSource :: Maybe ImplicitAddress
rcSource = Maybe ImplicitAddress
rcpSender
        , rcPayer :: Maybe ImplicitAddress
rcPayer = Maybe ImplicitAddress
rcpSource
        }
  RunCodeResult
res <- RunCode -> m RunCodeResult
forall (m :: * -> *). HasTezosRpc m => RunCode -> m RunCodeResult
runCode RunCode
args
  forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
m (Either e a) -> m a
throwLeft @_ @FromExpressionError (m (Either FromExpressionError (Value (TAsRPC st)))
 -> m (Value (TAsRPC st)))
-> m (Either FromExpressionError (Value (TAsRPC st)))
-> m (Value (TAsRPC st))
forall a b. (a -> b) -> a -> b
$ Either FromExpressionError (Value (TAsRPC st))
-> m (Either FromExpressionError (Value (TAsRPC st)))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either FromExpressionError (Value (TAsRPC st))
 -> m (Either FromExpressionError (Value (TAsRPC st))))
-> Either FromExpressionError (Value (TAsRPC st))
-> m (Either FromExpressionError (Value (TAsRPC st)))
forall a b. (a -> b) -> a -> b
$
    forall a.
FromExp RegularExp a =>
Expression -> Either FromExpressionError a
fromExpression @(AsRPC (T.Value st)) (RunCodeResult -> Expression
rcrStorage RunCodeResult
res)
      (StorageScope (TAsRPC st) =>
 Either FromExpressionError (Value (TAsRPC st)))
-> (StorageScope st :- StorageScope (TAsRPC st))
-> Either FromExpressionError (Value (TAsRPC st))
forall (c :: Constraint) e r. HasDict c e => (c => r) -> e -> r
\\ forall (t :: T). StorageScope t :- StorageScope (TAsRPC t)
rpcStorageScopeEvi @st

-- | Function for relatively safe getting password from stdin.
-- After reading bytes are converted to @ScrubbedBytes@, thus it's harder
-- to accidentally leak them.
readScrubbedBytes :: MonadIO m => m ScrubbedBytes
readScrubbedBytes :: forall (m :: * -> *). MonadIO m => m ScrubbedBytes
readScrubbedBytes = ByteString -> ScrubbedBytes
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert (ByteString -> ScrubbedBytes) -> m ByteString -> m ScrubbedBytes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ByteString
BS.getLine

-- | Convert @ScrubbedBytes@ to @String@, so that it can be passed to @octez-client@
-- as a stdin
scrubbedBytesToString :: ScrubbedBytes -> String
scrubbedBytesToString :: ScrubbedBytes -> String
scrubbedBytesToString = ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (ByteString -> String)
-> (ScrubbedBytes -> ByteString) -> ScrubbedBytes -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert @ScrubbedBytes @ByteString