View on GitHub
File Changes
import qualified Ledger.Tx                   as Tx
import           Ledger.Value                (Value)
import qualified Ledger.Value                as Value
-
import           Wallet.API                  (MonadWallet, PubKey, WalletAPIError, WalletAPI)
+
import           Wallet.API                  (MonadWallet, PubKey, WalletAPI, WalletAPIError)
import qualified Wallet.API                  as WAPI
import           Wallet.Emulator             (Wallet)
import qualified Wallet.Emulator             as E

                      
-- | Balance an unabalanced transaction, sign it, and submit
--   it to the chain in the context of a wallet.
-
handleTx :: (MonadWallet m, WAPI.NodeAPI m) => SigningProcess -> UnbalancedTx -> m Tx
+
handleTx :: MonadWallet m => SigningProcess -> UnbalancedTx -> m Tx
handleTx p utx =
    balanceWallet utx >>= addSignatures p (T.requiredSignatories utx) >>= WAPI.signTxAndSubmit

                      
    throwError = throwError
    catchError = catchError

                      
-
instance (Member WalletEffect effs, Member (Error WAPI.WalletAPIError) effs) => WAPI.WalletDiagnostics (Eff effs) where
+
instance (Member WalletEffect effs) => WAPI.WalletDiagnostics (Eff effs) where
    logMsg = walletLogMsg

                      
-- UTILITIES: should probably be elsewhere
{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE DeriveAnyClass    #-}
{-# LANGUAGE DeriveGeneric     #-}
+
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeApplications  #-}
    ( API
    ) where

                      
-
import           Ledger      (Tx, Slot)
-
import           Servant.API ((:<|>), (:>), Get, JSON, NoContent, ReqBody, Post)
+
import           Ledger      (Slot, Tx)
+
import           Servant.API ((:<|>), (:>), Get, JSON, NoContent, Post, ReqBody)

                      
type API
     = "healthcheck" :> Get '[ JSON] NoContent

                      
import           Cardano.Node.API    (API)
import           Data.Proxy          (Proxy (Proxy))
-
import           Ledger              (Slot, Tx, TxId)
+
import           Ledger              (Slot, Tx)
import           Network.HTTP.Client (defaultManagerSettings, newManager)
-
import           Servant             (NoContent, (:<|>)(..))
+
import           Servant             ((:<|>) (..), NoContent)
import           Servant.Client      (ClientM, client, mkClientEnv, parseBaseUrl, runClientM)

                      
healthcheck :: ClientM NoContent
(healthcheck, addTx, getCurrentSlot, randomTx) =
    (healthcheck_, addTx_, getCurrentSlot_, randomTx_)
  where
-
    healthcheck_ :<|> addTx_ :<|> getCurrentSlot_ :<|> randomTx_ = client (Proxy @API)
-
    
+
    healthcheck_ :<|> addTx_ :<|> getCurrentSlot_ :<|> randomTx_ =
+
        client (Proxy @API)
+

                      
main :: IO ()
main = do
    manager <- newManager defaultManagerSettings
import           Cardano.Node.API               (API)
import           Control.Concurrent             (forkIO, threadDelay)
import           Control.Concurrent.MVar        (MVar, newMVar, putMVar, takeMVar)
-
import           Control.Lens                   (view, over)
+
import           Control.Lens                   (over, view)
import           Control.Monad                  (forever, void)
import           Control.Monad.Freer            (Eff, Member)
import           Control.Monad.Freer.State      (State)

                      
data BlockReaperConfig =
    BlockReaperConfig
-
        { brcInterval :: Second
+
        { brcInterval     :: Second
        , brcBlocksToKeep :: Int
        }

                      
        , mscBlockReaper = Just BlockReaperConfig{brcInterval = 600, brcBlocksToKeep = 100 }
        }

                      
+
-- Spec:
+
-- Radu: You get block data, you get headers data and you can submit balanced transactions.
+
-- Index is a client of the node.
+
-- As it receives new blocks it will index whatever information it needs and perform different tasks.
+
-- contract
+
-- ---> (unabalanced tx) @ wallet
+
-- ---> (balanced tx) @ contract / network
+
-- ---> .. blockchain updates ..
+
-- ---> @node-client (incoming blocks)
+
-- ---> @index
+
-- ---> (confirmed K-blocks after tx that you care about event) @ contract
healthcheck :: Monad m => m NoContent
healthcheck = pure NoContent

                      
  , runSimpleLog
  ) where

                      
-
import           Control.Monad.Freer        (Eff, Member)
-
import qualified Control.Monad.Freer        as Eff
-
import           Control.Monad.IO.Class     (MonadIO)
-
import           Control.Monad.Logger       (MonadLogger, logDebugN, logInfoN, runStdoutLoggingT)
-
import           Data.Text                  (Text)
+
import           Control.Monad.Freer    (Eff, Member)
+
import qualified Control.Monad.Freer    as Eff
+
import           Control.Monad.IO.Class (MonadIO)
+
import           Control.Monad.Logger   (MonadLogger, logDebugN, logInfoN, runStdoutLoggingT)
+
import           Data.Text              (Text)

                      
-- $simpleLog
-- A @[email protected] wrapper around @[email protected]
    ) where

                      
import           Cardano.Wallet.Types   (WalletId)
-
import qualified Data.ByteString.Lazy      as BSL
-
import           Ledger                 (PubKey, Value,Signature)
+
import qualified Data.ByteString.Lazy   as BSL
+
import           Ledger                 (PubKey, Signature, Value)
import           Servant.API            ((:<|>), (:>), Capture, Get, JSON, Post, ReqBody)
import           Wallet.Emulator.Wallet (Wallet)

                      
import           Control.Monad.IO.Class     (MonadIO, liftIO)
import           Control.Monad.Logger       (LogLevel (LevelDebug), LoggingT, MonadLogger, filterLogger, logInfoN,
                                             runStdoutLoggingT)
-
import           Control.Monad.Reader       (MonadReader, ReaderT (ReaderT),  asks, runReaderT)
+
import           Control.Monad.Reader       (MonadReader, ReaderT (ReaderT), asks, runReaderT)
import           Data.Aeson                 (FromJSON, ToJSON, eitherDecode)
import qualified Data.Aeson.Encode.Pretty   as JSON
import qualified Data.ByteString.Lazy.Char8 as BSL8
instance WalletAPI App where
    ownPubKey = runWalletClientM WalletClient.getOwnPubKey
    sign bs = runWalletClientM $ WalletClient.sign bs
-
    updatePaymentWithChange value payment = undefined
+
    updatePaymentWithChange _ _ = undefined
    watchedAddresses = pure mempty
-
    startWatching address = pure ()
+
    startWatching _ = pure ()

                      
runAppClientM ::
       (Env -> ClientEnv) -> (ServantError -> SCBError) -> ClientM a -> App a
    contract <- liftError $ lookupContract filePath
    activeContractId <- liftIO uuidNextRandom
    logInfoN "Initializing Contract"
-
    response <- liftError $ invokeContract $ InitContract (contractPath contract)
+
    response <-
+
        liftError $ invokeContract $ InitContract (contractPath contract)
    let activeContractState =
            ActiveContractState
                { activeContract =
    logInfoN "Finding Contract"
    oldContractState <- liftError $ lookupActiveContractState uuid
    logInfoN "Updating Contract"
-
    response <-
-
        updateContract_ oldContractState endpointName endpointPayload
+
    response <- updateContract_ oldContractState endpointName endpointPayload
    case JSON.parseEither parseUnbalancedTxKey (hooks response) of
        Left err -> throwError $ ContractCommandError 0 $ Text.pack err
        Right unbalancedTxs -> do
                balancedTxs
                      --
            logInfoN $ "Submitting balanced TXs" <> tshow unbalancedTxs
-
            balanceResults :: [Ledger.TxId] <-
-
                traverse submitTxn balancedTxs
+
            balanceResults :: [Ledger.TxId] <- traverse submitTxn balancedTxs
                      --
            traverse_
-
                (runAggregateCommand
-
                     saveBalancedTxResult
-
                     nodeEventSource)
+
                (runAggregateCommand saveBalancedTxResult nodeEventSource)
                balanceResults
                      --
            let updatedContractState =
-
                    oldContractState
-
                        {partiallyDecodedResponse = response}
+
                    oldContractState {partiallyDecodedResponse = response}
            logInfoN "Storing Updated Contract State"
            void $
                runAggregateCommand
                    saveContractState
                    contractEventSource
                    updatedContractState
-
            logInfoN . render $
-
                "Updated:" <+> pretty updatedContractState
+
            logInfoN . render $ "Updated:" <+> pretty updatedContractState
            logInfoN "Done"

                      
-- | A wrapper around the NodeAPI function that returns some more
         WalletDiagnostics (ExceptT WalletAPIError m) where
    logMsg = lift . WAPI.logMsg

                      
-
instance (WalletAPI m, Monad m) => WalletAPI (ExceptT WalletAPIError m) where
+
instance (Monad m, NodeAPI m) => NodeAPI (ExceptT WalletAPIError m) where
+
    submitTxn = lift . WAPI.submitTxn
+
    slot = lift WAPI.slot
+

                      
+
instance WalletAPI m => WalletAPI (ExceptT WalletAPIError m) where
    ownPubKey = lift WAPI.ownPubKey
    sign = lift . WAPI.sign
    updatePaymentWithChange value inputs =
    runScenario action = do
      result <- runExceptT $ runStderrLoggingT $ evalStateT action emptyEventMap
      case result of
-
        Left err -> error $ show err
+
        Left err    -> error $ show err
        Right value -> pure value

                      
runCommandQueryChain ::
----
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE TemplateHaskell     #-}
+
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE DerivingStrategies  #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE ScopedTypeVariables #-} -- <.>
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveGeneric       #-}
+
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
-
{-# LANGUAGE TemplateHaskell     #-}
{-# LANGUAGE TupleSections       #-}
-
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeFamilies        #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}
instance FromJSON WalletAPIError
instance ToJSON WalletAPIError

                      
-
type MonadWallet m = (WalletAPI m, WalletDiagnostics m, MonadError WalletAPIError m)
+
type MonadWallet m = (WalletAPI m, WalletDiagnostics m, MonadError WalletAPIError m, NodeAPI m)

                      
-- | The ability to log messages and throw errors.
class Monad m => WalletDiagnostics m where
--
--   NOTE: In the future this won't be part of WalletAPI to allow the
--   signing to be handled by a different process
-
signTxn   :: (WalletAPI m, Monad m) => Tx -> m Tx
+
signTxn   :: WalletAPI m => Tx -> m Tx
signTxn tx = do
    pubK <- ownPubKey
    sig <- sign (getTxId $ txId tx)
    pure $ tx & signatures . at pubK ?~ sig

                      
-- | Transfer some funds to a number of script addresses, returning the
-- transaction that was submitted.
-
payToScripts :: (Monad m, WalletAPI m, NodeAPI m) => SlotRange -> [(Address, Value, DataValue)] -> m Tx
+
payToScripts :: (WalletAPI m, NodeAPI m) => SlotRange -> [(Address, Value, DataValue)] -> m Tx
payToScripts range ins = do
    let
        totalVal     = fold $ fmap (view _2) ins

                      
-- | Transfer some funds to an address locked by a script, returning the
--   transaction that was submitted.
-
payToScript :: (Monad m, WalletAPI m, NodeAPI m) => SlotRange -> Address -> Value -> DataValue -> m Tx
+
payToScript :: (WalletAPI m, NodeAPI m) => SlotRange -> Address -> Value -> DataValue -> m Tx
payToScript range addr v ds = payToScripts range [(addr, v, ds)]

                      
-- | Transfer some funds to an address locked by a script.
            Map.toList ourUtxo
    in inputs

                      
-
spendScriptOutputs :: (Monad m, WalletAPI m) => Validator -> RedeemerValue -> m [(TxIn, Value)]
+
spendScriptOutputs :: WalletAPI m => Validator -> RedeemerValue -> m [(TxIn, Value)]
spendScriptOutputs = spendScriptOutputsFilter (\_ _ -> True)

                      
-- | Take all known outputs at an 'Address' and spend them using the
--   validator and redeemer scripts.
-
spendScriptOutputsFilter :: (Monad m, WalletAPI m)
+
spendScriptOutputsFilter :: WalletAPI m
    => (TxOutRef -> TxOutTx -> Bool)
    -> Validator
    -> RedeemerValue

                      
-- | Transfer some funds to an address locked by a public key, returning the
--   transaction that was submitted.
-
payToPublicKey :: (Monad m, WalletAPI m, NodeAPI m) => SlotRange -> Value -> PubKey -> m Tx
+
payToPublicKey :: (WalletAPI m, NodeAPI m) => SlotRange -> Value -> PubKey -> m Tx
payToPublicKey range v pk = do
    (i, own) <- createPaymentWithChange v
    let other = pubKeyTxOut v pk
    createTxAndSubmit range i (other : maybeToList own) []

                      
-- | Transfer some funds to an address locked by a public key.
-
payToPublicKey_ :: (Monad m, WalletAPI m, NodeAPI m) => SlotRange -> Value -> PubKey -> m ()
+
payToPublicKey_ :: (WalletAPI m, NodeAPI m) => SlotRange -> Value -> PubKey -> m ()
payToPublicKey_ r v = void . payToPublicKey r v

                      
-- | Create a `TxOut` that pays to the public key owned by us.
-
ownPubKeyTxOut :: (Monad m, WalletAPI m) => Value -> m TxOut
+
ownPubKeyTxOut :: WalletAPI m => Value -> m TxOut
ownPubKeyTxOut v = pubKeyTxOut v <$> ownPubKey

                      
-- | Retrieve the unspent transaction outputs known to the wallet at an adresss.
-
outputsAt :: (Functor m, WalletAPI m) => Address -> m (Map.Map Ledger.TxOutRef TxOutTx)
+
outputsAt :: WalletAPI m => Address -> m (Map.Map Ledger.TxOutRef TxOutTx)
outputsAt adr = fmap (\utxos -> fromMaybe Map.empty $ utxos ^. at adr) watchedAddresses

                      
-- | Create a transaction, sign it with the wallet's private key, and submit it.
--   TODO: This is here to make the calculation of fees easier for old-style contracts
--         and should be removed when all contracts have been ported to the new API.
createTxAndSubmit ::
-
    (Monad m, WalletAPI m, NodeAPI m)
+
    (WalletAPI m, NodeAPI m)
    => SlotRange
    -> Set.Set TxIn
    -> [TxOut]

                      
-- | Add the wallet's signature to the transaction and submit it. Returns
--   the transaction with the wallet's signature.
-
signTxAndSubmit :: (Monad m, WalletAPI m, NodeAPI m) => Tx -> m Tx
+
signTxAndSubmit :: (WalletAPI m, NodeAPI m) => Tx -> m Tx
signTxAndSubmit t = do
    tx' <- signTxn t
    submitTxn tx'
    pure tx'

                      
-- | A version of 'signTxAndSubmit' that discards the result.
-
signTxAndSubmit_ :: (Monad m, WalletAPI m, NodeAPI m) => Tx -> m ()
+
signTxAndSubmit_ :: (WalletAPI m, NodeAPI m) => Tx -> m ()
signTxAndSubmit_ = void . signTxAndSubmit

                      
-- | The default slot validity range for transactions.

                      
mkInitialise
    :: forall s i m
-
    . (WAPI.WalletAPI m, MonadError WAPI.WalletAPIError m, WAPI.WalletDiagnostics m, PlutusTx.IsData s)
+
    . (WAPI.WalletAPI m, MonadError WAPI.WalletAPIError m, PlutusTx.IsData s)
    => SM.StateMachineInstance s i
    -- ^ Signatories and required signatures
    -> s
--
mkStep
    :: forall s i m
-
    . (WAPI.WalletAPI m, MonadError WAPI.WalletAPIError m, WAPI.WalletDiagnostics m, PlutusTx.IsData s, PlutusTx.IsData i)
+
    . (WAPI.WalletAPI m, MonadError WAPI.WalletAPIError m, PlutusTx.IsData s, PlutusTx.IsData i)
    => SM.StateMachineInstance s i
    -- ^ The parameters of the contract instance
    -> s
--
mkHalt
    :: forall s i m
-
    . (Show s, MonadError WAPI.WalletAPIError m, WAPI.WalletAPI m, WAPI.WalletDiagnostics m, PlutusTx.IsData s, PlutusTx.IsData i)
+
    . (Show s, MonadError WAPI.WalletAPIError m, WAPI.WalletAPI m, PlutusTx.IsData s, PlutusTx.IsData i)
    => SM.StateMachineInstance s i
    -- ^ The parameters of the contract instance
    -> s