Minor refactoring
parent
2f6f968bc4
commit
ced2f4b578
|
@ -38,11 +38,23 @@ latchIt latch = putMVar latch ()
|
||||||
awaitLatch :: Latch -> IO ()
|
awaitLatch :: Latch -> IO ()
|
||||||
awaitLatch latch = void $ takeMVar latch
|
awaitLatch latch = void $ takeMVar latch
|
||||||
|
|
||||||
type EChannel a = (Chan a, Latch)
|
type Channel a = (Chan a, Latch)
|
||||||
|
|
||||||
data Line = Timeout | EOF | Line !Message deriving (Show, Eq)
|
data Line = Timeout | EOF | Line !Message deriving (Show, Eq)
|
||||||
|
|
||||||
sendCommandLoop :: EChannel Command -> Bot -> IO ()
|
sendCommand :: Chan Command -> Command -> IO ()
|
||||||
|
sendCommand = writeChan
|
||||||
|
|
||||||
|
sendMessage :: Chan Line -> Message -> IO ()
|
||||||
|
sendMessage = (. Line) . writeChan
|
||||||
|
|
||||||
|
sendEvent :: Chan SomeEvent -> SomeEvent -> IO ()
|
||||||
|
sendEvent = writeChan
|
||||||
|
|
||||||
|
readLine :: Chan Line -> IO Line
|
||||||
|
readLine = readChan
|
||||||
|
|
||||||
|
sendCommandLoop :: Channel Command -> Bot -> IO ()
|
||||||
sendCommandLoop (commandChan, latch) bot@Bot { .. } = do
|
sendCommandLoop (commandChan, latch) bot@Bot { .. } = do
|
||||||
cmd <- readChan commandChan
|
cmd <- readChan commandChan
|
||||||
time <- getCurrentTime
|
time <- getCurrentTime
|
||||||
|
@ -56,10 +68,7 @@ sendCommandLoop (commandChan, latch) bot@Bot { .. } = do
|
||||||
QuitCmd -> latchIt latch
|
QuitCmd -> latchIt latch
|
||||||
_ -> sendCommandLoop (commandChan, latch) bot
|
_ -> sendCommandLoop (commandChan, latch) bot
|
||||||
|
|
||||||
sendCommand :: Chan Command -> Command -> IO ()
|
readLineLoop :: MVar BotStatus -> Channel Line -> Bot -> Int -> IO ()
|
||||||
sendCommand = writeChan
|
|
||||||
|
|
||||||
readLineLoop :: MVar BotStatus -> EChannel Line -> Bot -> Int -> IO ()
|
|
||||||
readLineLoop mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do
|
readLineLoop mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do
|
||||||
botStatus <- readMVar mvBotStatus
|
botStatus <- readMVar mvBotStatus
|
||||||
case botStatus of
|
case botStatus of
|
||||||
|
@ -81,12 +90,6 @@ readLineLoop mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do
|
||||||
now <- getCurrentTime
|
now <- getCurrentTime
|
||||||
return . Line $ msgFromLine botConfig now line
|
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 Command -> Int -> IRC ()
|
listenerLoop :: Chan Line -> Chan Command -> Int -> IRC ()
|
||||||
listenerLoop lineChan commandChan !idleFor = do
|
listenerLoop lineChan commandChan !idleFor = do
|
||||||
status <- get
|
status <- get
|
||||||
|
@ -134,16 +137,13 @@ listenerLoop lineChan commandChan !idleFor = do
|
||||||
Nothing -> return ()
|
Nothing -> return ()
|
||||||
Just cmd -> sendCommand commandChan cmd
|
Just cmd -> sendCommand commandChan cmd
|
||||||
|
|
||||||
sendEvent :: Chan SomeEvent -> SomeEvent -> IO ()
|
eventProcessLoop :: Channel SomeEvent -> Chan Line -> Chan Command -> Bot -> IO ()
|
||||||
sendEvent = writeChan
|
|
||||||
|
|
||||||
eventProcessLoop :: EChannel SomeEvent -> Chan Line -> Chan Command -> Bot -> IO ()
|
|
||||||
eventProcessLoop (eventChan, latch) lineChan commandChan bot@Bot {.. } = do
|
eventProcessLoop (eventChan, latch) lineChan commandChan bot@Bot {.. } = do
|
||||||
event <- readChan eventChan
|
event <- readChan eventChan
|
||||||
case fromEvent event of
|
case fromEvent event of
|
||||||
Just (QuitEvent, _) -> latchIt latch
|
Just (QuitEvent, _) -> latchIt latch
|
||||||
_ -> do
|
_ -> do
|
||||||
debug $ "** Event: " ++ pack (show event)
|
debug $ "Event: " ++ pack (show event)
|
||||||
forM_ (mapToList msgHandlers) $ \(_, msgHandler) -> fork $
|
forM_ (mapToList msgHandlers) $ \(_, msgHandler) -> fork $
|
||||||
handle (\(ex :: SomeException) ->
|
handle (\(ex :: SomeException) ->
|
||||||
debug $ "Exception while processing event: " ++ pack (show ex)) $ do
|
debug $ "Exception while processing event: " ++ pack (show ex)) $ do
|
||||||
|
@ -155,22 +155,7 @@ eventProcessLoop (eventChan, latch) lineChan commandChan bot@Bot {.. } = do
|
||||||
_ -> return ()
|
_ -> return ()
|
||||||
eventProcessLoop (eventChan, latch) lineChan commandChan bot
|
eventProcessLoop (eventChan, latch) lineChan commandChan bot
|
||||||
|
|
||||||
loadMsgHandlers :: BotConfig -> Chan SomeEvent -> IO (Map MsgHandlerName MsgHandler)
|
connect :: BotConfig -> IO (Bot, MVar BotStatus, Channel Line, Channel Command, Channel SomeEvent)
|
||||||
loadMsgHandlers botConfig@BotConfig { .. } eventChan =
|
|
||||||
flip (`foldM` mempty) msgHandlerNames $ \hMap msgHandlerName -> do
|
|
||||||
debug $ "Loading msg handler: " ++ msgHandlerName
|
|
||||||
mMsgHandler <- mkMsgHandler botConfig eventChan 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 Command, EChannel SomeEvent)
|
|
||||||
connect botConfig@BotConfig { .. } = do
|
connect botConfig@BotConfig { .. } = do
|
||||||
debug "Connecting ..."
|
debug "Connecting ..."
|
||||||
socket <- connectToWithRetry
|
socket <- connectToWithRetry
|
||||||
|
@ -181,8 +166,7 @@ connect botConfig@BotConfig { .. } = do
|
||||||
commandChan <- newChannel
|
commandChan <- newChannel
|
||||||
eventChan <- newChannel
|
eventChan <- newChannel
|
||||||
mvBotStatus <- newMVar Connected
|
mvBotStatus <- newMVar Connected
|
||||||
|
msgHandlers <- loadMsgHandlers (fst eventChan)
|
||||||
msgHandlers <- loadMsgHandlers botConfig (fst eventChan)
|
|
||||||
|
|
||||||
return (Bot botConfig socket msgHandlers, mvBotStatus, lineChan, commandChan, eventChan)
|
return (Bot botConfig socket msgHandlers, mvBotStatus, lineChan, commandChan, eventChan)
|
||||||
where
|
where
|
||||||
|
@ -194,8 +178,15 @@ connect botConfig@BotConfig { .. } = do
|
||||||
|
|
||||||
newChannel = (,) <$> newChan <*> newEmptyMVar
|
newChannel = (,) <$> newChan <*> newEmptyMVar
|
||||||
|
|
||||||
disconnect :: (Bot, MVar BotStatus, EChannel Line, EChannel Command, EChannel SomeEvent) -> IO ()
|
loadMsgHandlers eventChan = flip (`foldM` mempty) msgHandlerNames $ \hMap msgHandlerName -> do
|
||||||
disconnect (bot@Bot { .. }, mvBotStatus, (_, readLatch), (commandChan, sendLatch), (eventChan, eventLatch)) = do
|
debug $ "Loading msg handler: " ++ msgHandlerName
|
||||||
|
mMsgHandler <- mkMsgHandler botConfig eventChan msgHandlerName
|
||||||
|
case mMsgHandler of
|
||||||
|
Nothing -> debug ("No msg handler found with name: " ++ msgHandlerName) >> return hMap
|
||||||
|
Just msgHandler -> return $ insertMap msgHandlerName msgHandler hMap
|
||||||
|
|
||||||
|
disconnect :: (Bot, MVar BotStatus, Channel Line, Channel Command, Channel SomeEvent) -> IO ()
|
||||||
|
disconnect (Bot { .. }, mvBotStatus, (_, readLatch), (commandChan, sendLatch), (eventChan, eventLatch)) = do
|
||||||
debug "Disconnecting ..."
|
debug "Disconnecting ..."
|
||||||
sendCommand commandChan QuitCmd
|
sendCommand commandChan QuitCmd
|
||||||
awaitLatch sendLatch
|
awaitLatch sendLatch
|
||||||
|
@ -204,13 +195,13 @@ disconnect (bot@Bot { .. }, mvBotStatus, (_, readLatch), (commandChan, sendLatch
|
||||||
sendEvent eventChan =<< toEvent QuitEvent
|
sendEvent eventChan =<< toEvent QuitEvent
|
||||||
awaitLatch eventLatch
|
awaitLatch eventLatch
|
||||||
|
|
||||||
unloadMsgHandlers bot
|
unloadMsgHandlers
|
||||||
hClose socket
|
hClose socket
|
||||||
debug "Disconnected"
|
debug "Disconnected"
|
||||||
|
where
|
||||||
addCoreMsgHandlers :: BotConfig -> BotConfig
|
unloadMsgHandlers = forM_ (mapToList msgHandlers) $ \(msgHandlerName, msgHandler) -> do
|
||||||
addCoreMsgHandlers botConfig =
|
debug $ "Unloading msg handler: " ++ msgHandlerName
|
||||||
botConfig { msgHandlerNames = hashNub $ msgHandlerNames botConfig ++ coreMsgHandlerNames }
|
stopMsgHandler msgHandler botConfig
|
||||||
|
|
||||||
run :: BotConfig -> IO ()
|
run :: BotConfig -> IO ()
|
||||||
run botConfig' = withSocketsDo $ do
|
run botConfig' = withSocketsDo $ do
|
||||||
|
@ -225,7 +216,7 @@ run botConfig' = withSocketsDo $ do
|
||||||
NickNotAvailable -> return ()
|
NickNotAvailable -> return ()
|
||||||
_ -> error "Unsupported status"
|
_ -> error "Unsupported status"
|
||||||
where
|
where
|
||||||
botConfig = addCoreMsgHandlers botConfig'
|
botConfig = botConfig' { msgHandlerNames = hashNub $ msgHandlerNames botConfig' ++ coreMsgHandlerNames }
|
||||||
|
|
||||||
handleErrors :: SomeException -> IO BotStatus
|
handleErrors :: SomeException -> IO BotStatus
|
||||||
handleErrors e = case fromException e of
|
handleErrors e = case fromException e of
|
||||||
|
|
|
@ -9,8 +9,7 @@
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
|
||||||
module Network.IRC.Types
|
module Network.IRC.Types
|
||||||
( Channel
|
( Nick
|
||||||
, Nick
|
|
||||||
, MsgHandlerName
|
, MsgHandlerName
|
||||||
, User (..)
|
, User (..)
|
||||||
, Message (..)
|
, Message (..)
|
||||||
|
@ -38,7 +37,6 @@ import Control.Monad.State
|
||||||
import Data.Configurator.Types
|
import Data.Configurator.Types
|
||||||
import Data.Typeable (cast)
|
import Data.Typeable (cast)
|
||||||
|
|
||||||
type Channel = Text
|
|
||||||
type Nick = Text
|
type Nick = Text
|
||||||
type MsgHandlerName = Text
|
type MsgHandlerName = Text
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue