module Network.SimpleIRC.Core
(
MIrc
, EventFunc
, IrcConfig(..)
, IrcEvent(..)
, connect
, disconnect
, sendRaw
, sendMsg
, sendCmd
, addEvent
, changeEvents
, remEvent
, defaultConfig
, getDest
, getChannels
, getNickname
, getAddress
, getUsername
, getRealname
) where
import Network
import System.IO
import Data.Maybe
import Data.Char (isNumber)
import Control.Monad
import Control.Concurrent
import Control.Concurrent.Chan
import Control.Concurrent.MVar
import Network.SimpleIRC.Messages
import Data.Unique
import System.IO.Error
import Data.Time
import System.Locale
import qualified Data.ByteString.Char8 as B
import qualified Data.Map as Map
internalEvents = [joinChans, pong, onJoin]
internalNormEvents = [Privmsg ctcpHandler]
type MIrc = MVar IrcServer
data IrcConfig = IrcConfig
{ cAddr :: String
, cPort :: Int
, cNick :: String
, cUsername :: String
, cRealname :: String
, cChannels :: [String]
, cEvents :: [IrcEvent]
, cCTCPVersion :: String
, cCTCPTime :: IO String
}
data SIrcCommand =
SIrcAddEvent (Unique, IrcEvent)
| SIrcChangeEvents (Map.Map Unique IrcEvent)
| SIrcRemoveEvent Unique
data IrcServer = IrcServer
{ sAddr :: B.ByteString
, sPort :: Int
, sNickname :: B.ByteString
, sUsername :: B.ByteString
, sRealname :: B.ByteString
, sChannels :: [B.ByteString]
, sEvents :: Map.Map Unique IrcEvent
, sSock :: Maybe Handle
, sListenThread :: Maybe ThreadId
, sCmdThread :: Maybe ThreadId
, sCmdChan :: Chan SIrcCommand
, sDebug :: Bool
, sCTCPVersion :: String
, sCTCPTime :: IO String
}
data IrcEvent =
Privmsg EventFunc
| Numeric EventFunc
| Ping EventFunc
| Join EventFunc
| Part EventFunc
| Mode EventFunc
| Topic EventFunc
| Invite EventFunc
| Kick EventFunc
| Quit EventFunc
| Nick EventFunc
| Notice EventFunc
| RawMsg EventFunc
| Disconnect (IrcServer -> IO ())
instance Show IrcEvent where
show (Privmsg _) = "IrcEvent - Privmsg"
show (Numeric _) = "IrcEvent - Numeric"
show (Ping _) = "IrcEvent - Ping"
show (Join _) = "IrcEvent - Join"
show (Part _) = "IrcEvent - Part"
show (Mode _) = "IrcEvent - Mode"
show (Topic _) = "IrcEvent - Topic"
show (Invite _) = "IrcEvent - Invite"
show (Kick _) = "IrcEvent - Kick"
show (Quit _) = "IrcEvent - Quit"
show (Nick _) = "IrcEvent - Nick"
show (Notice _) = "IrcEvent - Notice"
show (RawMsg _) = "IrcEvent - RawMsg"
show (Disconnect _) = "IrcEvent - Disconnect"
type EventFunc = (MIrc -> IrcMessage -> IO ())
connect :: IrcConfig
-> Bool
-> Bool
-> IO (Either IOError MIrc)
connect config threaded debug = try $ do
(when debug $
B.putStrLn $ "Connecting to " `B.append` B.pack (cAddr config))
h <- connectTo (cAddr config) (PortNumber $ fromIntegral $ cPort config)
hSetBuffering h NoBuffering
cmdChan <- newChan
server <- toServer config h cmdChan debug
greetServer server
res <- newMVar server
if threaded
then do listenId <- forkIO (listenLoop res)
cmdId <- forkIO (execCmdsLoop res)
modifyMVar_ res (\srv -> return $ srv {sListenThread = Just listenId})
return res
else do listenLoop res
return res
disconnect :: MIrc
-> B.ByteString
-> IO ()
disconnect server quitMsg = do
s <- readMVar server
let h = fromJust $ sSock s
write s $ "QUIT :" `B.append` quitMsg
return ()
genUnique :: IrcEvent -> IO (Unique, IrcEvent)
genUnique e = do
u <- newUnique
return (u, e)
genUniqueMap :: [IrcEvent] -> IO (Map.Map Unique IrcEvent)
genUniqueMap events = do
uEvents <- mapM genUnique events
return $ Map.fromList uEvents
toServer :: IrcConfig -> Handle -> Chan SIrcCommand -> Bool -> IO IrcServer
toServer config h cmdChan debug = do
uniqueEvents <- genUniqueMap $ internalNormEvents ++ cEvents config
return $ IrcServer (B.pack $ cAddr config) (cPort config)
(B.pack $ cNick config) (B.pack $ cUsername config)
(B.pack $ cRealname config) (map B.pack $ cChannels config)
uniqueEvents (Just h) Nothing Nothing cmdChan debug
(cCTCPVersion config) (cCTCPTime config)
greetServer :: IrcServer -> IO IrcServer
greetServer server = do
write server $ "NICK " `B.append` nick
write server $ "USER " `B.append` user `B.append` " " `B.append`
user `B.append` " " `B.append` addr `B.append` " :" `B.append` real
return server
where nick = sNickname server
user = sUsername server
real = sRealname server
addr = sAddr server
execCmdsLoop :: MIrc -> IO ()
execCmdsLoop mIrc = do
server <- readMVar mIrc
cmd <- readChan $ sCmdChan server
case cmd of (SIrcAddEvent uEvent) -> do
swapMVar mIrc (server {sEvents =
(uncurry Map.insert uEvent) (sEvents server)})
execCmdsLoop mIrc
(SIrcChangeEvents events) -> do
swapMVar mIrc (server {sEvents = events})
execCmdsLoop mIrc
(SIrcRemoveEvent key) -> do
swapMVar mIrc (server {sEvents =
Map.delete key (sEvents server)})
execCmdsLoop mIrc
listenLoop :: MIrc -> IO ()
listenLoop s = do
server <- readMVar s
let h = fromJust $ sSock server
eof <- hIsEOF h
if eof
then do
let comp = (\a -> a `eqEvent` (Disconnect undefined))
events = Map.filter comp (sEvents server)
eventCall = (\obj -> (eventFuncD $ snd obj) server)
debugWrite server $ B.pack $ show $ length $ Map.toList events
mapM_ eventCall (Map.toList events)
else do
line <- B.hGetLine h
server1 <- takeMVar s
debugWrite server1 $ (B.pack ">> ") `B.append` line
newServ <- foldM (\sr f -> f sr (parse line)) server1 internalEvents
putMVar s newServ
callEvents s (parse line)
listenLoop s
joinChans :: IrcServer -> IrcMessage -> IO IrcServer
joinChans server msg =
if code == "001"
then do mapM_ (\chan -> write server $ "JOIN " `B.append` chan) (sChannels server)
return server {sChannels = []}
else return server
where h = fromJust $ sSock server
code = mCode msg
pong :: IrcServer -> IrcMessage -> IO IrcServer
pong server msg =
if code == "PING"
then do
write server $ "PONG :" `B.append` pingMsg
return server
else return server
where h = fromJust $ sSock server
pingMsg = mMsg msg
code = mCode msg
onJoin :: IrcServer -> IrcMessage -> IO IrcServer
onJoin server msg
| code == "JOIN" = do
let nick = fromJust $ mNick msg
chan = mMsg msg
if nick == sNickname server
then return server { sChannels = chan:(sChannels server) }
else return server
| otherwise = return server
where code = mCode msg
ctcpHandler :: EventFunc
ctcpHandler mServ iMsg
| msg == "\x01VERSION\x01" = do
server <- readMVar mServ
chan <- getDest mServ iMsg
sendCmd mServ
(MNotice chan ("\x01VERSION " `B.append`
B.pack (sCTCPVersion server) `B.append` "\x01"))
| msg == "\x01TIME\x01" = do
server <- readMVar mServ
time <- sCTCPTime server
chan <- getDest mServ iMsg
sendCmd mServ
(MNotice chan ("\x01TIME " `B.append`
(B.pack time) `B.append` "\x01"))
| "\x01PING " `B.isPrefixOf` msg = do
server <- readMVar mServ
chan <- getDest mServ iMsg
sendCmd mServ
(MNotice chan msg)
| otherwise = return ()
where msg = mMsg iMsg
events :: MIrc -> IrcEvent -> IrcMessage -> IO ()
events mServ event msg = do
server <- readMVar mServ
let comp = (`eqEvent` event)
events = Map.filter comp (sEvents server)
eventCall = (\obj -> (eventFunc $ snd obj) mServ msg)
mapM_ eventCall (Map.toList events)
callEvents :: MIrc -> IrcMessage -> IO ()
callEvents mServ msg
| mCode msg == "PRIVMSG" =
events mServ (Privmsg undefined) msg
| mCode msg == "PING" =
events mServ (Ping undefined) msg
| mCode msg == "JOIN" =
events mServ (Join undefined) msg
| mCode msg == "PART" =
events mServ (Part undefined) msg
| mCode msg == "MODE" =
events mServ (Mode undefined) msg
| mCode msg == "TOPIC" =
events mServ (Topic undefined) msg
| mCode msg == "INVITE" =
events mServ (Invite undefined) msg
| mCode msg == "KICK" =
events mServ (Kick undefined) msg
| mCode msg == "QUIT" =
events mServ (Quit undefined) msg
| mCode msg == "NICK" =
events mServ (Nick undefined) msg
| mCode msg == "NOTICE" =
events mServ (Notice undefined) msg
| B.all isNumber (mCode msg) =
events mServ (Numeric undefined) msg
| otherwise =
events mServ (RawMsg undefined) msg
(Privmsg _) `eqEvent` (Privmsg _) = True
(Numeric _) `eqEvent` (Numeric _) = True
(Ping _) `eqEvent` (Ping _) = True
(Join _) `eqEvent` (Join _) = True
(Part _) `eqEvent` (Part _) = True
(Mode _) `eqEvent` (Mode _) = True
(Topic _) `eqEvent` (Topic _) = True
(Invite _) `eqEvent` (Invite _) = True
(Kick _) `eqEvent` (Kick _) = True
(Quit _) `eqEvent` (Quit _) = True
(Nick _) `eqEvent` (Nick _) = True
(Notice _) `eqEvent` (Notice _) = True
(RawMsg _) `eqEvent` (RawMsg _) = True
(Disconnect _) `eqEvent` (Disconnect _) = True
_ `eqEvent` _ = False
eventFunc :: IrcEvent -> EventFunc
eventFunc (Privmsg f) = f
eventFunc (Numeric f) = f
eventFunc (Ping f) = f
eventFunc (Join f) = f
eventFunc (Part f) = f
eventFunc (Mode f) = f
eventFunc (Topic f) = f
eventFunc (Invite f) = f
eventFunc (Kick f) = f
eventFunc (Quit f) = f
eventFunc (Nick f) = f
eventFunc (Notice f) = f
eventFunc (RawMsg f) = f
eventFuncD (Disconnect f) = f
sendRaw :: MIrc -> B.ByteString -> IO ()
sendRaw mServ msg = do
server <- readMVar mServ
write server msg
sendMsg :: MIrc
-> B.ByteString
-> B.ByteString
-> IO ()
sendMsg mServ chan msg =
mapM_ s lins
where lins = B.lines msg
s m = sendCmd mServ (MPrivmsg chan m)
sendCmd :: MIrc
-> Command
-> IO ()
sendCmd mServ cmd = sendRaw mServ (showCommand cmd)
addEvent :: MIrc -> IrcEvent -> IO Unique
addEvent mIrc event = do
s <- readMVar mIrc
u <- newUnique
writeChan (sCmdChan s) (SIrcAddEvent (u, event))
return u
changeEvents :: MIrc -> [IrcEvent] -> IO ()
changeEvents mIrc events = do
s <- readMVar mIrc
uniqueEvents <- genUniqueMap events
writeChan (sCmdChan s) (SIrcChangeEvents uniqueEvents)
remEvent :: MIrc -> Unique -> IO ()
remEvent mIrc uniq = do
s <- readMVar mIrc
writeChan (sCmdChan s) (SIrcRemoveEvent uniq)
debugWrite :: IrcServer -> B.ByteString -> IO ()
debugWrite s msg =
(when (sDebug s) $ B.putStrLn msg)
write :: IrcServer -> B.ByteString -> IO ()
write s msg = do
debugWrite s $ "<< " `B.append` msg `B.append` "\\r\\n"
B.hPutStr h (msg `B.append` "\r\n")
where h = fromJust $ sSock s
defaultConfig = IrcConfig
{ cPort = 6667
, cUsername = "simpleirc"
, cRealname = "SimpleIRC Bot"
, cChannels = []
, cEvents = []
, cCTCPVersion = "SimpleIRC v0.2"
, cCTCPTime = fmap (formatTime defaultTimeLocale "%c") getZonedTime
}
getDest :: MIrc -> IrcMessage -> IO B.ByteString
getDest mIrc m = do
s <- readMVar mIrc
if sNickname s == chan
then return (fromJust $ mNick m)
else return chan
where chan = fromJust $ mChan m
getChannels :: MIrc -> IO [B.ByteString]
getChannels mIrc = do
s <- readMVar mIrc
return $ sChannels s
getNickname :: MIrc -> IO B.ByteString
getNickname mIrc = do
s <- readMVar mIrc
return $ sNickname s
getAddress :: MIrc -> IO B.ByteString
getAddress mIrc = do
s <- readMVar mIrc
return $ sAddr s
getUsername :: MIrc -> IO B.ByteString
getUsername mIrc = do
s <- readMVar mIrc
return $ sUsername s
getRealname :: MIrc -> IO B.ByteString
getRealname mIrc = do
s <- readMVar mIrc
return $ sRealname s