Add developer logs using log-base library

app/game/Swarm/App.hs

@@ -102,14 +102,17 @@ appMain opts = do
       modifyIORef appStateRef $ logColorMode vty
 
       -- Run the app.
-      void $
+      sFinal <-
         readIORef appStateRef
           >>= customMain
             vty
             (buildVty opts.colorMode)
             (Just chan)
             (app $ handleEventAndUpdateWeb appStateRef)
 
+      -- Finish writing logs before exiting
+      waitForLogger (sFinal ^. runtimeState . logger)
+
 -- | A demo program to run the web service directly, without the terminal application.
 --   This is useful to live update the code using @ghcid -W --test "Swarm.App.demoWeb"@.
 demoWeb :: IO ()

src/swarm-engine/Swarm/Effect.hs

@@ -2,8 +2,10 @@
 -- SPDX-License-Identifier: BSD-3-Clause
 -- Description: Effect system
 module Swarm.Effect (
-  module X,
+  module Time,
+  module Log,
 )
 where
 
-import Swarm.Effect.Time as X
+import Swarm.Effect.Log as Log (Log (..), LogIOC (..), runLogEnvIOC, runLogIOC)
+import Swarm.Effect.Time as Time

src/swarm-engine/Swarm/Effect/Log.hs

@@ -0,0 +1,143 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+-- Description: Log effects
+module Swarm.Effect.Log (
+  Log (..),
+
+  -- ** Log functions
+  logMessage,
+  localData,
+  localDomain,
+  localMaxLogLevel,
+  getLoggerEnv,
+  logAttention,
+  logInfo,
+  logTrace,
+  logAttention_,
+  logInfo_,
+  logTrace_,
+
+  -- ** Log Carrier
+  LogIOC (..),
+  runLogIOC,
+  runLogEnvIOC,
+
+  -- * Re-exports
+  module Log,
+) where
+
+import Control.Algebra
+import Control.Carrier.Reader
+import Control.Monad.Trans (MonadIO (liftIO))
+import Data.Aeson.Types
+import Data.Kind (Type)
+import Data.Text (Text)
+import Data.Time.Clock
+import Log as Log (object, (.=))
+import Log.Data as Log
+import Log.Logger as Log
+import Log.Monad
+
+-- | Effect for logging
+data Log (m :: Type -> Type) k where
+  LogMessageOp :: LogLevel -> Text -> Value -> Log m ()
+  LocalData :: [Pair] -> m a -> Log m a
+  LocalDomain :: Text -> m a -> Log m a
+  LocalMaxLogLevel :: LogLevel -> m a -> Log m a
+  GetLoggerEnv :: Log m LoggerEnv
+
+newtype LogIOC m a = LogIOC (ReaderC LoggerEnv m a)
+  deriving newtype (Applicative, Functor, Monad, MonadIO)
+
+{-
+runReader :: r -> ReaderC r m a -> m a
+runReader r (ReaderC runReaderC) = runReaderC r
+-}
+
+runLogIOC ::
+  Text ->
+  Logger ->
+  LogLevel ->
+  LogIOC m a ->
+  m a
+runLogIOC component logger maxLogLevel =
+  runLogEnvIOC $
+    LoggerEnv
+      { leLogger = logger
+      , leComponent = component
+      , leDomain = []
+      , leData = []
+      , leMaxLogLevel = maxLogLevel
+      }
+
+runLogEnvIOC :: LoggerEnv -> LogIOC m a -> m a
+runLogEnvIOC env (LogIOC (ReaderC runLogIO)) = runLogIO env
+
+{-
+instance Algebra sig m => Algebra (Reader r :+: sig) (ReaderC r m) where
+  alg Handler ctx n (ReaderC r m)
+hdl sig ctx ()
+ctx = ReaderC $ \ r -> case sig of
+    L Ask         -> pure (r <$ ctx)
+    L (Local f m) -> runReader (f r) (hdl (m <$ ctx))
+    R other       -> alg (runReader r . hdl) other ctx
+-}
+
+instance (MonadIO m, Algebra sig m) => Algebra (Log :+: sig) (LogIOC m) where
+  alg hdl sig ctx = LogIOC . ReaderC $ \env -> case sig of
+    L (LogMessageOp lvl msg data_) ->
+      (<$ ctx)
+        <$> liftIO
+          (getCurrentTime >>= \time -> logMessageIO env time lvl msg data_)
+    L (LocalData data_ m) -> runLogEnvIOC (env {leData = leData env <> data_}) (hdl (m <$ ctx))
+    L (LocalDomain domain m) -> runLogEnvIOC (env {leDomain = leDomain env <> [domain]}) (hdl (m <$ ctx))
+    L (LocalMaxLogLevel lvl m) -> runLogEnvIOC (env {leMaxLogLevel = lvl}) (hdl (m <$ ctx))
+    L GetLoggerEnv -> pure (env <$ ctx)
+    R other -> alg (runLogEnvIOC env . hdl) other ctx
+
+-- Redefine MonadLog with concrete type, to avoid type errors and incoherrent instances
+
+logMessage :: (Has Log sig m, Monad m) => LogLevel -> Text -> Value -> m ()
+logMessage level message data_ = send $ LogMessageOp level message data_
+
+localData :: (Has Log sig m, Monad m) => [Pair] -> m a -> m a
+localData data_ action = send $ LocalData data_ action
+
+localDomain :: (Has Log sig m, Monad m) => Text -> m a -> m a
+localDomain domain action = send $ LocalDomain domain action
+
+localMaxLogLevel :: (Has Log sig m, Monad m) => LogLevel -> m a -> m a
+localMaxLogLevel level action = send $ LocalMaxLogLevel level action
+
+getLoggerEnv :: (Has Log sig m, Monad m) => m LoggerEnv
+getLoggerEnv = send GetLoggerEnv
+
+-- Log message helpers
+
+logAttention :: (Has Log sig m, Monad m, ToJSON a) => Text -> a -> m ()
+logAttention msg a = logMessage LogAttention msg (toJSON a)
+
+logInfo :: (Has Log sig m, Monad m, ToJSON a) => Text -> a -> m ()
+logInfo msg a = logMessage LogInfo msg (toJSON a)
+
+logTrace :: (Has Log sig m, Monad m, ToJSON a) => Text -> a -> m ()
+logTrace msg a = logMessage LogTrace msg (toJSON a)
+
+-- Log message helpers - without value
+
+logAttention_ :: (Has Log sig m, Monad m) => Text -> m ()
+logAttention_ = (`logAttention` emptyObject)
+
+logInfo_ :: (Has Log sig m, Monad m) => Text -> m ()
+logInfo_ = (`logInfo` emptyObject)
+
+logTrace_ :: (Has Log sig m, Monad m) => Text -> m ()
+logTrace_ = (`logTrace` emptyObject)

src/swarm-engine/Swarm/Game/State.hs

@@ -33,6 +33,7 @@ module Swarm.Game.State (
   robotInfo,
   pathCaching,
   gameMetrics,
+  gameLogEnv,
 
   -- ** GameState initialization
   initGameState,
@@ -106,6 +107,7 @@ import Data.Text.Lazy qualified as TL
 import Data.Text.Lazy.Encoding qualified as TL
 import Data.Tuple (swap)
 import GHC.Generics (Generic)
+import Log (LogLevel (..), Logger, LoggerEnv (LoggerEnv))
 import Swarm.Failure (SystemFailure (..))
 import Swarm.Game.CESK (Store, emptyStore, store, suspendedEnv)
 import Swarm.Game.Entity
@@ -214,6 +216,7 @@ data GameState = GameState
   , _messageInfo :: Messages
   , _completionStatsSaved :: Bool
   , _gameMetrics :: Maybe GameMetrics
+  , _gameLogEnv :: LoggerEnv
   }
 
 makeLensesNoSigs ''GameState
@@ -328,6 +331,9 @@ completionStatsSaved :: Lens' GameState Bool
 -- | Metrics tracked for the Swarm Engine. See 'RuntimeState' metrics store.
 gameMetrics :: Lens' GameState (Maybe GameMetrics)
 
+-- | The logging setup for the Swarm Engine. See 'RuntimeState' logger.
+gameLogEnv :: Lens' GameState LoggerEnv
+
 ------------------------------------------------------------
 -- Utilities
 ------------------------------------------------------------
@@ -512,8 +518,8 @@ type LaunchParams a = ParameterizableLaunchParams CodeToRun a
 type ValidatedLaunchParams = LaunchParams Identity
 
 -- | Create an initial, fresh game state record when starting a new scenario.
-initGameState :: GameStateConfig -> GameState
-initGameState gsc =
+initGameState :: GameStateConfig -> Logger -> GameState
+initGameState gsc logger =
   GameState
     { _creativeMode = False
     , _temporal =
@@ -533,6 +539,7 @@ initGameState gsc =
     , _messageInfo = initMessages
     , _completionStatsSaved = False
     , _gameMetrics = Nothing
+    , _gameLogEnv = LoggerEnv logger "Engine" [] [] LogTrace
     }
 
 -- | Provide an entity accessor via the MTL transformer State API.

src/swarm-engine/Swarm/Game/State/Initialize.hs

@@ -24,6 +24,7 @@ import Data.Maybe (isNothing)
 import Data.Set qualified as S
 import Data.Text (Text)
 import Data.Tuple.Extra (dupe)
+import Log (Logger)
 import Swarm.Game.CESK (finalValue, initMachine)
 import Swarm.Game.Device (getCapabilitySet, getMap)
 import Swarm.Game.Entity
@@ -68,17 +69,18 @@ scenarioToGameState si@(ScenarioWith scenario _) (LaunchParams (Identity userSee
   theSeed <- arbitrateSeed userSeed $ scenario ^. scenarioLandscape
   now <- Clock.getTime Clock.Monotonic
   gMetric <- maybe (initGameMetrics $ rs ^. metrics) pure prevMetric
-  return $ pureScenarioToGameState si theSeed now toRun (Just gMetric) (rs ^. stdGameConfigInputs)
+  return $ pureScenarioToGameState si theSeed now toRun (Just gMetric) (rs ^. logger) (rs ^. stdGameConfigInputs)
 
 pureScenarioToGameState ::
   ScenarioWith (Maybe ScenarioPath) ->
   Seed ->
   Clock.TimeSpec ->
   Maybe CodeToRun ->
   Maybe GameMetrics ->
+  Logger ->
   GameStateConfig ->
   GameState
-pureScenarioToGameState (ScenarioWith scenario fp) theSeed now toRun gMetric gsc =
+pureScenarioToGameState (ScenarioWith scenario fp) theSeed now toRun gMetric gLogger gsc =
   preliminaryGameState
     & discovery . structureRecognition .~ recognition
  where
@@ -94,7 +96,7 @@ pureScenarioToGameState (ScenarioWith scenario fp) theSeed now toRun gMetric gsc
       . adaptGameState
       $ initializeRecognition mtlEntityAt (sLandscape ^. scenarioStructures)
 
-  gs = initGameState gsc
+  gs = initGameState gsc gLogger
   preliminaryGameState =
     gs
       & currentScenarioPath .~ fp

src/swarm-engine/Swarm/Game/State/Runtime.hs

@@ -19,10 +19,12 @@
   appData,
   stdGameConfigInputs,
   metrics,
+  logger,
 
   -- ** Utility
   initScenarioInputs,
   initGameStateConfig,
+  waitForLogger,
 )
 where
 
@@ -33,15 +35,20 @@
 import Data.Map (Map)
 import Data.Sequence (Seq)
 import Data.Text (Text)
+import Data.Text qualified as T
+import Data.Text.IO qualified as T
+import Log
 import Swarm.Failure (SystemFailure)
 import Swarm.Game.Land
 import Swarm.Game.Recipe (loadRecipes)
 import Swarm.Game.Scenario (GameStateInputs (..), ScenarioInputs (..))
 import Swarm.Game.State.Substate
 import Swarm.Game.World.Load (loadWorlds)
 import Swarm.Log
-import Swarm.ResourceLoading (initNameGenerator, readAppData)
+import Swarm.ResourceLoading (getSwarmLogsPath, initNameGenerator, readAppData)
 import Swarm.Util.Lens (makeLensesNoSigs)
+import System.FilePath
+import System.IO (BufferMode (..), IOMode (..), hSetBuffering, openFile)
 import System.Metrics qualified as Metrics
 
 data RuntimeState = RuntimeState
@@ -52,6 +59,7 @@
   , _stdGameConfigInputs :: GameStateConfig
   , _appData :: Map Text Text
   , _metrics :: Metrics.Store
+  , _logger :: Logger
   }
 
 initScenarioInputs ::
@@ -94,6 +102,7 @@
   { startPaused :: Bool
   , pauseOnObjectiveCompletion :: Bool
   , loadTestScenarios :: Bool
+  , startLogging :: Bool
   }
   deriving (Eq, Show)
 
@@ -108,6 +117,7 @@
   store <- sendIO Metrics.newStore
   sendIO $ Metrics.registerGcMetrics store
   gsc <- initGameStateConfig opts
+  fileLogger <- if startLogging opts then sendIO makeFileLogger else pure mempty
   return $
     RuntimeState
       { _webPort = Nothing
@@ -117,8 +127,19 @@
       , _appData = initAppDataMap gsc
       , _stdGameConfigInputs = gsc
       , _metrics = store
+      , _logger = fileLogger
       }
 
+makeFileLogger :: IO Logger
+makeFileLogger = do
+  logPath <- getSwarmLogsPath
+  logFile <- openFile (logPath </> "log.txt") WriteMode
+  hSetBuffering logFile LineBuffering
+  mkLogger "file log" (T.hPutStrLn logFile . formatMsg)
+ where
+  formatMsg :: LogMessage -> Text
+  formatMsg = showLogMessage Nothing
+
 makeLensesNoSigs ''RuntimeState
 
 -- | The port on which the HTTP debug service is running.
@@ -149,3 +170,10 @@
 -- will be published together with GHC metrics by the Wai server taking
 -- a reference to this store.
 metrics :: Lens' RuntimeState Metrics.Store
+
+-- | Get the persisted logger - you can think of this is as the IO action,
+-- while LoggerEnv should be passed around to enrich logging in current context.
+-- For example game engine logs can be enriched with the "game engine" component.
+-- While game state can be rebuilt each time time a scenario is started
+-- and LoggerEnv discarded, we want to keep around this logging IO action.
+logger :: Lens' RuntimeState Logger