From 831badf8793fc5deb52fdfde79178d72599a9dd4 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Wed, 20 Jan 2021 21:22:05 +0700 Subject: [PATCH 1/3] Make Parser stricter --- src/Data/Aeson/Config/Parser.hs | 22 ++++++++++++++++------ 1 file changed, 16 insertions(+), 6 deletions(-) diff --git a/src/Data/Aeson/Config/Parser.hs b/src/Data/Aeson/Config/Parser.hs index 741d7eab..07c9f674 100644 --- a/src/Data/Aeson/Config/Parser.hs +++ b/src/Data/Aeson/Config/Parser.hs @@ -35,6 +35,7 @@ import Control.Applicative import qualified Control.Monad.Fail as Fail import Control.Monad.Trans.Class import Control.Monad.Trans.Writer +import Control.Monad.Trans.State.Strict import Data.Monoid ((<>)) import Data.Scientific import Data.Set (Set, notMember) @@ -64,16 +65,20 @@ fromAesonPathElement e = case e of Aeson.Key k -> Key k Aeson.Index n -> Index n -newtype Parser a = Parser {unParser :: WriterT (Set JSONPath) Aeson.Parser a} +data ParserState = ParserState { + parserStateConsumedFields :: !(Set JSONPath) +} + +newtype Parser a = Parser {unParser :: StateT ParserState Aeson.Parser a} deriving (Functor, Applicative, Alternative, Monad, Fail.MonadFail) liftParser :: Aeson.Parser a -> Parser a liftParser = Parser . lift runParser :: (Value -> Parser a) -> Value -> Either String (a, [String]) -runParser p v = case iparse (runWriterT . unParser <$> p) v of +runParser p v = case iparse (flip runStateT (ParserState mempty) . unParser <$> p) v of IError path err -> Left ("Error while parsing " ++ formatPath (fromAesonPath path) ++ " - " ++ err) - ISuccess (a, consumed) -> Right (a, map formatPath (determineUnconsumed consumed v)) + ISuccess (a, ParserState consumed) -> Right (a, map formatPath (determineUnconsumed consumed v)) formatPath :: JSONPath -> String formatPath = go "$" . reverse @@ -104,13 +109,18 @@ determineUnconsumed ((<> Set.singleton []) -> consumed) = Set.toList . execWrite go (Index n : path) v () :: Parser a -> Aeson.JSONPathElement -> Parser a -() (Parser (WriterT p)) e = do - Parser (WriterT (p Aeson. e)) <* markConsumed (fromAesonPathElement e) +() p e = mapParser (Aeson. e) p <* markConsumed (fromAesonPathElement e) + +mapParser :: (Aeson.Parser (a, ParserState) -> Aeson.Parser (b, ParserState)) -> Parser a -> Parser b +mapParser f = Parser . mapStateT f . unParser markConsumed :: JSONPathElement -> Parser () markConsumed e = do path <- getPath - Parser $ tell (Set.singleton $ e : path) + tellJSONPath (e : path) + +tellJSONPath :: JSONPath -> Parser () +tellJSONPath path = Parser . modify $ \ st -> st {parserStateConsumedFields = Set.insert path $ parserStateConsumedFields st} getPath :: Parser JSONPath getPath = liftParser $ Aeson.parserCatchError empty $ \ path _ -> return (fromAesonPath path) From 01a7a2f38112335575235dc7da7db8b009efcfc2 Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Thu, 21 Jan 2021 00:54:29 +0700 Subject: [PATCH 2/3] Add supports for warnings while parsing --- src/Data/Aeson/Config/FromValue.hs | 6 +++++- src/Data/Aeson/Config/Parser.hs | 28 ++++++++++++++++++++++--- src/Hpack/Config.hs | 8 ++++--- src/Hpack/Yaml.hs | 6 +++--- test/Data/Aeson/Config/FromValueSpec.hs | 10 ++++----- test/Helper.hs | 5 +++++ test/Hpack/Syntax/DependenciesSpec.hs | 2 +- 7 files changed, 49 insertions(+), 16 deletions(-) diff --git a/src/Data/Aeson/Config/FromValue.hs b/src/Data/Aeson/Config/FromValue.hs index e329f114..8ab1e04d 100644 --- a/src/Data/Aeson/Config/FromValue.hs +++ b/src/Data/Aeson/Config/FromValue.hs @@ -12,6 +12,8 @@ module Data.Aeson.Config.FromValue ( FromValue(..) , Parser , Result +, Warning(..) +, WarningReason(..) , decodeValue , Generic @@ -28,6 +30,8 @@ module Data.Aeson.Config.FromValue ( , withNumber , withBool +, warn + , parseArray , traverseObject @@ -56,7 +60,7 @@ import Data.Aeson.Types (FromJSON(..)) import Data.Aeson.Config.Util import Data.Aeson.Config.Parser -type Result a = Either String (a, [String]) +type Result a = Either String (a, [Warning]) decodeValue :: FromValue a => Value -> Result a decodeValue = runParser fromValue diff --git a/src/Data/Aeson/Config/Parser.hs b/src/Data/Aeson/Config/Parser.hs index 07c9f674..a16b189d 100644 --- a/src/Data/Aeson/Config/Parser.hs +++ b/src/Data/Aeson/Config/Parser.hs @@ -4,6 +4,8 @@ {-# LANGUAGE CPP #-} module Data.Aeson.Config.Parser ( Parser +, Warning(..) +, WarningReason(..) , runParser , typeMismatch @@ -14,6 +16,8 @@ module Data.Aeson.Config.Parser ( , withNumber , withBool +, warn + , explicitParseField , explicitParseFieldMaybe @@ -67,6 +71,7 @@ fromAesonPathElement e = case e of data ParserState = ParserState { parserStateConsumedFields :: !(Set JSONPath) +, parserStateWarnings :: ![(JSONPath, String)] } newtype Parser a = Parser {unParser :: StateT ParserState Aeson.Parser a} @@ -75,10 +80,22 @@ newtype Parser a = Parser {unParser :: StateT ParserState Aeson.Parser a} liftParser :: Aeson.Parser a -> Parser a liftParser = Parser . lift -runParser :: (Value -> Parser a) -> Value -> Either String (a, [String]) -runParser p v = case iparse (flip runStateT (ParserState mempty) . unParser <$> p) v of +data Warning = Warning String WarningReason + deriving (Eq, Show) + +data WarningReason = WarningReason String | UnknownField + deriving (Eq, Show) + +runParser :: (Value -> Parser a) -> Value -> Either String (a, [Warning]) +runParser p v = case iparse (flip runStateT (ParserState mempty mempty) . unParser <$> p) v of IError path err -> Left ("Error while parsing " ++ formatPath (fromAesonPath path) ++ " - " ++ err) - ISuccess (a, ParserState consumed) -> Right (a, map formatPath (determineUnconsumed consumed v)) + ISuccess (a, ParserState consumed warnings) -> Right (a, map warning warnings ++ map unknownField (determineUnconsumed consumed v)) + where + warning :: (JSONPath, String) -> Warning + warning (path, reason) = Warning (formatPath path) (WarningReason reason) + + unknownField :: JSONPath -> Warning + unknownField path = Warning (formatPath path) UnknownField formatPath :: JSONPath -> String formatPath = go "$" . reverse @@ -160,3 +177,8 @@ withNumber _ v = typeMismatch "Number" v withBool :: (Bool -> Parser a) -> Value -> Parser a withBool p (Bool b) = p b withBool _ v = typeMismatch "Boolean" v + +warn :: String -> Parser () +warn s = do + path <- getPath + Parser . modify $ \ st -> st {parserStateWarnings = (path, s) : parserStateWarnings st} diff --git a/src/Hpack/Config.hs b/src/Hpack/Config.hs index 63deee7e..a8425570 100644 --- a/src/Hpack/Config.hs +++ b/src/Hpack/Config.hs @@ -849,16 +849,18 @@ sectionAll f sect = f sect <> foldMap (foldMap $ sectionAll f) (sectionCondition decodeValue :: FromValue a => ProgramName -> FilePath -> Value -> Warnings (Errors IO) a decodeValue (ProgramName programName) file value = do - (r, unknown) <- lift . ExceptT . return $ first (prefix ++) (Config.decodeValue value) + (r, warnings) <- lift . ExceptT . return $ first (prefix ++) (Config.decodeValue value) case r of UnsupportedSpecVersion v -> do lift $ throwE ("The file " ++ file ++ " requires version " ++ showVersion v ++ " of the Hpack package specification, however this version of " ++ programName ++ " only supports versions up to " ++ showVersion Hpack.version ++ ". Upgrading to the latest version of " ++ programName ++ " may resolve this issue.") SupportedSpecVersion a -> do - tell (map formatUnknownField unknown) + tell (map formatWarning warnings) return a where prefix = file ++ ": " - formatUnknownField name = prefix ++ "Ignoring unrecognized field " ++ name + formatWarning warning = prefix ++ case warning of + Warning path (WarningReason reason) -> reason <> " in " <> path + Warning path UnknownField -> "Ignoring unrecognized field " <> path data CheckSpecVersion a = SupportedSpecVersion a | UnsupportedSpecVersion Version diff --git a/src/Hpack/Yaml.hs b/src/Hpack/Yaml.hs index c68c427c..8da4cfff 100644 --- a/src/Hpack/Yaml.hs +++ b/src/Hpack/Yaml.hs @@ -20,13 +20,13 @@ module Hpack.Yaml ( import Data.Bifunctor import Data.Yaml hiding (decodeFile, decodeFileWithWarnings) import Data.Yaml.Include -import Data.Yaml.Internal (Warning(..)) +import qualified Data.Yaml.Internal as Yaml import Data.Aeson.Config.FromValue import Data.Aeson.Config.Parser (fromAesonPath, formatPath) -formatWarning :: FilePath -> Warning -> String +formatWarning :: FilePath -> Yaml.Warning -> String formatWarning file = \ case - DuplicateKey path -> file ++ ": Duplicate field " ++ formatPath (fromAesonPath path) + Yaml.DuplicateKey path -> file ++ ": Duplicate field " ++ formatPath (fromAesonPath path) decodeYaml :: FilePath -> IO (Either String ([String], Value)) decodeYaml file = do diff --git a/test/Data/Aeson/Config/FromValueSpec.hs b/test/Data/Aeson/Config/FromValueSpec.hs index 06b3eb9f..ff3a32ec 100644 --- a/test/Data/Aeson/Config/FromValueSpec.hs +++ b/test/Data/Aeson/Config/FromValueSpec.hs @@ -52,7 +52,7 @@ spec = do name: "Joe" age: 23 foo: bar - |] `shouldDecodeTo` Right (Person "Joe" 23 Nothing, ["$.foo"]) + |] `shouldDecodeTo` Right (Person "Joe" 23 Nothing, [unknownField "$.foo"]) it "captures nested unrecognized fields" $ do [yaml| @@ -63,7 +63,7 @@ spec = do zip: "123456" foo: bar: 23 - |] `shouldDecodeTo` Right (Person "Joe" 23 (Just (Address "somewhere" "123456")), ["$.address.foo"]) + |] `shouldDecodeTo` Right (Person "Joe" 23 (Just (Address "somewhere" "123456")), [unknownField "$.address.foo"]) it "ignores fields that start with an underscore" $ do [yaml| @@ -95,7 +95,7 @@ spec = do role: engineer salary: 100000 foo: bar - |] `shouldDecodeTo` Right ((Person "Joe" 23 Nothing, Job "engineer" 100000), ["$.foo"]) + |] `shouldDecodeTo` Right ((Person "Joe" 23 Nothing, Job "engineer" 100000), [unknownField "$.foo"]) context "with []" $ do it "captures unrecognized fields" $ do @@ -111,7 +111,7 @@ spec = do - name: "Marry" age: 25 bar: 42 - |] `shouldDecodeTo` Right (expected, ["$[1].bar", "$[0].address.foo"]) + |] `shouldDecodeTo` Right (expected, [unknownField "$[1].bar", unknownField "$[0].address.foo"]) context "with Map" $ do it "captures unrecognized fields" $ do @@ -120,4 +120,4 @@ spec = do region: somewhere zip: '123456' foo: bar - |] `shouldDecodeTo` Right (Map.fromList [("Joe", Address "somewhere" "123456")], ["$.Joe.foo"]) + |] `shouldDecodeTo` Right (Map.fromList [("Joe", Address "somewhere" "123456")], [unknownField "$.Joe.foo"]) diff --git a/test/Helper.hs b/test/Helper.hs index 8b40088c..9ae7fc67 100644 --- a/test/Helper.hs +++ b/test/Helper.hs @@ -10,6 +10,7 @@ module Helper ( , module System.FilePath , withCurrentDirectory , yaml +, unknownField ) where import Test.Hspec @@ -26,6 +27,7 @@ import Data.Yaml.TH (yamlQQ) import Language.Haskell.TH.Quote (QuasiQuoter) import Hpack.Config +import Data.Aeson.Config.FromValue instance IsString Cond where fromString = CondExpression @@ -42,3 +44,6 @@ withTempDirectory action = Temp.withSystemTempDirectory "hspec" $ \dir -> do yaml :: Language.Haskell.TH.Quote.QuasiQuoter yaml = yamlQQ + +unknownField :: String -> Warning +unknownField path = Warning path UnknownField diff --git a/test/Hpack/Syntax/DependenciesSpec.hs b/test/Hpack/Syntax/DependenciesSpec.hs index 9d167759..69ad15f9 100644 --- a/test/Hpack/Syntax/DependenciesSpec.hs +++ b/test/Hpack/Syntax/DependenciesSpec.hs @@ -212,7 +212,7 @@ spec = do outer-name: name: inner-name path: somewhere - |] `shouldDecodeTo` Right (Dependencies [("outer-name", defaultInfo { dependencyInfoVersion = DependencyVersion source AnyVersion })], ["$.outer-name.name"]) + |] `shouldDecodeTo` Right (Dependencies [("outer-name", defaultInfo { dependencyInfoVersion = DependencyVersion source AnyVersion })], [unknownField "$.outer-name.name"]) it "defaults to any version" $ do [yaml| From f9f91b8d20a9c9ad2afb706c75a2699f789bc32f Mon Sep 17 00:00:00 2001 From: Simon Hengel Date: Thu, 21 Jan 2021 00:58:38 +0700 Subject: [PATCH 3/3] Warn on spaces in module names --- src/Hpack/Module.hs | 6 +++++- test/EndToEndSpec.hs | 11 +++++++++++ 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/src/Hpack/Module.hs b/src/Hpack/Module.hs index cc849919..8bb2b573 100644 --- a/src/Hpack/Module.hs +++ b/src/Hpack/Module.hs @@ -33,7 +33,11 @@ instance IsString Module where fromString = Module instance FromValue Module where - fromValue = fmap Module . fromValue + fromValue v = do + r <- fromValue v + case words r of + [name] -> return (Module name) + _ -> warn ("invalid module name " ++ show r) >> return (Module r) toModule :: Path -> Module toModule path = case reverse $ Path.components path of diff --git a/test/EndToEndSpec.hs b/test/EndToEndSpec.hs index 227de42b..bf2b702c 100644 --- a/test/EndToEndSpec.hs +++ b/test/EndToEndSpec.hs @@ -70,6 +70,17 @@ spec = around_ (inTempDirectoryNamed "foo") $ do "package.yaml: Duplicate field $.name" ] + context "when a module name contains spaces" $ do + it "warns" $ do + [i| + name: foo + library: + other-modules: + Foo + Bar + Baz + |] `shouldWarn` ["package.yaml: invalid module name \"Foo Bar Baz\" in $.library.other-modules"] + describe "handling of Paths_ module" $ do it "adds Paths_ to other-modules" $ do [i|