diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for cfv + +## 0.1.0.0 -- 2026-11-10 + +* Initial release on Hackage. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2026, Harley D. Eades III + + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,17 @@ +# CFV: A simple file format for configuration variables + +Declare configuration variables in a '.cfv' file and parse them. + +An example of the contents of a CFV file is: + +``` +-- a comment +greeting = 'hello'; -- single-quoted string +empty = ""; -- double-quoted string +now = `date +%s`; -- run shell command +home' = `echo "$HOME"`; -- access to your shells PATH +secret api_key = "password/token/key" -- a secret variable (public is default) +``` + +For more information on the syntax of variable declarations see +[Hackage](https://hackage-content.haskell.org/package/cfv-0.1.0.0). diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,5 @@ +module Main (main) where + +main :: IO () +main = do + putStrLn "Hello, Haskell!" diff --git a/cfv.cabal b/cfv.cabal new file mode 100644 --- /dev/null +++ b/cfv.cabal @@ -0,0 +1,100 @@ +cabal-version: 3.14 +name: cfv +version: 0.1.0.0 +synopsis: A simple file format for configuration variables +license: BSD-3-Clause +license-file: LICENSE +author: Harley D. Eades III +maintainer: harley.eades@gmail.com +homepage: https://github.com/heades/cfv +bug-reports: https://github.com/heades/cfv/issues +category: Development +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md +extra-source-files: + test/files/basic.cfv +tested-with: + GHC == 9.8.4 + GHC == 9.10.1 + GHC == 9.10.2 + GHC == 9.10.3 + GHC == 9.12.2 + GHC == 9.12.4 + GHC == 9.14.1 + +description: + Declare configuration variables in a '.cfv' file and parse them. + + An example of the contents of a CFV file is: + + > -- a comment + > greeting = 'hello'; -- single-quoted string + > empty = ""; -- double-quoted string + > now = `date +%s`; -- run shell command + > home' = `echo "$HOME"`; -- access to your shells PATH + > secret api_key = "password/token/key" -- a secret variable (public is default) + + For more information on the syntax of variable declarations see "Configuration.Cfv". + +common extensions + default-language: GHC2021 + default-extensions: + InstanceSigs + OverloadedStrings + +common ghc-options + ghc-options: -Wall -Widentities + +common rts-options + ghc-options: -rtsopts -threaded "-with-rtsopts=-N" + +library + import: extensions + import: ghc-options + exposed-modules: + Configuration.Cfv + Configuration.Cfv.AST + Configuration.Cfv.Parser + Configuration.Cfv.Shell + build-depends: + base >= 4.7 && < 5 + ,bytestring >= 0.12.2 && < 0.13 + ,containers >= 0.8 && < 0.9 + ,filepath >= 1.5.4 && < 1.6 + ,megaparsec >= 9.8.3 && < 9.9 + ,mtl >= 2.3.1 && < 2.4 + ,process >= 1.6.26 && < 1.7 + ,text >= 2.1.3 && < 2.2 + hs-source-dirs: src + default-language: Haskell2010 + +executable cfv + import: extensions + import: ghc-options + import: rts-options + main-is: Main.hs + build-depends: + base >= 4.7 && < 5 + ,cfv + hs-source-dirs: app + default-language: Haskell2010 + +test-suite cfv-test + import: extensions + import: ghc-options + import: rts-options + default-language: Haskell2010 + other-modules: + CfvSpec + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + base >= 4.7 && < 5 + ,hspec >= 2.11.18 && < 2.12 + ,text >= 2.1.3 && < 2.2 + ,cfv diff --git a/src/Configuration/Cfv.hs b/src/Configuration/Cfv.hs new file mode 100644 --- /dev/null +++ b/src/Configuration/Cfv.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE Safe #-} +{-| +Module : Cfv +Description : The CFV API +Copyright : (c) Harley Eades, 2026 +Maintainer : harley.eades@gmail.com + +A CFV file is a sequence of configuration variable declarations. + +A valid variable declarations consist of one of the following: + +* Strings: @name = \'...\';@ or @name = "...";@ declares a string. The escapes + @\\\\, \\', \\", \\n, \\t, \\r, \\0@ are recognized; raw newlines are allowed. + +* Commands: @name = \`cmd\`@ runs @cmd@ in the user's shell and uses its + stdout as the value. Like shell command substitution, trailing + newlines are stripped. @cmd@ is everything up to the next backtick (there is + no escape for a backtick; use @$(...)@ for nested substitution). The command + runs in the current working directory with the calling process's environment + and a closed standard input. + +* Secrets: A declaration may be prefixed with @secret@ (@secret name = ...@) to + mark its value as a secret. When no @secret@ attribute labels a declaration it + is assumed to be non-sensitive (public). Note that @secret@ is only a keyword + when a variable name follows it, so @secret = \'x\';@ still declares a public + variable called @secret@. + +Parsing a CFV file returns a list of t'Binding' which is simply a pair +@('VarName', t'Var')@ of a variable name ( t'String' ) and a variable ( t'Var' ). The latter +labels a variable's value with an attribute which currently consist of 'Public' +and 'Secret'. After parsing you are free to use these variable declarations in +any way you wish. + +This API does place one restriction on the declarations attributed +with @sercret@. The default t'Show' instance does not convert a secret variable's +value to a string, but simply translates it to @Secret ()@. This makes printing +the contents of a CFV file to a log or the screen safe. +-} +module Configuration.Cfv + ( -- * Parsing and evaluating + Binding + , Var (..) + , varAttr + , revealVar + , VarAttr (..) + , parseCfvFile + , parseCfvFileWith + , parseEvalCfv + , parseEvalCfvWith + -- * Shell configuration + , ShellConfig (..) + , defaultShellConfig + -- * Errors + , CfvError (..) + , SyntaxError (..) + , ErrorKind (..) + , Item (..) + , Position (..) + , CommandError (..) + , CommandProblem (..) + , renderCfvError + ) where + +import Configuration.Cfv.AST +import Configuration.Cfv.Shell +import Configuration.Cfv.Parser + diff --git a/src/Configuration/Cfv/AST.hs b/src/Configuration/Cfv/AST.hs new file mode 100644 --- /dev/null +++ b/src/Configuration/Cfv/AST.hs @@ -0,0 +1,59 @@ +{-| +Module : AST +Description : Abstract syntax +Copyright : (c) Harley Eades, 2026 +Maintainer : harley.eades@gmail.com + +The abstract syntax for CFV files. +-} +module Configuration.Cfv.AST + (VarName + ,VarValue + ,Binding + ,Var(..) + ,VarAttr(..) + ,varAttr + ,revealVar) where +import Data.Text (Text) + +-- | Security level for variables. +data VarAttr + = Public -- ^ The default; has no syntax. + | Secret -- ^ Declared with a @secret@ prefix. + deriving (Eq, Ord, Show) + +-- | A variables value. +type VarValue = Text + +-- | A variable's final value (after any command has been run) together with its +-- attribute. +-- +-- The 'Show' instance never prints a secret value, so a list of bindings can +-- be logged safely: +-- +-- > [("name",Public "x"),("key",Secret ())] +-- +data Var + = Var VarAttr VarValue + deriving (Eq) + +instance Show Var where + showsPrec :: Int -> Var -> ShowS + showsPrec d (Var Public v) = + showParen (d > 10) (showString "Public " . showsPrec 11 v) + showsPrec _ (Var Secret _) = showString "Secret ()" + +-- | The variable's attribute. +varAttr :: Var -> VarAttr +varAttr (Var a _) = a + +-- | The variable's value, secret or not. +revealVar :: Var -> Text +revealVar (Var _ v) = v + +-- | A variables name. +type VarName = Text + +-- | A variable binding: a name, attribute, and a value. +type Binding = (VarName, Var) + diff --git a/src/Configuration/Cfv/Parser.hs b/src/Configuration/Cfv/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Configuration/Cfv/Parser.hs @@ -0,0 +1,462 @@ +{-# LANGUAGE ViewPatterns #-} +{-| +Module : Parser +Description : The CFV Parser +Copyright : (c) Harley Eades, 2026 +Maintainer : harley.eades@gmail.com + +This module consists of the CFV parser API. +-} +module Configuration.Cfv.Parser + (parseCfvFile + ,parseCfvFileWith + ,CfvError (..) + ,SyntaxError (..) + ,ErrorKind (..) + ,Item (..) + ,Position (..) + ,parseEvalCfv + ,parseEvalCfvWith + ,renderCfvError) where + +import qualified GHC.IO.Exception as E +import Data.Text.Encoding.Error (UnicodeException) +import qualified GHC.Exception as E +import Data.Text (Text) +import Text.Megaparsec (SourcePos (..), ParseErrorBundle (..), ParseError (..), ErrorItem (..), ErrorFancy (..), Parsec, unPos, PosState (..), errorOffset, TraversableStream (reachOffset), parseError, getOffset, getSourcePos, empty, try, MonadParsec (takeWhileP, notFollowedBy, observing, eof), satisfy, (), (<|>), many, optional, anySingle, option, parse) +import System.FilePath (takeExtension) +import qualified Control.Exception as E +import qualified Data.ByteString as BS +import qualified Data.Text.Encoding as TE +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as Set +import qualified Text.Megaparsec.Char.Lexer as L +import Text.Megaparsec.Char (space1, string, char) +import Control.Monad (void, when) +import Data.Char (isAlphaNum, isAsciiLower, isAsciiUpper) +import qualified Data.Bifunctor as BI + +import Configuration.Cfv.AST (VarAttr (..), Binding, Var (..)) +import Configuration.Cfv.Shell (CommandError (..), ShellConfig, defaultShellConfig, evalValue, describeProblem) +import qualified Data.Text as DT +import Data.List.NonEmpty (NonEmpty) + +------------------------------------------------------------------------------------------------------------------- +-- Public API + +-- | Read, parse and evaluate a @.cfv@ file using 'defaultShellConfig'. +-- Returns the variables in source order; a variable declared more than once +-- appears more than once (so 'lookup' finds the first declaration). Commands +-- run one at a time in file order, and the first failure aborts the whole +-- operation. +-- +-- Never throws for extension, read, decode, parse or command problems; they are +-- all returned as 'CfvError'. (To throw instead: +-- @either E.throwIO pure =<< parseCfvFile p@.) +parseCfvFile :: FilePath -> IO (Either CfvError [Binding]) +parseCfvFile = parseCfvFileWith defaultShellConfig + +-- | Like 'parseCfvFile' with an explicit shell configuration. +parseCfvFileWith :: ShellConfig -> FilePath -> IO (Either CfvError [Binding]) +parseCfvFileWith cfg path = do + parsed <- readCfvFile path + case parsed of + Left err -> pure (Left err) + Right decls -> runDeclarations cfg decls + +-- | Like 'parseCfvFile', but doesn't read from a file. Useful for testing. +parseEvalCfv :: [Char] -> Text -> IO (Either CfvError [Binding]) +parseEvalCfv = parseEvalCfvWith defaultShellConfig + +-- | Like 'parseEvalCfv' but with an explicit shell configuration. +parseEvalCfvWith :: ShellConfig -> [Char] -> Text -> IO (Either CfvError [Binding]) +parseEvalCfvWith cfg path txt = do + let parsed = BI.first FileSyntaxError $ parseCfv path txt + case parsed of + Left err -> pure (Left err) + Right decls -> runDeclarations cfg decls + +------------------------------------------------------------------------------------------------------------------- + +-- | One @[secret] name = value@ declaration, as written in the file. +data Declaration = Declaration + { declName :: Text + , declAttr :: VarAttr + , declValue :: Value + , declPosition :: Position + -- ^ Where the declaration starts (its @secret@ prefix if it has one, + -- otherwise its variable name). + } deriving (Eq) + +-- | Like the derived instance, except that the value of a 'Secret' +-- declaration is shown as @\@. +instance Show Declaration where + showsPrec :: Int -> Declaration -> ShowS + showsPrec d (Declaration n a v p) = + showParen (d > 10) $ + showString "Declaration " + . showsPrec 11 n . showChar ' ' + . showsPrec 11 a . showChar ' ' + . (case a of + Public -> showsPrec 11 v + Secret -> showString "") + . showChar ' ' + . showsPrec 11 p + +-- | The value of a variable declaration. +data Value + = StringValue Text -- ^ A quoted string, already unescaped. + | CommandValue Text -- ^ The text between backticks, unmodified. + deriving (Eq, Show) + +-- | Everything that can go wrong when processing a CFV file. +data CfvError + = InvalidExtension FilePath + -- ^ The file name does not end in @.cfv@ (checked before anything is read). + | FileReadError FilePath E.IOException + -- ^ The file could not be opened or read. + | FileDecodeError FilePath UnicodeException + -- ^ The file's contents are not valid UTF-8. + | FileSyntaxError SyntaxError + -- ^ The contents do not parse. + | FileCommandError CommandError Text VarAttr Position + -- ^ A backtick command could not be run, or failed. (Only produced by + -- functions that run commands.) + deriving (Eq, Show) + +-- | A problem with the text itself, with a location. +data SyntaxError = SyntaxError + { syntaxErrorPosition :: Position + -- ^ Approximate position where the syntax error occurred. + , syntaxErrorKind :: ErrorKind + -- ^ The kind of syntax error. + , syntaxErrorSourceLine :: Maybe Text + -- ^ The source line containing error. Always 'Nothing' when the input + -- contains the text @secret@ anywhere (even in a comment), because the line + -- could then contain, or be part of, a secret value. Every secret + -- declaration contains that text, so this cannot miss one. + } deriving (Eq, Show) + +-- | The specific kind of syntax error. +data ErrorKind + = UnexpectedInput (Maybe Item) [Item] + -- ^ Found this (if known), but expected one of these. + | ReservedWord Text + -- ^ A Haskell keyword (or a lone @_@) was used as a variable name. + -- Position: start of the word. + | InvalidEscape (Maybe Char) + -- ^ A backslash followed by a character that is not a known escape. + -- Position: the backslash. 'Nothing' (character withheld) inside the value + -- of a 'Secret' declaration. + | UnterminatedString Char + -- ^ A string literal with no closing quote (carries the quote character). + -- Position: the opening quote. + | UnterminatedCommand + -- ^ A backtick command with no closing backtick. + -- Position: the opening backtick. + | OtherFailure Text + -- ^ Anything else; should not occur with the current grammar. + deriving (Eq, Show) + +-- | Something the parser found or expected. +data Item + = Literal Text -- ^ Specific text, such as @";"@. + | Description Text -- ^ A named construct, such as @"variable name"@. + | EndOfFile + deriving (Eq, Ord, Show) + +-- | A location in the source. Line and column are 1-based; the offset is the +-- 0-based character offset from the start of the input. +data Position = Position + { posFile :: FilePath + , posLine :: Int + , posColumn :: Int + , posOffset :: Int + } deriving (Eq, Show) + +instance E.Exception CfvError where + displayException :: CfvError -> String + displayException = DT.unpack . renderCfvError + +instance E.Exception SyntaxError where + displayException :: SyntaxError -> String + displayException = DT.unpack . renderSyntaxError + +-- | Turn declarations into bindings, running each 'CommandValue' in the user's +-- shell. The shell is only looked up if there is at least one command. +runDeclarations :: ShellConfig -> [Declaration] -> IO (Either CfvError [Binding]) +runDeclarations cfg = go [] + where + go acc [] = pure (Right (reverse acc)) + go acc (d : ds) = do + case declValue d of + CommandValue cmd -> do + result <- evalValue cfg cmd + case result of + Left err -> pure (Left $ FileCommandError err (declName d) (declAttr d) (declPosition d)) + Right v -> go ((declName d, Var (declAttr d) (DT.pack v)) : acc) ds + StringValue v -> go ((declName d, Var (declAttr d) v) : acc) ds + +-- | Check the extension, read and parse a file, without running any command. +-- Never returns 'FileCommandError'. +readCfvFile :: FilePath -> IO (Either CfvError [Declaration]) +readCfvFile path + | takeExtension path /= ".cfv" = pure (Left (InvalidExtension path)) + | otherwise = do + result <- E.try (BS.readFile path) + pure $ case result of + Left e -> Left (FileReadError path e) + Right bytes -> + case TE.decodeUtf8' bytes of + Left e -> Left (FileDecodeError path e) + Right txt -> BI.first FileSyntaxError $ parseCfv path txt + +-- | Pure parser; runs nothing. The 'FilePath' is only used to label error +-- positions and is not checked for an extension. +parseCfv :: FilePath -> Text -> Either SyntaxError [Declaration] +parseCfv name input = BI.first fromBundle $ parse program name input + +-- | Converts a command error into a 'Text' that is appropriate for logging. +renderCommandError :: CommandError -> Text -> VarAttr -> Position -> Text +renderCommandError (CommandError cmd problem) name varAttr (Position f l c _) + = (DT.pack f) <> ":" <> DT.show l <> ":" <> DT.show c <> ": error: variable " <> DT.show name + <> ": " <> describeProblem problem + <> if varAttr == Secret then "" else "\n command: " <> cmd + +-- | Converts a error into a 'Text' that is appropriate for logging. +renderCfvError :: CfvError -> Text +renderCfvError (InvalidExtension (DT.pack->p)) + = p <> ": not a .cfv file (the file name must end in \".cfv\")" +renderCfvError (FileReadError (DT.pack->p) e) + = p <> ": cannot read file: " <> DT.show e +renderCfvError (FileDecodeError (DT.pack->p) e) + = p <> ": file is not valid UTF-8: " <> DT.show e +renderCfvError (FileSyntaxError e) + = renderSyntaxError e +renderCfvError (FileCommandError e n vatr p) + = renderCommandError e n vatr p + +-- | Multi-line, compiler-style message with a caret under the error. +renderSyntaxError :: SyntaxError -> Text +renderSyntaxError (SyntaxError (Position (DT.pack->f) l c _) kind srcLine) = + DT.intercalate "\n" $ + [ f <> ":" <> DT.show l <> ":" <> DT.show c <> ": error: " <> describeKind kind ] + <> case srcLine of + Just ln -> [ " | " <> ln, " | " <> DT.replicate (c - 1) " " <> "^" ] + Nothing -> [] + +-- | Describes a syntax error in a logging appropriate fashion. +describeKind :: ErrorKind -> Text +describeKind (UnexpectedInput found expected) + = "unexpected " <> maybe "input" describeItem found + <> (if null expected + then "" + else "; expected " <> DT.intercalate ", " (map describeItem expected)) +describeKind (ReservedWord w) = + "reserved word " <> DT.show w <> " cannot be used as a variable name" +describeKind (InvalidEscape (Just c)) + = "invalid escape sequence \\" <> DT.singleton c +describeKind (InvalidEscape Nothing) + = "invalid escape sequence (character withheld: secret value)" +describeKind (UnterminatedString q) + = "unterminated string literal (no closing " <> DT.singleton q <> " for this one)" +describeKind UnterminatedCommand + = "unterminated command (no closing backtick for this one)" +describeKind (OtherFailure msg) + = msg + +-- | Converts an 'Item' to a 'Text'. +describeItem :: Item -> Text +describeItem (Literal s) = DT.show s +describeItem (Description d) = d +describeItem EndOfFile = "end of input" + +-- | Internal custom errors raised by the parser itself. +data Custom + = CReservedWord Text + | CInvalidEscape (Maybe Char) + | CUnterminatedString Char + | CUnterminatedCommand + deriving (Eq, Ord, Show) + +-- | Converts a position in the source file into a t'Position'. +toPosition :: SourcePos -> Int -> Position +toPosition sp = Position (sourceName sp) (unPos (sourceLine sp)) (unPos (sourceColumn sp)) + +-- | Converts a "Text.Megaparsec" error into a t'SyntaxError'. +fromBundle :: ParseErrorBundle Text Custom -> SyntaxError +fromBundle bundle = + SyntaxError + { syntaxErrorPosition = toPosition (pstateSourcePos posState) offset + , syntaxErrorKind = kind + , syntaxErrorSourceLine = if "secret" `DT.isInfixOf` pstateInput (bundlePosState bundle) + then Nothing + else fmap DT.pack srcLine + } + where + -- Without error recovery there is exactly one error in the bundle. + err = NE.head (bundleErrors bundle) + offset = errorOffset err + (srcLine, posState) = reachOffset offset (bundlePosState bundle) + kind = case err of + TrivialError _ found expected -> + UnexpectedInput + (fromItem <$> found) + (map fromItem (Set.toList expected)) + FancyError _ fancy -> case Set.toList fancy of + (f : _) -> fromFancy f + [] -> OtherFailure "unknown error" + +-- | Converts a non-empty list of characters into a 'Text'. +textFromNEList :: NonEmpty Char -> Text +textFromNEList = DT.pack . NE.toList + +-- | Convert an t'Text.Megaparsec.Error.ErrorItem' into an 'Item'. +fromItem :: ErrorItem Char -> Item +fromItem (Tokens ts) = Literal $ textFromNEList ts +fromItem (Label cs) = Description $ textFromNEList cs +fromItem EndOfInput = EndOfFile + +-- | Convert an t'Text.Megaparsec.Error.ErrorFancy' into an 'ErrorKind'. +fromFancy :: ErrorFancy Custom -> ErrorKind +fromFancy (ErrorCustom (CReservedWord w)) = ReservedWord w +fromFancy (ErrorCustom (CInvalidEscape c)) = InvalidEscape c +fromFancy (ErrorCustom (CUnterminatedString q)) = UnterminatedString q +fromFancy (ErrorCustom CUnterminatedCommand) = UnterminatedCommand +fromFancy (ErrorFail msg) = OtherFailure . DT.pack $ msg +fromFancy ErrorIndentation {} = OtherFailure "indentation error" + +-- | The parser on 'Text' tokens firing errors based on 'Custom'. +type Parser = Parsec Custom Text + +-- | Fail with a custom error reported at the given offset. +failAt :: Int -> Custom -> Parser a +failAt o c = parseError (FancyError o (Set.singleton (ErrorCustom c))) + +-- | Get the current position during parsing. +currentPosition :: Parser Position +currentPosition = do + off <- getOffset + sp <- getSourcePos + pure (toPosition sp off) + +-- | Space consumer: whitespace (incl. newlines) and @--@ line comments. +sc :: Parser () +sc = L.space space1 lineComment empty + +-- | A Haskell line comment: two or more dashes NOT followed by a symbol +-- character (so @-->@ or @--|@ is an operator, not a comment, as in Haskell). +lineComment :: Parser () +lineComment = try $ do + _ <- string "--" + _ <- takeWhileP Nothing (== '-') + notFollowedBy (satisfy isSymbolChar) + void (takeWhileP (Just "comment text") (/= '\n')) + where + isSymbolChar c = c `elem` ['!','#','$','%','&','*','+','.','/','<','=','>','?','@','\\','^','|','~',':'] + +-- | A lexeme including our space consumer 'sc'. +lexeme :: Parser a -> Parser a +lexeme = L.lexeme sc + +-- | A symbol including our space consumer 'sc'. +symbol :: Text -> Parser Text +symbol = L.symbol sc + +-- | A Haskell variable identifier: starts with a lowercase letter or @_@, +-- continues with letters, digits, @_@ or @'@, and is not a reserved word. +varName :: Parser Text +varName = lexeme $ do + start <- getOffset + c <- satisfy (\x -> isAsciiLower x || isAsciiUpper x || x == '_') "variable name" + cs <- takeWhileP Nothing (\x -> isAlphaNum x || x == '_' || x == '\'') + let name = DT.cons c cs + when (name `elem` reserved) $ failAt start (CReservedWord name) + pure name + +-- | Reserved words. +reserved :: [Text] +reserved = [ "_" ] + +-- | A single- or double-quoted string. Supports the escapes +-- @\\\\ \\' \\" \\n \\t \\r \\0@. Raw newlines are allowed inside strings. +stringLit :: Parser Text +stringLit = lexeme (quoted '\'' <|> quoted '"') "string literal" + +-- | Parser a single or double quoted string. +quoted :: Char -- ^ The quote character. + -> Parser Text +quoted q = do + start <- getOffset + _ <- char q + body <- many (escaped start <|> plain) + -- 'many' only stops on the closing quote or at end of input. + closed <- optional (char q) + case closed of + Nothing -> failAt start (CUnterminatedString q) + Just _ -> pure . DT.pack $ body + where + plain = satisfy (\c -> c /= q && c /= '\\') + + escaped start = do + slash <- getOffset + _ <- char '\\' + next <- optional anySingle + case next of + Nothing -> failAt start (CUnterminatedString q) + Just c -> maybe (failAt slash (CInvalidEscape (Just c))) pure (lookup c escapes) + + escapes = + [ ('n', '\n'), ('t', '\t'), ('r', '\r'), ('0', '\0') + , ('\\', '\\'), ('\'', '\''), ('"', '"') + ] + +-- | A backtick-delimited shell command: everything up to the next backtick. +commandLit :: Parser Text +commandLit = lexeme body "backtick command" + where + body = do + start <- getOffset + _ <- char '`' + cmd <- takeWhileP Nothing (/= '`') + closed <- optional (char '`') + case closed of + Nothing -> failAt start CUnterminatedCommand + Just _ -> pure cmd + +-- | Parse a variable attribute. +attribute :: Parser VarAttr +attribute = option Public (Secret <$ try (keyword <* notFollowedBy (char '='))) + where + keyword = lexeme (string "secret" <* notFollowedBy (satisfy isNameChar)) + isNameChar x = isAlphaNum x || x == '_' || x == '\'' + +-- | Parser a variable declaration. +declaration :: Parser Declaration +declaration = do + pos <- currentPosition + attr <- attribute + name <- varName + _ <- symbol "=" + value <- withholdIfSecret attr (StringValue <$> stringLit <|> CommandValue <$> commandLit) + case value of + StringValue _ -> void (symbol ";") + CommandValue _ -> void (optional (symbol ";")) + pure (Declaration name attr value pos) + +-- | Run a parser for the value of a declaration. If it fails inside a +-- 'Secret' value, strip from the error any input that was quoted in it: the +-- unexpected character (which could be the start of the secret) and the +-- character after a bad backslash. +withholdIfSecret :: VarAttr -> Parser a -> Parser a +withholdIfSecret Public p = p +withholdIfSecret Secret p = observing p >>= either (parseError . withhold) pure + where + withhold (TrivialError o _ expected) = TrivialError o Nothing expected + withhold (FancyError o fancy) = FancyError o (Set.map hide fancy) + hide (ErrorCustom (CInvalidEscape _)) = ErrorCustom (CInvalidEscape Nothing) + hide f = f + +-- | A whole file: any number of declarations, with comments/whitespace anywhere. +program :: Parser [Declaration] +program = sc *> many declaration <* eof diff --git a/src/Configuration/Cfv/Shell.hs b/src/Configuration/Cfv/Shell.hs new file mode 100644 --- /dev/null +++ b/src/Configuration/Cfv/Shell.hs @@ -0,0 +1,140 @@ +{-| +Module : Shell +Description : Command evocation on the shell +Copyright : (c) Harley Eades, 2026 +Maintainer : harley.eades@gmail.com + +This is the API for accessing the users shell. All commands are ran in the login +shell with access to the @PATH@ environment variable, but the shell's rc-file is +not executed by default, and so aliases are not useable. If you need access to +your rc-file, then define a custom t`ShellConfig` for your project. +-} +module Configuration.Cfv.Shell + (CommandError(..) + ,CommandProblem(..) + ,ShellConfig(..) + ,evalValue + ,defaultShellConfig + ,describeProblem) where + +import qualified GHC.IO.Exception as E +import Data.Text.Encoding.Error (UnicodeException, lenientDecode) +import GHC.IO.Exception (ExitCode(..)) +import qualified Data.ByteString as BS +import System.Process (CreateProcess(..), waitForProcess, proc, createProcess, StdStream (..)) +import GHC.IO.Handle (Handle, hClose) +import Control.Concurrent (MVar, newEmptyMVar, forkIO, putMVar, takeMVar) +import qualified Control.Exception as E +import System.Environment (lookupEnv) +import qualified Data.Text.Encoding as TE +import Control.Exception (try) +import Data.Text (Text) +import qualified Data.Text as DT + +-- | A backtick command that could not produce a value. +-- +-- For a @Configuration.Cfv.AST.Secret@ variable anything that could contain or reveal the secret is +-- withheld: the command text (which may embed it) and the details of the +-- command's output (see 'CommandProblem'). +data CommandError = CommandError + { cmdCommand :: Text + , cmdProblem :: CommandProblem + } deriving (Eq, Show) + +-- | Errors produced by running a command on the shell. +data CommandProblem + = NoShell + -- ^ No shell configured and @SHELL@ is unset or empty. + | ShellLaunchFailed FilePath E.IOException + -- ^ The shell could not be started (not found, not executable, ...). + | NonZeroExit Int Text + -- ^ The command exited with this status (negative: killed by that signal) + -- and this standard error output, trimmed. The output is 'Nothing' for a + -- '@Configuration.Cfv.AST.Secret' variable. + | OutputNotUtf8 UnicodeException + -- ^ The command's standard output is not valid UTF-8. The exception names + -- the offending byte, so it is 'Nothing' for a '@Configuration.Cfv.AST.Secret' variable. + deriving (Eq, Show) + +-- | Shell configuration. +data ShellConfig = ShellConfig + { shellProgram :: Maybe FilePath + -- ^ The shell to use. 'Nothing' means the @SHELL@ environment variable. + , shellFlags :: [String] + -- ^ Arguments placed before the command text, which is passed last. + } deriving (Eq, Show) + +-- | Use @$SHELL@ as a login shell: @$SHELL -l -c cmd@. A login shell picks up +-- the user's profile (@PATH@ additions and so on). Add @"-i"@ to the flags if +-- you also need what the shell's interactive rc file sets up (aliases, +-- functions). +defaultShellConfig :: ShellConfig +defaultShellConfig = ShellConfig {shellProgram = Nothing, shellFlags = ["-l", "-c"]} + +-- | Evaluate a shell command reading in its @System.IO.stdout@. +evalValue :: ShellConfig -- ^ Shell configuration + -> Text -- ^ Command to execute + -> IO (Either CommandError [Char]) +evalValue shellCfg cmd + = do let failWith = Left . CommandError cmd + mShell <- resolveShell shellCfg + case mShell of + Nothing -> pure (failWith NoShell) + Just shell -> do + result <- try $ execShell shell (shellFlags shellCfg) $ DT.unpack cmd + pure $ case result of + Left e -> failWith (ShellLaunchFailed shell e) + Right (ExitFailure n, _, err) -> + failWith . NonZeroExit n . DT.strip $ TE.decodeUtf8With lenientDecode err + Right (ExitSuccess, out, _) + -> case TE.decodeUtf8' out of + Left e -> failWith (OutputNotUtf8 e) + Right t -> Right (DT.unpack (DT.dropWhileEnd (== '\n') t)) + +-- | Figure out the shell's path. +resolveShell :: ShellConfig -> IO (Maybe FilePath) +resolveShell cfg = case shellProgram cfg of + Just p -> pure (Just p) + Nothing -> do + v <- lookupEnv "SHELL" + pure $ case v of + Just s | not (null s) -> Just s + _ -> Nothing + +-- | Run @shell flags... cmd@ with stdin closed, collecting stdout and stderr as +-- raw bytes; to prevent deadlock we read both in concurrently. +execShell :: FilePath -> [String] -> String -> IO (ExitCode, BS.ByteString, BS.ByteString) +execShell shell flags cmd = do + (mIn, mOut, mErr, ph) <- + createProcess + (proc shell (flags ++ [cmd])) + { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } + case (mIn, mOut, mErr) of + (Just hin, Just hout, Just herr) -> do + hClose hin + outV <- readAll hout + errV <- readAll herr + code <- waitForProcess ph + (,,) code <$> takeMVar outV <*> takeMVar errV + _ -> E.throwIO (userError "could not create pipes for the shell process") + +-- | Read a handle until there is no more output to consume. +readAll :: Handle -> IO (MVar BS.ByteString) +readAll h = do + v <- newEmptyMVar + _ <- forkIO $ (BS.hGetContents h `E.catch` ignoreIO) >>= putMVar v + pure v + where + ignoreIO :: E.IOException -> IO BS.ByteString + ignoreIO _ = pure BS.empty + +-- | Converts a command problem into a 'Text'. +describeProblem :: CommandProblem -> Text +describeProblem NoShell = + "cannot run command: no shell configured and $SHELL is not set" +describeProblem (ShellLaunchFailed sh e) = + "cannot start shell " <> DT.show sh <> ": " <> DT.show e +describeProblem (NonZeroExit n err) = + "command exited with status " <> DT.show n <> (if DT.null err then "" else ": " <> err) +describeProblem (OutputNotUtf8 e) = + "command output is not valid UTF-8: " <> DT.show e diff --git a/test/CfvSpec.hs b/test/CfvSpec.hs new file mode 100644 --- /dev/null +++ b/test/CfvSpec.hs @@ -0,0 +1,90 @@ +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-| +Module : CfvSpec +Description : Spec for Cfv +Copyright : (c) Harley Eades, 2026 +Maintainer : harley.eades@gmail.com + +-} +module CfvSpec (spec) where + +import Test.Hspec ( Spec, runIO, shouldBe, it, SpecWith, describe ) + +import Configuration.Cfv.AST ( Var(..), VarAttr(..) ) +import Configuration.Cfv.Parser + ( parseCfvFile, + parseEvalCfv, + CfvError(FileSyntaxError), + SyntaxError(..), + Position(..), + ErrorKind(..), + Item(..), renderCfvError ) + +import System.IO (stderr) +import Data.Text.IO (hPutStrLn) + +spec :: Spec +spec = do + describe "Parser Tests:" $ do + testParseBasicCfv + testParseNoSemiColon + testParseNoSemiColonMultiline + testParseSecret + describe "Secret Tests:" $ do + testShowSecret + +testParseBasicCfv :: SpecWith () +testParseBasicCfv = do + r <- runIO $ parseCfvFile "test/files/basic.cfv" + either + (\err -> do runIO . hPutStrLn stderr . renderCfvError $ err + it "parseBasicCfv" False) + (\_ -> it "parseBasicCfv" True) + r + +testParseNoSemiColon :: SpecWith () +testParseNoSemiColon = do + let file = "test/files/noSemiColon.cfv" + let testConfig = "exampleVar = 'example value'" + r <- runIO $ parseEvalCfv file testConfig + it "parseNoSemiColon" $ r `shouldBe` (Left . FileSyntaxError $ SyntaxError + { syntaxErrorPosition = (Position + { posFile = file + , posLine = 1 + , posColumn = 29 + , posOffset = 28 }) + , syntaxErrorKind = UnexpectedInput (Just EndOfFile) [Literal ";"] + , syntaxErrorSourceLine = Just testConfig + }) + +testParseNoSemiColonMultiline :: SpecWith () +testParseNoSemiColonMultiline = do + let file = "test/files/noSemiColonMultiLine.cfv" + let testConfig = "exampleVar1 = 'example value 1';\nexampleVar2 = 'example value 2'\nexampleVar3 = 'example value 3';" + r <- runIO $ parseEvalCfv file testConfig + it "parseNoSemiColonMultiLine" $ r `shouldBe` (Left . FileSyntaxError $ SyntaxError + { syntaxErrorPosition = (Position + { posFile = file + , posLine = 3 + , posColumn = 1 + , posOffset = 65 }) + , syntaxErrorKind = UnexpectedInput (Just (Literal "e")) [Literal ";"] + , syntaxErrorSourceLine = Just "exampleVar3 = 'example value 3';" + }) + +testParseSecret :: SpecWith () +testParseSecret = do + let file = "test/files/secret.cfv" + let testConfig = "secret exampleVar = \"secret value\";" + r <- runIO $ parseEvalCfv file testConfig + it "testParseSecret" $ r `shouldBe` Right [("exampleVar", Var Secret "secret value")] + +testShowSecret :: SpecWith () +testShowSecret = do + let file = "test/files/secret.cfv" + let testConfig = "secret exampleVar = \"secret value\";" + r <- runIO $ parseEvalCfv file testConfig + it "testParseSecret" $ do + r `shouldBe` Right [("exampleVar", Var Secret "secret value")] + let (Right r') = r + (show r') `shouldBe` ("[(\"exampleVar\",Secret ())]") diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/files/basic.cfv b/test/files/basic.cfv new file mode 100644 --- /dev/null +++ b/test/files/basic.cfv @@ -0,0 +1,6 @@ +-- Basic set of config variables. +color="red"; +age='42'; +language="en"; +-- Get the current date from the shell. +current_date=`date`;