{-# LANGUAGE PatternGuards, BangPatterns, DeriveDataTypeable, OverloadedStrings, ScopedTypeVariables #-}
{- |
IRC stuff
Copyright (c) Don Stewart 2008-2009, Simon Michael 2009-2011
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