abhin4v
/
hask-irc
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Switched to hslogger based logging

master
Abhinav Sarkar 2014-05-22 01:08:36 +05:30
parent 13154a254a
commit cb40b9c4d3
8 changed files with 128 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
Main.hs
View File

@ -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

64
Network/IRC/Bot.hs
View File

@ -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

36
Network/IRC/Client.hs
View File

@ -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) ->

2
Network/IRC/Handlers/MessageLogger.hs
View File

@ -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)

12
Network/IRC/Handlers/SongSearch.hs
View File

@ -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)

2
Network/IRC/Types.hs
View File

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

9
Network/IRC/Util.hs
View File

@ -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 ()

72
hask-irc.cabal
View File

@ -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: