diff --git a/etc.cabal b/etc.cabal --- a/etc.cabal +++ b/etc.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: etc -version: 0.0.0.1 +version: 0.0.0.2 synopsis: Declarative configuration spec for Haskell projects description: Please see README.md category: Configuration, System @@ -30,8 +30,8 @@ type: git location: https://github.com/roman/Haskell-etc -flag printer - description: Include support for config printer +flag extra + description: Include extra utilities manual: False default: False @@ -78,12 +78,15 @@ default-language: Haskell2010 - if flag(printer) - cpp-options: -DWITH_PRINTER + if flag(extra) + cpp-options: -DWITH_EXTRA build-depends: - ansi-wl-pprint >=0.6 && <0.7 + ansi-wl-pprint >=0.6 && <0.7, + edit-distance >=0.2 && <0.3 + exposed-modules: - System.Etc.Internal.Printer + System.Etc.Internal.Extra.Printer + System.Etc.Internal.Extra.EnvMisspell if flag(cli) cpp-options: -DWITH_CLI @@ -130,6 +133,10 @@ cpp-options: -DWITH_YAML build-depends: yaml >=0.8 && <0.9 + if flag(extra) + cpp-options: -DWITH_EXTRA + build-depends: + edit-distance >=0.2 && <0.3 other-modules: Paths_etc System.Etc.Resolver.CliTest @@ -138,5 +145,6 @@ System.Etc.Resolver.DefaultTest System.Etc.Resolver.EnvTest System.Etc.Resolver.FileTest + System.Etc.Extra.EnvMisspellTest System.Etc.SpecTest default-language: Haskell2010 diff --git a/src/System/Etc.hs b/src/System/Etc.hs --- a/src/System/Etc.hs +++ b/src/System/Etc.hs @@ -43,12 +43,19 @@ , CliConfigError(..) #endif -#ifdef WITH_PRINTER - -- * Printer - -- $printer +#ifdef WITH_EXTRA + -- * Extra utilities + -- $extra , renderConfig , printPrettyConfig , hPrintPrettyConfig + + , EnvMisspell(..) + , getEnvMisspellings + , getEnvMisspellingsPure + , renderEnvMisspellings + , hPrintEnvMisspellings + , reportEnvMisspellingWarnings #endif ) where @@ -63,8 +70,17 @@ import System.Etc.Internal.Resolver.Cli.Plain (resolvePlainCli, resolvePlainCliPure) #endif -#ifdef WITH_PRINTER -import System.Etc.Internal.Printer (hPrintPrettyConfig, printPrettyConfig, renderConfig) +#ifdef WITH_EXTRA +import System.Etc.Internal.Extra.EnvMisspell + ( EnvMisspell (..) + , getEnvMisspellings + , getEnvMisspellingsPure + , hPrintEnvMisspellings + , renderEnvMisspellings + , reportEnvMisspellingWarnings + ) +import System.Etc.Internal.Extra.Printer + (hPrintPrettyConfig, printPrettyConfig, renderConfig) #endif import System.Etc.Internal.Config @@ -93,8 +109,7 @@ together using the mappend function -} -{- $printer +{- $extra - Use these function to render the configuration map and understand how the - resolving was performed. + Some extra utilities that are great for debugging (miss)-configurations. -} diff --git a/src/System/Etc/Internal/Extra/EnvMisspell.hs b/src/System/Etc/Internal/Extra/EnvMisspell.hs new file mode 100644 --- /dev/null +++ b/src/System/Etc/Internal/Extra/EnvMisspell.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module System.Etc.Internal.Extra.EnvMisspell ( + EnvMisspell (..) + , getEnvMisspellings + , getEnvMisspellingsPure + , renderEnvMisspellings + , hPrintEnvMisspellings + , reportEnvMisspellingWarnings + ) where + +import Protolude hiding ((<$>), (<>)) + +import Data.Vector (Vector) +import System.Environment (getEnvironment) + +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Text as Text +import qualified Data.Vector as Vector +import qualified Text.EditDistance as Distance + +import System.Etc.Internal.Spec.Types +import Text.PrettyPrint.ANSI.Leijen + +data EnvMisspell + = EnvMisspell { + currentText :: Text + , suggestionText :: Text + } + deriving (Show, Eq, Generic) + +lookupSpecEnvKeys :: ConfigSpec a -> Vector Text +lookupSpecEnvKeys spec = + let + foldEnvSettings val acc = + case val of + ConfigValue _ sources -> + maybe acc (`Vector.cons` acc) (envVar sources) + SubConfig hsh -> + HashMap.foldr foldEnvSettings acc hsh + in + foldEnvSettings (SubConfig $ specConfigValues spec) Vector.empty + +{-| + +-} +getEnvMisspellingsPure :: ConfigSpec a -> Vector Text -> Vector EnvMisspell +getEnvMisspellingsPure spec env = do + specEnvName <- lookupSpecEnvKeys spec + currentEnvName <- env + + let + distance = + Distance.levenshteinDistance + Distance.defaultEditCosts + (Text.unpack specEnvName) + (Text.unpack currentEnvName) + + guard (distance >= 1 && distance < 4) + return $ EnvMisspell currentEnvName specEnvName + +{-| + +-} +getEnvMisspellings :: ConfigSpec a -> IO (Vector EnvMisspell) +getEnvMisspellings spec = + getEnvironment + & fmap (Vector.fromList . map (Text.pack . fst)) + & fmap (getEnvMisspellingsPure spec) + +{-| + +-} +renderEnvMisspellings :: Vector EnvMisspell -> Doc +renderEnvMisspellings misspells + | Vector.null misspells = + mempty + | otherwise = + misspells + & Vector.map + (\misspell -> + text "WARNING: Environment variable `" + <> text (Text.unpack $ currentText misspell) + <> text "' found, perhaps you meant `" + <> text (Text.unpack $ suggestionText misspell) + <> text "'") + & Vector.foldl' (<$>) mempty + & (<$> mempty) + & (<$> mempty) + +{-| + +-} +hPrintEnvMisspellings :: Handle -> Vector EnvMisspell -> IO () +hPrintEnvMisspellings h = + hPutDoc h . renderEnvMisspellings + +{-| + +-} +reportEnvMisspellingWarnings :: ConfigSpec a -> IO () +reportEnvMisspellingWarnings spec = + getEnvMisspellings spec >>= + hPrintEnvMisspellings stderr diff --git a/src/System/Etc/Internal/Extra/Printer.hs b/src/System/Etc/Internal/Extra/Printer.hs new file mode 100644 --- /dev/null +++ b/src/System/Etc/Internal/Extra/Printer.hs @@ -0,0 +1,144 @@ +{-# OPTIONS_GHC -fno-warn-deprecations #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +module System.Etc.Internal.Extra.Printer ( + renderConfig + , printPrettyConfig + , hPrintPrettyConfig + ) where + +import Protolude hiding ((<>)) + +import qualified Data.Aeson as JSON +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Set as Set +import qualified Data.Text as Text + +import Text.PrettyPrint.ANSI.Leijen + +import System.Etc.Internal.Types + +renderJsonValue :: JSON.Value -> (Doc, Int) +renderJsonValue value' = + case value' of + JSON.String str -> + (text $ Text.unpack str, Text.length str) + + JSON.Number scientific -> + let + number = + show scientific + in + (text number, length number) + JSON.Bool bool' -> + if bool' then + (text "true", 5) + else + (text "false", 5) + _ -> + value' + & show + & ("Invalid configuration value creation " `mappend`) + & InvalidConfiguration + & show + & error + + +renderConfig :: Config -> Doc +renderConfig (Config configValue0) = + let + brackets' = enclose (lbracket <> space) (space <> rbracket) + + renderSource :: ConfigSource -> ((Doc, Int), Doc) + renderSource source' = + case source' of + Default value' -> + ( renderJsonValue value' + , brackets' (fill 10 (text "Default")) + ) + + File _index filepath' value' -> + ( renderJsonValue value' + , brackets' (fill 10 (text "File:" <+> text (Text.unpack filepath'))) + ) + + Env varname value' -> + ( renderJsonValue value' + , brackets' (fill 10 (text "Env:" <+> text (Text.unpack varname))) + ) + + Cli value' -> + ( renderJsonValue value' + , brackets' (fill 10 (text "Cli")) + ) + + None -> + ( (mempty, 0) + , mempty + ) + + renderSources :: [ConfigSource] -> Doc + renderSources sources0 = + let + sources@(((selValueDoc, _), selSourceDoc):others) = + map renderSource sources0 + + fillingWidth = + sources + & map (snd . fst) + & maximum + & max 10 + + selectedValue = + [ green $ fill fillingWidth selValueDoc <+> selSourceDoc ] + + otherValues = + map (\((valueDoc, _), sourceDoc) -> + fill fillingWidth valueDoc <+> sourceDoc) + others + in + selectedValue + & flip mappend otherValues + & vcat + & indent 2 + + configEntryRenderer :: [Text] -> [Doc] -> Text -> ConfigValue -> [Doc] + configEntryRenderer keys resultDoc configKey configValue = + resultDoc `mappend` loop (configKey : keys) configValue + + loop keys configValue = + case configValue of + SubConfig subConfigm -> + HashMap.foldlWithKey' + (configEntryRenderer keys) + mempty + subConfigm + + ConfigValue sources0 -> + let + configKey = + keys + & reverse + & Text.intercalate "." + + sources = + Set.toDescList sources0 + in + if null sources then + [] + else + [ blue (text (Text.unpack configKey)) + <$$> renderSources sources ] + in + loop [] configValue0 + & intersperse (linebreak <> linebreak) + & hcat + & (<> linebreak) + +printPrettyConfig :: Config -> IO () +printPrettyConfig = + putDoc . renderConfig + +hPrintPrettyConfig :: Handle -> Config -> IO () +hPrintPrettyConfig handle' = + hPutDoc handle' . renderConfig diff --git a/src/System/Etc/Internal/Printer.hs b/src/System/Etc/Internal/Printer.hs deleted file mode 100644 --- a/src/System/Etc/Internal/Printer.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-deprecations #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -module System.Etc.Internal.Printer ( - renderConfig - , printPrettyConfig - , hPrintPrettyConfig - ) where - -import Protolude hiding ((<>)) - -import qualified Data.Aeson as JSON -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Set as Set -import qualified Data.Text as Text - -import Text.PrettyPrint.ANSI.Leijen - -import System.Etc.Internal.Types - -renderJsonValue :: JSON.Value -> (Doc, Int) -renderJsonValue value' = - case value' of - JSON.String str -> - (text $ Text.unpack str, Text.length str) - - JSON.Number scientific -> - let - number = - show scientific - in - (text number, length number) - JSON.Bool bool' -> - if bool' then - (text "true", 5) - else - (text "false", 5) - _ -> - value' - & show - & ("Invalid configuration value creation " `mappend`) - & InvalidConfiguration - & show - & error - - -renderConfig :: Config -> Doc -renderConfig (Config configValue0) = - let - brackets' = enclose (lbracket <> space) (space <> rbracket) - - renderSource :: ConfigSource -> ((Doc, Int), Doc) - renderSource source' = - case source' of - Default value' -> - ( renderJsonValue value' - , brackets' (fill 10 (text "Default")) - ) - - File _index filepath' value' -> - ( renderJsonValue value' - , brackets' (fill 10 (text "File:" <+> text (Text.unpack filepath'))) - ) - - Env varname value' -> - ( renderJsonValue value' - , brackets' (fill 10 (text "Env:" <+> text (Text.unpack varname))) - ) - - Cli value' -> - ( renderJsonValue value' - , brackets' (fill 10 (text "Cli")) - ) - - None -> - ( (mempty, 0) - , mempty - ) - - renderSources :: [ConfigSource] -> Doc - renderSources sources0 = - let - sources@(((selValueDoc, _), selSourceDoc):others) = - map renderSource sources0 - - fillingWidth = - sources - & map (snd . fst) - & maximum - & max 10 - - selectedValue = - [ green $ fill fillingWidth selValueDoc <+> selSourceDoc ] - - otherValues = - map (\((valueDoc, _), sourceDoc) -> - fill fillingWidth valueDoc <+> sourceDoc) - others - in - selectedValue - & flip mappend otherValues - & vcat - & indent 2 - - configEntryRenderer :: [Text] -> [Doc] -> Text -> ConfigValue -> [Doc] - configEntryRenderer keys resultDoc configKey configValue = - resultDoc `mappend` loop (configKey : keys) configValue - - loop keys configValue = - case configValue of - SubConfig subConfigm -> - HashMap.foldlWithKey' - (configEntryRenderer keys) - mempty - subConfigm - - ConfigValue sources0 -> - let - configKey = - keys - & reverse - & Text.intercalate "." - - sources = - Set.toDescList sources0 - in - if null sources then - [] - else - [ blue (text (Text.unpack configKey)) - <$$> renderSources sources ] - in - loop [] configValue0 - & intersperse (linebreak <> linebreak) - & hcat - & (<> linebreak) - -printPrettyConfig :: Config -> IO () -printPrettyConfig = - putDoc . renderConfig - -hPrintPrettyConfig :: Handle -> Config -> IO () -hPrintPrettyConfig handle' = - hPutDoc handle' . renderConfig diff --git a/test/System/Etc/Extra/EnvMisspellTest.hs b/test/System/Etc/Extra/EnvMisspellTest.hs new file mode 100644 --- /dev/null +++ b/test/System/Etc/Extra/EnvMisspellTest.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module System.Etc.Extra.EnvMisspellTest where + +import Protolude + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertEqual, testCase) + +import qualified Data.Vector as Vector + +import System.Etc + +tests :: TestTree +tests = + testGroup "env misspells" + [ + testCase "it warns when misspell is present" $ do + let + input = + mconcat + [ + "{\"etc/entries\": {" + , " \"greeting\": { \"etc/spec\": { \"env\": \"GREETING\" }}}}" + ] + + (spec :: ConfigSpec ()) <- parseConfigSpec input + + let + result = + getEnvMisspellingsPure spec ["GREEING"] + + assertBool "expecting to get a warning for typo" + (not $ Vector.null result) + + assertEqual "expecting to get typo for key GREETING" + (EnvMisspell "GREEING" "GREETING") + (Vector.head result) + ] diff --git a/test/TestSuite.hs b/test/TestSuite.hs --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -18,6 +18,10 @@ import qualified System.Etc.Resolver.CliTest #endif +#ifdef WITH_EXTRA +import qualified System.Etc.Extra.EnvMisspellTest +#endif + main :: IO () main = defaultMainWithIngredients @@ -28,5 +32,9 @@ , System.Etc.Resolver.EnvTest.tests #ifdef WITH_CLI , System.Etc.Resolver.CliTest.tests +#endif + +#ifdef WITH_EXTRA + , System.Etc.Extra.EnvMisspellTest.tests #endif ])