{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Network.IRC.Client.Internal
( module Network.IRC.Client.Internal
, module Network.IRC.Client.Internal.Lens
, module Network.IRC.Client.Internal.Types
) where
import Control.Applicative ((<$>))
import Control.Concurrent (forkIO, killThread, myThreadId, threadDelay, throwTo)
import Control.Concurrent.STM (STM, atomically, readTVar, readTVarIO, writeTVar)
import Control.Concurrent.STM.TBMChan (TBMChan, closeTBMChan, isClosedTBMChan, isEmptyTBMChan, readTBMChan, writeTBMChan, newTBMChan)
import Control.Monad (forM_, unless, void, when)
import Control.Monad.Catch (SomeException, catch)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (ask, runReaderT)
import Data.ByteString (ByteString)
import Data.Conduit (ConduitM, (.|), await, awaitForever, yield)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import qualified Data.Set as S
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Time.Clock (NominalDiffTime, UTCTime, addUTCTime, diffUTCTime, getCurrentTime)
import Data.Time.Format (formatTime)
import Data.Void (Void)
import Network.IRC.Conduit (Event(..), Message(..), Source(..), floodProtector, rawMessage, toByteString)
#if MIN_VERSION_time(1,5,0)
import Data.Time.Format (defaultTimeLocale)
#else
import System.Locale (defaultTimeLocale)
#endif
import Network.IRC.Client.Internal.Lens
import Network.IRC.Client.Internal.Types
import Network.IRC.Client.Lens
setupInternal
:: (IO () -> ConduitM (Either ByteString (Event ByteString)) Void IO () -> ConduitM () (Message ByteString) IO () -> IO ())
-> IRC s ()
-> (Maybe SomeException -> IRC s ())
-> (Origin -> ByteString -> IO ())
-> ByteString
-> Int
-> ConnectionConfig s
setupInternal f oncon ondis logf host port_ = ConnectionConfig
{ _func = f
, _username = "irc-client"
, _realname = "irc-client"
, _password = Nothing
, _server = host
, _port = port_
, _flood = 1
, _timeout = 300
, _onconnect = oncon
, _ondisconnect = ondis
, _logfunc = logf
}
runner :: IRC s ()
runner = do
state <- getIRCState
let cconf = _connectionConfig state
let theUser = get username cconf
let theReal = get realname cconf
let thePass = get password cconf
let initialise = flip runIRCAction state $ do
liftIO . atomically $ writeTVar (_connectionState state) Connected
mapM_ (\p -> sendBS $ rawMessage "PASS" [encodeUtf8 p]) thePass
sendBS $ rawMessage "USER" [encodeUtf8 theUser, "-", "-", encodeUtf8 theReal]
_onconnect cconf
antiflood <- liftIO $ floodProtector (_flood cconf)
lastReceived <- liftIO $ newIORef =<< getCurrentTime
squeue <- liftIO . readTVarIO $ _sendqueue state
let source = sourceTBMChan squeue
.| antiflood
.| logConduit (_logfunc cconf FromClient . toByteString)
let sink = forgetful
.| logConduit (_logfunc cconf FromServer . _raw)
.| eventSink lastReceived state
mainTId <- liftIO myThreadId
let time = _timeout cconf
let delay = round time
let timeoutThread = do
now <- getCurrentTime
prior <- readIORef lastReceived
if diffUTCTime now prior >= time
then throwTo mainTId Timeout
else threadDelay delay >> timeoutThread
timeoutTId <- liftIO (forkIO timeoutThread)
(exc :: Maybe SomeException) <- liftIO $ catch
(_func cconf initialise sink source >> killThread timeoutTId >> pure Nothing)
(pure . Just)
disconnect
_ondisconnect cconf exc
forgetful :: Monad m => ConduitM (Either a b) b m ()
forgetful = awaitForever go where
go (Left _) = return ()
go (Right b) = yield b
eventSink :: MonadIO m => IORef UTCTime -> IRCState s -> ConduitM (Event ByteString) o m ()
eventSink lastReceived ircstate = go where
go = await >>= maybe (return ()) (\event -> do
now <- liftIO getCurrentTime
liftIO $ writeIORef lastReceived now
let event' = decodeUtf8 <$> event
ignored <- isIgnored ircstate event'
unless ignored . liftIO $ do
iconf <- snapshot instanceConfig ircstate
forM_ (get handlers iconf) $ \(EventHandler matcher handler) ->
maybe (pure ())
(void . flip runIRCAction ircstate . handler (_source event'))
(matcher event')
disconnected <- liftIO . atomically $ (==Disconnected) <$> getConnectionState ircstate
unless disconnected go)
isIgnored :: MonadIO m => IRCState s -> Event Text -> m Bool
isIgnored ircstate ev = do
iconf <- liftIO . readTVarIO . _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
logConduit :: MonadIO m => (a -> IO ()) -> ConduitM a a m ()
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 :: Message Text -> IRC s ()
send = sendBS . fmap encodeUtf8
sendBS :: Message ByteString -> IRC s ()
sendBS msg = do
qv <- _sendqueue <$> getIRCState
liftIO . atomically $ flip writeTBMChan msg =<< readTVar qv
disconnect :: IRC s ()
disconnect = do
s <- getIRCState
liftIO $ do
connState <- readTVarIO (_connectionState s)
case connState of
Connected -> do
atomically $ writeTVar (_connectionState s) Disconnecting
timeoutBlock 60 . atomically $ do
queue <- readTVar (_sendqueue s)
(||) <$> isEmptyTBMChan queue <*> isClosedTBMChan queue
atomically $ do
closeTBMChan =<< readTVar (_sendqueue s)
writeTVar (_connectionState s) Disconnected
mapM_ (`throwTo` Disconnect) =<< readTVarIO (_runningThreads s)
atomically $ writeTVar (_runningThreads s) S.empty
_ -> pure ()
reconnect :: IRC s ()
reconnect = do
disconnect
s <- getIRCState
liftIO . atomically $
writeTVar (_sendqueue s) =<< newTBMChan 16
runner
runIRCAction :: MonadIO m => IRC s a -> IRCState s -> m a
runIRCAction ma = liftIO . runReaderT (runIRC ma)
getIRCState :: IRC s (IRCState s)
getIRCState = ask
getConnectionState :: IRCState s -> STM ConnectionState
getConnectionState = readTVar . _connectionState
timeoutBlock :: MonadIO m => NominalDiffTime -> IO Bool -> m ()
timeoutBlock dt check = liftIO $ do
finish <- addUTCTime dt <$> getCurrentTime
let wait = do
now <- getCurrentTime
cond <- check
when (now < finish && not cond) wait
wait
sourceTBMChan :: MonadIO m => TBMChan a -> ConduitM () a m ()
sourceTBMChan ch = loop where
loop = do
a <- liftIO . atomically $ readTBMChan ch
case a of
Just x -> yield x >> loop
Nothing -> pure ()