diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Main where - -main :: IO () -main = do - putStrLn "hello world" diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # salak -[![Hackage](https://img.shields.io/badge/hackage-v0.1.2-orange.svg)](https://hackage.haskell.org/package/salak) +[![Hackage](https://img.shields.io/badge/hackage-v0.1.3-orange.svg)](https://hackage.haskell.org/package/salak) Configuration Loader for Production in Haskell. diff --git a/salak.cabal b/salak.cabal --- a/salak.cabal +++ b/salak.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 82f2482ba7f49ee8ad36d437e333c17b1bbfe849d8d94af64aeb66a611d3a71c +-- hash: 23ec79db8365c6f1dee0d024ad785c8e8a99b04bfa21907880d9474e7c0d003b name: salak -version: 0.1.2 +version: 0.1.3 synopsis: Configuration Loader description: Configuration Loader for Production in Haskell category: Library @@ -31,38 +31,19 @@ Data.Salak.Yaml hs-source-dirs: src + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-orphans -fno-warn-missing-signatures build-depends: aeson , base >=4.7 && <5 , directory , filepath , scientific - , split , text , unordered-containers , vector , yaml default-language: Haskell2010 -executable salak - main-is: Main.hs - other-modules: - Paths_salak - hs-source-dirs: - ./. - build-depends: - aeson - , base >=4.7 && <5 - , directory - , filepath - , scientific - , split - , text - , unordered-containers - , vector - , yaml - default-language: Haskell2010 - test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs @@ -77,15 +58,17 @@ hs-source-dirs: test src + ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-orphans -fno-warn-missing-signatures build-depends: QuickCheck , aeson + , aeson-pretty , base >=4.7 && <5 + , bytestring , directory , filepath , hspec ==2.* , scientific - , split , text , unordered-containers , vector diff --git a/src/Data/Salak.hs b/src/Data/Salak.hs --- a/src/Data/Salak.hs +++ b/src/Data/Salak.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} -- | -- Module: Data.Salak -- Copyright: (c) 2018 Daniel YU @@ -21,6 +22,7 @@ , empty -- * Lookup Properties , lookup + , lookup' , toKeys -- * Types , Property(..) @@ -44,7 +46,8 @@ import Data.Salak.Environment import Data.Salak.Types import Data.Salak.Yaml -import Prelude hiding (empty, lookup) +import Data.Text (Text, unpack) +import Prelude hiding (lookup) import System.Directory import System.FilePath (()) @@ -60,7 +63,7 @@ >>= makePropertiesFromEnvironment -- | Yaml file name. -type FileName = String +type FileName = Text -- | Initialize default properties from `CommandLine`, `Environment` and `Yaml` files. -- All these configuration sources has orders, from highest order to lowest order: @@ -74,22 +77,36 @@ 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) +defaultPropertiesWithFile name = defaultPropertiesWithFile' name defaultParseCommandLine + +-- | 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`. + -> ParseCommandLine -- ^ parser for command line + -> IO Properties +defaultPropertiesWithFile' name dpc = do + p <- defaultProperties' dpc + let n = fromMaybe name $ lookup "salak.config.name" p p' = insert (toKeys "salak.config.name") (PStr n) p c <- getCurrentDirectory h <- getHomeDirectory - foldl (go n) (return p') $ [(lookup "salak.config.dir" p, False), (Just c, True), (Just h, True)] + foldl (go n) (return p') [(lookup "salak.config.dir" p, False), (Just c, True), (Just h, True)] where - go _ p (Nothing, _) = p - go name p (Just d, ok) = let f = d name in do + go _ p (Nothing, _) = p + go n p (Just d, ok) = let f = d unpack n in do p' <- p b <- doesFileExist f if b then makePropertiesFromYaml f p' else if ok then return p' else error $ "File " ++ f ++ " not found" - -- $use -- 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 @@ -5,11 +5,8 @@ module Data.Salak.Aeson where import Data.Aeson -import Data.Char import qualified Data.HashMap.Strict as M -import Data.Maybe import Data.Salak.Types -import Data.Text (pack, unpack) import Data.Vector (fromList, toList) -- | Load `Properties` from JSON `Value` @@ -17,11 +14,11 @@ 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 (String s) p = insert [] (PStr s) p 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 +makePropertiesFromJson (Object _) p = p jsonToProperties :: Value -> Properties jsonToProperties = (`makePropertiesFromJson` empty) @@ -35,12 +32,12 @@ instance FromProperties Value where fromProperties (Properties [] []) = Empty - fromProperties (Properties [PBool p] []) = OK $ Bool p + 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 [PStr p] []) = OK $ String p + fromProperties (Properties ps []) = Array . fromList <$> traverse (fromProperties.singleton) ps fromProperties (Properties _ [m]) = OK $ Object $ M.map (fromReturn Null . fromProperties) m - fromProperties (Properties _ ms) = OK $ Array $ fromList $ mapReturn (fromProperties.(\m-> Properties [] [m])) ms + fromProperties (Properties _ ms) = Array . fromList <$> traverse (fromProperties.singletonMap) 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 @@ -1,8 +1,8 @@ module Data.Salak.CommandLine where -import Data.Char import Data.Maybe import Data.Salak.Types +import Data.Text (pack) import System.Environment -- | CommandLine parser. Parse command line into property key values. @@ -21,7 +21,7 @@ defaultParseCommandLine = return . mapMaybe go where go ('-':'-':as) = case break (=='=') as of - (a,'=':b) -> Just (a,PStr b) + (a,'=':b) -> Just (a,PStr $ pack b) _ -> Nothing go _ = Nothing @@ -32,4 +32,4 @@ makePropertiesFromCommandLine' :: [String] -> ParseCommandLine -> Properties -> IO Properties makePropertiesFromCommandLine' args parser p = do v <- parser args - return $ makeProperties v p + return $ makeProperties (fmap (\(a,b) -> (pack a,b)) v) 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 @@ -2,6 +2,7 @@ import Data.Char import Data.Salak.Types +import Data.Text (pack) import System.Environment -- | Load `Properties` from 'Environment' @@ -12,6 +13,6 @@ makePropertiesFromEnvironment' :: [(String,String)] -> Properties -> Properties makePropertiesFromEnvironment' vs = makeProperties $ go <$> vs where - go (k,v) = (fmap g2 k,PStr v) + go (k,v) = (pack $ fmap g2 k,PStr $ pack v) g2 '_' = '.' g2 a = toLower a diff --git a/src/Data/Salak/Types.hs b/src/Data/Salak/Types.hs --- a/src/Data/Salak/Types.hs +++ b/src/Data/Salak/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -8,12 +9,12 @@ 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.String +import Data.Text (Text) +import qualified Data.Text as T import Data.Word -import Foreign.C.Types import Text.Read -- | Property key @@ -22,70 +23,97 @@ -- | A Property value represented as a Haskell value. data Property = PNum !Scientific -- ^ Numeric Property - | PStr !String -- ^ String Property + | PStr !Text -- ^ String Property | PBool !Bool -- ^ Bool Property - deriving (Eq, Show) + deriving Eq +instance Show Property where + {-# INLINE show #-} + show (PNum n) = show n + show (PStr n) = T.unpack n + show (PBool n) = toLower <$> show n + +instance IsString Property where + fromString = PStr . T.pack + -- | A Property Container to hold all properties data Properties = Properties [Property] [M.HashMap Key Properties] deriving (Eq) instance Show Properties where + {-# INLINE show #-} 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 + {-# INLINE convert #-} + go p (Properties ps ms) = convert p g2 ps ++ concat (convert p g3 ms) + g2 "" a = ".=" ++ show a + g2 p a = p ++ "=" ++ show a 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 + g3 p = concatMap (g4 p) . M.toList + g4 "" (p2,ps) = go (T.unpack p2) ps + g4 p (p2,ps) = go (p ++ "." ++ T.unpack p2) ps + convert _ _ [] = [] + convert p f [a] = [f p a] + convert p f as = zipWith (\(i :: Int) a -> f (p ++ "[" ++ show i ++ "]") a) [0..] as -- | The empty `Properties` empty :: Properties empty = Properties [] [] + +singleton :: Property -> Properties +singleton p = Properties [p] [] + +singletonMap :: M.HashMap Key Properties -> Properties +singletonMap m = Properties [] [m] + -- | 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 "." +toKeys :: Text -> [Key] +toKeys = filter (not.T.null) . T.splitOn "." -- | 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 +insert (a:as) p (Properties ps []) = Properties ps [insertMap as p a M.empty] +insert (a:as) p (Properties ps ms) = Properties ps $ insertMap as p a <$> ms +insertMap as p = M.alter (Just . insert as p . fromMaybe empty) + -- | 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 +lookup :: FromProperties a => Text -> Properties -> Maybe a +lookup k = from . lookup' k where - go [] p = from $ fromProperties p + from :: Return a -> Maybe a + from (OK a) = Just a + from Empty = Nothing + from (Fail e) = error e + +-- | Find `Properties` by key and convert to specific Haskell value. +lookup' :: FromProperties a => Text -> Properties -> Return a +lookup' = go . toKeys + where + go [] p = fromProperties p go (a:as) (Properties _ [m]) = case M.lookup a m of - Just n -> go as n - Nothing -> Nothing - go (a:as) _ = Nothing + Just n -> go as n + _ -> Empty + go _ _ = Empty -- | Insert batch properties to `Properties` -makeProperties :: [(String, Property)] -> Properties -> Properties -makeProperties ps m = foldl go m ps +makeProperties :: [(Text, Property)] -> Properties -> Properties +makeProperties = flip (foldl go) where go m (k,v) = insert (toKeys k) v m @@ -118,42 +146,33 @@ 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 + fromProperties (Properties [a] _) = OK a + fromProperties (Properties [] _) = Empty + fromProperties _ = Fail "property has multi values" 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 + fromProperties (Properties ps ms) = traverse fromProperties $ fmap singleton ps ++ fmap singletonMap ms instance FromProperties Scientific where fromProperties = fromProperties >=> go where go (PNum a) = OK a - go (PStr a) = to readMaybe a - go _ = Empty + go (PStr a) = to readMaybe $ T.unpack a + go _ = Fail "bool cannot convert to number" 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 + fromProperties a = T.unpack <$> fromProperties a instance FromProperties Text where - fromProperties a = pack <$> fromProperties a + fromProperties = fromProperties >=> go + where + go (PStr a) = OK a + go a = OK $ T.pack $ show a instance FromProperties Float where fromProperties a = toRealFloat <$> fromProperties a @@ -162,61 +181,59 @@ fromProperties a = toRealFloat <$> fromProperties a instance FromProperties Int where - fromProperties = fromProperties >=> to toBoundedInteger + fromProperties = toNumeric instance FromProperties Int8 where - fromProperties = fromProperties >=> to toBoundedInteger + fromProperties = toNumeric instance FromProperties Int16 where - fromProperties = fromProperties >=> to toBoundedInteger + fromProperties = toNumeric instance FromProperties Int32 where - fromProperties = fromProperties >=> to toBoundedInteger + fromProperties = toNumeric instance FromProperties Int64 where - fromProperties = fromProperties >=> to toBoundedInteger + fromProperties = toNumeric instance FromProperties Word where - fromProperties = fromProperties >=> to toBoundedInteger + fromProperties = toNumeric instance FromProperties Word8 where - fromProperties = fromProperties >=> to toBoundedInteger + fromProperties = toNumeric instance FromProperties Word16 where - fromProperties = fromProperties >=> to toBoundedInteger + fromProperties = toNumeric instance FromProperties Word32 where - fromProperties = fromProperties >=> to toBoundedInteger + fromProperties = toNumeric instance FromProperties Word64 where - fromProperties = fromProperties >=> to toBoundedInteger + fromProperties = toNumeric +toNumeric :: (Bounded i, Integral i) => Properties -> Return i +toNumeric = fromProperties >=> to toBoundedInteger + to :: (b -> Maybe a) -> b -> Return a -to v a = case v a of +to v b = case v b 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 (PStr a) = g2 $ T.toLower a go _ = Fail "number cannot convert to bool" + g2 :: Text -> Return Bool g2 "true" = OK True g2 "false" = OK False - g2 _ = Empty + g2 _ = Fail "string value cannot convert to bool" 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 + go (PStr s) + | T.null s = Empty + | otherwise = OK $ T.head s + go _ = Fail "cannot convert to char" diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Main where -import Control.Exception (SomeException) import Data.Aeson import qualified Data.HashMap.Strict as M import Data.Maybe @@ -11,15 +11,17 @@ import Data.Salak.CommandLine import Data.Salak.Environment import qualified Data.Salak.Types as P -import Data.Text (Text, pack) +import Data.Text (Text, intercalate, pack) import System.Environment import Test.Hspec +import Test.QuickCheck main = hspec spec spec :: Spec spec = do describe "Data.Salak.Types" specProperty + describe "Data.Salak" specProperties shouldFail :: (HasCallStack, Show a, Eq a) => a -> a -> Expectation shouldFail f a = (f `shouldBe` a) `shouldThrow` anyErrorCall @@ -49,6 +51,8 @@ ["a"] `shouldBe` toKeys "a." ["a","b"] `shouldBe` toKeys "a.b" ["a","b"] `shouldBe` toKeys "a.....b" + it "quickCheck" $ do + quickCheck $ \a -> let b = toKeys $ pack a in b == toKeys (intercalate "." b) context "insert" $ do let p = PStr "Hello" k = toKeys "a.b" @@ -57,7 +61,11 @@ insert [] p empty `shouldBe` Properties [p] [] insert k p empty `shouldBe` Properties [] [M.insert "a" (Properties [] [M.insert "b" (Properties [p] []) M.empty]) M.empty] it "Reject replacement" $ do - insert k (PStr "1") m `shouldBe` m + insert k "1" m `shouldBe` m + it "quickCheck" $ do + quickCheck $ \a' (b :: Integer) -> let a = pack a' in Just b == P.lookup a (insert (toKeys a) (PNum $ fromInteger b) empty) + quickCheck $ \a' (b :: Bool) -> let a = pack a' in Just b == P.lookup a (insert (toKeys a) (PBool b) empty) + quickCheck $ \a' (b :: String) -> let a = pack a' in Just b == P.lookup a (insert (toKeys a) (PStr $ pack b) empty) context "lookup" $ do it "normal" $ do let m = insert ["a"] (PNum 1) empty @@ -88,28 +96,39 @@ P.lookup "package.a.enabled" m `shouldBe` Just True P.lookup "package.b.enabled" m `shouldBe` Just False (P.lookup "package.c.enabled" m :: Maybe Bool )`shouldBe` Nothing + +specProperties = do context "defaultPropertiesWithFile" $ do - let name = "salak.yml" :: String + let confName = "salak.yml" :: String + confName' = pack confName it "read config" $ do unsetEnv "SALAK_CONFIG_NAME" - p <- defaultPropertiesWithFile name - P.lookup "salak.config.name" p `shouldBe` Just name + p <- defaultPropertiesWithFile confName' + P.lookup "salak.config.name" p `shouldBe` Just confName it "read config - replacement" $ do - setEnv "SALAK_CONFIG_NAME" name + setEnv "SALAK_CONFIG_NAME" confName p <- defaultPropertiesWithFile "salak.ok" - P.lookup "salak.config.name" p `shouldBe` Just name + P.lookup "salak.config.name" p `shouldBe` Just confName it "read config - not found" $ do setEnv "SALAK_CONFIG_NAME" "salak.notfound" setEnv "SALAK_CONFIG_DIR" "test" - defaultPropertiesWithFile name `shouldThrow` anyErrorCall + defaultPropertiesWithFile confName' `shouldThrow` anyErrorCall it "read config - read file parse Config" $ do - setEnv "SALAK_CONFIG_NAME" name + setEnv "SALAK_CONFIG_NAME" confName setEnv "SALAK_CONFIG_DIR" "test" - p <- defaultPropertiesWithFile name - print p - P.lookup "salak.config.name" p `shouldBe` Just name - (P.lookup "salak.config" p :: Maybe Config) `shouldBe` Just (Config (pack name) "test" 1) - (P.lookup "array" p :: Maybe [String]) `shouldBe` Just ["a","b"] + setEnv "SALAK_CONFIG" confName + p <- defaultPropertiesWithFile confName' + let get :: FromProperties a => Text -> Maybe a + get = flip P.lookup p + -- print p + -- let v::Return Value = fromProperties p + -- P.fromReturn (return ()) $ BC.putStrLn . encodePretty <$> v + get "salak.config.name" `shouldBe` Just confName + get "salak.config" `shouldBe` Just confName + (get "salak.config" :: Maybe Config) `shouldBe` Just (Config confName' "test" 1) + (get "array" :: Maybe [String]) `shouldBe` Just ["a","b"] + (get "array" :: Maybe [Int]) `shouldFail` Nothing + (get "array" :: Maybe String) `shouldFail` Nothing