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 :: ModuleT IRCState LB [Command (ModuleT IRCState LB)]
moduleCmds = [Command (ModuleT IRCState LB)]
-> ModuleT IRCState LB [Command (ModuleT IRCState LB)]
forall (m :: * -> *) a. Monad m => a -> m a
return
[ (String -> Command Identity
command "irc-connect")
{ privileged :: Bool
privileged = Bool
True
, help :: Cmd (ModuleT IRCState LB) ()
help = String -> Cmd (ModuleT IRCState LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say "irc-connect tag host portnum nickname userinfo. connect to an irc server"
, process :: String -> Cmd (ModuleT IRCState LB) ()
process = \rest :: String
rest ->
case String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn " " String
rest of
tag :: String
tag:hostn :: String
hostn:portn :: String
portn:nickn :: String
nickn:uix :: [String]
uix -> do
PortNumber
pn <- Integer -> PortNumber
forall a. Num a => Integer -> a
fromInteger (Integer -> PortNumber)
-> Cmd (ModuleT IRCState LB) Integer
-> Cmd (ModuleT IRCState LB) PortNumber
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
ModuleT IRCState LB () -> Cmd (ModuleT IRCState LB) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String
-> String
-> PortNumber
-> String
-> String
-> ModuleT IRCState LB ()
online String
tag String
hostn PortNumber
pn String
nickn (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate " " [String]
uix))
_ -> String -> Cmd (ModuleT IRCState LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say "Not enough parameters!"
}
, (String -> Command Identity
command "irc-persist-connect")
{ privileged :: Bool
privileged = Bool
True
, help :: Cmd (ModuleT IRCState LB) ()
help = String -> Cmd (ModuleT IRCState LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say "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 = \rest :: String
rest ->
case String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn " " String
rest of
tag :: String
tag:hostn :: String
hostn:portn :: String
portn:nickn :: String
nickn:uix :: [String]
uix -> do
PortNumber
pn <- Integer -> PortNumber
forall a. Num a => Integer -> a
fromInteger (Integer -> PortNumber)
-> Cmd (ModuleT IRCState LB) Integer
-> Cmd (ModuleT IRCState LB) PortNumber
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
ModuleT IRCState LB () -> Cmd (ModuleT IRCState LB) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String
-> String
-> PortNumber
-> String
-> String
-> ModuleT IRCState LB ()
online String
tag String
hostn PortNumber
pn String
nickn (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate " " [String]
uix))
ModuleT IRCState LB () -> Cmd (ModuleT IRCState LB) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ModuleT IRCState LB () -> Cmd (ModuleT IRCState LB) ())
-> ModuleT IRCState LB () -> Cmd (ModuleT IRCState LB) ()
forall a b. (a -> b) -> a -> b
$ LB () -> ModuleT IRCState LB ()
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
$ \state' :: IRCRWState
state' -> IRCRWState
state' { ircPersists :: Map String Bool
ircPersists = String -> Bool -> Map String Bool -> Map String Bool
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
tag Bool
True (Map String Bool -> Map String Bool)
-> Map String Bool -> Map String Bool
forall a b. (a -> b) -> a -> b
$ IRCRWState -> Map String Bool
ircPersists IRCRWState
state' }
_ -> String -> Cmd (ModuleT IRCState LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say "Not enough parameters!"
}
, (String -> Command Identity
command "irc-password")
{ privileged :: Bool
privileged = Bool
True
, help :: Cmd (ModuleT IRCState LB) ()
help = String -> Cmd (ModuleT IRCState LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say "irc-password pwd. set password for next irc-connect command"
, process :: String -> Cmd (ModuleT IRCState LB) ()
process = \rest :: String
rest ->
case String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn " " String
rest of
pwd :: String
pwd:_ -> 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 (\ms :: LBState (Cmd (ModuleT IRCState LB))
ms -> LBState (Cmd (ModuleT IRCState LB))
IRCState
ms{ password :: Maybe String
password = String -> Maybe String
forall a. a -> Maybe a
Just String
pwd })
_ -> String -> Cmd (ModuleT IRCState LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say "Not enough parameters!"
}
]
, moduleDefState :: LB IRCState
moduleDefState = IRCState -> LB IRCState
forall (m :: * -> *) a. Monad m => a -> m a
return (IRCState -> LB IRCState) -> IRCState -> LB IRCState
forall a b. (a -> b) -> a -> b
$ IRCState :: Maybe String -> IRCState
IRCState{ password :: Maybe String
password = Maybe String
forall a. Maybe a
Nothing }
}
encodeMessage :: IrcMessage -> String -> String
encodeMessage :: IrcMessage -> String -> String
encodeMessage msg :: 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 prefix :: String
prefix = Char -> String -> String
showChar ':' (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 ' '
encodeCommand :: String -> String -> String
encodeCommand cmd :: String
cmd = String -> String -> String
showString String
cmd
encodeParams :: [String] -> String -> String
encodeParams [] = String -> String
forall a. a -> a
id
encodeParams (p :: String
p:ps :: [String]
ps) = Char -> String -> String
showChar ' ' (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
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 (\c :: Char
c -> if Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
> '\xFF' then '?' else Char
c)
decodeMessage :: String -> String -> String -> IrcMessage
decodeMessage :: String -> String -> String -> IrcMessage
decodeMessage svr :: String
svr lbn :: String
lbn line :: String
line =
let (prefix :: String
prefix, rest1 :: String
rest1) = (String -> String -> (String, String))
-> String -> (String, String)
forall p. (String -> String -> p) -> String -> p
decodePrefix (,) String
line
(cmd :: String
cmd, rest2 :: String
rest2) = (String -> String -> (String, String))
-> String -> (String, String)
forall p. (String -> String -> p) -> String -> p
decodeCmd (,) String
rest1
params :: [String]
params = String -> [String]
decodeParams String
rest2
in $WIrcMessage :: String -> String -> String -> String -> [String] -> IrcMessage
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 -> p) -> String -> p
decodePrefix k :: String -> String -> p
k (':':cs :: String
cs) = (String -> String -> p) -> String -> p
forall p. (String -> String -> p) -> String -> p
decodePrefix' String -> String -> p
k String
cs
where decodePrefix' :: (String -> String -> p) -> String -> p
decodePrefix' j :: String -> String -> p
j "" = String -> String -> p
j "" ""
decodePrefix' j :: String -> String -> p
j (' ':ds :: String
ds) = String -> String -> p
j "" String
ds
decodePrefix' j :: String -> String -> p
j (c :: Char
c:ds :: String
ds) = (String -> String -> p) -> String -> p
decodePrefix' (String -> String -> p
j (String -> String -> p)
-> (String -> String) -> String -> String -> p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:)) String
ds
decodePrefix k :: String -> String -> p
k cs :: String
cs = String -> String -> p
k "" String
cs
decodeCmd :: (String -> String -> p) -> String -> p
decodeCmd k :: String -> String -> p
k [] = String -> String -> p
k "" ""
decodeCmd k :: String -> String -> p
k (' ':cs :: String
cs) = String -> String -> p
k "" String
cs
decodeCmd k :: String -> String -> p
k (c :: Char
c:cs :: String
cs) = (String -> String -> p) -> String -> p
decodeCmd (String -> String -> p
k (String -> String -> p)
-> (String -> String) -> String -> String -> p
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 xs :: String
xs = String -> [String] -> String -> [String]
decodeParams' [] [] String
xs
where
decodeParams' :: String -> [String] -> String -> [String]
decodeParams' param :: String
param params :: [String]
params []
| String -> 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' param :: String
param params :: [String]
params (' ' : cs :: String
cs)
| String -> 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' param :: String
param params :: [String]
params rest :: String
rest@(c :: Char
c@Char
':' : cs :: String
cs)
| String -> 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' param :: String
param params :: [String]
params (c :: Char
c:cs :: 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 svr :: String
svr nickn :: Nick
nickn pwd :: Maybe String
pwd ircname :: String
ircname = do
LB () -> (String -> LB ()) -> Maybe String -> LB ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> LB ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (\pwd' :: 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
online :: String -> String -> PortNumber -> String -> String -> IRC ()
online :: String
-> String
-> PortNumber
-> String
-> String
-> ModuleT IRCState LB ()
online tag :: String
tag hostn :: String
hostn portnum :: PortNumber
portnum nickn :: String
nickn ui :: String
ui = do
Maybe String
pwd <- IRCState -> Maybe String
password (IRCState -> Maybe String)
-> ModuleT IRCState LB IRCState
-> ModuleT IRCState LB (Maybe String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ModuleT IRCState LB IRCState
forall (m :: * -> *). MonadLBState m => m (LBState m)
readMS
(LBState (ModuleT IRCState LB) -> LBState (ModuleT IRCState LB))
-> ModuleT IRCState LB ()
forall (m :: * -> *).
MonadLBState m =>
(LBState m -> LBState m) -> m ()
modifyMS ((LBState (ModuleT IRCState LB) -> LBState (ModuleT IRCState LB))
-> ModuleT IRCState LB ())
-> (LBState (ModuleT IRCState LB) -> LBState (ModuleT IRCState LB))
-> ModuleT IRCState LB ()
forall a b. (a -> b) -> a -> b
$ \ms :: LBState (ModuleT IRCState LB)
ms -> LBState (ModuleT IRCState LB)
IRCState
ms{ password :: Maybe String
password = Maybe String
forall a. Maybe a
Nothing }
let online' :: ModuleT IRCState LB ()
online' = do
Handle
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 () -> 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 -> BufferMode -> IO ()
hSetBuffering Handle
sock BufferMode
NoBuffering
SSem
sem1 <- IO SSem -> ModuleT IRCState LB SSem
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO SSem -> ModuleT IRCState LB SSem)
-> IO SSem -> ModuleT IRCState LB SSem
forall a b. (a -> b) -> a -> b
$ Int -> IO SSem
SSem.new 0
SSem
sem2 <- IO SSem -> ModuleT IRCState LB SSem
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO SSem -> ModuleT IRCState LB SSem)
-> IO SSem -> ModuleT IRCState LB SSem
forall a b. (a -> b) -> a -> b
$ Int -> IO SSem
SSem.new 4
MVar ()
sendmv <- IO (MVar ()) -> ModuleT IRCState LB (MVar ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io IO (MVar ())
forall (m :: * -> *) a. MonadBase IO m => m (MVar a)
newEmptyMVar
IORef Bool
pongref <- IO (IORef Bool) -> ModuleT IRCState LB (IORef Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO (IORef Bool) -> ModuleT IRCState LB (IORef Bool))
-> IO (IORef Bool) -> ModuleT IRCState LB (IORef Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
IO () -> ModuleT IRCState LB ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> ModuleT IRCState LB ())
-> (IO () -> IO ()) -> IO () -> ModuleT IRCState LB ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
fork (IO () -> IO ThreadId) -> (IO () -> IO ()) -> IO () -> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> ModuleT IRCState LB ())
-> IO () -> ModuleT IRCState LB ()
forall a b. (a -> b) -> a -> b
$ do
SSem -> IO ()
SSem.wait SSem
sem1
Int -> IO ()
forall (m :: * -> *). MonadBase IO m => Int -> m ()
threadDelay 2000000
SSem -> IO ()
SSem.signal SSem
sem2
IO () -> ModuleT IRCState LB ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> ModuleT IRCState LB ())
-> (IO () -> IO ()) -> IO () -> ModuleT IRCState LB ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
fork (IO () -> IO ThreadId) -> (IO () -> IO ()) -> IO () -> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> ModuleT IRCState LB ())
-> IO () -> ModuleT IRCState LB ()
forall a b. (a -> b) -> a -> b
$ do
SSem -> IO ()
SSem.wait SSem
sem2
MVar () -> () -> IO ()
forall (m :: * -> *) a. MonadBase IO m => MVar a -> a -> m ()
putMVar MVar ()
sendmv ()
SSem -> IO ()
SSem.signal SSem
sem1
SSem
fin <- IO SSem -> ModuleT IRCState LB SSem
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO SSem -> ModuleT IRCState LB SSem)
-> IO SSem -> ModuleT IRCState LB SSem
forall a b. (a -> b) -> a -> b
$ Int -> IO SSem
SSem.new 0
ModuleT IRCState LB ()
-> (SomeException -> ModuleT IRCState LB ())
-> ModuleT IRCState LB ()
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
E.catch
(String -> Server IRCState -> ModuleT IRCState LB ()
forall st. String -> Server st -> ModuleT st LB ()
registerServer String
tag (IO () -> ModuleT IRCState LB ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> ModuleT IRCState LB ())
-> (IrcMessage -> IO ()) -> Server IRCState
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{} -> 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 (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 () -> ModuleT IRCState LB ()
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (LB () -> ModuleT IRCState LB ())
-> LB () -> ModuleT IRCState 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 <- IO SSem -> ModuleT IRCState LB SSem
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO SSem -> ModuleT IRCState LB SSem)
-> IO SSem -> ModuleT IRCState LB SSem
forall a b. (a -> b) -> a -> b
$ Int -> IO SSem
SSem.new 0
LB () -> ModuleT IRCState LB ()
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (LB () -> ModuleT IRCState LB ())
-> LB () -> ModuleT IRCState LB ()
forall a b. (a -> b) -> a -> b
$ LB ThreadId -> LB ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LB ThreadId -> LB ()) -> LB ThreadId -> LB ()
forall a b. (a -> b) -> a -> b
$ LB () -> (Either SomeException () -> LB ()) -> LB ThreadId
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> (Either SomeException a -> m ()) -> m ThreadId
forkFinally
(LB () -> (SomeException -> LB ()) -> LB ()
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{} -> String -> LB ()
forall (m :: * -> *). MonadLogging m => String -> m ()
errorM (SomeException -> String
forall a. Show a => a -> String
show SomeException
e)))
(LB () -> Either SomeException () -> LB ()
forall a b. a -> b -> a
const (LB () -> Either SomeException () -> LB ())
-> LB () -> Either SomeException () -> LB ()
forall a b. (a -> b) -> a -> b
$ IO () -> LB ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> LB ()) -> IO () -> LB ()
forall a b. (a -> b) -> a -> b
$ SSem -> IO ()
SSem.signal SSem
fin)
ModuleT IRCState LB ThreadId -> ModuleT IRCState LB ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ModuleT IRCState LB ThreadId -> ModuleT IRCState LB ())
-> ModuleT IRCState LB ThreadId -> ModuleT IRCState LB ()
forall a b. (a -> b) -> a -> b
$ ModuleT IRCState LB ()
-> (Either SomeException () -> ModuleT IRCState LB ())
-> ModuleT IRCState LB ThreadId
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> (Either SomeException a -> m ()) -> m ThreadId
forkFinally
(ModuleT IRCState LB ()
-> (SomeException -> ModuleT IRCState LB ())
-> ModuleT IRCState LB ()
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
E.catch
(ModuleT IRCState LB ()
pingPongDelay ModuleT IRCState LB ()
-> ModuleT IRCState LB () -> ModuleT IRCState LB ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> String -> IORef Bool -> Handle -> ModuleT IRCState LB ()
pingPongLoop String
tag String
hostn IORef Bool
pongref Handle
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)))
(ModuleT IRCState LB ()
-> Either SomeException () -> ModuleT IRCState LB ()
forall a b. a -> b -> a
const (ModuleT IRCState LB ()
-> Either SomeException () -> ModuleT IRCState LB ())
-> ModuleT IRCState LB ()
-> Either SomeException ()
-> ModuleT IRCState LB ()
forall a b. (a -> b) -> a -> b
$ 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
$ SSem -> IO ()
SSem.signal SSem
fin)
ModuleT IRCState LB ThreadId -> ModuleT IRCState LB ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ModuleT IRCState LB ThreadId -> ModuleT IRCState LB ())
-> ModuleT IRCState LB ThreadId -> ModuleT IRCState LB ()
forall a b. (a -> b) -> a -> b
$ ModuleT IRCState LB () -> ModuleT IRCState LB ThreadId
forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
fork (ModuleT IRCState LB () -> ModuleT IRCState LB ThreadId)
-> ModuleT IRCState LB () -> ModuleT IRCState LB ThreadId
forall a b. (a -> b) -> a -> b
$ 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
$ SSem -> IO ()
SSem.wait SSem
fin
String -> ModuleT IRCState LB ()
forall mod. String -> ModuleT mod LB ()
unregisterServer String
tag
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 -> IO ()
hClose Handle
sock
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
$ SSem -> IO ()
SSem.signal SSem
ready
Int
delay <- Config Int -> ModuleT IRCState LB Int
forall (m :: * -> *) a. MonadConfig m => Config a -> m a
getConfig Config Int
reconnectDelay
let retry :: ModuleT IRCState LB ()
retry = do
Bool
continue <- LB Bool -> ModuleT IRCState LB Bool
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
$ \st :: 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 Bool
continue
then do
ModuleT IRCState LB ()
-> (SomeException -> ModuleT IRCState LB ())
-> ModuleT IRCState LB ()
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
E.catch ModuleT IRCState LB ()
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
Map ChanName String
chans <- LB (Map ChanName String)
-> ModuleT IRCState LB (Map ChanName String)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LB (Map ChanName String)
-> ModuleT IRCState LB (Map ChanName String))
-> LB (Map ChanName String)
-> ModuleT IRCState LB (Map ChanName String)
forall a b. (a -> b) -> a -> b
$ (IRCRWState -> Map ChanName String) -> LB (Map ChanName String)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets IRCRWState -> Map ChanName String
ircChannels
[ChanName]
-> (ChanName -> ModuleT IRCState LB ()) -> ModuleT IRCState LB ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map ChanName String -> [ChanName]
forall k a. Map k a -> [k]
M.keys Map ChanName String
chans) ((ChanName -> ModuleT IRCState LB ()) -> ModuleT IRCState LB ())
-> (ChanName -> ModuleT IRCState LB ()) -> ModuleT IRCState LB ()
forall a b. (a -> b) -> a -> b
$ \chan :: 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 (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
$ \state' :: IRCRWState
state' -> IRCRWState
state' { ircChannels :: Map ChanName String
ircChannels = ChanName -> Map ChanName String -> Map ChanName String
forall k a. Ord k => k -> Map k a -> Map k a
M.delete ChanName
chan (Map ChanName String -> Map ChanName String)
-> Map ChanName String -> Map ChanName String
forall a b. (a -> b) -> a -> b
$ IRCRWState -> Map ChanName String
ircChannels IRCRWState
state' }
ModuleT IRCState LB ()
retry
ThreadId
watch <- IO ThreadId -> ModuleT IRCState LB ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO ThreadId -> ModuleT IRCState LB ThreadId)
-> IO ThreadId -> ModuleT IRCState LB ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
fork (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
Int -> IO ()
forall (m :: * -> *). MonadBase IO m => Int -> m ()
threadDelay 10000000
String -> IO ()
forall (m :: * -> *). MonadLogging m => String -> m ()
errorM "Welcome timeout!"
SSem -> IO ()
SSem.signal SSem
fin
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
$ SSem -> IO ()
SSem.wait SSem
ready
ThreadId -> ModuleT IRCState LB ()
forall (m :: * -> *). MonadBase IO m => ThreadId -> m ()
killThread ThreadId
watch
ModuleT IRCState LB ()
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 120000000
pingPongLoop :: String -> String -> IORef Bool -> Handle -> IRC ()
pingPongLoop :: String -> String -> IORef Bool -> Handle -> ModuleT IRCState LB ()
pingPongLoop tag :: String
tag hostn :: String
hostn pongref :: IORef Bool
pongref sock :: 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
$ "PING " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hostn String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\r\n"
ModuleT IRCState LB ()
pingPongDelay
Bool
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 Bool
pong
then String -> String -> IORef Bool -> Handle -> ModuleT IRCState LB ()
pingPongLoop String
tag String
hostn IORef Bool
pongref Handle
sock
else String -> ModuleT IRCState LB ()
forall (m :: * -> *). MonadLogging m => String -> m ()
errorM "Ping timeout."
readerLoop :: String -> String -> IORef Bool -> Handle -> SSem.SSem -> LB ()
readerLoop :: String -> String -> IORef Bool -> Handle -> SSem -> LB ()
readerLoop tag :: String
tag nickn :: String
nickn pongref :: IORef Bool
pongref sock :: Handle
sock ready :: 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
String
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' :: String
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` "\r\n") String
line
if "PING " String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
line'
then IO () -> LB ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> LB ()) -> IO () -> 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
$ "PONG " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
drop 5 String
line' String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\r\n"
else LB ThreadId -> LB ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LB ThreadId -> LB ()) -> (LB () -> LB ThreadId) -> LB () -> LB ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LB () -> LB ThreadId
forall (m :: * -> *). MonadBaseControl IO m => m () -> m ThreadId
fork (LB () -> LB ThreadId) -> (LB () -> LB ()) -> LB () -> LB ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LB (Maybe ()) -> LB ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (LB (Maybe ()) -> LB ())
-> (LB () -> LB (Maybe ())) -> LB () -> LB ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> LB () -> LB (Maybe ())
forall (m :: * -> *) a.
MonadBaseControl IO m =>
Int -> m a -> m (Maybe a)
timeout 15000000 (LB () -> LB ()) -> LB () -> LB ()
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "PONG"
then IO () -> LB ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> LB ()) -> IO () -> LB ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
pongref Bool
True
else do
Bool -> LB () -> LB ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (IrcMessage -> String
ircMsgCommand IrcMessage
msg String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "001") (LB () -> LB ()) -> LB () -> LB ()
forall a b. (a -> b) -> a -> b
$ IO () -> LB ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (IO () -> LB ()) -> IO () -> LB ()
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 sock :: Handle
sock mv :: MVar ()
mv fin :: SSem
fin msg :: 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 "\r\n")
(\err :: 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)