abhin4v
/
hask-irc
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Some refactoring and reformatting

master
Abhinav Sarkar 2014-05-20 02:40:08 +05:30
parent 8659c5f755
commit a3e4b145ec
7 changed files with 106 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
Main.hs
View File

@ -14,7 +14,7 @@ import System.Environment
import System.Exit
import System.Posix.Signals
import Network.IRC.Types (BotConfig(BotConfig))
import Network.IRC.Types
import Network.IRC.Client
instance Configured a => Configured [a] where
@ -43,15 +43,15 @@ loadBotConfig configFile = do
case eCfg of
Left (ParseError _ _) -> error "Error while loading config"
Right cfg -> do
eBotConfig <- try $ do
server <- CF.require cfg "server"
port <- CF.require cfg "port"
channel <- CF.require cfg "channel"
botNick <- CF.require cfg "nick"
timeout <- CF.require cfg "timeout"
msghandlers <- CF.require cfg "msghandlers"
return $ BotConfig server port channel botNick timeout msghandlers cfg
eBotConfig <- try $ BotConfig <$>
CF.require cfg "server" <*>
CF.require cfg "port" <*>
CF.require cfg "channel" <*>
CF.require cfg "nick" <*>
CF.require cfg "timeout" <*>
CF.require cfg "msghandlers" <*>
pure cfg
case eBotConfig of
Left (KeyError k) -> error $ "Error while reading key from config: " ++ unpack k
Right botConfig -> return botConfig
Right botConf -> return botConf

10
Network/IRC/Client.hs
View File

@ -46,7 +46,10 @@ sendCommandLoop :: EChannel Command -> Bot -> IO ()
sendCommandLoop (commandChan, latch) bot@Bot { .. } = do
cmd <- readChan commandChan
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.print "[{}] > {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, line)
case cmd of
@ -128,9 +131,8 @@ listenerLoop lineChan commandChan !idleFor = do
mCmd <- runMsgHandler msgHandler botConfig message
case mCmd of
Nothing -> return ()
Just cmd -> case cmd of
MessageCmd msg -> sendMessage lineChan msg
_ -> sendCommand commandChan cmd
Just (MessageCmd msg) -> sendMessage lineChan msg
Just cmd -> sendCommand commandChan cmd
loadMsgHandlers :: BotConfig -> IO (Map MsgHandlerName MsgHandler)
loadMsgHandlers botConfig@BotConfig { .. } =

24
Network/IRC/Handlers/MessageLogger.hs
View File

@ -54,12 +54,11 @@ exitMessageLogger state = liftIO $ do
mHandle <- readIORef state
case mHandle of
Nothing -> return ()
Just (logFileHandle, _ :: Day) -> hClose logFileHandle
Just (logFileHandle, _) -> hClose logFileHandle
withLogFile :: MonadMsgHandler m => (Handle -> IO ()) -> IORef LoggerState -> m (Maybe Command)
withLogFile action state = do
botConfig <- ask
liftIO $ do
Just (logFileHandle, prevDay) <- readIORef state
curDay <- map utctDay getCurrentTime
@ -80,18 +79,17 @@ withLogFile action state = do
return Nothing
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
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 ->
TF.hprint logFile ("[{}] " ++ format ++ "\n") $ TF.buildParams (fmtTime (msgTime message) : args)

6
Network/IRC/Handlers/SongSearch.hs
View File

@ -32,8 +32,8 @@ instance FromJSON Song where
parseJSON _ = mempty
songSearch :: MonadMsgHandler m => Message -> m (Maybe Command)
songSearch ChannelMsg { .. } = if "!m " `isPrefixOf` msg
then do
songSearch ChannelMsg { .. }
| "!m " `isPrefixOf` msg = do
BotConfig { .. } <- ask
liftIO $ do
let query = strip . drop 3 $ msg
@ -51,5 +51,5 @@ songSearch ChannelMsg { .. } = if "!m " `isPrefixOf` msg
Right song -> case song of
Song { .. } -> "Listen to " ++ artist ++ " - " ++ name ++ " at " ++ url
NoSong -> "No song found for: " ++ query
else return Nothing
| otherwise = return Nothing
songSearch _ = return Nothing

34
Network/IRC/Protocol.hs
View File

@ -23,13 +23,11 @@ msgFromLine (BotConfig { .. }) time line
then ModeMsg time Self target message [] line
else ModeMsg time user target mode modeArgs 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
"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
where
isSpc = (== ' ')
@ -51,15 +49,17 @@ msgFromLine (BotConfig { .. }) time line
namesNicks = map stripNickPrefix . words . drop 1 . unwords . drop 5 $ splits
stripNickPrefix = pack . dropWhile (`elem` nickPrefixes) . unpack
lineFromCommand :: BotConfig -> Command -> Text
lineFromCommand (BotConfig { .. }) command = case command of
PongCmd { .. } -> "PONG :" ++ rmsg
PingCmd { .. } -> "PING :" ++ rmsg
NickCmd -> "NICK " ++ botNick
UserCmd -> "USER " ++ botNick ++ " 0 * :" ++ botNick
JoinCmd -> "JOIN " ++ channel
QuitCmd -> "QUIT"
ChannelMsgReply { .. } -> "PRIVMSG " ++ channel ++ " :" ++ rmsg
PrivMsgReply (User { .. }) rmsg -> "PRIVMSG " ++ botNick ++ " :" ++ rmsg
NamesCmd -> "NAMES " ++ channel
_ -> error $ "Unsupported command " ++ show command
isActionMsg = "\SOH" `isPrefixOf` message && "ACTION" `isPrefixOf` drop 1 message
lineFromCommand :: BotConfig -> Command -> Maybe Text
lineFromCommand BotConfig { .. } command = case command of
PongCmd { .. } -> Just $ "PONG :" ++ rmsg
PingCmd { .. } -> Just $ "PING :" ++ rmsg
NickCmd -> Just $ "NICK " ++ botNick
UserCmd -> Just $ "USER " ++ botNick ++ " 0 * :" ++ botNick
JoinCmd -> Just $ "JOIN " ++ channel
QuitCmd -> Just "QUIT"
ChannelMsgReply { .. } -> Just $ "PRIVMSG " ++ channel ++ " :" ++ rmsg
PrivMsgReply (User { .. }) rmsg -> Just $ "PRIVMSG " ++ botNick ++ " :" ++ rmsg
NamesCmd -> Just $ "NAMES " ++ channel
_ -> Nothing

21
Network/IRC/Types.hs
View File

@ -8,9 +8,22 @@
{-# LANGUAGE RecordWildCards #-}
module Network.IRC.Types
(Channel, Nick, MsgHandlerName, User (..), Message (..), Command (..),
BotConfig (..), BotStatus (..), Bot (..), IRC, runIRC,
MsgHandler (..), MonadMsgHandler, newMsgHandler, runMsgHandler, stopMsgHandler)
( Channel
, Nick
, MsgHandlerName
, User (..)
, Message (..)
, Command (..)
, BotConfig (..)
, BotStatus (..)
, Bot (..)
, IRC
, runIRC
, MsgHandler (..)
, MonadMsgHandler
, newMsgHandler
, runMsgHandler
, stopMsgHandler)
where
import ClassyPrelude
@ -107,7 +120,7 @@ newtype MsgHandlerT a = MsgHandlerT { _runMsgHandler :: ReaderT BotConfig IO a }
, MonadIO
, 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
instance MonadMsgHandler MsgHandlerT where

4
hask-irc.cabal
View File

@ -49,6 +49,8 @@ build-type: Simple
cabal-version: >=1.10
library
other-extensions: Safe
build-depends: base >=4.5 && <4.8,
text >=0.11 && <0.12,
mtl >=2.1 && <2.2,
@ -83,7 +85,7 @@ executable hask-irc
-- other-modules:
-- 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.
build-depends: base >=4.5 && <4.8,