Switched to hslogger based logging

Main.hs

@@ -6,12 +6,17 @@ module Main (main) where
 
 import qualified Data.Configurator as CF
 
-import ClassyPrelude hiding (try, getArgs)
+import ClassyPrelude hiding      (getArgs)
 import Control.Concurrent.Lifted (myThreadId)
-import Control.Exception.Lifted  (try, throwTo, AsyncException (UserInterrupt))
+import Control.Exception.Lifted  (throwTo, AsyncException (UserInterrupt))
 import Data.Configurator.Types   (Configured (..), Value (List), ConfigError (..), KeyError (..))
 import System.Environment        (getArgs, getProgName)
 import System.Exit               (exitFailure)
+import System.Log.Formatter      (tfLogFormatter)
+import System.Log.Handler        (setFormatter)
+import System.Log.Handler.Simple (streamHandler)
+import System.Log.Logger         (Priority (..), updateGlobalLogger, rootLoggerName,
+                                  setHandlers, setLevel)
 import System.Posix.Signals      (installHandler, sigINT, sigTERM, Handler (Catch))
 
 import Network.IRC.Types
@@ -23,6 +28,7 @@ instance Configured a => Configured [a] where
 
 main :: IO ()
 main = do
+  -- get args
   args <- getArgs
   prog <- getProgName
 
@@ -30,10 +36,17 @@ main = do
     putStrLn $ "Usage: " ++ pack prog ++ " <config file path>"
     exitFailure
 
+  -- setup signal handling
   mainThreadId <- myThreadId
   installHandler sigINT  (Catch $ throwTo mainThreadId UserInterrupt) Nothing
   installHandler sigTERM (Catch $ throwTo mainThreadId UserInterrupt) Nothing
 
+  -- setup logging
+  stderrHandler <- streamHandler stderr DEBUG >>= \lh -> return $
+                     setFormatter lh $ tfLogFormatter "%F %T" "[$utcTime] $loggername $prio $msg"
+  updateGlobalLogger rootLoggerName (setHandlers [stderrHandler] . setLevel DEBUG)
+
+  -- load config and start the bot
   let configFile = headEx args
   loadBotConfig configFile >>= runBot
 

Network/IRC/Bot.hs

@@ -3,11 +3,22 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
 
-module Network.IRC.Bot where
+module Network.IRC.Bot
+  ( Line (..)
+  , sendCommand
+  , sendMessage
+  , sendEvent
+  , readLine
+  , sendCommandLoop
+  , readLineLoop
+  , messageProcessLoop
+  , eventProcessLoop )
+where
 
 import qualified Data.Text.Format as TF
-import qualified Data.Text.Format.Params as TF
+import qualified System.Log.Logger as HSL
 
 import ClassyPrelude
 import Control.Concurrent.Lifted (fork, Chan, readChan, writeChan, threadDelay)
@@ -16,11 +27,14 @@ import Control.Monad.Reader      (ask)
 import Control.Monad.State       (get, put)
 import System.IO                 (hIsEOF)
 import System.Timeout            (timeout)
+import System.Log.Logger.TH      (deriveLoggers)
 
 import Network.IRC.Protocol
 import Network.IRC.Types
 import Network.IRC.Util
 
+$(deriveLoggers "HSL" [HSL.DEBUG, HSL.INFO, HSL.ERROR])
+
 data Line = Timeout | EOF | Line !Message deriving (Show, Eq)
 
 sendCommand :: Chan Command -> Command -> IO ()
@@ -38,16 +52,17 @@ readLine = readChan
 sendCommandLoop :: Channel Command -> Bot -> IO ()
 sendCommandLoop (commandChan, latch) bot@Bot { .. } = do
   cmd       <- readChan commandChan
-  time      <- getCurrentTime
   let mline = lineFromCommand botConfig cmd
-  case mline of
+  handle (\(e :: SomeException) ->
-    Nothing   -> return ()
+            errorM ("Error while writing to connection: " ++ show e) >> latchIt latch) $ do
-    Just line -> do
+    case mline of
-      TF.hprint socket "{}\r\n" $ TF.Only line
+      Nothing   -> return ()
-      TF.print "[{}] > {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, line)
+      Just line -> do
-  case cmd of
+        TF.hprint socket "{}\r\n" $ TF.Only line
-    QuitCmd -> latchIt latch
+        infoM . unpack $ "> " ++ line
-    _       -> sendCommandLoop (commandChan, latch) bot
+    case cmd of
+      QuitCmd -> latchIt latch
+      _       -> sendCommandLoop (commandChan, latch) bot
 
 readLineLoop :: MVar BotStatus -> Channel Line -> Bot -> Int -> IO ()
 readLineLoop mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do
@@ -55,10 +70,13 @@ readLineLoop mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do
   case botStatus of
     Disconnected -> latchIt latch
     _            -> do
-      mLine <- timeout timeoutDelay readLine'
+      mLine <- try $ timeout timeoutDelay readLine'
       case mLine of
-        Nothing   -> writeChan lineChan Timeout
+        Left (e :: SomeException) -> do
-        Just line -> writeChan lineChan line
+          errorM $ "Error while reading from connection: " ++ show e
+          writeChan lineChan EOF
+        Right Nothing     -> writeChan lineChan Timeout
+        Right (Just line) -> writeChan lineChan line
       readLineLoop mvBotStatus (lineChan, latch) bot timeoutDelay
       where
         readLine' = do
@@ -67,7 +85,7 @@ readLineLoop mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do
             then return EOF
             else do
               line <- map initEx $ hGetLine socket
-              debug $ "< " ++ line
+              infoM . unpack $ "< " ++ line
               now <- getCurrentTime
               return . Line $ msgFromLine botConfig now line
 
@@ -79,7 +97,7 @@ messageProcessLoop lineChan commandChan !idleFor = do
 
   nStatus <- liftIO . mask_ $
     if idleFor >= (oneSec * botTimeout botConfig)
-      then debug "Timeout" >> return Disconnected
+      then infoM "Timeout" >> return Disconnected
       else do
         when (status == Kicked) $
           threadDelay (5 * oneSec) >> sendCommand commandChan JoinCmd
@@ -87,13 +105,13 @@ messageProcessLoop lineChan commandChan !idleFor = do
         mLine <- readLine lineChan
         case mLine of
           Timeout      -> getCurrentTime >>= dispatchHandlers bot . IdleMsg  >> return Idle
-          EOF          -> debug "Connection closed" >> return Disconnected
+          EOF          -> infoM "Connection closed" >> return Disconnected
           Line message -> do
             nStatus <- case message of
-              JoinMsg { .. } | userNick user == nick -> debug "Joined" >> return Joined
+              JoinMsg { .. } | userNick user == nick -> infoM "Joined" >> return Joined
-              KickMsg { .. } | kickedNick == nick    -> debug "Kicked" >> return Kicked
+              KickMsg { .. } | kickedNick == nick    -> infoM "Kicked" >> return Kicked
               NickInUseMsg { .. }                    ->
-                debug "Nick already in use"     >> return NickNotAvailable
+                infoM "Nick already in use"     >> return NickNotAvailable
               ModeMsg { user = Self, .. }            ->
                 sendCommand commandChan JoinCmd >> return Connected
               _                                      -> return Connected
@@ -112,7 +130,7 @@ messageProcessLoop lineChan commandChan !idleFor = do
     dispatchHandlers Bot { .. } message =
       forM_ (mapToList msgHandlers) $ \(_, msgHandler) -> fork $
         handle (\(e :: SomeException) ->
-                  debug $ "Exception while processing message: " ++ pack (show e)) $ do
+                  errorM $ "Exception while processing message: " ++ show e) $ do
           mCmd <- handleMessage msgHandler botConfig message
           case mCmd of
             Nothing  -> return ()
@@ -124,10 +142,10 @@ eventProcessLoop (eventChan, latch) lineChan commandChan bot@Bot {.. } = do
   case fromEvent event of
     Just (QuitEvent, _) -> latchIt latch
     _                   -> do
-      debug $ "Event: " ++ pack (show event)
+      debugM $ "Event: " ++ show event
       forM_ (mapToList msgHandlers) $ \(_, msgHandler) -> fork $
         handle (\(ex :: SomeException) ->
-                  debug $ "Exception while processing event: " ++ pack (show ex)) $ do
+                  errorM $ "Exception while processing event: " ++ show ex) $ do
           resp <- handleEvent msgHandler botConfig event
           case resp of
             RespMessage message -> sendMessage lineChan message

Network/IRC/Client.hs

@@ -2,26 +2,32 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Network.IRC.Client (runBot) where
 
+import qualified System.Log.Logger as HSL
+
 import ClassyPrelude
 import Control.Concurrent.Lifted (fork, newChan, threadDelay)
 import Control.Exception.Lifted  (AsyncException (UserInterrupt))
 import Network                   (PortID (PortNumber), connectTo, withSocketsDo)
 import System.IO                 (hSetBuffering, BufferMode(..))
+import System.Log.Logger.TH      (deriveLoggers)
 
 import Network.IRC.Bot
 import Network.IRC.Handlers
 import Network.IRC.Types
 import Network.IRC.Util
 
+$(deriveLoggers "HSL" [HSL.DEBUG, HSL.ERROR])
+
 connect :: BotConfig -> IO (Bot, MVar BotStatus, Channel Line, Channel Command, Channel SomeEvent)
 connect botConfig@BotConfig { .. } = do
-  debug "Connecting ..."
+  debugM "Connecting ..."
   socket <- connectToWithRetry
   hSetBuffering socket LineBuffering
-  debug "Connected"
+  debugM "Connected"
 
   lineChan    <- newChannel
   commandChan <- newChannel
@@ -33,22 +39,24 @@ connect botConfig@BotConfig { .. } = do
   where
     connectToWithRetry = connectTo (unpack server) (PortNumber (fromIntegral port))
                            `catch` (\(e :: SomeException) -> do
-                                      debug ("Error while connecting: " ++ pack (show e) ++ ". Waiting.")
+                                      errorM ("Error while connecting: " ++ show e ++ ". Waiting.")
                                       threadDelay (5 * oneSec)
                                       connectToWithRetry)
 
     newChannel = (,) <$> newChan <*> newEmptyMVar
 
     loadMsgHandlers eventChan = flip (`foldM` mempty) msgHandlerNames $ \hMap msgHandlerName -> do
-      debug $ "Loading msg handler: " ++ msgHandlerName
+      debugM . unpack $ "Loading msg handler: " ++ msgHandlerName
       mMsgHandler <- mkMsgHandler botConfig eventChan msgHandlerName
       case mMsgHandler of
-        Nothing         -> debug ("No msg handler found with name: " ++ msgHandlerName) >> return hMap
+        Nothing         -> do
+          debugM . unpack $ "No msg handler found with name: " ++ msgHandlerName
+          return hMap
         Just msgHandler -> return $ insertMap msgHandlerName msgHandler hMap
 
 disconnect :: (Bot, MVar BotStatus, Channel Line, Channel Command, Channel SomeEvent) -> IO ()
 disconnect (Bot { .. }, mvBotStatus, (_, readLatch), (commandChan, sendLatch), (eventChan, eventLatch)) = do
-  debug "Disconnecting ..."
+  debugM "Disconnecting ..."
   sendCommand commandChan QuitCmd
   awaitLatch sendLatch
   swapMVar mvBotStatus Disconnected
@@ -57,22 +65,22 @@ disconnect (Bot { .. }, mvBotStatus, (_, readLatch), (commandChan, sendLatch), (
   awaitLatch eventLatch
 
   unloadMsgHandlers
-  hClose socket
+  handle (\(_ :: SomeException) -> return ()) $ hClose socket
-  debug "Disconnected"
+  debugM "Disconnected"
   where
     unloadMsgHandlers = forM_ (mapToList msgHandlers) $ \(msgHandlerName, msgHandler) -> do
-      debug $ "Unloading msg handler: " ++ msgHandlerName
+      debugM . unpack $ "Unloading msg handler: " ++ msgHandlerName
       stopMsgHandler msgHandler botConfig
 
 runBot :: BotConfig -> IO ()
 runBot botConfig' = withSocketsDo $ do
   hSetBuffering stdout LineBuffering
-  debug "Running with config:"
+  debugM "Running with config:"
   print botConfig
   status <- runBot_
   case status of
-    Disconnected     -> debug "Restarting .." >> runBot botConfig
+    Disconnected     -> debugM "Restarting .." >> runBot botConfig
-    Errored          -> debug "Restarting .." >> runBot botConfig
+    Errored          -> debugM "Restarting .." >> runBot botConfig
     Interrupted      -> return ()
     NickNotAvailable -> return ()
     _                -> error "Unsupported status"
@@ -81,8 +89,8 @@ runBot botConfig' = withSocketsDo $ do
 
     handleErrors :: SomeException -> IO BotStatus
     handleErrors e = case fromException e of
-        Just UserInterrupt -> debug "User interrupt"                 >> return Interrupted
+        Just UserInterrupt -> debugM "User interrupt"          >> return Interrupted
-        _                  -> debug ("Exception! " ++ pack (show e)) >> return Errored
+        _                  -> debugM ("Exception! " ++ show e) >> return Errored
 
     runBot_ = bracket (connect botConfig) disconnect $
       \(bot, mvBotStatus, (lineChan, readLatch), (commandChan, sendLatch), eventChannel) ->

Network/IRC/Handlers/MessageLogger.hs

@@ -10,7 +10,7 @@ import qualified Data.Configurator as C
 import qualified Data.Text.Format as TF
 import qualified Data.Text.Format.Params as TF
 
-import ClassyPrelude hiding (try, (</>), (<.>), FilePath, log)
+import ClassyPrelude hiding      ((</>), (<.>), FilePath, log)
 import Control.Concurrent.Lifted (Chan)
 import Control.Exception.Lifted  (mask_)
 import Control.Monad.Reader      (ask)

Network/IRC/Handlers/SongSearch.hs

@@ -3,23 +3,27 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Network.IRC.Handlers.SongSearch (mkMsgHandler) where
 
 import qualified Data.Configurator as CF
+import qualified System.Log.Logger as HSL
 
-import ClassyPrelude hiding      (try)
+import ClassyPrelude
 import Control.Concurrent.Lifted (Chan)
-import Control.Exception.Lifted  (try, evaluate)
+import Control.Exception.Lifted  (evaluate)
 import Control.Monad.Reader      (ask)
 import Data.Aeson                (FromJSON, parseJSON, Value (..), (.:))
 import Data.Aeson.Types          (emptyArray)
 import Data.Text                 (strip)
 import Network.Curl.Aeson        (curlAesonGet, CurlAesonException)
 import Network.HTTP.Base         (urlEncode)
+import System.Log.Logger.TH      (deriveLoggers)
 
 import Network.IRC.Types
-import Network.IRC.Util
+
+$(deriveLoggers "HSL" [HSL.ERROR])
 
 mkMsgHandler :: BotConfig -> Chan SomeEvent -> MsgHandlerName -> IO (Maybe MsgHandler)
 mkMsgHandler _ _ "songsearch" = return . Just $ newMsgHandler { onMessage = songSearch }
@@ -42,7 +46,7 @@ songSearch ChannelMsg { .. }
         mApiKey <- CF.lookup config "songsearch.tinysong_apikey"
         map (Just . ChannelMsgReply) $ case mApiKey of
           Nothing     -> do
-            debug "tinysong api key not found in config"
+            errorM "tinysong api key not found in config"
             return $ "Error while searching for " ++ query
           Just apiKey -> do
             let apiUrl = "http://tinysong.com/b/" ++ urlEncode (unpack query)

Network/IRC/Types.hs

@@ -28,7 +28,7 @@ module Network.IRC.Types
   , newMsgHandler
   , handleMessage
   , handleEvent
-  , stopMsgHandler)
+  , stopMsgHandler )
 where
 
 import ClassyPrelude

Network/IRC/Util.hs

@@ -4,8 +4,8 @@
 
 module Network.IRC.Util where
 
-import qualified Data.Text.Format as TF
+--import qualified Data.Text.Format as TF
-import qualified Data.Text.Format.Params as TF
+--import qualified Data.Text.Format.Params as TF
 
 import ClassyPrelude
 import Control.Concurrent.Lifted (Chan)
@@ -13,11 +13,6 @@ import Control.Concurrent.Lifted (Chan)
 oneSec :: Int
 oneSec = 1000000
 
-debug :: Text -> IO ()
-debug msg = do
-  time <- getCurrentTime
-  TF.print "[{}] {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, msg)
-
 type Latch = MVar ()
 
 latchIt :: Latch -> IO ()

hask-irc.cabal

@@ -51,23 +51,25 @@ cabal-version:       >=1.10
 library
   other-extensions:    Safe
 
-  build-depends:       base           >=4.5 && <4.8,
+  build-depends:       base              >=4.5 && <4.8,
-                       text           >=0.11 && <0.12,
+                       text              >=0.11 && <0.12,
-                       mtl            >=2.1 && <2.2,
+                       mtl               >=2.1 && <2.2,
-                       network        >=2.3 && <2.5,
+                       network           >=2.3 && <2.5,
-                       configurator   >= 0.2,
+                       configurator      >= 0.2,
-                       time           >=1.4.0,
+                       time              >=1.4.0,
-                       curl-aeson     ==0.0.3,
+                       curl-aeson        ==0.0.3,
-                       aeson          >=0.6.0.0,
+                       aeson             >=0.6.0.0,
-                       HTTP           >=4000,
+                       HTTP              >=4000,
-                       transformers   >=0.3,
+                       transformers      >=0.3,
-                       classy-prelude ==0.9.1,
+                       classy-prelude    ==0.9.1,
-                       text-format    >= 0.3.1,
+                       text-format       >= 0.3.1,
-                       filepath       >=1.3,
+                       filepath          >=1.3,
-                       directory      >=1.2,
+                       directory         >=1.2,
-                       lifted-base    >=0.2,
+                       lifted-base       >=0.2,
-                       unix           >=2.7,
+                       unix              >=2.7,
-                       convertible    >=1.1
+                       convertible       >=1.1,
+                       hslogger          >=1.2.4,
+                       hslogger-template >=2.0
 
   exposed-modules:     Network.IRC.Types, Network.IRC.Protocol,
                        Network.IRC.Handlers, Network.IRC.Client
@@ -88,23 +90,25 @@ executable hask-irc
   other-extensions:    Safe
 
   -- Other library packages from which modules are imported.
-  build-depends:       base           >=4.5 && <4.8,
+  build-depends:       base              >=4.5 && <4.8,
-                       text           >=0.11 && <0.12,
+                       text              >=0.11 && <0.12,
-                       mtl            >=2.1 && <2.2,
+                       mtl               >=2.1 && <2.2,
-                       network        >=2.3 && <2.5,
+                       network           >=2.3 && <2.5,
-                       configurator   >= 0.2,
+                       configurator      >= 0.2,
-                       time           >=1.4.0,
+                       time              >=1.4.0,
-                       curl-aeson     ==0.0.3,
+                       curl-aeson        ==0.0.3,
-                       aeson          >=0.6.0.0,
+                       aeson             >=0.6.0.0,
-                       HTTP           >=4000,
+                       HTTP              >=4000,
-                       transformers   >=0.3,
+                       transformers      >=0.3,
-                       classy-prelude ==0.9.1,
+                       classy-prelude    ==0.9.1,
-                       text-format    >= 0.3.1,
+                       text-format       >= 0.3.1,
-                       filepath       >=1.3,
+                       filepath          >=1.3,
-                       directory      >=1.2,
+                       directory         >=1.2,
-                       lifted-base    >=0.2,
+                       lifted-base       >=0.2,
-                       unix           >=2.7,
+                       unix              >=2.7,
-                       convertible    >=1.1
+                       convertible       >=1.1,
+                       hslogger          >=1.2.4,
+                       hslogger-template >=2.0
 
   -- Directories containing source files.
   -- hs-source-dirs: