From 8498cfb01c8088fba196f2ba7eb6c6411b1ed12d Mon Sep 17 00:00:00 2001 From: Ruud van Asseldonk Date: Thu, 22 Feb 2024 15:24:55 +0100 Subject: [PATCH 1/4] Add regression test for secrets file with comments This test currently fails because Vaultenv drops the second secret. I need to fix that, but let's add the test first. --- test/SecretFileSpec.hs | 20 ++++++++++++++++++++ test/golden/v2-comments.secrets | 8 ++++++++ 2 files changed, 28 insertions(+) create mode 100644 test/golden/v2-comments.secrets diff --git a/test/SecretFileSpec.hs b/test/SecretFileSpec.hs index c57bc06..c3f2c03 100644 --- a/test/SecretFileSpec.hs +++ b/test/SecretFileSpec.hs @@ -4,6 +4,7 @@ import Test.Hspec import Data.Either (isRight, isLeft) + import qualified SecretsFile import qualified System.Directory as Dir @@ -21,3 +22,22 @@ spec = do let invalidTestFiles = map ("test/invalid/" <>) invalidTestContents parseResults <- mapM SecretsFile.readSecretsFile invalidTestFiles parseResults `shouldSatisfy` (all isLeft) + + it "parses all v2-comments.secrets as expected" $ do + -- This is a regression test, Vaultenv 0.16.0 used to drop the second + -- secret. + Right parseResults <- SecretsFile.readSecretsFile "test/golden/v2-comments.secrets" + parseResults `shouldBe` + [ SecretsFile.Secret + { SecretsFile.sMount = "secret" + , SecretsFile.sPath = "devices/frobnicator" + , SecretsFile.sKey = "PASSWORD" + , SecretsFile.sVarName = "FROBNICATOR_PASSWORD" + } + , SecretsFile.Secret + { SecretsFile.sMount = "secret" + , SecretsFile.sPath = "devices/widgets/turboencabulator" + , SecretsFile.sKey = "PIN" + , SecretsFile.sVarName = "WIDGET_PIN" + } + ] diff --git a/test/golden/v2-comments.secrets b/test/golden/v2-comments.secrets new file mode 100644 index 0000000..78c4014 --- /dev/null +++ b/test/golden/v2-comments.secrets @@ -0,0 +1,8 @@ +VERSION 2 +MOUNT secret + +FROBNICATOR_PASSWORD=devices/frobnicator#PASSWORD + +# This is a comment. It should not inhibit the final entry from being loaded. +# There can be a second line of comment too. +WIDGET_PIN=devices/widgets/turboencabulator#PIN From da15edde796427e8689fb38f21ec2d339bc40f84 Mon Sep 17 00:00:00 2001 From: Ruud van Asseldonk Date: Thu, 22 Feb 2024 17:34:50 +0100 Subject: [PATCH 2/4] Break out the golden tests individually Then when one fails, it will print only the failing example, not the list with all the results. --- test/SecretFileSpec.hs | 24 +++++++++++++----------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/test/SecretFileSpec.hs b/test/SecretFileSpec.hs index c3f2c03..02038e9 100644 --- a/test/SecretFileSpec.hs +++ b/test/SecretFileSpec.hs @@ -3,7 +3,7 @@ module SecretFileSpec where import Test.Hspec import Data.Either (isRight, isLeft) - +import Control.Monad (forM_) import qualified SecretsFile import qualified System.Directory as Dir @@ -11,17 +11,19 @@ import qualified System.Directory as Dir spec :: SpecWith () spec = do describe "SecretFile.readSecretList" $ do - it "parses all golden tests succesfully" $ do - goldenTestContents <- Dir.listDirectory "test/golden" - let goldenTestFiles = map ("test/golden/" <>) goldenTestContents - parseResults <- mapM SecretsFile.readSecretsFile goldenTestFiles - parseResults `shouldSatisfy` (all isRight) + goldenTestContents <- runIO $ Dir.listDirectory "test/golden" + let goldenTestFiles = map ("test/golden/" <>) goldenTestContents + forM_ goldenTestFiles $ \fname -> + it ("parses " ++ fname ++ " correctly") $ do + parseResult <- SecretsFile.readSecretsFile fname + parseResult `shouldSatisfy` isRight - it "rejects all invalid examples succesfully" $ do - invalidTestContents <- Dir.listDirectory "test/invalid" - let invalidTestFiles = map ("test/invalid/" <>) invalidTestContents - parseResults <- mapM SecretsFile.readSecretsFile invalidTestFiles - parseResults `shouldSatisfy` (all isLeft) + invalidTestContents <- runIO $ Dir.listDirectory "test/invalid" + let invalidTestFiles = map ("test/invalid/" <>) invalidTestContents + forM_ invalidTestFiles $ \fname -> + it ("rejects " ++ fname) $ do + parseResult <- SecretsFile.readSecretsFile fname + parseResult `shouldSatisfy` isLeft it "parses all v2-comments.secrets as expected" $ do -- This is a regression test, Vaultenv 0.16.0 used to drop the second From 8a51b4da7ff0c6d82ec520d37c5e5abf29ebbe2d Mon Sep 17 00:00:00 2001 From: Ruud van Asseldonk Date: Thu, 22 Feb 2024 18:03:31 +0100 Subject: [PATCH 3/4] Add more tests for the secrets file parser I want to make sure that touching the parser doesn't break things. --- test/SecretFileSpec.hs | 78 +++++++++++++++++++++++++++++++++++++++++- 1 file changed, 77 insertions(+), 1 deletion(-) diff --git a/test/SecretFileSpec.hs b/test/SecretFileSpec.hs index 02038e9..57a06d5 100644 --- a/test/SecretFileSpec.hs +++ b/test/SecretFileSpec.hs @@ -25,7 +25,83 @@ spec = do parseResult <- SecretsFile.readSecretsFile fname parseResult `shouldSatisfy` isLeft - it "parses all v2-comments.secrets as expected" $ do + it "parses v1.secrets as expected" $ do + Right parseResults <- SecretsFile.readSecretsFile "test/golden/v1.secrets" + parseResults `shouldBe` + [ SecretsFile.Secret + { SecretsFile.sMount = "secret" + , SecretsFile.sPath = "foo" + , SecretsFile.sKey = "bar" + , SecretsFile.sVarName = "FOO_BAR" + } + , SecretsFile.Secret + { SecretsFile.sMount = "secret" + , SecretsFile.sPath = "foo/bar" + , SecretsFile.sKey = "baz" + , SecretsFile.sVarName = "FOO_BAR_BAZ" + } + , SecretsFile.Secret + { SecretsFile.sMount = "secret" + , SecretsFile.sPath = "bar" + , SecretsFile.sKey = "baz" + , SecretsFile.sVarName = "FOO" + } + , SecretsFile.Secret + { SecretsFile.sMount = "secret" + , SecretsFile.sPath = "foo/baz" + , SecretsFile.sKey = "quix" + , SecretsFile.sVarName = "BAR" + } + , SecretsFile.Secret + { SecretsFile.sMount = "secret" + , SecretsFile.sPath = "foo/single" + , SecretsFile.sKey = "underscore" + , SecretsFile.sVarName = "single_underscore" + } + , SecretsFile.Secret + { SecretsFile.sMount = "secret" + , SecretsFile.sPath = "foo/double" + , SecretsFile.sKey = "underscore" + , SecretsFile.sVarName = "double__underscore" + } + , SecretsFile.Secret + { SecretsFile.sMount = "secret" + , SecretsFile.sPath = "foo/double" + , SecretsFile.sKey = "underscore" + , SecretsFile.sVarName = "_leading_underscore" + } + ] + + it "parses v2.secrets as expected" $ do + Right parseResults <- SecretsFile.readSecretsFile "test/golden/v2.secrets" + parseResults `shouldBe` + [ SecretsFile.Secret + { SecretsFile.sMount = "secret" + , SecretsFile.sPath = "foo" + , SecretsFile.sKey = "bar" + , SecretsFile.sVarName = "SECRET_FOO_BAR" + } + , SecretsFile.Secret + { SecretsFile.sMount = "secret" + , SecretsFile.sPath = "foo/baz" + , SecretsFile.sKey = "bar" + , SecretsFile.sVarName = "BAR" + } + , SecretsFile.Secret + { SecretsFile.sMount = "otherthing" + , SecretsFile.sPath = "foo" + , SecretsFile.sKey = "bar" + , SecretsFile.sVarName = "OTHERTHING_FOO_BAR" + } + , SecretsFile.Secret + { SecretsFile.sMount = "otherthing" + , SecretsFile.sPath = "foo/baz" + , SecretsFile.sKey = "bar" + , SecretsFile.sVarName = "BAR" + } + ] + + it "parses v2-comments.secrets as expected" $ do -- This is a regression test, Vaultenv 0.16.0 used to drop the second -- secret. Right parseResults <- SecretsFile.readSecretsFile "test/golden/v2-comments.secrets" From cc50924a3597a04709bb5dd37e382d32d6a915bb Mon Sep 17 00:00:00 2001 From: Ruud van Asseldonk Date: Thu, 22 Feb 2024 17:54:40 +0100 Subject: [PATCH 4/4] Rewrite the secrets file parser There is a place for true parsers, but the Megaparsec one here was fragile. I wanted to add support for comment lines to it but it was not so clear where, and the current parser had this pretty dangerous failure mode of ignoring half the input. Instead of trying to deal with that, for Vaultenv's secrets file format, it is so simple, just splitting on lines and then splitting on = and # should be fine. --- app/Main.hs | 4 +- package.yaml | 3 - src/SecretsFile.hs | 256 ++++++++++----------------------- test/golden/whitespace.secrets | 2 +- 4 files changed, 81 insertions(+), 184 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index c268fbc..a732c19 100755 --- a/app/Main.hs +++ b/app/Main.hs @@ -49,7 +49,7 @@ import Config (AuthMethod (..), Options(..), parseOptions, unMilliSeconds, LogLevel(..), readConfigFromEnvFiles, getOptionsValue, Validated, Completed, DuplicateVariableBehavior (..)) import KeyMap (KeyMap) -import SecretsFile (Secret(..), SFError(..), readSecretsFile) +import SecretsFile (Secret(..), readSecretsFile) import Response (ClientToken (..)) import qualified KeyMap as KM @@ -177,7 +177,7 @@ instance FromJSON MountInfo where -- function which is responsible for printing an error message and exiting. data VaultError = SecretNotFound String - | SecretFileError SFError + | SecretFileError String | KeyNotFound Secret | WrongType Secret | BadRequest LBS.ByteString diff --git a/package.yaml b/package.yaml index 99d5502..2907496 100644 --- a/package.yaml +++ b/package.yaml @@ -19,16 +19,13 @@ dependencies: - http-conduit - http-client - http-client-openssl - - megaparsec - network-uri - optparse-applicative - - parser-combinators - retry - text - unordered-containers - unix - utf8-string - - optparse-applicative ghc-options: -threaded -Wall -Werror diff --git a/src/SecretsFile.hs b/src/SecretsFile.hs index 9b54fcc..94967cb 100644 --- a/src/SecretsFile.hs +++ b/src/SecretsFile.hs @@ -21,15 +21,9 @@ If you are user, please see the README for more information. -} module SecretsFile where -import Control.Applicative.Combinators (some, option, optional) import Control.Exception (try, displayException) -import Data.Char (toUpper, isSpace, isControl) -import Data.Functor (void) -import Data.List (intercalate) -import Data.Void (Void) -import qualified Text.Megaparsec as MP -import qualified Text.Megaparsec.Char as MPC -import qualified Text.Megaparsec.Char.Lexer as MPL +import Data.Char (toUpper, isSpace) +import Data.List (elemIndex, intercalate, isPrefixOf) data Secret = Secret { sMount :: String @@ -38,186 +32,92 @@ data Secret = Secret , sVarName :: String } deriving (Eq, Show) -data SFVersion - = V1 - | V2 - deriving (Show) - -type Parser = MP.Parsec Void String - --- | Error modes of this module. --- --- We either get IO errors because we cannot open the secrets file, or we --- cannot parse it. -data SFError = IOErr IOError | ParseErr (MP.ParseErrorBundle String Void) - -instance Show SFError where - show sfErr = case sfErr of - IOErr ioErr -> displayException ioErr - ParseErr pe -> MP.errorBundlePretty pe +-- | Read a file, catching all IOError exceptions. +safeReadFile :: FilePath -> IO (Either IOError String) +safeReadFile fp = (try . readFile) fp -- | Read a list of secrets from a file -readSecretsFile :: FilePath -> IO (Either SFError [Secret]) +readSecretsFile :: FilePath -> IO (Either String [Secret]) readSecretsFile fp = do contentsOrErr <- safeReadFile fp case contentsOrErr of - Right c -> do - let parseResult = parseSecretsFile fp c - case parseResult of - Right res -> pure $ Right res - Left err -> pure $ Left (ParseErr err) - Left err -> pure $ Left (IOErr err) - --- | Read a file, catching all IOError exceptions. -safeReadFile :: FilePath -> IO (Either IOError String) -safeReadFile fp = (try . readFile) fp - --- | Parse a String as a SecretsFile. -parseSecretsFile :: FilePath -> String -> Either (MP.ParseErrorBundle String Void) [Secret] -parseSecretsFile = MP.parse secretsFileP - --- | SpaceConsumer parser, which is responsible for stripping all whitespace. --- --- Sometimes, we require explicit newlines, therefore, we don't handle those --- here. @isSpace@ works on any unicode whitespace character. Megaparsec comes --- with some helpers that would make this better, but here we need to roll our --- own whitespace parser, because we want to preserve newlines. -whitespace :: Parser () -whitespace = MPL.space whitespaceChars lineComment blockComment + Right str -> pure $ parseSecretsFile str + Left err -> pure $ Left $ displayException err + +parseSecretsFile :: String -> Either String [Secret] +parseSecretsFile str = + let + dataLines = id + -- Drop blank lines. + $ filter (not . all isSpace) + -- Drop comment lines that start with #. + $ filter (\line -> not $ "#" `isPrefixOf` line) + $ lines str + in + case dataLines of + [] -> Left "Secrets file must not be empty." + "VERSION 2" : linesV2 -> parseSecretsV2 linesV2 + linesV1 -> mapM parseSecretV1 linesV1 + +-- | V1 secrets use mount "secret" and have no prefix in the default variable name. +parseSecretV1 :: String -> Either String Secret +parseSecretV1 = parseSecret "secret" [] + +parseSecretsV2 :: [String] -> Either String [Secret] +parseSecretsV2 fileLines = go Nothing [] fileLines + where + -- We build the list in reverse while we parse the file, so reverse it + -- at the end, to avoid being accidentally quadratic. + go _mountOpt acc [] = Right $ reverse acc + go mountOpt acc (line : more) = case (mountOpt, words line) of + (_, ["MOUNT", mount]) -> go (Just mount) acc more + (Nothing, _) -> Left $ "Expected a 'MOUNT ' line before secret definition." + (Just mount, _) -> do + secret <- parseSecret mount [mount] line + go mountOpt (secret : acc) more + +parseSecret :: String -> [String] -> String -> Either String Secret +parseSecret mount mountPrefix = parseVar where - whitespaceChars = void $ MP.takeWhile1P (Just "whitespace") (\c -> isSpace c && c /= '\n') - lineComment = MP.empty - blockComment = MP.empty - --- | Parses one or multiple newlines separated by whitespace. -newlines :: Parser () -newlines = void $ some $ lexeme $ MPC.char '\n' - --- | Helper which consumes all whitespace after a parser -lexeme :: Parser a -> Parser a -lexeme = MPL.lexeme whitespace - --- | Helper which looks for a string and consumes trailing whitespace. -symbol :: String -> Parser String -symbol = MPL.symbol whitespace - --- | Top level parser of the secrets file --- --- Parses the magic version number and dispatches to the Mount block based --- parser or the list based parser based on that. -secretsFileP :: Parser [Secret] -secretsFileP = do - _ <- optional newlines - _ <- whitespace - version <- versionP - case version of - V1 -> some (secretP version "secret") - V2 -> concat <$> some secretBlockP - --- | Parse the file version --- --- We need @MP.try@ because we need to backtrack after reading VERSION. (As --- some secrets could very well start with that path. -versionP :: Parser SFVersion -versionP = option V1 $ MP.try $ do - _ <- symbol "VERSION" - _ <- symbol "2" - _ <- newlines - pure V2 - --- | Parse a secret block --- --- Exclusive to V2 of the format. A secret block consists of a line describing --- the mount location followed by secret specifications. -secretBlockP :: Parser [Secret] -secretBlockP = do - _ <- symbol "MOUNT" - mountPath <- lexeme pathComponentP - _ <- newlines - some (MP.try (lexeme (secretP V2 mountPath))) - --- | Parses legal Vault path components. --- --- A Vault path allows a surprising amount of characters. Spaces, quotes and --- whatnot are all allowed. We don't want to complicate the parser and --- the format by specifying escaping for all kinds of things, so we impose the --- following restrictions: --- --- - We don't support mounts, paths and keys with whitespace in them. --- - We don't support control characters (vault doesn't either) --- - All other characters except @=@ and @#@ are allowed. Supporting paths --- with these characters in them would lead to ambiguities when parsing --- paths such as: --- --- FOO=foo=bar/baz#quix --- --- and --- --- foo#bar/baz#quix --- --- If this is undesired, have a compelling usecase, and a good proposal for --- supporting this, please open a ticket. -pathComponentP :: Parser String -pathComponentP = MP.takeWhile1P (Just "path component") isAllowed - where isAllowed c = not (isSpace c) && c /= '#' && c /= '=' && not (isControl c) - --- | Parse a secret specification line --- --- The version of the fileformat we're parsing determines the way we report --- variable information. For V2, the mount point is part of the variable name, --- to allow for disambiguation. For V1, this is not needed. -secretP :: SFVersion -> String -> Parser Secret -secretP version mount = do - secret <- lexeme $ do - varName <- optional $ MP.try secretVarP - path <- pathComponentP - _ <- symbol "#" - key <- pathComponentP - - pure Secret { sMount = mount - , sPath = path - , sKey = key - , sVarName = maybe (getVarName version mount path key) id varName - } - _ <- newlines - pure secret - --- | Parses a secret variable. --- --- We're restrictrive in the characters we allow in environment variables. We --- don't allow special characters or whitespace. Environment variables have to --- start with a letter or underscore which can be followed by letters --- underscores and digits. This is similar to what Zsh and Bash allow in their --- `export` statements. Even though the Unix process environment is technically --- just a string and you can put all kinds of things in there, most programs --- and standard libraries don't seem to support this. --- --- Please open a ticket if you require looser restrictions. -secretVarP :: Parser String -secretVarP = do - -- Environment variables have to start with a letter or underscore and can be - -- followed by letters, underscores and digits. - varStart <- MP.oneOf asciiLettersUnderscore - varRest <- MP.many $ MP.oneOf (asciiLettersUnderscore ++ digits) - _ <- symbol "=" - pure (varStart:varRest) - --- | Helper list for ASCII chars plus the underscore -asciiLettersUnderscore :: [MP.Token String] -asciiLettersUnderscore = ['a'..'z'] ++ ['A'..'Z'] ++ ['_'] - --- | Helper list for ASCII digits -digits :: [MP.Token String] -digits = ['0'..'9'] + parseVar line = case elemIndex '=' line of + Nothing -> parsePath line + Just i -> do + secret <- parsePath $ drop (i + 1) line + let varName = take i line + validateVariableName varName + pure $ secret { sVarName = varName } + + parsePath line = case elemIndex '#' line of + Nothing -> Left $ "Line must contain a '#' to indicate the key, on line: " ++ line + Just i -> do + let + key = drop (i + 1) line + path = take i line + validateKey key + pure $ Secret + { sKey = key + , sPath = path + , sMount = mount + , sVarName = getVarName mountPrefix path key + } + +validateKey :: String -> Either String () +validateKey key = if '#' `elem` key + then Left $ "Key must not contain '#': " ++ key + else Right () + +validateVariableName :: String -> Either String () +validateVariableName name = case name of + ch : _ | ch `elem` (['a'..'z'] ++ ['A'..'Z'] ++ ['_']) -> Right () + [] -> Left "Variable name must not be empty." + _ -> Left $ "Variable name must start with _ or ASCII letter: " ++ name -- | Convert a secret name into the name of the environment variable that it -- will be available under. -getVarName :: SFVersion -> String -> String -> String -> String -getVarName version mount path key = fmap format $ intercalate "_" components +getVarName :: [String] -> String -> String -> String +getVarName mountPrefix path key = fmap format $ intercalate "_" components where underscore '/' = '_' underscore '-' = '_' underscore c = c format = toUpper . underscore - components = case version of - V1 -> [path, key] - V2 -> [mount, path, key] + components = mountPrefix ++ [path, key] diff --git a/test/golden/whitespace.secrets b/test/golden/whitespace.secrets index 5dc0066..03e9fd2 100644 --- a/test/golden/whitespace.secrets +++ b/test/golden/whitespace.secrets @@ -1,5 +1,5 @@ -VERSION 2 +VERSION 2 MOUNT secret stuff/and#things