lambdabot-irc-plugins-5.2/0000755000000000000000000000000013461612703013730 5ustar0000000000000000lambdabot-irc-plugins-5.2/LICENSE0000644000000000000000000000225613461612703014742 0ustar0000000000000000Copyright (c) 2003 Andrew J. Bromage Portions Copyright (c) 2003 Shae Erisson, Sven M. Hallberg, Taylor Campbell Portions Copyright (c) 2003-2006 Members of the AUTHORS file Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. lambdabot-irc-plugins-5.2/Setup.hs0000644000000000000000000000014213461612703015361 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMainWithHooks defaultUserHooks lambdabot-irc-plugins-5.2/lambdabot-irc-plugins.cabal0000644000000000000000000000437013461612703021077 0ustar0000000000000000name: lambdabot-irc-plugins version: 5.2 license: GPL license-file: LICENSE author: Don Stewart maintainer: James Cook category: Development, Web synopsis: IRC plugins for lambdabot. description: Lambdabot is an IRC bot written over several years by those on the #haskell IRC channel. . Provided plugins: . [irc] Lets lambdabot connect to IRC. . [localtime] Check user's local time. . [log] Log IRC channels. . [topic] Modify channel topics. homepage: https://wiki.haskell.org/Lambdabot build-type: Simple cabal-version: >= 1.8 tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.1 source-repository head type: git location: https://github.com/lambdabot/lambdabot.git library hs-source-dirs: src ghc-options: -Wall -funbox-strict-fields exposed-modules: Lambdabot.Plugin.IRC other-modules: Lambdabot.Config.IRC Lambdabot.Plugin.IRC.IRC Lambdabot.Plugin.IRC.Localtime Lambdabot.Plugin.IRC.Log Lambdabot.Plugin.IRC.Topic build-depends: base >= 4.4 && < 5, bytestring >= 0.9, containers >= 0.4, directory >= 1.1, filepath >= 1.3, lambdabot-core >= 5.2 && < 5.3, lifted-base >= 0.2, mtl >= 2, network >= 2.7 && < 3.2, SafeSemaphore >= 0.9, split >= 0.2, time >= 1.4 lambdabot-irc-plugins-5.2/src/0000755000000000000000000000000013461612703014517 5ustar0000000000000000lambdabot-irc-plugins-5.2/src/Lambdabot/0000755000000000000000000000000013461612703016404 5ustar0000000000000000lambdabot-irc-plugins-5.2/src/Lambdabot/Plugin/0000755000000000000000000000000013461612703017642 5ustar0000000000000000lambdabot-irc-plugins-5.2/src/Lambdabot/Plugin/IRC.hs0000644000000000000000000000053113461612703020612 0ustar0000000000000000module Lambdabot.Plugin.IRC ( ircPlugin , localtimePlugin , logPlugin , topicPlugin , ircPlugins ) where import Lambdabot.Plugin.IRC.IRC import Lambdabot.Plugin.IRC.Localtime import Lambdabot.Plugin.IRC.Log import Lambdabot.Plugin.IRC.Topic ircPlugins :: [String] ircPlugins = ["irc", "localtime", "log", "topic"] lambdabot-irc-plugins-5.2/src/Lambdabot/Plugin/IRC/0000755000000000000000000000000013461612703020257 5ustar0000000000000000lambdabot-irc-plugins-5.2/src/Lambdabot/Plugin/IRC/Topic.hs0000644000000000000000000000763213461612703021701 0ustar0000000000000000-- | The Topic plugin is an interface for messing with the channel topic. -- It can alter the topic in various ways and keep track of the changes. -- The advantage of having the bot maintain the topic is that we get an -- authoritative source for the current topic, when the IRC server decides -- to delete it due to Network Splits. module Lambdabot.Plugin.IRC.Topic (topicPlugin) where import Lambdabot.IRC import Lambdabot.Monad import Lambdabot.Plugin import Lambdabot.Util import qualified Data.Map as M import Control.Monad.State (gets) type Topic = ModuleT () LB type TopicAction = Nick -> String -> Cmd Topic () data TopicCommand = TopicCommand { _commandAliases :: [String] , _commandHelp :: String , _invokeCommand :: TopicAction } commands :: [TopicCommand] commands = [ TopicCommand ["set-topic"] "Set the topic of the channel, without using all that listy stuff" (installTopic) , TopicCommand ["get-topic"] "Recite the topic of the channel" (reciteTopic) , TopicCommand ["unshift-topic", "queue-topic"] "Add a new topic item to the front of the topic list" (alterListTopic (:)) , TopicCommand ["shift-topic"] "Remove a topic item from the front of the topic list" (alterListTopic (const tail)) , TopicCommand ["push-topic"] "Add a new topic item to the end of the topic stack" (alterListTopic (\arg -> (++ [arg]))) , TopicCommand ["pop-topic", "dequeue-topic"] "Pop an item from the end of the topic stack" (alterListTopic (const init)) , TopicCommand ["clear-topic"] "Empty the topic stack" (alterListTopic (\_ _ -> [])) ] topicPlugin :: Module () topicPlugin = newModule { moduleCmds = return [ (command name) { help = say helpStr , aliases = aliases' , process = \args -> do tgt <- getTarget (chan, rest) <- case splitFirstWord args of (c@('#':_), r) -> do c' <- readNick c return (Just c', r) _ -> case nName tgt of ('#':_) -> return (Just tgt, args) _ -> return (Nothing, args) case chan of Just chan' -> invoke chan' rest Nothing -> say "What channel?" } | TopicCommand (name:aliases') helpStr invoke <- commands ] } ------------------------------------------------------------------------ -- Topic action implementations installTopic :: TopicAction installTopic chan topic = withTopic chan $ \_ -> do lb (send (setTopic chan topic)) reciteTopic :: TopicAction reciteTopic chan "" = withTopic chan $ \topic -> do say (nName chan ++ ": " ++ topic) reciteTopic _ ('#':_) = say "One channel at a time. Jeepers!" reciteTopic _ _ = say "I don't know what all that extra stuff is about." alterTopic :: (String -> String -> String) -> TopicAction alterTopic f chan args = withTopic chan $ \oldTopic -> do lb (send (setTopic chan (f args oldTopic))) alterListTopic :: (String -> [String] -> [String]) -> TopicAction alterListTopic f = alterTopic $ \args topic -> show $ case reads topic of [(xs, "")] -> f args xs _ -> f args [topic] ------------------------------------------------------------------------ lookupTopic :: Nick -> LB (Maybe String) lookupTopic chan = gets (\s -> M.lookup (mkCN chan) (ircChannels s)) -- | 'withTopic' is like 'lookupTopic' except that it ditches the Maybe in -- favor of just yelling at the user when things don't work out as planned. withTopic :: Nick -> (String -> Cmd Topic ()) -> Cmd Topic () withTopic chan f = do maybetopic <- lb (lookupTopic chan) case maybetopic of Just t -> f t Nothing -> say "I don't know that channel." lambdabot-irc-plugins-5.2/src/Lambdabot/Plugin/IRC/Localtime.hs0000644000000000000000000000474413461612703022535 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} -- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons -- GPL version 2 or later (see http://www.gnu.org/copyleft/gpl.html) -- | Simple wrapper over privmsg to get time information via the CTCP module Lambdabot.Plugin.IRC.Localtime (localtimePlugin) where import Lambdabot.Plugin import Lambdabot.Bot (ircPrivmsg') import qualified Data.Map as M type TimeMap = M.Map Nick -- the person who's time we requested [Nick] -- a list of targets waiting on this time localtimePlugin :: Module TimeMap localtimePlugin = newModule { moduleDefState = return M.empty , moduleCmds = return [ (command "time") { aliases = ["localtime"] , help = say "time . Print a user's local time. User's client must support ctcp pings." , process = doLocalTime } , (command "localtime-reply") { help = say "time . Print a user's local time. User's client must support ctcp pings." , process = doReply } ] } :: Module TimeMap -- record this person as a callback, for when we (asynchronously) get a result doLocalTime :: (MonadLBState m, LBState m ~ M.Map Nick [Nick]) => [Char] -> Cmd m () doLocalTime [] = do n <- getSender doLocalTime (nName n) doLocalTime rawWho = do whoAsked <- getTarget whoToPing <- readNick $ fst $ break (== ' ') rawWho me <- getLambdabotName if whoToPing /= me then do modifyMS $ \st -> M.insertWith (++) whoToPing [whoAsked] st -- this is a CTCP time call, which returns a NOTICE lb $ ircPrivmsg' whoToPing ("\^ATIME\^A") -- has to be raw else say "I live on the internet, do you expect me to have a local time?" -- the Base module caught the NOTICE TIME, mapped it to a PRIVMGS, and here it is :) doReply :: (MonadLBState m, LBState m ~ M.Map Nick [Nick]) => [Char] -> Cmd m () doReply text = do let (whoGotPinged', time') = break (== ':') text time = drop 1 time' whoGotPinged <- readNick whoGotPinged' targets <- withMS $ \st set -> do case M.lookup whoGotPinged st of Nothing -> return [] Just xs -> do set (M.insert whoGotPinged [] st) -- clear the callback state return xs whoGotPinged'' <- showNick whoGotPinged let txt = "Local time for " ++ whoGotPinged'' ++ " is " ++ time lb $ flip mapM_ targets $ flip ircPrivmsg' txt lambdabot-irc-plugins-5.2/src/Lambdabot/Plugin/IRC/Log.hs0000644000000000000000000001754013461612703021343 0ustar0000000000000000-- Copyright (c) 2004 Thomas Jaeger -- Copyright (c) 2005 Simon Winwood -- Copyright (c) 2005 Don Stewart -- Copyright (c) 2005 David House -- -- | Logging an IRC channel.. -- module Lambdabot.Plugin.IRC.Log (logPlugin) where import Lambdabot.Compat.FreenodeNick import Lambdabot.IRC import Lambdabot.Monad import qualified Lambdabot.Message as Msg import Lambdabot.Nick import Lambdabot.Plugin import Lambdabot.Util import Control.Monad import qualified Data.Map as M import Data.Time import System.Directory (createDirectoryIfMissing) import System.FilePath import System.IO -- ------------------------------------------------------------------------ type Channel = Nick type DateStamp = (Int, Int, Integer) data ChanState = CS { chanHandle :: Handle, chanDate :: DateStamp } deriving (Show, Eq) type LogState = M.Map Channel ChanState type Log = ModuleT LogState LB data Event = Said Nick UTCTime String | Joined Nick String UTCTime | Parted Nick String UTCTime -- covers quitting as well | Kicked Nick Nick String UTCTime String | Renick Nick String UTCTime Nick | Mode Nick String UTCTime String deriving (Eq) instance Show Event where show (Said nick ct what) = timeStamp ct ++ " <" ++ nName nick ++ "> " ++ what show (Joined nick usr ct) = timeStamp ct ++ " " ++ show (FreenodeNick nick) ++ " (" ++ usr ++ ") joined." show (Parted nick usr ct) = timeStamp ct ++ " " ++ show (FreenodeNick nick) ++ " (" ++ usr ++ ") left." show (Kicked nick op usrop ct reason) = timeStamp ct ++ " " ++ show (FreenodeNick nick) ++ " was kicked by " ++ show (FreenodeNick op) ++ " (" ++ usrop ++ "): " ++ reason ++ "." show (Renick nick usr ct new) = timeStamp ct ++ " " ++ show (FreenodeNick nick) ++ " (" ++ usr ++ ") is now " ++ show (FreenodeNick new) ++ "." show (Mode nick usr ct mode) = timeStamp ct ++ " " ++ show (FreenodeNick nick) ++ " (" ++ usr ++ ") changed mode to " ++ mode ++ "." -- * Dispatchers and Module instance declaration -- logPlugin :: Module (M.Map Channel ChanState) logPlugin = newModule { moduleDefState = return M.empty , moduleExit = cleanLogState , moduleInit = do let doLog f m hdl = logString hdl . show . f m 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 cb msg) now) (Msg.channels msg) connect "PRIVMSG" msgCB connect "JOIN" joinCB connect "PART" partCB connect "KICK" kickCB connect "NICK" nickCB connect "MODE" modeCB } -- * Logging helpers -- -- | Show a number, padded to the left with zeroes up to the specified width showWidth :: Int -- ^ Width to fill to -> Int -- ^ Number to show -> String -- ^ Padded string showWidth width n = zeroes ++ num where num = show n zeroes = replicate (width - length num) '0' timeStamp :: UTCTime -> String timeStamp (UTCTime _ ct) = (showWidth 2 (hours `mod` 24)) ++ ":" ++ (showWidth 2 (mins `mod` 60)) ++ ":" ++ (showWidth 2 (secs `mod` 60)) where secs = round ct :: Int mins = secs `div` 60 hours = mins `div` 60 -- | Show a DateStamp. dateToString :: DateStamp -> String dateToString (d, m, y) = (showWidth 2 $ fromInteger y) ++ "-" ++ (showWidth 2 $ fromEnum m + 1) ++ "-" ++ (showWidth 2 d) -- | UTCTime -> DateStamp conversion dateStamp :: UTCTime -> DateStamp dateStamp (UTCTime day _) = (d, m, y) where (y,m,d) = toGregorian day -- * State manipulation functions -- -- | Cleans up after the module (closes files) cleanLogState :: Log () cleanLogState = withMS $ \state writer -> do io $ M.foldr (\cs iom -> iom >> hClose (chanHandle cs)) (return ()) state writer M.empty -- | Fetch a channel from the internal map. Uses LB's fail if not found. getChannel :: Channel -> Log ChanState getChannel c = (readMS >>=) . mLookup $ c where mLookup k = maybe (fail "getChannel: not found") return . M.lookup k getDate :: Channel -> Log DateStamp getDate c = fmap chanDate . getChannel $ c getHandle :: Channel -> Log Handle getHandle c = fmap chanHandle . getChannel $ c -- add points. otherwise: -- Unbound implicit parameters (?ref::GHC.IOBase.MVar LogState, ?name::String) -- arising from instantiating a type signature at -- Plugin/Log.hs:187:30-39 -- Probable cause: `getChannel' is applied to too few arguments -- | Put a DateStamp and a Handle. Used by 'openChannelFile' and -- 'reopenChannelMaybe'. putHdlAndDS :: Channel -> Handle -> DateStamp -> Log () putHdlAndDS c hdl ds = modifyMS (M.adjust (\cs -> cs {chanHandle = hdl, chanDate = ds}) c) -- * Logging IO -- -- | Open a file to write the log to. openChannelFile :: Channel -> UTCTime -> Log Handle openChannelFile chan ct = do logDir <- lb $ findLBFileForWriting "Log" let dir = logDir nTag chan nName chan file = dir (dateToString date) <.> "txt" io $ createDirectoryIfMissing True dir >> openFile file AppendMode where date = dateStamp ct -- | Close and re-open a log file, and update the state. reopenChannelMaybe :: Channel -> UTCTime -> Log () reopenChannelMaybe chan ct = do date <- getDate chan when (date /= dateStamp ct) $ do hdl <- getHandle chan io $ hClose hdl hdl' <- openChannelFile chan ct putHdlAndDS chan hdl' (dateStamp ct) -- | Initialise the channel state (if it not already inited) initChannelMaybe :: Nick -> UTCTime -> Log () initChannelMaybe chan ct = do chanp <- liftM (M.member chan) readMS unless chanp $ do hdl <- openChannelFile chan ct modifyMS (M.insert chan $ CS hdl (dateStamp ct)) -- | Ensure that the log is correctly initialised etc. withValidLog :: (Handle -> UTCTime -> Log a) -> UTCTime -> Channel -> Log a withValidLog f ct chan = do initChannelMaybe chan ct reopenChannelMaybe chan ct hdl <- getHandle chan rv <- f hdl ct return rv -- | Log a string. Main logging workhorse. logString :: Handle -> String -> Log () logString hdl str = io $ hPutStrLn hdl str >> hFlush hdl -- We flush on each operation to ensure logs are up to date. -- * The event loggers themselves -- -- | When somebody joins. joinCB :: IrcMessage -> UTCTime -> Event joinCB msg ct = Joined (Msg.nick msg) (Msg.fullName msg) ct -- | When somebody quits. partCB :: IrcMessage -> UTCTime -> Event partCB msg ct = Parted (Msg.nick msg) (Msg.fullName msg) ct -- | When somebody is kicked. kickCB :: IrcMessage -> UTCTime -> Event kickCB msg ct = Kicked (Msg.nick msg) { nName = head $ tail $ ircMsgParams msg } (Msg.nick msg) (Msg.fullName msg) ct (tail . concat . tail . tail $ ircMsgParams msg) -- | When somebody changes his\/her name. -- TODO: We should only do this for channels that the user is currently on. nickCB :: IrcMessage -> UTCTime -> Event nickCB msg ct = Renick (Msg.nick msg) (Msg.fullName msg) ct (parseNick (Msg.server msg) $ drop 1 $ head $ ircMsgParams msg) -- | When somebody changes channel mode. modeCB :: IrcMessage -> UTCTime -> Event modeCB msg ct = Mode (Msg.nick msg) (Msg.fullName msg) ct (unwords $ tail $ ircMsgParams msg) -- | When somebody speaks. msgCB :: IrcMessage -> UTCTime -> Event msgCB msg ct = Said (Msg.nick msg) ct (tail . concat . tail $ ircMsgParams msg) -- each lines is :foo lambdabot-irc-plugins-5.2/src/Lambdabot/Plugin/IRC/IRC.hs0000644000000000000000000002317113461612703021234 0ustar0000000000000000-- | The plugin-level IRC interface. module Lambdabot.Plugin.IRC.IRC (ircPlugin) where import Lambdabot.IRC import Lambdabot.Logging 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 Lambdabot.Util.Network (connectTo') import Network.Socket (PortNumber) import System.IO import System.Timeout.Lifted import Data.IORef data IRCState = IRCState { password :: Maybe String } type IRC = ModuleT IRCState LB ircPlugin :: Module IRCState ircPlugin = newModule { moduleCmds = return [ (command "irc-connect") { privileged = True , help = say "irc-connect tag host portnum nickname userinfo. connect to an irc server" , process = \rest -> case splitOn " " rest of tag:hostn:portn:nickn:uix -> do pn <- fromInteger `fmap` readM portn 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 <- 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" , process = \rest -> case splitOn " " rest of pwd:_ -> do modifyMS (\ms -> ms{ password = Just pwd }) _ -> say "Not enough parameters!" } ] , moduleDefState = return $ IRCState{ password = Nothing } } ---------------------------------------------------------------------- -- Encoding and decoding of messages -- | 'encodeMessage' takes a message and converts it to a function. -- giving this function a string will attach the string to the message -- and output a string containing IRC protocol commands ready for writing -- on the outgoing stream socket. encodeMessage :: IrcMessage -> String -> String encodeMessage msg = encodePrefix (ircMsgPrefix msg) . encodeCommand (ircMsgCommand msg) . encodeParams (ircMsgParams msg) where encodePrefix [] = id encodePrefix prefix = showChar ':' . showString' prefix . showChar ' ' encodeCommand cmd = showString cmd encodeParams [] = id encodeParams (p:ps) = showChar ' ' . showString' p . encodeParams ps -- IrcMessage is supposed to contain strings that are lists of bytes, but -- if a plugin messes up the encoding then we may end up with arbitrary -- Unicode codepoints. This is dangerous (\x10a would produce a newline!), -- so we sanitize the message here. showString' = showString . map (\c -> if c > '\xFF' then '?' else c) -- | 'decodeMessage' Takes an input line from the IRC protocol stream -- and decodes it into a message. TODO: this has too many parameters. decodeMessage :: String -> String -> String -> IrcMessage decodeMessage svr lbn line = let (prefix, rest1) = decodePrefix (,) line (cmd, rest2) = decodeCmd (,) rest1 params = decodeParams rest2 in IrcMessage { ircMsgServer = svr, ircMsgLBName = lbn, ircMsgPrefix = prefix, ircMsgCommand = cmd, ircMsgParams = params } where decodePrefix k (':':cs) = decodePrefix' k cs where decodePrefix' j "" = j "" "" decodePrefix' j (' ':ds) = j "" ds decodePrefix' j (c:ds) = decodePrefix' (j . (c:)) ds decodePrefix k cs = k "" cs decodeCmd k [] = k "" "" decodeCmd k (' ':cs) = k "" cs decodeCmd k (c:cs) = decodeCmd (k . (c:)) cs decodeParams :: String -> [String] decodeParams xs = decodeParams' [] [] xs where decodeParams' param params [] | null param = reverse params | otherwise = reverse (reverse param : params) decodeParams' param params (' ' : cs) | null param = decodeParams' [] params cs | otherwise = decodeParams' [] (reverse param : params) cs decodeParams' param params rest@(c@':' : cs) | null param = reverse (rest : params) | otherwise = decodeParams' (c:param) params cs decodeParams' param params (c:cs) = decodeParams' (c:param) params cs ircSignOn :: String -> Nick -> Maybe String -> String -> LB () ircSignOn svr nickn pwd ircname = do maybe (return ()) (\pwd' -> send $ pass (nTag nickn) pwd') pwd send $ user (nTag nickn) (nName nickn) svr ircname send $ setNick nickn ------------------------------------------------------------------------ -- -- Lambdabot is mostly synchronous. We have a main loop, which reads -- messages and forks threads to execute commands (which write responses). -- OR -- We have a main loop which reads offline commands, and synchronously -- interprets them. online :: String -> String -> PortNumber -> String -> String -> IRC () online tag hostn portnum nickn ui = do pwd <- password `fmap` readMS modifyMS $ \ms -> ms{ password = Nothing } 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 -> IRC () pingPongLoop tag hostn pongref sock = do io $ writeIORef pongref False io $ P.hPut sock $ P.pack $ "PING " ++ hostn ++ "\r\n" pingPongDelay pong <- io $ readIORef pongref if pong then pingPongLoop tag hostn pongref sock else errorM "Ping timeout." 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' then io $ P.hPut sock $ P.pack $ "PONG " ++ drop 5 line' ++ "\r\n" else void . fork . void . timeout 15000000 $ do let msg = decodeMessage tag nickn line' if ircMsgCommand msg == "PONG" then io $ writeIORef pongref True else do when (ircMsgCommand msg == "001") $ io $ SSem.signal ready received 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)) SSem.signal fin) lambdabot-irc-plugins-5.2/src/Lambdabot/Config/0000755000000000000000000000000013461612703017611 5ustar0000000000000000lambdabot-irc-plugins-5.2/src/Lambdabot/Config/IRC.hs0000644000000000000000000000043013461612703020557 0ustar0000000000000000{-# 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 |]