language-puppet 1.4.3 → 1.4.4
raw patch · 11 files changed
+169/−57 lines, 11 filesdep ~http-client
Dependency ranges changed: http-client
Files
- CHANGELOG +16/−0
- language-puppet.cabal +2/−2
- src/Puppet/Interpreter/Resolve.hs +6/−3
- src/Puppet/Language/NativeTypes/File.hs +1/−0
- src/Puppet/Parser/Internal.hs +21/−15
- src/Puppet/Runner/Daemon/OptionalTests.hs +21/−14
- src/Puppet/Runner/Puppetlabs.hs +31/−14
- src/Puppet/Runner/Stdlib.hs +25/−6
- src/PuppetDB/TestDB.hs +1/−0
- tests/Interpreter/Function/MergeSpec.hs +44/−2
- tests/Spec.hs +1/−1
CHANGELOG view
@@ -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 <pierrer@pi3r.be> 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 <pierrer@pi3r.be> 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
language-puppet.cabal view
@@ -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
src/Puppet/Interpreter/Resolve.hs view
@@ -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 =
src/Puppet/Language/NativeTypes/File.hs view
@@ -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])
src/Puppet/Parser/Internal.hs view
@@ -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)
src/Puppet/Runner/Daemon/OptionalTests.hs view
@@ -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)
src/Puppet/Runner/Puppetlabs.hs view
@@ -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
src/Puppet/Runner/Stdlib.hs view
@@ -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"
src/PuppetDB/TestDB.hs view
@@ -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
tests/Interpreter/Function/MergeSpec.hs view
@@ -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")])]
tests/Spec.hs view
@@ -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