Some refactoring and reformatting
parent
8659c5f755
commit
a3e4b145ec
20
Main.hs
20
Main.hs
|
@ -14,7 +14,7 @@ import System.Environment
|
||||||
import System.Exit
|
import System.Exit
|
||||||
import System.Posix.Signals
|
import System.Posix.Signals
|
||||||
|
|
||||||
import Network.IRC.Types (BotConfig(BotConfig))
|
import Network.IRC.Types
|
||||||
import Network.IRC.Client
|
import Network.IRC.Client
|
||||||
|
|
||||||
instance Configured a => Configured [a] where
|
instance Configured a => Configured [a] where
|
||||||
|
@ -43,15 +43,15 @@ loadBotConfig configFile = do
|
||||||
case eCfg of
|
case eCfg of
|
||||||
Left (ParseError _ _) -> error "Error while loading config"
|
Left (ParseError _ _) -> error "Error while loading config"
|
||||||
Right cfg -> do
|
Right cfg -> do
|
||||||
eBotConfig <- try $ do
|
eBotConfig <- try $ BotConfig <$>
|
||||||
server <- CF.require cfg "server"
|
CF.require cfg "server" <*>
|
||||||
port <- CF.require cfg "port"
|
CF.require cfg "port" <*>
|
||||||
channel <- CF.require cfg "channel"
|
CF.require cfg "channel" <*>
|
||||||
botNick <- CF.require cfg "nick"
|
CF.require cfg "nick" <*>
|
||||||
timeout <- CF.require cfg "timeout"
|
CF.require cfg "timeout" <*>
|
||||||
msghandlers <- CF.require cfg "msghandlers"
|
CF.require cfg "msghandlers" <*>
|
||||||
return $ BotConfig server port channel botNick timeout msghandlers cfg
|
pure cfg
|
||||||
|
|
||||||
case eBotConfig of
|
case eBotConfig of
|
||||||
Left (KeyError k) -> error $ "Error while reading key from config: " ++ unpack k
|
Left (KeyError k) -> error $ "Error while reading key from config: " ++ unpack k
|
||||||
Right botConfig -> return botConfig
|
Right botConf -> return botConf
|
||||||
|
|
|
@ -46,7 +46,10 @@ sendCommandLoop :: EChannel 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
|
||||||
let line = lineFromCommand botConfig cmd
|
let mline = lineFromCommand botConfig cmd
|
||||||
|
case mline of
|
||||||
|
Nothing -> return ()
|
||||||
|
Just line -> do
|
||||||
TF.hprint socket "{}\r\n" $ TF.Only line
|
TF.hprint socket "{}\r\n" $ TF.Only line
|
||||||
TF.print "[{}] > {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, line)
|
TF.print "[{}] > {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, line)
|
||||||
case cmd of
|
case cmd of
|
||||||
|
@ -128,9 +131,8 @@ listenerLoop lineChan commandChan !idleFor = do
|
||||||
mCmd <- runMsgHandler msgHandler botConfig message
|
mCmd <- runMsgHandler msgHandler botConfig message
|
||||||
case mCmd of
|
case mCmd of
|
||||||
Nothing -> return ()
|
Nothing -> return ()
|
||||||
Just cmd -> case cmd of
|
Just (MessageCmd msg) -> sendMessage lineChan msg
|
||||||
MessageCmd msg -> sendMessage lineChan msg
|
Just cmd -> sendCommand commandChan cmd
|
||||||
_ -> sendCommand commandChan cmd
|
|
||||||
|
|
||||||
loadMsgHandlers :: BotConfig -> IO (Map MsgHandlerName MsgHandler)
|
loadMsgHandlers :: BotConfig -> IO (Map MsgHandlerName MsgHandler)
|
||||||
loadMsgHandlers botConfig@BotConfig { .. } =
|
loadMsgHandlers botConfig@BotConfig { .. } =
|
||||||
|
|
|
@ -54,12 +54,11 @@ exitMessageLogger state = liftIO $ do
|
||||||
mHandle <- readIORef state
|
mHandle <- readIORef state
|
||||||
case mHandle of
|
case mHandle of
|
||||||
Nothing -> return ()
|
Nothing -> return ()
|
||||||
Just (logFileHandle, _ :: Day) -> hClose logFileHandle
|
Just (logFileHandle, _) -> hClose logFileHandle
|
||||||
|
|
||||||
withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m (Maybe Command)
|
withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m (Maybe Command)
|
||||||
withLogFile action state = do
|
withLogFile action state = do
|
||||||
botConfig <- ask
|
botConfig <- ask
|
||||||
|
|
||||||
liftIO $ do
|
liftIO $ do
|
||||||
Just (logFileHandle, prevDay) <- readIORef state
|
Just (logFileHandle, prevDay) <- readIORef state
|
||||||
curDay <- map utctDay getCurrentTime
|
curDay <- map utctDay getCurrentTime
|
||||||
|
@ -80,18 +79,17 @@ withLogFile action state = do
|
||||||
return Nothing
|
return Nothing
|
||||||
|
|
||||||
messageLogger :: MonadMsgHandler m => Message -> IORef LoggerState -> m (Maybe Command)
|
messageLogger :: MonadMsgHandler m => Message -> IORef LoggerState -> m (Maybe Command)
|
||||||
messageLogger message = go message
|
messageLogger message = case message of
|
||||||
|
ChannelMsg { .. } -> log "<{}> {}" [userNick user, msg]
|
||||||
|
ActionMsg { .. } -> log "<{}> {} {}" [userNick user, userNick user, msg]
|
||||||
|
KickMsg { .. } -> log "** {} KICKED {} :{}" [userNick user, kickedNick, msg]
|
||||||
|
JoinMsg { .. } -> log "** {} JOINED" [userNick user]
|
||||||
|
PartMsg { .. } -> log "** {} PARTED :{}" [userNick user, msg]
|
||||||
|
QuitMsg { .. } -> log "** {} QUIT :{}" [userNick user, msg]
|
||||||
|
NickMsg { .. } -> log "** {} CHANGED NICK TO {}" [userNick user, nick]
|
||||||
|
NamesMsg { .. } -> log "** USERS {}" [unwords nicks]
|
||||||
|
_ -> const $ return Nothing
|
||||||
where
|
where
|
||||||
go ChannelMsg { .. } = log "<{}> {}" [userNick user, msg]
|
|
||||||
go ActionMsg { .. } = log "<{}> {} {}" [userNick user, userNick user, msg]
|
|
||||||
go KickMsg { .. } = log "** {} KICKED {} :{}" [userNick user, kickedNick, msg]
|
|
||||||
go JoinMsg { .. } = log "** {} JOINED" [userNick user]
|
|
||||||
go PartMsg { .. } = log "** {} PARTED :{}" [userNick user, msg]
|
|
||||||
go QuitMsg { .. } = log "** {} QUIT :{}" [userNick user, msg]
|
|
||||||
go NickMsg { .. } = log "** {} CHANGED NICK TO {}" [userNick user, nick]
|
|
||||||
go NamesMsg { .. } = log "** USERS {}" [unwords nicks]
|
|
||||||
go _ = const $ return Nothing
|
|
||||||
|
|
||||||
log format args = withLogFile $ \logFile ->
|
log format args = withLogFile $ \logFile ->
|
||||||
TF.hprint logFile ("[{}] " ++ format ++ "\n") $ TF.buildParams (fmtTime (msgTime message) : args)
|
TF.hprint logFile ("[{}] " ++ format ++ "\n") $ TF.buildParams (fmtTime (msgTime message) : args)
|
||||||
|
|
||||||
|
|
|
@ -32,8 +32,8 @@ instance FromJSON Song where
|
||||||
parseJSON _ = mempty
|
parseJSON _ = mempty
|
||||||
|
|
||||||
songSearch :: MonadMsgHandler m => Message -> m (Maybe Command)
|
songSearch :: MonadMsgHandler m => Message -> m (Maybe Command)
|
||||||
songSearch ChannelMsg { .. } = if "!m " `isPrefixOf` msg
|
songSearch ChannelMsg { .. }
|
||||||
then do
|
| "!m " `isPrefixOf` msg = do
|
||||||
BotConfig { .. } <- ask
|
BotConfig { .. } <- ask
|
||||||
liftIO $ do
|
liftIO $ do
|
||||||
let query = strip . drop 3 $ msg
|
let query = strip . drop 3 $ msg
|
||||||
|
@ -51,5 +51,5 @@ songSearch ChannelMsg { .. } = if "!m " `isPrefixOf` msg
|
||||||
Right song -> case song of
|
Right song -> case song of
|
||||||
Song { .. } -> "Listen to " ++ artist ++ " - " ++ name ++ " at " ++ url
|
Song { .. } -> "Listen to " ++ artist ++ " - " ++ name ++ " at " ++ url
|
||||||
NoSong -> "No song found for: " ++ query
|
NoSong -> "No song found for: " ++ query
|
||||||
else return Nothing
|
| otherwise = return Nothing
|
||||||
songSearch _ = return Nothing
|
songSearch _ = return Nothing
|
||||||
|
|
|
@ -23,13 +23,11 @@ msgFromLine (BotConfig { .. }) time line
|
||||||
then ModeMsg time Self target message [] line
|
then ModeMsg time Self target message [] line
|
||||||
else ModeMsg time user target mode modeArgs line
|
else ModeMsg time user target mode modeArgs line
|
||||||
"NICK" -> NickMsg time user (drop 1 target) line
|
"NICK" -> NickMsg time user (drop 1 target) line
|
||||||
"PRIVMSG" -> if target == channel
|
|
||||||
then if "\x01" `isPrefixOf` message && "ACTION" `isPrefixOf` drop 1 message
|
|
||||||
then ActionMsg time user (initDef . drop 8 $ message) line
|
|
||||||
else ChannelMsg time user message line
|
|
||||||
else PrivMsg time user message line
|
|
||||||
"353" -> NamesMsg time namesNicks
|
"353" -> NamesMsg time namesNicks
|
||||||
"433" -> NickInUseMsg time line
|
"433" -> NickInUseMsg time line
|
||||||
|
"PRIVMSG" | target /= channel -> PrivMsg time user message line
|
||||||
|
| isActionMsg -> ActionMsg time user (initDef . drop 8 $ message) line
|
||||||
|
| otherwise -> ChannelMsg time user message line
|
||||||
_ -> OtherMsg time source command target message line
|
_ -> OtherMsg time source command target message line
|
||||||
where
|
where
|
||||||
isSpc = (== ' ')
|
isSpc = (== ' ')
|
||||||
|
@ -51,15 +49,17 @@ msgFromLine (BotConfig { .. }) time line
|
||||||
namesNicks = map stripNickPrefix . words . drop 1 . unwords . drop 5 $ splits
|
namesNicks = map stripNickPrefix . words . drop 1 . unwords . drop 5 $ splits
|
||||||
stripNickPrefix = pack . dropWhile (`elem` nickPrefixes) . unpack
|
stripNickPrefix = pack . dropWhile (`elem` nickPrefixes) . unpack
|
||||||
|
|
||||||
lineFromCommand :: BotConfig -> Command -> Text
|
isActionMsg = "\SOH" `isPrefixOf` message && "ACTION" `isPrefixOf` drop 1 message
|
||||||
lineFromCommand (BotConfig { .. }) command = case command of
|
|
||||||
PongCmd { .. } -> "PONG :" ++ rmsg
|
lineFromCommand :: BotConfig -> Command -> Maybe Text
|
||||||
PingCmd { .. } -> "PING :" ++ rmsg
|
lineFromCommand BotConfig { .. } command = case command of
|
||||||
NickCmd -> "NICK " ++ botNick
|
PongCmd { .. } -> Just $ "PONG :" ++ rmsg
|
||||||
UserCmd -> "USER " ++ botNick ++ " 0 * :" ++ botNick
|
PingCmd { .. } -> Just $ "PING :" ++ rmsg
|
||||||
JoinCmd -> "JOIN " ++ channel
|
NickCmd -> Just $ "NICK " ++ botNick
|
||||||
QuitCmd -> "QUIT"
|
UserCmd -> Just $ "USER " ++ botNick ++ " 0 * :" ++ botNick
|
||||||
ChannelMsgReply { .. } -> "PRIVMSG " ++ channel ++ " :" ++ rmsg
|
JoinCmd -> Just $ "JOIN " ++ channel
|
||||||
PrivMsgReply (User { .. }) rmsg -> "PRIVMSG " ++ botNick ++ " :" ++ rmsg
|
QuitCmd -> Just "QUIT"
|
||||||
NamesCmd -> "NAMES " ++ channel
|
ChannelMsgReply { .. } -> Just $ "PRIVMSG " ++ channel ++ " :" ++ rmsg
|
||||||
_ -> error $ "Unsupported command " ++ show command
|
PrivMsgReply (User { .. }) rmsg -> Just $ "PRIVMSG " ++ botNick ++ " :" ++ rmsg
|
||||||
|
NamesCmd -> Just $ "NAMES " ++ channel
|
||||||
|
_ -> Nothing
|
||||||
|
|
|
@ -8,9 +8,22 @@
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
|
|
||||||
module Network.IRC.Types
|
module Network.IRC.Types
|
||||||
(Channel, Nick, MsgHandlerName, User (..), Message (..), Command (..),
|
( Channel
|
||||||
BotConfig (..), BotStatus (..), Bot (..), IRC, runIRC,
|
, Nick
|
||||||
MsgHandler (..), MonadMsgHandler, newMsgHandler, runMsgHandler, stopMsgHandler)
|
, MsgHandlerName
|
||||||
|
, User (..)
|
||||||
|
, Message (..)
|
||||||
|
, Command (..)
|
||||||
|
, BotConfig (..)
|
||||||
|
, BotStatus (..)
|
||||||
|
, Bot (..)
|
||||||
|
, IRC
|
||||||
|
, runIRC
|
||||||
|
, MsgHandler (..)
|
||||||
|
, MonadMsgHandler
|
||||||
|
, newMsgHandler
|
||||||
|
, runMsgHandler
|
||||||
|
, stopMsgHandler)
|
||||||
where
|
where
|
||||||
|
|
||||||
import ClassyPrelude
|
import ClassyPrelude
|
||||||
|
@ -107,7 +120,7 @@ newtype MsgHandlerT a = MsgHandlerT { _runMsgHandler :: ReaderT BotConfig IO a }
|
||||||
, MonadIO
|
, MonadIO
|
||||||
, MonadReader BotConfig )
|
, MonadReader BotConfig )
|
||||||
|
|
||||||
class ( MonadIO m, Applicative m, MonadReader BotConfig m ) => MonadMsgHandler m where
|
class (MonadIO m, Applicative m, MonadReader BotConfig m) => MonadMsgHandler m where
|
||||||
msgHandler :: MsgHandlerT a -> m a
|
msgHandler :: MsgHandlerT a -> m a
|
||||||
|
|
||||||
instance MonadMsgHandler MsgHandlerT where
|
instance MonadMsgHandler MsgHandlerT where
|
||||||
|
|
|
@ -49,6 +49,8 @@ build-type: Simple
|
||||||
cabal-version: >=1.10
|
cabal-version: >=1.10
|
||||||
|
|
||||||
library
|
library
|
||||||
|
other-extensions: Safe
|
||||||
|
|
||||||
build-depends: base >=4.5 && <4.8,
|
build-depends: base >=4.5 && <4.8,
|
||||||
text >=0.11 && <0.12,
|
text >=0.11 && <0.12,
|
||||||
mtl >=2.1 && <2.2,
|
mtl >=2.1 && <2.2,
|
||||||
|
@ -83,7 +85,7 @@ executable hask-irc
|
||||||
-- other-modules:
|
-- other-modules:
|
||||||
|
|
||||||
-- LANGUAGE extensions used by modules in this package.
|
-- LANGUAGE extensions used by modules in this package.
|
||||||
other-extensions: RecordWildCards, OverloadedStrings, ScopedTypeVariables, OverlappingInstances
|
other-extensions: Safe
|
||||||
|
|
||||||
-- Other library packages from which modules are imported.
|
-- Other library packages from which modules are imported.
|
||||||
build-depends: base >=4.5 && <4.8,
|
build-depends: base >=4.5 && <4.8,
|
||||||
|
|
Loading…
Reference in New Issue