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 }
}
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
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 :: 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
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
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
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)