configurator-pg 0.1.0.6 → 0.2.0

raw patch · 16 files changed

+167/−116 lines, 16 filesdep +megaparsecdep −attoparsecPVP ok

version bump matches the API change (PVP)

Dependencies added: megaparsec

Dependencies removed: attoparsec

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• README.md +6/−4
• configurator-pg.cabal +2/−2
• src/Data/Configurator/Load.hs +11/−10
• src/Data/Configurator/Syntax.hs +72/−97
• tests/Test.hs +36/−3
• tests/resources/err-import-2.cfg +2/−0
• tests/resources/err-import.cfg +2/−0
• tests/resources/err-interpolate-1.cfg +4/−0
• tests/resources/err-interpolate-2.cfg +4/−0
• tests/resources/err-parse-interp-1.cfg +1/−0
• tests/resources/err-parse-interp-2.cfg +1/−0
• tests/resources/err-parse-interp-3.cfg +1/−0
• tests/resources/err-parse-interp-4.cfg +1/−0
• tests/resources/err-single-quote.cfg +1/−0
• tests/resources/simple.cfg +16/−0

@@ -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.

@@ -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 

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -0,0 +1,2 @@+import "err-single-quote.cfg"+

@@ -0,0 +1,2 @@+import "not-exist.cfg"+

@@ -0,0 +1,4 @@+# unknown variable+first = 1+second = 2+third = "$(three)"

@@ -0,0 +1,4 @@+# not a number+first = [1,2,3]+second = 2+third = "$(first)"

@@ -0,0 +1,1 @@+a = "$x"

@@ -0,0 +1,1 @@+b = "$$$"

@@ -0,0 +1,1 @@+c = "$( let's never close this"

@@ -0,0 +1,1 @@+d = "$(a second $( is probably fine)"

@@ -0,0 +1,1 @@+app.settings.external_api_secret = 'some_value'

@@ -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