-- | The plugin-level IRC interface.

module Lambdabot.Plugin.IRC.IRC (ircPlugin) where

import Lambdabot.IRC
import Lambdabot.Logging
import Lambdabot.Monad
import Lambdabot.Plugin
import Lambdabot.Util
import Lambdabot.Config.IRC

import Control.Concurrent.Lifted
import qualified Control.Concurrent.SSem as SSem
import Control.Exception.Lifted as E (SomeException(..), throwIO, catch)
import Control.Monad
import Control.Monad.Trans
import Control.Monad.State
import qualified Data.ByteString.Char8 as P
import Data.List
import Data.List.Split
import qualified Data.Map as M
import Lambdabot.Util.Network (connectTo')
import Network.Socket (PortNumber)
import System.IO
import System.Timeout.Lifted
import Data.IORef

data IRCState =
    IRCState {
        IRCState -> Maybe String
password :: Maybe String
    }

type IRC = ModuleT IRCState LB

ircPlugin :: Module IRCState
ircPlugin :: Module IRCState
ircPlugin = forall st. Module st
newModule
    { moduleCmds :: ModuleT IRCState LB [Command (ModuleT IRCState LB)]
moduleCmds = forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (String -> Command Identity
command String
"irc-connect")
            { privileged :: Bool
privileged = Bool
True
            , help :: Cmd (ModuleT IRCState LB) ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"irc-connect tag host portnum nickname userinfo.  connect to an irc server"
            , process :: String -> Cmd (ModuleT IRCState LB) ()
process = \String
rest ->
                case forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
" " String
rest of
                    String
tag:String
hostn:String
portn:String
nickn:[String]
uix -> do
                        PortNumber
pn <- forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *) a. (MonadFail m, Read a) => String -> m a
readM String
portn
                        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> String -> PortNumber -> String -> String -> IRC ()
online String
tag String
hostn PortNumber
pn String
nickn (forall a. [a] -> [[a]] -> [a]
intercalate String
" " [String]
uix))
                    [String]
_ -> forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Not enough parameters!"
            }
        , (String -> Command Identity
command String
"irc-persist-connect")
            { privileged :: Bool
privileged = Bool
True
            , help :: Cmd (ModuleT IRCState LB) ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"irc-persist-connect tag host portnum nickname userinfo.  connect to an irc server and reconnect on network failures"
            , process :: String -> Cmd (ModuleT IRCState LB) ()
process = \String
rest ->
                case forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
" " String
rest of
                    String
tag:String
hostn:String
portn:String
nickn:[String]
uix -> do
                        PortNumber
pn <- forall a. Num a => Integer -> a
fromInteger forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *) a. (MonadFail m, Read a) => String -> m a
readM String
portn
                        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> String -> PortNumber -> String -> String -> IRC ()
online String
tag String
hostn PortNumber
pn String
nickn (forall a. [a] -> [[a]] -> [a]
intercalate String
" " [String]
uix))
                        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \IRCRWState
state' -> IRCRWState
state' { ircPersists :: Map String Bool
ircPersists = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
tag Bool
True forall a b. (a -> b) -> a -> b
$ IRCRWState -> Map String Bool
ircPersists IRCRWState
state' }
                    [String]
_ -> forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Not enough parameters!"
            }
        , (String -> Command Identity
command String
"irc-password")
            { privileged :: Bool
privileged = Bool
True
            , help :: Cmd (ModuleT IRCState LB) ()
help = forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"irc-password pwd.  set password for next irc-connect command"
            , process :: String -> Cmd (ModuleT IRCState LB) ()
process = \String
rest ->
                case forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
" " String
rest of
                    String
pwd:[String]
_ -> do
                        forall (m :: * -> *).
MonadLBState m =>
(LBState m -> LBState m) -> m ()
modifyMS (\LBState (Cmd (ModuleT IRCState LB))
ms -> LBState (Cmd (ModuleT IRCState LB))
ms{ password :: Maybe String
password = forall a. a -> Maybe a
Just String
pwd })
                    [String]
_ -> forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Not enough parameters!"
            }
        ]
    , moduleDefState :: LB IRCState
moduleDefState = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ IRCState{ password :: Maybe String
password = forall a. Maybe a
Nothing }
    }

----------------------------------------------------------------------
-- Encoding and decoding of messages

-- | 'encodeMessage' takes a message and converts it to a function.
--   giving this function a string will attach the string to the message
--   and output a string containing IRC protocol commands ready for writing
--   on the outgoing stream socket.
encodeMessage :: IrcMessage -> String -> String
encodeMessage :: IrcMessage -> String -> String
encodeMessage IrcMessage
msg
  = String -> String -> String
encodePrefix (IrcMessage -> String
ircMsgPrefix IrcMessage
msg) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
encodeCommand (IrcMessage -> String
ircMsgCommand IrcMessage
msg)
          forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String -> String
encodeParams (IrcMessage -> [String]
ircMsgParams IrcMessage
msg)
  where
    encodePrefix :: String -> String -> String
encodePrefix [] = forall a. a -> a
id
    encodePrefix String
prefix = Char -> String -> String
showChar Char
':' forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString' String
prefix forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> String
showChar Char
' '

    encodeCommand :: String -> String -> String
encodeCommand String
cmd = String -> String -> String
showString String
cmd

    encodeParams :: [String] -> String -> String
encodeParams [] = forall a. a -> a
id
    encodeParams (String
p:[String]
ps) = Char -> String -> String
showChar Char
' ' forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString' String
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String -> String
encodeParams [String]
ps

    -- IrcMessage is supposed to contain strings that are lists of bytes, but
    -- if a plugin messes up the encoding then we may end up with arbitrary
    -- Unicode codepoints. This is dangerous (\x10a would produce a newline!),
    -- so we sanitize the message here.
    showString' :: String -> String -> String
showString' = String -> String -> String
showString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c forall a. Ord a => a -> a -> Bool
> Char
'\xFF' then Char
'?' else Char
c)

-- | 'decodeMessage' Takes an input line from the IRC protocol stream
--   and decodes it into a message.  TODO: this has too many parameters.
decodeMessage :: String -> String -> String -> IrcMessage
decodeMessage :: String -> String -> String -> IrcMessage
decodeMessage String
svr String
lbn String
line =
    let (String
prefix, String
rest1) = forall {t}. (String -> String -> t) -> String -> t
decodePrefix (,) String
line
        (String
cmd, String
rest2)    = forall {t}. (String -> String -> t) -> String -> t
decodeCmd (,) String
rest1
        params :: [String]
params          = String -> [String]
decodeParams String
rest2
    in IrcMessage { ircMsgServer :: String
ircMsgServer = String
svr, ircMsgLBName :: String
ircMsgLBName = String
lbn, ircMsgPrefix :: String
ircMsgPrefix = String
prefix,
                    ircMsgCommand :: String
ircMsgCommand = String
cmd, ircMsgParams :: [String]
ircMsgParams = [String]
params }
  where
    decodePrefix :: (String -> String -> t) -> String -> t
decodePrefix String -> String -> t
k (Char
':':String
cs) = forall {t}. (String -> String -> t) -> String -> t
decodePrefix' String -> String -> t
k String
cs
      where decodePrefix' :: (String -> String -> t) -> String -> t
decodePrefix' String -> String -> t
j String
""       = String -> String -> t
j String
"" String
""
            decodePrefix' String -> String -> t
j (Char
' ':String
ds) = String -> String -> t
j String
"" String
ds
            decodePrefix' String -> String -> t
j (Char
c:String
ds)   = (String -> String -> t) -> String -> t
decodePrefix' (String -> String -> t
j forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
cforall a. a -> [a] -> [a]
:)) String
ds

    decodePrefix String -> String -> t
k String
cs = String -> String -> t
k String
"" String
cs

    decodeCmd :: (String -> String -> t) -> String -> t
decodeCmd String -> String -> t
k []       = String -> String -> t
k String
"" String
""
    decodeCmd String -> String -> t
k (Char
' ':String
cs) = String -> String -> t
k String
"" String
cs
    decodeCmd String -> String -> t
k (Char
c:String
cs)   = (String -> String -> t) -> String -> t
decodeCmd (String -> String -> t
k forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
cforall a. a -> [a] -> [a]
:)) String
cs

    decodeParams :: String -> [String]
    decodeParams :: String -> [String]
decodeParams String
xs = String -> [String] -> String -> [String]
decodeParams' [] [] String
xs
      where
        decodeParams' :: String -> [String] -> String -> [String]
decodeParams' String
param [String]
params []
          | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
param = forall a. [a] -> [a]
reverse [String]
params
          | Bool
otherwise  = forall a. [a] -> [a]
reverse (forall a. [a] -> [a]
reverse String
param forall a. a -> [a] -> [a]
: [String]
params)
        decodeParams' String
param [String]
params (Char
' ' : String
cs)
          | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
param = String -> [String] -> String -> [String]
decodeParams' [] [String]
params String
cs
          | Bool
otherwise  = String -> [String] -> String -> [String]
decodeParams' [] (forall a. [a] -> [a]
reverse String
param forall a. a -> [a] -> [a]
: [String]
params) String
cs
        decodeParams' String
param [String]
params rest :: String
rest@(c :: Char
c@Char
':' : String
cs)
          | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
param = forall a. [a] -> [a]
reverse (String
rest forall a. a -> [a] -> [a]
: [String]
params)
          | Bool
otherwise  = String -> [String] -> String -> [String]
decodeParams' (Char
cforall a. a -> [a] -> [a]
:String
param) [String]
params String
cs
        decodeParams' String
param [String]
params (Char
c:String
cs) = String -> [String] -> String -> [String]
decodeParams' (Char
cforall a. a -> [a] -> [a]
:String
param) [String]
params String
cs

ircSignOn :: String -> Nick -> Maybe String -> String -> LB ()
ircSignOn :: String -> Nick -> Maybe String -> String -> LB ()
ircSignOn String
svr Nick
nickn Maybe String
pwd String
ircname = do
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (\String
pwd' -> IrcMessage -> LB ()
send forall a b. (a -> b) -> a -> b
$ String -> String -> IrcMessage
pass (Nick -> String
nTag Nick
nickn) String
pwd') Maybe String
pwd
    IrcMessage -> LB ()
send forall a b. (a -> b) -> a -> b
$ String -> String -> String -> String -> IrcMessage
user (Nick -> String
nTag Nick
nickn) (Nick -> String
nName Nick
nickn) String
svr String
ircname
    IrcMessage -> LB ()
send forall a b. (a -> b) -> a -> b
$ Nick -> IrcMessage
setNick Nick
nickn

------------------------------------------------------------------------
--
-- Lambdabot is mostly synchronous.  We have a main loop, which reads
-- messages and forks threads to execute commands (which write responses).
-- OR
-- We have a main loop which reads offline commands, and synchronously
-- interprets them.

online :: String -> String -> PortNumber -> String -> String -> IRC ()
online :: String -> String -> PortNumber -> String -> String -> IRC ()
online String
tag String
hostn PortNumber
portnum String
nickn String
ui = do
    Maybe String
pwd <- IRCState -> Maybe String
password forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *). MonadLBState m => m (LBState m)
readMS
    forall (m :: * -> *).
MonadLBState m =>
(LBState m -> LBState m) -> m ()
modifyMS forall a b. (a -> b) -> a -> b
$ \LBState (ModuleT IRCState LB)
ms -> LBState (ModuleT IRCState LB)
ms{ password :: Maybe String
password = forall a. Maybe a
Nothing }

    let online' :: IRC ()
online' = do
        Handle
sock    <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ String -> PortNumber -> IO Handle
connectTo' String
hostn PortNumber
portnum
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
sock BufferMode
NoBuffering
        -- Implements flood control: RFC 2813, section 5.8
        SSem
sem1    <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Int -> IO SSem
SSem.new Int
0
        SSem
sem2    <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Int -> IO SSem
SSem.new Int
4 -- one extra token stays in the MVar
        MVar ()
sendmv  <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall (m :: * -> *) a. MonadBase IO m => m (MVar a)
newEmptyMVar
        IORef Bool
pongref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef Bool
False
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
fork forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
            SSem -> IO ()
SSem.wait SSem
sem1
            forall (m :: * -> *). MonadBase IO m => Int -> m ()
threadDelay Int
2000000
            SSem -> IO ()
SSem.signal SSem
sem2
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
fork forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
            SSem -> IO ()
SSem.wait SSem
sem2
            forall (m :: * -> *) a. MonadBase IO m => MVar a -> a -> m ()
putMVar MVar ()
sendmv ()
            SSem -> IO ()
SSem.signal SSem
sem1
        SSem
fin <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Int -> IO SSem
SSem.new Int
0
        forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
E.catch
            (forall st. String -> Server st -> ModuleT st LB ()
registerServer String
tag (forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> MVar () -> SSem -> IrcMessage -> IO ()
sendMsg Handle
sock MVar ()
sendmv SSem
fin))
            (\err :: SomeException
err@SomeException{} -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (Handle -> IO ()
hClose Handle
sock) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
E.throwIO SomeException
err)
        forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb forall a b. (a -> b) -> a -> b
$ String -> Nick -> Maybe String -> String -> LB ()
ircSignOn String
hostn (String -> String -> Nick
Nick String
tag String
nickn) Maybe String
pwd String
ui
        SSem
ready <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Int -> IO SSem
SSem.new Int
0
        forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> (Either SomeException a -> m ()) -> m ThreadId
forkFinally
            (forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
E.catch
                (String -> String -> IORef Bool -> Handle -> SSem -> LB ()
readerLoop String
tag String
nickn IORef Bool
pongref Handle
sock SSem
ready)
                (\e :: SomeException
e@SomeException{} -> forall (m :: * -> *). MonadLogging m => String -> m ()
errorM (forall a. Show a => a -> String
show SomeException
e)))
            (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ SSem -> IO ()
SSem.signal SSem
fin)
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> (Either SomeException a -> m ()) -> m ThreadId
forkFinally
            (forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
E.catch
                (IRC ()
pingPongDelay forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> String -> IORef Bool -> Handle -> IRC ()
pingPongLoop String
tag String
hostn IORef Bool
pongref Handle
sock)
                (\e :: SomeException
e@SomeException{} -> forall (m :: * -> *). MonadLogging m => String -> m ()
errorM (forall a. Show a => a -> String
show SomeException
e)))
            (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ SSem -> IO ()
SSem.signal SSem
fin)
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
fork forall a b. (a -> b) -> a -> b
$ do
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ SSem -> IO ()
SSem.wait SSem
fin
            forall mod. String -> ModuleT mod LB ()
unregisterServer String
tag
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
sock
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ SSem -> IO ()
SSem.signal SSem
ready
            Int
delay <- forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config Int
reconnectDelay
            let retry :: IRC ()
retry = do
                Bool
continue <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ \IRCRWState
st -> (forall k a. Ord k => k -> Map k a -> Bool
M.member String
tag forall a b. (a -> b) -> a -> b
$ IRCRWState -> Map String Bool
ircPersists IRCRWState
st) Bool -> Bool -> Bool
&& Bool -> Bool
not (forall k a. Ord k => k -> Map k a -> Bool
M.member String
tag forall a b. (a -> b) -> a -> b
$ IRCRWState -> Map String (DSum ModuleID ServerRef)
ircServerMap IRCRWState
st)
                if Bool
continue
                    then do
                        forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
E.catch IRC ()
online'
                            (\e :: SomeException
e@SomeException{} -> do
                                forall (m :: * -> *). MonadLogging m => String -> m ()
errorM (forall a. Show a => a -> String
show SomeException
e)
                                forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadBase IO m => Int -> m ()
threadDelay Int
delay
                                IRC ()
retry
                            )
                    else do
                        Map ChanName String
chans <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets IRCRWState -> Map ChanName String
ircChannels
                        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [k]
M.keys Map ChanName String
chans) forall a b. (a -> b) -> a -> b
$ \ChanName
chan ->
                            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Nick -> String
nTag (ChanName -> Nick
getCN ChanName
chan) forall a. Eq a => a -> a -> Bool
== String
tag) forall a b. (a -> b) -> a -> b
$
                            forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \IRCRWState
state' -> IRCRWState
state' { ircChannels :: Map ChanName String
ircChannels = forall k a. Ord k => k -> Map k a -> Map k a
M.delete ChanName
chan forall a b. (a -> b) -> a -> b
$ IRCRWState -> Map ChanName String
ircChannels IRCRWState
state' }

            IRC ()
retry
        ThreadId
watch <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
fork forall a b. (a -> b) -> a -> b
$ do
            forall (m :: * -> *). MonadBase IO m => Int -> m ()
threadDelay Int
10000000
            forall (m :: * -> *). MonadLogging m => String -> m ()
errorM String
"Welcome timeout!"
            SSem -> IO ()
SSem.signal SSem
fin
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ SSem -> IO ()
SSem.wait SSem
ready
        forall (m :: * -> *). MonadBase IO m => ThreadId -> m ()
killThread ThreadId
watch

    IRC ()
online'

pingPongDelay :: IRC ()
pingPongDelay :: IRC ()
pingPongDelay = forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadBase IO m => Int -> m ()
threadDelay Int
120000000

pingPongLoop :: String -> String -> IORef Bool -> Handle -> IRC ()
pingPongLoop :: String -> String -> IORef Bool -> Handle -> IRC ()
pingPongLoop String
tag String
hostn IORef Bool
pongref Handle
sock = do
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
pongref Bool
False
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
P.hPut Handle
sock forall a b. (a -> b) -> a -> b
$ String -> ByteString
P.pack forall a b. (a -> b) -> a -> b
$ String
"PING " forall a. [a] -> [a] -> [a]
++ String
hostn forall a. [a] -> [a] -> [a]
++ String
"\r\n"
    IRC ()
pingPongDelay
    Bool
pong <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef Bool
pongref
    if Bool
pong
        then String -> String -> IORef Bool -> Handle -> IRC ()
pingPongLoop String
tag String
hostn IORef Bool
pongref Handle
sock
        else forall (m :: * -> *). MonadLogging m => String -> m ()
errorM String
"Ping timeout."

readerLoop :: String -> String -> IORef Bool -> Handle -> SSem.SSem -> LB ()
readerLoop :: String -> String -> IORef Bool -> Handle -> SSem -> LB ()
readerLoop String
tag String
nickn IORef Bool
pongref Handle
sock SSem
ready = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
    String
line <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Handle -> IO String
hGetLine Handle
sock
    let line' :: String
line' = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
"\r\n") String
line
    if String
"PING " forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
line'
        then forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
P.hPut Handle
sock forall a b. (a -> b) -> a -> b
$ String -> ByteString
P.pack forall a b. (a -> b) -> a -> b
$ String
"PONG " forall a. [a] -> [a] -> [a]
++ forall a. Int -> [a] -> [a]
drop Int
5 String
line' forall a. [a] -> [a] -> [a]
++ String
"\r\n"
        else forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
fork forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
MonadBaseControl IO m =>
Int -> m a -> m (Maybe a)
timeout Int
15000000 forall a b. (a -> b) -> a -> b
$ do
            let msg :: IrcMessage
msg = String -> String -> String -> IrcMessage
decodeMessage String
tag String
nickn String
line'
            if IrcMessage -> String
ircMsgCommand IrcMessage
msg forall a. Eq a => a -> a -> Bool
== String
"PONG"
                then forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
pongref Bool
True
                else do
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IrcMessage -> String
ircMsgCommand IrcMessage
msg forall a. Eq a => a -> a -> Bool
== String
"001") forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ SSem -> IO ()
SSem.signal SSem
ready
                    IrcMessage -> LB ()
received IrcMessage
msg

sendMsg :: Handle -> MVar () -> SSem.SSem -> IrcMessage -> IO ()
sendMsg :: Handle -> MVar () -> SSem -> IrcMessage -> IO ()
sendMsg Handle
sock MVar ()
mv SSem
fin IrcMessage
msg =
    forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
E.catch (do forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
takeMVar MVar ()
mv
                Handle -> ByteString -> IO ()
P.hPut Handle
sock forall a b. (a -> b) -> a -> b
$ String -> ByteString
P.pack forall a b. (a -> b) -> a -> b
$ IrcMessage -> String -> String
encodeMessage IrcMessage
msg String
"\r\n")
            (\IOError
err -> do forall (m :: * -> *). MonadLogging m => String -> m ()
errorM (forall a. Show a => a -> String
show (IOError
err :: IOError))
                        SSem -> IO ()
SSem.signal SSem
fin)