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.2.1-orange.svg)](https://hackage.haskell.org/package/salak) +[![Hackage](https://img.shields.io/badge/hackage-v0.2.2-orange.svg)](https://hackage.haskell.org/package/salak) [![Build Status](https://travis-ci.org/leptonyu/salak.svg?branch=master)](https://travis-ci.org/leptonyu/salak) diff --git a/salak.cabal b/salak.cabal --- a/salak.cabal +++ b/salak.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: salak -version: 0.2.1 +version: 0.2.2 license: BSD3 license-file: LICENSE copyright: (c) 2018 Daniel YU @@ -28,19 +28,19 @@ Data.Salak.Yaml Data.Salak.Operation default-language: Haskell2010 - ghc-options: -Wall -Wcompat -Wincomplete-record-updates - -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-orphans - -fno-warn-missing-signatures + ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures build-depends: - aeson >=1.4.2.0 && <1.5, - base >=4.11 && <5, - directory >=1.3.3.0 && <1.4, - filepath >=1.4.2.1 && <1.5, - scientific >=0.3.6.2 && <0.4, - text >=1.2.3.1 && <1.3, - unordered-containers >=0.2.9.0 && <0.3, - vector >=0.12.0.2 && <0.13, - yaml >=0.11.0.0 && <0.12 + aeson <1.5, + base >=4.7 && <5, + directory <1.4, + filepath <1.5, + mtl <2.3, + scientific <0.4, + text <1.3, + transformers <0.6, + unordered-containers <0.3, + vector <0.13, + yaml <0.12 test-suite spec type: exitcode-stdio-1.0 @@ -56,20 +56,18 @@ Data.Salak.Yaml Paths_salak default-language: Haskell2010 - ghc-options: -Wall -Wcompat -Wincomplete-record-updates - -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-orphans - -fno-warn-missing-signatures + ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures build-depends: - QuickCheck >=2.12.6.1 && <2.13, - aeson >=1.4.2.0 && <1.5, - aeson-pretty >=0.8.7 && <0.9, - base >=4.11 && <5, - bytestring >=0.10.8.2 && <0.11, - directory >=1.3.3.0 && <1.4, - filepath >=1.4.2.1 && <1.5, + QuickCheck <2.13, + aeson <1.5, + base >=4.7 && <5, + directory <1.4, + filepath <1.5, hspec ==2.*, - scientific >=0.3.6.2 && <0.4, - text >=1.2.3.1 && <1.3, - unordered-containers >=0.2.9.0 && <0.3, - vector >=0.12.0.2 && <0.13, - yaml >=0.11.0.0 && <0.12 + mtl <2.3, + scientific <0.4, + text <1.3, + transformers <0.6, + unordered-containers <0.3, + vector <0.13, + yaml <0.12 diff --git a/src/Data/Salak.hs b/src/Data/Salak.hs --- a/src/Data/Salak.hs +++ b/src/Data/Salak.hs @@ -15,15 +15,23 @@ -- $use -- * Properties Loader - defaultProperties - , ParseCommandLine + LoadProperties + , runLoad + , askProperties + , setValue + , loadCommandLine + , loadEnvironment + , loadJSON + , loadYaml + , loadYamlIfExists + -- ** Predefined Loaders + , defaultProperties , defaultProperties' , defaultPropertiesWithFile , defaultPropertiesWithFile' , empty -- * Lookup Properties , lookup - , lookup' , toKeys -- * Types , Property(..) @@ -33,16 +41,14 @@ , Return -- * Properties Loader Helper , insert - , makePropertiesFromEnvironment , defaultParseCommandLine - , makePropertiesFromCommandLine - , makePropertiesFromJson - , makePropertiesFromYaml + , ParseCommandLine , FileName -- * Operations , module Data.Salak.Operation ) where +import Control.Monad.Trans.Class (lift) import Data.Maybe import Data.Salak.Aeson import Data.Salak.CommandLine @@ -50,10 +56,10 @@ import Data.Salak.Operation import Data.Salak.Types import Data.Salak.Yaml -import Data.Text (Text, unpack) -import Prelude hiding (lookup) +import Data.Text (pack) +import Prelude hiding (lookup) import System.Directory -import System.FilePath (()) +import System.FilePath (()) -- | Initialize default properties from `CommandLine` and `Environment`. -- `CommandLine` use default parser. @@ -62,12 +68,12 @@ -- | Initialize default properties from `CommandLine` and `Environment`. defaultProperties' :: ParseCommandLine -> IO Properties -defaultProperties' dpc - = makePropertiesFromCommandLine dpc empty - >>= makePropertiesFromEnvironment +defaultProperties' dpc = runLoad $ do + loadCommandLine dpc + loadEnvironment -- | Yaml file name. -type FileName = Text +type FileName = String -- | Initialize default properties from `CommandLine`, `Environment` and `Yaml` files. -- All these configuration sources has orders, from highest order to lowest order: @@ -96,21 +102,20 @@ :: 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)] - where - 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" +defaultPropertiesWithFile' name dpc = runLoad $ do + loadCommandLine dpc + loadEnvironment + p <- askProperties + let n = fromMaybe name $ p .>> "salak.config.name" + f = p .>> "salak.config.dir" + setValue "salak.config.name" (PStr $ pack n) + case f of + Just y -> loadYaml (y n) + _ -> return () + c <- lift getCurrentDirectory + loadYamlIfExists (Just $ c n) + h <- lift getHomeDirectory + loadYamlIfExists (Just $ h n) -- $use -- @@ -133,14 +138,16 @@ -- > , ext :: Int -- > } deriving (Eq, Show) -- > --- > instance FromJSON Config where --- > parseJSON = withObject "Config" $ \v -> Config --- > <$> v .: "name" --- > <*> v .:? "dir" --- > <*> (fromMaybe 1 <$> v .:? "ext") +-- > instance FromProperties Config where +-- > fromProperties v = Config +-- > <$> v .?> "name" +-- > <*> v .?> "dir" +-- > <*> v .?> "ext" .?= 1 -- -- > main = do -- > p <- defaultPropertiesWithFile "salak.yml" --- > let Just config = lookup "salak.config" p :: Maybe Config +-- > let config = p .>> "salak.config" :: Config +-- > enabled = p .?> "salak.enabled" .|= True -- > print config +-- > print enabled 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 @@ -4,10 +4,12 @@ module Data.Salak.Aeson where +import Control.Monad.IO.Class +import Control.Monad.State import Data.Aeson -import qualified Data.HashMap.Strict as M +import qualified Data.HashMap.Strict as M import Data.Salak.Types -import Data.Vector (toList) +import Data.Vector (toList) -- | Load `Properties` from JSON `Value` makePropertiesFromJson :: Value -> Properties -> Properties @@ -29,3 +31,9 @@ g2 [] = [] g2 (a:_) = [a] g3 (as,bs) (a,b) = (as++a,bs++b) + +-- | Load Properties from JSON Value +-- +-- @since 0.2.2 +loadJSON :: MonadIO m => Value -> LoadProperties m () +loadJSON = modify . makePropertiesFromJson 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,10 @@ module Data.Salak.CommandLine where +import Control.Monad.IO.Class +import Control.Monad.State import Data.Maybe import Data.Salak.Types -import Data.Text (pack) +import Data.Text (pack) import System.Environment -- | CommandLine parser. Parse command line into property key values. @@ -33,3 +35,13 @@ makePropertiesFromCommandLine' args parser p = do v <- parser args return $ makeProperties (fmap (\(a,b) -> (pack a,b)) v) p + + +-- | Load Properties from CommandLine +-- +-- @since 0.2.2 +loadCommandLine :: MonadIO m => ParseCommandLine -> LoadProperties m () +loadCommandLine pcl = do + p <- get + q <- liftIO $ makePropertiesFromCommandLine pcl p + put q 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,8 +1,10 @@ module Data.Salak.Environment where +import Control.Monad.IO.Class +import Control.Monad.State import Data.Char import Data.Salak.Types -import Data.Text (pack) +import Data.Text (pack) import System.Environment -- | Load `Properties` from 'Environment' @@ -16,3 +18,9 @@ go (k,v) = (pack $ fmap g2 k,PStr $ pack v) g2 '_' = '.' g2 a = toLower a + +-- | Load Properties from CommandLine +-- +-- @since 0.2.2 +loadEnvironment :: MonadIO m => LoadProperties m () +loadEnvironment = get >>= liftIO . makePropertiesFromEnvironment >>= put diff --git a/src/Data/Salak/Operation.hs b/src/Data/Salak/Operation.hs --- a/src/Data/Salak/Operation.hs +++ b/src/Data/Salak/Operation.hs @@ -3,23 +3,37 @@ import Data.Salak.Types import Data.Text (Text, unpack) +-- | Find `Properties` by key and convert to specific Haskell value. +-- +-- @since 0.2.1 infixl 5 .?> (.?>) :: FromProperties a => Properties -> Text -> Return a -(.?>) = flip lookup' +(.?>) = flip Data.Salak.Types.lookup +-- | Get property or use default value if not found, but will throw +-- exception if parse failed. +-- +-- @since 0.2.1 infixl 5 .|= (.|=) :: Return a -> a -> a (.|=) (Right a) _ = a (.|=) (Left (Fail e)) _ = error e (.|=) _ d = d +-- | Use default value if Key not found +-- +-- @since 0.2.1 infixl 5 .?= (.?=) :: Return a -> a -> Return a (.?=) a b = Right (a .|= b) +-- | Find `Properties` by key and convert to specific Haskell value. +-- Throw error if property not found or parse failed +-- +-- @since 0.2.1 infixl 5 .>> (.>>) :: FromProperties a => Properties -> Text -> a (.>>) p key = case p .?> key of Right v -> v - Left (EmptyKey k) -> error $ "Config " <> unpack k <> " not found" + Left (EmptyKey k) -> error $ "property " ++ unpack k ++ " not set" Left (Fail e) -> error e 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,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -5,7 +6,8 @@ module Data.Salak.Types where -import Control.Monad ((>=>)) +import Control.Monad () +import Control.Monad.State import Data.Char import qualified Data.HashMap.Strict as M import Data.Int @@ -15,8 +17,11 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Word -import Text.Read - +import System.Directory +import Text.Read (readMaybe) +#if __GLASGOW_HASKELL__ <= 802 +import Data.Monoid ((<>)) +#endif -- | Property key type Key = Text @@ -65,7 +70,6 @@ empty :: Properties empty = Properties [] [] - singleton :: Property -> Properties singleton p = Properties [p] [] @@ -92,26 +96,17 @@ 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 => Text -> Properties -> Maybe a -lookup k = from . lookup' k - where - from :: Return a -> Maybe a - from (Right a) = Just a - from (Left (EmptyKey _)) = Nothing - from (Left (Fail e)) = error e - --- | Find `Properties` by key and convert to specific Haskell value. -lookup' :: FromProperties a => Text -> Properties -> Return a -lookup' k = go (toKeys k) +lookup :: FromProperties a => Text -> Properties -> Return a +lookup k = go (toKeys k) where + {-# INLINE go #-} go [] p = fromProperties p - go (a:as) (Properties _ [m]) = case M.lookup a m of - Just n -> case go as n of + go (a:as) (Properties _ ms) = case go as $ fromMaybe empty $ select a ms of Left (EmptyKey ke) -> Left $ EmptyKey $ joinKey a ke v -> v - _ -> Left $ EmptyKey $ T.intercalate "." (a:as) - go ke _ = Left $ EmptyKey $ T.intercalate "." ke + select _ [] = Nothing + select a [m] = M.lookup a m + select _ _ = Nothing joinKey :: Text -> Text -> Text @@ -141,6 +136,12 @@ instance {-# OVERLAPPABLE #-} FromProperties a => FromProperties [a] where fromProperties (Properties ps ms) = traverse fromProperties $ fmap singleton ps <> fmap singletonMap ms +instance {-# OVERLAPPABLE #-} FromProperties a => FromProperties (Maybe a) where + fromProperties p = case fromProperties p of + Right a -> Right (Just a) + Left (EmptyKey _) -> Right Nothing + Left r -> Left r + instance FromProperties Scientific where fromProperties = fromProperties >=> go where @@ -222,3 +223,33 @@ | otherwise = Right $ T.head s go _ = Left $ Fail "cannot convert to char" +-- | Monad to Load Properties +-- +-- @since 0.2.2 +type LoadProperties = StateT Properties + +-- | Load Properties +-- +-- @since 0.2.2 +runLoad :: Monad m => LoadProperties m a -> m Properties +runLoad a = snd <$> runStateT a empty + +-- | Get current Properties +-- +-- @since 0.2.2 +askProperties :: Monad m => LoadProperties m Properties +askProperties = get + +-- | Set value to current properties +-- +-- @since 0.2.2 +setValue :: Monad m => Text -> Property -> LoadProperties m () +setValue k v = do + p <- askProperties + put (insert (toKeys k) v p) + +loadIfExists :: MonadIO m => Maybe FilePath -> (FilePath -> LoadProperties m ()) -> LoadProperties m () +loadIfExists (Just f) a = do + e <- liftIO $ doesFileExist f + when e (a f) +loadIfExists _ _ = return () 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,5 +1,8 @@ +{-# LANGUAGE CPP #-} module Data.Salak.Yaml where +import Control.Monad.IO.Class +import Control.Monad.State import Data.Salak.Aeson import Data.Salak.Types import Data.Yaml @@ -7,5 +10,29 @@ -- | Load `Properties` from `Yaml` file. makePropertiesFromYaml :: FilePath -> Properties -> IO Properties makePropertiesFromYaml file p = do + +#if __GLASGOW_HASKELL__ <= 710 + x <- decodeFile file + v <- case x of + Just a -> return a + _ -> error $ "load " ++ file ++ " failed" +#else v <- decodeFileThrow file +#endif + return $ makePropertiesFromJson v p + +-- | Load Properties from Yaml +-- +-- @since 0.2.2 +loadYaml :: MonadIO m => FilePath -> LoadProperties m () +loadYaml file = do + p <- get + q <- liftIO $ makePropertiesFromYaml file p + put q + +-- | Load Properties from Yaml if exists +-- +-- @since 0.2.2 +loadYamlIfExists :: MonadIO m => Maybe FilePath -> LoadProperties m () +loadYamlIfExists mf = loadIfExists mf loadYaml diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -9,7 +9,6 @@ import Data.Salak.CommandLine import Data.Salak.Environment import Data.Salak.Operation () -import qualified Data.Salak.Types as P import Data.Text (Text, intercalate, pack) import System.Environment import Test.Hspec @@ -22,7 +21,7 @@ describe "Data.Salak.Types" specProperty describe "Data.Salak" specProperties -shouldFail :: (HasCallStack, Show a, Eq a) => a -> a -> Expectation +shouldFail :: (Show a, Eq a) => a -> a -> Expectation shouldFail f a = (f `shouldBe` a) `shouldThrow` anyErrorCall data Config = Config @@ -62,39 +61,39 @@ it "Reject replacement" $ do insert k "1" m `shouldBe` m it "quickCheck" $ do - quickCheck $ \a' (b :: Int) -> let a = pack a' in Just b == P.lookup a (insert (toKeys a) (PNum $ fromIntegral 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) + quickCheck $ \a' (b :: Int) -> let a = pack a' in Just b == (insert (toKeys a) (PNum $ fromIntegral b) empty) .>> a + quickCheck $ \a' (b :: Bool) -> let a = pack a' in Just b == (insert (toKeys a) (PBool b) empty) .>> a + quickCheck $ \a' (b :: String) -> let a = pack a' in Just b == (insert (toKeys a) (PStr $ pack b) empty) .>> a context "lookup" $ do it "normal" $ do let m = insert ["a"] (PNum 1) empty n = insert ["a"] (PStr "true") empty - (P.lookup "a" empty :: Maybe Int) `shouldBe` Nothing - (P.lookup "a" m :: Maybe Int) `shouldBe` Just 1 - (P.lookup "a" m :: Maybe Bool) `shouldFail` Nothing - (P.lookup "a" m :: Maybe String) `shouldBe` Just "1.0" - (P.lookup "a" n :: Maybe Int) `shouldFail` Nothing - (P.lookup "a" n :: Maybe Bool) `shouldBe` Just True - (P.lookup "a" n :: Maybe Text) `shouldBe` Just "true" + (empty .>> "a" :: Maybe Int) `shouldBe` Nothing + (m .>> "a" :: Maybe Int) `shouldBe` Just 1 + (m .>> "a" :: Maybe Bool) `shouldFail` Nothing + (m .>> "a" :: Maybe String) `shouldBe` Just "1.0" + (n .>> "a" :: Maybe Int) `shouldFail` Nothing + (n .>> "a" :: Maybe Bool) `shouldBe` Just True + (n .>> "a" :: Maybe Text) `shouldBe` Just "true" context "makeProperties" $ do it "normal" $ do m <- makePropertiesFromEnvironment empty h <- getEnv "HOME" - (P.lookup "home" m) `shouldBe` Just h + (m .>> "home") `shouldBe` Just h context "command-line" $ do it "normal" $ do let args = ["--package.a.enabled=true","--package.b.enabled=false","package.c.enabled=false"] m <- makePropertiesFromCommandLine' args defaultParseCommandLine empty - 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 + (m .>> "package.a.enabled") `shouldBe` Just True + (m .>> "package.b.enabled") `shouldBe` Just False + (m .>> "package.c.enabled" :: Maybe Bool )`shouldBe` Nothing context "environment" $ do it "normal" $ do let args = [("PACKAGE_A_ENABLED","true"),("PACKAGE_B_ENABLED","false")] m = makePropertiesFromEnvironment' args empty - 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 + (m .>> "package.a.enabled") `shouldBe` Just True + (m .>> "package.b.enabled") `shouldBe` Just False + (m .>> "package.c.enabled" :: Maybe Bool )`shouldBe` Nothing specProperties = do context "defaultPropertiesWithFile" $ do @@ -102,32 +101,27 @@ confName' = pack confName it "read config" $ do unsetEnv "SALAK_CONFIG_NAME" - p <- defaultPropertiesWithFile confName' - P.lookup "salak.config.name" p `shouldBe` Just confName + p <- defaultPropertiesWithFile confName + p .>> "salak.config.name" `shouldBe` Just confName it "read config - replacement" $ do setEnv "SALAK_CONFIG_NAME" confName p <- defaultPropertiesWithFile "salak.ok" - P.lookup "salak.config.name" p `shouldBe` Just confName + p .>> "salak.config.name" `shouldBe` Just confName it "read config - not found" $ do setEnv "SALAK_CONFIG_NAME" "salak.notfound" setEnv "SALAK_CONFIG_DIR" "test" - defaultPropertiesWithFile confName' `shouldThrow` anyErrorCall + defaultPropertiesWithFile confName `shouldThrow` anyException it "read config - read file parse Config" $ do setEnv "SALAK_CONFIG_NAME" confName setEnv "SALAK_CONFIG_DIR" "test" 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 + p <- defaultPropertiesWithFile confName + (p .>> "salak.config.name") `shouldBe` Just confName + (p .>> "salak.config") `shouldBe` Just confName + (p .>> "salak.config" :: Maybe Config) `shouldBe` Just (Config confName' "test" 1) + (p .>> "array" :: Maybe [String]) `shouldBe` Just ["a","b"] + (p .>> "array" :: Maybe [Int]) `shouldFail` Nothing + (p .>> "array" :: Maybe String) `shouldFail` Nothing