module Network.IRC.Client.Internal where
import Control.Applicative ((<$>))
import Control.Concurrent (forkIO)
import Control.Concurrent.STM (atomically, readTVar, retry)
import Control.Exception (SomeException, catch, throwIO)
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
#if MIN_VERSION_time(1,5,0)
import Data.Time.Format (defaultTimeLocale)
#else
import System.Locale (defaultTimeLocale)
#endif
connectInternal :: MonadIO m
=> (Int -> ByteString -> IO () -> Consumer (Either ByteString IrcEvent) IO () -> Producer IO IrcMessage -> IO ())
-> StatefulIRC s ()
-> StatefulIRC s ()
-> (Origin -> ByteString -> IO ())
-> ByteString
-> Int
-> NominalDiffTime
-> m (ConnectionConfig s)
connectInternal f onconnect ondisconnect logf host port flood = liftIO $ do
queueS <- newTBMChanIO 16
return ConnectionConfig
{ _func = f
, _sendqueue = queueS
, _server = host
, _port = port
, _flood = flood
, _onconnect = onconnect
, _ondisconnect = ondisconnect
, _logfunc = logf
}
runner :: StatefulIRC s ()
runner = do
state <- ircState
theUser <- _username <$> instanceConfig
theReal <- _realname <$> instanceConfig
password <- _password <$> instanceConfig
let initialise = flip runReaderT state $ do
mapM_ (\p -> sendBS $ rawMessage "PASS" [encodeUtf8 p]) password
sendBS $ rawMessage "USER" [encodeUtf8 theUser, "-", "-", encodeUtf8 theReal]
_onconnect =<< connectionConfig
cconf <- connectionConfig
let flood = _flood cconf
let func = _func cconf
let logf = _logfunc cconf
let port = _port cconf
let queue = _sendqueue cconf
let server = _server cconf
antiflood <- liftIO $ floodProtector flood
dchandler <- _ondisconnect <$> connectionConfig
let source = toProducer $ sourceTBMChan queue $= antiflood $= logConduit (logf FromClient . toByteString)
let sink = forgetful =$= logConduit (logf FromServer . _raw) =$ eventSink state
(exc :: Maybe SomeException) <- liftIO $ catch
(func port server initialise sink source >> pure Nothing)
(pure . Just)
disconnect
dchandler
liftIO $ maybe (pure ()) throwIO exc
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 s -> 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 s -> 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 s] -> [UnicodeEvent -> StatefulIRC s ()]
getHandlersFor e ehs = [_eventFunc eh | eh <- ehs, _matchType eh `elem` [EEverything, eventType e]]
logConduit :: MonadIO m => (a -> IO ()) -> Conduit a m a
logConduit logf = awaitForever $ \x -> do
liftIO $ logf x
yield x
stdoutLogger :: Origin -> ByteString -> IO ()
stdoutLogger origin x = do
now <- getCurrentTime
putStrLn $ unwords
[ formatTime defaultTimeLocale "%c" now
, if origin == FromServer then "<---" else "--->"
, init . tail $ show x
]
fileLogger :: FilePath -> Origin -> ByteString -> IO ()
fileLogger fp origin x = do
now <- getCurrentTime
appendFile fp $ unwords
[ formatTime defaultTimeLocale "%c" now
, if origin == FromServer then "--->" else "<---"
, init . tail $ show x
]
noopLogger :: a -> b -> IO ()
noopLogger _ _ = return ()
send :: UnicodeMessage -> StatefulIRC s ()
send = sendBS . fmap encodeUtf8
sendBS :: IrcMessage -> StatefulIRC s ()
sendBS msg = do
queue <- _sendqueue <$> connectionConfig
liftIO . atomically $ writeTBMChan queue msg
disconnect :: StatefulIRC s ()
disconnect = do
queueS <- _sendqueue <$> connectionConfig
liftIO . atomically $ do
empty <- isEmptyTBMChan queueS
unless empty retry
disconnectNow
disconnectNow :: StatefulIRC s ()
disconnectNow = do
queueS <- _sendqueue <$> connectionConfig
liftIO . atomically $ closeTBMChan queueS