language-puppet 1.3.7 → 1.3.8
raw patch · 20 files changed
+293/−65 lines, 20 files
Files
- CHANGELOG.markdown +6/−0
- Puppet/Daemon.hs +2/−1
- Puppet/Interpreter.hs +7/−5
- Puppet/Interpreter/PrettyPrinter.hs +1/−0
- Puppet/Interpreter/Resolve.hs +45/−2
- Puppet/Interpreter/Types.hs +14/−2
- Puppet/Interpreter/Utils.hs +4/−1
- Puppet/Lens.hs +2/−3
- Puppet/Parser.hs +99/−33
- Puppet/Parser/PrettyPrinter.hs +38/−7
- Puppet/Parser/Types.hs +37/−2
- Puppet/Stdlib.hs +0/−1
- PuppetDB/TestDB.hs +0/−1
- README.adoc +6/−3
- language-puppet.cabal +4/−3
- progs/PuppetResources.hs +1/−1
- tests/DT/Parser.hs +19/−0
- tests/Spec.hs +3/−0
- tests/evals.hs +2/−0
- tests/expr.hs +3/−0
CHANGELOG.markdown view
@@ -1,3 +1,9 @@+# v1.3.8 (2017/07/20)++* Add support for calling Functions in Strings (#199)+* Add $facts hash for Puppet 4 (#198)+* Initial support for datatype syntax (#206)+ # v1.3.7 (2017/03/14) * Add puppet `sprintf` function
Puppet/Daemon.hs view
@@ -28,6 +28,7 @@ import System.Log.Handler (setFormatter) import qualified System.Log.Handler.Simple as LOG (streamHandler) import qualified System.Log.Logger as LOG+import qualified Text.Megaparsec as P import Erb.Compute import Hiera.Server@@ -184,7 +185,7 @@ cnt <- T.readFile fname o <- case runPParser fname cnt of Right r -> traceEventIO ("Stopped parsing " ++ fname) >> return (S.Right r)- Left rr -> traceEventIO ("Stopped parsing " ++ fname ++ " (failure: " ++ show rr ++ ")") >> return (S.Left (show rr))+ Left rr -> traceEventIO ("Stopped parsing " ++ fname ++ " (failure: " ++ show rr ++ ")") >> return (S.Left (P.parseErrorPretty rr)) traceEventIO ("STOP parsing " ++ fname) return o
Puppet/Interpreter.hs view
@@ -210,7 +210,7 @@ evaluateNode (NodeDecl _ sx inheritnode p) = do curPos .= p pushScope ContRoot- unless (S.isNothing inheritnode) $ throwPosError "Node inheritance is not handled yet, and will probably never be"+ unless (S.isNothing inheritnode) $ throwPosError "Node inheritance is not handled. It is deprecated since puppet v4" mapM evaluateStatement sx >>= finalize . concat noderes <- evaluateNode nd >>= finalStep . (++ (mainstage : topres))@@ -557,11 +557,11 @@ -- -- It is able to fill unset parameters with values from Hiera (for classes -- only) or default values.-loadParameters :: Foldable f => Container PValue -> f (Pair Text (S.Maybe Expression)) -> PPosition -> S.Maybe T.Text -> InterpreterMonad ()+loadParameters :: Foldable f => Container PValue -> f (Pair (Pair Text (S.Maybe DataType)) (S.Maybe Expression)) -> PPosition -> S.Maybe T.Text -> InterpreterMonad () loadParameters params classParams defaultPos wHiera = do p <- use curPos curPos .= defaultPos- let classParamSet = HS.fromList (classParams ^.. folded . _1)+ let classParamSet = HS.fromList (classParams ^.. folded . _1 . _1) spuriousParams = ikeys params `HS.difference` classParamSet mclassdesc = S.maybe mempty ((\x -> mempty <+> "when including class" <+> x) . ttext) wHiera @@ -588,10 +588,12 @@ -- try to set a value to all parameters -- The order of evaluation is defined / hiera / default- unsetParams <- fmap concat $ for (toList classParams) $ \(k :!: defValue) -> do+ unsetParams <- fmap concat $ for (toList classParams) $ \(k :!: mtype :!: defValue) -> do ev <- runExceptT (checkDef k <|> checkHiera k <|> checkDefault defValue) case ev of- Right v -> loadVariable k v >> return []+ Right v -> do+ forM_ mtype $ \dt -> unless (datatypeMatch dt v) (throwPosError ("Expected type" <+> pretty dt <+> "for parameter" <+> pretty k <+> "but its value was:" <+> pretty v))+ loadVariable k v >> return [] Left (Max True) -> loadVariable k PUndef >> return [] Left (Max False) -> return [k] curPos .= p
Puppet/Interpreter/PrettyPrinter.hs view
@@ -50,6 +50,7 @@ pretty (PResourceReference t n) = capitalize t <> brackets (text (T.unpack n)) pretty (PArray v) = list (map pretty (V.toList v)) pretty (PHash g) = containerComma g+ pretty (PType dt) = pretty dt instance Pretty TopLevelType where pretty TopNode = dullyellow (text "node")
Puppet/Interpreter/Resolve.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-} -- | This module is all about converting and resolving foreign data into -- the fully exploitable corresponding data type. The main use case is the -- conversion of 'Expression' to 'PValue'.@@ -26,7 +27,8 @@ hfSetvars, hfRestorevars, toNumbers,- fixResourceName+ fixResourceName,+ datatypeMatch ) where import Control.Lens@@ -45,7 +47,8 @@ import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS-import Data.Maybe (fromMaybe, mapMaybe)+import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe (fromMaybe, mapMaybe, catMaybes) import qualified Data.Maybe.Strict as S import Data.Scientific import qualified Data.Text as T@@ -285,6 +288,9 @@ Left (_,rr) -> throwPosError ("Could not match" <+> pretty v <+> ":" <+> string rr) Right Nothing -> checkCond xs Right (Just _) -> resolveExpression ce+ checkCond ((SelectorType dt :!: ce) : xs) = if datatypeMatch dt rese+ then resolveExpression ce+ else checkCond xs checkCond ((SelectorValue uv :!: ce) : xs) = do rv <- resolveValue uv if puppetEquality rese rv@@ -712,3 +718,40 @@ PHash hh -> return $ PHash $ HM.fromList $ map Prelude.fst $ filter Prelude.snd $ Prelude.zip (HM.toList hh) res x -> throwPosError ("Can't iterate on this data type:" <+> pretty x) x -> throwPosError ("This type of function is not supported yet by language-puppet!" <+> pretty x)++-- | Checks that a value matches a puppet datatype+datatypeMatch :: DataType -> PValue -> Bool+datatypeMatch dt v+ = case dt of+ DTType -> has _PType v+ DTUndef -> v == PUndef+ NotUndef -> v /= PUndef+ DTString mmin mmax -> boundedBy _PString T.length mmin mmax+ DTInteger mmin mmax -> boundedBy (_PNumber . to toBoundedInteger . _Just) id mmin mmax+ DTFloat mmin mmax -> boundedBy _PNumber toRealFloat mmin mmax+ DTBoolean -> has _PBoolean v+ DTArray sdt mi mmx -> container (_PArray . to V.toList) (datatypeMatch sdt) mi mmx+ DTHash kt sdt mi mmx -> container (_PHash . to itoList) (\(k,a) -> datatypeMatch kt (PString k) && datatypeMatch sdt a) mi mmx+ DTScalar -> datatypeMatch (DTVariant (DTInteger Nothing Nothing :| [DTString Nothing Nothing, DTBoolean])) v+ DTData -> datatypeMatch (DTVariant (DTScalar :| [DTArray DTData 0 Nothing, DTHash DTScalar DTData 0 Nothing])) v+ DTOptional sdt -> datatypeMatch (DTVariant (DTUndef :| [sdt])) v+ DTVariant sdts -> any (`datatypeMatch` v) sdts+ DTEnum lst -> maybe False (`elem` lst) (v ^? _PString)+ DTAny -> True+ DTCollection -> datatypeMatch (DTVariant (DTArray DTData 0 Nothing :| [DTHash DTScalar DTData 0 Nothing])) v+ DTPattern patterns -> maybe False (\str -> any (checkPattern (T.encodeUtf8 str)) patterns) (v ^? _PString)+ where+ checkPattern str (CompRegex _ ptrn)+ = case execute' ptrn str of+ Right (Just _) -> True+ _ -> False+ container :: Fold PValue [a] -> (a -> Bool) -> Int -> Maybe Int -> Bool+ container f c mi mmx =+ let lst = v ^. f+ ln = length lst+ in ln >= mi && (fmap (ln <=) mmx /= Just False) && all c lst+ boundedBy :: Ord b => Fold PValue a -> (a -> b) -> Maybe b -> Maybe b -> Bool+ boundedBy prm f mmin mmax+ = fromMaybe False $ do+ vr <- f <$> v ^? prm+ return $ and $ catMaybes [fmap (vr >=) mmin, fmap (vr <=) mmax]
Puppet/Interpreter/Types.hs view
@@ -41,7 +41,17 @@ , HasInterpreterState(..) , InterpreterState(InterpreterState) -- * Sum types+ -- ** PValue , PValue(..)+ , _PType+ , _PBoolean+ , _PString+ , _PResourceReference+ , _PArray+ , _PHash+ , _PNumber+ , _PUndef+ -- ** Misc , CurContainerDesc(..) , ResourceCollectorType(..) , RSearchExpression(..)@@ -148,6 +158,7 @@ | PArray !(V.Vector PValue) | PHash !(Container PValue) | PNumber !Scientific+ | PType DataType deriving (Eq, Show) instance IsString PValue where@@ -270,7 +281,7 @@ , _readerGetStatement :: TopLevelType -> Text -> m (S.Either PrettyError Statement) , _readerGetTemplate :: Either Text T.Text -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError T.Text) , _readerPdbApi :: PuppetDBAPI m- , _readerExternalFunc :: Container ([PValue] -> InterpreterMonad PValue)+ , _readerExternalFunc :: Container ([PValue] -> InterpreterMonad PValue) -- ^ external func such as stdlib or puppetlabs , _readerNodename :: Text , _readerHieraQuery :: HieraQueryFunc m , _readerIoMethods :: IoMethods m@@ -485,7 +496,7 @@ makeClassy ''NodeInfo makeClassy ''WireCatalog makeClassy ''FactInfo-+makePrisms ''PValue class Monad m => MonadThrowPos m where throwPosError :: Doc -> m a@@ -531,6 +542,7 @@ parseJSON (Object o) = fmap PHash (TR.mapM parseJSON o) instance ToJSON PValue where+ toJSON (PType t) = toJSON t toJSON (PBoolean b) = Bool b toJSON PUndef = Null toJSON (PString s) = String s
Puppet/Interpreter/Utils.hs view
@@ -31,7 +31,10 @@ initialState facts settings = InterpreterState baseVars initialclass mempty [ContRoot] dummyppos mempty [] [] where callervars = HM.fromList [("caller_module_name", PString "::" :!: dummyppos :!: ContRoot), ("module_name", PString "::" :!: dummyppos :!: ContRoot)]- factvars = fmap (\x -> x :!: initialPPos "facts" :!: ContRoot) facts+ factvars =+ -- add the `facts` key: https://docs.puppet.com/puppet/4.10/lang_facts_and_builtin_vars.html#accessing-facts-from-puppet-code+ let facts' = HM.insert "facts" (PHash facts) facts+ in fmap (\x -> x :!: initialPPos "facts" :!: ContRoot) facts' settingvars = fmap (\x -> PString x :!: initialPPos "settings" :!: ContClass "settings") settings baseVars = HM.fromList [ ("::", ScopeInformation (factvars `mappend` callervars) mempty mempty (CurContainer ContRoot mempty) mempty S.Nothing) , ("settings", ScopeInformation settingvars mempty mempty (CurContainer (ContClass "settings") mempty) mempty S.Nothing)
Puppet/Lens.hs view
@@ -3,7 +3,7 @@ ( -- * Pure resolution prisms _PResolveExpression , _PResolveValue- -- * Prisms for PValues+ -- * Prisms for PValues (reexport from "Puppet.Interpreter.Types") , _PHash , _PBoolean , _PString@@ -67,8 +67,6 @@ import Data.Tuple.Strict hiding (uncurry) import Control.Exception (SomeException, toException, fromException) --- Prisms-makePrisms ''PValue --makePrisms ''Statement makePrisms ''Expression @@ -152,6 +150,7 @@ toU (PResourceReference t n) = UResourceReference t (Terminal (UString n)) toU (PArray r) = UArray (fmap (Terminal . toU) r) toU (PHash h) = UHash (V.fromList $ map (\(k,v) -> (Terminal (UString k) :!: Terminal (toU v))) $ HM.toList h)+ toU (PType _) = error "TODO, _PResolveValue PType undefined" -- | Extracts the statements from 'ClassDeclaration', 'DefineDeclaration', -- 'Node' and the spurious statements of 'TopContainer'.
Puppet/Parser.hs view
@@ -6,6 +6,7 @@ -- * Parsers , puppetParser , expression+ , datatype ) where import Control.Applicative@@ -13,7 +14,10 @@ import Control.Monad import Data.Char import qualified Data.Foldable as F+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE import qualified Data.Maybe.Strict as S+import Data.Maybe (fromMaybe) import Data.Scientific import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -86,16 +90,19 @@ symbolic '?' return $ maybe trm ($ trm) lookups let cas = do- c <- (SelectorDefault <$ symbol "default") -- default case- <|> fmap SelectorValue (fmap UVariableReference variableReference- <|> fmap UBoolean puppetBool- <|> (UUndef <$ symbol "undef")- <|> literalValue- <|> fmap UInterpolable interpolableString- <|> (URegexp <$> termRegexp))- void $ symbol "=>"- e <- expression- return (c :!: e)+ c <- (SelectorDefault <$ symbol "default") -- default case+ <|> fmap SelectorType (try datatype)+ <|> fmap SelectorValue+ ( fmap UVariableReference variableReference+ <|> fmap UBoolean puppetBool+ <|> (UUndef <$ symbol "undef")+ <|> literalValue+ <|> fmap UInterpolable interpolableString+ <|> (URegexp <$> termRegexp)+ )+ void $ symbol "=>"+ e <- expression+ return (c :!: e) cases <- braces (sepComma1 cas) return (ConditionalValue selectedExpression (V.fromList cases)) @@ -198,17 +205,12 @@ return v rvariable = Terminal . UVariableReference <$> rvariableName simpleIndexing = Lookup <$> rvariable <*> between (symbolic '[') (symbolic ']') expression- interpolableVariableReference = try $ do+ interpolableVariableReference = do void (char '$')- lookAhead anyChar >>= \c -> case c of- '{' -> between (symbolic '{') (char '}') ( try simpleIndexing- <|> rvariable- )- -- This is not as robust as the "qualif"- -- implementation, but considerably shorter.- --- -- This needs refactoring.- _ -> rvariable+ let fenced = try (simpleIndexing <* char '}')+ <|> try (rvariable <* char '}')+ <|> (expression <* char '}')+ (symbolic '{' *> fenced) <|> try rvariable <|> pure (Terminal (UString (T.singleton '$'))) regexp :: Parser T.Text regexp = do@@ -377,15 +379,17 @@ pe <- getPosition return (DefineDecl name params st (p :!: pe)) -puppetClassParameters :: Parser (V.Vector (Pair T.Text (S.Maybe Expression)))+puppetClassParameters :: Parser (V.Vector (Pair (Pair T.Text (S.Maybe DataType)) (S.Maybe Expression))) puppetClassParameters = V.fromList <$> parens (sepComma var) where toStrictMaybe (Just x) = S.Just x toStrictMaybe Nothing = S.Nothing- var :: Parser (Pair T.Text (S.Maybe Expression))- var = (:!:)- <$> variableReference- <*> (toStrictMaybe <$> optional (symbolic '=' *> expression))+ var :: Parser (Pair (Pair T.Text (S.Maybe DataType)) (S.Maybe Expression))+ var = do+ tp <- toStrictMaybe <$> optional datatype+ n <- variableReference+ df <- toStrictMaybe <$> optional (symbolic '=' *> expression)+ return (n :!: tp :!: df) puppetIfStyleCondition :: Parser (Pair Expression (V.Vector Statement)) puppetIfStyleCondition = (:!:) <$> expression <*> braces statementList@@ -631,6 +635,67 @@ <|> (pure . MainFunctionDeclaration <$> mainFuncDecl) <?> "Statement" +datatype :: Parser DataType+datatype = dtString+ <|> dtInteger+ <|> dtFloat+ <|> dtNumeric+ <|> (DTBoolean <$ reserved "Boolean")+ <|> (DTScalar <$ reserved "Scalar")+ <|> (DTData <$ reserved "Data")+ <|> (DTAny <$ reserved "Any")+ <|> (DTCollection <$ reserved "Collection")+ <|> dtArray+ <|> dtHash+ <|> (DTUndef <$ reserved "Undef")+ <|> (reserved "Optional" *> (DTOptional <$> brackets datatype))+ <|> (NotUndef <$ reserved "NotUndef")+ <|> (reserved "Variant" *> (DTVariant . NE.fromList <$> brackets (datatype `sepBy1` symbolic ',')))+ <|> (reserved "Pattern" *> (DTPattern . NE.fromList <$> brackets (termRegexp `sepBy1` symbolic ',')))+ <|> (reserved "Enum" *> (DTEnum . NE.fromList <$> brackets ((stringLiteral' <|> bareword) `sepBy1` symbolic ',')))+ <?> "DataType"+ where+ integer = integerOrDouble >>= either (return . fromIntegral) (const (fail "Integer value expected"))+ float = either fromIntegral id <$> integerOrDouble+ dtArgs str def parseArgs = do+ void $ reserved str+ fromMaybe def <$> optional (brackets parseArgs)+ dtbounded s constructor parser = dtArgs s (constructor Nothing Nothing) $ do+ lst <- parser `sepBy` symbolic ','+ case lst of+ [minlen] -> return $ constructor (Just minlen) Nothing+ [minlen,maxlen] -> return $ constructor (Just minlen) (Just maxlen)+ _ -> fail ("Too many arguments to datatype " ++ s)+ dtString = dtbounded "String" DTString integer+ dtInteger = dtbounded "Integer" DTInteger integer+ dtFloat = dtbounded "Float" DTFloat float+ dtNumeric = dtbounded "Numeric" (\ma mb -> DTVariant (DTFloat ma mb :| [DTInteger (truncate <$> ma) (truncate <$> mb)])) float+ dtArray = do+ reserved "Array"+ ml <- optional $ brackets $ do+ tp <- datatype+ rst <- optional (symbolic ',' *> integer `sepBy1` symbolic ',')+ return (tp, rst)+ case ml of+ Nothing -> return (DTArray DTData 0 Nothing)+ Just (t, Nothing) -> return (DTArray t 0 Nothing)+ Just (t, Just [mi]) -> return (DTArray t mi Nothing)+ Just (t, Just [mi, mx]) -> return (DTArray t mi (Just mx))+ Just (_, Just _) -> fail "Too many arguments to datatype Array"+ dtHash = do+ reserved "Hash"+ ml <- optional $ brackets $ do+ tk <- datatype+ symbolic ','+ tv <- datatype+ rst <- optional (symbolic ',' *> integer `sepBy1` symbolic ',')+ return (tk, tv, rst)+ case ml of+ Nothing -> return (DTHash DTScalar DTData 0 Nothing)+ Just (tk, tv, Nothing) -> return (DTHash tk tv 0 Nothing)+ Just (tk, tv, Just [mi]) -> return (DTHash tk tv mi Nothing)+ Just (tk, tv, Just [mi, mx]) -> return (DTHash tk tv mi (Just mx))+ Just (_, _, Just _) -> fail "Too many arguments to datatype Hash" statementList :: Parser (V.Vector Statement) statementList = (V.fromList . concat) <$> many statement@@ -640,17 +705,18 @@ let toStrict (Just x) = S.Just x toStrict Nothing = S.Nothing HOLambdaCall <$> lambFunc- <*> fmap (toStrict . join) (optional (parens (optional expression)))- <*> lambParams- <*> (symbolic '{' *> fmap (V.fromList . concat) (many (try statement)))- <*> fmap toStrict (optional expression) <* symbolic '}'+ <*> fmap (toStrict . join) (optional (parens (optional expression)))+ <*> lambParams+ <*> (symbolic '{' *> fmap (V.fromList . concat) (many (try statement)))+ <*> fmap toStrict (optional expression) <* symbolic '}' where lambFunc :: Parser LambdaFunc lambFunc = (reserved "each" *> pure LambEach)- <|> (reserved "map" *> pure LambMap )- <|> (reserved "reduce" *> pure LambReduce)- <|> (reserved "filter" *> pure LambFilter)- <|> (reserved "slice" *> pure LambSlice)+ <|> (reserved "map" *> pure LambMap )+ <|> (reserved "reduce" *> pure LambReduce)+ <|> (reserved "filter" *> pure LambFilter)+ <|> (reserved "slice" *> pure LambSlice)+ <|> (reserved "lookup" *> pure LambLookup) lambParams :: Parser LambdaParameters lambParams = between (symbolic '|') (symbolic '|') hp where
Puppet/Parser/PrettyPrinter.hs view
@@ -34,6 +34,32 @@ escapeChar x = T.singleton x {-# INLINE stringEscape #-} +instance Pretty DataType where+ pretty t = case t of+ DTType -> "Type"+ DTString ma mb -> bounded "String" ma mb+ DTInteger ma mb -> bounded "Integer" ma mb+ DTFloat ma mb -> bounded "Float" ma mb+ DTBoolean -> "Boolean"+ DTArray dt mi mmx -> "Array" <> list (pretty dt : pretty mi : maybe [] (pure . pretty) mmx)+ DTHash kt dt mi mmx -> "Hash" <> list (pretty kt : pretty dt : pretty mi : maybe [] (pure . pretty) mmx)+ DTUndef -> "Undef"+ DTScalar -> "Scalar"+ DTData -> "Data"+ DTOptional o -> "Optional" <> brackets (pretty o)+ NotUndef -> "NotUndef"+ DTVariant vs -> "Variant" <> list (foldMap (pure . pretty) vs)+ DTPattern vs -> "Pattern" <> list (foldMap (pure . pretty) vs)+ DTEnum tx -> "Enum" <> list (foldMap (pure . text . T.unpack) tx)+ DTAny -> "Any"+ DTCollection -> "Collection"+ where+ bounded :: (Pretty a, Pretty b) => Doc -> Maybe a -> Maybe b -> Doc+ bounded s ma mb = s <> case (ma, mb) of+ (Just a, Nothing) -> list [pretty a]+ (Just a, Just b) -> list [pretty a, pretty b]+ _ -> mempty+ instance Pretty Expression where pretty (Equal a b) = parens (pretty a <+> text "==" <+> pretty b) pretty (Different a b) = parens (pretty a <+> text "!=" <+> pretty b)@@ -66,6 +92,7 @@ pretty LambReduce = bold $ red $ text "reduce" pretty LambFilter = bold $ red $ text "filter" pretty LambSlice = bold $ red $ text "slice"+ pretty LambLookup = bold $ red $ text "lookup" instance Pretty LambdaParameters where pretty b = magenta (char '|') <+> vars <+> magenta (char '|')@@ -96,11 +123,14 @@ pretty (UResourceReference t n) = capitalize t <> brackets (pretty n) pretty (UArray v) = list (map pretty (V.toList v)) pretty (UHash g) = hashComma g- pretty (URegexp (CompRegex r _)) = char '/' <> text (T.unpack r) <> char '/'+ pretty (URegexp r) = pretty r pretty (UVariableReference v) = dullblue (char '$' <> text (T.unpack v)) pretty (UFunctionCall f args) = showFunc f args pretty (UHOLambdaCall c) = pretty c +instance Pretty CompRegex where+ pretty (CompRegex r _) = char '/' <> text (T.unpack r) <> char '/'+ instance Pretty HOLambdaCall where pretty (HOLambdaCall hf me bp stts mee) = pretty hf <> mme <+> pretty bp <+> nest 2 (char '{' <$> ppStatements stts <> mmee) <$> char '}' where@@ -112,6 +142,7 @@ S.Nothing -> mempty instance Pretty SelectorCase where pretty SelectorDefault = dullmagenta (text "default")+ pretty (SelectorType t) = pretty t pretty (SelectorValue v) = pretty v instance Pretty LinkType where@@ -138,15 +169,15 @@ maxlen = maximum (fmap (\(AttributeDecl k _ _) -> T.length k) vx) prettyDecl (AttributeDecl k op v) = dullblue (fill maxlen (ttext k)) <+> pretty op <+> pretty v -showArgs :: V.Vector (Pair T.Text (S.Maybe Expression)) -> Doc+showArgs :: V.Vector (Pair (Pair T.Text (S.Maybe DataType)) (S.Maybe Expression)) -> Doc showArgs vec = tupled (map ra lst) where lst = V.toList vec- maxlen = maximum (map (T.length . S.fst) lst)- ra (argname :!: rval) = dullblue (char '$' <> fill maxlen (text (T.unpack argname)))- <> case rval of- S.Nothing -> empty- S.Just v -> empty <+> char '=' <+> pretty v+ maxlen = maximum (map (T.length . S.fst . S.fst) lst)+ ra (argname :!: mtype :!: rval)+ = dullblue (char '$' <> foldMap (\t -> pretty t <+> empty) mtype+ <> fill maxlen (text (T.unpack argname)))+ <> foldMap (\v -> empty <+> char '=' <+> pretty v) rval showFunc :: T.Text -> V.Vector Expression -> Doc showFunc funcname args = bold (red (text (T.unpack funcname))) <> parensList args
Puppet/Parser/Types.hs view
@@ -30,6 +30,8 @@ Virtuality(..), NodeDesc(..), LinkType(..),+ -- ** Datatypes+ DataType(..), -- ** Search Expressions SearchExpression(..), -- ** Statements@@ -52,6 +54,7 @@ import Control.Lens import Data.Aeson+import Data.Aeson.TH (deriveToJSON) import Data.Char (toUpper) import Data.Hashable import qualified Data.Maybe.Strict as S@@ -61,6 +64,7 @@ import qualified Data.Text as T import Data.Tuple.Strict import qualified Data.Vector as V+import Data.List.NonEmpty (NonEmpty) import GHC.Exts import GHC.Generics@@ -110,6 +114,7 @@ | LambReduce | LambFilter | LambSlice+ | LambLookup deriving (Eq, Show) -- | Lambda block parameters:@@ -147,6 +152,10 @@ show (CompRegex t _) = show t instance Eq CompRegex where (CompRegex a _) == (CompRegex b _) = a == b+instance FromJSON CompRegex where+ parseJSON = fail "Can't deserialize a regular expression"+instance ToJSON CompRegex where+ toJSON (CompRegex t _) = toJSON t -- | An unresolved value, typically the parser's output. data UnresolvedValue@@ -176,6 +185,7 @@ data SelectorCase = SelectorValue !UnresolvedValue+ | SelectorType !DataType | SelectorDefault deriving (Eq, Show) @@ -207,6 +217,29 @@ | Terminal !UnresolvedValue -- ^ Terminal object contains no expression deriving (Eq, Show) +data DataType+ = DTType+ | DTString (Maybe Int) (Maybe Int)+ | DTInteger (Maybe Int) (Maybe Int)+ | DTFloat (Maybe Double) (Maybe Double)+ | DTBoolean+ | DTArray DataType Int (Maybe Int)+ | DTHash DataType DataType Int (Maybe Int)+ | DTUndef+ | DTScalar+ | DTData+ | DTOptional DataType+ | NotUndef+ | DTVariant (NonEmpty DataType)+ | DTPattern (NonEmpty CompRegex)+ | DTEnum (NonEmpty Text)+ | DTAny+ | DTCollection+ -- | Tuple (NonEmpty DataType) Integer Integer+ -- | DTDefault+ -- | Struct TODO+ deriving (Eq, Show)+ instance IsList Expression where type Item Expression = Expression fromList = Terminal . fromList@@ -299,8 +332,8 @@ -- (interpreted as "if first cond is true, choose first statements, else take the next pair, check the condition ...") data ConditionalDecl = ConditionalDecl !(V.Vector (Pair Expression (V.Vector Statement))) !PPosition deriving (Eq, Show) -data ClassDecl = ClassDecl !Text !(V.Vector (Pair Text (S.Maybe Expression))) !(S.Maybe Text) !(V.Vector Statement) !PPosition deriving (Eq, Show)-data DefineDecl = DefineDecl !Text !(V.Vector (Pair Text (S.Maybe Expression))) !(V.Vector Statement) !PPosition deriving (Eq, Show)+data ClassDecl = ClassDecl !Text !(V.Vector (Pair (Pair Text (S.Maybe DataType)) (S.Maybe Expression))) !(S.Maybe Text) !(V.Vector Statement) !PPosition deriving (Eq, Show)+data DefineDecl = DefineDecl !Text !(V.Vector (Pair (Pair Text (S.Maybe DataType)) (S.Maybe Expression))) !(V.Vector Statement) !PPosition deriving (Eq, Show) -- | A node is a collection of statements + maybe an inherit node data NodeDecl = NodeDecl !NodeDesc !(V.Vector Statement) !(S.Maybe NodeDesc) !PPosition deriving (Eq, Show)@@ -338,3 +371,5 @@ deriving (Eq, Show) makeClassy ''HOLambdaCall+$(deriveToJSON defaultOptions ''DataType)+
Puppet/Stdlib.hs view
@@ -23,7 +23,6 @@ import Puppet.Interpreter.Resolve import Puppet.Interpreter.Types import Puppet.Interpreter.Utils-import Puppet.Lens import Puppet.PP -- | Contains the implementation of the StdLib functions.
PuppetDB/TestDB.hs view
@@ -28,7 +28,6 @@ import Text.Megaparsec.Pos import Puppet.Interpreter.Types-import Puppet.Lens import Puppet.Parser.Types import Puppet.PP
README.adoc view
@@ -17,11 +17,10 @@ git clone https://github.com/bartavelle/language-puppet.git cd language-puppet # Add ~/.local/bin to $PATH+ln -s stack-8.0.yaml stack.yaml stack install ``` -https://hub.docker.com/r/pierrer/language-puppet/[A docker image] is available.- == Puppetresources The `puppetresources` command is a command line utility that let you interactively compute catalogs on your local computer.@@ -173,8 +172,12 @@ == Unsupported Puppet idioms or features +OS::+ * `OS X` is currently not supported (https://github.com/bartavelle/language-puppet/issues/197[issue #197])+ puppet functions:: * the `require` function is not supported (see https://github.com/bartavelle/language-puppet/issues/17[issue #17])- * the deprecated `import` function is not supported (see https://github.com/bartavelle/language-puppet/issues/82[issue #82])+ * the deprecated `import` function is not supported+ * the deprecated node inheritance feature is not supported custom ruby functions::
language-puppet.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet-version: 1.3.7+version: 1.3.8 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, simulationg of complex interactions between nodes, Puppet master replacement, and more ! homepage: http://lpuppet.banquise.net/@@ -15,7 +15,7 @@ build-type: Simple cabal-version: >=1.8 -Tested-With: GHC == 7.10.3, GHC == 8.0.1+Tested-With: GHC == 7.10.3, GHC == 8.0.2 extra-source-files: CHANGELOG.markdown@@ -175,7 +175,7 @@ type: exitcode-stdio-1.0 ghc-options: -Wall -rtsopts -threaded extensions: OverloadedStrings- build-depends: language-puppet,base,strict-base-types,lens,text,hspec,unordered-containers,megaparsec,vector,scientific,mtl+ build-depends: language-puppet,base,strict-base-types,lens,text,hspec,unordered-containers,megaparsec,vector,scientific,mtl,hspec-megaparsec other-modules: Function.ShellquoteSpec Function.SprintfSpec Function.SizeSpec@@ -187,6 +187,7 @@ InterpreterSpec Interpreter.CollectorSpec Interpreter.IfSpec+ DT.Parser Helpers main-is: Spec.hs
progs/PuppetResources.hs view
@@ -371,7 +371,7 @@ -- | Parse mode run Options {_optParse = Just fp, ..} = parseFile fp >>= \case- Left rr -> error ("parse error:" ++ show rr)+ Left rr -> error (P.parseErrorPretty rr) Right s -> if _optLoglevel == LOG.DEBUG then mapM_ print s else putDoc $ ppStatements s
+ tests/DT/Parser.hs view
@@ -0,0 +1,19 @@+module DT.Parser (spec) where++import qualified Data.Text as T+import Puppet.Parser+import Puppet.Parser.Types+import Test.Hspec+import Test.Hspec.Megaparsec+import Text.Megaparsec (parse)++spec :: Spec+spec = do+ let prs s r = it s $ parse datatype "?" (T.pack s) `shouldParse` r+ fl s = it s $ shouldFailOn (parse datatype "?") (T.pack s)+ describe "String" $ do+ "String" `prs` DTString Nothing Nothing+ fl "String[]"+ fl "String[4,5,6]"+ "String[5]" `prs` DTString (Just 5) Nothing+ "String[5,8]" `prs` DTString (Just 5) (Just 8)
tests/Spec.hs view
@@ -11,12 +11,15 @@ import qualified Function.DeleteAtSpec import qualified Interpreter.IfSpec import qualified Function.SprintfSpec+import qualified DT.Parser main :: IO () main = hspec spec spec :: Spec spec = do+ describe "Data types" $ do+ describe "Parser" DT.Parser.spec describe "Interpreter" $ do describe "Collector" InterpreterSpec.collectorSpec describe "Class include" InterpreterSpec.classIncludeSpec
tests/evals.hs view
@@ -21,6 +21,8 @@ , "[1,2,3] << 10 == [1,2,3,10]" , "[1,2,3] << [4,5] == [1,2,3,[4,5]]" , "4 / 2.0 == 2"+ , "$architecture == 'amd64'"+ , "$facts['architecture'] == 'amd64'" , "$settings::confdir == '/etc/puppet'" , "regsubst('127', '([0-9]+)', '<\\1>', 'G') == '<127>'" , "regsubst(['1','2','3'], '([0-9]+)', '<\\1>', 'G') == ['<1>','<2>','<3>']"
tests/expr.hs view
@@ -23,9 +23,12 @@ (V.fromList [SelectorValue UUndef :!: Terminal (UString "undef") ,SelectorDefault :!: Terminal (UString "default")])) , ("$x", Terminal (UVariableReference "x"))+ , ("x($y)", Terminal (UFunctionCall "x" (V.singleton (Terminal (UVariableReference "y"))))) , ("\"${x}\"", Terminal (UInterpolable (V.fromList [Terminal (UVariableReference "x")]))) , ("\"${x[3]}\"", Terminal (UInterpolable (V.fromList [Lookup (Terminal (UVariableReference "x")) 3]))) , ("\"${x[$y]}\"", Terminal (UInterpolable (V.fromList [Lookup (Terminal (UVariableReference "x")) (Terminal (UVariableReference "y")) ])))+ , ("\"${x($y)}\"", Terminal (UInterpolable (V.fromList [ Terminal (UFunctionCall "x" (V.singleton (Terminal (UVariableReference "y")))) ])))+ , ("\"${x($y)}$'\"", Terminal (UInterpolable (V.fromList [ Terminal (UFunctionCall "x" (V.singleton (Terminal (UVariableReference "y")))),Terminal (UString "$"),Terminal (UString "'")]))) ] main :: IO ()