Removes core's and handler's dependency on configurator.
by using core's own configuration module. Also changes runner to convert between configurator's config and core's config.master
parent
53a28f6c06
commit
9960ae2d58
|
@ -7,7 +7,6 @@ module Network.IRC.Bot
|
||||||
, messageProcessLoop )
|
, messageProcessLoop )
|
||||||
where
|
where
|
||||||
|
|
||||||
import qualified Data.Configurator as CF
|
|
||||||
import qualified Data.Text.Format as TF
|
import qualified Data.Text.Format as TF
|
||||||
import qualified System.Log.Logger as HSL
|
import qualified System.Log.Logger as HSL
|
||||||
|
|
||||||
|
@ -20,6 +19,7 @@ import System.IO (hIsEOF)
|
||||||
import System.Timeout (timeout)
|
import System.Timeout (timeout)
|
||||||
import System.Log.Logger.TH (deriveLoggers)
|
import System.Log.Logger.TH (deriveLoggers)
|
||||||
|
|
||||||
|
import qualified Network.IRC.Configuration as CF
|
||||||
import Network.IRC.MessageBus
|
import Network.IRC.MessageBus
|
||||||
import Network.IRC.Internal.Types
|
import Network.IRC.Internal.Types
|
||||||
import Network.IRC.Protocol
|
import Network.IRC.Protocol
|
||||||
|
@ -132,7 +132,7 @@ messageProcessLoop inChan messageChan = loop 0
|
||||||
Bot { .. } <- ask
|
Bot { .. } <- ask
|
||||||
let nick = botNick botConfig
|
let nick = botNick botConfig
|
||||||
let origNick = botOrigNick botConfig
|
let origNick = botOrigNick botConfig
|
||||||
mpass <- io $ CF.lookup (config botConfig) "password"
|
let mpass = CF.lookup "password" (config botConfig)
|
||||||
|
|
||||||
nStatus <- io . mask_ $
|
nStatus <- io . mask_ $
|
||||||
if idleFor >= (oneSec * botTimeout botConfig)
|
if idleFor >= (oneSec * botTimeout botConfig)
|
||||||
|
@ -143,12 +143,12 @@ messageProcessLoop inChan messageChan = loop 0
|
||||||
|
|
||||||
mIn <- receiveMessage inChan
|
mIn <- receiveMessage inChan
|
||||||
case mIn of
|
case mIn of
|
||||||
Timeout -> do
|
Timeout -> do
|
||||||
idleMsg <- newMessage IdleMsg
|
idleMsg <- newMessage IdleMsg
|
||||||
sendMessage messageChan idleMsg
|
sendMessage messageChan idleMsg
|
||||||
sendWhoisMessage nick origNick
|
sendWhoisMessage nick origNick
|
||||||
return Idle
|
return Idle
|
||||||
EOD -> infoM "Connection closed" >> return Disconnected
|
EOD -> infoM "Connection closed" >> return Disconnected
|
||||||
Msg (msg@Message { .. }) -> do
|
Msg (msg@Message { .. }) -> do
|
||||||
nStatus <- handleMsg nick origNick message mpass
|
nStatus <- handleMsg nick origNick message mpass
|
||||||
sendMessage messageChan msg
|
sendMessage messageChan msg
|
||||||
|
|
|
@ -0,0 +1,79 @@
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, ExistentialQuantification, GADTs #-}
|
||||||
|
|
||||||
|
module Network.IRC.Configuration
|
||||||
|
( Name
|
||||||
|
, Value (..)
|
||||||
|
, Configuration
|
||||||
|
, Configurable (..)
|
||||||
|
, fromMap
|
||||||
|
, lookup
|
||||||
|
, require
|
||||||
|
, lookupDefault
|
||||||
|
) where
|
||||||
|
|
||||||
|
import qualified ClassyPrelude as P
|
||||||
|
|
||||||
|
import ClassyPrelude hiding (lookup)
|
||||||
|
import Data.Maybe (fromJust)
|
||||||
|
|
||||||
|
type Name = Text
|
||||||
|
|
||||||
|
class Configurable a where
|
||||||
|
fromValue :: Value -> Maybe a
|
||||||
|
|
||||||
|
valueToList :: Value -> Maybe [a]
|
||||||
|
valueToList (List xs) = mapM fromValue xs
|
||||||
|
valueToList _ = Nothing
|
||||||
|
|
||||||
|
toValue :: a -> Value
|
||||||
|
|
||||||
|
listToValue :: [a] -> Value
|
||||||
|
listToValue = List . map toValue
|
||||||
|
|
||||||
|
valueToNum :: (Num a) => Value -> Maybe a
|
||||||
|
valueToNum (Number n) = Just . fromInteger $ n
|
||||||
|
valueToNum _ = Nothing
|
||||||
|
|
||||||
|
instance Configurable Integer where
|
||||||
|
fromValue = valueToNum
|
||||||
|
toValue = Number
|
||||||
|
|
||||||
|
instance Configurable Int where
|
||||||
|
fromValue = valueToNum
|
||||||
|
toValue = Number . toInteger
|
||||||
|
|
||||||
|
instance Configurable Text where
|
||||||
|
fromValue (String s) = Just s
|
||||||
|
fromValue _ = Nothing
|
||||||
|
|
||||||
|
toValue = String
|
||||||
|
|
||||||
|
instance Configurable Bool where
|
||||||
|
fromValue (Boolean b) = Just b
|
||||||
|
fromValue _ = Nothing
|
||||||
|
|
||||||
|
toValue = Boolean
|
||||||
|
|
||||||
|
instance Configurable a => Configurable [a] where
|
||||||
|
fromValue = valueToList
|
||||||
|
toValue = listToValue
|
||||||
|
|
||||||
|
data Value = String Text
|
||||||
|
| Number Integer
|
||||||
|
| Boolean Bool
|
||||||
|
| List [Value]
|
||||||
|
deriving (Eq, Show)
|
||||||
|
|
||||||
|
newtype Configuration = Configuration { configMap :: (Map Name Value) } deriving (Show)
|
||||||
|
|
||||||
|
fromMap :: Map Name Value -> Configuration
|
||||||
|
fromMap = Configuration
|
||||||
|
|
||||||
|
lookup :: (Configurable a) => Name -> Configuration -> Maybe a
|
||||||
|
lookup name Configuration {..} = join . map fromValue $ P.lookup name configMap
|
||||||
|
|
||||||
|
require :: (Configurable a) => Name -> Configuration -> a
|
||||||
|
require n = fromJust . lookup n
|
||||||
|
|
||||||
|
lookupDefault :: (Configurable a) => Name -> Configuration -> a -> a
|
||||||
|
lookupDefault n c v = fromMaybe v $ lookup n c
|
|
@ -5,13 +5,11 @@
|
||||||
|
|
||||||
module Network.IRC.Internal.Types where
|
module Network.IRC.Internal.Types where
|
||||||
|
|
||||||
import qualified Data.Configurator as CF
|
|
||||||
|
|
||||||
import ClassyPrelude
|
import ClassyPrelude
|
||||||
import Control.Monad.Base (MonadBase)
|
import Control.Monad.Base (MonadBase)
|
||||||
import Control.Monad.State.Strict (StateT, MonadState, execStateT)
|
import Control.Monad.State.Strict (StateT, MonadState, execStateT)
|
||||||
import Data.Configurator.Types (Config)
|
|
||||||
|
|
||||||
|
import qualified Network.IRC.Configuration as CF
|
||||||
import Network.IRC.Message.Types
|
import Network.IRC.Message.Types
|
||||||
import Network.IRC.MessageBus
|
import Network.IRC.MessageBus
|
||||||
import Network.IRC.Util
|
import Network.IRC.Util
|
||||||
|
@ -76,7 +74,7 @@ data BotConfig = BotConfig
|
||||||
-- | A list of extra command formatters. Note that these formatters will always be called after the built-in ones.
|
-- | A list of extra command formatters. Note that these formatters will always be called after the built-in ones.
|
||||||
, cmdFormatters :: ![CommandFormatter]
|
, cmdFormatters :: ![CommandFormatter]
|
||||||
-- | All the bot configuration so that message handlers can lookup their own specific configs.
|
-- | All the bot configuration so that message handlers can lookup their own specific configs.
|
||||||
, config :: !Config
|
, config :: !(CF.Configuration)
|
||||||
}
|
}
|
||||||
|
|
||||||
instance Show BotConfig where
|
instance Show BotConfig where
|
||||||
|
@ -96,7 +94,7 @@ newBotConfig :: Text -- ^ server
|
||||||
-> Int -- ^ botTimeout
|
-> Int -- ^ botTimeout
|
||||||
-> BotConfig
|
-> BotConfig
|
||||||
newBotConfig server port channel botNick botTimeout =
|
newBotConfig server port channel botNick botTimeout =
|
||||||
BotConfig server port channel botNick botNick botTimeout mempty mempty [] [] CF.empty
|
BotConfig server port channel botNick botNick botTimeout mempty mempty [] [] (CF.fromMap mempty)
|
||||||
|
|
||||||
-- | The bot.
|
-- | The bot.
|
||||||
data Bot = Bot
|
data Bot = Bot
|
||||||
|
|
|
@ -55,7 +55,6 @@ library
|
||||||
|
|
||||||
build-depends: base >=4.5 && <4.8,
|
build-depends: base >=4.5 && <4.8,
|
||||||
classy-prelude >=0.10 && <1.0,
|
classy-prelude >=0.10 && <1.0,
|
||||||
configurator >=0.2 && <0.3,
|
|
||||||
convertible >=1.1 && <1.2,
|
convertible >=1.1 && <1.2,
|
||||||
hslogger >=1.2 && <1.3,
|
hslogger >=1.2 && <1.3,
|
||||||
hslogger-template >=2.0 && <2.1,
|
hslogger-template >=2.0 && <2.1,
|
||||||
|
@ -72,6 +71,7 @@ library
|
||||||
exposed-modules: Network.IRC,
|
exposed-modules: Network.IRC,
|
||||||
Network.IRC.Types,
|
Network.IRC.Types,
|
||||||
Network.IRC.Client,
|
Network.IRC.Client,
|
||||||
|
Network.IRC.Configuration,
|
||||||
Network.IRC.Util
|
Network.IRC.Util
|
||||||
|
|
||||||
other-modules: Network.IRC.Internal.Types,
|
other-modules: Network.IRC.Internal.Types,
|
||||||
|
|
|
@ -2,7 +2,6 @@
|
||||||
|
|
||||||
module Network.IRC.Handlers.MessageLogger (messageLoggerMsgHandlerMaker) where
|
module Network.IRC.Handlers.MessageLogger (messageLoggerMsgHandlerMaker) where
|
||||||
|
|
||||||
import qualified Data.Configurator as CF
|
|
||||||
import qualified Data.Text.Format as TF
|
import qualified Data.Text.Format as TF
|
||||||
import qualified Data.Text.Format.Params as TF
|
import qualified Data.Text.Format.Params as TF
|
||||||
|
|
||||||
|
@ -12,6 +11,7 @@ import System.Directory (createDirectoryIfMissing, getModificationTime,
|
||||||
import System.FilePath (FilePath, (</>), (<.>))
|
import System.FilePath (FilePath, (</>), (<.>))
|
||||||
import System.IO (openFile, IOMode(..), hSetBuffering, BufferMode(..))
|
import System.IO (openFile, IOMode(..), hSetBuffering, BufferMode(..))
|
||||||
|
|
||||||
|
import qualified Network.IRC.Configuration as CF
|
||||||
import Network.IRC
|
import Network.IRC
|
||||||
import Network.IRC.Util
|
import Network.IRC.Util
|
||||||
|
|
||||||
|
@ -28,9 +28,9 @@ messageLoggerMsgHandlerMaker = MsgHandlerMaker "messagelogger" go
|
||||||
|
|
||||||
getLogFilePath :: BotConfig -> IO FilePath
|
getLogFilePath :: BotConfig -> IO FilePath
|
||||||
getLogFilePath BotConfig { .. } = do
|
getLogFilePath BotConfig { .. } = do
|
||||||
logFileDir <- CF.require config "messagelogger.logdir"
|
let logFileDir = CF.require "messagelogger.logdir" config :: Text
|
||||||
createDirectoryIfMissing True logFileDir
|
createDirectoryIfMissing True (unpack logFileDir)
|
||||||
return $ logFileDir </> unpack (botChannel ++ "-" ++ nickToText botNick) <.> "log"
|
return $ (unpack logFileDir) </> unpack (botChannel ++ "-" ++ nickToText botNick) <.> "log"
|
||||||
|
|
||||||
openLogFile :: FilePath -> IO Handle
|
openLogFile :: FilePath -> IO Handle
|
||||||
openLogFile logFilePath = do
|
openLogFile logFilePath = do
|
||||||
|
|
|
@ -3,7 +3,6 @@
|
||||||
|
|
||||||
module Network.IRC.Handlers.NickTracker (nickTrackerMsgHandlerMaker) where
|
module Network.IRC.Handlers.NickTracker (nickTrackerMsgHandlerMaker) where
|
||||||
|
|
||||||
import qualified Data.Configurator as CF
|
|
||||||
import qualified Data.IxSet as IS
|
import qualified Data.IxSet as IS
|
||||||
import qualified Data.UUID as U
|
import qualified Data.UUID as U
|
||||||
import qualified Data.UUID.V4 as U
|
import qualified Data.UUID.V4 as U
|
||||||
|
@ -17,6 +16,7 @@ import Data.Convertible (convert)
|
||||||
import Data.IxSet (getOne, (@=))
|
import Data.IxSet (getOne, (@=))
|
||||||
import Data.Time (addUTCTime, NominalDiffTime)
|
import Data.Time (addUTCTime, NominalDiffTime)
|
||||||
|
|
||||||
|
import qualified Network.IRC.Configuration as CF
|
||||||
import Network.IRC
|
import Network.IRC
|
||||||
import Network.IRC.Handlers.NickTracker.Internal.Types
|
import Network.IRC.Handlers.NickTracker.Internal.Types
|
||||||
import Network.IRC.Util
|
import Network.IRC.Util
|
||||||
|
@ -193,9 +193,9 @@ nickTrackerMsgHandlerMaker = MsgHandlerMaker "nicktracker" go
|
||||||
|
|
||||||
go BotConfig { .. } _ = do
|
go BotConfig { .. } _ = do
|
||||||
state <- io $ do
|
state <- io $ do
|
||||||
now <- getCurrentTime
|
now <- getCurrentTime
|
||||||
refreshInterval <- map convert (CF.lookupDefault 60 config "nicktracker.refresh_interval" :: IO Int)
|
let refreshInterval = convert (CF.lookupDefault "nicktracker.refresh_interval" config 60 :: Int)
|
||||||
acid <- openLocalState emptyNickTracking
|
acid <- openLocalState emptyNickTracking
|
||||||
newIORef (NickTrackingState acid refreshInterval mempty now)
|
newIORef (NickTrackingState acid refreshInterval mempty now)
|
||||||
return $ newMsgHandler { onMessage = nickTrackerMsg state
|
return $ newMsgHandler { onMessage = nickTrackerMsg state
|
||||||
, onStop = stopNickTracker state
|
, onStop = stopNickTracker state
|
||||||
|
|
|
@ -3,7 +3,6 @@
|
||||||
|
|
||||||
module Network.IRC.Handlers.SongSearch (songSearchMsgHandlerMaker) where
|
module Network.IRC.Handlers.SongSearch (songSearchMsgHandlerMaker) where
|
||||||
|
|
||||||
import qualified Data.Configurator as CF
|
|
||||||
import qualified System.Log.Logger as HSL
|
import qualified System.Log.Logger as HSL
|
||||||
|
|
||||||
import ClassyPrelude
|
import ClassyPrelude
|
||||||
|
@ -15,6 +14,7 @@ import Network.Curl.Aeson (curlAesonGet, CurlAesonException)
|
||||||
import Network.HTTP.Base (urlEncode)
|
import Network.HTTP.Base (urlEncode)
|
||||||
import System.Log.Logger.TH (deriveLoggers)
|
import System.Log.Logger.TH (deriveLoggers)
|
||||||
|
|
||||||
|
import qualified Network.IRC.Configuration as CF
|
||||||
import Network.IRC
|
import Network.IRC
|
||||||
|
|
||||||
$(deriveLoggers "HSL" [HSL.ERROR])
|
$(deriveLoggers "HSL" [HSL.ERROR])
|
||||||
|
@ -42,15 +42,15 @@ songSearch Message { .. }
|
||||||
, "!m " `isPrefixOf` msg = do
|
, "!m " `isPrefixOf` msg = do
|
||||||
BotConfig { .. } <- ask
|
BotConfig { .. } <- ask
|
||||||
liftIO $ do
|
liftIO $ do
|
||||||
let query = strip . drop 3 $ msg
|
let query = strip . drop 3 $ msg
|
||||||
mApiKey <- CF.lookup config "songsearch.tinysong_apikey"
|
let mApiKey = CF.lookup "songsearch.tinysong_apikey" config
|
||||||
reply <- map ChannelMsgReply $ case mApiKey of
|
reply <- map ChannelMsgReply $ case mApiKey of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
errorM "tinysong api key not found in config"
|
errorM "tinysong api key not found in config"
|
||||||
return $ "Error while searching for " ++ query
|
return $ "Error while searching for " ++ query
|
||||||
Just apiKey -> do
|
Just (apiKey :: Text) -> do
|
||||||
let apiUrl = "http://tinysong.com/b/" ++ urlEncode (unpack query)
|
let apiUrl = "http://tinysong.com/b/" ++ urlEncode (unpack query)
|
||||||
++ "?format=json&key=" ++ apiKey
|
++ "?format=json&key=" ++ unpack apiKey
|
||||||
|
|
||||||
result <- try $ curlAesonGet apiUrl >>= evaluate
|
result <- try $ curlAesonGet apiUrl >>= evaluate
|
||||||
case result of
|
case result of
|
||||||
|
|
|
@ -58,7 +58,6 @@ library
|
||||||
acid-state >=0.12 && <0.13,
|
acid-state >=0.12 && <0.13,
|
||||||
aeson >=0.7 && <0.8,
|
aeson >=0.7 && <0.8,
|
||||||
classy-prelude >=0.10 && <1.0,
|
classy-prelude >=0.10 && <1.0,
|
||||||
configurator >=0.2 && <0.3,
|
|
||||||
convertible >=1.1 && <1.2,
|
convertible >=1.1 && <1.2,
|
||||||
curl-aeson >=0.0.3 && <0.1,
|
curl-aeson >=0.0.3 && <0.1,
|
||||||
directory >=1.2 && <1.3,
|
directory >=1.2 && <1.3,
|
||||||
|
|
|
@ -3,17 +3,38 @@
|
||||||
module Network.IRC.Config (loadBotConfig) where
|
module Network.IRC.Config (loadBotConfig) where
|
||||||
|
|
||||||
import qualified Data.Configurator as CF
|
import qualified Data.Configurator as CF
|
||||||
|
import qualified Data.Configurator.Types as CFT
|
||||||
|
import qualified Data.Ratio as R
|
||||||
|
|
||||||
import ClassyPrelude
|
import ClassyPrelude
|
||||||
import Data.Configurator.Types (Configured (..), Value (List), ConfigError (..), KeyError (..))
|
import Data.Configurator.Types (Configured (..), ConfigError (..), KeyError (..))
|
||||||
|
|
||||||
import Network.IRC
|
import Network.IRC
|
||||||
|
import Network.IRC.Configuration
|
||||||
import Network.IRC.Handlers
|
import Network.IRC.Handlers
|
||||||
|
|
||||||
instance Configured a => Configured [a] where
|
instance Configured a => Configured [a] where
|
||||||
convert (List xs) = Just . mapMaybe convert $ xs
|
convert (CFT.List xs) = Just . mapMaybe convert $ xs
|
||||||
convert _ = Nothing
|
convert _ = Nothing
|
||||||
|
|
||||||
|
instance Configurable CFT.Value where
|
||||||
|
fromValue (String a) = Just $ CFT.String a
|
||||||
|
fromValue (Number a) = Just $ CFT.Number (a R.% 1)
|
||||||
|
fromValue (Boolean a) = Just $ CFT.Bool a
|
||||||
|
fromValue (List a) = Just $ CFT.List (mapMaybe fromValue a)
|
||||||
|
|
||||||
|
toValue (CFT.String a) = toValue a
|
||||||
|
toValue (CFT.Number r) = toValue (R.numerator r `div` R.denominator r)
|
||||||
|
toValue (CFT.Bool a) = toValue a
|
||||||
|
toValue (CFT.List vs) = toValue vs
|
||||||
|
|
||||||
|
fromConfiguratorConfig :: CFT.Config -> IO Configuration
|
||||||
|
fromConfiguratorConfig config =
|
||||||
|
fromMap
|
||||||
|
. foldl' (\m (k, v) -> insertMap k (toValue v) m) mempty
|
||||||
|
. mapToList
|
||||||
|
<$> CF.getMap config
|
||||||
|
|
||||||
loadBotConfig :: String -> IO BotConfig
|
loadBotConfig :: String -> IO BotConfig
|
||||||
loadBotConfig configFile = do
|
loadBotConfig configFile = do
|
||||||
eConfig <- try $ CF.load [CF.Required configFile]
|
eConfig <- try $ CF.load [CF.Required configFile]
|
||||||
|
@ -33,9 +54,10 @@ loadBotConfig configFile = do
|
||||||
CF.require config "channel" <*>
|
CF.require config "channel" <*>
|
||||||
(Nick <$> CF.require config "nick") <*>
|
(Nick <$> CF.require config "nick") <*>
|
||||||
CF.require config "timeout"
|
CF.require config "timeout"
|
||||||
|
configMap <- fromConfiguratorConfig config
|
||||||
return botConfig { msgHandlerInfo = handlerInfo
|
return botConfig { msgHandlerInfo = handlerInfo
|
||||||
, msgHandlerMakers = handlerMakers
|
, msgHandlerMakers = handlerMakers
|
||||||
, config = config
|
, config = configMap
|
||||||
}
|
}
|
||||||
|
|
||||||
case eBotConfig of
|
case eBotConfig of
|
||||||
|
|
Loading…
Reference in New Issue