From 6a159df001309159cf6522cd1fc0a3d18c696593 Mon Sep 17 00:00:00 2001 From: Abhinav Sarkar Date: Tue, 6 May 2014 02:50:40 +0530 Subject: [PATCH] Some type refactoring, added config related error handling --- Main.hs | 37 +++++++++++------ Network/IRC/Client.hs | 64 +++++++++++++++--------------- Network/IRC/Handlers.hs | 15 ++++--- Network/IRC/Handlers/SongSearch.hs | 35 ++++++++-------- Network/IRC/Types.hs | 19 +++++++-- config.cfg.template | 2 +- hask-irc.cabal | 11 ++++- 7 files changed, 109 insertions(+), 74 deletions(-) diff --git a/Main.hs b/Main.hs index 052fb56..df1b336 100644 --- a/Main.hs +++ b/Main.hs @@ -4,9 +4,10 @@ module Main (main) where import qualified Data.Text as T -import qualified Data.Configurator as C +import Control.Exception +import Control.Monad +import Data.Configurator import Data.Configurator.Types - import Data.Maybe import System.Environment import System.Exit @@ -23,16 +24,28 @@ main = do args <- getArgs prog <- getProgName + when (length args < 1) $ do + putStrLn ("Usage: " ++ prog ++ " ") + exitFailure + let configFile = head args - cfg <- C.load [C.Required configFile] + loadBotConfig configFile >>= run - server <- C.require cfg "server" - port <- C.require cfg "port" - channel <- C.require cfg "channel" - botNick <- C.require cfg "nick" - timeout <- C.require cfg "timeout" - handlers <- C.require cfg "handlers" +loadBotConfig :: FilePath -> IO BotConfig +loadBotConfig configFile = do + eCfg <- try $ load [Required configFile] + case eCfg of + Left (ParseError _ _) -> error "Error while loading config" + Right cfg -> do + eBotConfig <- try $ do + server <- require cfg "server" + port <- require cfg "port" + channel <- require cfg "channel" + botNick <- require cfg "nick" + timeout <- require cfg "timeout" + handlers <- require cfg "handlers" + return $ BotConfig server port channel botNick timeout handlers cfg - if length args < 1 - then putStrLn ("Usage: " ++ prog ++ " ") >> exitFailure - else run $ BotConfig server port channel botNick timeout handlers cfg + case eBotConfig of + Left (KeyError k) -> error $ "Error while reading key from config: " ++ T.unpack k + Right botConfig -> return botConfig diff --git a/Network/IRC/Client.hs b/Network/IRC/Client.hs index a2566ae..65063a9 100644 --- a/Network/IRC/Client.hs +++ b/Network/IRC/Client.hs @@ -6,7 +6,9 @@ import qualified Data.Text as T import Control.Exception import Control.Concurrent +import Control.Monad import Control.Monad.Reader +import Control.Monad.State import Network import Prelude hiding (log, catch) import System.IO @@ -18,13 +20,8 @@ import Network.IRC.Handlers import Network.IRC.Protocol import Network.IRC.Types -data Status = Connected | Disconnected | Joined | Kicked | Errored - deriving (Show, Eq) - oneSec = 1000000 -io = liftIO - log msg = getClockTime >>= \t -> printf "[%s] ** %s\n" (show t) msg sendCommand :: Bot -> Command -> IO () @@ -32,39 +29,40 @@ sendCommand Bot { .. } reply = do let line = T.unpack $ lineFromCommand botConfig reply hPrintf socket "%s\r\n" line >> printf "> %s\n" line -listen :: Status -> IRC Status -listen status = do +listen :: IRC () +listen = do + status <- get bot@Bot { .. } <- ask let nick = botNick botConfig - when (status == Kicked) $ - io $ threadDelay (5 * oneSec) >> sendCommand bot JoinCmd + nStatus <- liftIO $ do + when (status == Kicked) $ + threadDelay (5 * oneSec) >> sendCommand bot JoinCmd - mLine <- io . timeout (oneSec * botTimeout botConfig) . hGetLine $ socket - case mLine of - Nothing -> return Disconnected - Just l -> do - let line = init l - time <- io getClockTime + mLine <- fmap (fmap init) . timeout (oneSec * botTimeout botConfig) . hGetLine $ socket + case mLine of + Nothing -> return Disconnected + Just line -> do + time <- getClockTime + printf "[%s] %s\n" (show time) line - io $ printf "[%s] %s\n" (show time) line + let message = msgFromLine botConfig time (T.pack line) + case message of + JoinMsg { .. } | userNick user == nick -> log "Joined" >> return Joined + KickMsg { .. } -> log "Kicked" >> return Kicked + _ -> do + forkIO $ case message of + Ping { .. } -> sendCommand bot $ Pong msg + ModeMsg { user = Self, .. } -> sendCommand bot JoinCmd + msg -> forM_ (handlers botConfig) $ \handler -> forkIO $ do + cmd <- runHandler (getHandler handler) botConfig msg + case cmd of + Nothing -> return () + Just cmd -> sendCommand bot cmd + return status - let message = msgFromLine botConfig time (T.pack line) - nStatus <- io $ case message of - JoinMsg { .. } | userNick user == nick -> log "Joined" >> return Joined - KickMsg { .. } -> log "Kicked" >> return Kicked - _ -> do - forkIO $ case message of - Ping { .. } -> sendCommand bot $ Pong msg - ModeMsg { user = Self, .. } -> sendCommand bot JoinCmd - msg -> forM_ (handlers botConfig) $ \handler -> do - cmd <- handleMessage handler botConfig msg - case cmd of - Nothing -> return () - Just cmd -> sendCommand bot cmd - return status - - listen nStatus + put nStatus + when (nStatus /= Disconnected) listen connect :: BotConfig -> IO Bot connect botConfig@BotConfig { .. } = do @@ -104,4 +102,4 @@ run botConfig = withSocketsDo $ do go bot = do sendCommand bot NickCmd sendCommand bot UserCmd - runReaderT (listen Connected) bot + runIRC bot Connected listen diff --git a/Network/IRC/Handlers.hs b/Network/IRC/Handlers.hs index e93988b..f3e3357 100644 --- a/Network/IRC/Handlers.hs +++ b/Network/IRC/Handlers.hs @@ -1,6 +1,6 @@ {-# LANGUAGE RecordWildCards, OverloadedStrings #-} -module Network.IRC.Handlers (handleMessage) where +module Network.IRC.Handlers (getHandler) where import qualified Data.List as L @@ -13,21 +13,20 @@ import Network.IRC.Types clean = toLower . strip (++) = append -handleMessage :: HandlerName -> Handler -handleMessage "greeter" = greeter -handleMessage "welcomer" = welcomer -handleMessage "songsearch" = songSearch +getHandler :: HandlerName -> Handler +getHandler "greeter" = Handler greeter +getHandler "welcomer" = Handler welcomer +getHandler "songsearch" = Handler songSearch -greeter bot ChannelMsg { .. } = case L.find (== clean msg) greetings of +greeter _ ChannelMsg { .. } = case L.find (== clean msg) greetings of Nothing -> return Nothing Just greeting -> return . Just . ChannelMsgReply $ greeting ++ " " ++ userNick user where greetings = ["hi", "hello", "hey", "sup", "bye" , "good morning", "good evening", "good night" , "ohayo", "oyasumi"] - greeter _ _ = return Nothing -welcomer bot@BotConfig { .. } JoinMsg { .. } +welcomer BotConfig { .. } JoinMsg { .. } | userNick user /= botNick = return . Just . ChannelMsgReply $ "welcome back " ++ userNick user welcomer _ _ = return Nothing diff --git a/Network/IRC/Handlers/SongSearch.hs b/Network/IRC/Handlers/SongSearch.hs index d8e274a..09e620e 100644 --- a/Network/IRC/Handlers/SongSearch.hs +++ b/Network/IRC/Handlers/SongSearch.hs @@ -1,26 +1,26 @@ -{-# LANGUAGE RecordWildCards, OverloadedStrings, ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE RecordWildCards, OverloadedStrings, ScopedTypeVariables #-} module Network.IRC.Handlers.SongSearch (songSearch) where -import qualified Data.Configurator as C - import Control.Applicative import Control.Exception import Control.Monad +import Control.Monad.Trans import Data.Aeson import Data.Aeson.Types (emptyArray) +import Data.Configurator import Data.Text import Data.Text.IO import Network.Curl.Aeson import Network.HTTP.Base -import Prelude hiding (putStrLn, drop) +import Prelude hiding (putStrLn, drop, lookup) import Network.IRC.Types (+++) = append data Song = NoSong | Song { url :: Text, name :: Text, artist :: Text } - deriving (Show) + deriving (Show, Eq) instance FromJSON Song where parseJSON (Object o) = Song <$> o .: "Url" <*> o .: "SongName" <*> o .: "ArtistName" @@ -28,18 +28,21 @@ instance FromJSON Song where parseJSON _ = mzero songSearch bot@BotConfig { .. } ChannelMsg { .. } - | "!m " `isPrefixOf` msg = do + | "!m " `isPrefixOf` msg = liftIO $ do let query = strip . drop 3 $ msg - apiKey <- C.require config "songsearch.tinysong_apikey" - let apiUrl = "http://tinysong.com/b/" ++ urlEncode (unpack query) - ++ "?format=json&key=" ++ apiKey + mApiKey <- lookup config "songsearch.tinysong_apikey" + fmap (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 . Just . ChannelMsgReply $ 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 + 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/Types.hs b/Network/IRC/Types.hs index 8086903..3893641 100644 --- a/Network/IRC/Types.hs +++ b/Network/IRC/Types.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards, DeriveDataTypeable, RankNTypes, GeneralizedNewtypeDeriving #-} module Network.IRC.Types where import Control.Monad.Reader +import Control.Monad.State import Data.Configurator.Types +import Data.Dynamic import Data.Text (Text) import System.IO import System.Time @@ -11,7 +13,10 @@ import System.Time type Channel = Text type Nick = Text type HandlerName = Text -type Handler = BotConfig -> Message -> IO (Maybe Command) + +newtype Handler = Handler { + runHandler :: forall m . (MonadIO m) => BotConfig -> Message -> m (Maybe Command) +} data User = Self | User { userNick :: Nick, userServer :: Text } deriving (Show, Eq) @@ -56,4 +61,12 @@ instance Show BotConfig where data Bot = Bot { botConfig :: BotConfig, socket :: Handle } deriving (Show) -type IRC = ReaderT Bot IO +data BotStatus = Connected | Disconnected | Joined | Kicked | Errored + deriving (Show, Eq) + +newtype IRC a = IRC { _runIRC :: StateT BotStatus (ReaderT Bot IO) a } + deriving (Functor, Monad, MonadIO, MonadReader Bot, MonadState BotStatus) + +runIRC :: Bot -> BotStatus -> IRC a -> IO BotStatus +runIRC bot botStatus irc = + fmap snd $ runReaderT (runStateT (_runIRC irc) Connected) bot diff --git a/config.cfg.template b/config.cfg.template index b1977c1..5ad71a3 100644 --- a/config.cfg.template +++ b/config.cfg.template @@ -2,7 +2,7 @@ server = "irc.freenode.net" port = 6667 channel = "#testtesttest" nick = "haskman" -handlers = ["greeter", "welcomer"] +handlers = ["greeter", "welcomer", "songsearch"] songsearch { tinysong_apikey = "xxxyyyzzz" diff --git a/hask-irc.cabal b/hask-irc.cabal index ca123ba..4014cd4 100644 --- a/hask-irc.cabal +++ b/hask-irc.cabal @@ -48,6 +48,15 @@ build-type: Simple -- Constraint on the version of Cabal needed to build this package. cabal-version: >=1.10 +library + build-depends: base >=4.5 && <4.7, text >=0.11 && <0.12, mtl >=2.1 && <2.2, + network >=2.3 && <2.5, old-time >=1.1 && <1.2, configurator >= 0.2, + curl-aeson ==0.0.3, aeson >=0.6.0.0, HTTP, transformers >=0.3 + + exposed-modules: Network.IRC.Types, Network.IRC.Protocol, + Network.IRC.Handlers, Network.IRC.Client + + default-language: Haskell2010 executable hask-irc -- .hs or .lhs file containing the Main module. @@ -62,7 +71,7 @@ executable hask-irc -- Other library packages from which modules are imported. build-depends: base >=4.5 && <4.7, text >=0.11 && <0.12, mtl >=2.1 && <2.2, network >=2.3 && <2.5, old-time >=1.1 && <1.2, configurator >= 0.2, - curl-aeson ==0.0.3, aeson >=0.6.0.0, HTTP + curl-aeson ==0.0.3, aeson >=0.6.0.0, HTTP, transformers >=0.3 -- Directories containing source files. -- hs-source-dirs: