Some type refactoring, added config related error handling

master
Abhinav Sarkar 2014-05-06 02:50:40 +05:30
parent 89c0ffefc7
commit 6a159df001
7 changed files with 109 additions and 74 deletions

37
Main.hs
View File

@ -4,9 +4,10 @@ module Main (main) where
import qualified Data.Text as T 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.Configurator.Types
import Data.Maybe import Data.Maybe
import System.Environment import System.Environment
import System.Exit import System.Exit
@ -23,16 +24,28 @@ main = do
args <- getArgs args <- getArgs
prog <- getProgName prog <- getProgName
when (length args < 1) $ do
putStrLn ("Usage: " ++ prog ++ " <config file path>")
exitFailure
let configFile = head args let configFile = head args
cfg <- C.load [C.Required configFile] loadBotConfig configFile >>= run
server <- C.require cfg "server" loadBotConfig :: FilePath -> IO BotConfig
port <- C.require cfg "port" loadBotConfig configFile = do
channel <- C.require cfg "channel" eCfg <- try $ load [Required configFile]
botNick <- C.require cfg "nick" case eCfg of
timeout <- C.require cfg "timeout" Left (ParseError _ _) -> error "Error while loading config"
handlers <- C.require cfg "handlers" 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 case eBotConfig of
then putStrLn ("Usage: " ++ prog ++ " <config file path>") >> exitFailure Left (KeyError k) -> error $ "Error while reading key from config: " ++ T.unpack k
else run $ BotConfig server port channel botNick timeout handlers cfg Right botConfig -> return botConfig

View File

@ -6,7 +6,9 @@ import qualified Data.Text as T
import Control.Exception import Control.Exception
import Control.Concurrent import Control.Concurrent
import Control.Monad
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.State
import Network import Network
import Prelude hiding (log, catch) import Prelude hiding (log, catch)
import System.IO import System.IO
@ -18,13 +20,8 @@ import Network.IRC.Handlers
import Network.IRC.Protocol import Network.IRC.Protocol
import Network.IRC.Types import Network.IRC.Types
data Status = Connected | Disconnected | Joined | Kicked | Errored
deriving (Show, Eq)
oneSec = 1000000 oneSec = 1000000
io = liftIO
log msg = getClockTime >>= \t -> printf "[%s] ** %s\n" (show t) msg log msg = getClockTime >>= \t -> printf "[%s] ** %s\n" (show t) msg
sendCommand :: Bot -> Command -> IO () sendCommand :: Bot -> Command -> IO ()
@ -32,39 +29,40 @@ sendCommand Bot { .. } reply = do
let line = T.unpack $ lineFromCommand botConfig reply let line = T.unpack $ lineFromCommand botConfig reply
hPrintf socket "%s\r\n" line >> printf "> %s\n" line hPrintf socket "%s\r\n" line >> printf "> %s\n" line
listen :: Status -> IRC Status listen :: IRC ()
listen status = do listen = do
status <- get
bot@Bot { .. } <- ask bot@Bot { .. } <- ask
let nick = botNick botConfig let nick = botNick botConfig
when (status == Kicked) $ nStatus <- liftIO $ do
io $ threadDelay (5 * oneSec) >> sendCommand bot JoinCmd when (status == Kicked) $
threadDelay (5 * oneSec) >> sendCommand bot JoinCmd
mLine <- io . timeout (oneSec * botTimeout botConfig) . hGetLine $ socket mLine <- fmap (fmap init) . timeout (oneSec * botTimeout botConfig) . hGetLine $ socket
case mLine of case mLine of
Nothing -> return Disconnected Nothing -> return Disconnected
Just l -> do Just line -> do
let line = init l time <- getClockTime
time <- io 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) put nStatus
nStatus <- io $ case message of when (nStatus /= Disconnected) listen
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
connect :: BotConfig -> IO Bot connect :: BotConfig -> IO Bot
connect botConfig@BotConfig { .. } = do connect botConfig@BotConfig { .. } = do
@ -104,4 +102,4 @@ run botConfig = withSocketsDo $ do
go bot = do go bot = do
sendCommand bot NickCmd sendCommand bot NickCmd
sendCommand bot UserCmd sendCommand bot UserCmd
runReaderT (listen Connected) bot runIRC bot Connected listen

View File

@ -1,6 +1,6 @@
{-# LANGUAGE RecordWildCards, OverloadedStrings #-} {-# LANGUAGE RecordWildCards, OverloadedStrings #-}
module Network.IRC.Handlers (handleMessage) where module Network.IRC.Handlers (getHandler) where
import qualified Data.List as L import qualified Data.List as L
@ -13,21 +13,20 @@ import Network.IRC.Types
clean = toLower . strip clean = toLower . strip
(++) = append (++) = append
handleMessage :: HandlerName -> Handler getHandler :: HandlerName -> Handler
handleMessage "greeter" = greeter getHandler "greeter" = Handler greeter
handleMessage "welcomer" = welcomer getHandler "welcomer" = Handler welcomer
handleMessage "songsearch" = songSearch 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 Nothing -> return Nothing
Just greeting -> return . Just . ChannelMsgReply $ greeting ++ " " ++ userNick user Just greeting -> return . Just . ChannelMsgReply $ greeting ++ " " ++ userNick user
where where
greetings = ["hi", "hello", "hey", "sup", "bye" greetings = ["hi", "hello", "hey", "sup", "bye"
, "good morning", "good evening", "good night" , "good morning", "good evening", "good night"
, "ohayo", "oyasumi"] , "ohayo", "oyasumi"]
greeter _ _ = return Nothing greeter _ _ = return Nothing
welcomer bot@BotConfig { .. } JoinMsg { .. } welcomer BotConfig { .. } JoinMsg { .. }
| userNick user /= botNick = return . Just . ChannelMsgReply $ "welcome back " ++ userNick user | userNick user /= botNick = return . Just . ChannelMsgReply $ "welcome back " ++ userNick user
welcomer _ _ = return Nothing welcomer _ _ = return Nothing

View File

@ -1,26 +1,26 @@
{-# LANGUAGE RecordWildCards, OverloadedStrings, ScopedTypeVariables, BangPatterns #-} {-# LANGUAGE RecordWildCards, OverloadedStrings, ScopedTypeVariables #-}
module Network.IRC.Handlers.SongSearch (songSearch) where module Network.IRC.Handlers.SongSearch (songSearch) where
import qualified Data.Configurator as C
import Control.Applicative import Control.Applicative
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
import Control.Monad.Trans
import Data.Aeson import Data.Aeson
import Data.Aeson.Types (emptyArray) import Data.Aeson.Types (emptyArray)
import Data.Configurator
import Data.Text import Data.Text
import Data.Text.IO import Data.Text.IO
import Network.Curl.Aeson import Network.Curl.Aeson
import Network.HTTP.Base import Network.HTTP.Base
import Prelude hiding (putStrLn, drop) import Prelude hiding (putStrLn, drop, lookup)
import Network.IRC.Types import Network.IRC.Types
(+++) = append (+++) = append
data Song = NoSong | Song { url :: Text, name :: Text, artist :: Text } data Song = NoSong | Song { url :: Text, name :: Text, artist :: Text }
deriving (Show) deriving (Show, Eq)
instance FromJSON Song where instance FromJSON Song where
parseJSON (Object o) = Song <$> o .: "Url" <*> o .: "SongName" <*> o .: "ArtistName" parseJSON (Object o) = Song <$> o .: "Url" <*> o .: "SongName" <*> o .: "ArtistName"
@ -28,18 +28,21 @@ instance FromJSON Song where
parseJSON _ = mzero parseJSON _ = mzero
songSearch bot@BotConfig { .. } ChannelMsg { .. } songSearch bot@BotConfig { .. } ChannelMsg { .. }
| "!m " `isPrefixOf` msg = do | "!m " `isPrefixOf` msg = liftIO $ do
let query = strip . drop 3 $ msg let query = strip . drop 3 $ msg
apiKey <- C.require config "songsearch.tinysong_apikey" mApiKey <- lookup config "songsearch.tinysong_apikey"
let apiUrl = "http://tinysong.com/b/" ++ urlEncode (unpack query) fmap (Just . ChannelMsgReply) $ case mApiKey of
++ "?format=json&key=" ++ apiKey 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 result <- try $ curlAesonGet apiUrl >>= evaluate
return $ case result of
return . Just . ChannelMsgReply $ case result of Left (_ :: CurlAesonException) -> "Error while searching for " +++ query
Left (_ :: CurlAesonException) -> "Error while searching for " +++ query 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
| otherwise = return Nothing | otherwise = return Nothing
songSearch _ _ = return Nothing songSearch _ _ = return Nothing

View File

@ -1,9 +1,11 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards, DeriveDataTypeable, RankNTypes, GeneralizedNewtypeDeriving #-}
module Network.IRC.Types where module Network.IRC.Types where
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.State
import Data.Configurator.Types import Data.Configurator.Types
import Data.Dynamic
import Data.Text (Text) import Data.Text (Text)
import System.IO import System.IO
import System.Time import System.Time
@ -11,7 +13,10 @@ import System.Time
type Channel = Text type Channel = Text
type Nick = Text type Nick = Text
type HandlerName = 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 } data User = Self | User { userNick :: Nick, userServer :: Text }
deriving (Show, Eq) deriving (Show, Eq)
@ -56,4 +61,12 @@ instance Show BotConfig where
data Bot = Bot { botConfig :: BotConfig, socket :: Handle } deriving (Show) 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

View File

@ -2,7 +2,7 @@ server = "irc.freenode.net"
port = 6667 port = 6667
channel = "#testtesttest" channel = "#testtesttest"
nick = "haskman" nick = "haskman"
handlers = ["greeter", "welcomer"] handlers = ["greeter", "welcomer", "songsearch"]
songsearch { songsearch {
tinysong_apikey = "xxxyyyzzz" tinysong_apikey = "xxxyyyzzz"

View File

@ -48,6 +48,15 @@ build-type: Simple
-- Constraint on the version of Cabal needed to build this package. -- Constraint on the version of Cabal needed to build this package.
cabal-version: >=1.10 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 executable hask-irc
-- .hs or .lhs file containing the Main module. -- .hs or .lhs file containing the Main module.
@ -62,7 +71,7 @@ executable hask-irc
-- Other library packages from which modules are imported. -- 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, 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, 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. -- Directories containing source files.
-- hs-source-dirs: -- hs-source-dirs: