A simple IRC bot written in Haskell
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

Client.hs 8.2KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196
  1. {-|
  2. Module : Network.IRC.Client
  3. Description : The IRC bot client used to create and run a bot.
  4. Copyright : (c) Abhinav Sarkar, 2014
  5. License : Apache-2.0
  6. Maintainer : abhinav@abhinavsarkar.net
  7. Stability : experimental
  8. Portability : POSIX
  9. -}
  10. {-# LANGUAGE TemplateHaskell #-}
  11. module Network.IRC.Client (runBot) where
  12. import qualified System.Log.Logger as HSL
  13. import ClassyPrelude
  14. import Control.Concurrent.Lifted (fork, threadDelay, myThreadId)
  15. import Control.Exception.Lifted (throwTo, AsyncException (UserInterrupt))
  16. import Network (PortID (PortNumber), connectTo, withSocketsDo)
  17. import System.IO (hSetBuffering, BufferMode(..))
  18. import System.Log.Formatter (tfLogFormatter)
  19. import System.Log.Handler (setFormatter)
  20. import System.Log.Handler.Simple (streamHandler)
  21. import System.Log.Logger (Priority (..), updateGlobalLogger, rootLoggerName,
  22. setHandlers, setLevel)
  23. import System.Log.Logger.TH (deriveLoggers)
  24. import System.Posix.Signals (installHandler, sigINT, sigTERM, Handler (Catch))
  25. import Network.IRC.Bot
  26. import Network.IRC.Internal.Types
  27. import Network.IRC.MessageBus
  28. import Network.IRC.Types
  29. import Network.IRC.Handlers.Core
  30. import Network.IRC.Util
  31. $(deriveLoggers "HSL" [HSL.DEBUG, HSL.ERROR])
  32. data ConnectionResource = ConnectionResource
  33. { bot :: !Bot
  34. , botStatus :: !(MVar BotStatus) -- TODO: is this really needed
  35. , inChannel :: !(MessageChannel In)
  36. , mainMsgChannel :: !(MessageChannel Message)
  37. , handlerMsgChannels :: !(Map MsgHandlerName (MessageChannel Message))
  38. }
  39. connect :: BotConfig -> IO ConnectionResource
  40. connect botConfig@BotConfig { .. } = do
  41. debugM "Connecting ..."
  42. socket <- connectToWithRetry
  43. hSetBuffering socket LineBuffering
  44. debugM "Connected"
  45. messageBus <- newMessageBus
  46. inBus <- newMessageBus
  47. mvBotStatus <- newMVar Connected
  48. inChannel <- newMessageChannel inBus
  49. mainMsgChannel <- newMessageChannel messageBus
  50. msgHandlersChans <- loadMsgHandlers messageBus
  51. msgHandlerInfo' <- flip (`foldM` mempty) (mapToList msgHandlersChans)
  52. $ \handlerInfo (handlerName, (handler, _)) -> do
  53. handlerHelp <- getHelp handler botConfig
  54. return $ insertMap handlerName handlerHelp handlerInfo
  55. let botConfig' = botConfig { msgHandlerInfo = msgHandlerInfo'}
  56. let msgHandlerChannels = map snd msgHandlersChans
  57. let msgHandlers = map fst msgHandlersChans
  58. return ConnectionResource { bot = (Bot botConfig' socket msgHandlers)
  59. , botStatus = mvBotStatus
  60. , inChannel = inChannel
  61. , mainMsgChannel = mainMsgChannel
  62. , handlerMsgChannels = msgHandlerChannels
  63. }
  64. where
  65. connectToWithRetry = connectTo (unpack botServer) (PortNumber (fromIntegral botPort))
  66. `catch` (\(e :: SomeException) -> do
  67. errorM ("Error while connecting: " ++ show e ++ ". Retrying.")
  68. threadDelay (5 * oneSec)
  69. connectToWithRetry)
  70. mkMsgHandler name messageBus =
  71. case lookup name msgHandlerMakers of
  72. Nothing -> return Nothing
  73. Just maker -> do
  74. messageChannel <- newMessageChannel messageBus
  75. handler <- msgHandlerMaker maker botConfig messageChannel
  76. return $ Just (handler, messageChannel)
  77. loadMsgHandlers messageBus =
  78. flip (`foldM` mempty) (mapKeys msgHandlerInfo) $ \hMap msgHandlerName -> do
  79. debugM . unpack $ "Loading msg handler: " ++ msgHandlerName
  80. mMsgHandler <- mkMsgHandler msgHandlerName messageBus
  81. case mMsgHandler of
  82. Nothing -> do
  83. debugM . unpack $ "No msg handler found with name: " ++ msgHandlerName
  84. return hMap
  85. Just msgHandlerAndChannel -> return $ insertMap msgHandlerName msgHandlerAndChannel hMap
  86. disconnect :: ConnectionResource -> IO ()
  87. disconnect ConnectionResource { bot = Bot { .. }, .. } = do
  88. debugM "Disconnecting ..."
  89. sendMessage mainMsgChannel =<< newMessage QuitCmd
  90. awaitMessageChannel mainMsgChannel
  91. swapMVar botStatus Disconnected
  92. awaitMessageChannel inChannel
  93. forM_ handlerMsgChannels awaitMessageChannel
  94. handle (\(_ :: SomeException) -> return ()) $ hClose botSocket
  95. debugM "Disconnected"
  96. runBotIntenal :: BotConfig -> IO ()
  97. runBotIntenal botConfig' = withSocketsDo $ do
  98. status <- run
  99. case status of
  100. Disconnected -> debugM "Restarting .." >> runBotIntenal botConfigWithCore
  101. Errored -> debugM "Restarting .." >> runBotIntenal botConfigWithCore
  102. NickNotAvailable -> debugM "Trying new nick" >> runBotIntenal botConfigWithNewNick
  103. NickAvailable -> debugM "Trying original nick" >> runBotIntenal botConfigWithOrigNick
  104. Interrupted -> return ()
  105. _ -> error "Unsupported status"
  106. where
  107. botConfigWithCore = botConfig' {
  108. msgHandlerInfo =
  109. foldl' (flip (`insertMap` mempty)) mempty
  110. (hashNub $ mapKeys (msgHandlerInfo botConfig') ++ mapKeys coreMsgHandlerMakers)
  111. , msgHandlerMakers = coreMsgHandlerMakers <> msgHandlerMakers botConfig'
  112. }
  113. botConfigWithNewNick = botConfigWithCore {
  114. botNick = Nick $ nickToText (botNick botConfigWithCore) ++ "_"
  115. }
  116. botConfigWithOrigNick = botConfigWithCore {
  117. botNick = botOrigNick botConfigWithCore
  118. }
  119. handleErrors :: SomeException -> IO BotStatus
  120. handleErrors e = case fromException e of
  121. Just UserInterrupt -> debugM "User interrupt" >> return Interrupted
  122. _ -> debugM ("Exception! " ++ show e) >> return Errored
  123. -- TODO: handle handler errors?
  124. runHandler :: BotConfig -> (MsgHandlerName, (MsgHandler, MessageChannel Message)) -> IO ()
  125. runHandler botConfig (msgHandlerName, (handler, msgChannel)) = go =<< receiveMessage msgChannel
  126. where
  127. go msg@Message { .. }
  128. | Just QuitCmd <- fromMessage message = do
  129. debugM . unpack $ "Stopping msg handler: " ++ msgHandlerName
  130. stopMsgHandler handler botConfig
  131. closeMessageChannel msgChannel
  132. | otherwise = do
  133. resps <- handleMessage handler botConfig msg
  134. forM_ resps $ sendMessage msgChannel
  135. runHandler botConfig (msgHandlerName, (handler, msgChannel))
  136. run = bracket (connect botConfigWithCore) disconnect $
  137. \ConnectionResource { .. } ->
  138. handle handleErrors $ do
  139. let Bot { .. } = bot
  140. debugM $ "Running with config:\n" ++ show botConfig
  141. sendMessage mainMsgChannel =<< newMessage NickCmd
  142. sendMessage mainMsgChannel =<< newMessage UserCmd
  143. fork $ sendCommandLoop mainMsgChannel bot
  144. `catch` (\(e :: SomeException) -> errorM $ "Error in sendCommandLoop: " ++ show e)
  145. fork $ readMessageLoop botStatus inChannel bot oneSec
  146. `catch` (\(e :: SomeException) -> errorM $ "Error in readMessageLoop: " ++ show e)
  147. forM_ (mapToList . asMap $ mergeMaps msgHandlers handlerMsgChannels) $
  148. void . fork . runHandler botConfig
  149. runIRC bot Connected $ messageProcessLoop inChannel mainMsgChannel
  150. -- | Creates and runs an IRC bot for given the config. This IO action runs forever.
  151. runBot :: BotConfig -- ^ The bot config used to create the bot.
  152. -> IO ()
  153. runBot botConfig = do
  154. -- setup signal handling
  155. mainThreadId <- myThreadId
  156. let interruptMainThread = throwTo mainThreadId UserInterrupt
  157. installHandler sigINT (Catch interruptMainThread) Nothing
  158. installHandler sigTERM (Catch interruptMainThread) Nothing
  159. -- setup logging
  160. hSetBuffering stdout LineBuffering
  161. hSetBuffering stderr LineBuffering
  162. stderrHandler <- streamHandler stderr DEBUG >>= \logHandler ->
  163. return . setFormatter logHandler $
  164. tfLogFormatter "%F %T" "[$utcTime] $loggername $prio $msg"
  165. updateGlobalLogger rootLoggerName (setHandlers [stderrHandler] . setLevel DEBUG)
  166. -- run
  167. runBotIntenal botConfig