Some type refactoring, added config related error handling
parent
89c0ffefc7
commit
6a159df001
37
Main.hs
37
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 ++ " <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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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:
|
||||
|
|
Loading…
Reference in New Issue