{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- Module      : Network.IRC.Client.Internal
-- Copyright   : (c) 2016 Michael Walker
-- License     : MIT
-- Maintainer  : Michael Walker <mike@barrucadu.co.uk>
-- Stability   : experimental
-- Portability : CPP, OverloadedStrings, ScopedTypeVariables
--
-- Most of the hairy code. This isn't all internal, due to messy
-- dependencies, but I've tried to make this as \"internal\" as
-- reasonably possible.
--
-- This module is NOT considered to form part of the public interface
-- of this library.
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, newTBMChan,
                                                    readTBMChan, writeTBMChan)
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, isPrefixOf)
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


-------------------------------------------------------------------------------
-- * Configuration

-- | Config to connect to a server using the supplied connection
-- function.
setupInternal
  :: (IO () -> ConduitM (Either ByteString (Event ByteString)) Void IO () -> ConduitM () (Message ByteString) IO () -> IO ())
  -- ^ Function to start the network conduits.
  -> IRC s ()
  -- ^ Connect handler
  -> (Maybe SomeException -> IRC s ())
  -- ^ Disconnect handler
  -> (Origin -> ByteString -> IO ())
  -- ^ Logging function
  -> ByteString
  -- ^ Server hostname
  -> Int
  -- ^ Server port
  -> ConnectionConfig s
setupInternal :: forall s.
(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 IO ()
-> ConduitM (Either ByteString (Event ByteString)) Void IO ()
-> ConduitM () (Message ByteString) IO ()
-> IO ()
f IRC s ()
oncon Maybe SomeException -> IRC s ()
ondis Origin -> ByteString -> IO ()
logf ByteString
host Int
port_ = ConnectionConfig
  { _func :: IO ()
-> ConduitM (Either ByteString (Event ByteString)) Void IO ()
-> ConduitM () (Message ByteString) IO ()
-> IO ()
_func         = IO ()
-> ConduitM (Either ByteString (Event ByteString)) Void IO ()
-> ConduitM () (Message ByteString) IO ()
-> IO ()
f
  , _username :: Text
_username     = Text
"irc-client"
  , _realname :: Text
_realname     = Text
"irc-client"
  , _password :: Maybe Text
_password     = forall a. Maybe a
Nothing
  , _server :: ByteString
_server       = ByteString
host
  , _port :: Int
_port         = Int
port_
  , _flood :: NominalDiffTime
_flood        = NominalDiffTime
1
  , _timeout :: NominalDiffTime
_timeout      = NominalDiffTime
300
  , _onconnect :: IRC s ()
_onconnect    = IRC s ()
oncon
  , _ondisconnect :: Maybe SomeException -> IRC s ()
_ondisconnect = Maybe SomeException -> IRC s ()
ondis
  , _logfunc :: Origin -> ByteString -> IO ()
_logfunc      = Origin -> ByteString -> IO ()
logf
  }


-------------------------------------------------------------------------------
-- * Event loop

-- | The event loop.
runner :: IRC s ()
runner :: forall s. IRC s ()
runner = do
  IRCState s
state <- forall s. IRC s (IRCState s)
getIRCState
  let cconf :: ConnectionConfig s
cconf = forall s. IRCState s -> ConnectionConfig s
_connectionConfig IRCState s
state

  -- Set the real- and user-name
  let theUser :: Text
theUser = forall a s. Getting a s a -> s -> a
get forall s. Lens' (ConnectionConfig s) Text
username ConnectionConfig s
cconf
  let theReal :: Text
theReal = forall a s. Getting a s a -> s -> a
get forall s. Lens' (ConnectionConfig s) Text
realname ConnectionConfig s
cconf
  let thePass :: Maybe Text
thePass = forall a s. Getting a s a -> s -> a
get forall s. Lens' (ConnectionConfig s) (Maybe Text)
password ConnectionConfig s
cconf

  -- Initialise the IRC session
  let initialise :: IO ()
initialise = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. MonadIO m => IRC s a -> IRCState s -> m a
runIRCAction IRCState s
state forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar (forall s. IRCState s -> TVar ConnectionState
_connectionState IRCState s
state) ConnectionState
Connected
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Text
p -> forall s. Message ByteString -> IRC s ()
sendBS forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString] -> Message ByteString
rawMessage ByteString
"PASS" [Text -> ByteString
encodeUtf8 Text
p]) Maybe Text
thePass
        forall s. Message ByteString -> IRC s ()
sendBS forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString] -> Message ByteString
rawMessage ByteString
"USER" [Text -> ByteString
encodeUtf8 Text
theUser, ByteString
"-", ByteString
"-", Text -> ByteString
encodeUtf8 Text
theReal]
        forall s. ConnectionConfig s -> IRC s ()
_onconnect ConnectionConfig s
cconf

  -- Run the event loop, and call the disconnect handler if the remote
  -- end closes the socket.
  ConduitM (Message ByteString) (Message ByteString) IO ()
antiflood <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadIO m =>
NominalDiffTime -> IO (ConduitM a a m ())
floodProtector (forall s. ConnectionConfig s -> NominalDiffTime
_flood ConnectionConfig s
cconf)

  -- An IORef to keep track of the time of the last received message, to allow a local timeout.
  IORef UTCTime
lastReceived <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO UTCTime
getCurrentTime

  TBMChan (Message ByteString)
squeue <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TVar a -> IO a
readTVarIO forall a b. (a -> b) -> a -> b
$ forall s. IRCState s -> TVar (TBMChan (Message ByteString))
_sendqueue IRCState s
state

  let source :: ConduitM () (Message ByteString) IO ()
source = forall (m :: * -> *) a.
MonadIO m =>
TBMChan a -> ConduitM () a m ()
sourceTBMChan TBMChan (Message ByteString)
squeue
               forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitM (Message ByteString) (Message ByteString) IO ()
antiflood
               forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a.
MonadIO m =>
(a -> IO ()) -> ConduitM a a m ()
logConduit (forall s. ConnectionConfig s -> Origin -> ByteString -> IO ()
_logfunc ConnectionConfig s
cconf Origin
FromClient forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message ByteString -> ByteString
toByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message ByteString -> Message ByteString
concealPass)
  let sink :: ConduitT (Either a (Event ByteString)) c IO ()
sink   = forall (m :: * -> *) a b. Monad m => ConduitM (Either a b) b m ()
forgetful
               forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a.
MonadIO m =>
(a -> IO ()) -> ConduitM a a m ()
logConduit (forall s. ConnectionConfig s -> Origin -> ByteString -> IO ()
_logfunc ConnectionConfig s
cconf Origin
FromServer forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Event a -> ByteString
_raw)
               forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) s o.
MonadIO m =>
IORef UTCTime -> IRCState s -> ConduitM (Event ByteString) o m ()
eventSink IORef UTCTime
lastReceived IRCState s
state

  -- Fork a thread to disconnect if the timeout elapses.
  ThreadId
mainTId <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ThreadId
myThreadId
  let time :: NominalDiffTime
time  = forall s. ConnectionConfig s -> NominalDiffTime
_timeout ConnectionConfig s
cconf
  let delayms :: Int
delayms = Int
1000000 forall a. Num a => a -> a -> a
* forall a b. (RealFrac a, Integral b) => a -> b
round NominalDiffTime
time
  let timeoutThread :: IO ()
timeoutThread = do
        UTCTime
now <- IO UTCTime
getCurrentTime
        UTCTime
prior <- forall a. IORef a -> IO a
readIORef IORef UTCTime
lastReceived
        if UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
prior forall a. Ord a => a -> a -> Bool
>= NominalDiffTime
time
          then forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
mainTId Timeout
Timeout
          else Int -> IO ()
threadDelay Int
delayms forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
timeoutThread
  ThreadId
timeoutTId <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ThreadId
forkIO IO ()
timeoutThread)

  -- Start the client.
  (Maybe SomeException
exc :: Maybe SomeException) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch
    (forall s.
ConnectionConfig s
-> IO ()
-> ConduitM (Either ByteString (Event ByteString)) Void IO ()
-> ConduitM () (Message ByteString) IO ()
-> IO ()
_func ConnectionConfig s
cconf IO ()
initialise forall {a} {c}. ConduitT (Either a (Event ByteString)) c IO ()
sink ConduitM () (Message ByteString) IO ()
source forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ThreadId -> IO ()
killThread ThreadId
timeoutTId forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)
    (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just)

  forall s. IRC s ()
disconnect
  forall s. ConnectionConfig s -> Maybe SomeException -> IRC s ()
_ondisconnect ConnectionConfig s
cconf Maybe SomeException
exc

-- | Forget failed decodings.
forgetful :: Monad m => ConduitM (Either a b) b m ()
forgetful :: forall (m :: * -> *) a b. Monad m => ConduitM (Either a b) b m ()
forgetful = forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever forall {m :: * -> *} {a} {o} {i}.
Monad m =>
Either a o -> ConduitT i o m ()
go where
  go :: Either a o -> ConduitT i o m ()
go (Left  a
_) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  go (Right o
b) = forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield o
b

-- | Block on receiving a message and invoke all matching handlers.
eventSink :: MonadIO m => IORef UTCTime -> IRCState s -> ConduitM (Event ByteString) o m ()
eventSink :: forall (m :: * -> *) s o.
MonadIO m =>
IORef UTCTime -> IRCState s -> ConduitM (Event ByteString) o m ()
eventSink IORef UTCTime
lastReceived IRCState s
ircstate = forall {o}. ConduitT (Event ByteString) o m ()
go where
  go :: ConduitT (Event ByteString) o m ()
go = forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (\Event ByteString
event -> do
    -- Record the current time.
    UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef UTCTime
lastReceived UTCTime
now

    -- Handle the event.
    let event' :: Event Text
event' = ByteString -> Text
decodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event ByteString
event
    Bool
ignored <- forall (m :: * -> *) s.
MonadIO m =>
IRCState s -> Event Text -> m Bool
isIgnored IRCState s
ircstate Event Text
event'
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ignored forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
      InstanceConfig s
iconf <- forall (m :: * -> *) a s.
MonadIO m =>
Getting (TVar a) s (TVar a) -> s -> m a
snapshot forall s. Lens' (IRCState s) (TVar (InstanceConfig s))
instanceConfig IRCState s
ircstate
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a s. Getting a s a -> s -> a
get forall s. Lens' (InstanceConfig s) [EventHandler s]
handlers InstanceConfig s
iconf) forall a b. (a -> b) -> a -> b
$ \(EventHandler Event Text -> Maybe b
matcher Source Text -> b -> IRC s ()
handler) ->
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure ())
              (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. MonadIO m => IRC s a -> IRCState s -> m a
runIRCAction IRCState s
ircstate forall b c a. (b -> c) -> (a -> b) -> a -> c
. Source Text -> b -> IRC s ()
handler (forall a. Event a -> Source a
_source Event Text
event'))
              (Event Text -> Maybe b
matcher Event Text
event')

    -- If disconnected, do not loop.
    Bool
disconnected <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ (forall a. Eq a => a -> a -> Bool
==ConnectionState
Disconnected) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. IRCState s -> STM ConnectionState
getConnectionState IRCState s
ircstate
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
disconnected ConduitT (Event ByteString) o m ()
go)

-- | Check if an event is ignored or not.
isIgnored :: MonadIO m => IRCState s -> Event Text -> m Bool
isIgnored :: forall (m :: * -> *) s.
MonadIO m =>
IRCState s -> Event Text -> m Bool
isIgnored IRCState s
ircstate Event Text
ev = do
  InstanceConfig s
iconf <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TVar a -> IO a
readTVarIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. IRCState s -> TVar (InstanceConfig s)
_instanceConfig forall a b. (a -> b) -> a -> b
$ IRCState s
ircstate
  let ignoreList :: [(Text, Maybe Text)]
ignoreList = forall s. InstanceConfig s -> [(Text, Maybe Text)]
_ignore InstanceConfig s
iconf

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    case forall a. Event a -> Source a
_source Event Text
ev of
      User      Text
n ->  (Text
n, forall a. Maybe a
Nothing) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(Text, Maybe Text)]
ignoreList
      Channel Text
c Text
n -> ((Text
n, forall a. Maybe a
Nothing) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(Text, Maybe Text)]
ignoreList) Bool -> Bool -> Bool
|| ((Text
n, forall a. a -> Maybe a
Just Text
c) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(Text, Maybe Text)]
ignoreList)
      Server  Text
_   -> Bool
False

-- |A conduit which logs everything which goes through it.
logConduit :: MonadIO m => (a -> IO ()) -> ConduitM a a m ()
logConduit :: forall (m :: * -> *) a.
MonadIO m =>
(a -> IO ()) -> ConduitM a a m ()
logConduit a -> IO ()
logf = forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever forall a b. (a -> b) -> a -> b
$ \a
x -> do
  -- Call the logging function
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ a -> IO ()
logf a
x

  -- And pass the message on
  forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield a
x

-- | Print messages to stdout, with the current time.
stdoutLogger :: Origin -> ByteString -> IO ()
stdoutLogger :: Origin -> ByteString -> IO ()
stdoutLogger Origin
origin ByteString
x = do
  UTCTime
now <- IO UTCTime
getCurrentTime

  String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
    [ forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%c" UTCTime
now
    , if Origin
origin forall a. Eq a => a -> a -> Bool
== Origin
FromServer then String
"<---" else String
"--->"
    , forall a. [a] -> [a]
init forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ByteString
x
    ]

-- | Append messages to a file, with the current time.
fileLogger :: FilePath -> Origin -> ByteString -> IO ()
fileLogger :: String -> Origin -> ByteString -> IO ()
fileLogger String
fp Origin
origin ByteString
x = do
  UTCTime
now <- IO UTCTime
getCurrentTime

  String -> String -> IO ()
appendFile String
fp forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords
    [ forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%c" UTCTime
now
    , if Origin
origin forall a. Eq a => a -> a -> Bool
== Origin
FromServer then String
"--->" else String
"<---"
    , forall a. [a] -> [a]
init forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
tail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show ByteString
x
    , String
"\n"
    ]

-- | Do no logging.
noopLogger :: a -> b -> IO ()
noopLogger :: forall a b. a -> b -> IO ()
noopLogger a
_ b
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Clear passwords from logs.
concealPass :: Message ByteString -> Message ByteString
concealPass :: Message ByteString -> Message ByteString
concealPass (RawMsg ByteString
msg)
  | ByteString
"PASS " ByteString -> ByteString -> Bool
`isPrefixOf` ByteString
msg = ByteString -> [ByteString] -> Message ByteString
rawMessage ByteString
"PASS" [ByteString
"<password redacted>"]
concealPass Message ByteString
m = Message ByteString
m


-------------------------------------------------------------------------------
-- * Messaging

-- | Send a message as UTF-8, using TLS if enabled. This blocks if
-- messages are sent too rapidly.
send :: Message Text -> IRC s ()
send :: forall s. Message Text -> IRC s ()
send = forall s. Message ByteString -> IRC s ()
sendBS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ByteString
encodeUtf8

-- | Send a message, using TLS if enabled. This blocks if messages are
-- sent too rapidly.
sendBS :: Message ByteString -> IRC s ()
sendBS :: forall s. Message ByteString -> IRC s ()
sendBS Message ByteString
msg = do
  TVar (TBMChan (Message ByteString))
qv <- forall s. IRCState s -> TVar (TBMChan (Message ByteString))
_sendqueue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s. IRC s (IRCState s)
getIRCState
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. TBMChan a -> a -> STM ()
writeTBMChan Message ByteString
msg forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. TVar a -> STM a
readTVar TVar (TBMChan (Message ByteString))
qv


-------------------------------------------------------------------------------
-- * Disconnecting

-- | Disconnect from the server, properly tearing down the TLS session
-- (if there is one).
disconnect :: IRC s ()
disconnect :: forall s. IRC s ()
disconnect = do
  IRCState s
s <- forall s. IRC s (IRCState s)
getIRCState

  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    ConnectionState
connState <- forall a. TVar a -> IO a
readTVarIO (forall s. IRCState s -> TVar ConnectionState
_connectionState IRCState s
s)
    case ConnectionState
connState of
      ConnectionState
Connected -> do
        -- Set the state to @Disconnecting@
        forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar (forall s. IRCState s -> TVar ConnectionState
_connectionState IRCState s
s) ConnectionState
Disconnecting

        -- Wait for all messages to be sent, or a minute has passed.
        forall (m :: * -> *).
MonadIO m =>
NominalDiffTime -> IO Bool -> m ()
timeoutBlock NominalDiffTime
60 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
          TBMChan (Message ByteString)
queue <- forall a. TVar a -> STM a
readTVar (forall s. IRCState s -> TVar (TBMChan (Message ByteString))
_sendqueue IRCState s
s)
          Bool -> Bool -> Bool
(||) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TBMChan a -> STM Bool
isEmptyTBMChan TBMChan (Message ByteString)
queue forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. TBMChan a -> STM Bool
isClosedTBMChan TBMChan (Message ByteString)
queue

        -- Close the chan, which closes the sending conduit, and set
        -- the state to @Disconnected@.
        forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
          forall a. TBMChan a -> STM ()
closeTBMChan forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. TVar a -> STM a
readTVar (forall s. IRCState s -> TVar (TBMChan (Message ByteString))
_sendqueue IRCState s
s)
          forall a. TVar a -> a -> STM ()
writeTVar (forall s. IRCState s -> TVar ConnectionState
_connectionState IRCState s
s) ConnectionState
Disconnected

        -- Kill all managed threads. Don't wait for them to terminate
        -- here, as they might be masking exceptions and not pick up
        -- the 'Disconnect' for a while; just clear the list.
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall e. Exception e => ThreadId -> e -> IO ()
`throwTo` Disconnect
Disconnect) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. TVar a -> IO a
readTVarIO (forall s. IRCState s -> TVar (Set ThreadId)
_runningThreads IRCState s
s)
        forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar (forall s. IRCState s -> TVar (Set ThreadId)
_runningThreads IRCState s
s) forall a. Set a
S.empty

      -- If already disconnected, or disconnecting, do nothing.
      ConnectionState
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Disconnect from the server (this will wait for all messages to be
-- sent, or a minute to pass), and then connect again.
--
-- This can be called after the client has already disconnected, in
-- which case it will just connect again.
--
-- Like 'runClient' and 'runClientWith', this will not return until
-- the client terminates (ie, disconnects without reconnecting).
reconnect :: IRC s ()
reconnect :: forall s. IRC s ()
reconnect = do
  forall s. IRC s ()
disconnect

  -- create a new send queue
  IRCState s
s <- forall s. IRC s (IRCState s)
getIRCState
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$
    forall a. TVar a -> a -> STM ()
writeTVar (forall s. IRCState s -> TVar (TBMChan (Message ByteString))
_sendqueue IRCState s
s) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. Int -> STM (TBMChan a)
newTBMChan Int
16

  forall s. IRC s ()
runner


-------------------------------------------------------------------------------
-- * Utils

-- | Interact with a client from the outside, by using its 'IRCState'.
runIRCAction :: MonadIO m => IRC s a -> IRCState s -> m a
runIRCAction :: forall (m :: * -> *) s a. MonadIO m => IRC s a -> IRCState s -> m a
runIRCAction IRC s a
ma = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall s a. IRC s a -> ReaderT (IRCState s) IO a
runIRC IRC s a
ma)

-- | Access the client state.
getIRCState :: IRC s (IRCState s)
getIRCState :: forall s. IRC s (IRCState s)
getIRCState = forall r (m :: * -> *). MonadReader r m => m r
ask

-- | Get the connection state from an IRC state.
getConnectionState :: IRCState s -> STM ConnectionState
getConnectionState :: forall s. IRCState s -> STM ConnectionState
getConnectionState = forall a. TVar a -> STM a
readTVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. IRCState s -> TVar ConnectionState
_connectionState

-- | Block until an action is successful or a timeout is reached.
timeoutBlock :: MonadIO m => NominalDiffTime -> IO Bool -> m ()
timeoutBlock :: forall (m :: * -> *).
MonadIO m =>
NominalDiffTime -> IO Bool -> m ()
timeoutBlock NominalDiffTime
dt IO Bool
check = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  UTCTime
finish <- NominalDiffTime -> UTCTime -> UTCTime
addUTCTime NominalDiffTime
dt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
  let wait :: IO ()
wait = do
        UTCTime
now  <- IO UTCTime
getCurrentTime
        Bool
cond <- IO Bool
check
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTCTime
now forall a. Ord a => a -> a -> Bool
< UTCTime
finish Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
cond) IO ()
wait
  IO ()
wait

-- | A simple wrapper around a TBMChan. As data is pushed into the
-- channel, the source will read it and pass it down the conduit
-- pipeline. When the channel is closed, the source will close also.
--
-- If the channel fills up, the pipeline will stall until values are
-- read.
--
-- From stm-conduit-3.0.0 (by Clark Gaebel <cg.wowus.cg@gmail.com>)
sourceTBMChan :: MonadIO m => TBMChan a -> ConduitM () a m ()
sourceTBMChan :: forall (m :: * -> *) a.
MonadIO m =>
TBMChan a -> ConduitM () a m ()
sourceTBMChan TBMChan a
ch = forall {i}. ConduitT i a m ()
loop where
  loop :: ConduitT i a m ()
loop = do
    Maybe a
a <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TBMChan a -> STM (Maybe a)
readTBMChan TBMChan a
ch
    case Maybe a
a of
      Just a
x  -> forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield a
x forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ConduitT i a m ()
loop
      Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()