-- | 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 :: 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 String
"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 String
"irc-connect tag host portnum nickname userinfo.  connect to an irc server"
            , process :: String -> Cmd (ModuleT IRCState LB) ()
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
                        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
" " [String]
uix))
                    [String]
_ -> String -> Cmd (ModuleT IRCState LB) ()
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 = String -> Cmd (ModuleT IRCState LB) ()
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 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
                        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
" " [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
$ \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]
_ -> String -> Cmd (ModuleT IRCState LB) ()
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 = String -> Cmd (ModuleT IRCState LB) ()
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 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))
IRCState
ms{ password :: Maybe String
password = String -> Maybe String
forall a. a -> Maybe a
Just String
pwd })
                    [String]
_ -> String -> Cmd (ModuleT IRCState LB) ()
forall (m :: * -> *). Monad m => String -> Cmd m ()
say String
"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 }
    }

----------------------------------------------------------------------
-- 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 p. (String -> String -> p) -> String -> p
decodePrefix (,) String
line
        (String
cmd, 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 IrcMessage :: 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 String -> String -> p
k (Char
':':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' String -> String -> p
j String
""       = String -> String -> p
j String
"" String
""
            decodePrefix' String -> String -> p
j (Char
' ':String
ds) = String -> String -> p
j String
"" String
ds
            decodePrefix' String -> String -> p
j (Char
c: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 String -> String -> p
k String
cs = String -> String -> p
k String
"" String
cs

    decodeCmd :: (String -> String -> p) -> String -> p
decodeCmd String -> String -> p
k []       = String -> String -> p
k String
"" String
""
    decodeCmd String -> String -> p
k (Char
' ':String
cs) = String -> String -> p
k String
"" String
cs
    decodeCmd String -> String -> p
k (Char
c: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 String
xs = String -> [String] -> String -> [String]
decodeParams' [] [] String
xs
      where
        decodeParams' :: String -> [String] -> String -> [String]
decodeParams' String
param [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' String
param [String]
params (Char
' ' : 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' String
param [String]
params rest :: String
rest@(c :: Char
c@Char
':' : 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' 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 (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
    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
$ \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
        -- Implements flood control: RFC 2813, section 5.8
        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 Int
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 Int
4 -- one extra token stays in the MVar
        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 Int
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 Int
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 Int
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
$ \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
$ \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
$ \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 Int
10000000
            String -> IO ()
forall (m :: * -> *). MonadLogging m => String -> m ()
errorM String
"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 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
    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 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 = 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` String
"\r\n") String
line
    if String
"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
$ String
"PONG " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
5 String
line' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\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 Int
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
== String
"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
== String
"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 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)