diff --git a/marlowe-dashboard-server/app/PSGenerator.hs b/marlowe-dashboard-server/app/PSGenerator.hs index 7c20d6d26b..cee14dc242 100644 --- a/marlowe-dashboard-server/app/PSGenerator.hs +++ b/marlowe-dashboard-server/app/PSGenerator.hs @@ -78,7 +78,7 @@ myTypes = mkSumType @TokenNameDto, mkSumType @WalletIdDto, mkSumType @AssetsDto, - order . mkSumType @RestoreError + order $ mkSumType @RestoreError ] ) diff --git a/marlowe-dashboard-server/app/Webserver.hs b/marlowe-dashboard-server/app/Webserver.hs index c9f2826862..70c3f0a3db 100644 --- a/marlowe-dashboard-server/app/Webserver.hs +++ b/marlowe-dashboard-server/app/Webserver.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} @@ -6,8 +7,11 @@ module Webserver where import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as Aeson +import Data.Char (toLower) +import Data.List (stripPrefix) import Data.Proxy (Proxy (Proxy)) -import Marlowe.Run (AppConfig (..), WBEConfig (..), initializeServerContext) +import GHC.Generics (Generic) import Marlowe.Run.API (API) import qualified Marlowe.Run.Server as Server import Network.HTTP.Client (defaultManagerSettings, newManager) @@ -16,18 +20,39 @@ import Servant (serve) import Servant.Client (BaseUrl (BaseUrl, baseUrlHost, baseUrlPath, baseUrlPort, baseUrlScheme), Scheme (Http), mkClientEnv) -run :: FilePath -> Settings -> IO () -run configPath settings = do - appConfig <- initializeServerContext configPath - let - wbeHost = _wbeHost . _appWbeConfig $ appConfig - wbePort = _wbePort . _appWbeConfig $ appConfig - staticPath = _appStaticPath appConfig +normalizeFieldLabel :: String -> String -> String +normalizeFieldLabel prefix label = + maybe label lower1 $ stripPrefix ('_' : prefix) label - manager <- liftIO $ newManager defaultManagerSettings +lower1 :: String -> String +lower1 (c:cs) = toLower c : cs +lower1 [] = [] - let baseUrl = BaseUrl{baseUrlScheme=Http,baseUrlHost=wbeHost,baseUrlPort=wbePort,baseUrlPath=""} - clientEnv = mkClientEnv manager baseUrl +data WBEConfig = WBEConfig { _wbeHost :: String, _wbePort :: Int } + deriving (Eq, Generic, Show) + +instance Aeson.FromJSON WBEConfig where + parseJSON = Aeson.genericParseJSON $ Aeson.defaultOptions + { Aeson.fieldLabelModifier = normalizeFieldLabel "wbe" } + +data AppConfig = AppConfig { _appWbeConfig :: WBEConfig, _appStaticPath :: FilePath } + deriving (Eq, Generic, Show) +instance Aeson.FromJSON AppConfig where + parseJSON = Aeson.genericParseJSON $ Aeson.defaultOptions + { Aeson.fieldLabelModifier = normalizeFieldLabel "app" } + +run :: FilePath -> Settings -> IO () +run configPath settings = do + mConfig <- Aeson.decodeFileStrict configPath + appConfig <- case mConfig of + Just config -> pure config + Nothing -> ioError $ userError "Config file has invalid format" + let wbeHost = _wbeHost . _appWbeConfig $ appConfig + let wbePort = _wbePort . _appWbeConfig $ appConfig + let staticPath = _appStaticPath appConfig + let baseUrl = BaseUrl{baseUrlScheme=Http,baseUrlHost=wbeHost,baseUrlPort=wbePort,baseUrlPath=""} let server = Server.handlers + manager <- liftIO $ newManager defaultManagerSettings + let clientEnv = mkClientEnv manager baseUrl Warp.runSettings settings (serve (Proxy @API) (server staticPath clientEnv)) diff --git a/marlowe-dashboard-server/marlowe-dashboard-server.cabal b/marlowe-dashboard-server/marlowe-dashboard-server.cabal index ed67c0e552..3a148123c6 100644 --- a/marlowe-dashboard-server/marlowe-dashboard-server.cabal +++ b/marlowe-dashboard-server/marlowe-dashboard-server.cabal @@ -18,17 +18,16 @@ source-repository head library default-extensions: NoImplicitPrelude exposed-modules: - Marlowe.Run Marlowe.Run.Server Marlowe.Run.API Marlowe.Run.Dto Marlowe.Run.Wallet.API Marlowe.Run.WebSocket - Marlowe.Run.Types Marlowe.Run.Wallet.CentralizedTestnet.Types Marlowe.Run.Wallet.Client other-modules: Paths_marlowe_dashboard_server + Marlowe.Run Marlowe.Run.Wallet Marlowe.Run.Wallet.Server Marlowe.Run.Wallet.CentralizedTestnet.API diff --git a/marlowe-dashboard-server/src/Marlowe/Run/Server.hs b/marlowe-dashboard-server/src/Marlowe/Run/Server.hs index f2ae19d304..e6158194fd 100644 --- a/marlowe-dashboard-server/src/Marlowe/Run/Server.hs +++ b/marlowe-dashboard-server/src/Marlowe/Run/Server.hs @@ -8,12 +8,12 @@ module Marlowe.Run.Server where import Cardano.Prelude hiding (Handler) import Marlowe.Run (getVersion) import Marlowe.Run.API (API) -import Marlowe.Run.Types (Env) import qualified Marlowe.Run.Wallet.Server as Wallet import qualified Marlowe.Run.WebSocket as WS import Servant (Handler (Handler), Server, ServerError, hoistServer, serveDirectoryFileServer, (:<|>) ((:<|>))) +import Servant.Client (ClientEnv) -handlers :: FilePath -> Env -> Server API +handlers :: FilePath -> ClientEnv -> Server API handlers staticPath env = hoistServer (Proxy @API) liftHandler ( WS.handle @@ -23,5 +23,5 @@ handlers staticPath env = :<|> serveDirectoryFileServer staticPath ) where - liftHandler :: ReaderT Env (ExceptT ServerError IO) a -> Handler a + liftHandler :: ReaderT ClientEnv (ExceptT ServerError IO) a -> Handler a liftHandler = Handler . flip runReaderT env diff --git a/marlowe-dashboard-server/src/Marlowe/Run/Types.hs b/marlowe-dashboard-server/src/Marlowe/Run/Types.hs deleted file mode 100644 index b21fec1984..0000000000 --- a/marlowe-dashboard-server/src/Marlowe/Run/Types.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DerivingVia #-} - -module Marlowe.Run.Types where - -import Cardano.Prelude -import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) -import qualified Data.Map as M -import Plutus.V1.Ledger.Api (CurrencySymbol (unCurrencySymbol), TokenName (unTokenName), Value (..)) -import qualified PlutusTx.AssocMap as AM -import qualified PlutusTx.Builtins as BI -import PlutusTx.Prelude (fromBuiltin) -import Servant.Client (ClientEnv) - -type Env = ClientEnv - -newtype CurrencySymbolDto = CurrencySymbolDto Text - deriving (Show, Eq, Ord, Generic) - deriving anyclass (FromJSON , FromJSONKey, ToJSON, ToJSONKey) - -newtype TokenNameDto = TokenNameDto Text - deriving (Show, Eq, Ord, Generic) - deriving anyclass (FromJSON , FromJSONKey, ToJSON, ToJSONKey) - -type ValueDto = M.Map CurrencySymbolDto (M.Map TokenNameDto Integer) - -assocMapToDto :: Ord k' => (k -> k') -> (v -> v') -> AM.Map k v -> M.Map k' v' -assocMapToDto f g = M.fromList . fmap (bimap f g) . AM.toList - -valueToDto :: Value -> ValueDto -valueToDto = assocMapToDto currencySymbolToDto (assocMapToDto tokenNameToDto identity) . getValue - -currencySymbolToDto :: CurrencySymbol -> CurrencySymbolDto -currencySymbolToDto = CurrencySymbolDto . fromBuiltin . BI.decodeUtf8 . unCurrencySymbol - -tokenNameToDto :: TokenName -> TokenNameDto -tokenNameToDto = TokenNameDto . fromBuiltin . BI.decodeUtf8 . unTokenName diff --git a/marlowe-dashboard-server/src/Marlowe/Run/Wallet/CentralizedTestnet/Server.hs b/marlowe-dashboard-server/src/Marlowe/Run/Wallet/CentralizedTestnet/Server.hs index 742d1d6d03..d1b19a54a8 100644 --- a/marlowe-dashboard-server/src/Marlowe/Run/Wallet/CentralizedTestnet/Server.hs +++ b/marlowe-dashboard-server/src/Marlowe/Run/Wallet/CentralizedTestnet/Server.hs @@ -12,36 +12,31 @@ module Marlowe.Run.Wallet.CentralizedTestnet.Server import Cardano.Mnemonic (mkSomeMnemonic) import Cardano.Prelude hiding (Handler) +import Cardano.Wallet.Api (WalletKeys) import qualified Cardano.Wallet.Api.Client as WBE.Api import Cardano.Wallet.Api.Types (ApiVerificationKeyShelley (..)) import qualified Cardano.Wallet.Api.Types as WBE -import Marlowe.Run.Wallet.CentralizedTestnet.API (API) - -import Cardano.Wallet.Api (WalletKeys) import Cardano.Wallet.Mock.Types (WalletInfo (..)) +import Cardano.Wallet.Primitive.AddressDerivation (Passphrase (Passphrase)) import qualified Cardano.Wallet.Primitive.AddressDerivation as WBE import qualified Cardano.Wallet.Primitive.Types as WBE - - -import Cardano.Wallet.Primitive.AddressDerivation (Passphrase (Passphrase)) - import Data.String as S import qualified Data.Text as Text import Data.Text.Class (FromText (..)) import Ledger (PaymentPubKeyHash (..), PubKeyHash (..)) -import Marlowe.Run.Types (Env) +import Marlowe.Run.Wallet.CentralizedTestnet.API (API) import Marlowe.Run.Wallet.CentralizedTestnet.Types (CheckPostData (..), RestoreError (..), RestorePostData (..)) import Marlowe.Run.Wallet.Client (callWBE, decodeError) import PlutusTx.Builtins.Internal (BuiltinByteString (..)) import Servant (ServerT, (:<|>) ((:<|>)), (:>)) -import Servant.Client (ClientError (FailureResponse), ClientM, ResponseF (responseBody), client) +import Servant.Client (ClientEnv, ClientError (FailureResponse), ClientM, ResponseF (responseBody), client) import Text.Regex (Regex) import qualified Text.Regex as Regex import qualified Wallet.Emulator.Wallet as Pab.Wallet handlers :: MonadIO m => - MonadReader Env m => + MonadReader ClientEnv m => ServerT API m handlers = restoreWallet :<|> checkMnemonic @@ -55,7 +50,7 @@ checkMnemonic (CheckPostData phrase) = -- [UC-WALLET-TESTNET-2][1] Restore a testnet wallet restoreWallet :: MonadIO m => - MonadReader Env m => + MonadReader ClientEnv m => RestorePostData -> m (Either RestoreError WalletInfo) restoreWallet postData = runExceptT $ do @@ -80,7 +75,7 @@ restoreWallet postData = runExceptT $ do getPubKeyHashFromWallet :: MonadIO m => - MonadReader Env m => + MonadReader ClientEnv m => WBE.WalletId -> m (Either ClientError PubKeyHash) getPubKeyHashFromWallet walletId = let @@ -104,7 +99,7 @@ getPubKeyHashFromWallet walletId = let createOrRestoreWallet :: MonadIO m => - MonadReader Env m => + MonadReader ClientEnv m => RestorePostData -> WBE.ApiMnemonicT '[15, 18, 21, 24] -> m (Either ClientError WBE.WalletId) diff --git a/marlowe-dashboard-server/src/Marlowe/Run/Wallet/Client.hs b/marlowe-dashboard-server/src/Marlowe/Run/Wallet/Client.hs index 5219af224a..621d4b1e65 100644 --- a/marlowe-dashboard-server/src/Marlowe/Run/Wallet/Client.hs +++ b/marlowe-dashboard-server/src/Marlowe/Run/Wallet/Client.hs @@ -9,17 +9,12 @@ module Marlowe.Run.Wallet.Client where import Cardano.Prelude hiding (Handler) - - import Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson - import qualified Data.ByteString.Lazy as BL +import Servant.Client (ClientEnv, ClientError, ClientM, runClientM) -import Marlowe.Run.Types (Env) -import Servant.Client (ClientError, ClientM, runClientM) - -callWBE :: MonadIO m => MonadReader Env m => ClientM a -> m (Either ClientError a) +callWBE :: MonadIO m => MonadReader ClientEnv m => ClientM a -> m (Either ClientError a) callWBE client = do clientEnv <- ask liftIO $ runClientM client clientEnv diff --git a/marlowe-dashboard-server/src/Marlowe/Run/Wallet/Server.hs b/marlowe-dashboard-server/src/Marlowe/Run/Wallet/Server.hs index b64111256e..4a0452855a 100644 --- a/marlowe-dashboard-server/src/Marlowe/Run/Wallet/Server.hs +++ b/marlowe-dashboard-server/src/Marlowe/Run/Wallet/Server.hs @@ -12,16 +12,16 @@ 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.Types (Env) import Marlowe.Run.Wallet (getTotalFunds) import Marlowe.Run.Wallet.API (API, GetTotalFundsResponse (..)) import qualified Marlowe.Run.Wallet.CentralizedTestnet.Server as CentralizedTestnet import Marlowe.Run.Wallet.Client (callWBE) import Servant (ServerError, ServerT, err404, (:<|>) ((:<|>))) +import Servant.Client (ClientEnv) handlers :: MonadIO m => - MonadReader Env m => + MonadReader ClientEnv m => MonadError ServerError m => ServerT API m handlers = handleGetTotalFunds :<|> CentralizedTestnet.handlers @@ -29,7 +29,7 @@ handlers = handleGetTotalFunds :<|> CentralizedTestnet.handlers handleGetTotalFunds :: MonadIO m => MonadError ServerError m => - MonadReader Env m => + MonadReader ClientEnv m => WalletIdDto -> m GetTotalFundsResponse handleGetTotalFunds =