{-# 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, 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
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 :: 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
}
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
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
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
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)
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
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)
(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
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
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
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
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')
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)
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
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
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ a -> IO ()
logf a
x
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield a
x
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
]
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"
]
noopLogger :: a -> b -> IO ()
noopLogger :: forall a b. a -> b -> IO ()
noopLogger a
_ b
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
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
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
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
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
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
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
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
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
ConnectionState
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
reconnect :: IRC s ()
reconnect :: forall s. IRC s ()
reconnect = do
forall s. IRC s ()
disconnect
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
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)
getIRCState :: IRC s (IRCState s)
getIRCState :: forall s. IRC s (IRCState s)
getIRCState = forall r (m :: * -> *). MonadReader r m => m r
ask
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
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
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 ()