Wrong way

IntersectMBO · Aug 7, 2020 · 2600bde · 2600bde
1 parent 3820356
commit 2600bde
Show file tree

Hide file tree

Showing 4 changed files with 123 additions and 2 deletions.
diff --git a/plutus-scb/plutus-scb.cabal b/plutus-scb/plutus-scb.cabal
@@ -88,6 +88,7 @@ library
         Plutus.SCB.Effects.EventLog
         Plutus.SCB.Effects.MultiAgent
         Plutus.SCB.Effects.UUID
+        Plutus.SCB.MonadLoggerBridge
         Plutus.SCB.Monitoring
         Plutus.SCB.Webserver.Types
         Plutus.SCB.Webserver.API

diff --git a/plutus-scb/src/Plutus/SCB/App.hs b/plutus-scb/src/Plutus/SCB/App.hs
@@ -28,6 +28,7 @@ import qualified Cardano.SigningProcess.Server    as SigningProcess
 import qualified Cardano.Wallet.Client            as WalletClient
 import qualified Cardano.Wallet.Server            as WalletServer
 import           Control.Monad.Freer
+import           Cardano.BM.Trace (Trace)
 import           Control.Monad.Freer.Error        (Error, handleError, runError, throwError)
 import           Control.Monad.Freer.Extra.Log    (LogMsg, handleWriterLog, logDebug, logInfo, runStderrLog)
 import           Control.Monad.Freer.Log          (LogMessage, LogObserve, handleObserveLog, renderLogMessages)
@@ -56,6 +57,7 @@ import           Plutus.SCB.Core                  (Connection (Connection),
                                                    ContractCommand (InitContract, UpdateContract), CoreMsg, dbConnect)
 import           Plutus.SCB.Core.ContractInstance (ContractInstanceMsg)
 import           Plutus.SCB.Effects.Contract      (ContractEffect (..))
+import Plutus.SCB.MonadLoggerBridge (MonadLoggerMsg)
 import           Plutus.SCB.Effects.EventLog      (EventLogEffect (..), handleEventLogSql)
 import           Plutus.SCB.Effects.UUID          (UUIDEffect, handleUUIDEffect)
 import           Plutus.SCB.Events                (ChainEvent)
@@ -103,13 +105,74 @@ type AppBackend m =
          , LogMsg (ContractInstanceMsg ContractExe)
          , LogMsg UnStringifyJSONLog
          , LogMsg (CoreMsg ContractExe)
+         , LogMsg MonadLoggerMsg
          , LogObserve (LogMessage Text.Text)
          , LogMsg Text.Text
          , Reader Connection
          , Reader Env
          , m
          ]
 
+runAppBackend' ::
+    forall m a.
+    ( MonadIO m
+    , MonadUnliftIO m
+    )
+    => Trace m a
+    -> Env
+    -> Eff (AppBackend m) a
+    -> m (Either SCBError a)
+runAppBackend' trace e@Env{dbConnection, nodeClientEnv, walletClientEnv, signingProcessEnv, chainIndexEnv} =
+    runM
+    . runReader e
+    . runReader dbConnection
+    . runStderrLog
+    . handleObserveLog
+    . renderLogMessages
+    . renderLogMessages
+    . renderLogMessages
+    . renderLogMessages
+    . renderLogMessages
+    . renderLogMessages
+    . handleWriterLog (\_ -> Log.Info)
+    . runError
+    . handleEventLogSql
+    . handleChainIndex
+    . handleContractEffectApp
+    . handleUUIDEffect
+    . handleSigningProcess
+    . handleNodeClient
+    . handleWallet
+    . handleNodeFollower
+    . handleRandomTxClient nodeClientEnv
+    where
+        handleChainIndex :: Eff (ChainIndexEffect ': Error ClientError ': _) a -> Eff _ a
+        handleChainIndex =
+            flip handleError (throwError . ChainIndexError)
+            . handleChainIndexClient chainIndexEnv
+
+        handleSigningProcess :: Eff (SigningProcessEffect ': Error ClientError ': _) a -> Eff _ a
+        handleSigningProcess =
+            flip handleError (throwError . SigningProcessError)
+            . SigningProcessClient.handleSigningProcessClient signingProcessEnv
+
+        handleNodeClient :: Eff (NodeClientEffect ': Error ClientError ': _) a -> Eff _ a
+        handleNodeClient =
+            flip handleError (throwError . NodeClientError)
+            . handleNodeClientClient nodeClientEnv
+
+        handleNodeFollower :: Eff (NodeFollowerEffect ': Error ClientError ': _) a -> Eff _ a
+        handleNodeFollower =
+            flip handleError (throwError . NodeClientError)
+            . handleNodeFollowerClient nodeClientEnv
+
+        handleWallet :: Eff (WalletEffect ': Error WalletAPIError ': Error ClientError ': _) a -> Eff _ a
+        handleWallet =
+            flip handleError (throwError . WalletClientError)
+            . flip handleError (throwError . WalletError)
+            . WalletClient.handleWalletClient walletClientEnv
+
+
 runAppBackend ::
     forall m a.
     ( MonadIO m
@@ -130,6 +193,7 @@ runAppBackend e@Env{dbConnection, nodeClientEnv, walletClientEnv, signingProcess
     . renderLogMessages
     . renderLogMessages
     . renderLogMessages
+    . renderLogMessages
     . handleWriterLog (\_ -> Log.Info)
     . runError
     . handleEventLogSql

diff --git a/plutus-scb/src/Plutus/SCB/Effects/EventLog.hs b/plutus-scb/src/Plutus/SCB/Effects/EventLog.hs
@@ -60,7 +60,7 @@ handleEventLogSql ::
     , LastMember m effs
     , ToJSON event
     , FromJSON event
-    , MonadLogger.MonadLogger m
+    -- , MonadLogger.MonadLogger m
     , Unlift.MonadUnliftIO m
     )
     => Eff (EventLogEffect event ': effs) ~> Eff effs
@@ -75,7 +75,7 @@ handleEventLogSql = interpret $ \case
                 getLatestStreamProjection reader projection
     RunCommand aggregate source input -> do
         (Connection (sqlConfig, connectionPool)) <- ask
-        sendM $ do
+        (events, logLines) <- sendM $ MonadLogger.unWriterLoggingT $ do
             let reader =
                     serializedVersionedEventStoreReader jsonStringSerializer $
                     sqlEventStoreReader sqlConfig
@@ -86,6 +86,7 @@ handleEventLogSql = interpret $ \case
                         reader
             retryOnBusy . flip runSqlPool connectionPool $
                 commandStoredAggregate writer reader aggregate (toUUID source) input
+        pure events
 
 runGlobalQuery ::
        Member (EventLogEffect event) effs

diff --git a/plutus-scb/src/Plutus/SCB/MonadLoggerBridge.hs b/plutus-scb/src/Plutus/SCB/MonadLoggerBridge.hs
@@ -0,0 +1,55 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE MonoLocalBinds #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+-- | A 'Control.Monad.Logger.Logger' instance
+--   using the 'Control.Monad.Freer.Log.Log' effect
+module Plutus.SCB.MonadLoggerBridge(
+  MonadLoggerMsg(..)
+  ) where
+
+import Control.Monad.Logger (MonadLogger(..), Loc, LogSource, LogLevel(..), LogStr, ToLogStr(..))
+import Control.Monad.Freer
+import Control.Monad.Freer.Log (LogMsg(..), LogMessage(..))
+import qualified Control.Monad.Freer.Log as L
+import Data.Text.Prettyprint.Doc (Pretty(..), (<+>), vsep, viaShow)
+
+data MonadLoggerMsg =
+  MonadLoggerMsg
+    { mlmLocation :: Loc
+    , mlmLogSource :: LogSource
+    , mlmLogStr   :: LogStr
+    }
+
+instance Pretty MonadLoggerMsg where
+    pretty MonadLoggerMsg{mlmLocation, mlmLogSource, mlmLogStr} =
+        vsep
+            [ "Location:" <+> viaShow mlmLocation
+            , "Source:" <+> viaShow mlmLogSource
+            , "Message:" <+> viaShow mlmLogStr
+            ]
+
+instance (Member (LogMsg MonadLoggerMsg) effs) => MonadLogger (Eff effs) where
+    monadLoggerLog l ls ll msg =
+        send
+            $ LMessage
+            $ LogMessage
+                { _logLevel = toLogLevel ll
+                , _logMessageContent =
+                    MonadLoggerMsg
+                        { mlmLocation = l
+                        , mlmLogSource = ls
+                        , mlmLogStr = toLogStr msg
+                        }
+                }
+
+toLogLevel :: LogLevel -> L.LogLevel
+toLogLevel = \case
+    LevelDebug   -> L.Debug
+    LevelInfo    -> L.Info
+    LevelWarn    -> L.Warning
+    LevelError   -> L.Error
+    LevelOther _ -> L.Info