module Lambdabot.Plugin.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
type IRC = ModuleT () LB
ircPlugin :: Module ()
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!"
}
]
}
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 -> String -> LB ()
ircSignOn svr nickn ircname = do
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
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)
lb $ ircSignOn hostn (Nick tag nickn) ui
lb . void . fork $ E.catch
(readerLoop tag nickn sock)
(\e@SomeException{} -> do
errorM (show e)
remServer tag)
readerLoop :: String -> String -> Handle -> LB ()
readerLoop tag nickn sock = forever $ do
line <- io $ hGetLine sock
let line' = filter (`notElem` "\r\n") line
if "PING " `isPrefixOf` line'
then io $ hPutStr sock ("PONG " ++ drop 5 line' ++ "\r\n")
else void . fork . void . timeout 15000000 $ received (decodeMessage tag nickn line')
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)