diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,9 +8,22 @@ Nothing +## [v1.1.0.0] 2021-03-01 + +### Changed + +* Rename `fromFilePath` to `fromFilePath'`. +* Define a new `fromFilePath` whose type is `FilePath -> SourceCreator` instaed of `FilePath -> IO Source`. +* Validate that the json value doesn't contain any wrong key name (only lowercase ascii and numbers + are accepted) and throw otherwise. +* Treat the special key `_self` as explained in the docs to allow nesting keys that's used elsewhere. +* Even if invalid key names get through, ignore them in the source. + + ## [v1.0.0.0] 2020-12-29 First release -[Unreleased]: https://github.com/ludat/conferer/compare/conferer-aeson_v1.0.0.0...HEAD +[Unreleased]: https://github.com/ludat/conferer/compare/conferer-aeson_v1.1.0.0...HEAD +[v1.1.0.0]: https://github.com/ludat/conferer/compare/conferer-aeson_v1.0.0.0...conferer-aeson_v1.1.0.0 [v1.0.0.0]: https://github.com/ludat/conferer/compare/v0.0.0.0...conferer-aeson_v1.0.0.0 diff --git a/conferer-aeson.cabal b/conferer-aeson.cabal --- a/conferer-aeson.cabal +++ b/conferer-aeson.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 2543e03c19711f47aefac06d11874917b5f28a3c1d272d42fbb5d4016968c1cd +-- hash: cdd4956f023c56c73b29439f3a0cafebbc5b26d1091e28a67e8b847d76974ee9 name: conferer-aeson -version: 1.0.0.0 +version: 1.1.0.0 synopsis: conferer's source for reading json files description: Library to abstract the parsing of many haskell config values from different config sources @@ -51,6 +51,7 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: + Conferer.FromConfig.AesonSpec Conferer.Source.AesonSpec Paths_conferer_aeson hs-source-dirs: diff --git a/src/Conferer/FromConfig/Aeson.hs b/src/Conferer/FromConfig/Aeson.hs --- a/src/Conferer/FromConfig/Aeson.hs +++ b/src/Conferer/FromConfig/Aeson.hs @@ -17,7 +17,7 @@ import qualified Data.Text.Encoding as Text instance FromConfig Value where - fetchFromConfig key config = do + fromConfig key config = do rawAeson <- fetchFromConfig @Text key config case eitherDecodeStrict' @Value $ Text.encodeUtf8 rawAeson of Right value -> diff --git a/src/Conferer/Source/Aeson.hs b/src/Conferer/Source/Aeson.hs --- a/src/Conferer/Source/Aeson.hs +++ b/src/Conferer/Source/Aeson.hs @@ -22,6 +22,8 @@ import qualified Data.ByteString.Lazy as L import Data.List (intersperse) import System.Directory (doesFileExist) +import Control.Exception +import Control.Monad (guard) import Conferer.Source.Files import qualified Conferer.Source.Null as Null @@ -44,15 +46,24 @@ fromConfig :: Key -> SourceCreator fromConfig key config = do fileToParse <- getFilePathFromEnv key "json" config - fromFilePath fileToParse + fromFilePath' fileToParse +-- | Create a 'SourceCreator' from a filepath +-- +-- If the file is not present it will behave as if it had no keys. +-- +-- If the file doesn't have valid json it will throw an error. +fromFilePath :: FilePath -> SourceCreator +fromFilePath fileToParse _config = + fromFilePath' fileToParse + -- | Create a 'Source' from a filepath -- -- If the file is not present it will behave as if it had no keys. -- -- If the file doesn't have valid json it will throw an error. -fromFilePath :: FilePath -> IO Source -fromFilePath fileToParse = do +fromFilePath' :: FilePath -> IO Source +fromFilePath' fileToParse = do fileExists <- doesFileExist fileToParse if fileExists then do @@ -61,10 +72,21 @@ Nothing -> error $ "Failed to decode json file '" ++ fileToParse ++ "'" Just v -> do - return $ fromValue v + case invalidJsonKeys v of + [] -> + return $ fromValue v + errors -> + throwIO $ JsonHasInvalidKeysError fileToParse errors else do return $ Null.empty +-- | Exception thrown from 'fromFilePath' when the json in the +-- parsed file has incorrect keys +data JsonHasInvalidKeysError = + JsonHasInvalidKeysError FilePath [RawKey] deriving (Eq, Show) + +instance Exception JsonHasInvalidKeysError + -- | Create a 'Source' from a json value, never fails. fromValue :: Value -> Source fromValue value = @@ -117,9 +139,16 @@ go :: Key -> Value -> [Key] go key value = case (unconsKey key, value) of - (_, Object o) -> do - (k, v) <- HashMap.toList o - go (key /. fromText k) v + (_, Object o) -> + let + self = + case valueToText <$> HashMap.lookup "_self" o of + Just _ -> [key] + Nothing -> [] + in self ++ do + (k, v) <- HashMap.toList o + guard $ isValidKeyFragment k + go (key /. fromText k) v (_, Array as) -> do (index :: Integer, v) <- zip [0..] $ Vector.toList as go (key /. mkKey (show index)) v @@ -129,7 +158,9 @@ -- | Turn json 'Value' into 'Text' to return that key valueToText :: Value -> Maybe Text valueToText (String t) = Just t -valueToText (Object _o) = Nothing +valueToText (Object o) = do + selfValue <- HashMap.lookup "_self" o + valueToText selfValue valueToText (Array _as) = Nothing valueToText (Number n) = Just $ Text.decodeUtf8 $ L.toStrict $ encode $ Number n valueToText (Bool b) = Just $ boolToString b @@ -145,3 +176,40 @@ resultToMaybe (Error _) = Nothing resultToMaybe (Success a) = Just a +type RawKey = [Text] + +-- | Validates that a json has the correct format for keys, +-- since Conferer 'Key's are pretty restricted. +-- +-- The Source will work with incorrect keys but they will +-- be ignored. +invalidJsonKeys :: Value -> [RawKey] +invalidJsonKeys = filter (not . validKey) . allKeys + where + validFragmentForJSON :: Text -> Bool + validFragmentForJSON fragment = isValidKeyFragment fragment || fragment == "_self" + validKey :: RawKey -> Bool + validKey fragments = all validFragmentForJSON fragments + +-- | Returns all keys in a json object +allKeys :: Value -> [RawKey] +allKeys = go mempty + where + go :: RawKey -> Value -> [RawKey] + go rawkey value = + case value of + Object o -> + let + keys = + fmap (\t -> rawkey ++ [t]) + . HashMap.keys + $ o + in keys ++ do + (k, v) <- HashMap.toList o + let subkey = rawkey ++ [k] + go subkey v + Array as -> do + (index :: Integer, v) <- zip [0..] $ Vector.toList as + let subkey = rawkey ++ [Text.pack $ show index] + go subkey v + _ -> [] diff --git a/test/Conferer/FromConfig/AesonSpec.hs b/test/Conferer/FromConfig/AesonSpec.hs new file mode 100644 --- /dev/null +++ b/test/Conferer/FromConfig/AesonSpec.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TypeApplications #-} +module Conferer.FromConfig.AesonSpec where + +import Data.Aeson +import Data.Aeson.QQ +import Test.Hspec + +import Conferer.FromConfig +import Conferer.FromConfig.Aeson () + +import Conferer.Test + +spec :: Spec +spec = do + it "getting an existing path returns the right value" $ do + c <- configWith [] [("some.key", "{\"some\": \"some url\", \"ssl\": true}")] + res <- fetchFromConfig @Value "some.key" c + res `shouldBe` [aesonQQ| {"some": "some url", "ssl": true} |] diff --git a/test/Conferer/Source/AesonSpec.hs b/test/Conferer/Source/AesonSpec.hs --- a/test/Conferer/Source/AesonSpec.hs +++ b/test/Conferer/Source/AesonSpec.hs @@ -26,6 +26,18 @@ res <- getKeyInSource c "some.path" res `shouldBe` Nothing + context "getting a key with an object that has '_self'" $ do + it "gets the value inside '_self'" $ do + c <- mk [aesonQQ| { key: {_self: 72}} |] + res <- getKeyInSource c "key" + res `shouldBe` Just "72" + + context "with a key that's not valid" $ do + it "ignores the value" $ do + c <- mk [aesonQQ| { key: {key_: 72}} |] + res <- getKeyInSource c "key" + res `shouldBe` Nothing + describe "with an array" $ do it "getting a path with number gets the right value" $ do c <- mk [aesonQQ| {"key": ["value"]} |] @@ -127,4 +139,44 @@ c <- mk [aesonQQ|[true, true, true]|] res <- getSubkeysInSource c "" res `shouldBe` ["0", "1", "2"] + describe "gettings keys with invalid names" $ do + it "ignores those names" $ do + c <- mk [aesonQQ|{"_a": 7}|] + res <- getSubkeysInSource c "" + res `shouldBe` [] + describe "when json keys don't follow the conferer Key format" $ do + it "ignores the evil keys" $ do + c <- mk [aesonQQ|{some: {k_e_y: 0}}|] + res <- getSubkeysInSource c "" + res `shouldBe` [] + describe "when '_self' is present" $ do + it "gets an object if it has '_self'" $ do + c <- mk [aesonQQ|{some: {_self: 7, key: 0}}|] + res <- getSubkeysInSource c "" + res `shouldBe` ["some", "some.key"] + describe "#invalidJsonKeys" $ do + context "with some common keys" $ + it "works" $ do + invalidJsonKeys [aesonQQ|{postgres: {url: "some url", ssl: true}} |] + `shouldBe` [] + context "with one top level invalid key" $ + it "fails" $ do + invalidJsonKeys [aesonQQ|{k_e_y: {}} |] + `shouldBe` [["k_e_y"]] + context "with one invalid key inside an object" $ + it "fails" $ do + invalidJsonKeys [aesonQQ|{some: {k_e_y: {}}} |] + `shouldBe` [["some", "k_e_y"]] + context "with one invalid key inside an array" $ + it "fails" $ do + invalidJsonKeys [aesonQQ|[{k_e_y: {}}]|] + `shouldBe` [["0", "k_e_y"]] + context "with _self" $ + it "succeeds" $ do + invalidJsonKeys [aesonQQ|[{some: {_self: 7}}]|] + `shouldBe` [] + context "with empty key" $ + it "fails" $ do + invalidJsonKeys [aesonQQ|{"": 7}|] + `shouldBe` [[""]]