aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Data/ConfigManager.hs6
-rw-r--r--Data/ConfigManager/Instances.hs24
-rw-r--r--Data/ConfigManager/Parser/Duration.hs36
-rw-r--r--Data/ConfigManager/Types.hs2
-rw-r--r--Data/ConfigManager/Types/Internal.hs9
-rw-r--r--config-manager.cabal10
-rw-r--r--tests/Test.hs42
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))