-- | 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 = Module IRCState
forall st. Module st
newModule
    { moduleCmds = return
        [ (command "irc-connect")
            { privileged = True
            , help = say "irc-connect tag host portnum nickname userinfo.  connect to an irc server"
            , process = \String
rest ->
                case String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
" " String
rest of
                    String
tag:String
hostn:String
portn:String
nickn:[String]
uix -> do
                        pn <- Integer -> PortNumber
forall a. Num a => Integer -> a
fromInteger (Integer -> PortNumber)
-> Cmd (ModuleT IRCState LB) Integer
-> Cmd (ModuleT IRCState LB) PortNumber
forall a b.
(a -> b)
-> Cmd (ModuleT IRCState LB) a -> Cmd (ModuleT IRCState LB) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> Cmd (ModuleT IRCState LB) Integer
forall (m :: * -> *) a. (MonadFail m, Read a) => String -> m a
readM String
portn
                        lift (online tag hostn pn nickn (intercalate " " uix))
                    [String]
_ -> String -> Cmd (ModuleT IRCState LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Not enough parameters!"
            }
        , (command "irc-persist-connect")
            { privileged = True
            , help = say "irc-persist-connect tag host portnum nickname userinfo.  connect to an irc server and reconnect on network failures"
            , process = \String
rest ->
                case String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
" " String
rest of
                    String
tag:String
hostn:String
portn:String
nickn:[String]
uix -> do
                        pn <- Integer -> PortNumber
forall a. Num a => Integer -> a
fromInteger (Integer -> PortNumber)
-> Cmd (ModuleT IRCState LB) Integer
-> Cmd (ModuleT IRCState LB) PortNumber
forall a b.
(a -> b)
-> Cmd (ModuleT IRCState LB) a -> Cmd (ModuleT IRCState LB) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> Cmd (ModuleT IRCState LB) Integer
forall (m :: * -> *) a. (MonadFail m, Read a) => String -> m a
readM String
portn
                        lift (online tag hostn pn nickn (intercalate " " uix))
                        lift $ lift $ modify $ \IRCRWState
state' -> IRCRWState
state' { ircPersists = M.insert tag True $ ircPersists state' }
                    [String]
_ -> String -> Cmd (ModuleT IRCState LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Not enough parameters!"
            }
        , (command "irc-password")
            { privileged = True
            , help = say "irc-password pwd.  set password for next irc-connect command"
            , process = \String
rest ->
                case String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
" " String
rest of
                    String
pwd:[String]
_ -> do
                        (LBState (Cmd (ModuleT IRCState LB))
 -> LBState (Cmd (ModuleT IRCState LB)))
-> Cmd (ModuleT IRCState LB) ()
forall (m :: * -> *).
MonadLBState m =>
(LBState m -> LBState m) -> m ()
modifyMS (\LBState (Cmd (ModuleT IRCState LB))
ms -> LBState (Cmd (ModuleT IRCState LB))
ms{ password = Just pwd })
                    [String]
_ -> String -> Cmd (ModuleT IRCState LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"Not enough parameters!"
            }
        ]
    , moduleDefState = return $ IRCState{ password = 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) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
encodeCommand (IrcMessage -> String
ircMsgCommand IrcMessage
msg)
          (String -> String) -> (String -> String) -> String -> String
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 [] = String -> String
forall a. a -> a
id
    encodePrefix String
prefix = Char -> String -> String
showChar Char
':' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString' String
prefix (String -> String) -> (String -> String) -> String -> String
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 [] = String -> String
forall a. a -> a
id
    encodeParams (String
p:[String]
ps) = Char -> String -> String
showChar Char
' ' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
showString' String
p (String -> String) -> (String -> String) -> String -> String
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 (String -> String -> String)
-> (String -> String) -> String -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> Char -> Bool
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) = (String -> String -> (String, String))
-> String -> (String, String)
forall {t}. (String -> String -> t) -> String -> t
decodePrefix (,) String
line
        (String
cmd, String
rest2)    = (String -> String -> (String, String))
-> String -> (String, String)
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) = (String -> String -> t) -> String -> t
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 (String -> String -> t)
-> (String -> String) -> String -> String -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
cChar -> String -> String
forall 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 (String -> String -> t)
-> (String -> String) -> String -> String -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
cChar -> String -> String
forall 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 []
          | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
param = [String] -> [String]
forall a. [a] -> [a]
reverse [String]
params
          | Bool
otherwise  = [String] -> [String]
forall a. [a] -> [a]
reverse (String -> String
forall a. [a] -> [a]
reverse String
param String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
params)
        decodeParams' String
param [String]
params (Char
' ' : String
cs)
          | String -> Bool
forall a. [a] -> Bool
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' [] (String -> String
forall a. [a] -> [a]
reverse String
param String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
params) String
cs
        decodeParams' String
param [String]
params rest :: String
rest@(c :: Char
c@Char
':' : String
cs)
          | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
param = [String] -> [String]
forall a. [a] -> [a]
reverse (String
rest String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
params)
          | Bool
otherwise  = String -> [String] -> String -> [String]
decodeParams' (Char
cChar -> String -> String
forall 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
cChar -> String -> String
forall 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
    LB () -> (String -> LB ()) -> Maybe String -> LB ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> LB ()
forall a. a -> LB a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (\String
pwd' -> IrcMessage -> LB ()
send (IrcMessage -> LB ()) -> IrcMessage -> LB ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IrcMessage
pass (Nick -> String
nTag Nick
nickn) String
pwd') Maybe String
pwd
    IrcMessage -> LB ()
send (IrcMessage -> LB ()) -> IrcMessage -> LB ()
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 (IrcMessage -> LB ()) -> IrcMessage -> LB ()
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
-> ModuleT IRCState LB ()
online String
tag String
hostn PortNumber
portnum String
nickn String
ui = do
    pwd <- IRCState -> Maybe String
password (IRCState -> Maybe String)
-> ModuleT IRCState LB IRCState
-> ModuleT IRCState LB (Maybe String)
forall a b.
(a -> b) -> ModuleT IRCState LB a -> ModuleT IRCState LB b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ModuleT IRCState LB (LBState (ModuleT IRCState LB))
ModuleT IRCState LB IRCState
forall (m :: * -> *). MonadLBState m => m (LBState m)
readMS
    modifyMS $ \LBState (ModuleT IRCState LB)
ms -> LBState (ModuleT IRCState LB)
ms{ password = Nothing }

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

            retry
        watch <- io $ fork $ do
            threadDelay 10000000
            errorM "Welcome timeout!"
            SSem.signal fin
        io $ SSem.wait ready
        killThread watch

    online'

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

pingPongLoop :: String -> String -> IORef Bool -> Handle -> IRC ()
pingPongLoop :: String -> String -> IORef Bool -> Handle -> ModuleT IRCState LB ()
pingPongLoop String
tag String
hostn IORef Bool
pongref Handle
sock = do
    IO () -> ModuleT IRCState LB ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> ModuleT IRCState LB ())
-> IO () -> ModuleT IRCState LB ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
pongref Bool
False
    IO () -> ModuleT IRCState LB ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> ModuleT IRCState LB ())
-> IO () -> ModuleT IRCState LB ()
forall a b. (a -> b) -> a -> b
$ Handle -> ByteString -> IO ()
P.hPut Handle
sock (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString
P.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"PING " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hostn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\r\n"
    ModuleT IRCState LB ()
pingPongDelay
    pong <- IO Bool -> ModuleT IRCState LB Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO Bool -> ModuleT IRCState LB Bool)
-> IO Bool -> ModuleT IRCState LB Bool
forall a b. (a -> b) -> a -> b
$ IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
pongref
    if pong
        then pingPongLoop tag hostn pongref sock
        else errorM "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 = LB () -> LB ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (LB () -> LB ()) -> LB () -> LB ()
forall a b. (a -> b) -> a -> b
$ do
    line <- IO String -> LB String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO String -> LB String) -> IO String -> LB String
forall a b. (a -> b) -> a -> b
$ Handle -> IO String
hGetLine Handle
sock
    let line' = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
"\r\n") String
line
    if "PING " `isPrefixOf` line'
        then io $ P.hPut sock $ P.pack $ "PONG " ++ drop 5 line' ++ "\r\n"
        else void . fork . void . timeout 15000000 $ do
            let msg = String -> String -> String -> IrcMessage
decodeMessage String
tag String
nickn String
line'
            if ircMsgCommand msg == "PONG"
                then io $ writeIORef pongref True
                else do
                    when (ircMsgCommand msg == "001") $ io $ SSem.signal ready
                    received msg

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