diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # Revision history for configurator-pg +## 0.2.0 -- 2020-03-10 + +* Rewrite file parser with Megaparsec instead of + Attoparsec for better error messages. No expected + change in functionality except possibly in + pathological cases. + ## 0.1.0.6 -- 2020-03-08 * Fix GHC 7.10 build by depending on package fail. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -18,7 +18,7 @@ to supply explicit value parsers. - There's only `load` to read and evaluate a configuration file, and `runParser` to extract configuration values. - * Simpler error handling. + * Simpler error handling and improved logging of parse errors. * Simplified handling of configuration subsets. There's `subassocs` and the unit tests pass, but the author didn't attempt to understand the original implementation fully. @@ -28,9 +28,11 @@ The original configurator-ng is due to MailRank, Inc., Bryan O'Sullivan and Leon P Smith. -The low-level parser (Data.Configurator.Syntax) is mostly unchanged, -evaluation (Data.Configurator.Load) is also close to the original. -The high-level parser (Data.Configurator.Parser) is original. +The low-level parser (Data.Configurator.Syntax) was initially +mostly unchanged, but has since been rewritten with Megaparsec +for better error messages. The evaluation (Data.Configurator.Load) +is still close to the original. The high-level parser +(Data.Configurator.Parser) is original. ## File format diff --git a/configurator-pg.cabal b/configurator-pg.cabal --- a/configurator-pg.cabal +++ b/configurator-pg.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: configurator-pg -version: 0.1.0.6 +version: 0.2.0 synopsis: Reduced parser for configurator-ng config files description: This module provides a simplified and updated interface to the @@ -33,7 +33,7 @@ Data.Configurator.Syntax Data.Configurator.Types build-depends: base >= 4.8.2 && < 4.14 - , attoparsec >= 0.13.1 && < 0.14 + , megaparsec >= 7.0.0 && < 8.1 , containers >= 0.5.6.2 && < 0.7 , protolude >= 0.1.10 && < 0.3 , scientific >= 0.3.4.9 && < 0.4 diff --git a/src/Data/Configurator/Load.hs b/src/Data/Configurator/Load.hs --- a/src/Data/Configurator/Load.hs +++ b/src/Data/Configurator/Load.hs @@ -5,7 +5,7 @@ import Protolude import Control.Exception (throw) -import qualified Data.Attoparsec.Text as A +import Text.Megaparsec (parse, errorBundlePretty) import qualified Data.Map.Strict as M import Data.Scientific (toBoundedInteger, toRealFloat) @@ -32,14 +32,14 @@ loadOne :: Path -> IO [Directive] loadOne path = do s <- readFile (T.unpack path) - case A.parseOnly topLevel s of - Left err -> throw $ ParseError $ "parsing " <> path <> ": " <> T.pack err + case parse topLevel (T.unpack path) s of + Left err -> throw $ ParseError $ T.pack $ errorBundlePretty err Right directives -> return directives applyDirective :: Key -> Path -> Config -> Directive -> IO Config applyDirective prefix path config directive = case directive of Bind key (String str) -> do - v <- interpolate prefix str config + v <- interpolate prefix (prefix <> key) str config return $! M.insert (prefix <> key) (String v) config Bind key value -> return $! M.insert (prefix <> key) value config @@ -52,11 +52,11 @@ foldM (applyDirective prefix path') config directives DirectiveComment _ -> return config -interpolate :: Key -> Text -> Config -> IO Text -interpolate prefix s config +interpolate :: Key -> Key -> Text -> Config -> IO Text +interpolate prefix key s config | "$" `T.isInfixOf` s = - case A.parseOnly interp s of - Left err -> throw $ ParseError $ "parsing interpolation: " <> T.pack err + case parse interp ("<" ++ T.unpack key ++ ">") s of + Left err -> throw $ ParseError $ T.pack $ errorBundlePretty err Right xs -> TL.toStrict . toLazyText . mconcat <$> mapM interpret xs | otherwise = return s @@ -78,12 +78,13 @@ case toBoundedInteger r :: Maybe Int64 of Just n -> return (decimal n) Nothing -> return (realFloat (toRealFloat r :: Double)) - Just _ -> throw $ ParseError $ "variable '" <> name <> "' is not a string or number" + Just _ -> throw $ formatErr $ "variable '" <> name <> "' is not a string or number" Nothing -> do var <- System.Environment.lookupEnv (T.unpack name) case var of - Nothing -> throw $ ParseError $ "no such variable: '" <> name <> "'" + Nothing -> throw $ formatErr $ "no such variable: '" <> name <> "'" Just x -> return (fromString x) + formatErr err = ParseError $ "<" <> key <> ">:\n" <> err <> "\n" relativize :: Path -> Path -> Path relativize parent child diff --git a/src/Data/Configurator/Syntax.hs b/src/Data/Configurator/Syntax.hs --- a/src/Data/Configurator/Syntax.hs +++ b/src/Data/Configurator/Syntax.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Module: Data.Configurator.Syntax @@ -20,142 +21,116 @@ import Protolude hiding (First, try) import Control.Monad (fail) -import Data.Attoparsec.Text as A -import Data.Char (isAlpha, isAlphaNum, isSpace) +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as Lexer +import qualified Data.Char as Char import Data.Configurator.Types import qualified Data.Text as T -import qualified Data.Text.Lazy as L -import Data.Text.Lazy.Builder (fromText, singleton, - toLazyText) +type Parser = Parsec Void Text + topLevel :: Parser [Directive] -topLevel = directives <* skipLWS <* endOfInput +topLevel = skipLWS *> directives <* skipLWS <* eof directive :: Parser Directive directive = - mconcat [ - string "import" *> skipLWS *> (Import <$> string_) - , string "#;" *> skipHWS *> (DirectiveComment <$> directive) - , Bind <$> try (ident <* skipLWS <* char '=' <* skipLWS) <*> value - , Group <$> try (ident <* skipLWS <* char '{' <* skipLWS) - <*> directives <* skipLWS <* char '}' - ] + choice + [ do try (keyword "import") <* skipLWS + Import <$> string_ + , do ident <- identifier <* skipLWS + choice + [ Bind ident <$> (char '=' *> skipLWS *> value) + , Group ident <$> brackets '{' '}' directives + ] + , do string "#;" *> skipHWS + DirectiveComment <$> directive + ] directives :: Parser [Directive] -directives = (skipLWS *> directive <* skipHWS) `sepBy` - (satisfy $ \c -> c == '\r' || c == '\n') - -data Skip = Space | Comment +directives = (directive <* skipHWS) `sepEndBy` (eol *> skipLWS) <* skipLWS -- | Skip lines, comments, or horizontal white space. skipLWS :: Parser () -skipLWS = loop +skipLWS = Lexer.space space1 comment empty where - loop = A.takeWhile isSpace >> ((comment >> loop) <|> return ()) - - comment = try beginComment >> A.takeWhile (\c -> c /= '\r' && c /= '\n') - - beginComment = do - _ <- A.char '#' - mc <- peekChar - case mc of - Just ';' -> fail "" - _ -> return () + beginComment = char '#' *> notFollowedBy (char ';') + comment = try beginComment <* takeWhileP Nothing (\c -> c /= '\r' && c /= '\n') -- | Skip comments or horizontal white space. skipHWS :: Parser () -skipHWS = scan Space go *> pure () - where go Space ' ' = Just Space - go Space '\t' = Just Space - go Space '#' = Just Comment - go Space _ = Nothing - go Comment '\r' = Nothing - go Comment '\n' = Nothing - go Comment _ = Just Comment +skipHWS = Lexer.space + (satisfy (\c -> c == ' ' || c == '\t') >> return ()) + (Lexer.skipLineComment "#") + empty -data IdentState = First | Follow +isIdentifier :: Char -> Bool +isIdentifier c = Char.isAlphaNum c || c == '_' || c == '-' -ident :: Parser Key -ident = do - n <- scan First go - when (n == "import") $ - fail $ "reserved word (" ++ show n ++ ") used as identifier" - when (T.null n) $ fail "no identifier found" - when (T.last n == '.') $ fail "identifier must not end with a dot" - return n +keyword :: Text -> Parser () +keyword kw = string kw *> notFollowedBy (satisfy isAnyIdentifier) + where + isAnyIdentifier c = c == '.' || isIdentifier c + +identifier :: Parser Key +identifier = fst <$> match (word `sepBy1` char '.') where - go First c = - if isAlpha c - then Just Follow - else Nothing - go Follow c = - if isAlphaNum c || c == '_' || c == '-' - then Just Follow - else if c == '.' - then Just First - else Nothing + word = T.cons <$> letterChar <*> takeWhileP (Just "alphanumeric character") isIdentifier value :: Parser Value -value = mconcat [ - string "on" *> pure (Bool True) - , string "off" *> pure (Bool False) - , string "true" *> pure (Bool True) - , string "false" *> pure (Bool False) +value = choice [ + Bool <$> boolean , String <$> string_ - , Number <$> scientific + , Number <$> Lexer.scientific , List <$> brackets '[' ']' ((value <* skipLWS) `sepBy` (char ',' <* skipLWS)) ] + where + boolean = choice + [ string "on" *> pure True + , string "off" *> pure False + , string "true" *> pure True + , string "false" *> pure False + ] string_ :: Parser Text -string_ = do - s <- char '"' *> scan False isChar <* char '"' - if "\\" `T.isInfixOf` s - then unescape s - else return s +string_ = T.pack <$> str where - isChar True _ = Just False - isChar _ '"' = Nothing - isChar _ c = Just (c == '\\') + str = char '"' *> manyTill charLiteral (char '"') brackets :: Char -> Char -> Parser a -> Parser a -brackets open close p = char open *> skipLWS *> p <* char close - -embed :: Parser a -> Text -> Parser a -embed p s = case parseOnly p s of - Left err -> fail err - Right v -> return v +brackets open close p = between (char open *> skipLWS) (char close) p -unescape :: Text -> Parser Text -unescape = fmap (L.toStrict . toLazyText) . embed (p mempty) +charLiteral :: Parser Char +charLiteral = choice + [ char '\\' *> parseEscape + , anySingle + ] where - p acc = do - h <- A.takeWhile (/='\\') - let rest = do - let cont c = p (acc `mappend` fromText h `mappend` singleton c) - c <- char '\\' *> satisfy (inClass "ntru\"\\") - case c of - 'n' -> cont '\n' - 't' -> cont '\t' - 'r' -> cont '\r' - '"' -> cont '"' - '\\' -> cont '\\' - _ -> cont =<< hexQuad - done <- atEnd - if done - then return (acc `mappend` fromText h) - else rest + parseEscape = do + c <- oneOf ("ntru\"\\" :: [Char]) + case c of + 'n' -> pure '\n' + 't' -> pure '\t' + 'r' -> pure '\r' + '"' -> pure '"' + '\\' -> pure '\\' + _ -> hexQuad hexQuad :: Parser Char hexQuad = do - a <- embed hexadecimal =<< A.take 4 + a <- quad if a < 0xd800 || a > 0xdfff then return (chr a) else do - b <- embed hexadecimal =<< string "\\u" *> A.take 4 + b <- string "\\u" *> quad if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff then return $! chr (((a - 0xd800) `shiftL` 10) + (b - 0xdc00) + 0x10000) else fail "invalid UTF-16 surrogates" + where + quad = mkNum <$> count 4 (satisfy Char.isHexDigit "hexadecimal digit") + mkNum = foldl' step 0 + step a c = a * 16 + fromIntegral (Char.digitToInt c) -- | Parse a string interpolation spec. -- @@ -165,13 +140,13 @@ interp = reverse <$> p [] where p acc = do - h <- Literal <$> A.takeWhile (/='$') + h <- Literal <$> takeWhileP Nothing (/='$') let rest = do let cont x = p (x : h : acc) c <- char '$' *> satisfy (\c -> c == '$' || c == '(') case c of '$' -> cont (Literal (T.singleton '$')) - _ -> (cont . Interpolate) =<< A.takeWhile1 (/=')') <* char ')' + _ -> (cont . Interpolate) =<< takeWhile1P Nothing (/=')') <* char ')' done <- atEnd if done then return (h : acc) diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Main where @@ -17,13 +18,28 @@ tests :: [Test] tests = - [ testCase "read" readTest + [ testCase "read-simple" $ readTest "simple.cfg" + , testCase "read-pathological" $ readTest "pathological.cfg" , testCase "load" loadTest + , testCase "load" loadTest , testCase "types" typesTest , testCase "interp" interpTest , testCase "scoped-interp" scopedInterpTest , testCase "import" importTest , testCase "readme" readmeTest + -- top level parsing errors + , testCase "quote-error" $ parseErrorTest "err-single-quote.cfg" + -- errors with imported files + , testCase "import-error" $ ioErrorTest "err-import.cfg" + , testCase "import-error-2" $ parseErrorTest "err-import-2.cfg" + -- interpolation parsing errors + , testCase "parse-interp-error-1" $ parseErrorTest "err-parse-interp-1.cfg" + , testCase "parse-interp-error-2" $ parseErrorTest "err-parse-interp-2.cfg" + , testCase "parse-interp-error-3" $ parseErrorTest "err-parse-interp-3.cfg" + , testCase "parse-interp-error-4" $ parseErrorTest "err-parse-interp-4.cfg" + -- interpolation interpretation errors + , testCase "interpolate-error-1" $ parseErrorTest "err-interpolate-1.cfg" + , testCase "interpolate-error-2" $ parseErrorTest "err-interpolate-2.cfg" ] withLoad :: FilePath -> (Config -> IO ()) -> IO () @@ -32,6 +48,9 @@ testFile :: FilePath -> FilePath testFile name = "tests" "resources" name +errorFile :: FilePath -> FilePath +errorFile name = testFile name <> ".err" + parse :: Config -> Parser Value a -> Key -> Either Text a parse cfg p key = runParser (required key p) cfg @@ -41,8 +60,8 @@ parseSub :: Config -> Parser Value a -> Key -> Either Text [(Key, a)] parseSub cfg p prefix = runParser (subassocs prefix p) cfg -readTest :: Assertion -readTest = load (testFile "pathological.cfg") >> return () +readTest :: FilePath -> Assertion +readTest file = load (testFile file) >> return () loadTest :: Assertion loadTest = @@ -204,3 +223,17 @@ [("users.alice", "alice@example.com"), ("users.bob", "bob@example.com")] [("passwords.alice", "secret")])) (runParser settingsParser cfg) + +parseErrorTest :: FilePath -> Assertion +parseErrorTest file = do + err <- readFile $ errorFile file + (load (testFile file) >> assertFailure "expected a parse error") + `catch` \ (ParseError err') -> do + assertEqual "" err err' + +ioErrorTest :: FilePath -> Assertion +ioErrorTest file = do + err <- readFile $ errorFile file + (load (testFile file) >> assertFailure "expected an IO error") + `catch` \ (ex :: IOException) -> do + assertEqual "" err (show ex) diff --git a/tests/resources/err-import-2.cfg b/tests/resources/err-import-2.cfg new file mode 100644 --- /dev/null +++ b/tests/resources/err-import-2.cfg @@ -0,0 +1,2 @@ +import "err-single-quote.cfg" + diff --git a/tests/resources/err-import.cfg b/tests/resources/err-import.cfg new file mode 100644 --- /dev/null +++ b/tests/resources/err-import.cfg @@ -0,0 +1,2 @@ +import "not-exist.cfg" + diff --git a/tests/resources/err-interpolate-1.cfg b/tests/resources/err-interpolate-1.cfg new file mode 100644 --- /dev/null +++ b/tests/resources/err-interpolate-1.cfg @@ -0,0 +1,4 @@ +# unknown variable +first = 1 +second = 2 +third = "$(three)" diff --git a/tests/resources/err-interpolate-2.cfg b/tests/resources/err-interpolate-2.cfg new file mode 100644 --- /dev/null +++ b/tests/resources/err-interpolate-2.cfg @@ -0,0 +1,4 @@ +# not a number +first = [1,2,3] +second = 2 +third = "$(first)" diff --git a/tests/resources/err-parse-interp-1.cfg b/tests/resources/err-parse-interp-1.cfg new file mode 100644 --- /dev/null +++ b/tests/resources/err-parse-interp-1.cfg @@ -0,0 +1,1 @@ +a = "$x" diff --git a/tests/resources/err-parse-interp-2.cfg b/tests/resources/err-parse-interp-2.cfg new file mode 100644 --- /dev/null +++ b/tests/resources/err-parse-interp-2.cfg @@ -0,0 +1,1 @@ +b = "$$$" diff --git a/tests/resources/err-parse-interp-3.cfg b/tests/resources/err-parse-interp-3.cfg new file mode 100644 --- /dev/null +++ b/tests/resources/err-parse-interp-3.cfg @@ -0,0 +1,1 @@ +c = "$( let's never close this" diff --git a/tests/resources/err-parse-interp-4.cfg b/tests/resources/err-parse-interp-4.cfg new file mode 100644 --- /dev/null +++ b/tests/resources/err-parse-interp-4.cfg @@ -0,0 +1,1 @@ +d = "$(a second $( is probably fine)" diff --git a/tests/resources/err-single-quote.cfg b/tests/resources/err-single-quote.cfg new file mode 100644 --- /dev/null +++ b/tests/resources/err-single-quote.cfg @@ -0,0 +1,1 @@ +app.settings.external_api_secret = 'some_value' diff --git a/tests/resources/simple.cfg b/tests/resources/simple.cfg new file mode 100644 --- /dev/null +++ b/tests/resources/simple.cfg @@ -0,0 +1,16 @@ +# this is a config file that is meant to eventually cover the +# good syntax except for pathological stuff + +# some identifiers + +a = 1 +a_snakey_word = 2 +WeCanDoCamelCaseToo = 3 +and-hyphens-are-allowed = 4 +numbers2 = 5 + +then.we.can.add.dots = 6 + +# while plain import is disallowed, we can use it otherwise +importance = 7 +import.this.name = 8