module Manatee.Extension.IrcClient.Daemon where
import Control.Applicative hiding (empty)
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad
import DBus.Client hiding (Signal)
import Data.List (delete)
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import Manatee.Extension.IrcClient.DBus
import Manatee.Extension.IrcClient.Types
import Manatee.Toolkit.General.DBus
import Manatee.Toolkit.General.Map
import Manatee.Toolkit.General.Maybe
import Manatee.Toolkit.General.STM
import Network
import Network.FastIRC.IO
import Network.FastIRC.Messages
import Network.FastIRC.Users
import System.IO
import System.Posix.Types (ProcessID)
import Text.Groom
import qualified Control.Exception as Exc
import qualified Data.ByteString.Char8 as B
import qualified Data.Map as M
import qualified Data.Set as S
type HasConnected = Bool
type IrcConnect =
Map Server
(MVar Handle, Map Channel [ProcessID])
data IrcStatus =
IrcStatus {ircConnect :: TVar IrcConnect
,ircClient :: Client
,ircExitSignal :: MVar String}
ircInitStatus :: IO IrcStatus
ircInitStatus =
IrcStatus <$> newTVarIO M.empty
<*> mkSessionClient
<*> newEmptyMVar
ircSendMessage :: IrcStatus -> IrcDaemonSignalArgs -> IO ()
ircSendMessage IrcStatus {ircConnect = connect}
(SendMessageArgs server message) = do
connectStatus <- readTVarIO connect
case findMinMatch connectStatus (\ serverName _ -> serverName == server) of
Just (_, (handle, _)) -> do
isEmpty <- isEmptyMVar handle
if isEmpty
then putStrLn $ "Server " ++ server ++ "'s handle is not activated."
else do
h <- readMVar handle
write h message
Nothing -> putStrLn $ "Server " ++ server ++ " is not connected."
ircPart :: IrcStatus -> IrcDaemonSignalArgs -> IO ()
ircPart (IrcStatus {ircConnect = connect
,ircExitSignal= exitSignal})
(PartArgs server channel processId) = do
connectStatus <- readTVarIO connect
findMinMatch connectStatus (\ serverName _ -> serverName == server)
?>= \ (_, (handle, channelMap)) -> do
let newChannelMap =
case findMinMatch channelMap (\ channelName _ -> channelName == channel) of
Just (_, processIdList) ->
case delete processId processIdList of
[] -> M.delete channel channelMap
x -> M.insert channel x channelMap
Nothing -> channelMap
if M.null newChannelMap
then do
tryTakeMVar handle >?>= \h ->
hClose h
let newConnect = M.delete server connectStatus
if M.null newConnect
then putMVar exitSignal "Exit"
else
writeTVarIO connect newConnect
else
modifyTVarIO connect $ \c ->
M.insert server (handle, newChannelMap) c
ircJoin :: IrcStatus -> IrcDaemonSignalArgs -> IO ()
ircJoin status@(IrcStatus {ircConnect = connect})
(JoinArgs server port channel nick processId) = do
connectStatus <- readTVarIO connect
let connectMatch = findMinMatch connectStatus (\ serverName _ -> serverName == server)
(connectHandle, firstJoin) <-
case connectMatch of
Just (serverName, (handle, channelMap)) -> do
let newConnectStatus =
M.insert serverName
(handle,
case findMinMatch channelMap (\ channelName _ -> channelName == channel) of
Just (channelName, processList) ->
if processId `elem` processList
then channelMap
else M.insert channelName (processList ++ [processId]) channelMap
Nothing ->
M.insert channel [processId] channelMap)
connectStatus
writeTVarIO connect newConnectStatus
return (handle, False)
Nothing -> do
handle <- newEmptyMVar
let newConnectStatus =
M.insert server
(handle, M.fromList [(channel, [processId])])
connectStatus
writeTVarIO connect newConnectStatus
h <- connectTo server (PortNumber (fromIntegral port))
hSetBuffering h NoBuffering
isSucess <- tryPutMVar handle h
if isSucess
then putStrLn $ "ircJoin : connect server " ++ server ++ " successful."
else putStrLn "### ircJoin : Impossible! Multiple threads trying to connect to same server."
forkIO $ ircListenServerMessage status (server, h)
return (handle, True)
h <- readMVar connectHandle
when firstJoin $ do
hPutCommand h (NickCmd (B.pack nick) Nothing)
hPutCommand h (UserCmd tempUser "0" tempRealname "0")
hPutCommand h (JoinCmd $ M.fromList [(B.pack channel, Nothing)])
ircListenServerMessage :: IrcStatus -> (Server, Handle) -> IO ()
ircListenServerMessage status@(IrcStatus {ircConnect = connect
,ircClient = client})
(server, handle) =
Exc.catch
(do
Message {msgOrigin = origin
,msgCommand = command} <- hGetMessage handle
let (nick, user, host) =
case origin of
Just spec ->
case spec of
Nick n -> (n, "", "")
User n u h -> (n, u, h)
Nothing -> ("", "", "")
connectStatus <- readTVarIO connect
let sendToChannel command channelMap channel action =
case findMinMatch channelMap (\ channelName _ -> B.pack channelName == channel) of
Just (_, processIdList) ->
forM_ processIdList action
Nothing -> putStrLn $ "ircListenServerMessage : " ++ groom command
case findMinMatch connectStatus (\ serverName _ -> serverName == server) of
Just (_, (_, channelMap)) ->
case command of
PrivMsgCmd targetNameSet commandArg ->
mapM_ (\ target ->
sendToChannel command channelMap target $ \processId ->
mkIrcClientSignal client processId ReceivePrivate (ReceivePrivateArgs nick commandArg)
) $ S.toList targetNameSet
PingCmd server str ->
hPutCommand handle $ PongCmd server str
JoinCmd channels ->
when enableJoinMessage $
mapM_ (\ (channel, _) ->
sendToChannel command channelMap channel $ \processId ->
mkIrcClientSignal client processId ReceiveJoin (ReceiveJoinArgs nick user host)
) $ M.toList channels
QuitCmd reason ->
when enableQuitMessage $
mapM_ (\ (_, processIdList) ->
forM_ processIdList $ \processId ->
mkIrcClientSignal client processId
ReceiveQuit
(ReceiveQuitArgs nick user host (fromMaybe "" reason))
) $ M.toList channelMap
PartCmd targetNameSet commandArg ->
mapM_ (\ target ->
sendToChannel command channelMap target $ \processId ->
mkIrcClientSignal client processId
ReceivePart
(ReceivePartArgs nick user host (fromMaybe "" commandArg))
) $ S.toList targetNameSet
NumericCmd number messages ->
case number of
332 ->
when (length messages >= 3) $ do
let channel = messages !! 1
msg = B.concat $ drop 2 messages
sendToChannel command channelMap channel $ \processId ->
mkIrcClientSignal
client processId
ReceiveTopicReply
(ReceiveTopicReplyArgs msg)
333 ->
when (length messages >= 4) $ do
let channel = messages !! 1
nick = messages !! 2
seconds = read (B.unpack (messages !! 3)) :: Integer
sendToChannel command channelMap channel $ \processId ->
mkIrcClientSignal
client processId
ReceiveTopicWhoTime
(ReceiveTopicWhoTimeArgs nick seconds)
328 ->
when (length messages >= 3) $ do
let channel = messages !! 1
url = messages !! 2
sendToChannel command channelMap channel $ \processId ->
mkIrcClientSignal
client processId
ReceiveChannelUrl
(ReceiveChannelUrlArgs url)
353 ->
when (length messages >= 4) $ do
let channel = messages !! 2
nicks = messages !! 3
sendToChannel command channelMap channel $ \processId ->
mkIrcClientSignal
client processId
ReceiveNames
(ReceiveNamesArgs nicks)
_ -> putStrLn $ "Numeric <" ++ show number ++ "> " ++ show messages
_ -> putStrLn $ groom $ showCommand command
Nothing -> putStrLn $ "### Impossible! ircListenServerMessage : Unknown server " ++ server
ircListenServerMessage status (server, handle))
(\ (_ :: Exc.IOException) -> putStrLn $ "ircListenServerMessage : Catch server " ++ server ++ " socket exception\n.")
write :: Handle -> B.ByteString -> IO ()
write handle msg = do
B.hPutStr handle (msg `B.append` "\r\n")
B.putStrLn msg