diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,10 +1,26 @@ +language-puppet (1.4.5) artful; urgency=medium + +language-puppet (1.4.4) artful; urgency=medium + + * Add the `deep_merge` stdlib function. + * Add placeholder function for 'epp' template (see #251) + * Add `recurse` support for the file resource. + * Add `show_diff` parameter to the file resource. + * Add a workaround in case some external module uses the `require` function. + + -- Pierre Radermecker Wed, 17 April 2019 16:32:48 +0100 + language-puppet (1.4.3) artful; urgency=medium + * Add the `dirname` stdlib function. * Add validate_cmd param to concat. * Support double assignment: see #201 * Support namespace in function name: see #271 + -- Pierre Radermecker Wed, 20 Feb 2019 21:32:48 +0100 + language-puppet (1.4.2) artful; urgency=medium + * Bump upper version bounds for some haskell packages language-puppet (1.4.1) artful; urgency=medium diff --git a/language-puppet.cabal b/language-puppet.cabal --- a/language-puppet.cabal +++ b/language-puppet.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet -version: 1.4.3 +version: 1.4.4 synopsis: Tools to parse and evaluate the Puppet DSL. description: This is a set of tools that is supposed to fill all your Puppet needs : syntax checks, catalog compilation, PuppetDB queries, simulation of complex interactions between nodes, Puppet master replacement, and more ! homepage: http://lpuppet.banquise.net/ @@ -111,7 +111,7 @@ , formatting , hashable == 1.2.* , http-api-data >= 0.2 && < 0.5 - , http-client >= 0.4.30 && < 0.6 + , http-client >= 0.4.30 && < 0.7 , hruby >= 0.3.2 && < 0.4 , hslogger == 1.2.* , lens >= 4.12 && < 5 diff --git a/src/Puppet/Interpreter/Resolve.hs b/src/Puppet/Interpreter/Resolve.hs --- a/src/Puppet/Interpreter/Resolve.hs +++ b/src/Puppet/Interpreter/Resolve.hs @@ -526,6 +526,9 @@ scp <- getScopeName scpset <- use (scopes . ix scp . scopeExtraTags) pure (PBoolean (scpset `HS.intersection` tags == tags)) +resolveFunction' "epp" [] = throwPosError "epp(): Expects at least one argument" +-- TODO Epp not yet implemented see #251 +resolveFunction' "epp" _ = pure $ PString "<< -- EPP templates are not supported yet -- >>" resolveFunction' "template" [] = throwPosError "template(): Expects at least one argument" resolveFunction' "template" templates = let compute = fmap (Filename . Text.unpack) . resolvePValueString >=> calcTemplate @@ -592,9 +595,9 @@ calcTemplate :: TemplateSource -> InterpreterMonad Text -calcTemplate templatetype = do - intpstate <- use identity - Operational.singleton (ComputeTemplate templatetype intpstate) +calcTemplate tplsrc = do + interp_state <- use identity + Operational.singleton (ComputeTemplate tplsrc interp_state) resolveExpressionSE :: Expression -> InterpreterMonad PValue resolveExpressionSE e = diff --git a/src/Puppet/Language/NativeTypes/File.hs b/src/Puppet/Language/NativeTypes/File.hs --- a/src/Puppet/Language/NativeTypes/File.hs +++ b/src/Puppet/Language/NativeTypes/File.hs @@ -34,6 +34,7 @@ ,("recurse" , [string, values ["inf","true","false","remote"]]) ,("recurselimit" , [integer]) ,("replace" , [string, values ["true","false","yes","no"]]) + ,("show_diff" , [string, values ["true","false"]]) ,("sourceselect" , [values ["first","all"]]) ,("seltype" , [string]) ,("selrange" , [string]) diff --git a/src/Puppet/Parser/Internal.hs b/src/Puppet/Parser/Internal.hs --- a/src/Puppet/Parser/Internal.hs +++ b/src/Puppet/Parser/Internal.hs @@ -94,9 +94,12 @@ isIdentifierChar :: Char -> Bool isIdentifierChar x = Char.isAsciiLower x || Char.isAsciiUpper x || Char.isDigit x || (x == '_') --- | Like 'isIndentifierChar' but hyphens (-) are allowed. -isBarewordChar :: Char -> Bool -isBarewordChar x = isIdentifierChar x || (x == '-') +-- | Like 'indentifier' but hyphens (-) are allowed. +bareword :: Parser Text +bareword = Text.cons <$> satisfy Char.isAsciiLower <*> takeWhileP Nothing isBarewordChar + where + isBarewordChar :: Char -> Bool + isBarewordChar x = isIdentifierChar x || (x == '-') reserved :: Text -> Parser () reserved s = @@ -126,19 +129,22 @@ variableName :: Parser Text variableName = qualif identifier +-- yay with reserved words +typeName :: Parser Text +typeName = className + className :: Parser Text -className = lexeme $ qualif moduleName +className = lexeme $ qualif $ genericModuleName False funcName :: Parser Text funcName = lexeme $ qualif $ genericModuleName False --- yay with reserved words -typeName :: Parser Text -typeName = className - moduleName :: Parser Text moduleName = lexeme $ genericModuleName False +parameterName :: Parser Text +parameterName = moduleName + resourceNameRef :: Parser Text resourceNameRef = lexeme $ qualif (genericModuleName True) @@ -150,9 +156,6 @@ else satisfy Char.isAsciiLower (Text.cons) <$> firstletter <*> takeWhileP Nothing acceptable -parameterName :: Parser Text -parameterName = moduleName - -- | Variable expression varExpression :: Parser Expression varExpression = Terminal . UVariableReference <$> variableReference @@ -239,11 +242,9 @@ args <- withparens <|> withoutparens pure (fname, V.fromList args) - literalValue :: Parser UnresolvedValue literalValue = lexeme (fmap UString stringLiteral' <|> fmap UString bareword <|> fmap UNumber numericalvalue "Literal Value") where - bareword = Text.cons <$> satisfy Char.isAsciiLower <*> takeWhileP Nothing isBarewordChar "Bare word" signed :: Num n => Parser (n -> n) signed = (negate <$ char '-') <|> pure (\x -> x) numericalvalue = ((,) <$> signed <*> integerOrDouble) >>= \case @@ -465,7 +466,7 @@ (AttributeDecl <$> lexeme key <*> arrowOp <*> expression) <|> (AttributeWildcard <$> (symbolic '*' *> symbol "=>" *> expression)) where - key = (Text.cons) <$> (satisfy Char.isAsciiLower) <*> takeWhileP Nothing isBarewordChar "Assignment key" + key = bareword "Assignment key" arrowOp = (AssignArrow <$ symbol "=>") <|> (AppendArrow <$ symbol "+>") @@ -560,6 +561,9 @@ pe <- getSourcePos pure [ ResOverrideDecl restype n assignments (p :!: pe) | n <- names ] +arrayof :: Parser p -> Parser [p] +arrayof p = symbolic '[' *> sepBy p comma <* symbolic ']' + -- | Heterogeneous chain (interleaving resource declarations with -- resource references) needs to be supported: -- @@ -576,7 +580,8 @@ pe <- getSourcePos pure (ChainResRefr restype resnames (p :!: pe)) _ -> ChainResColl <$> resCollDecl p restype - chain <- parseRelationships $ pure <$> try withresname <|> map ChainResDecl <$> resDeclGroup + let oneresource = pure <$> try withresname <|> map ChainResDecl <$> resDeclGroup + chain <- parseRelationships (oneresource <|> concat <$> arrayof oneresource) let relations = do (g1, g2, lt) <- zipChain chain (rt1, rn1, _ :!: pe1) <- concatMap extractResRef g1 @@ -762,6 +767,7 @@ , reserved "Systemd::Unit" $> UDTData , reserved "Systemd::ServiceLimits" $> UDTData , reserved "Systemd::Dropin" $> UDTData + , reserved "Systemd::JournaldSettings" $> UDTData ] statementList :: Parser (Vector Statement) diff --git a/src/Puppet/Runner/Daemon/OptionalTests.hs b/src/Puppet/Runner/Daemon/OptionalTests.hs --- a/src/Puppet/Runner/Daemon/OptionalTests.hs +++ b/src/Puppet/Runner/Daemon/OptionalTests.hs @@ -58,20 +58,24 @@ presentFile r = r ^. rid . itype == "file" && (r ^. rattributes . at "ensure") `elem` [Nothing, Just "present"] && r ^. rattributes . at "source" /= Just PUndef - getsource = mapMaybe (\r -> (,) <$> pure r <*> r ^. rattributes . at "source") + recurse r = case r ^? rattributes . ix "recurse" of + Just (PString "true") -> True + Just (PBoolean b) -> b + _ -> False + getsource = mapMaybe (\r -> (,,) <$> pure r <*> r ^. rattributes . at "source" <*> pure (recurse r)) checkAllSources basedir $ (getsource . getfiles) c -- | Check source for all file resources and append failures along. -checkAllSources :: FilePath -> [(Resource, PValue)] -> ExceptT PrettyError IO () +checkAllSources :: FilePath -> [(Resource, PValue, Bool)] -> ExceptT PrettyError IO () checkAllSources fp fs = -- we could just do : -- traverse_ (\(res, src) -> catchE (checkFile fp src) (throwE ...)) fs -- but that would print the first encountered failure. go fs [] where - go :: [(Resource, PValue)] -> [PrettyError] -> ExceptT PrettyError IO () - go ((res, filesrc):xs) es = ExceptT $ do - runExceptT (checkFile fp filesrc) >>= \case + go :: [(Resource, PValue, Bool)] -> [PrettyError] -> ExceptT PrettyError IO () + go ((res, filesrc, recurse):xs) es = ExceptT $ do + runExceptT (checkFile fp filesrc recurse) >>= \case Right () -> runExceptT $ go xs es Left err -> runExceptT @@ -82,22 +86,25 @@ go [] [] = pure () go [] es = throwE (mconcat es) -testFile :: FilePath -> ExceptT PrettyError IO () -testFile fp = do +testFile :: Bool -> FilePath -> ExceptT PrettyError IO () +testFile recurse fp = do p <- liftIO (Directory.doesFileExist fp) - unless p (throwE $ PrettyError $ "searched in" <+> squotes (pptext fp)) + p' <- if recurse && not p + then liftIO (Directory.doesDirectoryExist fp) + else return p + unless p' (throwE $ PrettyError $ "searched in" <+> squotes (pptext fp)) -- | Only test the `puppet:///` protocol (files managed by the puppet server) -- we don't test absolute path (puppet client files) -checkFile :: FilePath -> PValue -> ExceptT PrettyError IO () -checkFile basedir (PString f) = +checkFile :: FilePath -> PValue -> Bool -> ExceptT PrettyError IO () +checkFile basedir (PString f) recurse = case Text.stripPrefix "puppet:///" f of Just stringdir -> case Text.splitOn "/" stringdir of - ("modules":modname:rest) -> testFile (basedir <> "/modules/" <> toS modname <> "/files/" <> toS (Text.intercalate "/" rest)) - ("files":rest) -> testFile (basedir <> "/files/" <> toS (Text.intercalate "/" rest)) + ("modules":modname:rest) -> testFile recurse (basedir <> "/modules/" <> toS modname <> "/files/" <> toS (Text.intercalate "/" rest)) + ("files":rest) -> testFile recurse (basedir <> "/files/" <> toS (Text.intercalate "/" rest)) ("private":_) -> pure () _ -> throwE (PrettyError $ "Invalid file source:" <+> ppline f) Nothing -> return () -- source is always an array of possible paths. We only fails if none of them check. -checkFile basedir (PArray xs) = asum [checkFile basedir x | x <- toList xs] -checkFile _ x = throwE (PrettyError $ "Source was not a string, but" <+> pretty x) +checkFile basedir (PArray xs) recurse = asum [checkFile basedir x recurse | x <- toList xs] +checkFile _ x _ = throwE (PrettyError $ "Source was not a string, but" <+> pretty x) diff --git a/src/Puppet/Runner/Puppetlabs.hs b/src/Puppet/Runner/Puppetlabs.hs --- a/src/Puppet/Runner/Puppetlabs.hs +++ b/src/Puppet/Runner/Puppetlabs.hs @@ -30,19 +30,21 @@ , ("docker", "docker_swarm_init_flags", mockDockerSwarmInitFlags) , ("docker", "docker_run_flags", mockDockerRunFlags) , ("docker", "docker_stack_flags", mockDockerStackFlags) + , ("docker", "sanitised_name", dockerSanitisedName) , ("jenkins", "jenkins_port", mockJenkinsPort) , ("jenkins", "jenkins_prefix", mockJenkinsPrefix) , ("postgresql", "postgresql_acls_to_resources_hash", pgAclsToHash) , ("postgresql", "postgresql_password", pgPassword) - , ("puppetdb", "puppetdb_create_subsetting_resource_hash", puppetdb_create_subsetting_resource_hash) + , ("puppetdb", "puppetdb_create_subsetting_resource_hash", puppetdbCreateSubsettingResourceHash) , ("extlib", "random_password", randomPassword) , ("extlib", "cache_data", mockCacheData) , ("kubernetes", "kubeadm_init_flags", mockKubernetesInitFlags) + , ("kubernetes", "kubeadm_join_flags", mockKubernetesJoinFlags) ] -- | Build the map of available external functions. -- --- If the ruby file is not found on the local filesystem the record is ignored. This is to avoid potential namespace conflict. +-- If the ruby/puppet file is not found on the local filesystem the record is ignored. This is to avoid potential namespace conflict. extFunctions :: FilePath -> IO (Container ( [PValue] -> InterpreterMonad PValue)) extFunctions modpath = foldlM f Map.empty extFun where @@ -51,16 +53,19 @@ if test then pure $ Map.insert name fn acc else pure acc - testFile nspath funcname = do - let funcpath0 = modpath nspath "lib/puppet" - funcpath1 = funcpath0 "parser/functions" - funcpath2 = funcpath0 "functions" - filename = toS funcname <.> "rb" - isJust <$> Directory.findFile [ funcpath1 - , funcpath2 - , funcpath1 nspath + testFile nspath funcname = + let funcpath0 = modpath nspath + funcpath1 = funcpath0 "lib/puppet" + funcpath2 = funcpath1 "parser/functions" + funcpath3 = funcpath1 "functions" + in + isJust <$> Directory.findFile [ funcpath0 "functions"] (toS funcname <.> "pp") + ||^ + isJust <$> Directory.findFile [ funcpath2 + , funcpath3 , funcpath2 nspath - ] filename + , funcpath3 nspath + ] (toS funcname <.> "rb") apacheBool2httpd :: MonadThrowPos m => [PValue] -> m PValue apacheBool2httpd [PBoolean True] = pure $ PString "On" @@ -164,6 +169,11 @@ mockKubernetesInitFlags arg@[PHash _]= (pure . PString . show . head) arg mockKubernetesInitFlags arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg +-- faked implementation, replace by the correct one if you need so. +mockKubernetesJoinFlags :: MonadThrowPos m => [PValue] -> m PValue +mockKubernetesJoinFlags arg@[PHash _]= (pure . PString . show . head) arg +mockKubernetesJoinFlags arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg + -- utils scientificToInt :: MonadThrowPos m => Scientific -> m Int scientificToInt s = maybe (throwPosError $ "Unable to convert" <+> pretty s <+> "into an int.") @@ -171,11 +181,18 @@ (Sci.toBoundedInteger s) -- https://github.com/puppetlabs/puppetlabs-puppetdb/blob/master/lib/puppet/parser/functions/puppetdb_create_subsetting_resource_hash.rb -puppetdb_create_subsetting_resource_hash :: MonadThrowPos m => [PValue] -> m PValue -puppetdb_create_subsetting_resource_hash [PHash s, PHash args] = do +puppetdbCreateSubsettingResourceHash :: MonadThrowPos m => [PValue] -> m PValue +puppetdbCreateSubsettingResourceHash [PHash s, PHash args] = do let res_hash = [ (k, PHash h) | (k,v) <- itoList s , let h = [ ( "subsetting", PString k) , ("value", v)] `Map.union` args ] pure $ PHash (Map.fromList res_hash) -puppetdb_create_subsetting_resource_hash arg@_ = throwPosError $ "Expect 2 hashes as arguments but was" <+> pretty arg +puppetdbCreateSubsettingResourceHash arg@_ = throwPosError $ "Expect 2 hashes as arguments but was" <+> pretty arg + +-- To be implemented if needed. +dockerSanitisedName :: MonadThrowPos m => [PValue] -> m PValue +dockerSanitisedName [PString s] = + -- ruby implementation: regsubst($name, '[^0-9A-Za-z.\-_]', '-', 'G') + pure $ PString s +dockerSanitisedName arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg diff --git a/src/Puppet/Runner/Stdlib.hs b/src/Puppet/Runner/Stdlib.hs --- a/src/Puppet/Runner/Stdlib.hs +++ b/src/Puppet/Runner/Stdlib.hs @@ -41,7 +41,7 @@ , ("concat", puppetConcat) -- convert_base , ("count", puppetCount) - -- deep_merge + , ("deep_merge", deepMerge) , ("defined_with_params", const (throwPosError "defined_with_params can't be implemented with language-puppet")) , ("delete", delete) , ("delete_at", deleteAt) @@ -414,11 +414,30 @@ hasKey _ = throwPosError "has_key(): expected two arguments." merge :: [PValue] -> InterpreterMonad PValue -merge xs | length xs < 2 = throwPosError "merge(): Expects at least two hashes" - | otherwise = let hashcontents = mapM (preview _PHash) xs - in case hashcontents of - Nothing -> throwPosError "merge(): Expects hashes" - Just hashes -> return $ PHash (getDual $ foldMap Dual hashes) +merge xs + | length xs < 2 = throwPosError "merge(): Expects at least two hashes" + | otherwise = + let hashcontents = mapM (preview _PHash) xs + in + case hashcontents of + Nothing -> throwPosError "merge(): Expects hashes" + Just hashes -> return $ PHash (getDual $ foldMap Dual hashes) + +deepMerge :: [PValue] -> InterpreterMonad PValue +deepMerge xs + | length xs < 2 = throwPosError "deep_merge(): Expects at least two hashes" + | otherwise = + let hashcontents = mapM (preview _PHash) xs + in + case hashcontents of + Nothing -> throwPosError "deep_merge(): Expects hashes" + Just hashes -> pure $ PHash (List.foldr1 rec_merge hashes) + where + rec_merge :: Container PValue -> Container PValue -> Container PValue + rec_merge a b = HM.unionWith f a b + f :: PValue -> PValue -> PValue + f (PHash a) (PHash b) = PHash $ rec_merge a b + f _ h = h pick :: [PValue] -> InterpreterMonad PValue pick [] = throwPosError "pick(): must receive at least one non empty value" diff --git a/src/PuppetDB/TestDB.hs b/src/PuppetDB/TestDB.hs --- a/src/PuppetDB/TestDB.hs +++ b/src/PuppetDB/TestDB.hs @@ -54,6 +54,7 @@ then newFile else baseError (ppstring s) Left (InvalidYaml (Just (YamlParseException pb ctx (YamlMark _ l c)))) -> baseError $ red (ppstring pb <+> ppstring ctx) <+> "at line" <+> pretty l <> ", column" <+> pretty c + Left (AesonException e) -> baseError (fromString e) Left _ -> newFile Right x -> fmap Right (genDBAPI (x & backingFile ?~ fp )) where diff --git a/tests/Interpreter/Function/MergeSpec.hs b/tests/Interpreter/Function/MergeSpec.hs --- a/tests/Interpreter/Function/MergeSpec.hs +++ b/tests/Interpreter/Function/MergeSpec.hs @@ -10,14 +10,19 @@ main :: IO () main = hspec spec +spec = do + spec0 + spec1 + evalArgs :: InterpreterMonad PValue -> Either PrettyError (HM.HashMap Text PValue) evalArgs = dummyEval >=> \pv -> case pv of PHash s -> return s _ -> Left ("Expected a string, not " <> PrettyError (pretty pv)) -spec :: Spec -spec = withStdlibFunction "merge" $ \mergeFunc -> do +spec0 :: Spec +spec0 = do + withStdlibFunction "merge" $ \mergeFunc -> do let evalArgs' = evalArgs . mergeFunc let check args res = case evalArgs' (map PHash args) of Left rr -> expectationFailure (show rr) @@ -38,3 +43,40 @@ check [ [], [("key", "value")] ] [("key","value")] check [ [("key1", "value1")], [("key2", "value2")], [("key3", "value3")] ] [("key1", "value1"), ("key2", "value2"), ("key3", "value3")] check [ [("key", "value1")], [("key", "value2")] ] [("key","value2")] + +spec1 :: Spec +spec1 = do + describe "deep_merge" $ do + withStdlibFunction "deep_merge" $ \mergeFunc -> do + let evalArgs' = evalArgs . mergeFunc + let check args res = case evalArgs' (map PHash args) of + Left rr -> expectationFailure (show rr) + Right res' -> res' `shouldBe` res + checkError args ins = case evalArgs' args of + Left rr -> show rr `shouldContain` ins + Right r -> expectationFailure ("Should have errored, received this instead: " <> show r) + + it "should error with invalid arguments" $ do + checkError [] "Expects at least two hashes" + checkError [PNumber 1] "Expects at least two hashes" + checkError [PBoolean True] "Expects at least two hashes" + checkError ["foo"] "Expects at least two hashes" + it "should handle empty hashes" $ do + check [[],[]] [] + check [[],[],[]] [] + it "should deeply merge hashes" $ do + check [ [("key", "value")], [] ] [("key","value")] + check [ [], [("key", "value")] ] [("key","value")] + check [ [("key1", "value1")] + , [("key2", "value2")] + , [("key3", "value3")] + ] [("key1", "value1"), ("key2", "value2"), ("key3", "value3")] + check [ [("key", "value1")] + , [("key", "value2")] + ] [("key","value2")] + check [ [("key", PHash [("key00", "value00")])] + , [("key", PHash [("key01", "value01")])] + ] [("key", PHash [("key01", PString "value01"), ("key00", PString "value00")])] + check [ [("key", PHash [("key01", "value00")])] + , [("key", PHash [("key01", "value01")])] + ] [("key", PHash [("key01", PString "value01")])] diff --git a/tests/Spec.hs b/tests/Spec.hs --- a/tests/Spec.hs +++ b/tests/Spec.hs @@ -45,7 +45,7 @@ describe "stdlib functions" $ do describe "The assert_private function" Interpreter.Function.AssertPrivateSpec.spec describe "The join_keys_to_values function" Interpreter.Function.JoinKeysToValuesSpec.spec - describe "The merge function" Interpreter.Function.MergeSpec.spec + describe "The function" Interpreter.Function.MergeSpec.spec describe "The size function" Interpreter.Function.SizeSpec.spec describe "The delete_at function" Interpreter.Function.DeleteAtSpec.spec describe "puppet functions" $ do