Refactoring Logging

resources/appConfig.yaml

@@ -1 +1 @@
-priority: DEBUG
+stage: Dev

src/Macbeth/Fics/AppConfig.hs

@@ -2,6 +2,7 @@
 
 module Macbeth.Fics.AppConfig (
   AppConfig(..),
+  Stage(..),
   loadAppConfig
 ) where
 
@@ -11,14 +12,15 @@ import Control.Monad.Except
 import Data.Aeson.Types
 import Data.Yaml
 import GHC.Generics
-import System.Log.Logger
 
 
 data AppConfig = AppConfig {
-  priority :: Priority
+  stage :: Stage
 } deriving (Show, Generic)
 
 
+data Stage = Prod | Dev deriving (Show, Eq, Generic)
+
 instance ToJSON AppConfig
 instance FromJSON AppConfig
 
@@ -31,26 +33,14 @@ fromDisk :: ExceptT ParseException IO AppConfig
 fromDisk = ExceptT $ getDataFileName "appConfig.yaml" >>= decodeFileEither
 
 
-instance ToJSON Priority where
-  toJSON DEBUG = String "DEBUG"
-  toJSON INFO = String "INFO"
-  toJSON NOTICE = String "NOTICE"
-  toJSON WARNING = String "WARNING"
-  toJSON ERROR = String "ERROR"
-  toJSON CRITICAL = String "CRITICAL"
-  toJSON ALERT = String "ALERT"
-  toJSON EMERGENCY = String "EMERGENCY"
-
-
-instance FromJSON Priority where
-  parseJSON (String "DEBUG") = pure DEBUG
-  parseJSON (String "INFO") = pure INFO
-  parseJSON (String "NOTICE") = pure NOTICE
-  parseJSON (String "WARNING") = pure WARNING
-  parseJSON (String "ERROR") = pure ERROR
-  parseJSON (String "CRITICAL") = pure CRITICAL
-  parseJSON (String "ALERT") = pure ALERT
-  parseJSON (String "EMERGENCY") = pure EMERGENCY
+instance ToJSON Stage where
+  toJSON Dev = String "Dev"
+  toJSON Prod = String "Prod"
+
+
+instance FromJSON Stage where
+  parseJSON (String "Dev") = pure Dev
+  parseJSON (String "Prod") = pure Prod
 
   parseJSON invalid = typeMismatch "priority" invalid
 

src/Macbeth/Fics/FicsConnection.hs

@@ -4,7 +4,7 @@ module Macbeth.Fics.FicsConnection (
   ficsConnection
 ) where
 
-import Macbeth.Fics.AppConfig
+
 import Macbeth.Fics.FicsMessage hiding (gameId)
 import Macbeth.Fics.Api.Api
 import Macbeth.Fics.Api.Move hiding (Observing)
@@ -14,23 +14,25 @@ import qualified Macbeth.Fics.Api.Result as R
 import Control.Concurrent.Chan
 import Control.Monad
 import Control.Monad.State
-import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Resource
 import Data.Char
 import Data.Conduit
 import Data.Conduit.Binary
 import Data.Conduit.List hiding (filter)
 import Data.Maybe
+import GHC.Show (showLitString)
 import System.Log.Logger
-import System.Log.Handler.Simple hiding (priority)
-import System.Log.Handler (setFormatter)
-import System.Log.Formatter
 import Network
 import Prelude hiding (log)
 import System.IO
 
 import qualified Data.ByteString.Char8 as BS
 
+
+logger :: String
+logger = "Macbeth.Fics.FicsConnection"
+
+
 data HelperState = HelperState { takebackAccptedBy :: Maybe (Maybe String)
                                , illegalMove :: Maybe String }
 
@@ -39,7 +41,6 @@ ficsConnection :: IO (Handle, Chan FicsMessage)
 ficsConnection = runResourceT $ do
   (_, hsock) <- allocate (connectTo "freechess.org" $ PortNumber 5000) hClose
   liftIO $ hSetBuffering hsock LineBuffering
-  liftIO $ initLogger . priority =<< loadAppConfig
   chan <- liftIO newChan
   _ <- resourceForkIO $ liftIO $ chain hsock chan
   return (hsock, chan)
@@ -65,11 +66,10 @@ sink chan = awaitForever $ liftIO . writeChan chan
 
 
 logFicsMessageC :: Conduit FicsMessage (StateT HelperState IO) FicsMessage
-logFicsMessageC = awaitForever $ \cmd -> do
-  _ <- liftIO $ runMaybeT ((MaybeT $ return $ logMsg cmd) >>= \msg -> do
-    lift $ debugM fileLogger msg
-    lift $ debugM consoleLogger msg)
-  yield cmd
+logFicsMessageC = awaitForever $ \cmd -> case cmd of
+  NewSeek{} -> yield cmd
+  RemoveSeeks{} -> yield cmd
+  _ -> liftIO (infoM "console" $ show cmd) >> yield cmd
 
 
 copyC :: Chan FicsMessage -> Conduit FicsMessage (StateT HelperState IO) FicsMessage
@@ -90,7 +90,7 @@ stateC = awaitForever $ \cmd -> do
     IllegalMove m -> put (state' {illegalMove = Just m}) >> sourceNull
 
     m@(GameMove _ move')
-      | isCheckmate move' && isOponentMove move' -> sourceList $ cmd : [moveToResult move']
+      | isCheckmate move' && isOponentMove move' -> sourceList $ cmd : [convertMoveToResult move']
       | isJust $ takebackAccptedBy state' -> do
           put $ state' {takebackAccptedBy = Nothing}
           sourceList [m{context = Takeback $ fromJust $ takebackAccptedBy state'}]
@@ -157,43 +157,16 @@ dropPrompt line
 
 
 logStreamC :: Conduit BS.ByteString (StateT HelperState IO) BS.ByteString
-logStreamC = awaitForever $ \chunk -> do
-  liftIO $ debugM fileLogger $ (foldr (.) (showString "") $ fmap showLitChar (BS.unpack chunk)) ""
-  yield chunk
+logStreamC = awaitForever $ \block -> do
+  liftIO $ infoM logger $ showLitString (BS.unpack block) ""
+  yield block
 
 
-moveToResult :: Move -> FicsMessage
-moveToResult move' = GameResult $ R.Result (gameId move') (nameW move') (nameB move') result (turnToGameResult colorTurn)
+convertMoveToResult :: Move -> FicsMessage
+convertMoveToResult move' = GameResult $ R.Result (gameId move') (nameW move') (nameB move') result (turnToGameResult colorTurn)
   where
     colorTurn = turn move'
     result = namePlayer colorTurn move' ++ " checkmated"
     turnToGameResult Black = R.WhiteWins
     turnToGameResult White = R.BlackWins
 
-
-logMsg :: FicsMessage -> Maybe String
-logMsg NewSeek {} = Nothing
-logMsg RemoveSeeks {} = Nothing
-logMsg cmd = Just $ show cmd
-
-
-consoleLogger :: String
-consoleLogger = "_CONSOLE"
-
-
-fileLogger :: String
-fileLogger = "_FILE"
-
-
-initLogger :: Priority -> IO ()
-initLogger prio = do
-  updateGlobalLogger rootLoggerName removeHandler
-  updateGlobalLogger rootLoggerName (setLevel prio)
-  fileH <- fileHandler "/tmp/macbeth2.log" prio >>= \lh -> return $
-       setFormatter lh (simpleLogFormatter "$time $msg")
-  stdOutH <- streamHandler stdout prio >>= \lh -> return $
-       setFormatter lh (simpleLogFormatter "$time $msg")
-
-  updateGlobalLogger fileLogger (addHandler fileH)
-  updateGlobalLogger consoleLogger (addHandler stdOutH)
-

src/Macbeth/Wx/RuntimeEnv.hs

@@ -11,15 +11,21 @@ module Macbeth.Wx.RuntimeEnv (
 
 import qualified Macbeth.Wx.Config.UserConfig as C
 import Macbeth.Fics.Api.Player
+import Macbeth.Fics.AppConfig
 
 import Control.Concurrent.STM
+import Control.Monad
 import Paths
 import Sound.ALUT
 import System.FilePath
 import System.Directory
 import System.IO
 import System.IO.Unsafe
 import qualified Data.HashMap.Strict as M
+import System.Log.Logger
+import System.Log.Handler.Simple hiding (priority)
+import System.Log.Handler (setFormatter)
+import System.Log.Formatter
 
 data RuntimeEnv = RuntimeEnv {
     handle :: Handle
@@ -32,6 +38,7 @@ data RuntimeEnv = RuntimeEnv {
 initRuntime :: Handle -> IO RuntimeEnv
 initRuntime h = do
   c <- C.initConfig
+  initLogger . stage =<< loadAppConfig
   RuntimeEnv h <$> return c <*> initSources <*> initBufferMap c <*> newTVarIO emptyUserHandle
 
 
@@ -109,3 +116,18 @@ loadSounds dir = do
     foo :: FilePath -> IO (String, Buffer)
     foo f = (,) (takeFileName f) <$> createBuffer (File f)
 
+
+initLogger :: Stage -> IO ()
+initLogger stage' = do
+  updateGlobalLogger rootLoggerName removeHandler
+  updateGlobalLogger rootLoggerName $ setLevel DEBUG
+
+  fileH <- fileHandler "/tmp/macbeth.log" INFO >>= \lh -> return $
+       setFormatter lh (simpleLogFormatter "$time $msg")
+
+  stdOutH <- streamHandler stdout INFO >>= \lh -> return $
+       setFormatter lh (simpleLogFormatter "$time $msg")
+
+  updateGlobalLogger rootLoggerName (addHandler fileH)
+  when (stage' == Dev) $ updateGlobalLogger "console" (addHandler stdOutH)
+