module Network.IRC.Client.Internal where
import Control.Applicative ((<$>))
import Control.Concurrent (forkIO)
import Control.Concurrent.STM (atomically, readTVar, writeTVar)
import Control.Exception (SomeException, catch, throwIO)
import Control.Monad (unless, when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Reader (runReaderT)
import Data.ByteString (ByteString)
import Data.Conduit (Producer, Conduit, Consumer, (=$=), ($=), (=$), await, awaitForever, toProducer, yield)
import Data.Conduit.TMChan (closeTBMChan, isEmptyTBMChan, newTBMChanIO, sourceTBMChan, writeTBMChan)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Time.Clock (NominalDiffTime, addUTCTime, 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
=> (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
liftIO . atomically $ writeTVar (_connState state) Connected
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 queue = _sendqueue 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 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 = go where
go = await >>= maybe (return ()) (\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
disconnected <- (==Disconnected) <$> getConnState ircstate
unless disconnected go)
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
, "\n"
]
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
s <- ircState
connState <- liftIO . atomically . readTVar $ _connState s
case connState of
Connected -> do
liftIO . atomically $ writeTVar (_connState s) Disconnecting
queueS <- _sendqueue <$> connectionConfig
timeout 60 . atomically $ isEmptyTBMChan queueS
disconnectNow
_ -> pure ()
disconnectNow :: StatefulIRC s ()
disconnectNow = do
queueS <- _sendqueue <$> connectionConfig
liftIO . atomically $ closeTBMChan queueS
s <- ircState
liftIO . atomically $ writeTVar (_connState s) Disconnected
timeout :: MonadIO m => NominalDiffTime -> IO Bool -> m ()
timeout dt check = liftIO $ do
finish <- addUTCTime dt <$> getCurrentTime
let wait = do
now <- getCurrentTime
cond <- check
when (now < finish && not cond) wait
wait