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/SecretFileSpec.hs b/test/SecretFileSpec.hs index c57bc06..57a06d5 100644 --- a/test/SecretFileSpec.hs +++ b/test/SecretFileSpec.hs @@ -3,6 +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 @@ -10,14 +11,111 @@ 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) - - 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) + 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 + + 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 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" + 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 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