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.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 ++ " <config file path>")
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 ++ " <config file path>") >> 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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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"

View File

@ -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: