1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198
|
{-# LANGUAGE PatternGuards, BangPatterns, DeriveDataTypeable, OverloadedStrings, ScopedTypeVariables #-}
{- |
IRC stuff
Copyright (c) Don Stewart 2008-2009, Simon Michael 2009-2014
License: BSD3.
-}
module Irc where
import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.List
import Data.Maybe
import Data.Time.Clock (getCurrentTime,diffUTCTime)
import Network (PortID(PortNumber), connectTo)
import Network.IRC (Message(Message),msg_command,msg_params,decode,encode,nick,user,joinChan,privmsg)
import Prelude hiding (log)
import System.IO (BufferMode(NoBuffering),stdout,hSetBuffering,hFlush,hClose,hGetLine,hPutStr)
import Text.Printf
import Base
import Utils
-- | Connect to the irc server.
connect :: App -> IO App
connect !app@App{aOpts=opts, aBot=bot@Bot{server=srv,port=p,channel=c,botnick=n}} = do
unless (quiet opts) $
log $ n ++ " connecting to " ++
(if null srv then "(simulated)" else printf "%s, channel %s" srv c)
bot' <- if null srv
then return bot
else do
h <- connectTo srv (PortNumber $ fromIntegral p)
hSetBuffering h NoBuffering
return bot{socket=h}
ircWrite opts bot' $ encode $ nick n
ircWrite opts bot' $ encode $ user defusername "0" "*" (ident opts)
(connected,err) <- if null srv then return (True,"")
else ircWaitForConnectConfirmation opts bot' -- some servers require this
unless connected $ throw $ IrcException err
ircWrite opts bot' $ encode $ joinChan c
unless (quiet opts) $ log "connected."
return app{aBot=bot'}
-- | Disconnect from the irc server, if connected.
disconnect :: App -> IO ()
disconnect App{aBot=Bot{server=srv,socket=s}}
| s == stdout = return ()
| otherwise = log (printf "disconnecting from %s" srv) >> hClose s
-- | Wait for server connection confirmation.
ircWaitForConnectConfirmation :: Opts -> Bot -> IO (Bool,String)
ircWaitForConnectConfirmation _ Bot{server=""} = return (True,"")
ircWaitForConnectConfirmation !opts !bot@Bot{socket=h} = do
s <- hGetLine h
when (debug_irc opts) $ log $ printf "<-%s" s
if isPing s
then ircPong opts bot s >> ircWaitForConnectConfirmation opts bot
else if isResponseOK s
then return (True, chomp s)
else if isNotice s
then ircWaitForConnectConfirmation opts bot
else return (False, chomp s)
where
parseRespCode x = if length (words x) > 1 then (words x) !! 1 else "000"
isResponseOK x = (parseRespCode x) `elem` [ "001", "002", "003", "004" ]
isNotice x = (head $ parseRespCode x) `elem` ('0':['a'..'z']++['A'..'Z'])
{-
2011-10-18 13:28:20 PDT: <-PING :niven.freenode.net
2011-10-18 13:28:20 PDT: ->PONG niven.freenode.net
hGetIRCLine :: Handle -> IO MsgString Read an IRC message string.
hGetMessage :: Handle -> IO Message Read the next valid IRC message.
hPutCommand :: Handle -> Command -> IO () Write an IRC command with no origin.
hPutMessage :: Handle -> Message -> IO () Write an IRC message.
-}
-- | Run forever, responding to irc PING commands to keep the bot connected.
-- Also keeps track of the last time a message was sent, for --idle.
ircResponder :: Shared App -> IO ()
ircResponder !appvar = do
app@App{aOpts=opts,aBot=bot@Bot{server=srv,socket=h}} <- getSharedVar appvar
if null srv
then threadDelay (maxBound::Int)
else do
s <- hGetLine h
let s' = init s
when (debug_irc opts) $ log $ printf "<-%s" s'
let respond | isMessage s = do t <- getCurrentTime
putSharedVar appvar app{aBot=bot{lastmsgtime=t}}
| isPing s = ircPong opts bot s'
| otherwise = return ()
respond
ircResponder appvar
-- | Run forever, printing announcements appearing in the bot's announce
-- queue to its irc channel, complying with bot and irc server policies.
-- Specifically:
--
-- - no messages until --idle minutes of silence on the channel
--
-- - no more than 400 chars per message
--
-- - no more than one message per 2s
--
-- - no more than --max-items feed items announced per polling interval
--
-- - no more than --max-items messages per polling interval, except a
-- final item split across multiple messages will be completed.
-- XXX On freenode, six 400-char messages in 2s can still cause a flood.
-- Try limiting chars-per-period, or do ping-pong ?
ircAnnouncer :: Shared App -> IO ()
ircAnnouncer !appvar = do
-- wait for something to announce
App{aBot=Bot{announcequeue=q}} <- getSharedVar appvar
ann <- readChan q
-- re-read bot to get an up-to-date idle time
app@App{aOpts=opts, aBot=bot@Bot{server=srv,batchindex=i}} <- getSharedVar appvar
idletime <- channelIdleTime bot
let batchsize = max_items opts
requiredidle = idle opts -- minutes
pollinterval = interval opts -- minutes
sendinterval = if null srv then 0 else 2 -- seconds
iscontinuation = continuationprefix `isPrefixOf` ann
go | i >= batchsize && not iscontinuation = do
-- reached max batch size, sleep
when (debug_irc opts) $
log $ printf "sent %d messages in this batch, max is %d, sleeping for %dm" i batchsize pollinterval
threadDelay $ pollinterval * minutes
unGetChan q ann
putSharedVar appvar app{aBot=bot{batchindex=0}}
ircAnnouncer appvar
| requiredidle > 0 && (idletime < requiredidle) = do
-- not yet at required idle time, sleep
let idleinterval = requiredidle - idletime
when (debug_irc opts) $ log $
printf "channel has been idle %dm, %dm required, sleeping for %dm" idletime requiredidle idleinterval
threadDelay $ idleinterval * minutes
unGetChan q ann
ircAnnouncer appvar
| otherwise = do
-- ok, announce it
when (debug_irc opts) $ do
let s | requiredidle == 0 = "" :: String
| otherwise = printf " and channel has been idle %dm" idletime
log $ printf "sent %d messages in this batch%s, sending next" i s
let (a,rest) = splitAnnouncement ann
when (not $ null rest) $ unGetChan q rest
ircPrivmsg opts bot a
threadDelay $ sendinterval * seconds
putSharedVar appvar app{aBot=bot{batchindex=i+1}}
ircAnnouncer appvar
go
-- | The time in minutes since the last message on this bot's channel, or
-- otherwise since joining the channel. Leap seconds are ignored.
channelIdleTime :: Bot -> IO Int
channelIdleTime (Bot{lastmsgtime=t1}) = do
t <- getCurrentTime
return $ round (diffUTCTime t t1) `div` 60
-- IRC utils
-- | Send a response to the irc server's ping.
ircPong :: Opts -> Bot -> String -> IO ()
ircPong opts b x = ircWrite opts b $ printf "PONG :%s" (drop 6 x)
-- | Send a privmsg to the bot's irc server & channel, and to stdout unless --quiet is in effect.
ircPrivmsg :: Opts -> Bot -> String -> IO ()
ircPrivmsg opts bot@(Bot{channel=c}) msg = do
ircWrite opts bot $ encode $ privmsg c msg'
unless (quiet opts) $ putStrLn msg >> hFlush stdout
where
msg' | use_actions opts = "\1ACTION " ++ msg ++ "\1"
| otherwise = msg
-- | Send a message to the bot's irc server, and log to the console if --debug-irc is in effect.
ircWrite :: Opts -> Bot -> String -> IO ()
ircWrite opts (Bot{server=srv,socket=h}) s = do
when (debug_irc opts) $ log $ printf "->%s" s -- (B8.unpack $ showCommand c)
unless (null srv) $ hPutStr h (s++"\r\n")
isMessage :: String -> Bool
isMessage s = isPrivmsg s && not ("VERSION" `elem` (msg_params $ fromJust $ decode s))
isPrivmsg :: String -> Bool
isPrivmsg s = case decode s of Just Message{msg_command="PRIVMSG"} -> True
_ -> False
isPing :: String -> Bool
isPing s = case decode s of Just Message{msg_command="PING"} -> True
_ -> False
|