From a3e4b145ecd31c0f657c8fe481a316e3acba8b6f Mon Sep 17 00:00:00 2001 From: Abhinav Sarkar Date: Tue, 20 May 2014 02:40:08 +0530 Subject: [PATCH] Some refactoring and reformatting --- Main.hs | 22 +++++++-------- Network/IRC/Client.hs | 26 +++++++++-------- Network/IRC/Handlers/MessageLogger.hs | 36 ++++++++++++------------ Network/IRC/Handlers/SongSearch.hs | 40 +++++++++++++-------------- Network/IRC/Protocol.hs | 38 ++++++++++++------------- Network/IRC/Types.hs | 31 +++++++++++++++------ hask-irc.cabal | 4 ++- 7 files changed, 106 insertions(+), 91 deletions(-) diff --git a/Main.hs b/Main.hs index c343a06..3da9bf9 100644 --- a/Main.hs +++ b/Main.hs @@ -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 @@ -31,7 +31,7 @@ main = do exitFailure mainThreadId <- myThreadId - installHandler sigINT (Catch $ throwTo mainThreadId UserInterrupt) Nothing + installHandler sigINT (Catch $ throwTo mainThreadId UserInterrupt) Nothing installHandler sigTERM (Catch $ throwTo mainThreadId UserInterrupt) Nothing let configFile = headEx args @@ -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 diff --git a/Network/IRC/Client.hs b/Network/IRC/Client.hs index 0b6fc5c..7481c2e 100644 --- a/Network/IRC/Client.hs +++ b/Network/IRC/Client.hs @@ -44,11 +44,14 @@ data Line = Timeout | EOF | Line !Message deriving (Show, Eq) sendCommandLoop :: EChannel Command -> Bot -> IO () sendCommandLoop (commandChan, latch) bot@Bot { .. } = do - cmd <- readChan commandChan - time <- getCurrentTime - let line = lineFromCommand botConfig cmd - TF.hprint socket "{}\r\n" $ TF.Only line - TF.print "[{}] > {}\n" $ TF.buildParams (formatTime defaultTimeLocale "%F %T" time, line) + cmd <- readChan commandChan + time <- getCurrentTime + 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 QuitCmd -> latchIt latch _ -> sendCommandLoop (commandChan, latch) bot @@ -86,9 +89,9 @@ sendMessage = (. Line) . writeChan listenerLoop :: Chan Line -> Chan Command -> Int -> IRC () listenerLoop lineChan commandChan !idleFor = do - status <- get + status <- get bot@Bot { .. } <- ask - let nick = botNick botConfig + let nick = botNick botConfig nStatus <- liftIO . mask_ $ if idleFor >= (oneSec * botTimeout botConfig) @@ -127,10 +130,9 @@ listenerLoop lineChan commandChan !idleFor = do 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 + Nothing -> return () + Just (MessageCmd msg) -> sendMessage lineChan msg + Just cmd -> sendCommand commandChan cmd loadMsgHandlers :: BotConfig -> IO (Map MsgHandlerName MsgHandler) loadMsgHandlers botConfig@BotConfig { .. } = @@ -202,7 +204,7 @@ run botConfig' = withSocketsDo $ do handleErrors :: SomeException -> IO BotStatus handleErrors e = case fromException e of - Just UserInterrupt -> debug "User interrupt" >> return Interrupted + Just UserInterrupt -> debug "User interrupt" >> return Interrupted _ -> debug ("Exception! " ++ pack (show e)) >> return Errored run_ = bracket (connect botConfig) disconnect $ diff --git a/Network/IRC/Handlers/MessageLogger.hs b/Network/IRC/Handlers/MessageLogger.hs index 7e42ce3..3db1506 100644 --- a/Network/IRC/Handlers/MessageLogger.hs +++ b/Network/IRC/Handlers/MessageLogger.hs @@ -28,7 +28,7 @@ mkMsgHandler botConfig "messagelogger" = do initMessageLogger botConfig state return . Just $ newMsgHandler { msgHandlerRun = flip messageLogger state , msgHandlerStop = exitMessageLogger state } -mkMsgHandler _ _ = return Nothing +mkMsgHandler _ _ = return Nothing getLogFilePath :: BotConfig -> IO FilePath getLogFilePath BotConfig { .. } = do @@ -46,25 +46,24 @@ initMessageLogger :: BotConfig -> IORef LoggerState -> IO () initMessageLogger botConfig state = do logFilePath <- getLogFilePath botConfig logFileHandle <- openLogFile logFilePath - time <- getModificationTime logFilePath + time <- getModificationTime logFilePath atomicWriteIORef state $ Just (logFileHandle, utctDay time) exitMessageLogger :: MonadMsgHandler m => IORef LoggerState -> m () exitMessageLogger state = liftIO $ do mHandle <- readIORef state case mHandle of - Nothing -> return () - Just (logFileHandle, _ :: Day) -> hClose logFileHandle + Nothing -> return () + 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 - let diff = diffDays curDay prevDay - logFileHandle' <- if diff >= 1 + curDay <- map utctDay getCurrentTime + let diff = diffDays curDay prevDay + logFileHandle' <- if diff >= 1 then do hClose logFileHandle logFilePath <- getLogFilePath botConfig @@ -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) diff --git a/Network/IRC/Handlers/SongSearch.hs b/Network/IRC/Handlers/SongSearch.hs index 4db09ee..6d6d8f7 100644 --- a/Network/IRC/Handlers/SongSearch.hs +++ b/Network/IRC/Handlers/SongSearch.hs @@ -21,7 +21,7 @@ import Network.IRC.Types mkMsgHandler :: BotConfig -> MsgHandlerName -> IO (Maybe MsgHandler) mkMsgHandler _ "songsearch" = return . Just $ newMsgHandler { msgHandlerRun = songSearch } -mkMsgHandler _ _ = return Nothing +mkMsgHandler _ _ = return Nothing data Song = NoSong | Song { url :: Text, name :: Text, artist :: Text } deriving (Show, Eq) @@ -32,24 +32,24 @@ instance FromJSON Song where parseJSON _ = mempty songSearch :: MonadMsgHandler m => Message -> m (Maybe Command) -songSearch ChannelMsg { .. } = if "!m " `isPrefixOf` msg - then do - BotConfig { .. } <- ask - liftIO $ do - let query = strip . drop 3 $ msg - mApiKey <- CF.lookup config "songsearch.tinysong_apikey" - map (Just . ChannelMsgReply) $ case mApiKey of - Nothing -> -- do log "tinysong api key not found in config" - return $ "Error while searching for " ++ query - Just apiKey -> do - let apiUrl = "http://tinysong.com/b/" ++ urlEncode (unpack query) - ++ "?format=json&key=" ++ apiKey +songSearch ChannelMsg { .. } + | "!m " `isPrefixOf` msg = do + BotConfig { .. } <- ask + liftIO $ do + let query = strip . drop 3 $ msg + mApiKey <- CF.lookup config "songsearch.tinysong_apikey" + map (Just . ChannelMsgReply) $ case mApiKey of + Nothing -> -- do log "tinysong api key not found in config" + return $ "Error while searching for " ++ query + Just apiKey -> do + let apiUrl = "http://tinysong.com/b/" ++ urlEncode (unpack query) + ++ "?format=json&key=" ++ apiKey - result <- try $ curlAesonGet apiUrl >>= evaluate - return $ case result of - Left (_ :: CurlAesonException) -> "Error while searching for " ++ query - Right song -> case song of - Song { .. } -> "Listen to " ++ artist ++ " - " ++ name ++ " at " ++ url - NoSong -> "No song found for: " ++ query - else return Nothing + result <- try $ curlAesonGet apiUrl >>= evaluate + return $ case result of + Left (_ :: CurlAesonException) -> "Error while searching for " ++ query + Right song -> case song of + Song { .. } -> "Listen to " ++ artist ++ " - " ++ name ++ " at " ++ url + NoSong -> "No song found for: " ++ query + | otherwise = return Nothing songSearch _ = return Nothing diff --git a/Network/IRC/Protocol.hs b/Network/IRC/Protocol.hs index 2afa7e4..7732c9a 100644 --- a/Network/IRC/Protocol.hs +++ b/Network/IRC/Protocol.hs @@ -20,16 +20,14 @@ msgFromLine (BotConfig { .. }) time line "PART" -> PartMsg time user message line "KICK" -> KickMsg time user kicked kickReason line "MODE" -> if source == botNick - then ModeMsg time Self target message [] line - else ModeMsg time user target mode modeArgs 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 diff --git a/Network/IRC/Types.hs b/Network/IRC/Types.hs index 6cd2bdf..d11ddf5 100644 --- a/Network/IRC/Types.hs +++ b/Network/IRC/Types.hs @@ -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 @@ -68,11 +81,11 @@ data BotConfig = BotConfig { server :: !Text , config :: !Config } instance Show BotConfig where - show BotConfig { .. } = "server = " ++ show server ++ "\n" ++ - "port = " ++ show port ++ "\n" ++ - "channel = " ++ show channel ++ "\n" ++ - "nick = " ++ show botNick ++ "\n" ++ - "timeout = " ++ show botTimeout ++ "\n" ++ + show BotConfig { .. } = "server = " ++ show server ++ "\n" ++ + "port = " ++ show port ++ "\n" ++ + "channel = " ++ show channel ++ "\n" ++ + "nick = " ++ show botNick ++ "\n" ++ + "timeout = " ++ show botTimeout ++ "\n" ++ "handlers = " ++ show msgHandlerNames data Bot = Bot { botConfig :: !BotConfig @@ -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 diff --git a/hask-irc.cabal b/hask-irc.cabal index 57627d3..9564ffd 100644 --- a/hask-irc.cabal +++ b/hask-irc.cabal @@ -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,