module Manatee.Extension.IrcClient.IrcBuffer where
import Control.Concurrent.STM
import Control.Monad
import DBus.Client hiding (Signal)
import Data.Array
import Data.Map (Map)
import Data.Maybe
import Data.Set (Set)
import Data.Typeable
import Graphics.UI.Gtk hiding (Language, eventButton, eventClick)
import Graphics.UI.Gtk.Gdk.Events
import Graphics.UI.Gtk.SourceView.SourceBuffer
import Language.Translate.Google
import Manatee.Core.DBus
import Manatee.Core.Types
import Manatee.Extension.IrcClient.DBus
import Manatee.Extension.IrcClient.HighlightNick
import Manatee.Extension.IrcClient.PageMode
import Manatee.Extension.IrcClient.Smile
import Manatee.Extension.IrcClient.Types
import Manatee.Toolkit.General.Basic
import Manatee.Toolkit.General.ByteString
import Manatee.Toolkit.General.DBus
import Manatee.Toolkit.General.List
import Manatee.Toolkit.General.Map
import Manatee.Toolkit.General.Maybe
import Manatee.Toolkit.General.Process
import Manatee.Toolkit.General.STM
import Manatee.Toolkit.General.Set
import Manatee.Toolkit.General.Time
import Manatee.Toolkit.Gtk.Multiline
import Network.FastIRC.Types
import Network.URI
import System.Posix.Process
import Text.Regex.Posix hiding (after)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Map as M
import qualified Data.Set as S
data IrcBuffer =
IrcBuffer {ircBufferServer :: Server
,ircBufferPort :: Port
,ircBufferChannel :: Channel
,ircBufferClient :: Client
,ircBufferPageId :: PageId
,ircBufferMode :: PageMode
,ircBufferBuffer :: SourceBuffer
,ircBufferInsertMark :: TextMark
,ircBufferPromptMark :: TextMark
,ircBufferScrollMark :: TVar (Maybe TextMark)
,ircBufferEditableTag :: TextTag
,ircBufferMessageTag :: TextTag
,ircBufferServerColorTag :: TextTag
,ircBufferSelfColorTag :: TextTag
,ircBufferOtherColorTag :: TextTag
,ircBufferJoinColorTag :: TextTag
,ircBufferQuitColorTag :: TextTag
,ircBufferPartColorTag :: TextTag
,ircBufferActionColorTag :: TextTag
,ircBufferUrlColorTag :: TextTag
,ircBufferTimeStamp :: TVar (Map Int (String, Color))
,ircBufferNick :: TVar Nick
,ircBufferNickSet :: TVar (Set NickName)
,ircBufferNickColorMap :: TVar (Map NickName TextTag)
,ircBufferTranslateLanguage :: TVar Language
,ircBufferBroadcastChannel :: TChan IrcBufferSignal
,ircBufferSmilePixbufs :: Map String Pixbuf
}
deriving Typeable
data IrcBufferSignal = SwitchTranslateLanguage
| BufferChanged
deriving (Show, Eq, Ord)
ircBufferNew :: String -> Client -> PageId -> IO IrcBuffer
ircBufferNew info client pageId = do
let (mynick, server, port, channel) = ircParseInfo info
putStrLn ("Buffer create (server, port, channel) : " ++ show (server, port, channel))
sourceBuffer <- sourceBufferNew Nothing
ircBufferInsertPromptStr sourceBuffer
insertMark <- ircBufferCreateInsertMark sourceBuffer
promptMark <- ircBufferCreatePromptMark sourceBuffer
scrollMark <- newTVarIO Nothing
textTag <- textTagNew Nothing
set textTag [textTagEditable := False]
tagTable <- textBufferGetTagTable sourceBuffer
textTagTableAdd tagTable textTag
messageTag <- textTagNew Nothing
set messageTag [textTagEditable := False]
textTagTableAdd tagTable messageTag
serverColorTag <- ircBufferCreateColorTag sourceBuffer serverMsgColor
selfColorTag <- ircBufferCreateColorTag sourceBuffer selfMsgColor
otherColorTag <- ircBufferCreateColorTag sourceBuffer otherMsgColor
joinColorTag <- ircBufferCreateColorTag sourceBuffer joinMsgColor
quitColorTag <- ircBufferCreateColorTag sourceBuffer quitMsgColor
partColorTag <- ircBufferCreateColorTag sourceBuffer partMsgColor
actionColorTag <- ircBufferCreateColorTag sourceBuffer actionMsgColor
urlColorTag <- ircBufferCreateColorTag sourceBuffer urlColor
set urlColorTag [textTagUnderline := UnderlineSingle]
urlColorTag `onTextTagEvent` \ event iter ->
case event of
Button {eventClick = click
,eventButton = button} ->
when (button == LeftButton && click == SingleClick) $
textBufferGetTagTextWithIter sourceBuffer iter urlColorTag
>?>= \ url ->
mkDaemonSignal client NewTab (NewTabArgs "PageBrowser" url)
_ -> return ()
startIter <- textBufferGetStartIter sourceBuffer
endIter <- textBufferGetIterAtMark sourceBuffer promptMark
textBufferApplyTag sourceBuffer textTag startIter endIter
timeStamp <- newTVarIO M.empty
nick <- newTVarIO mynick
nickSet <- newTVarIO S.empty
nickColorMap <- newTVarIO M.empty
lang <- newTVarIO targetLanguage
broadcastChannel <- newTChanIO :: IO (TChan IrcBufferSignal)
smilePixbufs <- createSmilePixbufs
let buffer = IrcBuffer server port channel
client pageId ircMode
sourceBuffer insertMark promptMark scrollMark
textTag messageTag serverColorTag selfColorTag otherColorTag
joinColorTag quitColorTag partColorTag actionColorTag urlColorTag
timeStamp nick nickSet nickColorMap lang
broadcastChannel smilePixbufs
ircBufferAddNick buffer (B.pack mynick)
processId <- getProcessID
mkIrcClientMatchRules client
[(ReceivePrivate,
\ (ReceivePrivateArgs nick msg) ->
ircBufferReceivePrivate buffer nick msg)
,(ReceiveJoin,
\ (ReceiveJoinArgs nick user host) ->
ircBufferReceiveJoin buffer nick user host)
,(ReceiveTopicReply,
\ (ReceiveTopicReplyArgs msg) ->
ircBufferReceiveTopicReply buffer msg)
,(ReceiveTopicWhoTime,
\ (ReceiveTopicWhoTimeArgs nick seconds) ->
ircBufferReceiveTopicWhoTime buffer nick seconds)
,(ReceiveChannelUrl,
\ (ReceiveChannelUrlArgs url) ->
ircBufferReceiveChannelUrl buffer url)
,(ReceiveNames,
\ (ReceiveNamesArgs nicks) ->
ircBufferReceiveNames buffer nicks)
,(ReceiveQuit,
\ (ReceiveQuitArgs nick user host reason) ->
ircBufferReceiveQuit buffer nick user host reason)
,(ReceivePart,
\ (ReceivePartArgs nick user host reason) ->
ircBufferReceivePart buffer nick user host reason)
,(DaemonProcessStartup,
\_ -> mkIrcDaemonSignal client Join (JoinArgs server port channel mynick processId))]
ifM (isBusNameExist ircDaemonBusName)
(mkIrcDaemonSignal client Join (JoinArgs server port channel mynick processId))
(do
putStrLn "No irc daemon process, starting one."
runProcess_ "manatee-irc-daemon" [show processId])
quitAdd 0 (do
putStrLn $ "Irc process " ++ show processId ++ " quit."
mkIrcDaemonSignal client Part (PartArgs server channel processId)
return False)
sourceBuffer `on` bufferChanged $ do
cursorMark <- textBufferGetInsert sourceBuffer
promptIter <- textBufferGetIterAtMark sourceBuffer promptMark
insertIter <- textBufferGetInsertIter sourceBuffer
order <- textIterCompare insertIter promptIter
case order of
GT -> writeTVarIO scrollMark (Just cursorMark)
EQ -> writeTVarIO scrollMark (Just cursorMark)
_ -> writeTVarIO scrollMark Nothing
sourceBuffer `after` bufferChanged $
writeTChanIO broadcastChannel BufferChanged
return buffer
ircParseInfo :: String -> (Nick, Server, Port, Channel)
ircParseInfo str =
if null matchTextList
then (defaultNick, defaultServer, defaultPort, defaultChannel)
else
let (_ : (nickStr, _) : (serverStr, _) : (portStr, _) : (channelStr, _) : _) = elems $ head matchTextList
nick = if null nickStr then defaultNick else init nickStr
server = if null serverStr then defaultServer else serverStr
port = if null portStr then defaultPort else read $ tail portStr :: Int
channel = (\x -> case x of
('/':c) -> c
_ -> x
) $ if null channelStr then defaultChannel else channelStr
in (nick, server, port, channel)
where matchTextList =
matchAllText
(makeRegex ("irc://([^<> \t\n'@:]+@)*([a-zA-Z.]+)*(:[0-9]+)*(/*[$#+!].[^ \t\n,]+)*" :: String) :: Regex)
str
ircBufferReceivePrivate :: IrcBuffer -> NickName -> CommandArg -> IO ()
ircBufferReceivePrivate buffer@(IrcBuffer {ircBufferClient = client
,ircBufferPageId = pageId
,ircBufferSelfColorTag = selfColorTag
,ircBufferOtherColorTag = otherColorTag
,ircBufferActionColorTag = actionColorTag
,ircBufferNick = mynick})
nick content = do
let ((msg, msgHeadLen), isAction) =
if B.pack "\SOHACTION " `B.isPrefixOf` content
&& B.pack "\SOH" `B.isSuffixOf` content
then
let prefixLen = B.length (B.pack "\SOHACTION ")
suffixLen = B.length (B.pack "\SOH")
takeLen = B.length content prefixLen suffixLen
newContent = B.take takeLen $ B.drop prefixLen content
in (ircBufferIndentMessage newContent (B.concat ["* ", nick, " "]), True)
else
(ircBufferIndentMessage content (B.concat ["<", nick, "> "]), False)
mynickname <- readTVarIO mynick
let messageColor
| B.unpack nick == mynickname
= selfColorTag
| isAction
= actionColorTag
| otherwise
= otherColorTag
ircBufferReceiveMsg buffer msg msgHeadLen messageColor
let myNickName = B.pack mynickname
unless (nick == myNickName) $
when (B.isInfixOf myNickName msg) $
mkDaemonSignal client
ShowTooltip
(ShowTooltipArgs (init_ (UTF8.toString msg)) Nothing 8000 Nothing Nothing False (Just pageId))
ircBufferReceiveQuit :: IrcBuffer -> NickName -> UserName -> HostName -> B.ByteString -> IO ()
ircBufferReceiveQuit buffer@(IrcBuffer {ircBufferNickSet = nickSet
,ircBufferQuitColorTag = quitColorTag})
nick user host reason = do
set <- readTVarIO nickSet
case maybeFindMin set (== nick) of
Just _ -> do
modifyTVarIO nickSet $ \ set ->
S.delete nick set
let adjustMsg = B.pack "*** "
content = B.concat [nick, " (", user, "@", host, ") has quit: ", reason]
(msg, msgHeadLen) = ircBufferIndentMessage content adjustMsg
ircBufferReceiveMsg buffer msg msgHeadLen quitColorTag
Nothing -> return ()
ircBufferReceivePart :: IrcBuffer -> NickName -> UserName -> HostName -> B.ByteString -> IO ()
ircBufferReceivePart buffer@(IrcBuffer {ircBufferNickSet = nickSet
,ircBufferPartColorTag = partColorTag})
nick user host reason = do
modifyTVarIO nickSet $ \ set ->
S.delete nick set
let adjustMsg = B.pack "*** "
content = B.concat [nick, " (", user, "@", host, ") has part: ", reason]
(msg, msgHeadLen) = ircBufferIndentMessage content adjustMsg
ircBufferReceiveMsg buffer msg msgHeadLen partColorTag
ircBufferReceiveNames :: IrcBuffer -> B.ByteString -> IO ()
ircBufferReceiveNames buffer nicks =
forM_ (B.words nicks) $ \nick ->
ircBufferAddNick buffer nick
ircBufferReceiveChannelUrl :: IrcBuffer -> B.ByteString -> IO ()
ircBufferReceiveChannelUrl buffer@(IrcBuffer {ircBufferChannel = channel
,ircBufferServerColorTag = serverColorTag})
url = do
let adjustMsg = B.pack "*** "
content = B.concat [B.pack channel, " URL: ", url]
(msg, msgHeadLen) = ircBufferIndentMessage content adjustMsg
ircBufferReceiveMsg buffer msg msgHeadLen serverColorTag
ircBufferReceiveTopicReply :: IrcBuffer -> CommandArg -> IO ()
ircBufferReceiveTopicReply buffer@(IrcBuffer {ircBufferChannel = channel
,ircBufferServerColorTag = serverColorTag})
message = do
let adjustMsg = B.pack "*** "
content = B.concat ["Topic for ", B.pack channel, ": ", message]
(msg, msgHeadLen) = ircBufferIndentMessage content adjustMsg
ircBufferReceiveMsg buffer msg msgHeadLen serverColorTag
ircBufferReceiveTopicWhoTime :: IrcBuffer -> NickName -> Integer -> IO ()
ircBufferReceiveTopicWhoTime buffer@(IrcBuffer {ircBufferChannel = channel
,ircBufferServerColorTag = serverColorTag})
nick seconds = do
time <- getSecondsTimeStamp seconds "%H:%M:%S %Y/%m/%d"
let adjustMsg = B.pack "*** "
content = B.concat [B.pack channel, ": topic set by ", nick, ", ", B.pack time]
(msg, msgHeadLen) = ircBufferIndentMessage content adjustMsg
ircBufferReceiveMsg buffer msg msgHeadLen serverColorTag
ircBufferReceiveJoin :: IrcBuffer -> NickName -> UserName -> HostName -> IO ()
ircBufferReceiveJoin buffer@(IrcBuffer {ircBufferChannel = channel
,ircBufferJoinColorTag = joinColorTag
,ircBufferNick = mynick})
nick user host = do
nickname <- readTVarIO mynick
when (B.unpack nick /= nickname) $ do
ircBufferAddNick buffer nick
let adjustMsg = B.pack "*** "
content = B.concat [nick, " (", user, "@", host, ") has joined channel ", B.pack channel]
(msg, msgHeadLen) = ircBufferIndentMessage content adjustMsg
ircBufferReceiveMsg buffer msg msgHeadLen joinColorTag
ircBufferReceiveMsg :: IrcBuffer -> B.ByteString -> Int -> TextTag -> IO ()
ircBufferReceiveMsg IrcBuffer {ircBufferBuffer = buffer
,ircBufferInsertMark = insertMark
,ircBufferPromptMark = promptMark
,ircBufferEditableTag = tag
,ircBufferMessageTag = messageTag
,ircBufferTimeStamp = stamp
,ircBufferNickColorMap = nickColorMap
,ircBufferUrlColorTag = urlColorTag
,ircBufferSmilePixbufs = smilePixbufs
}
message msgHeadLen colorTag = do
set tag [textTagEditable := True]
insertIter<- textBufferGetIterAtMark buffer insertMark
line <- textIterGetLine insertIter
timeStamp <- getTimeStamp "[%H:%M:%S]"
color <- get colorTag textTagForegroundGdk
modifyTVarIO stamp $ \s ->
M.insert line (timeStamp, color) s
saveMark <- textBufferCreateMark buffer Nothing insertIter True
(msg, smileIndex) <- smileMessage message smilePixbufs
textBufferInsertByteString buffer insertIter msg
saveIter <- textBufferGetIterAtMark buffer saveMark
insertIter <- textBufferGetIterAtMark buffer insertMark
textBufferApplyTag buffer colorTag saveIter insertIter
colorMap <- readTVarIO nickColorMap
unless (null $ map fst $ M.toList colorMap) $
forM_ (matchAllText (makeRegex (B.pack "[^<> \t\n\'@,.:]+") :: Regex) msg)
$ \ x -> do
let ((word, (matchOffset, matchLength)) : _) = elems x
case findMinMatch colorMap (\ nickName _ -> nickName == word) of
Just (_, colorTag) -> do
matchStartIter <- textIterCopy saveIter
matchEndIter <- textIterCopy saveIter
textIterForwardChars matchStartIter matchOffset
textIterForwardChars matchEndIter (matchOffset + matchLength)
textBufferApplyTag buffer colorTag matchStartIter matchEndIter
Nothing -> return ()
forM_ (matchAllText (makeRegex (B.pack "[^]\\ \t\n`\\[\"^]+") :: Regex) msg)
$ \ x -> do
let ((word, (matchOffset, matchLength)) : _) = elems x
parseURI (UTF8.toString word) ?>= \ uri ->
when (isJust $ uriAuthority uri) $ do
matchStartIter <- textIterCopy saveIter
matchEndIter <- textIterCopy saveIter
textIterForwardChars matchStartIter matchOffset
textIterForwardChars matchEndIter (matchOffset + matchLength)
textBufferApplyTag buffer urlColorTag matchStartIter matchEndIter
forM_ smileIndex $ \ (offset, pixbuf) -> do
iter <- textBufferGetIterAtMark buffer saveMark
textIterForwardChars iter offset
textBufferInsertPixbuf buffer iter pixbuf
msgStartIter <- textBufferGetIterAtMark buffer saveMark
msgEndIter <- textBufferGetIterAtMark buffer insertMark
textIterForwardChars msgStartIter msgHeadLen
textIterBackwardChar msgEndIter
textBufferApplyTag buffer messageTag msgStartIter msgEndIter
startIter <- textBufferGetStartIter buffer
endIter <- textBufferGetIterAtMark buffer promptMark
textBufferApplyTag buffer tag startIter endIter
set tag [textTagEditable := False]
ircBufferAddNick :: IrcBuffer -> NickName -> IO ()
ircBufferAddNick buffer@(IrcBuffer {ircBufferNickSet = nickSet})
nick = do
set <- readTVarIO nickSet
case maybeFindMin set (== nick) of
Just _ ->
return ()
Nothing ->
modifyTVarIO nickSet $ \ set ->
S.insert nick set
ircBufferUpdateNickColor buffer nick
ircBufferUpdateNickColor :: IrcBuffer -> NickName -> IO ()
ircBufferUpdateNickColor (IrcBuffer {ircBufferBuffer = buffer
,ircBufferNickColorMap = nickColorMap})
nick = do
colorMap <- readTVarIO nickColorMap
case findMinMatch colorMap (\ nickName _ -> nickName == nick) of
Just _ ->
return ()
Nothing -> do
let color = nickColorToColor $ nickColor nick
textTag <- textTagNew Nothing
set textTag [textTagForegroundGdk := color
,textTagWeight := fromEnum WeightBold]
tagTable <- textBufferGetTagTable buffer
textTagTableAdd tagTable textTag
modifyTVarIO nickColorMap $ \map ->
M.insert nick textTag map
ircBufferCreateColorTag :: TextBufferClass buffer => buffer -> Color -> IO TextTag
ircBufferCreateColorTag buffer color = do
tagTable <- textBufferGetTagTable buffer
colorTag <- textTagNew Nothing
set colorTag [textTagForegroundGdk := color]
textTagTableAdd tagTable colorTag
return colorTag
ircBufferInsertPromptStr :: TextBufferClass buffer => buffer -> IO ()
ircBufferInsertPromptStr buffer =
textBufferSetText buffer promptStr
ircBufferCreateInsertMark :: TextBufferClass buffer => buffer -> IO TextMark
ircBufferCreateInsertMark buffer = do
textIter <- textBufferGetStartIter buffer
textBufferCreateMark buffer Nothing textIter False
ircBufferCreatePromptMark :: TextBufferClass buffer => buffer -> IO TextMark
ircBufferCreatePromptMark buffer = do
textIter <- textBufferGetIterAtOffset buffer (length promptStr)
textBufferCreateMark buffer Nothing textIter True
ircBufferIndentMessage :: B.ByteString -> B.ByteString -> (B.ByteString, Int)
ircBufferIndentMessage content adjustMsg = (concatMsg msgLines, B.length adjustMsg)
where indentMsg = B.replicate (B.length adjustMsg) ' '
msgLines = map B.unwords $ wrapLine (wrapColumn B.length adjustMsg) (splitWords content)
concatMsg [] = B.concat [adjustMsg, "\n"]
concatMsg [x] = B.concat [adjustMsg, x, "\n"]
concatMsg (x:xs) = B.concat [B.concat [adjustMsg, x, "\n"]
,B.concat $ map (\ xx -> B.concat [indentMsg, xx, "\n"]) xs]