diff options
| -rw-r--r-- | Data/ConfigManager.hs | 6 | ||||
| -rw-r--r-- | Data/ConfigManager/Instances.hs | 24 | ||||
| -rw-r--r-- | Data/ConfigManager/Parser/Duration.hs | 36 | ||||
| -rw-r--r-- | Data/ConfigManager/Types.hs | 2 | ||||
| -rw-r--r-- | Data/ConfigManager/Types/Internal.hs | 9 | ||||
| -rw-r--r-- | config-manager.cabal | 10 | ||||
| -rw-r--r-- | tests/Test.hs | 42 |
7 files changed, 121 insertions, 8 deletions
diff --git a/Data/ConfigManager.hs b/Data/ConfigManager.hs index 37da8b6..a13457c 100644 --- a/Data/ConfigManager.hs +++ b/Data/ConfigManager.hs @@ -34,7 +34,6 @@ module Data.ConfigManager ) where import Prelude hiding (lookup) -import Text.Read (readMaybe) import Data.Text (Text) import qualified Data.Text as T @@ -42,6 +41,7 @@ import qualified Data.HashMap.Strict as M import qualified Data.ConfigManager.Reader as R import Data.ConfigManager.Types +import Data.ConfigManager.Instances () -- | Load a 'Config' from a given 'FilePath'. @@ -50,13 +50,13 @@ readConfig = R.readConfig Required -- | Lookup for the value associated to a name. -lookup :: Read a => Name -> Config -> Either Text a +lookup :: Configured a => Name -> Config -> Either Text a lookup name config = case M.lookup name (hashMap config) of Nothing -> Left . T.concat $ ["Value not found for Key ", name] Just value -> - case readMaybe . T.unpack $ value of + case convert value of Nothing -> Left . T.concat $ ["Reading error for key ", name] Just result -> Right result diff --git a/Data/ConfigManager/Instances.hs b/Data/ConfigManager/Instances.hs new file mode 100644 index 0000000..0855117 --- /dev/null +++ b/Data/ConfigManager/Instances.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE IncoherentInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.ConfigManager.Instances + () where + +import qualified Data.Text as T +import Data.Time.Clock (DiffTime, NominalDiffTime) + +import Text.Read (readMaybe) + +import Data.ConfigManager.Types.Internal +import Data.ConfigManager.Parser.Duration (parseDuration) + +instance Configured DiffTime where + convert value = parseDuration value + +instance Configured NominalDiffTime where + convert value = realToFrac <$> parseDuration value + +instance Read a => Configured a where + convert = readMaybe . T.unpack diff --git a/Data/ConfigManager/Parser/Duration.hs b/Data/ConfigManager/Parser/Duration.hs new file mode 100644 index 0000000..f169c55 --- /dev/null +++ b/Data/ConfigManager/Parser/Duration.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.ConfigManager.Parser.Duration + ( parseDuration + ) where + +import Control.Applicative ((<|>)) + +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock (DiffTime) +import qualified Data.Time.Clock as Time + +import Text.Read (readMaybe) + +parseDuration :: Text -> Maybe DiffTime +parseDuration input = + case T.splitOn " " input of + [count, unit] -> do + n <- readMaybe . T.unpack $ count + let matchDuration singularUnit pluralUnit seconds = + if ((n == 0 || n == 1) && unit == singularUnit) || (n > 1 && unit == pluralUnit) + then Just . Time.secondsToDiffTime $ n * seconds + else Nothing + (matchDuration "second" "seconds" second) + <|> (matchDuration "minute" "minutes" minute) + <|> (matchDuration "hour" "hours" hour) + <|> (matchDuration "day" "days" day) + <|> (matchDuration "week" "weeks" week) + _ -> Nothing + where + second = 1 + minute = 60 * second + hour = 60 * minute + day = 24 * hour + week = 7 * day diff --git a/Data/ConfigManager/Types.hs b/Data/ConfigManager/Types.hs index ea2691f..8939713 100644 --- a/Data/ConfigManager/Types.hs +++ b/Data/ConfigManager/Types.hs @@ -12,6 +12,8 @@ module Data.ConfigManager.Types , Name , Value , Requirement(..) + , Configured + , convert ) where import Data.ConfigManager.Types.Internal diff --git a/Data/ConfigManager/Types/Internal.hs b/Data/ConfigManager/Types/Internal.hs index c4d5d0e..4459b01 100644 --- a/Data/ConfigManager/Types/Internal.hs +++ b/Data/ConfigManager/Types/Internal.hs @@ -4,10 +4,11 @@ module Data.ConfigManager.Types.Internal , Name , Value , Requirement(..) + , Configured + , convert ) where import Data.Text (Text) - import Data.HashMap.Strict -- | Configuration data. @@ -37,3 +38,9 @@ data Requirement = Required | Optional deriving (Eq, Read, Show) + +-- | This class represents types that can be converted /from/ a value /to/ a +-- destination type + +class Configured a where + convert :: Value -> Maybe a diff --git a/config-manager.cabal b/config-manager.cabal index 99d5b1b..2104e4f 100644 --- a/config-manager.cabal +++ b/config-manager.cabal @@ -1,5 +1,5 @@ name: config-manager -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Configuration management description: A configuration management library which supports: @@ -29,13 +29,16 @@ library Data.ConfigManager.Types other-modules: Data.ConfigManager.Reader Data.ConfigManager.Parser + Data.ConfigManager.Instances Data.ConfigManager.Types.Internal + Data.ConfigManager.Parser.Duration ghc-options: -Wall -Werror build-depends: base < 5, text, unordered-containers, parsec, - filepath + filepath, + time default-language: Haskell2010 source-repository head @@ -55,5 +58,6 @@ Test-Suite test-config-manager test-framework-hunit, temporary, directory, - unordered-containers + unordered-containers, + time default-language: Haskell2010 diff --git a/tests/Test.hs b/tests/Test.hs index 641e1e6..3956236 100644 --- a/tests/Test.hs +++ b/tests/Test.hs @@ -18,6 +18,8 @@ import Test.HUnit hiding (Test) import Data.ConfigManager import Data.ConfigManager.Types (Config(..)) import qualified Data.Text as T +import Data.Time.Clock (DiffTime) +import qualified Data.Time.Clock as Time import Helper (forceGetConfig, getConfig, eitherToMaybe) @@ -32,6 +34,7 @@ tests = , testCase "value" valueAssertion , testCase "skip" skipAssertion , testCase "import" importAssertion + , testCase "duration" durationAssertion ] bindingAssertion :: Assertion @@ -41,7 +44,7 @@ bindingAssertion = do oneBinding <- forceGetConfig "x = \"foo\"" assertEqual "one binding present" (Right "foo") (lookup "x" oneBinding) - assertBool "one binding missing" (isLeft $ (lookup "y" oneBinding :: Either Text Int)) + assertBool "one binding missing" (isLeft (lookup "y" oneBinding :: Either Text Int)) assertEqual "one binding count" 1 (M.size . hashMap $ oneBinding) multipleBindings <- forceGetConfig $ T.unlines @@ -133,3 +136,40 @@ importAssertion = do , "x = 4" ] assertEqual "missing optional config" (Right 4) (lookup "x" missingOptionalConfig) + +durationAssertion :: Assertion +durationAssertion = do + config <- forceGetConfig $ T.unlines + [ "a = 1 second" + , "b = 5 seconds" + , "c = 1 minute" + , "d = 10 minutes" + , "e = 1 hour" + , "f = 7 hours" + , "g = 1 day" + , "h = 2 days" + , "i = 1 week" + , "j = 9 weeks" + , "" + , "k = 1 minutes" + , "l = 20 weeks" + ] + + let second = 1 + let minute = 60 * second + let hour = 60 * minute + let day = 24 * hour + let week = 7 * day + + assertEqual "a" (Right (Time.secondsToDiffTime $ 1 * second)) (lookup "a" config) + assertEqual "b" (Right (Time.secondsToDiffTime $ 5 * second)) (lookup "b" config) + assertEqual "c" (Right (Time.secondsToDiffTime $ 1 * minute)) (lookup "c" config) + assertEqual "d" (Right (Time.secondsToDiffTime $ 10 * minute)) (lookup "d" config) + assertEqual "e" (Right (Time.secondsToDiffTime $ 1 * hour)) (lookup "e" config) + assertEqual "f" (Right (Time.secondsToDiffTime $ 7 * hour)) (lookup "f" config) + assertEqual "g" (Right (Time.secondsToDiffTime $ 1 * day)) (lookup "g" config) + assertEqual "h" (Right (Time.secondsToDiffTime $ 2 * day)) (lookup "h" config) + assertEqual "i" (Right (Time.secondsToDiffTime $ 1 * week)) (lookup "i" config) + assertEqual "j" (Right (Time.secondsToDiffTime $ 9 * week)) (lookup "j" config) + assertBool "k" (isLeft (lookup "k" config :: Either Text DiffTime)) + assertBool "l" (isLeft (lookup "l" config :: Either Text DiffTime)) |