module Lambdabot.Plugin.IRC.IRC (ircPlugin) where
import Lambdabot.IRC
import Lambdabot.Logging
import Lambdabot.Monad
import Lambdabot.Plugin
import Lambdabot.Util
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 qualified Data.ByteString.Char8 as P
import Data.List
import Data.List.Split
import Network( connectTo, PortID(..) )
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 <- (PortNumber . fromInteger) `fmap` readM portn
lift (online tag hostn pn nickn (intercalate " " uix))
_ -> 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 }
}
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
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
online :: String -> String -> PortID -> String -> String -> IRC ()
online tag hostn portnum nickn ui = do
sock <- io $ connectTo hostn portnum
io $ hSetBuffering sock NoBuffering
sem1 <- io $ SSem.new 0
sem2 <- io $ SSem.new 4
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 ()
pingPongDelay = io $ threadDelay 120000000
pingPongLoop :: String -> String -> IORef Bool -> Handle -> LB ()
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." >> remServer tag
readerLoop :: String -> String -> IORef Bool -> Handle -> LB ()
readerLoop tag nickn pongref sock = 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 received msg
sendMsg :: Handle -> MVar () -> IrcMessage -> IO ()
sendMsg sock mv msg =
E.catch (do takeMVar mv
P.hPut sock $ P.pack $ encodeMessage msg "\r\n")
(\err -> do errorM (show (err :: IOError))
hClose sock)