214 lines
7.5 KiB
Haskell
214 lines
7.5 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
module Network.IRC.Client (run) where
|
|
|
|
import qualified Data.Text.Format as TF
|
|
import qualified Data.Text.Format.Params as TF
|
|
|
|
import ClassyPrelude
|
|
import Control.Exception.Lifted
|
|
import Control.Concurrent.Lifted
|
|
import Control.Monad.Reader hiding (forM_, foldM)
|
|
import Control.Monad.State hiding (forM_, foldM)
|
|
import Network
|
|
import System.IO (hIsEOF, hSetBuffering, BufferMode(..))
|
|
import System.Timeout
|
|
|
|
import Network.IRC.Handlers
|
|
import Network.IRC.Protocol
|
|
import Network.IRC.Types
|
|
|
|
oneSec :: Int
|
|
oneSec = 1000000
|
|
|
|
debug :: Text -> IO ()
|
|
debug msg = do
|
|
time <- getCurrentTime
|
|
TF.print "[{}] {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, msg)
|
|
|
|
type Latch = MVar ()
|
|
|
|
latchIt :: Latch -> IO ()
|
|
latchIt latch = putMVar latch ()
|
|
|
|
awaitLatch :: Latch -> IO ()
|
|
awaitLatch latch = void $ takeMVar latch
|
|
|
|
type EChannel a = (Chan a, Latch)
|
|
|
|
data Cmd = CmdQuit | Cmd !Command deriving (Show, Eq)
|
|
data Line = Timeout | EOF | Line !Message deriving (Show, Eq)
|
|
|
|
sendCommandLoop :: EChannel Cmd -> Bot -> IO ()
|
|
sendCommandLoop (commandChan, latch) bot@Bot { .. } = do
|
|
cmd <- readChan commandChan
|
|
case cmd of
|
|
CmdQuit -> latchIt latch
|
|
Cmd command -> do
|
|
time <- getCurrentTime
|
|
let line = lineFromCommand botConfig command
|
|
TF.hprint socket "{}\r\n" $ TF.Only line
|
|
TF.print "[{}] > {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, line)
|
|
sendCommandLoop (commandChan, latch) bot
|
|
|
|
sendCommand :: Chan Cmd -> Cmd -> IO ()
|
|
sendCommand = writeChan
|
|
|
|
readLineLoop :: MVar BotStatus -> EChannel Line -> Bot -> Int -> IO ()
|
|
readLineLoop mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do
|
|
botStatus <- readMVar mvBotStatus
|
|
case botStatus of
|
|
Disconnected -> latchIt latch
|
|
_ -> do
|
|
mLine <- timeout timeoutDelay readLine'
|
|
case mLine of
|
|
Nothing -> writeChan lineChan Timeout
|
|
Just line -> writeChan lineChan line
|
|
readLineLoop mvBotStatus (lineChan, latch) bot timeoutDelay
|
|
where
|
|
readLine' = do
|
|
eof <- hIsEOF socket
|
|
if eof
|
|
then return EOF
|
|
else do
|
|
line <- map initEx $ hGetLine socket
|
|
debug $ "< " ++ line
|
|
now <- getCurrentTime
|
|
return . Line $ msgFromLine botConfig now line
|
|
|
|
readLine :: Chan Line -> IO Line
|
|
readLine = readChan
|
|
|
|
sendMessage :: Chan Line -> Message -> IO ()
|
|
sendMessage = (. Line) . writeChan
|
|
|
|
listenerLoop :: Chan Line -> Chan Cmd -> Int -> IRC ()
|
|
listenerLoop lineChan commandChan idleFor = do
|
|
status <- get
|
|
bot@Bot { .. } <- ask
|
|
let nick = botNick botConfig
|
|
|
|
nStatus <- liftIO $
|
|
if idleFor >= (oneSec * botTimeout botConfig)
|
|
then return Disconnected
|
|
else do
|
|
when (status == Kicked) $
|
|
threadDelay (5 * oneSec) >> sendCommand commandChan (Cmd JoinCmd)
|
|
|
|
mLine <- readLine lineChan
|
|
case mLine of
|
|
Timeout -> dispatchHandlers bot IdleMsg >> return Idle
|
|
EOF -> return Disconnected
|
|
Line message -> do
|
|
nStatus <- case message of
|
|
JoinMsg { .. } | userNick user == nick -> debug "Joined" >> return Joined
|
|
KickMsg { .. } | kickedNick == nick -> debug "Kicked" >> return Kicked
|
|
ModeMsg { user = Self, .. } ->
|
|
sendCommand commandChan (Cmd JoinCmd) >> return Connected
|
|
_ -> return Connected
|
|
|
|
dispatchHandlers bot message
|
|
return nStatus
|
|
|
|
put nStatus
|
|
case nStatus of
|
|
Idle -> listenerLoop lineChan commandChan (idleFor + oneSec)
|
|
Disconnected -> return ()
|
|
_ -> listenerLoop lineChan commandChan 0
|
|
|
|
where
|
|
dispatchHandlers Bot { .. } message =
|
|
forM_ (mapToList msgHandlers) $ \(_, msgHandler) -> fork $
|
|
handle (\(e :: SomeException) -> debug $ "Exception! " ++ pack (show e)) $ do
|
|
mCmd <- runMsgHandler msgHandler botConfig message
|
|
case mCmd of
|
|
Nothing -> return ()
|
|
Just cmd -> case cmd of
|
|
MessageCmd msg -> sendMessage lineChan msg
|
|
_ -> sendCommand commandChan (Cmd cmd)
|
|
|
|
loadMsgHandlers :: BotConfig -> IO (Map MsgHandlerName MsgHandler)
|
|
loadMsgHandlers botConfig@BotConfig { .. } =
|
|
flip (`foldM` mempty) msgHandlerNames $ \hMap msgHandlerName -> do
|
|
debug $ "Loading msg handler: " ++ msgHandlerName
|
|
mMsgHandler <- mkMsgHandler botConfig msgHandlerName
|
|
case mMsgHandler of
|
|
Nothing -> debug ("No msg handler found with name: " ++ msgHandlerName) >> return hMap
|
|
Just msgHandler -> return $ insertMap msgHandlerName msgHandler hMap
|
|
|
|
unloadMsgHandlers :: Bot -> IO ()
|
|
unloadMsgHandlers Bot { .. } =
|
|
forM_ (mapToList msgHandlers) $ \(msgHandlerName, msgHandler) -> do
|
|
debug $ "Unloading msg handler: " ++ msgHandlerName
|
|
stopMsgHandler msgHandler botConfig
|
|
|
|
connect :: BotConfig -> IO (Bot, MVar BotStatus, EChannel Line, EChannel Cmd)
|
|
connect botConfig@BotConfig { .. } = do
|
|
debug "Connecting ..."
|
|
socket <- connectToWithRetry
|
|
hSetBuffering socket LineBuffering
|
|
msgHandlers <- loadMsgHandlers botConfig
|
|
debug "Connected"
|
|
|
|
lineChan <- newChan
|
|
commandChan <- newChan
|
|
sendLatch <- newEmptyMVar
|
|
readLatch <- newEmptyMVar
|
|
mvBotStatus <- newMVar Connected
|
|
|
|
return (Bot botConfig socket msgHandlers, mvBotStatus, (lineChan, readLatch), (commandChan, sendLatch))
|
|
where
|
|
connectToWithRetry = connectTo (unpack server) (PortNumber (fromIntegral port))
|
|
`catch` (\(e :: SomeException) -> do
|
|
debug ("Error while connecting: " ++ pack (show e) ++ ". Waiting.")
|
|
threadDelay (5 * oneSec)
|
|
connectToWithRetry)
|
|
|
|
disconnect :: (Bot, MVar BotStatus, EChannel Line, EChannel Cmd) -> IO ()
|
|
disconnect (bot@Bot { .. }, mvBotStatus, (_, readLatch), (commandChan, sendLatch)) = do
|
|
debug "Disconnecting ..."
|
|
sendCommand commandChan CmdQuit
|
|
awaitLatch sendLatch
|
|
swapMVar mvBotStatus Disconnected
|
|
awaitLatch readLatch
|
|
|
|
unloadMsgHandlers bot
|
|
hClose socket
|
|
debug "Disconnected"
|
|
|
|
addCoreMsgHandlers :: BotConfig -> BotConfig
|
|
addCoreMsgHandlers botConfig =
|
|
botConfig { msgHandlerNames = hashNub $ msgHandlerNames botConfig ++ coreMsgHandlerNames }
|
|
|
|
run :: BotConfig -> IO ()
|
|
run botConfig' = withSocketsDo $ do
|
|
hSetBuffering stdout LineBuffering
|
|
debug "Running with config:"
|
|
print botConfig
|
|
status <- run_
|
|
case status of
|
|
Disconnected -> debug "Connection timed out" >> run botConfig
|
|
Interrupted -> return ()
|
|
Errored -> debug "Errored, restarting" >> run botConfig
|
|
_ -> error "Unsupported status"
|
|
where
|
|
botConfig = addCoreMsgHandlers botConfig'
|
|
|
|
handleErrors :: SomeException -> IO BotStatus
|
|
handleErrors e = case fromException e of
|
|
Just UserInterrupt -> debug "User interrupt" >> return Interrupted
|
|
_ -> debug ("Exception! " ++ pack (show e)) >> return Errored
|
|
|
|
run_ = bracket (connect botConfig) disconnect $
|
|
\(bot, mvBotStatus, (lineChan, readLatch), (commandChan, sendLatch)) ->
|
|
handle handleErrors $ do
|
|
sendCommand commandChan (Cmd NickCmd)
|
|
sendCommand commandChan (Cmd UserCmd)
|
|
|
|
fork $ sendCommandLoop (commandChan, sendLatch) bot
|
|
fork $ readLineLoop mvBotStatus (lineChan, readLatch) bot oneSec
|
|
runIRC bot Connected (listenerLoop lineChan commandChan 0)
|