From cb40b9c4d311bfca055c292fea5bd13306c665de Mon Sep 17 00:00:00 2001 From: Abhinav Sarkar Date: Thu, 22 May 2014 01:08:36 +0530 Subject: [PATCH] Switched to hslogger based logging --- Main.hs | 17 ++++++- Network/IRC/Bot.hs | 64 +++++++++++++++--------- Network/IRC/Client.hs | 36 ++++++++------ Network/IRC/Handlers/MessageLogger.hs | 2 +- Network/IRC/Handlers/SongSearch.hs | 12 +++-- Network/IRC/Types.hs | 2 +- Network/IRC/Util.hs | 9 +--- hask-irc.cabal | 72 ++++++++++++++------------- 8 files changed, 128 insertions(+), 86 deletions(-) diff --git a/Main.hs b/Main.hs index f7c6db5..c61b899 100644 --- a/Main.hs +++ b/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 ++ " " 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 diff --git a/Network/IRC/Bot.hs b/Network/IRC/Bot.hs index 037df0b..e0dc9f2 100644 --- a/Network/IRC/Bot.hs +++ b/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 - Nothing -> return () - Just line -> do - TF.hprint socket "{}\r\n" $ TF.Only line - TF.print "[{}] > {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, line) - case cmd of - QuitCmd -> latchIt latch - _ -> sendCommandLoop (commandChan, latch) bot + handle (\(e :: SomeException) -> + errorM ("Error while writing to connection: " ++ show e) >> latchIt latch) $ do + case mline of + Nothing -> return () + Just line -> do + TF.hprint socket "{}\r\n" $ TF.Only line + infoM . unpack $ "> " ++ line + 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 - Just line -> writeChan lineChan line + Left (e :: SomeException) -> do + 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 - KickMsg { .. } | kickedNick == nick -> debug "Kicked" >> return Kicked + JoinMsg { .. } | userNick user == nick -> infoM "Joined" >> return Joined + 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 diff --git a/Network/IRC/Client.hs b/Network/IRC/Client.hs index 0ba26ab..8ba3e2e 100644 --- a/Network/IRC/Client.hs +++ b/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 - debug "Disconnected" + handle (\(_ :: SomeException) -> return ()) $ hClose socket + 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 - Errored -> debug "Restarting .." >> runBot botConfig + Disconnected -> debugM "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 - _ -> debug ("Exception! " ++ pack (show e)) >> return Errored + Just UserInterrupt -> debugM "User interrupt" >> return Interrupted + _ -> debugM ("Exception! " ++ show e) >> return Errored runBot_ = bracket (connect botConfig) disconnect $ \(bot, mvBotStatus, (lineChan, readLatch), (commandChan, sendLatch), eventChannel) -> diff --git a/Network/IRC/Handlers/MessageLogger.hs b/Network/IRC/Handlers/MessageLogger.hs index 7c4857c..00b940d 100644 --- a/Network/IRC/Handlers/MessageLogger.hs +++ b/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) diff --git a/Network/IRC/Handlers/SongSearch.hs b/Network/IRC/Handlers/SongSearch.hs index c6ce6fa..e31be0c 100644 --- a/Network/IRC/Handlers/SongSearch.hs +++ b/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) diff --git a/Network/IRC/Types.hs b/Network/IRC/Types.hs index b812082..42a4a6f 100644 --- a/Network/IRC/Types.hs +++ b/Network/IRC/Types.hs @@ -28,7 +28,7 @@ module Network.IRC.Types , newMsgHandler , handleMessage , handleEvent - , stopMsgHandler) + , stopMsgHandler ) where import ClassyPrelude diff --git a/Network/IRC/Util.hs b/Network/IRC/Util.hs index 6b37c5e..0298a4e 100644 --- a/Network/IRC/Util.hs +++ b/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.Params as TF +--import qualified Data.Text.Format 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 () diff --git a/hask-irc.cabal b/hask-irc.cabal index 9564ffd..5017912 100644 --- a/hask-irc.cabal +++ b/hask-irc.cabal @@ -51,23 +51,25 @@ cabal-version: >=1.10 library other-extensions: Safe - build-depends: base >=4.5 && <4.8, - text >=0.11 && <0.12, - mtl >=2.1 && <2.2, - network >=2.3 && <2.5, - configurator >= 0.2, - time >=1.4.0, - curl-aeson ==0.0.3, - aeson >=0.6.0.0, - HTTP >=4000, - transformers >=0.3, - classy-prelude ==0.9.1, - text-format >= 0.3.1, - filepath >=1.3, - directory >=1.2, - lifted-base >=0.2, - unix >=2.7, - convertible >=1.1 + build-depends: base >=4.5 && <4.8, + text >=0.11 && <0.12, + mtl >=2.1 && <2.2, + network >=2.3 && <2.5, + configurator >= 0.2, + time >=1.4.0, + curl-aeson ==0.0.3, + aeson >=0.6.0.0, + HTTP >=4000, + transformers >=0.3, + classy-prelude ==0.9.1, + text-format >= 0.3.1, + filepath >=1.3, + directory >=1.2, + lifted-base >=0.2, + unix >=2.7, + 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, - text >=0.11 && <0.12, - mtl >=2.1 && <2.2, - network >=2.3 && <2.5, - configurator >= 0.2, - time >=1.4.0, - curl-aeson ==0.0.3, - aeson >=0.6.0.0, - HTTP >=4000, - transformers >=0.3, - classy-prelude ==0.9.1, - text-format >= 0.3.1, - filepath >=1.3, - directory >=1.2, - lifted-base >=0.2, - unix >=2.7, - convertible >=1.1 + build-depends: base >=4.5 && <4.8, + text >=0.11 && <0.12, + mtl >=2.1 && <2.2, + network >=2.3 && <2.5, + configurator >= 0.2, + time >=1.4.0, + curl-aeson ==0.0.3, + aeson >=0.6.0.0, + HTTP >=4000, + transformers >=0.3, + classy-prelude ==0.9.1, + text-format >= 0.3.1, + filepath >=1.3, + directory >=1.2, + lifted-base >=0.2, + unix >=2.7, + convertible >=1.1, + hslogger >=1.2.4, + hslogger-template >=2.0 -- Directories containing source files. -- hs-source-dirs: