From 84e92d3f54f0856fddf536acfdf9fa5683343e68 Mon Sep 17 00:00:00 2001 From: Jamie Bertram Date: Mon, 17 Jan 2022 12:44:57 -0500 Subject: [PATCH] Remove explicit DTO layer --- .../generated/Marlowe.purs | 6 +- .../generated/Marlowe/Run/Dto.purs | 127 ------------------ .../Run/Wallet/{V1/API.purs => V1.purs} | 12 +- .../src/API/Marlowe/Run/Wallet.purs | 23 ---- marlowe-dashboard-client/src/AppM.purs | 4 +- .../src/Capability/Wallet.purs | 21 +-- .../src/Page/Dashboard/State.purs | 7 +- marlowe-dashboard-server/app/PSGenerator.hs | 20 ++- .../marlowe-dashboard-server.cabal | 1 - .../src/Marlowe/Run/Dto.hs | 91 ------------- .../src/Marlowe/Run/Wallet/V1.hs | 7 +- .../src/Marlowe/Run/Wallet/V1/API.hs | 30 ++--- .../src/Marlowe/Run/Wallet/V1/Server.hs | 18 ++- 13 files changed, 57 insertions(+), 310 deletions(-) delete mode 100644 marlowe-dashboard-client/generated/Marlowe/Run/Dto.purs rename marlowe-dashboard-client/generated/Marlowe/Run/Wallet/{V1/API.purs => V1.purs} (87%) delete mode 100644 marlowe-dashboard-client/src/API/Marlowe/Run/Wallet.purs delete mode 100644 marlowe-dashboard-server/src/Marlowe/Run/Dto.hs diff --git a/marlowe-dashboard-client/generated/Marlowe.purs b/marlowe-dashboard-client/generated/Marlowe.purs index 57dae8412c..68653cfc4b 100644 --- a/marlowe-dashboard-client/generated/Marlowe.purs +++ b/marlowe-dashboard-client/generated/Marlowe.purs @@ -8,6 +8,7 @@ import Affjax.RequestBody (json) as Request import Affjax.RequestHeader (RequestHeader(..)) import Affjax.ResponseFormat (json) as Response import Cardano.Wallet.Mock.Types (WalletInfo) +import Component.Contacts.Types (WalletId) import Control.Monad.Error.Class (class MonadError, throwError) import Control.Monad.Reader.Class (class MonadAsk, asks) import Data.Argonaut.Decode (decodeJson) @@ -23,8 +24,7 @@ import Data.Maybe (Maybe(..)) import Data.Newtype (unwrap) import Data.String (joinWith) import Effect.Aff.Class (class MonadAff, liftAff) -import Marlowe.Run.Dto (WalletIdDto) -import Marlowe.Run.Wallet.V1.API (GetTotalFundsResponse) +import Marlowe.Run.Wallet.V1 (GetTotalFundsResponse) import Marlowe.Run.Wallet.V1.CentralizedTestnet.Types ( CheckPostData , RestoreError @@ -107,7 +107,7 @@ getApiWalletV1ByWalletidTotalfunds => MonadAsk env m => MonadError AjaxError m => MonadAff m - => WalletIdDto + => WalletId -> m GetTotalFundsResponse getApiWalletV1ByWalletidTotalfunds wallet_id = do spSettings <- asks spSettings diff --git a/marlowe-dashboard-client/generated/Marlowe/Run/Dto.purs b/marlowe-dashboard-client/generated/Marlowe/Run/Dto.purs deleted file mode 100644 index 0f3c994041..0000000000 --- a/marlowe-dashboard-client/generated/Marlowe/Run/Dto.purs +++ /dev/null @@ -1,127 +0,0 @@ --- File auto generated by purescript-bridge! -- -module Marlowe.Run.Dto where - -import Prelude - -import Control.Lazy (defer) -import Data.Argonaut.Core (jsonNull) -import Data.Argonaut.Decode (class DecodeJson) -import Data.Argonaut.Decode.Aeson ((), (), ()) -import Data.Argonaut.Decode.Aeson as D -import Data.Argonaut.Encode (class EncodeJson, encodeJson) -import Data.Argonaut.Encode.Aeson ((>$<), (>/\<)) -import Data.Argonaut.Encode.Aeson as E -import Data.BigInt.Argonaut (BigInt) -import Data.Generic.Rep (class Generic) -import Data.Lens (Iso', Lens', Prism', iso, prism') -import Data.Lens.Iso.Newtype (_Newtype) -import Data.Lens.Record (prop) -import Data.Map (Map) -import Data.Map as Map -import Data.Maybe (Maybe(..)) -import Data.Newtype (class Newtype, unwrap) -import Data.Show.Generic (genericShow) -import Data.Tuple.Nested ((/\)) -import Type.Proxy (Proxy(Proxy)) - -newtype AssetsDto = AssetsDto (Map CurrencySymbolDto (Map TokenNameDto BigInt)) - -derive instance eqAssetsDto :: Eq AssetsDto - -instance showAssetsDto :: Show AssetsDto where - show a = genericShow a - -instance encodeJsonAssetsDto :: EncodeJson AssetsDto where - encodeJson = defer \_ -> E.encode $ unwrap >$< - (E.dictionary E.value (E.dictionary E.value E.value)) - -instance decodeJsonAssetsDto :: DecodeJson AssetsDto where - decodeJson = defer \_ -> D.decode $ - (AssetsDto <$> (D.dictionary D.value (D.dictionary D.value D.value))) - -derive instance genericAssetsDto :: Generic AssetsDto _ - -derive instance newtypeAssetsDto :: Newtype AssetsDto _ - --------------------------------------------------------------------------------- - -_AssetsDto :: Iso' AssetsDto (Map CurrencySymbolDto (Map TokenNameDto BigInt)) -_AssetsDto = _Newtype - --------------------------------------------------------------------------------- - -newtype CurrencySymbolDto = CurrencySymbolDto String - -derive instance eqCurrencySymbolDto :: Eq CurrencySymbolDto - -instance showCurrencySymbolDto :: Show CurrencySymbolDto where - show a = genericShow a - -instance encodeJsonCurrencySymbolDto :: EncodeJson CurrencySymbolDto where - encodeJson = defer \_ -> E.encode $ unwrap >$< E.value - -instance decodeJsonCurrencySymbolDto :: DecodeJson CurrencySymbolDto where - decodeJson = defer \_ -> D.decode $ (CurrencySymbolDto <$> D.value) - -derive instance ordCurrencySymbolDto :: Ord CurrencySymbolDto - -derive instance genericCurrencySymbolDto :: Generic CurrencySymbolDto _ - -derive instance newtypeCurrencySymbolDto :: Newtype CurrencySymbolDto _ - --------------------------------------------------------------------------------- - -_CurrencySymbolDto :: Iso' CurrencySymbolDto String -_CurrencySymbolDto = _Newtype - --------------------------------------------------------------------------------- - -newtype TokenNameDto = TokenNameDto String - -derive instance eqTokenNameDto :: Eq TokenNameDto - -instance showTokenNameDto :: Show TokenNameDto where - show a = genericShow a - -instance encodeJsonTokenNameDto :: EncodeJson TokenNameDto where - encodeJson = defer \_ -> E.encode $ unwrap >$< E.value - -instance decodeJsonTokenNameDto :: DecodeJson TokenNameDto where - decodeJson = defer \_ -> D.decode $ (TokenNameDto <$> D.value) - -derive instance ordTokenNameDto :: Ord TokenNameDto - -derive instance genericTokenNameDto :: Generic TokenNameDto _ - -derive instance newtypeTokenNameDto :: Newtype TokenNameDto _ - --------------------------------------------------------------------------------- - -_TokenNameDto :: Iso' TokenNameDto String -_TokenNameDto = _Newtype - --------------------------------------------------------------------------------- - -newtype WalletIdDto = WalletIdDto String - -derive instance eqWalletIdDto :: Eq WalletIdDto - -instance showWalletIdDto :: Show WalletIdDto where - show a = genericShow a - -instance encodeJsonWalletIdDto :: EncodeJson WalletIdDto where - encodeJson = defer \_ -> E.encode $ unwrap >$< E.value - -instance decodeJsonWalletIdDto :: DecodeJson WalletIdDto where - decodeJson = defer \_ -> D.decode $ (WalletIdDto <$> D.value) - -derive instance ordWalletIdDto :: Ord WalletIdDto - -derive instance genericWalletIdDto :: Generic WalletIdDto _ - -derive instance newtypeWalletIdDto :: Newtype WalletIdDto _ - --------------------------------------------------------------------------------- - -_WalletIdDto :: Iso' WalletIdDto String -_WalletIdDto = _Newtype \ No newline at end of file diff --git a/marlowe-dashboard-client/generated/Marlowe/Run/Wallet/V1/API.purs b/marlowe-dashboard-client/generated/Marlowe/Run/Wallet/V1.purs similarity index 87% rename from marlowe-dashboard-client/generated/Marlowe/Run/Wallet/V1/API.purs rename to marlowe-dashboard-client/generated/Marlowe/Run/Wallet/V1.purs index b588e1f757..e77464bc2d 100644 --- a/marlowe-dashboard-client/generated/Marlowe/Run/Wallet/V1/API.purs +++ b/marlowe-dashboard-client/generated/Marlowe/Run/Wallet/V1.purs @@ -1,5 +1,5 @@ -- File auto generated by purescript-bridge! -- -module Marlowe.Run.Wallet.V1.API where +module Marlowe.Run.Wallet.V1 where import Prelude @@ -20,11 +20,11 @@ import Data.Maybe (Maybe(..)) import Data.Newtype (class Newtype, unwrap) import Data.Show.Generic (genericShow) import Data.Tuple.Nested ((/\)) -import Marlowe.Run.Dto (AssetsDto) +import Plutus.V1.Ledger.Value (Value) import Type.Proxy (Proxy(Proxy)) newtype GetTotalFundsResponse = GetTotalFundsResponse - { assets :: AssetsDto + { assets :: Value , sync :: Number } @@ -36,7 +36,7 @@ instance showGetTotalFundsResponse :: Show GetTotalFundsResponse where instance encodeJsonGetTotalFundsResponse :: EncodeJson GetTotalFundsResponse where encodeJson = defer \_ -> E.encode $ unwrap >$< ( E.record - { assets: E.value :: _ AssetsDto + { assets: E.value :: _ Value , sync: E.value :: _ Number } ) @@ -44,7 +44,7 @@ instance encodeJsonGetTotalFundsResponse :: EncodeJson GetTotalFundsResponse whe instance decodeJsonGetTotalFundsResponse :: DecodeJson GetTotalFundsResponse where decodeJson = defer \_ -> D.decode $ ( GetTotalFundsResponse <$> D.record "GetTotalFundsResponse" - { assets: D.value :: _ AssetsDto + { assets: D.value :: _ Value , sync: D.value :: _ Number } ) @@ -56,5 +56,5 @@ derive instance newtypeGetTotalFundsResponse :: Newtype GetTotalFundsResponse _ -------------------------------------------------------------------------------- _GetTotalFundsResponse :: Iso' GetTotalFundsResponse - { assets :: AssetsDto, sync :: Number } + { assets :: Value, sync :: Number } _GetTotalFundsResponse = _Newtype \ No newline at end of file diff --git a/marlowe-dashboard-client/src/API/Marlowe/Run/Wallet.purs b/marlowe-dashboard-client/src/API/Marlowe/Run/Wallet.purs deleted file mode 100644 index ec0f7d9cde..0000000000 --- a/marlowe-dashboard-client/src/API/Marlowe/Run/Wallet.purs +++ /dev/null @@ -1,23 +0,0 @@ -module API.Marlowe.Run.Wallet - ( getTotalFunds - ) where - -import Prologue - -import API.Request (doGetRequest) -import Component.Contacts.Types (WalletId) -import Control.Monad.Error.Class (class MonadError) -import Data.Newtype (unwrap) -import Effect.Aff.Class (class MonadAff) -import Marlowe.Run.Dto (WalletIdDto) -import Marlowe.Run.Wallet.V1.API (GetTotalFundsResponse) -import Servant.PureScript (AjaxError) - -getTotalFunds - :: forall m - . MonadAff m - => MonadError AjaxError m - => WalletIdDto - -> m GetTotalFundsResponse -getTotalFunds wallet = - doGetRequest $ "/api/wallet/v1/" <> unwrap wallet <> "/total-funds" diff --git a/marlowe-dashboard-client/src/AppM.purs b/marlowe-dashboard-client/src/AppM.purs index bb74cf2e3c..3acc8698c8 100644 --- a/marlowe-dashboard-client/src/AppM.purs +++ b/marlowe-dashboard-client/src/AppM.purs @@ -26,7 +26,7 @@ import Halogen.Store.Monad , runStoreT , updateStore ) -import Marlowe (postApiWalletCentralizedtestnetCheckmnemonic) +import Marlowe (postApiWalletV1CentralizedtestnetCheckmnemonic) import Marlowe.Run.Wallet.V1.CentralizedTestnet.Types (CheckPostData(..)) import Store as Store @@ -71,7 +71,7 @@ instance checkMnemonicAppM :: CheckMnemonic AppM where checkMnemonic = map (either (const false) identity) <<< runExceptT - <<< postApiWalletCentralizedtestnetCheckmnemonic + <<< postApiWalletV1CentralizedtestnetCheckmnemonic <<< CheckPostData <<< map wordToString <<< toWords diff --git a/marlowe-dashboard-client/src/Capability/Wallet.purs b/marlowe-dashboard-client/src/Capability/Wallet.purs index 3fcce95e12..ebc4ca3e9a 100644 --- a/marlowe-dashboard-client/src/Capability/Wallet.purs +++ b/marlowe-dashboard-client/src/Capability/Wallet.purs @@ -1,6 +1,5 @@ module Capability.Wallet ( class ManageWallet - , GetTotalFundsResponse , createWallet , restoreWallet , submitWalletTransaction @@ -11,7 +10,6 @@ module Capability.Wallet import Prologue -import API.Marlowe.Run.Wallet as WBE import API.Marlowe.Run.Wallet.CentralizedTestnet ( RestoreError , RestoreWalletOptions @@ -23,23 +21,13 @@ import Bridge (toBack, toFront) import Component.Contacts.Types (WalletId, WalletInfo) import Control.Monad.Except (lift, runExceptT) import Halogen (HalogenM) -import Marlowe.Run.Wallet.V1.API as BE +import Marlowe as WBE +import Marlowe.Run.Wallet.V1 (GetTotalFundsResponse(..)) import Marlowe.Semantics (Assets) import Plutus.V1.Ledger.Tx (Tx) import Types (AjaxResponse) import Unsafe.Coerce (unsafeCoerce) -type GetTotalFundsResponse = - { assets :: Assets - , sync :: Number - } - --- TODO create a Dto module to replace Bridge (but where decoding can fail). --- This will mirror backend architecture. -getTotalFundsResponseFromDto - :: BE.GetTotalFundsResponse -> GetTotalFundsResponse -getTotalFundsResponseFromDto = unsafeCoerce - -- FIXME: Abstract away AjaxResponse (just return an `m ResponseType` and -- handle API failures in the concrete Monad instance). class Monad m <= ManageWallet m where @@ -57,10 +45,7 @@ instance monadWalletAppM :: ManageWallet AppM where MockAPI.submitWalletTransaction (toBack wallet) tx getWalletInfo wallet = map (map toFront) $ runExceptT $ MockAPI.getWalletInfo (toBack wallet) - getWalletTotalFunds walletId = runExceptT - $ map getTotalFundsResponseFromDto - $ WBE.getTotalFunds - $ unsafeCoerce walletId -- TODO create DTO module like backend + getWalletTotalFunds = runExceptT <<< WBE.getApiWalletV1ByWalletidTotalfunds signTransaction wallet tx = runExceptT $ MockAPI.signTransaction (toBack wallet) tx diff --git a/marlowe-dashboard-client/src/Page/Dashboard/State.purs b/marlowe-dashboard-client/src/Page/Dashboard/State.purs index 5c8231d53c..f2b8322099 100644 --- a/marlowe-dashboard-client/src/Page/Dashboard/State.purs +++ b/marlowe-dashboard-client/src/Page/Dashboard/State.purs @@ -5,6 +5,7 @@ module Page.Dashboard.State import Prologue +import Bridge (toFront) import Capability.Contract (class ManageContract) import Capability.MainFrameLoop (class MainFrameLoop, callMainFrameAction) import Capability.Marlowe @@ -97,6 +98,7 @@ import Marlowe.Deinstantiate (findTemplate) import Marlowe.Execution.State (getAllPayments) import Marlowe.Extended.Metadata (_metaData) import Marlowe.PAB (PlutusAppId, transactionFee) +import Marlowe.Run.Wallet.V1 (GetTotalFundsResponse(..)) import Marlowe.Semantics ( MarloweData , MarloweParams @@ -565,9 +567,10 @@ updateTotalFunds updateTotalFunds = do walletId <- use (_walletDetails <<< _walletInfo <<< _walletId) response <- getWalletTotalFunds walletId - for_ response \({ assets }) -> + for_ response \(GetTotalFundsResponse { assets }) -> modify_ - $ set (_walletDetails <<< _assets) assets + $ set (_walletDetails <<< _assets) + $ toFront assets toContacts :: forall m msg slots diff --git a/marlowe-dashboard-server/app/PSGenerator.hs b/marlowe-dashboard-server/app/PSGenerator.hs index 8f2200f4e0..c6cec44b55 100644 --- a/marlowe-dashboard-server/app/PSGenerator.hs +++ b/marlowe-dashboard-server/app/PSGenerator.hs @@ -19,12 +19,11 @@ import Data.Monoid () import Data.Proxy (Proxy (Proxy)) import qualified Data.Text.Encoding as T () import qualified Data.Text.IO as T () -import Language.PureScript.Bridge (BridgePart, Language (Haskell), SumType, argonaut, buildBridge, typeName, - writePSTypes, (^==)) +import Language.PureScript.Bridge (BridgePart, Language (Haskell, PureScript), SumType, TypeInfo (..), argonaut, + buildBridge, typeName, writePSTypes, (^==)) import Language.PureScript.Bridge.PSTypes (psNumber, psString) import Language.PureScript.Bridge.SumType (equal, genericShow, mkSumType, order) import Marlowe.Run.API (HTTPAPI) -import Marlowe.Run.Dto import Marlowe.Run.Wallet.V1.API (GetTotalFundsResponse) import Marlowe.Run.Wallet.V1.CentralizedTestnet.Types (CheckPostData, RestoreError, RestorePostData) import Marlowe.Run.WebSocket (StreamToClient, StreamToServer) @@ -37,6 +36,12 @@ doubleBridge = typeName ^== "Double" >> return psNumber dayBridge :: BridgePart dayBridge = typeName ^== "Day" >> return psString +psWalletId :: TypeInfo 'PureScript +psWalletId = TypeInfo "marlowe-dashboard-client" "Component.Contacts.Types" "WalletId" [] + +walletIdBridge :: BridgePart +walletIdBridge = typeName ^== "HttpWalletId" >> return psWalletId + myBridge :: BridgePart myBridge = PSGenerator.Common.aesonBridge <|> PSGenerator.Common.containersBridge @@ -47,6 +52,7 @@ myBridge = <|> doubleBridge <|> dayBridge <|> defaultBridge + <|> walletIdBridge data MyBridge @@ -59,10 +65,6 @@ instance HasBridge MyBridge where dto :: SumType 'Haskell -> SumType 'Haskell dto = equal . genericShow . argonaut --- FIXME: remove all of this shared stuff from plutus-apps. We should only be --- exporting API types to PureScript, and those should all be defined --- internally in this project. With a multi-repo setup, there is far too much --- potential for breakage with updates. myTypes :: [SumType 'Haskell] myTypes = PSGenerator.Common.ledgerTypes <> @@ -74,10 +76,6 @@ myTypes = mkSumType @RestorePostData, mkSumType @CheckPostData, mkSumType @GetTotalFundsResponse, - mkSumType @AssetsDto, - order $ mkSumType @CurrencySymbolDto, - order $ mkSumType @TokenNameDto, - order $ mkSumType @WalletIdDto, order $ mkSumType @RestoreError ] ) diff --git a/marlowe-dashboard-server/marlowe-dashboard-server.cabal b/marlowe-dashboard-server/marlowe-dashboard-server.cabal index f110418089..6cf5bc638d 100644 --- a/marlowe-dashboard-server/marlowe-dashboard-server.cabal +++ b/marlowe-dashboard-server/marlowe-dashboard-server.cabal @@ -19,7 +19,6 @@ library default-extensions: NoImplicitPrelude exposed-modules: Marlowe.Run.API - Marlowe.Run.Dto Marlowe.Run.Server Marlowe.Run.Wallet.V1.API Marlowe.Run.Wallet.V1.CentralizedTestnet.Types diff --git a/marlowe-dashboard-server/src/Marlowe/Run/Dto.hs b/marlowe-dashboard-server/src/Marlowe/Run/Dto.hs deleted file mode 100644 index d8bc844dc5..0000000000 --- a/marlowe-dashboard-server/src/Marlowe/Run/Dto.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Marlowe.Run.Dto where - -import Cardano.Prelude -import Cardano.Wallet.Primitive.Types (WalletId) -import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) -import qualified Data.Map as M -import Data.Text.Class (FromText (fromText), ToText (toText)) -import Plutus.V1.Ledger.Api (CurrencySymbol (..), TokenName (..), Value (..)) -import qualified PlutusTx.AssocMap as AM -import PlutusTx.Prelude (BuiltinByteString, fromBuiltin, toBuiltin) -import qualified PlutusTx.Prelude as BI -import Servant (FromHttpApiData, ToHttpApiData) -import Servant.Server (ServerError, err400) - -class ToDto a dto where - toDto :: a -> dto - -class FromDto a dto where - fromDto :: dto -> Maybe a - -instance ToDto Integer Integer where - toDto = identity - -instance FromDto Integer Integer where - fromDto = Just - -instance {-# OVERLAPPING #-} FromText a => FromDto a Text where - fromDto = either (const Nothing) Just . fromText - -instance {-# OVERLAPPING #-} ToText a => ToDto a Text where - toDto = toText - -instance (Ord k', ToJSONKey k', ToJSON v', ToDto k k', ToDto v v') => ToDto (AM.Map k v) (M.Map k' v') where - toDto = M.fromList . fmap (bimap toDto toDto) . AM.toList - -instance {-# OVERLAPPING #-} ToDto BuiltinByteString Text where - toDto = fromBuiltin . BI.decodeUtf8 - -instance {-# OVERLAPPING #-} FromDto BuiltinByteString Text where - fromDto = Just . BI.encodeUtf8 . toBuiltin - -newtype CurrencySymbolDto = CurrencySymbolDto Text - deriving (Show, Eq, Ord, Generic) - deriving anyclass (FromJSON , FromJSONKey, ToJSON, ToJSONKey) - -instance ToDto CurrencySymbol CurrencySymbolDto where - toDto = CurrencySymbolDto . toDto . unCurrencySymbol - -instance FromDto CurrencySymbol CurrencySymbolDto where - fromDto (CurrencySymbolDto t) = CurrencySymbol <$> fromDto t - -newtype TokenNameDto = TokenNameDto Text - deriving (Show, Eq, Ord, Generic) - deriving anyclass (FromJSON , FromJSONKey, ToJSON, ToJSONKey) - -instance ToDto TokenName TokenNameDto where - toDto = TokenNameDto . toDto . unTokenName - -instance FromDto TokenName TokenNameDto where - fromDto (TokenNameDto t) = TokenName <$> fromDto t - -newtype WalletIdDto = WalletIdDto Text - deriving (Show, Eq, Ord, Generic) - deriving newtype (FromHttpApiData, ToHttpApiData, FromJSON , FromJSONKey, ToJSON, ToJSONKey) - -instance ToDto WalletId WalletIdDto where - toDto = WalletIdDto . toDto - -instance FromDto WalletId WalletIdDto where - fromDto (WalletIdDto t) = fromDto t - -newtype AssetsDto = AssetsDto (M.Map CurrencySymbolDto (M.Map TokenNameDto Integer)) - deriving (Show, Eq, Ord, Generic) - deriving anyclass (FromJSON , FromJSONKey, ToJSON, ToJSONKey) - -instance ToDto Value AssetsDto where - toDto = AssetsDto . toDto . getValue - -dtoHandler :: (MonadError ServerError m, FromDto a req, ToDto b res) => (a -> m b) -> req -> m res -dtoHandler f req = case fromDto req of - Nothing -> throwError err400 - Just a -> toDto <$> f a diff --git a/marlowe-dashboard-server/src/Marlowe/Run/Wallet/V1.hs b/marlowe-dashboard-server/src/Marlowe/Run/Wallet/V1.hs index 22deb61728..3c24ea5b83 100644 --- a/marlowe-dashboard-server/src/Marlowe/Run/Wallet/V1.hs +++ b/marlowe-dashboard-server/src/Marlowe/Run/Wallet/V1.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} @@ -17,6 +19,7 @@ import Cardano.Wallet.Primitive.Types.Hash (getHash) import Cardano.Wallet.Primitive.Types.TokenMap (AssetId (..), TokenMap, toFlatList) import Cardano.Wallet.Primitive.Types.TokenPolicy (unTokenName, unTokenPolicyId) import Cardano.Wallet.Primitive.Types.TokenQuantity (TokenQuantity (..)) +import Data.Aeson (ToJSON) import Data.Quantity (getPercentage, getQuantity) import GHC.Natural (naturalToInteger) import qualified Plutus.V1.Ledger.Ada as Ledger @@ -40,7 +43,9 @@ wbeTokenMapToLedgerValue tokenMap = ) (toFlatList tokenMap) -data GetTotalFundsResponse = GetTotalFundsResponse { assets :: !Value , sync :: !Double } +data GetTotalFundsResponse = GetTotalFundsResponse { assets :: !Value, sync :: !Double } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON) getTotalFunds :: Monad m => diff --git a/marlowe-dashboard-server/src/Marlowe/Run/Wallet/V1/API.hs b/marlowe-dashboard-server/src/Marlowe/Run/Wallet/V1/API.hs index 6c57a9ea73..c043046743 100644 --- a/marlowe-dashboard-server/src/Marlowe/Run/Wallet/V1/API.hs +++ b/marlowe-dashboard-server/src/Marlowe/Run/Wallet/V1/API.hs @@ -6,27 +6,27 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeOperators #-} -module Marlowe.Run.Wallet.V1.API where +module Marlowe.Run.Wallet.V1.API + ( HttpWalletId(..) + , API + , GetTotalFundsResponse + ) where import Cardano.Prelude -import Data.Aeson (ToJSON) -import Marlowe.Run.Dto (AssetsDto, ToDto (..), WalletIdDto) -import qualified Marlowe.Run.Wallet.V1 as Domain + +import Cardano.Wallet.Primitive.Types (WalletId) +import qualified Data.Text as T +import Data.Text.Class (FromText (fromText), TextDecodingError (getTextDecodingError)) +import Marlowe.Run.Wallet.V1 (GetTotalFundsResponse) import qualified Marlowe.Run.Wallet.V1.CentralizedTestnet.API as CentralizedTestnet +import Servant (FromHttpApiData (..)) import Servant.API (Capture, Get, JSON, (:<|>), (:>)) -data GetTotalFundsResponse = - GetTotalFundsResponse - { assets :: !AssetsDto - , sync :: !Double - } - deriving stock (Eq, Generic, Show) - deriving anyclass (ToJSON) +newtype HttpWalletId = HttpWalletId WalletId -instance ToDto Domain.GetTotalFundsResponse GetTotalFundsResponse where - toDto Domain.GetTotalFundsResponse{..} = - GetTotalFundsResponse (toDto assets) sync +instance FromHttpApiData HttpWalletId where + parseUrlPiece = bimap (T.pack . getTextDecodingError) HttpWalletId . fromText type API = - (Capture "wallet-id" WalletIdDto :> "total-funds" :> Get '[JSON] GetTotalFundsResponse) + (Capture "wallet-id" HttpWalletId :> "total-funds" :> Get '[JSON] GetTotalFundsResponse) :<|> ("centralized-testnet" :> CentralizedTestnet.API) diff --git a/marlowe-dashboard-server/src/Marlowe/Run/Wallet/V1/Server.hs b/marlowe-dashboard-server/src/Marlowe/Run/Wallet/V1/Server.hs index 93e9f0fddb..49ed20fbf6 100644 --- a/marlowe-dashboard-server/src/Marlowe/Run/Wallet/V1/Server.hs +++ b/marlowe-dashboard-server/src/Marlowe/Run/Wallet/V1/Server.hs @@ -11,9 +11,8 @@ module Marlowe.Run.Wallet.V1.Server where import Cardano.Prelude hiding (Handler) import qualified Cardano.Wallet.Api.Client as WBE.Api import qualified Cardano.Wallet.Api.Types as WBE -import Marlowe.Run.Dto (WalletIdDto, dtoHandler) -import Marlowe.Run.Wallet.V1 (getTotalFunds) -import Marlowe.Run.Wallet.V1.API (API, GetTotalFundsResponse (..)) +import Marlowe.Run.Wallet.V1 (GetTotalFundsResponse, getTotalFunds) +import Marlowe.Run.Wallet.V1.API (API, HttpWalletId (..)) import qualified Marlowe.Run.Wallet.V1.CentralizedTestnet.Server as CentralizedTestnet import Marlowe.Run.Wallet.V1.Client (callWBE) import Servant (ServerError, ServerT, err404, (:<|>) ((:<|>))) @@ -30,12 +29,11 @@ handleGetTotalFunds :: MonadIO m => MonadError ServerError m => MonadReader ClientEnv m => - WalletIdDto -> + HttpWalletId -> m GetTotalFundsResponse -handleGetTotalFunds = - let - getWallet = - either (const $ throwError err404) pure +handleGetTotalFunds (HttpWalletId walletId) = + getTotalFunds + ( either (const $ throwError err404) pure <=< callWBE . WBE.Api.getWallet WBE.Api.walletClient . WBE.ApiT - in - dtoHandler $ getTotalFunds getWallet + ) + walletId