diff --git a/salak.cabal b/salak.cabal --- a/salak.cabal +++ b/salak.cabal @@ -2,17 +2,17 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 0f2d8453e74e53a24b06a57047e8a2cbff0554c3d8008c00c80746a3715498f6 +-- hash: 5c22b23921e52c02d6bfc91c02e5cd2945f51b95d388cd2e07e992173557b53e name: salak -version: 0.1.0 -synopsis: Configuration -description: Configuration +version: 0.1.1 +synopsis: Configuration Loader +description: Configuration Loader for Production in Haskell category: Library homepage: https://github.com/leptonyu/salak#readme author: Daniel YU -maintainer: Daniel YU <leptonyu@gmail.com> -copyright: (c) Daniel YU +maintainer: Daniel YU +copyright: (c) 2018 Daniel YU license: BSD3 license-file: LICENSE build-type: Simple @@ -24,7 +24,7 @@ exposed-modules: Data.Salak other-modules: - Data.Salak.Property + Data.Salak.Types Data.Salak.Environment Data.Salak.CommandLine Data.Salak.Aeson @@ -34,7 +34,6 @@ build-depends: aeson , base >=4.7 && <5 - , bytestring , directory , filepath , scientific @@ -54,7 +53,6 @@ build-depends: aeson , base >=4.7 && <5 - , bytestring , directory , filepath , scientific @@ -73,7 +71,7 @@ Data.Salak.Aeson Data.Salak.CommandLine Data.Salak.Environment - Data.Salak.Property + Data.Salak.Types Data.Salak.Yaml Paths_salak hs-source-dirs: @@ -83,7 +81,6 @@ QuickCheck , aeson , base >=4.7 && <5 - , bytestring , directory , filepath , hspec ==2.* diff --git a/src/Data/Salak.hs b/src/Data/Salak.hs --- a/src/Data/Salak.hs +++ b/src/Data/Salak.hs @@ -1,23 +1,40 @@ {-# LANGUAGE NoImplicitPrelude #-} - +-- | +-- Module: Data.Salak +-- Copyright: (c) 2018 Daniel YU +-- License: BSD3 +-- Maintainer: Daniel YU +-- Stability: experimental +-- Portability: portable +-- +-- Configuration Loader for Production in Haskell. +-- module Data.Salak( - Property(..) + -- * How to use this library + -- $use + + -- * Properties Loader + defaultProperties + , ParseCommandLine + , defaultProperties' + , defaultPropertiesWithFile + , empty + -- * Lookup Properties + , lookup + , toKeys + -- * Types + , Property(..) , Properties(..) , Key + , FromProperties(..) , Return(..) + -- * Properties Loader Helper , insert - , toKeys - , empty - , lookup , makePropertiesFromEnvironment , defaultParseCommandLine , makePropertiesFromCommandLine - , ParseCommandLine , makePropertiesFromJson , makePropertiesFromYaml - , defaultProperties - , defaultProperties' - , defaultPropertiesWithFile , FileName ) where @@ -25,23 +42,38 @@ import Data.Salak.Aeson import Data.Salak.CommandLine import Data.Salak.Environment -import Data.Salak.Property +import Data.Salak.Types import Data.Salak.Yaml import Prelude hiding (empty, lookup) import System.Directory import System.FilePath (()) +-- | Initialize default properties from `CommandLine` and `Environment`. +-- `CommandLine` use default parser. defaultProperties :: IO Properties defaultProperties = defaultProperties' defaultParseCommandLine +-- | Initialize default properties from `CommandLine` and `Environment`. defaultProperties' :: ParseCommandLine -> IO Properties defaultProperties' dpc = makePropertiesFromCommandLine dpc empty >>= makePropertiesFromEnvironment +-- | Yaml file name. type FileName = String -defaultPropertiesWithFile :: FileName -> IO Properties +-- | Initialize default properties from `CommandLine`, `Environment` and `Yaml` files. +-- All these configuration sources has orders, from highest order to lowest order: +-- +-- > 1. CommandLine +-- > 2. Environment +-- > 3. Specified Yaml file(file in "salak.config.dir") +-- > 4. Yaml file in current directory +-- > 5. Yaml file in home directory +-- +defaultPropertiesWithFile + :: FileName -- ^ specify default config file name, can reset by config "salak.config.name" from `CommandLine` or `Environment`. + -> IO Properties defaultPropertiesWithFile name = do p <- defaultProperties let n = fromMaybe name $ (lookup "salak.config.name" p :: Maybe String) @@ -57,3 +89,37 @@ if b then makePropertiesFromYaml f p' else if ok then return p' else error $ "File " ++ f ++ " not found" + + +-- $use +-- +-- | This library default a standard configuration load process. It can load properties from `CommandLine`, `Environment`, +-- `JSON value` and `Yaml` files. They all load to the same format `Properties`. Earler property source has higher order +-- to load property. For example: +-- +-- > CommandLine: --package.a.enabled=true +-- > Environment: PACKAGE_A_ENABLED: false +-- +-- > lookup "package.a.enabled" properties => Just True +-- +-- `CommandLine` has higher order then `Environment`, for the former load properties earler then later. +-- +-- Usage: +-- +-- > data Config = Config +-- > { name :: Text +-- > , dir :: Maybe Text +-- > , ext :: Int +-- > } deriving (Eq, Show) +-- > +-- > instance FromJSON Config where +-- > parseJSON = withObject "Config" $ \v -> Config +-- > <$> v .: "name" +-- > <*> v .:? "dir" +-- > <*> (fromMaybe 1 <$> v .:? "ext") +-- +-- > main = do +-- > p <- defaultPropertiesWithFile "salak.yml" +-- > let Just config = lookup "salak.config" p :: Maybe Config +-- > print config + diff --git a/src/Data/Salak/Aeson.hs b/src/Data/Salak/Aeson.hs --- a/src/Data/Salak/Aeson.hs +++ b/src/Data/Salak/Aeson.hs @@ -8,18 +8,19 @@ import Data.Char import qualified Data.HashMap.Strict as M import Data.Maybe -import Data.Salak.Property +import Data.Salak.Types import Data.Text (pack, unpack) import Data.Vector (fromList, toList) +-- | Load `Properties` from JSON `Value` makePropertiesFromJson :: Value -> Properties -> Properties makePropertiesFromJson Null p = p makePropertiesFromJson (Bool b) p = insert [] (PBool b) p makePropertiesFromJson (Number n) p = insert [] (PNum n) p makePropertiesFromJson (String s) p = insert [] (PStr $ unpack s) p -makePropertiesFromJson (Array v) (Node ps ms) = let (nps,nms) = fromArray v in Node (ps++nps) (ms++nms) -makePropertiesFromJson (Object o) (Node ps []) = Node ps [M.map jsonToProperties o] -makePropertiesFromJson (Object o) (Node ps [m]) = Node ps [m `M.union` M.map jsonToProperties o] +makePropertiesFromJson (Array v) (Properties ps ms) = let (nps,nms) = fromArray v in Properties (ps++nps) (ms++nms) +makePropertiesFromJson (Object o) (Properties ps []) = Properties ps [M.map jsonToProperties o] +makePropertiesFromJson (Object o) (Properties ps [m]) = Properties ps [m `M.union` M.map jsonToProperties o] makePropertiesFromJson (Object o) p = p jsonToProperties :: Value -> Properties @@ -27,19 +28,19 @@ fromArray v = foldl g3 ([],[]) $ go . jsonToProperties <$> toList v where - go (Node ps ms) = (g2 ps,g2 ms) + go (Properties ps ms) = (g2 ps,g2 ms) g2 [] = [] g2 (a:_) = [a] g3 (as,bs) (a,b) = (as++a,bs++b) instance FromProperties Value where - fromProperties (Node [] []) = Empty - fromProperties (Node [PBool p] []) = OK $ Bool p - fromProperties (Node [PNum p] []) = OK $ Number p - fromProperties (Node [PStr p] []) = OK $ String $ pack p - fromProperties (Node ps []) = OK $ Array $ fromList $ mapReturn (fromProperties.(\p-> Node [p] [])) ps - fromProperties (Node _ [m]) = OK $ Object $ M.map (fromReturn Null . fromProperties) m - fromProperties (Node _ ms) = OK $ Array $ fromList $ mapReturn (fromProperties.(\m-> Node [] [m])) ms + fromProperties (Properties [] []) = Empty + fromProperties (Properties [PBool p] []) = OK $ Bool p + fromProperties (Properties [PNum p] []) = OK $ Number p + fromProperties (Properties [PStr p] []) = OK $ String $ pack p + fromProperties (Properties ps []) = OK $ Array $ fromList $ mapReturn (fromProperties.(\p-> Properties [p] [])) ps + fromProperties (Properties _ [m]) = OK $ Object $ M.map (fromReturn Null . fromProperties) m + fromProperties (Properties _ ms) = OK $ Array $ fromList $ mapReturn (fromProperties.(\m-> Properties [] [m])) ms instance {-# OVERLAPPABLE #-} FromJSON a => FromProperties a where fromProperties a = do diff --git a/src/Data/Salak/CommandLine.hs b/src/Data/Salak/CommandLine.hs --- a/src/Data/Salak/CommandLine.hs +++ b/src/Data/Salak/CommandLine.hs @@ -2,11 +2,21 @@ import Data.Char import Data.Maybe -import Data.Salak.Property +import Data.Salak.Types import System.Environment +-- | CommandLine parser. Parse command line into property key values. type ParseCommandLine = [String] -> IO [(String,Property)] +-- | Default command line parsers. +-- Use format: +-- +-- > --KEY=VALUE +-- +-- For example: +-- +-- > --salak.config.name=test.yml => ("salak.config.name", PStr "test.yml") +-- defaultParseCommandLine :: ParseCommandLine defaultParseCommandLine = return . mapMaybe go where @@ -15,6 +25,7 @@ _ -> Nothing go _ = Nothing +-- | Load `Properties` from 'CommandLine' makePropertiesFromCommandLine :: ParseCommandLine -> Properties -> IO Properties makePropertiesFromCommandLine parser p = getArgs >>= (\a -> makePropertiesFromCommandLine' a parser p) diff --git a/src/Data/Salak/Environment.hs b/src/Data/Salak/Environment.hs --- a/src/Data/Salak/Environment.hs +++ b/src/Data/Salak/Environment.hs @@ -1,9 +1,10 @@ module Data.Salak.Environment where import Data.Char -import Data.Salak.Property +import Data.Salak.Types import System.Environment +-- | Load `Properties` from 'Environment' makePropertiesFromEnvironment :: Properties -> IO Properties makePropertiesFromEnvironment p = getEnvironment >>= (\v -> return $ makePropertiesFromEnvironment' v p) diff --git a/src/Data/Salak/Property.hs b/src/Data/Salak/Property.hs deleted file mode 100644 --- a/src/Data/Salak/Property.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} -module Data.Salak.Property where - -import Control.Monad ((>=>)) -import Data.Char -import qualified Data.HashMap.Strict as M -import Data.Int -import Data.List.Split -import Data.Maybe -import Data.Scientific -import Data.Text (Text, pack, unpack) -import Data.Word -import Foreign.C.Types -import Text.Read - -type Key = Text - -data Properties - = Node [Property] [M.HashMap Key Properties] - deriving (Eq) - -instance Show Properties where - show = unlines . go "" - where - go p (Node ps ms) = fmap (g2 p) ps ++ concat (fmap (g3 p) ms) - g2 p (PNum n) = p ++ "=" ++ show n - g2 p (PStr n) = p ++ "=" ++ n - g2 p (PBool n) = p ++ "=" ++ show n - g3 :: String -> M.HashMap Key Properties -> [String] - g3 p m = concat $ fmap (g4 p) $ M.toList m - g4 "" (p2,ps) = go (unpack p2) ps - g4 p (p2,ps) = go (p ++ "." ++ unpack p2) ps - -data Property - = PNum Scientific - | PStr String - | PBool Bool - deriving (Eq, Show) - -empty :: Properties -empty = Node [] [] - -toKeys :: String -> [Key] -toKeys = fmap pack . filter (not.null) . splitOneOf "." - -insert :: [Key] -> Property -> Properties -> Properties -insert [] p (Node [] m) = Node [p] m -insert [] _ (Node ps m) = Node ps m -insert (a:as) p (Node ps []) = Node ps [M.insert a (insert as p empty) M.empty] -insert (a:as) p (Node ps ms) = Node ps $ go a as p <$> ms - where - go a as p m = case M.lookup a m of - Just n -> M.insert a (insert as p n) m - Nothing -> M.insert a (insert as p empty) m - -lookup :: FromProperties a => String -> Properties -> Maybe a -lookup = go . toKeys - where - go [] p = from $ fromProperties p - go (a:as) (Node _ [m]) = case M.lookup a m of - Just n -> go as n - Nothing -> Nothing - go (a:as) _ = Nothing - -makeProperties :: [(String, Property)] -> Properties -> Properties -makeProperties ps m = foldl go m ps - where - go m (k,v) = insert (toKeys k) v m - -data Return a - = Empty - | OK a - | Fail String - deriving Show - -instance Functor Return where - fmap f (OK a) = OK (f a) - fmap _ Empty = Empty - fmap _ (Fail b) = Fail b - -instance Applicative Return where - pure = OK - (OK f) <*> (OK a) = OK (f a) - (Fail x) <*> (Fail y) = Fail $ x ++ ";" ++ y - (Fail x) <*> _ = Fail x - _ <*> (Fail y) = Fail y - _ <*> _ = Empty - -instance Monad Return where - (OK a) >>= f = f a - Empty >>= _ = Empty - (Fail b) >>= _ = Fail b - -fromReturn :: b -> Return b -> b -fromReturn _ (OK a) = a -fromReturn a _ = a - -mapReturn :: (a -> Return b) -> [a] -> [b] -mapReturn f as = go $ fmap f as - where - go [] = [] - go (OK a:as) = a : go as - go (_:as) = go as - -class FromProperties a where - fromProperties :: Properties -> Return a - -instance FromProperties Property where - fromProperties (Node (a:_) _) = OK a - fromProperties _ = Empty - -instance {-# OVERLAPPABLE #-} FromProperties a => FromProperties [a] where - fromProperties (Node ps ms) = - let ns = fmap (\p -> Node [p] []) ps ++ fmap (\m -> Node [] [m]) ms - in OK $ mapReturn fromProperties ns - -instance FromProperties Scientific where - fromProperties = fromProperties >=> go - where - go (PNum a) = OK a - go (PStr a) = to readMaybe a - go _ = Empty - -instance FromProperties String where - fromProperties = fromProperties >=> go - where - go (PStr a) = OK a - go (PNum a) = OK $ show a - go (PBool a) = OK $ toLower <$> show a - -instance FromProperties Text where - fromProperties a = pack <$> fromProperties a - -instance FromProperties Float where - fromProperties a = toRealFloat <$> fromProperties a - -instance FromProperties Double where - fromProperties a = toRealFloat <$> fromProperties a - -instance FromProperties Int where - fromProperties = fromProperties >=> to toBoundedInteger - -instance FromProperties Int8 where - fromProperties = fromProperties >=> to toBoundedInteger - -instance FromProperties Int16 where - fromProperties = fromProperties >=> to toBoundedInteger - -instance FromProperties Int32 where - fromProperties = fromProperties >=> to toBoundedInteger - -instance FromProperties Int64 where - fromProperties = fromProperties >=> to toBoundedInteger - -instance FromProperties Word where - fromProperties = fromProperties >=> to toBoundedInteger - -instance FromProperties Word8 where - fromProperties = fromProperties >=> to toBoundedInteger - -instance FromProperties Word16 where - fromProperties = fromProperties >=> to toBoundedInteger - -instance FromProperties Word32 where - fromProperties = fromProperties >=> to toBoundedInteger - -instance FromProperties Word64 where - fromProperties = fromProperties >=> to toBoundedInteger - -to :: (b -> Maybe a) -> b -> Return a -to v a = case v a of - Just a -> OK a - Nothing -> Fail "number convert failed" - -from :: Return a -> Maybe a -from (OK a) = Just a -from Empty = Nothing -from (Fail e) = error e - -instance FromProperties Bool where - fromProperties = fromProperties >=> go - where - go (PBool a) = OK a - go (PStr a) = g2 $ fmap toLower a - go _ = Fail "number cannot convert to bool" - g2 "true" = OK True - g2 "false" = OK False - g2 _ = Empty - -instance FromProperties Char where - fromProperties = fromProperties >=> go - where - go (PStr (a:_)) = OK a - go _ = Fail "cannot convert to char" - -instance FromProperties CTime where - fromProperties a = CTime <$> fromProperties a - diff --git a/src/Data/Salak/Types.hs b/src/Data/Salak/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Salak/Types.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Data.Salak.Types where + +import Control.Monad ((>=>)) +import Data.Char +import qualified Data.HashMap.Strict as M +import Data.Int +import Data.List.Split +import Data.Maybe +import Data.Scientific +import Data.Text (Text, pack, unpack) +import Data.Word +import Foreign.C.Types +import Text.Read + +-- | Property key +type Key = Text + +-- | A Property value represented as a Haskell value. +data Property + = PNum !Scientific -- ^ Numeric Property + | PStr !String -- ^ String Property + | PBool !Bool -- ^ Bool Property + deriving (Eq, Show) + +-- | A Property Container to hold all properties +data Properties + = Properties [Property] [M.HashMap Key Properties] + deriving (Eq) + +instance Show Properties where + show = unlines . go "" + where + {-# INLINE go #-} + {-# INLINE g2 #-} + {-# INLINE g3 #-} + {-# INLINE g4 #-} + go p (Properties ps ms) = fmap (g2 p) ps ++ concat (fmap (g3 p) ms) + g2 p (PNum n) = p ++ "=" ++ show n + g2 p (PStr n) = p ++ "=" ++ n + g2 p (PBool n) = p ++ "=" ++ show n + g3 :: String -> M.HashMap Key Properties -> [String] + g3 p m = concat $ fmap (g4 p) $ M.toList m + g4 "" (p2,ps) = go (unpack p2) ps + g4 p (p2,ps) = go (p ++ "." ++ unpack p2) ps + +-- | The empty `Properties` +empty :: Properties +empty = Properties [] [] + +-- | Split origin key by '.' to sub keys: +-- +-- > "salak.config.name" -> ["salak","config","name"] +-- > "" -> [] +-- > "a..b" -> ["a","b"] +-- +toKeys :: String -> [Key] +toKeys = fmap pack . filter (not.null) . splitOneOf "." + +-- | Insert simple `Property` into `Properties` by `Key`. +-- If the key already have values then the new property will discard. +insert :: [Key] -> Property -> Properties -> Properties +insert [] p (Properties [] m) = Properties [p] m +insert [] _ (Properties ps m) = Properties ps m +insert (a:as) p (Properties ps []) = Properties ps [M.insert a (insert as p empty) M.empty] +insert (a:as) p (Properties ps ms) = Properties ps $ go a as p <$> ms + where + go a as p m = case M.lookup a m of + Just n -> M.insert a (insert as p n) m + Nothing -> M.insert a (insert as p empty) m + +-- | Find `Properties` by key and convert to specific Haskell value. +-- Return `Nothing` means not found, and throw `ErrorCall` means convert failed. +lookup :: FromProperties a => String -> Properties -> Maybe a +lookup = go . toKeys + where + go [] p = from $ fromProperties p + go (a:as) (Properties _ [m]) = case M.lookup a m of + Just n -> go as n + Nothing -> Nothing + go (a:as) _ = Nothing + +-- | Insert batch properties to `Properties` +makeProperties :: [(String, Property)] -> Properties -> Properties +makeProperties ps m = foldl go m ps + where + go m (k,v) = insert (toKeys k) v m + +-- | Return of `FromProperties` +data Return a + = Empty + | OK a + | Fail String + deriving Show + +instance Functor Return where + fmap f (OK a) = OK (f a) + fmap _ Empty = Empty + fmap _ (Fail b) = Fail b + +instance Applicative Return where + pure = OK + (OK f) <*> (OK a) = OK (f a) + (Fail x) <*> (Fail y) = Fail $ x ++ ";" ++ y + (Fail x) <*> _ = Fail x + _ <*> (Fail y) = Fail y + _ <*> _ = Empty + +instance Monad Return where + (OK a) >>= f = f a + Empty >>= _ = Empty + (Fail b) >>= _ = Fail b + +fromReturn :: b -> Return b -> b +fromReturn _ (OK a) = a +fromReturn a _ = a + +mapReturn :: (a -> Return b) -> [a] -> [b] +mapReturn f as = go $ fmap f as + where + go [] = [] + go (OK a:as) = a : go as + go (_:as) = go as + +-- | Convert `Properties` to Haskell value. +class FromProperties a where + fromProperties :: Properties -> Return a + +instance FromProperties Property where + fromProperties (Properties (a:_) _) = OK a + fromProperties _ = Empty + +instance {-# OVERLAPPABLE #-} FromProperties a => FromProperties [a] where + fromProperties (Properties ps ms) = + let ns = fmap (\p -> Properties [p] []) ps ++ fmap (\m -> Properties [] [m]) ms + in OK $ mapReturn fromProperties ns + +instance FromProperties Scientific where + fromProperties = fromProperties >=> go + where + go (PNum a) = OK a + go (PStr a) = to readMaybe a + go _ = Empty + +instance FromProperties String where + fromProperties = fromProperties >=> go + where + go (PStr a) = OK a + go (PNum a) = OK $ show a + go (PBool a) = OK $ toLower <$> show a + +instance FromProperties Text where + fromProperties a = pack <$> fromProperties a + +instance FromProperties Float where + fromProperties a = toRealFloat <$> fromProperties a + +instance FromProperties Double where + fromProperties a = toRealFloat <$> fromProperties a + +instance FromProperties Int where + fromProperties = fromProperties >=> to toBoundedInteger + +instance FromProperties Int8 where + fromProperties = fromProperties >=> to toBoundedInteger + +instance FromProperties Int16 where + fromProperties = fromProperties >=> to toBoundedInteger + +instance FromProperties Int32 where + fromProperties = fromProperties >=> to toBoundedInteger + +instance FromProperties Int64 where + fromProperties = fromProperties >=> to toBoundedInteger + +instance FromProperties Word where + fromProperties = fromProperties >=> to toBoundedInteger + +instance FromProperties Word8 where + fromProperties = fromProperties >=> to toBoundedInteger + +instance FromProperties Word16 where + fromProperties = fromProperties >=> to toBoundedInteger + +instance FromProperties Word32 where + fromProperties = fromProperties >=> to toBoundedInteger + +instance FromProperties Word64 where + fromProperties = fromProperties >=> to toBoundedInteger + +to :: (b -> Maybe a) -> b -> Return a +to v a = case v a of + Just a -> OK a + Nothing -> Fail "number convert failed" + +from :: Return a -> Maybe a +from (OK a) = Just a +from Empty = Nothing +from (Fail e) = error e + +instance FromProperties Bool where + fromProperties = fromProperties >=> go + where + go (PBool a) = OK a + go (PStr a) = g2 $ fmap toLower a + go _ = Fail "number cannot convert to bool" + g2 "true" = OK True + g2 "false" = OK False + g2 _ = Empty + +instance FromProperties Char where + fromProperties = fromProperties >=> go + where + go (PStr (a:_)) = OK a + go _ = Fail "cannot convert to char" + +instance FromProperties CTime where + fromProperties a = CTime <$> fromProperties a + diff --git a/src/Data/Salak/Yaml.hs b/src/Data/Salak/Yaml.hs --- a/src/Data/Salak/Yaml.hs +++ b/src/Data/Salak/Yaml.hs @@ -1,9 +1,10 @@ module Data.Salak.Yaml where import Data.Salak.Aeson -import Data.Salak.Property +import Data.Salak.Types import Data.Yaml +-- | Load `Properties` from `Yaml` file. makePropertiesFromYaml :: FilePath -> Properties -> IO Properties makePropertiesFromYaml file p = do v <- decodeFileThrow file