Greatly improved configuration file handling.

HsbotIrcBot/Hsbot/Irc/Config.hs

@@ -4,6 +4,8 @@ module Hsbot.Irc.Config
     , getIrcConfig
     ) where
 
+import Control.Monad.Error
+import Data.Char (isDigit)
 import qualified Data.ConfigFile as C
 import Data.Either.Utils
 import Network
@@ -46,7 +48,7 @@ ircDefaultConfig = IrcConfig
     , ircConfigPassword      = ""
     , ircConfigRealname      = "The One True bot, with it's haskell soul."
     , ircConfigCommandPrefix = '@'
-    , ircConfigPlugins       = ["Ping"]
+    , ircConfigPlugins       = ["Ping", "Core"]
     }
 
 -- | config file retrieving
@@ -59,7 +61,7 @@ getIrcConfig maybePath =
                 True -> do
                     fileStatus <- getFileStatus path
                     case isRegularFile $ fileStatus of
-                        True -> compileIrcConfig ircDefaultConfig path
+                        True -> getConfigFromFile path
                         False -> do
                             putStrLn "Invalid configuration file path."
                             exitWith $ ExitFailure 1
@@ -68,51 +70,65 @@ getIrcConfig maybePath =
                     exitWith $ ExitFailure 1
         Nothing -> return ircDefaultConfig  -- TODO : try defaults like $HOME/.hsbotrc, /etc/hsbotrc or /usr/local/etc/hsbotrc
 
--- | config file parsing
+-- | Get configuration from config file
-compileIrcConfig :: IrcConfig -> String -> IO (IrcConfig)
+getConfigFromFile :: FilePath -> IO IrcConfig
-compileIrcConfig ircConfig path = do
+getConfigFromFile fname = readfile C.emptyCP fname >>= extractConfig . forceEither
-    val <- C.readfile C.emptyCP path
+
-    let cp = forceEither val
+-- | A version of readfile that treats the file as UTF-8
-    let address = case C.get cp "IRC" "address" of
+readfile :: MonadError C.CPError m => C.ConfigParser -> FilePath -> IO (m C.ConfigParser)
-         Right this -> this
+readfile cp path' = do
-         Left _ -> ircConfigAddress ircConfig
+    contents <- readFile path'
-    let port = case C.get cp "IRC" "port" of
+    return $ C.readstring cp contents
-         Right this -> PortNumber $ fromIntegral (read this :: Int) -- TODO error handling
+
-         Left _ -> ircConfigPort ircConfig
+-- | config file processing
-    let channels = case C.get cp "IRC" "channels" of
+extractConfig :: C.ConfigParser -> IO IrcConfig
-         Right this -> map (lstrip ' ') (split this ',')
+extractConfig cp = do
-         Left _ -> ircConfigChannels ircConfig
+    config' <- runErrorT $ do
-    let nickname = case C.get cp "IRC" "nickname" of
+        cfAddress <- getit "address"
-         Right this -> this
+        cfPort <- getit "port"
-         Left _ -> ircConfigNickname ircConfig
+        cfChannels <- getit "channels"
-    let password = case C.get cp "IRC" "password" of
+        cfNickname <- getit "nickname"
-         Right this -> this
+        cfPassword <- getit "password"
-         Left _ -> ircConfigPassword ircConfig
+        cfRealname <- getit "realname"
-    let realname = case C.get cp "IRC" "realname" of
+        cfCommandPrefix <- getit "commandprefix"
-         Right this -> this
+        cfPlugins <- getit "plugins"
-         Left _ -> ircConfigRealname ircConfig
+        return $! IrcConfig {
-    let commandPrefix = case C.get cp "IRC" "commandPrefix" of
+                      ircConfigAddress       = cfAddress
-         Right this -> head this -- TODO error handling
+                    , ircConfigPort          = PortNumber . fromIntegral $ readInteger "port" cfPort
-         Left _ -> ircConfigCommandPrefix ircConfig
+                    , ircConfigChannels      = splitCommaList cfChannels
-    let plugins = case C.get cp "IRC" "plugins" of
+                    , ircConfigNickname      = cfNickname
-         Right this -> map (lstrip ' ') (split this ',')
+                    , ircConfigPassword      = cfPassword
-         Left _ -> ircConfigPlugins ircConfig
+                    , ircConfigRealname      = cfRealname
-    return ircConfig { ircConfigAddress       = address
+                    , ircConfigCommandPrefix = readChar "commandprefix" cfCommandPrefix
-                     , ircConfigPort          = port
+                    , ircConfigPlugins       = splitCommaList cfPlugins }
-                     , ircConfigChannels      = channels
+    case config' of
-                     , ircConfigNickname      = nickname
+         Left (C.ParseError e, e') -> error $ "Parse error: " ++ e ++ "\n" ++ e'
-                     , ircConfigPassword      = password
+         Left e                  -> error (show e)
-                     , ircConfigRealname      = realname
+         Right c                 -> return c
-                     , ircConfigCommandPrefix = commandPrefix
+  where
-                     , ircConfigPlugins       = plugins }
+    getit = C.get cp "IRC"
-  where
+
-    split :: String -> Char -> [String]
+readChar :: String -> String -> Char
-    split [] _ = [""]
+readChar _ x | length x == 1 = head x
-    split (c:cs) delim
+readChar opt _ = error $ opt ++ " must be one character long."
-       | c == delim = "" : rest
+
-       | otherwise = (c : head rest) : tail rest
+readInteger :: String -> String -> Int
-      where rest = split cs delim
+readInteger _   x | all isDigit x = read x ::Int
-    lstrip :: Char -> String -> String
+readInteger opt _ = error $ opt ++ " must be an integer."
-    lstrip x (c:cs) = if (x == c) then (lstrip x cs) else c:(lstrip x cs)
+
-    lstrip _ [] = []
+-- readNumber :: (Num a, Read a) => String -> String -> a
+-- readNumber _   x | all isDigit x = read x
+-- readNumber opt _ = error $ opt ++ " must be a number."
+
+splitCommaList :: String -> [String]
+splitCommaList l =
+    let (first, rest) = break (== ',') l
+        first' = lrStrip first
+    in case rest of
+            []     -> if null first' then [] else [first']
+            (_:rs) -> first' : splitCommaList rs
+
+lrStrip :: String -> String
+lrStrip = reverse . dropWhile isWhitespace . reverse . dropWhile isWhitespace
+    where isWhitespace = (`elem` " \t\n")
 

HsbotIrcBot/hsbot-irc.cabal

@@ -19,7 +19,7 @@ Build-type:         Simple
 Executable hsbot-irc
   Main-is:          Main.hs
   Ghc-options:      -Wall
-  Extensions:       DeriveDataTypeable ScopedTypeVariables
+  Extensions:       DeriveDataTypeable FlexibleContexts ScopedTypeVariables
   Build-depends:    base >= 4.1 && < 5,
                     ConfigFile,
                     containers,