lambdabot-irc-plugins 5.0.3 → 5.1
raw patch · 4 files changed
+108/−46 lines, 4 filesdep ~lambdabot-corePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: lambdabot-core
API changes (from Hackage documentation)
Files
- lambdabot-irc-plugins.cabal +5/−4
- src/Lambdabot/Config/IRC.hs +11/−0
- src/Lambdabot/Plugin/IRC/IRC.hs +89/−38
- src/Lambdabot/Plugin/IRC/Log.hs +3/−4
lambdabot-irc-plugins.cabal view
@@ -1,5 +1,5 @@ name: lambdabot-irc-plugins-version: 5.0.3+version: 5.1 license: GPL license-file: LICENSE@@ -26,7 +26,7 @@ build-type: Simple cabal-version: >= 1.8-tested-with: GHC == 7.6.3, GHC == 7.8.3+tested-with: GHC == 7.8.4, GHC == 7.10.3 source-repository head type: git@@ -39,7 +39,8 @@ exposed-modules: Lambdabot.Plugin.IRC - other-modules: Lambdabot.Plugin.IRC.IRC+ other-modules: Lambdabot.Config.IRC+ Lambdabot.Plugin.IRC.IRC Lambdabot.Plugin.IRC.Localtime Lambdabot.Plugin.IRC.Log Lambdabot.Plugin.IRC.Topic@@ -49,7 +50,7 @@ containers >= 0.4, directory >= 1.1, filepath >= 1.3,- lambdabot-core >= 5.0.3 && < 5.1,+ lambdabot-core >= 5.1 && < 5.2, lifted-base >= 0.2, mtl >= 2, network >= 2.3.0.13,
+ src/Lambdabot/Config/IRC.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}+module Lambdabot.Config.IRC+ ( reconnectDelay+ ) where++import Lambdabot.Config++config "reconnectDelay" [t| Int |] [| 10000000 |]
src/Lambdabot/Plugin/IRC/IRC.hs view
@@ -7,15 +7,18 @@ import Lambdabot.Monad import Lambdabot.Plugin import Lambdabot.Util+import Lambdabot.Config.IRC import Control.Concurrent.Lifted import qualified Control.Concurrent.SSem as SSem import Control.Exception.Lifted as E (SomeException(..), throwIO, catch) import Control.Monad import Control.Monad.Trans+import Control.Monad.State import qualified Data.ByteString.Char8 as P import Data.List import Data.List.Split+import qualified Data.Map as M import Network( connectTo, PortID(..) ) import System.IO import System.Timeout.Lifted@@ -41,6 +44,17 @@ lift (online tag hostn pn nickn (intercalate " " uix)) _ -> say "Not enough parameters!" }+ , (command "irc-persist-connect")+ { privileged = True+ , help = say "irc-persist-connect tag host portnum nickname userinfo. connect to an irc server and reconnect on network failures"+ , process = \rest ->+ case splitOn " " rest of+ tag:hostn:portn:nickn:uix -> do+ pn <- (PortNumber . fromInteger) `fmap` readM portn+ lift (online tag hostn pn nickn (intercalate " " uix))+ lift $ lift $ modify $ \state' -> state' { ircPersists = M.insert tag True $ ircPersists state' }+ _ -> say "Not enough parameters!"+ } , (command "irc-password") { privileged = True , help = say "irc-password pwd. set password for next irc-connect command"@@ -125,42 +139,77 @@ online :: String -> String -> PortID -> String -> String -> IRC () online tag hostn portnum nickn ui = do- sock <- io $ connectTo hostn portnum- io $ hSetBuffering sock NoBuffering- -- Implements flood control: RFC 2813, section 5.8- sem1 <- io $ SSem.new 0- sem2 <- io $ SSem.new 4 -- one extra token stays in the MVar- sendmv <- io newEmptyMVar- pongref <- io $ newIORef False- io . void . fork . forever $ do- SSem.wait sem1- threadDelay 2000000- SSem.signal sem2- io . void . fork . forever $ do- SSem.wait sem2- putMVar sendmv ()- SSem.signal sem1- E.catch - (addServer tag (io . sendMsg sock sendmv))- (\err@SomeException{} -> io (hClose sock) >> E.throwIO err) pwd <- password `fmap` readMS modifyMS $ \ms -> ms{ password = Nothing }- lb $ ircSignOn hostn (Nick tag nickn) pwd ui- lb . void . fork $ E.catch- (readerLoop tag nickn pongref sock)- (\e@SomeException{} -> do- errorM (show e)- remServer tag)- lb . void . fork $ E.catch- (pingPongDelay >> pingPongLoop tag hostn pongref sock)- (\e@SomeException{} -> do- errorM (show e)- remServer tag) -pingPongDelay :: LB ()+ let online' = do+ sock <- io $ connectTo hostn portnum+ io $ hSetBuffering sock NoBuffering+ -- Implements flood control: RFC 2813, section 5.8+ sem1 <- io $ SSem.new 0+ sem2 <- io $ SSem.new 4 -- one extra token stays in the MVar+ sendmv <- io newEmptyMVar+ pongref <- io $ newIORef False+ io . void . fork . forever $ do+ SSem.wait sem1+ threadDelay 2000000+ SSem.signal sem2+ io . void . fork . forever $ do+ SSem.wait sem2+ putMVar sendmv ()+ SSem.signal sem1+ fin <- io $ SSem.new 0+ E.catch+ (registerServer tag (io . sendMsg sock sendmv fin))+ (\err@SomeException{} -> io (hClose sock) >> E.throwIO err)+ lb $ ircSignOn hostn (Nick tag nickn) pwd ui+ ready <- io $ SSem.new 0+ lb $ void $ forkFinally+ (E.catch+ (readerLoop tag nickn pongref sock ready)+ (\e@SomeException{} -> errorM (show e)))+ (const $ io $ SSem.signal fin)+ void $ forkFinally+ (E.catch+ (pingPongDelay >> pingPongLoop tag hostn pongref sock)+ (\e@SomeException{} -> errorM (show e)))+ (const $ io $ SSem.signal fin)+ void $ fork $ do+ io $ SSem.wait fin+ unregisterServer tag+ io $ hClose sock+ io $ SSem.signal ready+ delay <- getConfig reconnectDelay+ let retry = do+ continue <- lift $ gets $ \st -> (M.member tag $ ircPersists st) && not (M.member tag $ ircServerMap st)+ if continue+ then do+ E.catch online'+ (\e@SomeException{} -> do+ errorM (show e)+ io $ threadDelay delay+ retry+ )+ else do+ chans <- lift $ gets ircChannels+ forM_ (M.keys chans) $ \chan ->+ when (nTag (getCN chan) == tag) $+ lift $ modify $ \state' -> state' { ircChannels = M.delete chan $ ircChannels state' }++ retry+ watch <- io $ fork $ do+ threadDelay 10000000+ errorM "Welcome timeout!"+ SSem.signal fin+ io $ SSem.wait ready+ killThread watch++ online'++pingPongDelay :: IRC () pingPongDelay = io $ threadDelay 120000000 -pingPongLoop :: String -> String -> IORef Bool -> Handle -> LB ()+pingPongLoop :: String -> String -> IORef Bool -> Handle -> IRC () pingPongLoop tag hostn pongref sock = do io $ writeIORef pongref False io $ P.hPut sock $ P.pack $ "PING " ++ hostn ++ "\r\n"@@ -168,10 +217,10 @@ pong <- io $ readIORef pongref if pong then pingPongLoop tag hostn pongref sock- else errorM "Ping timeout." >> remServer tag+ else errorM "Ping timeout." -readerLoop :: String -> String -> IORef Bool -> Handle -> LB ()-readerLoop tag nickn pongref sock = forever $ do+readerLoop :: String -> String -> IORef Bool -> Handle -> SSem.SSem -> LB ()+readerLoop tag nickn pongref sock ready = forever $ do line <- io $ hGetLine sock let line' = filter (`notElem` "\r\n") line if "PING " `isPrefixOf` line'@@ -180,11 +229,13 @@ let msg = decodeMessage tag nickn line' if ircMsgCommand msg == "PONG" then io $ writeIORef pongref True- else received msg+ else do+ when (ircMsgCommand msg == "001") $ io $ SSem.signal ready+ received msg -sendMsg :: Handle -> MVar () -> IrcMessage -> IO ()-sendMsg sock mv msg =+sendMsg :: Handle -> MVar () -> SSem.SSem -> IrcMessage -> IO ()+sendMsg sock mv fin msg = E.catch (do takeMVar mv P.hPut sock $ P.pack $ encodeMessage msg "\r\n") (\err -> do errorM (show (err :: IOError))- hClose sock)+ SSem.signal fin)
src/Lambdabot/Plugin/IRC/Log.hs view
@@ -7,9 +7,9 @@ -- module Lambdabot.Plugin.IRC.Log (logPlugin) where -import Lambdabot.Bot import Lambdabot.Compat.FreenodeNick import Lambdabot.IRC+import Lambdabot.Monad import qualified Lambdabot.Message as Msg import Lambdabot.Nick import Lambdabot.Plugin@@ -64,12 +64,11 @@ , moduleExit = cleanLogState , moduleInit = do let doLog f m hdl = logString hdl . show . f m- wrapCB f = bindModule1 $ \msg -> do+ connect signal cb = registerCallback signal $ \msg -> do now <- io getCurrentTime -- map over the channels this message was directed to, adding to each -- of their log files.- mapM_ (withValidLog (doLog f msg) now) (Msg.channels msg)- connect signal cb = ircSignalConnect signal =<< wrapCB cb+ mapM_ (withValidLog (doLog cb msg) now) (Msg.channels msg) connect "PRIVMSG" msgCB connect "JOIN" joinCB