diff --git a/Data/AppSettings.hs b/Data/AppSettings.hs new file mode 100644 --- /dev/null +++ b/Data/AppSettings.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE RankNTypes #-} + +-- | +-- A library to deal with application settings. +-- This library deals with read-write application settings. +-- You will have to specify the settings that your application +-- uses, their name, types and default values. +-- Setting types must implement the 'Read' and 'Show' typeclasses. +-- +-- The settings are saved in a file in an INI-like key-value format +-- (without sections). +-- +-- Reading and updating settings is done in pure code, the IO +-- monad is only used to load settings and save them to disk. +-- It is advised for the user to create a module in your project +-- holding settings handling. +-- +-- You can then declare settings: +-- +-- > fontSize :: Setting Double +-- > fontSize = Setting "fontSize" 14 +-- > +-- > dateFormat :: Setting String +-- > dateFormat = Setting "dateFormat" "%x" +-- > +-- > backgroundColor :: Setting (Int, Int, Int) +-- > backgroundColor = Setting "backcolor" (255, 0, 0) +-- +-- Optionally you can declare the list of all your settings: +-- +-- > defaultConfig :: DefaultConfig +-- > defaultConfig = getDefaultConfig $ do +-- > setting fontSize +-- > setting dateFormat +-- > setting backgroundColor +-- +-- If you do it, 'saveSettings' will also save settings +-- which have not been modified, which are still at their +-- default value in the configuration file, in a commented +-- form, as a documentation to the user who may open the +-- configuration file. +-- So for instance if you declare this default configuration +-- and have set the font size to 16 but left the other +-- settings untouched, the configuration file which will be +-- saved will be: +-- +-- > fontSize=16 +-- > # dateFormat="%x" +-- > # backcolor=(255,0,0) +-- +-- If you did not specify the list of settings, only the +-- first line would be present in the configuration file. +-- +-- Once we declared the settings, we can read the configuration +-- from disk (and your settings module should export your wrapper +-- around the function offered by this library): +-- +-- > readResult <- try $ readSettings (AutoFromAppName "test") +-- > case readResult of +-- > Right (conf, GetSetting getSetting) -> do +-- > let textSize = getSetting textSizeFromWidth +-- > saveSettings getDefaultConfig (AutoFromAppName "test") conf +-- > Left (x :: SomeException) -> error "Error reading the config file!" +-- +-- 'AutoFromAppName' specifies where to save the configuration file. +-- And we've already covered the getSetting in this snippet, see +-- the 'readSettings' documentation for further information. + +module Data.AppSettings ( + Conf, + DefaultConfig, + Setting(..), + GetSetting(..), + setting, + getDefaultConfig, + emptyDefaultConfig, + FileLocation(..), + readSettings, + ParseException, + saveSettings, + setSetting) where + +import System.Directory +import qualified Data.Map as M +import Control.Monad.State +import Text.Read (readMaybe) +import Data.Maybe (fromMaybe) + +import Data.Serialization + +-- http://stackoverflow.com/questions/23117205/ +newtype GetSetting = GetSetting (forall a. Read a => Setting a -> a) + +-- for the tests... +instance Show GetSetting where + show _ = "GetSetting" + +-- | The type of a setting. +-- It contains the setting name +-- (key in the configuration file) and its default value. +-- +-- It is advised to have a module in your project handling settings. +-- In this module, you'd have all the settings declared at the +-- toplevel, and exported. +-- The rest of the application can then do +-- +-- @ +-- getSetting \ +-- setSetting \ \ +-- @ +-- +-- and so on. +data Setting a = Setting { name :: String, defaultValue :: a } + +-- | Information about the default configuration. Contains +-- all the settings (that you declare using 'getDefaultConfig') +-- and their default values. It is useful when you save a +-- configuration file, if you give this information to 'saveSettings', +-- it will save default options in the configuration file +-- in a commented form, as a form of documentation to a user +-- who would edit the configuration file. +-- However this is completely optional, you can give +-- 'emptyDefaultConfig' if you don't want this behaviour. +newtype DefaultConfig = DefaultConfig Conf + +-- | Default configuration containing no options. It's fine +-- to give that to 'saveSettings' if you don't want default +-- settings being written to the configuration file in +-- commented form (see 'DefaultConfig') +emptyDefaultConfig :: DefaultConfig +emptyDefaultConfig = DefaultConfig M.empty + +-- | see the 'getDefaultConfig' documentation. +setting :: (Show a) => Setting a -> State Conf () +setting (Setting nameV defaultV) = do + soFar <- get + put $ M.insert nameV (SettingInfo { value = show defaultV, userSet = False }) soFar + +-- | Used in combination with 'setting' to register settings. +-- Registering settings is optional, see 'DefaultConfig'. +-- +-- @ +-- defaultSettings :: DefaultConfig +-- defaultSettings = getDefaultConfig $ do +-- setting \ +-- setting \ +-- @ +getDefaultConfig :: State Conf () -> DefaultConfig +getDefaultConfig actions = do + DefaultConfig $ execState actions M.empty + +-- | Where to look for or store the configuration file. +data FileLocation = AutoFromAppName String + -- ^ Automatically build the location based on the + -- application name. It will be ~\/.\\/config.ini. + | Path FilePath + -- ^ Absolute path to a location on disk. + +getPathForLocation :: FileLocation -> IO FilePath +getPathForLocation location = case location of + AutoFromAppName appName -> getConfigFileName appName + Path path -> return path + +-- | Read settings from disk. +-- Because it is doing file I/O it is smart to wrap the call +-- with a 'try', as I/O exceptions can be thrown. +-- Also, the function will throw a 'ParseException' if the +-- file is not properly formatted. +-- NOTE that if the file is properly formatted in general, +-- but a value is stored in an invalid format (for instance \"hello\" +-- for a Double), you will get no error and get the default value +-- for that setting when you attempt to read it. +-- +-- This function returns a pair. The first element +-- is the configuration itself, which you can use to save +-- back or modify the configuration. +-- The second element is a function wrapped in the 'GetSetting' +-- newtype. This function allows you to read a configuration +-- option simply by giving that option (without that callback +-- you'd have to call getSetting settings \, so +-- the callback lets you save a parameter). +-- +-- Example of use: +-- +-- @ +-- readResult <- try $ readSettings (Path \"my.config\") +-- case readResult of +-- Right (conf, GetSetting getSetting) -> do +-- let textSize = getSetting textSizeFromWidth +-- saveSettings getDefaultConfig (Path \"my.config\") conf +-- Left (x :: SomeException) -> error \"Error reading the config file!\" +-- @ +readSettings :: FileLocation -> IO (Conf, GetSetting) +readSettings location = do + filePath <- getPathForLocation location + exists <- doesFileExist filePath + conf <- if exists + then readConfigFile filePath + else return M.empty + return (conf, GetSetting $ getSetting' conf) + +-- | It is advised to run the save within a try call +-- because it does disk I/O, otherwise the call is straightforward. +saveSettings :: DefaultConfig -> FileLocation -> Conf -> IO () +saveSettings (DefaultConfig defaults) location conf = do + filePath <- getPathForLocation location + writeConfigFile filePath (M.union conf defaults) + +-- TODO maybe another getSetting that'll tell you +-- if the setting is invalid in the config file instead of silently +-- give you the default? +getSetting' :: (Read a) => Conf -> Setting a -> a +getSetting' conf (Setting key defaultV) = fromMaybe defaultV $ getSettingValueFromConf conf key + +getSettingValueFromConf :: Read a => Conf -> String -> Maybe a +getSettingValueFromConf conf key = do + asString <- M.lookup key conf + readMaybe $ value asString + +-- | Change the value of a setting. You'll have to call +-- 'saveSettings' so that the change is written to disk. +setSetting :: (Show a) => Conf -> Setting a -> a -> Conf +setSetting conf (Setting key _) v = M.insert key (SettingInfo { value = show v, userSet=True }) conf + +getSettingsFolder :: String -> IO FilePath +getSettingsFolder appName = do + home <- getHomeDirectory + let result = home ++ "/." ++ appName ++ "/" + createDirectoryIfMissing False result + return result + +getConfigFileName :: String -> IO String +getConfigFileName appName = fmap (++"config.ini") $ getSettingsFolder appName diff --git a/Data/Serialization.hs b/Data/Serialization.hs new file mode 100644 --- /dev/null +++ b/Data/Serialization.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} +module Data.Serialization ( + Conf, + SettingInfo(..), + readConfigFile, + writeConfigFile, + ParseException) where + +import System.IO +import qualified Data.Text.IO as T +import qualified Data.Map as M +import Text.ParserCombinators.Parsec +import Text.Parsec.Text as T +import Control.Monad (unless, when) +import Control.Exception (throwIO, Exception) +import Data.Typeable (Typeable) +import System.Directory (doesFileExist, copyFile) + +data SettingInfo = SettingInfo { value :: String, userSet :: Bool } deriving (Show, Eq) + +-- | The in-memory configuration data. +type Conf = M.Map String SettingInfo + +-- | The configuration file is in an invalid format. +data ParseException = ParseException FilePath String + deriving (Show, Typeable) +instance Exception ParseException + +readConfigFile :: FilePath -> IO Conf +readConfigFile path = do + contents <- T.readFile path + case parse parseConfigFile "" contents of + Left _ -> throwIO $ ParseException path "Invalid configuration file" + Right v -> return v + +data ConfigElement = ConfigEntry String String + | Comment + +isConfigEntry :: ConfigElement -> Bool +isConfigEntry (ConfigEntry _ _) = True +isConfigEntry _ = False + +parseConfigFile :: T.GenParser st Conf +parseConfigFile = do + elements <- many $ parseComment <|> parseConfigEntry + let configEntries = filter isConfigEntry elements + return $ M.fromList $ map (\(ConfigEntry a b) -> + (a, SettingInfo {value=b, userSet=True})) configEntries + +parseComment :: T.GenParser st ConfigElement +parseComment = do + char '#' + many $ noneOf "\r\n" + many $ oneOf "\r\n" + return Comment + +parseConfigEntry :: T.GenParser st ConfigElement +parseConfigEntry = do + key <- many $ noneOf "=\r\n" + char '=' + val <- many $ noneOf "\r\n" + many $ oneOf "\r\n" + return $ ConfigEntry key val + +writeConfigFile :: FilePath -> Conf -> IO () +writeConfigFile path config = do + whenM (doesFileExist path) $ + copyFile path $ path ++ ".bak" + withFile path WriteMode $ \handle -> do + hPutStrLn handle "# This file is autogenerated. You can change, comment and uncomment settings but text comments you may add will be lost." + mapM_ (uncurry $ writeConfigEntry handle) $ M.toList config + where whenM s r = s >>= flip when r + +writeConfigEntry :: Handle -> String -> SettingInfo -> IO () +writeConfigEntry handle key (SettingInfo sValue sUserSet) = do + unless sUserSet $ hPutStr handle "# " + hPutStrLn handle $ key ++ "=" ++ sValue diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Emmanuel Touzery + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Emmanuel Touzery nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app-settings.cabal b/app-settings.cabal new file mode 100644 --- /dev/null +++ b/app-settings.cabal @@ -0,0 +1,46 @@ +-- Initial app-settings.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: app-settings +version: 0.1.0.0 +synopsis: A library to manage application settings (INI file-like) +-- description: +homepage: https://github.com/emmanueltouzery/app-settings +license: BSD3 +license-file: LICENSE +author: Emmanuel Touzery +maintainer: etouzery@gmail.com +-- copyright: +category: Configuration +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Data.AppSettings + other-modules: Data.Serialization + -- other-extensions: + build-depends: base >=4.6 && <4.7, + mtl == 2.1.*, + containers == 0.5.*, + directory == 1.2.*, + text >= 0.10, + parsec == 3.1.* + -- hs-source-dirs: + default-language: Haskell2010 + Ghc-Options: -Wall + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: ., tests + main-is: Tests.hs + default-language: Haskell2010 + build-depends: base, + hspec >= 1.8 && <1.9, + HUnit >= 1.2 && <1.3, + mtl == 2.1.*, + containers == 0.5.*, + directory == 1.2.*, + text >= 0.10, + parsec == 3.1.* + Ghc-Options: -Wall diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +import Data.AppSettings + +import Test.Hspec +import Test.HUnit (assertBool) + +import System.Directory (removeFile, copyFile, doesFileExist) +import Control.Exception (try, SomeException) + +textSizeFromWidth :: Setting Double +textSizeFromWidth = Setting "textSizeFromWidth" 0.04 + +textFill :: Setting (Double,Double,Double,Double) +textFill = Setting "textFill" (1, 1, 0, 1) + +textSizeFromHeight :: Setting Double +textSizeFromHeight = Setting "textSizeFromHeight" 12.4 + +defaultConfig :: DefaultConfig +defaultConfig = getDefaultConfig $ do + setting textSizeFromWidth + setting textSizeFromHeight + setting textFill + +main :: IO () +main = hspec $ do + describe "load config" $ do + testEmptyFileDefaults + testPartialFileDefaults + testFileWithComments + testInvalidFile + testInvalidValue + testNonExistingFile + describe "save config" $ do + testSaveUserSetAndDefaults + createBakBeforeSaving + +testEmptyFileDefaults :: Spec +testEmptyFileDefaults = it "parses correctly an empty file with defaults" $ do + readResult <- try $ readSettings (Path "tests/empty.config") + case readResult of + Right (_, GetSetting getSetting) -> do + getSetting textSizeFromWidth `shouldBe` 0.04 + getSetting textSizeFromHeight `shouldBe` 12.4 + getSetting textFill `shouldBe` (1,1,0,1) + Left (x :: SomeException) -> assertBool (show x) False + +testPartialFileDefaults :: Spec +testPartialFileDefaults = it "parses correctly a partial file with defaults" $ do + readResult <- try $ readSettings (Path "tests/partial.config") + case readResult of + Right (_, GetSetting getSetting) -> do + getSetting textSizeFromWidth `shouldBe` 1.02 + getSetting textSizeFromHeight `shouldBe` 12.4 + getSetting textFill `shouldBe` (1,2,3,4) + Left (x :: SomeException) -> assertBool (show x) False + +testFileWithComments :: Spec +testFileWithComments = it "parses correctly a partial file with comments" $ do + readResult <- try $ readSettings (Path "tests/test-save.txt") + case readResult of + Right (_, GetSetting getSetting) -> do + getSetting textSizeFromWidth `shouldBe` 1.02 + getSetting textSizeFromHeight `shouldBe` 12.4 + getSetting textFill `shouldBe` (1,2,3,4) + Left (x :: SomeException) -> assertBool (show x) False + +testInvalidValue :: Spec +testInvalidValue = it "parses correctly a file with invalid values" $ do + readResult <- try $ readSettings (Path "tests/brokenvalue.config") + case readResult of + Right (_, GetSetting getSetting) -> do + -- give the default for the invalid value + getSetting textSizeFromWidth `shouldBe` 0.04 + getSetting textSizeFromHeight `shouldBe` 12.4 + getSetting textFill `shouldBe` (1,2,3,4) + Left (x :: SomeException) -> assertBool (show x) False + +testNonExistingFile :: Spec +testNonExistingFile = it "returns empty config for a non-existing file" $ do + readResult <- try $ readSettings (Path "tests/dontexist.conf") + case readResult of + Right (_, GetSetting getSetting) -> do + getSetting textSizeFromWidth `shouldBe` 0.04 + getSetting textSizeFromHeight `shouldBe` 12.4 + getSetting textFill `shouldBe` (1,1,0,1) + Left (x :: SomeException) -> assertBool (show x) False + +testInvalidFile :: Spec +testInvalidFile = it "reports errors properly for invalid files" $ do + readResult <- try $ readSettings (Path "tests/broken.config") + case readResult of + Left (_ :: SomeException) -> assertBool "ok" True + Right _ -> assertBool "did not get an error!" False + +testSaveUserSetAndDefaults :: Spec +testSaveUserSetAndDefaults = it "saves a file with user-set and default settings" $ do + readResult <- try $ readSettings (Path "tests/partial.config") + case readResult of + Right (conf, _) -> do + saveSettings defaultConfig (Path "test.txt") conf + actual <- readFile "test.txt" + reference <- readFile "tests/test-save.txt" + actual `shouldBe` reference + removeFile "test.txt" + Left (x :: SomeException) -> assertBool (show x) False + +createBakBeforeSaving :: Spec +createBakBeforeSaving = it "creates a backup of the config file before overwriting it" $ do + readResult <- try $ readSettings (Path "tests/partial.config") + case readResult of + Right (conf, _) -> do + copyFile "tests/partial.config" "p.config" + saveSettings defaultConfig (Path "p.config") conf + doesFileExist "p.config.bak" >>= (flip shouldBe) True + doesFileExist "p.config" >>= (flip shouldBe) True + removeFile "p.config" + removeFile "p.config.bak" + Left (x :: SomeException) -> assertBool (show x) False