module Network.IRC.Client.Internal where
import Control.Applicative ((<$>))
import Control.Concurrent (forkIO)
import Control.Concurrent.STM (atomically, readTVar, retry)
import Control.Monad (unless)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Reader (runReaderT)
import Data.ByteString (ByteString)
import Data.Conduit (Producer, Conduit, Consumer, (=$=), ($=), (=$), awaitForever, toProducer, yield)
import Data.Conduit.TMChan (closeTBMChan, isEmptyTBMChan, newTBMChanIO, sourceTBMChan, writeTBMChan)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Time.Clock (NominalDiffTime, getCurrentTime)
import Data.Time.Format (formatTime)
import Network.IRC.Conduit (IrcEvent, IrcMessage, floodProtector, rawMessage, toByteString)
import Network.IRC.Client.Types
import System.Locale (defaultTimeLocale)
connect' :: MonadIO m
=> (Int -> ByteString -> IO () -> Consumer (Either ByteString IrcEvent) IO () -> Producer IO IrcMessage -> IO ())
-> IRC ()
-> ByteString
-> Int
-> NominalDiffTime
-> m ConnectionConfig
connect' f dcHandler host port flood = liftIO $ do
queueS <- newTBMChanIO 16
return ConnectionConfig
{ _func = f
, _sendqueue = queueS
, _server = host
, _port = port
, _flood = flood
, _disconnect = dcHandler
}
runner :: IRC ()
runner = do
state <- ircState
theNick <- _nick <$> instanceConfig
theUser <- _username <$> instanceConfig
theReal <- _realname <$> instanceConfig
let initialise = flip runReaderT state $ do
sendBS $ rawMessage "USER" [encodeUtf8 theUser, "-", "-", encodeUtf8 theReal]
send $ Nick theNick
mapM_ (send . Join) . _channels <$> instanceConfig
return ()
flood <- _flood <$> connectionConfig
func <- _func <$> connectionConfig
port <- _port <$> connectionConfig
server <- _server <$> connectionConfig
queue <- _sendqueue <$> connectionConfig
antiflood <- liftIO $ floodProtector flood
dchandler <- _disconnect <$> connectionConfig
let source = toProducer $ sourceTBMChan queue $= antiflood $= logConduit False toByteString
let sink = forgetful =$= logConduit True _raw =$ eventSink state
liftIO $ func port server initialise sink source
disconnect
dchandler
forgetful :: Monad m => Conduit (Either a b) m b
forgetful = awaitForever go where
go (Left _) = return ()
go (Right b) = yield b
eventSink :: MonadIO m => IRCState -> Consumer IrcEvent m ()
eventSink ircstate = awaitForever $ \event -> do
let event' = decodeUtf8 <$> event
ignored <- isIgnored ircstate event'
unless ignored $ do
handlers <- getHandlersFor event' . _eventHandlers <$> getInstanceConfig' ircstate
liftIO $ mapM_ (\h -> forkIO $ runReaderT (h event') ircstate) handlers
isIgnored :: MonadIO m => IRCState -> UnicodeEvent -> m Bool
isIgnored ircstate ev = do
iconf <- liftIO . atomically . readTVar . _instanceConfig $ ircstate
let ignoreList = _ignore iconf
return $
case _source ev of
User n -> (n, Nothing) `elem` ignoreList
Channel c n -> ((n, Nothing) `elem` ignoreList) || ((n, Just c) `elem` ignoreList)
Server _ -> False
getHandlersFor :: Event a -> [EventHandler] -> [UnicodeEvent -> IRC ()]
getHandlersFor e ehs = [_eventFunc eh | eh <- ehs, _matchType eh `elem` [EEverything, eventType e]]
logConduit :: MonadIO m => Bool -> (a -> ByteString) -> Conduit a m a
logConduit fromsrv f = awaitForever $ \x -> do
liftIO $ do
now <- getCurrentTime
putStrLn $ unwords [ formatTime defaultTimeLocale "%c" now
, if fromsrv then "<---" else "--->"
, init . tail . show $ f x
]
yield x
send :: UnicodeMessage -> IRC ()
send = sendBS . fmap encodeUtf8
sendBS :: IrcMessage -> IRC ()
sendBS msg = do
queue <- _sendqueue <$> connectionConfig
liftIO . atomically $ writeTBMChan queue msg
disconnect :: IRC ()
disconnect = do
queueS <- _sendqueue <$> connectionConfig
liftIO . atomically $ do
empty <- isEmptyTBMChan queueS
unless empty retry
disconnectNow
disconnectNow :: IRC ()
disconnectNow = do
queueS <- _sendqueue <$> connectionConfig
liftIO . atomically $ closeTBMChan queueS