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.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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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"
|
||||||
|
|
|
@ -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:
|
||||||
|
|
Loading…
Reference in New Issue