Skip to content

Commit c5ead5f

Browse files
borsboomborsboom
committed
Give warnings on unexpected config keys (commercialhaskell#48)
1 parent af0fa73 commit c5ead5f

8 files changed

Lines changed: 233 additions & 90 deletions

File tree

‎ChangeLog.md‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@
1111
* --force-dirty flag: Force treating all local packages as having dirty files (useful for cases where stack can't detect a file change)
1212
* GHC error messages: display file paths as absolute instead of relative for better editor integration
1313
* Add the `--copy-bins` option [#569](https://github.com/commercialhaskell/stack/issues/569)
14+
* Give warnings on unexpected config keys [#48](https://github.com/commercialhaskell/stack/issues/48)
1415

1516
Bug fixes:
1617

‎src/Data/Aeson/Extended.hs‎

Lines changed: 133 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -1,23 +1,151 @@
1-
-- | The purpose of this module is to provide better failure messages
2-
-- When parsing a key of an object, this makes sure the key itself will show up
1+
{-# LANGUAGE OverloadedStrings, RecordWildCards, TemplateHaskell, TupleSections #-}
2+
3+
-- | Extensions to Aeson parsing of objects.
34
module Data.Aeson.Extended (
45
module Export
6+
-- * Extended failure messages
57
, (.:)
68
, (.:?)
9+
-- * JSON Parser that emits warnings
10+
, WarningParser
11+
, JSONWarning (..)
12+
, withObjectWarnings
13+
, (..:)
14+
, (..:?)
15+
, (..!=)
16+
, jsonSubWarnings
17+
, jsonSubWarningsT
18+
, jsonSubWarningsMT
19+
, logJSONWarnings
720
) where
821

22+
import Control.Monad.Logger (MonadLogger, logWarn)
23+
import Control.Monad.Trans (lift)
24+
import Control.Monad.Trans.Writer.Strict (WriterT, mapWriterT, runWriterT, tell)
925
import Data.Aeson as Export hiding ((.:), (.:?))
1026
import qualified Data.Aeson as A
11-
1227
import Data.Aeson.Types hiding ((.:), (.:?))
13-
28+
import qualified Data.HashMap.Strict as HashMap
29+
import Data.Monoid (Monoid (..), (<>))
30+
import Data.Set (Set)
31+
import qualified Data.Set as Set
1432
import Data.Text (unpack, Text)
15-
import Data.Monoid ((<>))
33+
import qualified Data.Text as T
34+
import Data.Traversable (Traversable)
35+
import qualified Data.Traversable as Traversable
1636

37+
-- | Extends @.:@ warning to include field name.
1738
(.:) :: FromJSON a => Object -> Text -> Parser a
1839
(.:) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..: p)
1940
{-# INLINE (.:) #-}
2041

42+
-- | Extends @.:?@ warning to include field name.
2143
(.:?) :: FromJSON a => Object -> Text -> Parser (Maybe a)
2244
(.:?) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..:? p)
2345
{-# INLINE (.:?) #-}
46+
47+
-- | 'WarningParser' version of @.:@.
48+
(..:)
49+
:: FromJSON a
50+
=> Object -> Text -> WarningParser a
51+
o ..: k = tellField k >> lift (o .: k)
52+
53+
-- | 'WarningParser' version of @.:?@.
54+
(..:?)
55+
:: FromJSON a
56+
=> Object -> Text -> WarningParser (Maybe a)
57+
o ..:? k = tellField k >> lift (o .:? k)
58+
59+
-- | 'WarningParser' version of @.!=@.
60+
(..!=) :: WarningParser (Maybe a) -> a -> WarningParser a
61+
wp ..!= d =
62+
flip mapWriterT wp $
63+
\p ->
64+
do a <- fmap snd p
65+
fmap (, a) (fmap fst p .!= d)
66+
67+
-- | Tell warning parser about about an expected field.
68+
tellField :: Text -> WarningParser ()
69+
tellField key = tell (mempty { wpmExpectedFields = Set.singleton key})
70+
71+
-- | 'MonadParser' version of 'withObject'.
72+
withObjectWarnings :: String
73+
-> (Object -> WarningParser a)
74+
-> Value
75+
-> Parser (a, [JSONWarning])
76+
withObjectWarnings expected f =
77+
withObject expected $
78+
\obj ->
79+
do (a,w) <- runWriterT (f obj)
80+
let unrecognizedFields =
81+
Set.toList
82+
(Set.difference
83+
(Set.fromList (HashMap.keys obj))
84+
(wpmExpectedFields w))
85+
return
86+
( a
87+
, wpmWarnings w ++
88+
case unrecognizedFields of
89+
[] -> []
90+
_ -> [JSONUnrecognizedFields expected unrecognizedFields])
91+
92+
-- | Log JSON warnings.
93+
logJSONWarnings
94+
:: MonadLogger m
95+
=> FilePath -> [JSONWarning] -> m ()
96+
logJSONWarnings fp =
97+
mapM_ (\w -> $logWarn ("Warning: " <> T.pack fp <> ": " <> T.pack (show w)))
98+
99+
-- | Handle warnings in a sub-object.
100+
jsonSubWarnings :: WarningParser (a, [JSONWarning]) -> WarningParser a
101+
jsonSubWarnings f = do
102+
(result,warnings) <- f
103+
tell
104+
(mempty
105+
{ wpmWarnings = warnings
106+
})
107+
return result
108+
109+
-- | Handle warnings in a @Traversable@ of sub-objects.
110+
jsonSubWarningsT
111+
:: Traversable t
112+
=> WarningParser (t (a, [JSONWarning])) -> WarningParser (t a)
113+
jsonSubWarningsT f =
114+
Traversable.mapM (jsonSubWarnings . return) =<< f
115+
116+
-- | Handle warnings in a @Maybe Traversable@ of sub-objects.
117+
jsonSubWarningsMT
118+
:: (Traversable t)
119+
=> WarningParser (Maybe (t (a, [JSONWarning])))
120+
-> WarningParser (Maybe (t a))
121+
jsonSubWarningsMT f = do
122+
ml <- f
123+
case ml of
124+
Nothing -> return Nothing
125+
Just l -> fmap Just (jsonSubWarningsT (return l))
126+
127+
-- | JSON parser that warns about unexpected fields in objects.
128+
type WarningParser a = WriterT WarningParserMonoid Parser a
129+
130+
-- | Monoid used by 'MonadParser' to track expected fields and warnings.
131+
data WarningParserMonoid = WarningParserMonoid
132+
{ wpmExpectedFields :: !(Set Text)
133+
, wpmWarnings :: [JSONWarning]
134+
}
135+
instance Monoid WarningParserMonoid where
136+
mempty = WarningParserMonoid Set.empty []
137+
mappend a b =
138+
WarningParserMonoid
139+
{ wpmExpectedFields = Set.union
140+
(wpmExpectedFields a)
141+
(wpmExpectedFields b)
142+
, wpmWarnings = wpmWarnings a ++ wpmWarnings b
143+
}
144+
145+
-- | Warning output from 'WarningParser'.
146+
data JSONWarning = JSONUnrecognizedFields String [Text]
147+
instance Show JSONWarning where
148+
show (JSONUnrecognizedFields obj [field]) =
149+
"Unrecognized field in " <> obj <> ": " <> T.unpack field
150+
show (JSONUnrecognizedFields obj fields) =
151+
"Unrecognized fields in " <> obj <> ": " <> T.unpack (T.intercalate ", " fields)

‎src/Stack/Config.hs‎

Lines changed: 8 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -418,10 +418,14 @@ getExtraConfigs stackRoot = liftIO $ do
418418
: maybe [] return (mstackGlobalConfig <|> defaultStackGlobalConfig)
419419

420420
-- | Load and parse YAML from the given file.
421-
loadYaml :: (FromJSON a,MonadIO m) => Path Abs File -> m a
422-
loadYaml path =
423-
liftIO $ Yaml.decodeFileEither (toFilePath path)
424-
>>= either (throwM . ParseConfigFileException path) return
421+
loadYaml :: (FromJSON (a, [JSONWarning]), MonadIO m, MonadLogger m) => Path Abs File -> m a
422+
loadYaml path = do
423+
(result,warnings) <-
424+
liftIO $
425+
Yaml.decodeFileEither (toFilePath path) >>=
426+
either (throwM . ParseConfigFileException path) return
427+
logJSONWarnings (toFilePath path) warnings
428+
return result
425429

426430
-- | Get the location of the project config file, if it exists.
427431
getProjectConfig :: (MonadIO m, MonadThrow m, MonadLogger m)

‎src/Stack/Docker.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -157,7 +157,7 @@ runContainerAndExit modConfig
157157
pwd <- getWorkingDir
158158
when (maybe False (isPrefixOf "tcp://") dockerHost &&
159159
maybe False (isInfixOf "boot2docker") dockerCertPath)
160-
($logWarn "WARNING: Using boot2docker is NOT supported, and not likely to perform well.")
160+
($logWarn "Warning: Using boot2docker is NOT supported, and not likely to perform well.")
161161
let image = dockerImage docker
162162
maybeImageInfo <- inspect envOverride image
163163
imageInfo <- case maybeImageInfo of

‎src/Stack/Solver.hs‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -14,7 +14,7 @@ import Control.Monad.IO.Class
1414
import Control.Monad.Logger
1515
import Control.Monad.Reader
1616
import Control.Monad.Trans.Control
17-
import Data.Aeson (object, (.=), toJSON)
17+
import Data.Aeson.Extended (object, (.=), toJSON, logJSONWarnings)
1818
import qualified Data.ByteString as S
1919
import qualified Data.ByteString.Char8 as S8
2020
import Data.Either
@@ -181,7 +181,9 @@ solveExtraDeps modStackYaml = do
181181
when modStackYaml $ do
182182
let fp = toFilePath $ bcStackYaml bconfig
183183
obj <- liftIO (Yaml.decodeFileEither fp) >>= either throwM return
184-
ProjectAndConfigMonoid project _ <- liftIO (Yaml.decodeFileEither fp) >>= either throwM return
184+
(ProjectAndConfigMonoid project _, warnings) <-
185+
liftIO (Yaml.decodeFileEither fp) >>= either throwM return
186+
logJSONWarnings fp warnings
185187
let obj' =
186188
HashMap.insert "extra-deps"
187189
(toJSON $ map fromTuple $ Map.toList

‎src/Stack/Types/Config.hs‎

Lines changed: 62 additions & 54 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
{-# LANGUAGE DefaultSignatures #-}
22
{-# LANGUAGE DeriveDataTypeable #-}
3+
{-# LANGUAGE FlexibleInstances #-}
34
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
45
{-# LANGUAGE OverloadedStrings #-}
56
{-# LANGUAGE TemplateHaskell #-}
@@ -15,8 +16,11 @@ import Control.Monad (liftM, mzero)
1516
import Control.Monad.Catch (MonadThrow, throwM)
1617
import Control.Monad.Reader (MonadReader, ask, asks, MonadIO, liftIO)
1718
import Control.Monad.Logger (LogLevel(..))
18-
import Data.Aeson.Extended (ToJSON, toJSON, FromJSON, parseJSON, withText, withObject, object
19-
,(.=), (.:?), (.!=), (.:), Value (String, Object))
19+
import Data.Aeson.Extended
20+
(ToJSON, toJSON, FromJSON, parseJSON, withText, withObject, object,
21+
(.=), (.:), (..:), (..:?), (..!=), Value(String),
22+
withObjectWarnings, WarningParser, Object, jsonSubWarnings, JSONWarning,
23+
jsonSubWarningsMT)
2024
import Data.Binary (Binary)
2125
import Data.ByteString (ByteString)
2226
import qualified Data.ByteString.Char8 as S8
@@ -121,12 +125,12 @@ data PackageIndex = PackageIndex
121125
-- ^ Require that hashes and package size information be available for packages in this index
122126
}
123127
deriving Show
124-
instance FromJSON PackageIndex where
125-
parseJSON = withObject "PackageIndex" $ \o -> do
126-
name <- o .: "name"
127-
prefix <- o .: "download-prefix"
128-
mgit <- o .:? "git"
129-
mhttp <- o .:? "http"
128+
instance FromJSON (PackageIndex, [JSONWarning]) where
129+
parseJSON = withObjectWarnings "PackageIndex" $ \o -> do
130+
name <- o ..: "name"
131+
prefix <- o ..: "download-prefix"
132+
mgit <- o ..:? "git"
133+
mhttp <- o ..:? "http"
130134
loc <-
131135
case (mgit, mhttp) of
132136
(Nothing, Nothing) -> fail $
@@ -135,8 +139,8 @@ instance FromJSON PackageIndex where
135139
(Just git, Nothing) -> return $ ILGit git
136140
(Nothing, Just http) -> return $ ILHttp http
137141
(Just git, Just http) -> return $ ILGitHttp git http
138-
gpgVerify <- o .:? "gpg-verify" .!= False
139-
reqHashes <- o .:? "require-hashes" .!= False
142+
gpgVerify <- o ..:? "gpg-verify" ..!= False
143+
reqHashes <- o ..:? "require-hashes" ..!= False
140144
return PackageIndex
141145
{ indexName = name
142146
, indexLocation = loc
@@ -293,20 +297,20 @@ instance ToJSON PackageEntry where
293297
, "location" .= peLocation pe
294298
, "subdirs" .= peSubdirs pe
295299
]
296-
instance FromJSON PackageEntry where
300+
instance FromJSON (PackageEntry, [JSONWarning]) where
297301
parseJSON (String t) = do
298302
loc <- parseJSON $ String t
299-
return PackageEntry
300-
{ peExtraDepMaybe = Nothing
301-
, peValidWanted = Nothing
302-
, peLocation = loc
303-
, peSubdirs = []
304-
}
305-
parseJSON v = withObject "PackageEntry" (\o -> PackageEntry
306-
<$> o .:? "extra-dep"
307-
<*> o .:? "valid-wanted"
308-
<*> o .: "location"
309-
<*> o .:? "subdirs" .!= []) v
303+
return (PackageEntry
304+
{ peExtraDepMaybe = Nothing
305+
, peValidWanted = Nothing
306+
, peLocation = loc
307+
, peSubdirs = []
308+
}, [])
309+
parseJSON v = withObjectWarnings "PackageEntry" (\o -> PackageEntry
310+
<$> o ..:? "extra-dep"
311+
<*> o ..:? "valid-wanted"
312+
<*> o ..: "location"
313+
<*> o ..:? "subdirs" ..!= []) v
310314

311315
data PackageLocation
312316
= PLFilePath FilePath
@@ -528,31 +532,35 @@ instance Monoid ConfigMonoid where
528532
, configMonoidImageOpts = configMonoidImageOpts l <> configMonoidImageOpts r
529533
}
530534

531-
instance FromJSON ConfigMonoid where
532-
parseJSON =
533-
withObject "ConfigMonoid" $
534-
\obj ->
535-
do configMonoidDockerOpts <- obj .:? T.pack "docker" .!= mempty
536-
configMonoidConnectionCount <- obj .:? "connection-count"
537-
configMonoidHideTHLoading <- obj .:? "hide-th-loading"
538-
configMonoidLatestSnapshotUrl <- obj .:? "latest-snapshot-url"
539-
configMonoidPackageIndices <- obj .:? "package-indices"
540-
configMonoidSystemGHC <- obj .:? "system-ghc"
541-
configMonoidInstallGHC <- obj .:? "install-ghc"
542-
configMonoidSkipGHCCheck <- obj .:? "skip-ghc-check"
543-
configMonoidSkipMsys <- obj .:? "skip-msys"
544-
configMonoidRequireStackVersion <- unVersionRangeJSON <$>
545-
obj .:? "require-stack-version"
546-
.!= VersionRangeJSON anyVersion
547-
configMonoidOS <- obj .:? "os"
548-
configMonoidArch <- obj .:? "arch"
549-
configMonoidJobs <- obj .:? "jobs"
550-
configMonoidExtraIncludeDirs <- obj .:? "extra-include-dirs" .!= Set.empty
551-
configMonoidExtraLibDirs <- obj .:? "extra-lib-dirs" .!= Set.empty
552-
configMonoidConcurrentTests <- obj .:? "concurrent-tests"
553-
configMonoidLocalBinPath <- obj .:? "local-bin-path"
554-
configMonoidImageOpts <- obj .:? T.pack "image" .!= mempty
555-
return ConfigMonoid {..}
535+
instance FromJSON (ConfigMonoid, [JSONWarning]) where
536+
parseJSON = withObjectWarnings "ConfigMonoid" parseConfigMonoidJSON
537+
538+
-- | Parse a partial configuration. Used both to parse both a standalone config
539+
-- file and a project file, so that a sub-parser is not required, which would interfere with
540+
-- warnings for missing fields.
541+
parseConfigMonoidJSON :: Object -> WarningParser ConfigMonoid
542+
parseConfigMonoidJSON obj = do
543+
configMonoidDockerOpts <- jsonSubWarnings (obj ..:? "docker" ..!= mempty)
544+
configMonoidConnectionCount <- obj ..:? "connection-count"
545+
configMonoidHideTHLoading <- obj ..:? "hide-th-loading"
546+
configMonoidLatestSnapshotUrl <- obj ..:? "latest-snapshot-url"
547+
configMonoidPackageIndices <- jsonSubWarningsMT (obj ..:? "package-indices")
548+
configMonoidSystemGHC <- obj ..:? "system-ghc"
549+
configMonoidInstallGHC <- obj ..:? "install-ghc"
550+
configMonoidSkipGHCCheck <- obj ..:? "skip-ghc-check"
551+
configMonoidSkipMsys <- obj ..:? "skip-msys"
552+
configMonoidRequireStackVersion <- unVersionRangeJSON <$>
553+
obj ..:? "require-stack-version"
554+
..!= VersionRangeJSON anyVersion
555+
configMonoidOS <- obj ..:? "os"
556+
configMonoidArch <- obj ..:? "arch"
557+
configMonoidJobs <- obj ..:? "jobs"
558+
configMonoidExtraIncludeDirs <- obj ..:? "extra-include-dirs" ..!= Set.empty
559+
configMonoidExtraLibDirs <- obj ..:? "extra-lib-dirs" ..!= Set.empty
560+
configMonoidConcurrentTests <- obj ..:? "concurrent-tests"
561+
configMonoidLocalBinPath <- obj ..:? "local-bin-path"
562+
configMonoidImageOpts <- jsonSubWarnings (obj ..:? "image" ..!= mempty)
563+
return ConfigMonoid {..}
556564

557565
-- | Newtype for non-orphan FromJSON instance.
558566
newtype VersionRangeJSON = VersionRangeJSON { unVersionRangeJSON :: VersionRange }
@@ -778,18 +786,18 @@ getMinimalEnvOverride = do
778786
data ProjectAndConfigMonoid
779787
= ProjectAndConfigMonoid !Project !ConfigMonoid
780788

781-
instance FromJSON ProjectAndConfigMonoid where
782-
parseJSON = withObject "Project, ConfigMonoid" $ \o -> do
783-
dirs <- o .:? "packages" .!= [packageEntryCurrDir]
784-
extraDeps' <- o .:? "extra-deps" .!= []
789+
instance FromJSON (ProjectAndConfigMonoid, [JSONWarning]) where
790+
parseJSON = withObjectWarnings "ProjectAndConfigMonoid" $ \o -> do
791+
dirs <- jsonSubWarningsMT (o ..:? "packages") ..!= [packageEntryCurrDir]
792+
extraDeps' <- o ..:? "extra-deps" ..!= []
785793
extraDeps <-
786794
case partitionEithers $ goDeps extraDeps' of
787795
([], x) -> return $ Map.fromList x
788796
(errs, _) -> fail $ unlines errs
789797

790-
flags <- o .:? "flags" .!= mempty
791-
resolver <- o .: "resolver"
792-
config <- parseJSON $ Object o
798+
flags <- o ..:? "flags" ..!= mempty
799+
resolver <- o ..: "resolver"
800+
config <- parseConfigMonoidJSON o
793801
let project = Project
794802
{ projectPackages = dirs
795803
, projectExtraDeps = extraDeps

0 commit comments

Comments
 (0)