Use MonadReader to pass the clientEnv

marlowe-dashboard-server/app/Webserver.hs

@@ -5,13 +5,23 @@
 
 module Webserver where
 
+import           Control.Monad.IO.Class       (liftIO)
 import           Data.Proxy                   (Proxy (Proxy))
 import           Marlowe.Run.Webserver.API    (API)
 import qualified Marlowe.Run.Webserver.Server as Server
+import           Network.HTTP.Client          (defaultManagerSettings, newManager)
 import           Network.Wai.Handler.Warp     as Warp
 import           Servant                      (serve)
+import           Servant.Client               (BaseUrl (BaseUrl, baseUrlHost, baseUrlPath, baseUrlPort, baseUrlScheme),
+                                               Scheme (Http), mkClientEnv)
+
 
 run :: FilePath -> Settings -> IO ()
 run staticPath settings = do
+  -- FIXME: Reuse connection and setup using configuration
+  manager <- liftIO $ newManager defaultManagerSettings
+  let baseUrl = BaseUrl{baseUrlScheme=Http,baseUrlHost="localhost",baseUrlPort=8090,baseUrlPath=""}
+      clientEnv = mkClientEnv manager baseUrl
+
   let server = Server.handlers
-  Warp.runSettings settings (serve (Proxy @API) (server staticPath))
+  Warp.runSettings settings (serve (Proxy @API) (server staticPath clientEnv))

marlowe-dashboard-server/src/Marlowe/Run/Webserver/Server.hs

@@ -9,7 +9,11 @@
 {-# LANGUAGE TypeOperators         #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
-module Marlowe.Run.Webserver.Server where
+module Marlowe.Run.Webserver.Server
+ (
+    handlers
+ )
+ where
 
 import           Cardano.Mnemonic                           (MkSomeMnemonicError, mkSomeMnemonic)
 import qualified Cardano.Wallet.Api.Client                  as WBE.Api
@@ -25,12 +29,13 @@ import qualified Cardano.Wallet.Primitive.Types             as WBE
 import           Control.Monad.Except                       (ExceptT (ExceptT), runExceptT, withExceptT)
 import           Control.Monad.IO.Class                     (MonadIO, liftIO)
 import           Control.Monad.Logger                       (LoggingT, MonadLogger, logInfoN, runStderrLoggingT)
-import           Control.Monad.Reader                       (ReaderT, runReaderT)
+import           Control.Monad.Reader                       (MonadReader (ask), ReaderT, runReaderT)
 import           Data.Aeson                                 (FromJSON, ToJSON, eitherDecode, encode)
 import           Data.Aeson                                 as Aeson
 import qualified Data.Aeson.Types                           as Aeson
 
 import           Cardano.Wallet.Primitive.AddressDerivation (Passphrase (Passphrase))
+import           Control.Monad.Reader.Class
 import qualified Data.ByteString.Lazy                       as BL
 import           Data.Maybe                                 (fromMaybe)
 import           Data.Proxy                                 (Proxy (Proxy))
@@ -41,7 +46,7 @@ import           Data.Text.Class                            (FromText (..))
 import qualified Data.Text.Encoding                         as Text
 import           GHC.Generics                               (Generic)
 import           Ledger                                     (PubKeyHash (..))
-import           Marlowe.Run.Webserver.Types                (RestoreError (..), RestorePostData (..))
+import           Marlowe.Run.Webserver.Types                (Env, RestoreError (..), RestorePostData (..))
 import qualified Marlowe.Run.Webserver.WebSocket            as WS
 import           Network.HTTP.Client                        (defaultManagerSettings, newManager)
 import           Network.Wai.Middleware.Cors                (cors, corsRequestHeaders, simpleCorsResourcePolicy)
@@ -57,28 +62,33 @@ import           Text.Regex                                 (Regex)
 import qualified Text.Regex                                 as Regex
 import qualified Wallet.Emulator.Wallet                     as Pab.Wallet
 
-handlers :: FilePath -> Server API
-handlers staticPath =
-        WS.handle
-        :<|> (handleVersion
-                :<|> restoreWallet
-             )
-        :<|> serveDirectoryFileServer staticPath
-
+handlers :: FilePath -> Env -> Server API
+handlers staticPath env =
+    hoistServer (Proxy @API) liftHandler
+        ( WS.handle
+            :<|> (handleVersion
+                   :<|> restoreWallet
+                 )
+            :<|> serveDirectoryFileServer staticPath
+        )
+    where
+    liftHandler :: ReaderT Env (ExceptT ServerError IO) a -> Handler a
+    liftHandler = Handler . flip runReaderT env
 
 -- TODO: Can we get this from cabal somehow?
-handleVersion :: Handler Text
+handleVersion :: Applicative m => m Text
 handleVersion = pure "1.0.0.0"
 
--- FIXME: Reuse connection and setup using configuration
-callWBE :: ClientM a -> IO (Either ClientError a)
+callWBE :: MonadIO m => MonadReader Env m => ClientM a -> m (Either ClientError a)
 callWBE client = do
-    manager <- newManager defaultManagerSettings
-    let baseUrl = BaseUrl{baseUrlScheme=Http,baseUrlHost="localhost",baseUrlPort=8090,baseUrlPath=""}
-        clientEnv = mkClientEnv manager baseUrl
-    runClientM client clientEnv
-
-restoreWallet :: MonadIO m => RestorePostData -> m (Either RestoreError WalletInfo)
+    clientEnv <- ask
+    liftIO $ runClientM client clientEnv
+
+restoreWallet ::
+     MonadIO m =>
+     MonadReader Env m =>
+     RestorePostData ->
+     m (Either RestoreError WalletInfo)
 restoreWallet postData = runExceptT $ do
     let
         phrase = getMnemonicPhrase postData
@@ -90,22 +100,22 @@ restoreWallet postData = runExceptT $ do
         )
     -- Call the WBE trying to restore the wallet, and take error 409 Conflict as a success
     walletId <- ExceptT $ createOrRestoreWallet postData mnemonic
+    -- Get the pubKeyHash of the first wallet derivation
     pubKeyHash <- withExceptT (const CantFetchPubKeyHash) $
-        ExceptT $ liftIO $ getPubKeyHashFromWallet walletId
+        ExceptT $ getPubKeyHashFromWallet walletId
     pure $ WalletInfo{wiWallet=Pab.Wallet.Wallet (Pab.Wallet.WalletId walletId), wiPubKeyHash = pubKeyHash }
 
-
-
 getPubKeyHashFromWallet ::
     MonadIO m =>
+    MonadReader Env m =>
     WBE.WalletId ->
     m (Either ClientError PubKeyHash)
 getPubKeyHashFromWallet walletId = let
     -- This endpoint is not exposed directly by the WBE, I took this helper from the plutus-pab code.
     getWalletKey :: WBE.ApiT WBE.WalletId -> WBE.ApiT WBE.Role -> WBE.ApiT WBE.DerivationIndex -> Maybe Bool -> ClientM WBE.ApiVerificationKeyShelley
     getWalletKey :<|> _ :<|> _ :<|> _ = client (Proxy @("v2" :> WalletKeys))
 
-    makeRequest = liftIO $ callWBE $
+    makeRequest = callWBE $
        getWalletKey
         (WBE.ApiT walletId)
         -- Role: External, to receive funds
@@ -121,6 +131,7 @@ getPubKeyHashFromWallet walletId = let
 
 createOrRestoreWallet ::
     MonadIO m =>
+    MonadReader Env m =>
     RestorePostData ->
     WBE.ApiMnemonicT '[15, 18, 21, 24] ->
     m (Either RestoreError WBE.WalletId)
@@ -136,7 +147,7 @@ createOrRestoreWallet postData mnemonic = do
             (WBE.ApiT $ WBE.WalletName walletName)
             (WBE.ApiT $ Passphrase $ fromString passphrase )
 
-    result <- liftIO $ callWBE $ WBE.Api.postWallet WBE.Api.walletClient walletPostData
+    result <- callWBE $ WBE.Api.postWallet WBE.Api.walletClient walletPostData
     case result of
         Left (FailureResponse _ r) -> do
             let
@@ -177,13 +188,3 @@ safeHead (x:_) = Just x
 
 hush :: Either a b -> Maybe b
 hush = either (const Nothing) Just
-
-app :: FilePath -> Application
-app staticPath =
-  cors (const $ Just policy) $ serve (Proxy @API) (handlers staticPath)
-  where
-    policy =
-      simpleCorsResourcePolicy
-
-initializeApplication :: FilePath -> IO Application
-initializeApplication staticPath = pure $ app staticPath

marlowe-dashboard-server/src/Marlowe/Run/Webserver/Types.hs

@@ -10,6 +10,7 @@ import qualified Data.Aeson       as Aeson
 import           Data.Aeson.Types (FromJSON, ToJSON, genericToJSON)
 import           Data.Text        (Text)
 import           GHC.Generics     (Generic)
+import           Servant.Client   (ClientEnv)
 
 
 data RestorePostData =
@@ -27,3 +28,5 @@ data RestoreError =
     | UnknownRestoreError
     deriving stock (Eq, Generic, Show)
     deriving anyclass (ToJSON)
+
+type Env = ClientEnv