language-puppet 0.12.3 → 0.13.0
raw patch · 39 files changed
+723/−450 lines, 39 filesdep ~basedep ~case-insensitivedep ~hspec
Dependency ranges changed: base, case-insensitive, hspec, http-conduit, lens, optparse-applicative, parsers, text, yaml
Files
- Erb/Compute.hs +24/−17
- Erb/Evaluate.hs +7/−6
- Erb/Parser.hs +5/−4
- Facter.hs +2/−2
- Hiera/Server.hs +1/−1
- Puppet/Daemon.hs +6/−6
- Puppet/Interpreter.hs +12/−15
- Puppet/Interpreter/IO.hs +8/−8
- Puppet/Interpreter/PrettyPrinter.hs +3/−2
- Puppet/Interpreter/Pure.hs +144/−0
- Puppet/Interpreter/Resolve.hs +59/−48
- Puppet/Interpreter/Types.hs +56/−52
- Puppet/Lens.hs +36/−59
- Puppet/Manifests.hs +6/−6
- Puppet/NativeTypes.hs +2/−2
- Puppet/NativeTypes/Cron.hs +10/−10
- Puppet/NativeTypes/File.hs +12/−12
- Puppet/NativeTypes/Helpers.hs +33/−30
- Puppet/NativeTypes/Host.hs +8/−8
- Puppet/NativeTypes/Package.hs +9/−9
- Puppet/NativeTypes/ZoneRecord.hs +2/−2
- Puppet/Parser.hs +33/−30
- Puppet/Parser/PrettyPrinter.hs +2/−1
- Puppet/Parser/Types.hs +26/−1
- Puppet/Plugins.hs +3/−1
- Puppet/Stdlib.hs +23/−0
- Puppet/Testing.hs +54/−21
- Puppet/Utils.hs +11/−8
- PuppetDB/Common.hs +1/−2
- PuppetDB/Remote.hs +8/−6
- PuppetDB/TestDB.hs +14/−20
- language-puppet.cabal +15/−7
- progs/PuppetResources.hs +15/−16
- progs/pdbQuery.hs +11/−9
- ruby/hrubyerb.rb +4/−0
- tests/evals.hs +34/−0
- tests/expr.hs +5/−7
- tests/hiera.hs +17/−20
- tests/lexer.hs +2/−2
Erb/Compute.hs view
@@ -51,19 +51,21 @@ type RubyInterpreter = () #endif -instance Error ParseError where- noMsg = newErrorUnknown (initialPos "dummy")- strMsg s = newErrorMessage (Message s) (initialPos "dummy")+newtype TemplateParseError = TemplateParseError { tgetError :: ParseError } +instance Error TemplateParseError where+ noMsg = TemplateParseError $ newErrorUnknown (initialPos "dummy")+ strMsg s = TemplateParseError $ newErrorMessage (Message s) (initialPos "dummy")+ type TemplateQuery = (Chan TemplateAnswer, Either T.Text T.Text, T.Text, Container ScopeInformation)-type TemplateAnswer = S.Either Doc T.Text+type TemplateAnswer = S.Either PrettyError T.Text #ifdef HRUBY-showRubyError :: RubyError -> Doc-showRubyError (Stack msg stk) = dullred (string msg) </> dullyellow (string stk)-showRubyError (WithOutput str _) = dullred (string str)+showRubyError :: RubyError -> PrettyError+showRubyError (Stack msg stk) = PrettyError $ dullred (string msg) </> dullyellow (string stk)+showRubyError (WithOutput str _) = PrettyError $ dullred (string str) -initTemplateDaemon :: RubyInterpreter -> (Preferences IO) -> MStats -> IO (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text))+initTemplateDaemon :: RubyInterpreter -> (Preferences IO) -> MStats -> IO (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either PrettyError T.Text)) initTemplateDaemon intr (Preferences _ modpath templatepath _ _ _ _) mvstats = do controlchan <- newChan templatecache <- newFileCache@@ -76,7 +78,7 @@ return (templateQuery controlchan) Left rs -> returnError rs #else-initTemplateDaemon :: Preferences -> MStats -> IO (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text))+initTemplateDaemon :: Preferences -> MStats -> IO (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either PrettyError T.Text)) initTemplateDaemon (Preferences _ modpath templatepath _ _ _ _ _ _) mvstats = do controlchan <- newChan templatecache <- newFileCache@@ -84,13 +86,13 @@ return (templateQuery controlchan) #endif -templateQuery :: Chan TemplateQuery -> Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text)+templateQuery :: Chan TemplateQuery -> Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either PrettyError T.Text) templateQuery qchan filename scope variables = do rchan <- newChan writeChan qchan (rchan, filename, scope, variables) readChan rchan -templateDaemon :: RubyInterpreter -> T.Text -> T.Text -> Chan TemplateQuery -> MStats -> FileCacheR ParseError [RubyStatement] -> IO ()+templateDaemon :: RubyInterpreter -> T.Text -> T.Text -> Chan TemplateQuery -> MStats -> FileCacheR TemplateParseError [RubyStatement] -> IO () templateDaemon intr modpath templatepath qchan mvstats filecache = do nameThread "RubyTemplateDaemon" (respchan, fileinfo, scope, variables) <- readChan qchan@@ -101,12 +103,12 @@ | otherwise = [templatepath <> "/" <> filename] acceptablefiles <- filterM (fileExist . T.unpack) searchpathes if null acceptablefiles- then writeChan respchan (S.Left $ "Can't find template file for" <+> ttext filename <+> ", looked in" <+> list (map ttext searchpathes))+ then writeChan respchan (S.Left $ PrettyError $ "Can't find template file for" <+> ttext filename <+> ", looked in" <+> list (map ttext searchpathes)) else measure mvstats filename (computeTemplate intr (Right (head acceptablefiles)) scope variables mvstats filecache) >>= writeChan respchan Left _ -> measure mvstats "inline" (computeTemplate intr fileinfo scope variables mvstats filecache) >>= writeChan respchan templateDaemon intr modpath templatepath qchan mvstats filecache -computeTemplate :: RubyInterpreter -> Either T.Text T.Text -> T.Text -> Container ScopeInformation -> MStats -> FileCacheR ParseError [RubyStatement] -> IO TemplateAnswer+computeTemplate :: RubyInterpreter -> Either T.Text T.Text -> T.Text -> Container ScopeInformation -> MStats -> FileCacheR TemplateParseError [RubyStatement] -> IO TemplateAnswer computeTemplate intr fileinfo curcontext variables mstats filecache = do let (filename, ufilename) = case fileinfo of Left _ -> ("inline", "inline")@@ -114,13 +116,14 @@ mkSafe a = makeSafe intr a >>= \case Left rr -> return (S.Left (showRubyError rr)) Right x -> return x+ encapsulateError = _Left %~ TemplateParseError traceEventIO ("START template " ++ T.unpack filename) parsed <- case fileinfo of- Right _ -> measure mstats ("parsing - " <> filename) $ lazyQuery filecache ufilename $ parseErbFile ufilename- Left content -> measure mstats ("parsing - " <> filename) $ return (runParser erbparser () "inline" (T.unpack content))+ Right _ -> measure mstats ("parsing - " <> filename) $ lazyQuery filecache ufilename $ fmap encapsulateError (parseErbFile ufilename)+ Left content -> measure mstats ("parsing - " <> filename) $ return $ encapsulateError (runParser erbparser () "inline" (T.unpack content)) o <- case parsed of Left err -> do- let !msg = "template " ++ ufilename ++ " could not be parsed " ++ show err+ let !msg = "template " ++ ufilename ++ " could not be parsed " ++ show (tgetError err) traceEventIO msg LOG.debugM "Erb.Compute" msg measure mstats ("ruby - " <> filename) $ mkSafe $ computeTemplateWRuby fileinfo curcontext variables@@ -159,6 +162,10 @@ variables <- FR.extractHaskellValue rvariables toresolve <- FR.fromRuby rtoresolve let answer = case toresolve of+ Just "~g~e~t_h~a~s~h~" ->+ let getvars ctx = (variables ^. ix ctx . scopeVariables) & traverse %~ view (_1 . _1)+ vars = getvars "::" <> getvars scope+ in Right (PHash vars) Just t -> getVariable variables scope t _ -> Left "The variable name is not a string" case answer of@@ -190,7 +197,7 @@ let fname = case fileinfo of Right f -> T.unpack f Left _ -> "inline_template"- in return (S.Left (dullred (text rr) <+> "in" <+> dullgreen (text fname)))+ in return (S.Left $ PrettyError (dullred (text rr) <+> "in" <+> dullgreen (text fname))) Right r -> FR.fromRuby r >>= \case Just result -> return (S.Right result) Nothing -> return (S.Left "Could not deserialiaze ruby output")
Erb/Evaluate.hs view
@@ -13,7 +13,7 @@ import Control.Lens import qualified Data.Vector as V import Data.Char (isSpace)-import Data.Attoparsec.Number+import Data.Aeson.Lens rubyEvaluate :: Container ScopeInformation -> T.Text -> [RubyStatement] -> Either Doc T.Text rubyEvaluate vars ctx = foldl (evalruby vars ctx) (Right "") . optimize@@ -46,9 +46,9 @@ PArray arr -> case a2i rvindx of Nothing -> Left $ "Can't convert index to integer when resolving" <+> ttext rvname P.<> brackets (ttext rvindx)- Just i -> if V.length arr <= i+ Just i -> if fromIntegral (V.length arr) <= i then Left $ "Array out of bound" <+> ttext rvname P.<> brackets (ttext rvindx)- else evalValue (arr V.! i)+ else evalValue (arr V.! fromIntegral i) PHash hs -> case hs ^. at rvindx of Just x -> evalValue x _ -> Left $ "Can't index variable" <+> ttext rvname <+> ", it is " <+> pretty (PHash hs)@@ -59,9 +59,10 @@ evalValue :: PValue -> Either Doc T.Text evalValue (PString x) = Right x+evalValue (PNumber x) = Right (scientific2text x) evalValue x = Right $ tshow x -a2i :: T.Text -> Maybe Int-a2i x = case text2Number x of- Just (I y) -> Just (fromIntegral y)+a2i :: T.Text -> Maybe Integer+a2i x = case text2Scientific x of+ Just y -> y ^? _Integer _ -> Nothing
Erb/Parser.hs view
@@ -95,14 +95,14 @@ void $ try $ string "scope" end <- (string ".lookupvar(" >> return (char ')')) <|> (char '[' >> return (char ']')) expr <- rubyexpression- void $ end+ void end return $ Object expr stringLiteral :: Parser Expression stringLiteral = Value `fmap` (doubleQuoted <|> singleQuoted) doubleQuoted :: Parser Value-doubleQuoted = fmap Interpolable $ between (char '"') (char '"') quoteInternal+doubleQuoted = Interpolable <$> between (char '"') (char '"') quoteInternal where quoteInternal = many (basicContent <|> interpvar <|> escaped) escaped = char '\\' >> (Value . Literal . T.singleton) `fmap` anyChar@@ -114,7 +114,7 @@ return (Object (Value (Literal (T.pack o)))) singleQuoted :: Parser Value-singleQuoted = fmap (Literal . T.pack) $ between (char '\'') (char '\'') (many $ noneOf "'")+singleQuoted = Literal . T.pack <$> between (char '\'') (char '\'') (many $ noneOf "'") objectterm :: Parser Expression objectterm = do@@ -178,4 +178,5 @@ handler e = let msg = show (e :: SomeException) in return $ Left $ newErrorMessage (Message msg) (initialPos fname) -+parseErbString :: String -> Either ParseError [RubyStatement]+parseErbString = runParser erbparser () "dummy"
Facter.hs view
@@ -132,7 +132,7 @@ modelnames = mapMaybe (fmap (dropWhile (`elem` "\t :")) . stripPrefix "model name") (lines cpuinfo) return $ ("processorcount", show (length cpuinfos)) : cpuinfos -puppetDBFacts :: T.Text -> PuppetDBAPI IO -> IO (Container T.Text)+puppetDBFacts :: T.Text -> PuppetDBAPI IO -> IO (Container PValue) puppetDBFacts ndename pdbapi = getFacts pdbapi (QEqual FCertname ndename) >>= \case S.Right facts@(_:_) -> return (HM.fromList (map (\f -> (f ^. factname, f ^. factval)) facts))@@ -156,5 +156,5 @@ ] allfacts = nfacts `HM.union` ofacts genFacts = HM.fromList- return allfacts+ return (allfacts & traverse %~ PString)
Hiera/Server.hs view
@@ -153,7 +153,7 @@ query :: HieraConfig -> HieraCache -> HieraQueryFunc IO query (HieraConfig b h bd) cache vars hquery qtype = do- fmap (S.Right . prepout) (runWriterT (sequencerFunction (map query' h))) `catch` (\e -> return . S.Left . string . show $ (e :: SomeException))+ fmap (S.Right . prepout) (runWriterT (sequencerFunction (map query' h))) `catch` (\e -> return . S.Left . PrettyError . string . show $ (e :: SomeException)) where prepout (a,s) = s :!: a varlist = hcat (L.intersperse comma (map (dullblue . ttext) (L.sort (HM.keys vars))))
Puppet/Daemon.hs view
@@ -102,13 +102,13 @@ return (DaemonMethods (gCatalog myprefs getStatements getTemplate catalogStats hquery) parserStats catalogStats templateStats) gCatalog :: Preferences IO- -> ( TopLevelType -> T.Text -> IO (S.Either Doc Statement) )- -> (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text))+ -> ( TopLevelType -> T.Text -> IO (S.Either PrettyError Statement) )+ -> (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either PrettyError T.Text)) -> MStats -> HieraQueryFunc IO -> T.Text -> Facts- -> IO (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))+ -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) gCatalog prefs getStatements getTemplate stats hquery ndename facts = do logDebug ("Received query for node " <> ndename) traceEventIO ("START gCatalog " <> T.unpack ndename)@@ -117,7 +117,7 @@ traceEventIO ("STOP gCatalog " <> T.unpack ndename) return stmts -parseFunction :: Preferences IO -> FileCache (V.Vector Statement) -> MStats -> TopLevelType -> T.Text -> IO (S.Either Doc Statement)+parseFunction :: Preferences IO -> FileCache (V.Vector Statement) -> MStats -> TopLevelType -> T.Text -> IO (S.Either PrettyError Statement) parseFunction prefs filecache stats topleveltype toplevelname = case compileFileList prefs topleveltype toplevelname of S.Left rr -> return (S.Left rr)@@ -128,11 +128,11 @@ x <- measure stats fname (query filecache sfname (parseFile sfname `catch` handleFailure)) case x of S.Right stmts -> filterStatements topleveltype toplevelname stmts- S.Left rr -> return (S.Left (red (text rr)))+ S.Left rr -> return (S.Left (PrettyError (red (text rr)))) -- TODO this is wrong, see -- http://docs.puppetlabs.com/puppet/3/reference/lang_namespaces.html#behavior-compileFileList :: Preferences IO -> TopLevelType -> T.Text -> S.Either Doc T.Text+compileFileList :: Preferences IO -> TopLevelType -> T.Text -> S.Either PrettyError T.Text compileFileList prefs TopNode _ = S.Right (T.pack (prefs ^. manifestPath) <> "/site.pp") compileFileList prefs _ name = moduleInfo where
Puppet/Interpreter.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LambdaCase, RankNTypes #-} module Puppet.Interpreter where import Puppet.Interpreter.Types@@ -40,9 +40,9 @@ -- coverage tests)) along with all messages that have been generated by the -- compilation process. getCatalog :: Monad m- => (InterpreterReader m -> InterpreterState -> InterpreterMonad (FinalCatalog, EdgeMap, FinalCatalog, [Resource]) -> m (Either Doc (FinalCatalog, EdgeMap, FinalCatalog, [Resource]), InterpreterState, InterpreterWriter)) -- ^ A function that will interpret the InterpreterMonad and will convert it to something else (for example, 'interpretIO')- -> ( TopLevelType -> T.Text -> m (S.Either Doc Statement) ) -- ^ get statements function- -> (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> m (S.Either Doc T.Text)) -- ^ compute template function+ => (forall a. InterpreterReader m -> InterpreterState -> InterpreterMonad a -> m (Either PrettyError a, InterpreterState, InterpreterWriter)) -- ^ A function that will interpret the InterpreterMonad and will convert it to something else (for example, 'interpretIO')+ -> ( TopLevelType -> T.Text -> m (S.Either PrettyError Statement) ) -- ^ get statements function+ -> (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> m (S.Either PrettyError T.Text)) -- ^ compute template function -> PuppetDBAPI m -> T.Text -- ^ Node name -> Facts -- ^ Facts ...@@ -50,16 +50,11 @@ -> Container ( [PValue] -> InterpreterMonad PValue ) -> HieraQueryFunc m -- ^ Hiera query function -> ImpureMethods m- -> m (Pair (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) [Pair Priority Doc])+ -> m (Pair (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) [Pair Priority Doc]) getCatalog convertMonad gtStatement gtTemplate pdbQuery ndename facts nTypes extfuncs hquery im = do -- nameThread ("Catalog " <> T.unpack ndename) let rdr = InterpreterReader nTypes gtStatement gtTemplate pdbQuery extfuncs ndename hquery im- dummypos = initialPPos "dummy"- initialclass = mempty & at "::" ?~ (IncludeStandard :!: dummypos)- stt = InterpreterState baseVars initialclass mempty [ContRoot] dummypos mempty [] []- factvars = facts & each %~ (\x -> PString x :!: initialPPos "facts" :!: ContRoot)- callervars = ifromList [("caller_module_name", PString "::" :!: dummypos :!: ContRoot), ("module_name", PString "::" :!: dummypos :!: ContRoot)]- baseVars = isingleton "::" (ScopeInformation (factvars <> callervars) mempty mempty (CurContainer ContRoot mempty) mempty S.Nothing)+ stt = initialState facts (output, _, warnings) <- convertMonad rdr stt (computeCatalog ndename) return (strictifyEither output :!: warnings) @@ -163,7 +158,7 @@ -- replace the modified stuff let res = foldl' (\curm e -> curm & at (e ^. rid) ?~ e) realized refinalized return (toList res)- mainstage = Resource (RIdentifier "stage" "main") mempty mempty mempty [ContRoot] Normal mempty (initialPPos "dummy") ndename+ mainstage = Resource (RIdentifier "stage" "main") mempty mempty mempty [ContRoot] Normal mempty dummypos ndename resnode <- evaluateNode node >>= finalStep . (++ (mainstage : restop)) let (real :!: exported) = foldl' classify (mempty :!: mempty) resnode classify :: Pair (HM.HashMap RIdentifier Resource) (HM.HashMap RIdentifier Resource)@@ -282,7 +277,7 @@ then i cma :!: i cmo :!: True else cma :!: cmo :!: matched (result :!: mtch) <- foldM applyModification (curmap :!: modified :!: False) filtrd- when (rmod ^. rmModifierType == ModifierMustMatch && not mtch) (throwError ("Could not apply this resource override :" <+> pretty rmod))+ when (rmod ^. rmModifierType == ModifierMustMatch && not mtch) (throwError (PrettyError ("Could not apply this resource override :" <+> pretty rmod))) return result equalModifier (ResourceModifier a1 b1 c1 d1 _ e1) (ResourceModifier a2 b2 c2 d2 _ e2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 result <- use resMod >>= foldM mutate (rma :!: mempty) . nubBy equalModifier@@ -416,7 +411,7 @@ scopes . ix scp . scopeOverrides . at rident ?= ResRefOverride rident withAssignements p return [] evaluateStatement (SHFunctionCall c p) = curPos .= p >> evaluateHFC c-evaluateStatement r = throwError ("Do not know how to evaluate this statement:" <$> pretty r)+evaluateStatement r = throwError (PrettyError ("Do not know how to evaluate this statement:" <$> pretty r)) ----------------------------------------------------------- -- Class evaluation@@ -476,7 +471,7 @@ !unsetParams = mandatoryParamSet `HS.difference` definedParamSet !spuriousParams = definedParamSet `HS.difference` classParamSet mclassdesc = S.maybe mempty ((\x -> mempty <+> "when including class" <+> x) . ttext) wHiera- unless (fnull unsetParams) $ throwPosError ("The following mandatory parameters where not set:" <+> tupled (map ttext $ toList unsetParams) <> mclassdesc)+ unless (fnull unsetParams) $ throwPosError ("The following mandatory parameters were not set:" <+> tupled (map ttext $ toList unsetParams) <> mclassdesc) unless (fnull spuriousParams) $ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ttext) $ toList spuriousParams) <> mclassdesc) let isDefault = not . flip HS.member definedParamSet . S.fst mapM_ (uncurry loadVariable) (itoList params')@@ -621,6 +616,8 @@ pushScope scopedesc -- not done through loadvariable because of override -- errors+ loadVariable "title" (PString classname)+ loadVariable "name" (PString classname) loadParameters params classParams cp (S.Just classname) curPos .= cp res <- evaluateStatementsVector stmts
Puppet/Interpreter/IO.hs view
@@ -28,8 +28,8 @@ import Data.Tuple.Strict (Pair(..)) import System.Log.Logger (Priority(..)) -bs :: BS.ByteString -> Doc-bs = string . show+bs :: BS.ByteString -> PrettyError+bs = PrettyError . string . show defaultImpureMethods :: (Functor m, MonadIO m) => ImpureMethods m defaultImpureMethods = ImpureMethods (liftIO currentCallStack)@@ -42,11 +42,11 @@ runlua c fname args = liftIO $ withMVar c $ \lstt -> catch (fmap Right (Lua.callfunc lstt (T.unpack fname) args)) (\e -> return $ Left $ show (e :: SomeException)) -evalInstrGen :: (Functor m, Monad m) => InterpreterReader m -> InterpreterState -> ProgramViewT InterpreterInstr (State InterpreterState) a -> m (Either Doc a, InterpreterState, InterpreterWriter)+evalInstrGen :: (Functor m, Monad m) => InterpreterReader m -> InterpreterState -> ProgramViewT InterpreterInstr (State InterpreterState) a -> m (Either PrettyError a, InterpreterState, InterpreterWriter) evalInstrGen _ stt (Return x) = return (Right x, stt, mempty) evalInstrGen rdr stt (a :>>= f) = let runC a' = interpretMonad rdr stt (f a')- thpe = interpretMonad rdr stt . throwPosError+ thpe = interpretMonad rdr stt . throwPosError . getError pdb = _pdbAPI rdr strFail iof errf = iof >>= \case Left rr -> thpe (errf (string rr))@@ -58,7 +58,7 @@ in case a of ExternalFunction fname args -> case rdr ^. externalFunctions . at fname of Just fn -> interpretMonad rdr stt ( fn args >>= f)- Nothing -> thpe ("Unknown function: " <> ttext fname)+ Nothing -> thpe (PrettyError ("Unknown function: " <> ttext fname)) GetStatement topleveltype toplevelname -> canFail ((rdr ^. getStatement) topleveltype toplevelname) ComputeTemplate fn scp cscps -> canFail ((rdr ^. computeTemplateFunction) fn scp cscps)@@ -80,17 +80,17 @@ PDBCommitDB -> canFail (commitDB pdb) PDBGetResourcesOfNode nn q -> canFail (getResourcesOfNode pdb nn q) GetCurrentCallStack -> (rdr ^. ioMethods . imGetCurrentCallStack) >>= runC- ReadFile fls -> strFail ((rdr ^. ioMethods . imReadFile) fls) (const $ "No file found in " <> list (map ttext fls))+ ReadFile fls -> strFail ((rdr ^. ioMethods . imReadFile) fls) (const $ PrettyError ("No file found in " <> list (map ttext fls))) TraceEvent e -> (rdr ^. ioMethods . imTraceEvent) e >>= runC CallLua c fname args -> (rdr ^. ioMethods . imCallLua) c fname args >>= \case Right x -> runC x- Left rr -> thpe (string rr)+ Left rr -> thpe (PrettyError (string rr)) interpretMonad :: (Functor m, Monad m) => InterpreterReader m -> InterpreterState -> InterpreterMonad a- -> m (Either Doc a, InterpreterState, InterpreterWriter)+ -> m (Either PrettyError a, InterpreterState, InterpreterWriter) interpretMonad rd_ prmstate instr = case runState (viewT instr) prmstate of (!a,!nextstate) -> evalInstrGen rd_ nextstate a
Puppet/Interpreter/PrettyPrinter.hs view
@@ -6,8 +6,8 @@ import Puppet.Parser.Types import Puppet.Interpreter.Types import Puppet.Parser.PrettyPrinter+import Puppet.Utils -import Data.Monoid import qualified Data.Vector as V import qualified Data.Text as T import qualified Data.HashMap.Strict as HM@@ -39,6 +39,7 @@ pretty (PBoolean True) = dullmagenta $ text "true" pretty (PBoolean False) = dullmagenta $ text "false" pretty (PString s) = dullcyan (ttext (stringEscape s))+ pretty (PNumber n) = cyan (ttext (scientific2text n)) pretty PUndef = dullmagenta (text "undef") pretty (PResourceReference t n) = capitalize t <> brackets (text (T.unpack n)) pretty (PArray v) = list (map pretty (V.toList v))@@ -129,7 +130,7 @@ pretty GetNodeName = pf "GetNodeName" [] pretty (HieraQuery _ q _) = pf "HieraQuery" [ttext q] pretty GetCurrentCallStack = pf "GetCurrentCallStack" []- pretty (ErrorThrow rr) = pf "ErrorThrow" [rr]+ pretty (ErrorThrow rr) = pf "ErrorThrow" [getError rr] pretty (ErrorCatch _ _) = pf "ErrorCatch" [] pretty (WriterTell t) = pf "WriterTell" (map (pretty . view _2) t) pretty (WriterPass _) = pf "WriterPass" []
+ Puppet/Interpreter/Pure.hs view
@@ -0,0 +1,144 @@+-- | This is a set of pure helpers for evaluation the 'InterpreterMonad'+-- function that can be found in "Puppet.Interpreter" and+-- "Puppet.Interpreter.Resolve". They are used to power some prisms from+-- "Puppet.Lens".+--+-- > > dummyEval (resolveExpression (Addition "1" "2"))+-- > Right (PString "3")+module Puppet.Interpreter.Pure where++import Puppet.PP+import Puppet.Parser.Types+import Puppet.Interpreter.Types+import Puppet.Interpreter.IO+import Puppet.NativeTypes+import Erb.Parser+import Erb.Evaluate+import PuppetDB.Dummy++import qualified Data.HashMap.Strict as HM+import Control.Monad.Identity+import qualified Data.Either.Strict as S+import qualified Data.Maybe.Strict as S+import Data.Tuple.Strict+import Data.Monoid+import qualified Data.Text as T+import Control.Lens++-- | Worst name ever, this is a set of pure stub for the 'ImpureMethods'+-- type.+impurePure :: ImpureMethods Identity+impurePure = ImpureMethods (return []) (const (return (Left "Can't read file"))) (\_ -> return ()) (\_ _ _ -> return (Left "Can't call lua"))++-- | A pure 'InterpreterReader', that can only evaluate a subset of the+-- templates, and that can include only the supplied top level statements.+pureReader :: HM.HashMap (TopLevelType, T.Text) Statement -- ^ A top-level statement map+ -> InterpreterReader Identity+pureReader sttmap = InterpreterReader baseNativeTypes getstatementdummy templatedummy dummyPuppetDB mempty "dummy" hieradummy impurePure+ where+ templatedummy (Right _) _ _ = return (S.Left "Can't interpret files")+ templatedummy (Left cnt) ctx scope =+ return $ case parseErbString (T.unpack cnt) of+ Left rr -> S.Left (PrettyError (text (show rr)))+ Right stmts -> case rubyEvaluate scope ctx stmts of+ Right x -> S.Right x+ Left rr -> S.Left (PrettyError rr)+ hieradummy _ _ _ = return (S.Right (mempty :!: S.Nothing))+ getstatementdummy tlt n = return $ case HM.lookup (tlt,n) sttmap of+ Just x -> S.Right x+ Nothing -> S.Left "Can't get statement"++-- | Evaluates an interpreter expression in a pure context.+pureEval :: Facts -- ^ A list of facts that will be used during evaluation+ -> HM.HashMap (TopLevelType, T.Text) Statement -- ^ A top-level map+ -> InterpreterMonad a -- ^ The action to evaluate+ -> (Either PrettyError a, InterpreterState, InterpreterWriter)+pureEval facts sttmap action = runIdentity (interpretMonad (pureReader sttmap) startingState action)+ where+ startingState = initialState facts++-- | A bunch of facts that can be used for pure evaluation.+dummyFacts :: Facts+dummyFacts = HM.fromList $+ [ ("architecture", "amd64")+ , ("augeasversion", "0.10.0")+ , ("bios_release_date", "07/06/2010")+ , ("bios_vendor", "Dell Inc.")+ , ("bios_version", "2.2.0")+ , ("boardmanufacturer", "Dell Inc.")+ , ("domain", "dummy.domain")+ , ("facterversion", "1.7.5")+ , ("filesystems", "ext2,ext3,ext4,vfat")+ , ("fqdn", "dummy.dummy.domain")+ , ("hardwareisa", "x86_64")+ , ("hardwaremodel", "x86_64")+ , ("hostname", "dummy")+ , ("id", "root")+ , ("interfaces", "eth0,lo")+ , ("ipaddress", "172.17.42.1")+ , ("ipaddress_eth0", "172.17.42.1")+ , ("ipaddress_lo", "127.0.0.1")+ , ("is_virtual", "false")+ , ("kernel", "Linux")+ , ("kernelmajversion", "3.8")+ , ("kernelrelease", "3.8.0-37-generic")+ , ("kernelversion", "3.8.0")+ , ("lsbdistcodename", "precise")+ , ("lsbdistdescription", "Ubuntu 12.04.4 LTS")+ , ("lsbdistid", "Ubuntu")+ , ("lsbdistrelease", "12.04")+ , ("lsbmajdistrelease", "12")+ , ("macaddress", "a5:cb:10:b0:9a:4b")+ , ("macaddress_eth0", "72:53:10:c1:eb:70")+ , ("manufacturer", "Dell Inc.")+ , ("memoryfree", "12.57 GB")+ , ("memoryfree_mb", "12869.89")+ , ("memorysize", "15.63 GB")+ , ("memorysize_mb", "16009.07")+ , ("memorytotal", "15.63 GB")+ , ("mtu_eth0", "1500")+ , ("mtu_lo", "65536")+ , ("netmask", "255.255.0.0")+ , ("netmask_eth0", "255.255.255.0")+ , ("netmask_lo", "255.0.0.0")+ , ("network_eth0", "172.17.42.0")+ , ("network_lo", "127.0.0.0")+ , ("operatingsystem", "Ubuntu")+ , ("operatingsystemrelease", "12.04")+ , ("osfamily", "Debian")+ , ("path", "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin")+ , ("physicalprocessorcount", "1")+ , ("processor0", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")+ , ("processor1", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")+ , ("processor2", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")+ , ("processor3", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")+ , ("processor4", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")+ , ("processor5", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")+ , ("processor6", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")+ , ("processor7", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz")+ , ("processorcount", "8")+ , ("productname", "Vostro 430")+ , ("ps", "ps -ef")+ , ("puppetversion", "3.4.3")+ , ("rubysitedir", "/usr/local/lib/site_ruby/1.8")+ , ("rubyversion", "1.8.7")+ , ("selinux", "false")+ , ("serialnumber", "9L3FW4J")+ , ("swapfree", "15.96 GB")+ , ("swapfree_mb", "16340.00")+ , ("swapsize", "15.96 GB")+ , ("swapsize_mb", "16340.00")+ , ("timezone", "CEST")+ , ("type", "Desktop")+ , ("uniqueid", "007f0101")+ , ("uptime", "5:48 hours")+ , ("uptime_days", "0")+ , ("uptime_hours", "5")+ , ("uptime_seconds", "20932")+ , ("uuid", "97b75940-be55-11e3-b1b6-0800200c9a66")+ , ("virtual", "physical")+ ]++-- | A default evaluation function for arbitrary interpreter actions.+dummyEval :: InterpreterMonad a -> Either PrettyError a+dummyEval action = pureEval dummyFacts mempty action ^. _1
Puppet/Interpreter/Resolve.hs view
@@ -33,6 +33,7 @@ import Puppet.Interpreter.PrettyPrinter() import Puppet.Parser.PrettyPrinter(showPos) import Puppet.Interpreter.RubyRandom+import Puppet.Utils import Data.Version (parseVersion) import Text.ParserCombinators.ReadP (readP_to_S)@@ -45,7 +46,6 @@ import qualified Data.HashSet as HS import qualified Data.Text as T import qualified Data.Text.Encoding as T-import Data.Monoid import Control.Applicative hiding ((<$>)) import Control.Monad import Control.Monad.Error@@ -53,8 +53,6 @@ import Control.Lens import Data.Maybe (mapMaybe) import Data.Aeson.Lens hiding (key)-import Data.Attoparsec.Number-import qualified Data.Either.Strict as S import qualified Data.Maybe.Strict as S import qualified Data.ByteString as BS import qualified Crypto.Hash.MD5 as MD5@@ -64,10 +62,11 @@ import Control.Monad.Writer (tell) import Control.Monad.Operational (singleton) import Text.Regex.PCRE.ByteString.Utils+import Data.Scientific -- | A useful type that is used when trying to perform arithmetic on Puppet -- numbers.-type NumberPair = S.Either (Pair Integer Integer) (Pair Double Double)+type NumberPair = Pair Scientific Scientific -- | A hiera helper function, that will throw all Hiera errors and log -- messages to the main monad.@@ -104,14 +103,11 @@ -- attoparsec. If the two values can be converted, it will convert them so -- that they are of the same type toNumbers :: PValue -> PValue -> S.Maybe NumberPair-toNumbers (PString a) (PString b) =- let t2s = fmap scientific2Number . text2Scientific- in case t2s a :!: t2s b of- (Just (I x) :!: Just (I y)) -> S.Just (S.Left (x :!: y))- (Just (D x) :!: Just (D y)) -> S.Just (S.Right (x :!: y))- (Just (I x) :!: Just (D y)) -> S.Just (S.Right (fromIntegral x :!: y))- (Just (D x) :!: Just (I y)) -> S.Just (S.Right (x :!: fromIntegral y))- _ -> S.Nothing+toNumbers (PString a) b = case text2Scientific a of+ Just na -> toNumbers (PNumber na) b+ Nothing -> S.Nothing+toNumbers a (PString b) = toNumbers (PString b) a+toNumbers (PNumber a) (PNumber b) = S.Just (a :!: b) toNumbers _ _ = S.Nothing -- | This tries to run a numerical binary operation on two puppet@@ -119,27 +115,19 @@ -- (using 'toNumbners'), and will finally apply the correct operation. binaryOperation :: Expression -- ^ left operand -> Expression -- ^ right operand- -> (Integer -> Integer -> Integer) -- ^ operation in case those are integers- -> (Double -> Double -> Double) -- ^ operation in case those are doubles+ -> (Scientific -> Scientific -> Scientific) -- ^ operation -> InterpreterMonad PValue-binaryOperation a b opi opd = do- ra <- resolveExpression a- rb <- resolveExpression b- case toNumbers ra rb of- S.Nothing -> throwPosError ("Expected numbers, not" <+> pretty ra <+> "or" <+> pretty rb)- S.Just (S.Right (na :!: nb)) -> return (_Double # opd na nb)- S.Just (S.Left (na :!: nb)) -> return (_Integer # opi na nb)+binaryOperation a b opr = ((PNumber .) . opr) `fmap` resolveExpressionNumber a <*> resolveExpressionNumber b -- | Just like 'binaryOperation', but for operations that only work on -- integers. integerOperation :: Expression -> Expression -> (Integer -> Integer -> Integer) -> InterpreterMonad PValue integerOperation a b opr = do- ra <- resolveExpression a- rb <- resolveExpression b- case toNumbers ra rb of- S.Nothing -> throwPosError ("Expected numbers, not" <+> pretty ra <+> "or" <+> pretty rb)- S.Just (S.Right _) -> throwPosError ("Expected integer values, not" <+> pretty ra <+> "or" <+> pretty rb)- S.Just (S.Left (na :!: nb)) -> return (_Integer # opr na nb)+ ra <- resolveExpressionNumber a+ rb <- resolveExpressionNumber b+ case (preview _Integer ra, preview _Integer rb) of+ (Just na, Just nb) -> return (PNumber $ fromIntegral (opr na nb))+ _ -> throwPosError ("Expected integer values, not" <+> string (show ra) <+> "or" <+> string (show rb)) -- | Resolves a variable, or throws an error if it can't. resolveVariable :: T.Text -> InterpreterMonad PValue@@ -173,21 +161,14 @@ Nothing -> throwError ("Could not resolve variable" <+> pretty (UVariableReference fullvar) <+> "in context" <+> ttext varscope <+> "or root") -- | A helper for numerical comparison functions.-numberCompare :: Expression -> Expression -> (Integer -> Integer -> Bool) -> (Double -> Double -> Bool) -> InterpreterMonad PValue-numberCompare a b compi compd = do- ra <- resolveExpression a- rb <- resolveExpression b- case toNumbers ra rb of- S.Nothing -> throwPosError ("Comparison functions expect numbers, not:" <+> pretty ra <+> comma <+> pretty rb)- S.Just (S.Right (na :!: nb)) -> return (PBoolean (compd na nb))- S.Just (S.Left (na :!: nb)) -> return (PBoolean (compi na nb))+numberCompare :: Expression -> Expression -> (Scientific -> Scientific -> Bool) -> InterpreterMonad PValue+numberCompare a b comp = ((PBoolean .) . comp) `fmap` resolveExpressionNumber a <*> resolveExpressionNumber b -- | Handles the wonders of puppet equality checks. puppetEquality :: PValue -> PValue -> Bool puppetEquality ra rb = case toNumbers ra rb of- (S.Just (S.Right (na :!: nb))) -> na == nb- (S.Just (S.Left (na :!: nb))) -> na == nb+ (S.Just (na :!: nb)) -> na == nb _ -> case (ra, rb) of (PUndef , PBoolean x) -> not x (PString "true", PBoolean x) -> x@@ -218,10 +199,10 @@ else do rb <- fmap pValue2Bool (resolveExpression b) return (PBoolean (ra || rb))-resolveExpression (LessThan a b) = numberCompare a b (<) (<)-resolveExpression (MoreThan a b) = numberCompare a b (>) (>)-resolveExpression (LessEqualThan a b) = numberCompare a b (<=) (<=)-resolveExpression (MoreEqualThan a b) = numberCompare a b (>=) (>=)+resolveExpression (LessThan a b) = numberCompare a b (<)+resolveExpression (MoreThan a b) = numberCompare a b (>)+resolveExpression (LessEqualThan a b) = numberCompare a b (<=)+resolveExpression (MoreEqualThan a b) = numberCompare a b (>=) resolveExpression (RegexMatch a v@(PValue (URegexp _ rv))) = do ra <- fmap T.encodeUtf8 (resolveExpressionString a) case execute' rv ra of@@ -282,13 +263,31 @@ then resolveExpression ce else checkCond xs checkCond (V.toList conds)-resolveExpression (Addition a b) = binaryOperation a b (+) (+)-resolveExpression (Substraction a b) = binaryOperation a b (-) (-)-resolveExpression (Division a b) = binaryOperation a b div (/)-resolveExpression (Multiplication a b) = binaryOperation a b (*) (*)+resolveExpression (Addition a b) = do+ ra <- resolveExpression a+ rb <- resolveExpression b+ case (ra, rb) of+ (PHash ha, PHash hb) -> return (PHash (ha <> hb))+ (PArray ha, PArray hb) -> return (PArray (ha <> hb))+ _ -> binaryOperation a b (+)+resolveExpression (Substraction a b) = binaryOperation a b (-)+resolveExpression (Division a b) = do+ ra <- resolveExpressionNumber a+ rb <- resolveExpressionNumber b+ case rb of+ 0 -> throwPosError "Division by 0"+ _ -> case ( (,) `fmap` preview _Integer ra <*> preview _Integer rb) of+ Just (ia, ib) -> return $ PNumber $ fromIntegral (ia `div` ib)+ _ -> return $ PNumber $ ra / rb+resolveExpression (Multiplication a b) = binaryOperation a b (*) resolveExpression (Modulo a b) = integerOperation a b mod resolveExpression (RightShift a b) = integerOperation a b (\x -> shiftR x . fromIntegral)-resolveExpression (LeftShift a b) = integerOperation a b (\x -> shiftL x . fromIntegral)+resolveExpression (LeftShift a b) = do+ ra <- resolveExpression a+ rb <- resolveExpression b+ case (ra, rb) of+ (PArray ha, v) -> return (PArray (V.snoc ha v))+ _ -> integerOperation a b (\x -> shiftL x . fromIntegral) resolveExpression a@(FunctionApplication e (PValue (UHFunctionCall hf))) = do unless (S.isNothing (hf ^. hfexpr)) (throwPosError ("You can't combine chains of higher order functions (with .) and giving them parameters, in:" <+> pretty a)) resolveValue (UHFunctionCall (hf & hfexpr .~ S.Just e))@@ -298,6 +297,7 @@ -- | Resolves an 'UValue' (terminal for the 'Expression' data type) into -- a 'PValue' resolveValue :: UValue -> InterpreterMonad PValue+resolveValue (UNumber n) = return (PNumber n) resolveValue n@(URegexp _ _) = throwPosError ("Regular expressions are not allowed in this context: " <+> pretty n) resolveValue (UBoolean x) = return (PBoolean x) resolveValue (UString x) = return (PString x)@@ -316,13 +316,20 @@ resolveValue (UFunctionCall fname args) = resolveFunction fname args resolveValue (UHFunctionCall hf) = evaluateHFCPure hf --- | Turns strings and booleans into 'T.Text', or throws an error.+-- | Turns strings, numbers and booleans into 'T.Text', or throws an error. resolvePValueString :: PValue -> InterpreterMonad T.Text resolvePValueString (PString x) = return x resolvePValueString (PBoolean True) = return "true" resolvePValueString (PBoolean False) = return "false"+resolvePValueString (PNumber x) = return (scientific2text x) resolvePValueString x = throwPosError ("Don't know how to convert this to a string:" <$> pretty x) +-- | Turns everything it can into a number, or throws an error+resolvePValueNumber :: PValue -> InterpreterMonad Scientific+resolvePValueNumber x = case x ^? _Number of+ Just n -> return n+ Nothing -> throwPosError ("Don't know how to convert this to a number:" <$> pretty x)+ -- | > resolveValueString = resolveValue >=> resolvePValueString resolveValueString :: UValue -> InterpreterMonad T.Text resolveValueString = resolveValue >=> resolvePValueString@@ -331,6 +338,10 @@ resolveExpressionString :: Expression -> InterpreterMonad T.Text resolveExpressionString = resolveExpression >=> resolvePValueString +-- | > resolveExpressionNumber = resolveExpression >=> resolvePValueNumber+resolveExpressionNumber :: Expression -> InterpreterMonad Scientific+resolveExpressionNumber = resolveExpression >=> resolvePValueNumber+ -- | Just like 'resolveExpressionString', but accepts arrays. resolveExpressionStrings :: Expression -> InterpreterMonad [T.Text] resolveExpressionStrings x =@@ -481,7 +492,7 @@ -- Inject the classes variable. Note that we are relying on the -- invariant that the scope is already entered, and hence present -- in the scps container.- cscps = scps & ix scp . scopeVariables . at "classes" ?~ ( classes :!: initialPPos "dummy" :!: cd )+ cscps = scps & ix scp . scopeVariables . at "classes" ?~ ( classes :!: dummypos :!: cd ) PString `fmap` singleton (ComputeTemplate (templatetype fname) scp cscps) resolveExpressionSE :: Expression -> InterpreterMonad PValue
Puppet/Interpreter/Types.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE DeriveGeneric, TemplateHaskell, CPP, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase, FlexibleContexts #-} {-# LANGUAGE GADTs #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} module Puppet.Interpreter.Types where import Puppet.Parser.Types@@ -35,7 +34,6 @@ import Data.Time.Clock import GHC.Stack import Data.Maybe (fromMaybe)-import Data.Attoparsec.Number import Data.Attoparsec.Text (parseOnly,rational) import Data.Scientific import Control.Monad.Operational@@ -54,12 +52,21 @@ type Container = HM.HashMap T.Text +newtype PrettyError = PrettyError { getError :: Doc }++instance Show PrettyError where+ show = show . getError++instance IsString PrettyError where+ fromString = PrettyError . string+ data PValue = PBoolean !Bool | PUndef | PString !T.Text -- integers and doubles are internally serialized as strings by puppet | PResourceReference !T.Text !T.Text | PArray !(V.Vector PValue) | PHash !(Container PValue)+ | PNumber !Scientific deriving (Eq, Show) -- | The different kind of hiera queries@@ -71,7 +78,7 @@ type HieraQueryFunc m = Container T.Text -- ^ All the variables that Hiera can interpolate, the top level ones being prefixed with :: -> T.Text -- ^ The query -> HieraQueryType- -> m (S.Either Doc (Pair InterpreterWriter (S.Maybe PValue)))+ -> m (S.Either PrettyError (Pair InterpreterWriter (S.Maybe PValue))) data RSearchExpression = REqualitySearch !T.Text !PValue@@ -89,7 +96,7 @@ type Scope = T.Text -type Facts = Container T.Text+type Facts = Container PValue -- |This type is used to differenciate the distinct top level types that are -- exposed by the DSL.@@ -152,8 +159,8 @@ } data InterpreterReader m = InterpreterReader { _nativeTypes :: !(Container PuppetTypeMethods)- , _getStatement :: TopLevelType -> T.Text -> m (S.Either Doc Statement)- , _computeTemplateFunction :: Either T.Text T.Text -> T.Text -> Container ScopeInformation -> m (S.Either Doc T.Text)+ , _getStatement :: TopLevelType -> T.Text -> m (S.Either PrettyError Statement)+ , _computeTemplateFunction :: Either T.Text T.Text -> T.Text -> Container ScopeInformation -> m (S.Either PrettyError T.Text) , _pdbAPI :: PuppetDBAPI m , _externalFunctions :: Container ( [PValue] -> InterpreterMonad PValue ) , _thisNodename :: T.Text@@ -177,8 +184,8 @@ HieraQuery :: Container T.Text -> T.Text -> HieraQueryType -> InterpreterInstr (Pair InterpreterWriter (S.Maybe PValue)) GetCurrentCallStack :: InterpreterInstr [String] -- error- ErrorThrow :: Doc -> InterpreterInstr a- ErrorCatch :: InterpreterMonad a -> (Doc -> InterpreterMonad a) -> InterpreterInstr a+ ErrorThrow :: PrettyError -> InterpreterInstr a+ ErrorCatch :: InterpreterMonad a -> (PrettyError -> InterpreterMonad a) -> InterpreterInstr a -- writer WriterTell :: InterpreterWriter -> InterpreterInstr () WriterPass :: InterpreterMonad (a, InterpreterWriter -> InterpreterWriter) -> InterpreterInstr a@@ -217,7 +224,7 @@ -- | The main monad type InterpreterMonad = ProgramT InterpreterInstr (State InterpreterState) -instance MonadError Doc InterpreterMonad where+instance MonadError PrettyError InterpreterMonad where throwError = singleton . ErrorThrow catchError a c = singleton (ErrorCatch a c) @@ -226,9 +233,9 @@ pass = singleton . WriterPass listen = singleton . WriterListen -instance Error Doc where- noMsg = empty- strMsg = text+instance Error PrettyError where+ noMsg = PrettyError empty+ strMsg = PrettyError . text data RIdentifier = RIdentifier { _itype :: !T.Text , _iname :: !T.Text@@ -287,7 +294,7 @@ -- |This is a function type than can be bound. It is the type of all -- subsequent validators.-type PuppetTypeValidate = Resource -> Either Doc Resource+type PuppetTypeValidate = Resource -> Either PrettyError Resource data PuppetTypeMethods = PuppetTypeMethods { _puppetValidate :: PuppetTypeValidate@@ -296,7 +303,7 @@ type FinalCatalog = HM.HashMap RIdentifier Resource -data DaemonMethods = DaemonMethods { _dGetCatalog :: T.Text -> Facts -> IO (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) -- ^ The most important function, computing catalogs. Given a node name and a list of facts, it returns the result of the catalog compilation : either an error, or a tuple containing all the resources in this catalog, the dependency map, the exported resources, and a list of known resources, that might not be up to date, but are here for code coverage tests.+data DaemonMethods = DaemonMethods { _dGetCatalog :: T.Text -> Facts -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) -- ^ The most important function, computing catalogs. Given a node name and a list of facts, it returns the result of the catalog compilation : either an error, or a tuple containing all the resources in this catalog, the dependency map, the exported resources, and a list of known resources, that might not be up to date, but are here for code coverage tests. , _dParserStats :: MStats , _dCatalogStats :: MStats , _dTemplateStats :: MStats@@ -314,7 +321,7 @@ data PFactInfo = PFactInfo { _pfactinfoNodename :: !T.Text , _pfactinfoFactname :: !T.Text- , _pfactinfoFactval :: !T.Text+ , _pfactinfoFactval :: !PValue } data PNodeInfo = PNodeInfo { _pnodeinfoNodename :: !Nodename@@ -325,14 +332,14 @@ } data PuppetDBAPI m = PuppetDBAPI { pdbInformation :: m Doc- , replaceCatalog :: WireCatalog -> m (S.Either Doc ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-catalog-version-3>- , replaceFacts :: [(Nodename, Facts)] -> m (S.Either Doc ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-facts-version-1>- , deactivateNode :: Nodename -> m (S.Either Doc ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#deactivate-node-version-1>- , getFacts :: Query FactField -> m (S.Either Doc [PFactInfo]) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/facts.html#get-v3facts>- , getResources :: Query ResourceField -> m (S.Either Doc [Resource]) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/resources.html#get-v3resources>- , getNodes :: Query NodeField -> m (S.Either Doc [PNodeInfo])- , commitDB :: m (S.Either Doc ()) -- ^ This is only here to tell the test PuppetDB to save its content to disk.- , getResourcesOfNode :: Nodename -> Query ResourceField -> m (S.Either Doc [Resource])+ , replaceCatalog :: WireCatalog -> m (S.Either PrettyError ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-catalog-version-3>+ , replaceFacts :: [(Nodename, Facts)] -> m (S.Either PrettyError ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-facts-version-1>+ , deactivateNode :: Nodename -> m (S.Either PrettyError ()) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#deactivate-node-version-1>+ , getFacts :: Query FactField -> m (S.Either PrettyError [PFactInfo]) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/facts.html#get-v3facts>+ , getResources :: Query ResourceField -> m (S.Either PrettyError [Resource]) -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/resources.html#get-v3resources>+ , getNodes :: Query NodeField -> m (S.Either PrettyError [PNodeInfo])+ , commitDB :: m (S.Either PrettyError ()) -- ^ This is only here to tell the test PuppetDB to save its content to disk.+ , getResourcesOfNode :: Nodename -> Query ResourceField -> m (S.Either PrettyError [Resource]) } -- | Pretty straightforward way to define the various PuppetDB queries@@ -392,14 +399,14 @@ instance MonadStack InterpreterMonad where getCallStack = singleton GetCurrentCallStack -tpe :: (MonadStack m, MonadError Doc m, MonadState InterpreterState m) => Doc -> m b+tpe :: (MonadStack m, MonadError PrettyError m, MonadState InterpreterState m) => Doc -> m b tpe s = do p <- use (curPos . _1) stack <- getCallStack let dstack = if null stack then mempty else mempty </> string (renderStack stack)- throwError (s <+> "at" <+> showPos p <> dstack)+ throwError (PrettyError (s <+> "at" <+> showPos p <> dstack)) instance MonadThrowPos InterpreterMonad where throwPosError = tpe@@ -432,7 +439,7 @@ instance FromJSON PValue where parseJSON Null = return PUndef- parseJSON (Number n) = return (PString (T.pack (show (scientific2Number n))))+ parseJSON (Number n) = return $ PNumber n parseJSON (String s) = return (PString s) parseJSON (Bool b) = return (PBoolean b) parseJSON (Array v) = fmap PArray (V.mapM parseJSON v)@@ -445,6 +452,7 @@ toJSON (PResourceReference _ _) = Null -- TODO toJSON (PArray r) = Array (V.map toJSON r) toJSON (PHash x) = Object (HM.map toJSON x)+ toJSON (PNumber n) = Number n #ifdef HRUBY instance ToRuby PValue where@@ -456,33 +464,33 @@ Error _ -> return Nothing Success suc -> return (Just suc) #endif-eitherDocIO :: IO (S.Either Doc a) -> IO (S.Either Doc a)-eitherDocIO computation = (computation >>= check) `catch` (\e -> return $ S.Left $ dullred $ text $ show (e :: SomeException))+eitherDocIO :: IO (S.Either PrettyError a) -> IO (S.Either PrettyError a)+eitherDocIO computation = (computation >>= check) `catch` (\e -> return $ S.Left $ PrettyError $ dullred $ text $ show (e :: SomeException)) where check (S.Left r) = return (S.Left r) check (S.Right x) = return (S.Right x) -interpreterIO :: (MonadThrowPos m, MonadIO m) => IO (S.Either Doc a) -> m a+interpreterIO :: (MonadThrowPos m, MonadIO m) => IO (S.Either PrettyError a) -> m a {-# INLINE interpreterIO #-} interpreterIO f = do liftIO (eitherDocIO f) >>= \case S.Right x -> return x- S.Left rr -> throwPosError rr+ S.Left rr -> throwPosError (getError rr) -mightFail :: (MonadError Doc m, MonadThrowPos m) => m (S.Either Doc a) -> m a+mightFail :: (MonadError PrettyError m, MonadThrowPos m) => m (S.Either PrettyError a) -> m a mightFail a = a >>= \case S.Right x -> return x- S.Left rr -> throwPosError rr+ S.Left rr -> throwPosError (getError rr) safeDecodeUtf8 :: BS.ByteString -> InterpreterMonad T.Text {-# INLINE safeDecodeUtf8 #-} safeDecodeUtf8 i = return (T.decodeUtf8 i) -interpreterError :: InterpreterMonad (S.Either Doc a) -> InterpreterMonad a+interpreterError :: InterpreterMonad (S.Either PrettyError a) -> InterpreterMonad a {-# INLINE interpreterError #-} interpreterError f = f >>= \case S.Right r -> return r- S.Left rr -> throwPosError rr+ S.Left rr -> throwPosError (getError rr) resourceRelations :: Resource -> [(RIdentifier, LinkType)] resourceRelations = concatMap expandSet . HM.toList . _rrelations@@ -707,7 +715,7 @@ ] instance ToJSON PFactInfo where- toJSON (PFactInfo n f v) = object [("certname", String n), ("name", String f), ("value", String v)]+ toJSON (PFactInfo n f v) = object [("certname", String n), ("name", String f), ("value", toJSON v)] instance FromJSON PFactInfo where parseJSON (Object v) = PFactInfo <$> v .: "certname" <*> v .: "name" <*> v .: "value"@@ -734,30 +742,26 @@ Left _ -> Nothing Right s -> Just s -scientific2Number :: Scientific -> Number-scientific2Number s =- let e = base10Exponent s- c = coefficient s- in if e >= 0- then I (c * 10 ^ e)- else D ((fromInteger c / 10 ^ negate e) :: Double)--text2Number :: T.Text -> Maybe Number-text2Number = fmap scientific2Number . text2Scientific- instance AsNumber PValue where _Number = prism num2PValue toNumber where num2PValue :: Scientific -> PValue- num2PValue s =- let e = base10Exponent s- c = coefficient s- in PString $ T.pack $ if e >= 0- then show (c * 10 ^ e)- else show ( (fromInteger c / 10 ^ negate e) :: Double)+ num2PValue = PNumber toNumber :: PValue -> Either PValue Scientific+ toNumber (PNumber n) = Right n toNumber p@(PString x) = case text2Scientific x of Just o -> Right o _ -> Left p toNumber p = Left p++initialState :: Facts -> InterpreterState+initialState facts = InterpreterState baseVars initialclass mempty [ContRoot] dummypos mempty [] []+ where+ callervars = HM.fromList [("caller_module_name", PString "::" :!: dummypos :!: ContRoot), ("module_name", PString "::" :!: dummypos :!: ContRoot)]+ factvars = facts & each %~ (\x -> x :!: initialPPos "facts" :!: ContRoot)+ baseVars = HM.singleton "::" (ScopeInformation (factvars `mappend` callervars) mempty mempty (CurContainer ContRoot mempty) mempty S.Nothing)+ initialclass = mempty & at "::" ?~ (IncludeStandard :!: dummypos)++dummypos :: PPosition+dummypos = initialPPos "dummy"
Puppet/Lens.hs view
@@ -7,6 +7,7 @@ , _PHash , _PBoolean , _PString+ , _PNumber , _PResourceReference , _PUndef , _PArray@@ -27,15 +28,40 @@ , _Dependency , _TopContainer , _Statements+ -- * Lenses and Prisms for 'Expression's+ , _Equal+ , _Different+ , _Not+ , _And+ , _Or+ , _LessThan+ , _MoreThan+ , _LessEqualThan+ , _MoreEqualThan+ , _RegexMatch+ , _NotRegexMatch+ , _Contains+ , _Addition+ , _Substraction+ , _Division+ , _Multiplication+ , _Modulo+ , _RightShift+ , _LeftShift+ , _Lookup+ , _Negate+ , _ConditionalValue+ , _FunctionApplication+ , _PValue ) where import Control.Lens-import Data.Aeson.Lens import Control.Applicative import Puppet.PP (displayNocolor) import Puppet.Parser.Types import Puppet.Interpreter.Types+import Puppet.Interpreter.Pure import Puppet.Interpreter.Resolve import Puppet.Parser import Puppet.Parser.PrettyPrinter (ppStatements)@@ -44,79 +70,30 @@ import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import Data.Tuple.Strict hiding (uncurry)-import Data.Bits import Text.Parser.Combinators (eof) -- Prisms makePrisms ''PValue makePrisms ''Statement+makePrisms ''Expression -- | Incomplete _PResolveExpression :: Prism' Expression PValue _PResolveExpression = prism reinject extract where- extract x@(PValue v) = case v ^? _PResolveValue of- Just r -> Right r- Nothing -> Left x- extract x@(And a b) =- let a' = a ^? _PResolveExpression . to pValue2Bool- b' = b ^? _PResolveExpression . to pValue2Bool- in case (a',b') of- (Just False, _) -> Right (PBoolean False)- (Just _, Just r) -> Right (PBoolean r)- _ -> Left x- extract x@(Or a b) =- let a' = a ^? _PResolveExpression . to pValue2Bool- b' = b ^? _PResolveExpression . to pValue2Bool- in case (a',b') of- (Just True, _) -> Right (PBoolean True)- (Just _, Just r) -> Right (PBoolean r)- _ -> Left x- extract x@(Addition a b) = extractBinop x a b (+) (+)- extract x@(Substraction a b) = extractBinop x a b (-) (-)- extract x@(Division a b) = extractNotZero b >> extractBinop x a b div (/)- extract x@(Multiplication a b) = extractBinop x a b (*) (*)- extract x@(Modulo a b) = extractNotZero b >> extractIntOp x a b mod- extract x@(RightShift a b) = extractIntOp x a b (\v -> shiftR v . fromIntegral)- extract x@(LeftShift a b) = extractIntOp x a b (\v -> shiftL v . fromIntegral)- extract x = Left x- reinject = PValue . review _PResolveValue--extractNotZero :: Expression -> Either Expression PValue-extractNotZero e = case e ^? _PResolveExpression of- Just "0" -> Left e- Just r -> Right r- _ -> Left e--extractBinop :: Expression -> Expression -> Expression -> (Integer -> Integer -> Integer) -> (Double -> Double -> Double) -> Either Expression PValue-extractBinop x a b opi opf = case opi `fmap` (a ^? _PResolveExpression . _Integer) <*> (b ^? _PResolveExpression . _Integer) of- Just ri -> Right $ review _Integer ri- Nothing -> case opf `fmap` (a ^? _PResolveExpression . _Double) <*> (b ^? _PResolveExpression . _Double) of- Just rd -> Right $ review _Double rd- Nothing -> Left x--extractIntOp :: Expression -> Expression -> Expression -> (Integer -> Integer -> Integer) -> Either Expression PValue-extractIntOp x a b opi = case opi `fmap` (a ^? _PResolveExpression . _Integer) <*> (b ^? _PResolveExpression . _Integer) of- Just ri -> Right $ review _Integer ri- Nothing -> Left x+ extract e = case dummyEval (resolveExpression e) of+ Right x -> Right x+ Left _ -> Left e+ reinject = PValue . review _PResolveValue _PResolveValue :: Prism' UValue PValue _PResolveValue = prism toU toP where- toP (UString s) = Right (PString s)- toP UUndef = Right PUndef- toP (UBoolean b) = Right (PBoolean b)- toP r@(UResourceReference t n) = maybe (Left r) (Right . PResourceReference t) (n ^? _PResolveExpression . _PString)- toP r@(UArray lst) = maybe (Left r) (Right . PArray) (V.mapM (preview _PResolveExpression) lst)- toP r@(UHash lst) = maybe (Left r) (Right . PHash . HM.fromList) (mapM resolveKV (V.toList lst))- where- resolveKV (k :!: v) = do- k' <- k ^? _PResolveExpression . _PString- v' <- v ^? _PResolveExpression- return (k',v')- toP r@(UInterpolable ip) = maybe (Left r) (Right . PString . T.concat . V.toList ) (V.mapM (preview (_PResolveValue . _PString)) ip)- toP r = Left r+ toP uv = case dummyEval (resolveValue uv) of+ Right x -> Right x+ Left _ -> Left uv toU (PBoolean x) = UBoolean x+ toU (PNumber x) = UNumber x toU PUndef = UUndef toU (PString s) = UString s toU (PResourceReference t n) = UResourceReference t (PValue (UString n))
Puppet/Manifests.hs view
@@ -17,7 +17,7 @@ import qualified Data.HashMap.Strict as HM -- TODO pre-triage stuff-filterStatements :: TopLevelType -> T.Text -> V.Vector Statement -> IO (S.Either Doc Statement)+filterStatements :: TopLevelType -> T.Text -> V.Vector Statement -> IO (S.Either PrettyError Statement) -- the most complicated case, node matching filterStatements TopNode ndename stmts = -- this operation should probably get cached@@ -27,11 +27,11 @@ triage curstuff n@(Node NodeDefault _ _ _) = curstuff & _4 ?~ n triage curstuff x = curstuff & _1 %~ (|> x) bsnodename = T.encodeUtf8 ndename- checkRegexp :: [Pair Regex Statement] -> ErrorT Doc IO (Maybe Statement)+ checkRegexp :: [Pair Regex Statement] -> ErrorT PrettyError IO (Maybe Statement) checkRegexp [] = return Nothing checkRegexp ((regexp :!: s):xs) = do case execute' regexp bsnodename of- Left rr -> throwError ("Regexp match error:" <+> text (show rr))+ Left rr -> throwError (PrettyError ("Regexp match error:" <+> text (show rr))) Right Nothing -> checkRegexp xs Right (Just _) -> return (Just s) strictEither (Left x) = S.Left x@@ -42,7 +42,7 @@ regexpMatchM <- checkRegexp (V.toList regexpmatches) -- match regexps case regexpMatchM <|> defaultnode of -- check for regexp matches or use the default node Just r -> return (TopContainer spurious r)- Nothing -> throwError ("Couldn't find node" <+> ttext ndename)+ Nothing -> throwError (PrettyError ("Couldn't find node" <+> ttext ndename)) filterStatements x ndename stmts = let (!spurious, !defines, !classes) = V.foldl' triage (V.empty, HM.empty, HM.empty) stmts triage curstuff n@(ClassDeclaration cname _ _ _ _) = curstuff & _3 . at cname ?~ n@@ -56,7 +56,7 @@ TopSpurious -> return (S.Left "Should not ask for a TopSpurious!!!") TopDefine -> case defines ^. at ndename of Just n -> return (S.Right (tc n))- Nothing -> return (S.Left ("Couldn't find define " <+> ttext ndename))+ Nothing -> return (S.Left (PrettyError ("Couldn't find define " <+> ttext ndename))) TopClass -> case classes ^. at ndename of Just n -> return (S.Right (tc n))- Nothing -> return (S.Left ("Couldn't find class " <+> ttext ndename))+ Nothing -> return (S.Left (PrettyError ("Couldn't find class " <+> ttext ndename)))
Puppet/NativeTypes.hs view
@@ -21,7 +21,7 @@ fakeTypes = map faketype ["class"] defaultTypes :: [(PuppetTypeName, PuppetTypeMethods)]-defaultTypes = map defaulttype ["augeas","computer","filebucket","interface","k5login","macauthorization","mailalias","maillist","mcx","nagios_command","nagios_contact","nagios_contactgroup","nagios_host","nagios_hostdependency","nagios_hostescalation","nagios_hostextinfo","nagios_hostgroup","nagios_service","nagios_servicedependency","nagios_serviceescalation","nagios_serviceextinfo","nagios_servicegroup","nagios_timeperiod","notify","package","resources","router","schedule","scheduledtask","selboolean","selmodule","service","sshauthorizedkey","sshkey","stage","tidy","vlan","yumrepo","zfs","zone","zpool"]+defaultTypes = map defaulttype ["augeas","computer","filebucket","interface","k5login","macauthorization","mailalias","maillist","mcx","nagios_command","nagios_contact","nagios_contactgroup","nagios_host","nagios_hostdependency","nagios_hostescalation","nagios_hostextinfo","nagios_hostgroup","nagios_service","nagios_servicedependency","nagios_serviceescalation","nagios_serviceextinfo","nagios_servicegroup","nagios_timeperiod","notify","package","resources","router","schedule","scheduledtask","selboolean","selmodule","service","ssh_authorized_key","sshkey","stage","tidy","vlan","yumrepo","zfs","zone","zpool"] -- | The map of native types. They are described in "Puppet.NativeTypes.Helpers". baseNativeTypes :: Container PuppetTypeMethods@@ -46,6 +46,6 @@ case tps ^. at (r ^. rid . itype) of Just x -> case (x ^. puppetValidate) r of Right nr -> return nr- Left err -> throwPosError ("Invalid resource" <+> pretty r </> err)+ Left err -> throwPosError ("Invalid resource" <+> pretty r </> getError err) Nothing -> return r
Puppet/NativeTypes/Cron.hs view
@@ -8,7 +8,7 @@ import qualified Data.Text as T import Control.Lens import qualified Data.Vector as V-import Data.Attoparsec.Number+import Data.Scientific nativeCron :: (PuppetTypeName, PuppetTypeMethods) nativeCron = ("cron", PuppetTypeMethods validateCron parameterset)@@ -43,14 +43,15 @@ Just x -> vrange' mi ma valuelist param res x Nothing -> defaultvalue "*" param res -vrange' :: Integer -> Integer -> [T.Text] -> T.Text -> Resource -> PValue -> Either Doc Resource+vrange' :: Integer -> Integer -> [T.Text] -> T.Text -> Resource -> PValue -> Either PrettyError Resource vrange' mi ma valuelist param res y = case y of PString "*" -> Right res PString "absent" -> Right res+ PNumber n -> checkint' n mi ma param res PString x -> if x `elem` valuelist then Right res else parseval x mi ma param res- x -> Left $ "Parameter" <+> paramname param <+> "value should be a valid cron declaration and not" <+> pretty x+ x -> perror $ "Parameter" <+> paramname param <+> "value should be a valid cron declaration and not" <+> pretty x parseval :: T.Text -> Integer -> Integer -> T.Text -> PuppetTypeValidate parseval resval mi ma pname res | "*/" `T.isPrefixOf` resval = checkint (T.drop 2 resval) 1 ma pname res@@ -58,13 +59,12 @@ checkint :: T.Text -> Integer -> Integer -> T.Text -> PuppetTypeValidate checkint st mi ma pname res =- case text2Number st of- Just (I v) -> checkint' v mi ma pname res- Just (D _) -> Left $ "Invalid value type for parameter" <+> paramname pname <+> ": expected an integer"- Nothing -> Left $ "Invalid value type for parameter" <+> paramname pname <+> ": " <+> red (ttext st)+ case text2Scientific st of+ Just n -> checkint' n mi ma pname res+ Nothing -> perror $ "Invalid value type for parameter" <+> paramname pname <+> ": " <+> red (ttext st) -checkint' :: Integer -> Integer -> Integer -> T.Text -> PuppetTypeValidate+checkint' :: Scientific -> Integer -> Integer -> T.Text -> PuppetTypeValidate checkint' i mi ma param res =- if (i>=mi) && (i<=ma)+ if (i >= fromIntegral mi) && (i <= fromIntegral ma) then Right res- else Left $ "Parameter" <+> paramname param <+> "value is out of bound, should statisfy" <+> P.integer mi <+> "<=" <+> P.integer i <+> "<=" <+> P.integer ma+ else perror $ "Parameter" <+> paramname param <+> "value is out of bound, should satisfy" <+> P.integer mi <+> "<=" <+> P.string (show i) <+> "<=" <+> P.integer ma
Puppet/NativeTypes/File.hs view
@@ -44,16 +44,16 @@ validateFile = defaultValidate parameterset >=> parameterFunctions parameterfunctions >=> validateSourceOrContent >=> validateMode validateMode :: PuppetTypeValidate-validateMode res = let- modestr = case res ^. rattributes . at "mode" of- Just (PString s) -> s- _ -> "0644"- in do- when ((T.length modestr /= 3) && (T.length modestr /= 4)) (throwError "Invalid mode size")- unless (T.all isDigit modestr) (throwError "The mode should only be made of digits")- if T.length modestr == 3- then return $ res & rattributes . at "mode" ?~ PString (T.cons '0' modestr)- else return res+validateMode res = do+ modestr <- case res ^. rattributes . at "mode" of+ Just (PString s) -> return s+ Just x -> throwError $ PrettyError ("Invalide mode type, should be a string " <+> pretty x)+ Nothing -> throwError "Could not find mode!"+ when ((T.length modestr /= 3) && (T.length modestr /= 4)) (throwError "Invalid mode size")+ unless (T.all isDigit modestr) (throwError "The mode should only be made of digits")+ if T.length modestr == 3+ then return $ res & rattributes . at "mode" ?~ PString (T.cons '0' modestr)+ else return res validateSourceOrContent :: PuppetTypeValidate validateSourceOrContent res = let@@ -61,11 +61,11 @@ source = HM.member "source" parammap content = HM.member "content" parammap in if source && content- then Left "Source and content can't be specified at the same time"+ then perror "Source and content can't be specified at the same time" else Right res checkSource :: T.Text -> PValue -> PuppetTypeValidate checkSource _ (PString x) res | "puppet://" `T.isPrefixOf` x = Right res | "file://" `T.isPrefixOf` x = Right res | otherwise = throwError "A source should start with either puppet:// or file://"-checkSource _ x _ = throwError ("Expected a string, not" <+> pretty x)+checkSource _ x _ = throwError $ PrettyError ("Expected a string, not" <+> pretty x)
Puppet/NativeTypes/Helpers.hs view
@@ -1,7 +1,7 @@ {-| These are the function and data types that are used to define the Puppet native types. -}-module Puppet.NativeTypes.Helpers +module Puppet.NativeTypes.Helpers ( module Puppet.PP , ipaddr , paramname@@ -25,9 +25,11 @@ , faketype , defaulttype , runarray+ , perror ) where import Puppet.PP hiding (string,integer)+import Puppet.Utils import qualified Text.PrettyPrint.ANSI.Leijen as P import Puppet.Interpreter.Types import Puppet.Interpreter.PrettyPrinter()@@ -36,16 +38,19 @@ import Data.Char (isDigit) import Control.Monad import qualified Data.Text as T-import Puppet.Utils import Control.Lens import qualified Data.Vector as V-import Data.Attoparsec.Number+import Data.Aeson.Lens (_Number,_Integer) type PuppetTypeName = T.Text paramname :: T.Text -> Doc paramname = red . ttext +-- | Useful helper for buiding error messages+perror :: Doc -> Either PrettyError Resource+perror = Left . PrettyError+ faketype :: PuppetTypeName -> (PuppetTypeName, PuppetTypeMethods) faketype tname = (tname, PuppetTypeMethods Right HS.empty) @@ -62,7 +67,7 @@ checkParameterList validparameters res | HS.null validparameters = Right res | otherwise = if HS.null setdiff then Right res- else Left $ "Unknown parameters: " <+> list (map paramname $ HS.toList setdiff)+ else perror $ "Unknown parameters: " <+> list (map paramname $ HS.toList setdiff) where keyset = HS.fromList $ HM.keys (res ^. rattributes) setdiff = HS.difference keyset (metaparameters `HS.union` validparameters)@@ -80,7 +85,7 @@ runarray :: T.Text -> (T.Text -> PValue -> PuppetTypeValidate) -> PuppetTypeValidate runarray param func res = case res ^. rattributes . at param of Just (PArray x) -> V.foldM (flip (func param)) res x- Just x -> Left $ "Parameter" <+> paramname param <+> "should be an array, not" <+> pretty x+ Just x -> perror $ "Parameter" <+> paramname param <+> "should be an array, not" <+> pretty x Nothing -> Right res {-| This checks that a given parameter is a string. If it is a 'ResolvedInt' or@@ -99,15 +104,16 @@ PString _ -> Right res PBoolean True -> Right (res & rattributes . at param ?~ PString "true") PBoolean False -> Right (res & rattributes . at param ?~ PString "false")- x -> Left $ "Parameter" <+> paramname param <+> "should be a string, and not" <+> pretty x+ PNumber n -> Right (res & rattributes . at param ?~ PString (scientific2text n))+ x -> perror $ "Parameter" <+> paramname param <+> "should be a string, and not" <+> pretty x -- | Makes sure that the parameter, if defined, has a value among this list. values :: [T.Text] -> T.Text -> PuppetTypeValidate values valuelist param res = case res ^. rattributes . at param of Just (PString x) -> if x `elem` valuelist then Right res- else Left $ "Parameter" <+> paramname param <+> "value should be one of" <+> list (map ttext valuelist) <+> "and not" <+> ttext x- Just x -> Left $ "Parameter" <+> paramname param <+> "value should be one of" <+> list (map ttext valuelist) <+> "and not" <+> pretty x+ else perror $ "Parameter" <+> paramname param <+> "value should be one of" <+> list (map ttext valuelist) <+> "and not" <+> ttext x+ Just x -> perror $ "Parameter" <+> paramname param <+> "value should be one of" <+> list (map ttext valuelist) <+> "and not" <+> pretty x Nothing -> Right res -- | This fills the default values of unset parameters.@@ -129,9 +135,9 @@ integers param = runarray param integer'' integer'' :: T.Text -> PValue -> PuppetTypeValidate-integer'' param val res = case puppet2number val of- Just (I v) -> Right (res & rattributes . at param ?~ PString (T.pack (show v)))- _ -> Left $ "Parameter" <+> paramname param <+> "must be an integer"+integer'' param val res = case val ^? _Integer of+ Just v -> Right (res & rattributes . at param ?~ PNumber (fromIntegral v))+ _ -> perror $ "Parameter" <+> paramname param <+> "must be an integer" -- | Copies the "name" value into the parameter if this is not set. It implies -- the `string` validator.@@ -139,7 +145,7 @@ nameval prm res = string prm res >>= \r -> case r ^. rattributes . at prm of Just (PString al) -> Right (res & rid . iname .~ al)- Just x -> Left ("The alias must be a string, not" <+> pretty x)+ Just x -> perror ("The alias must be a string, not" <+> pretty x) Nothing -> Right (r & rattributes . at prm ?~ PString (r ^. rid . iname)) -- | Checks that a given parameter is set unless the resources "ensure" is set to absent@@ -148,21 +154,21 @@ Just _ -> Right res Nothing -> case res ^. rattributes . at "ensure" of Just "absent" -> Right res- _ -> Left $ "Parameter" <+> paramname param <+> "should be set."+ _ -> perror $ "Parameter" <+> paramname param <+> "should be set." -- | Checks that a given parameter is set. mandatory :: T.Text -> PuppetTypeValidate mandatory param res = case res ^. rattributes . at param of Just _ -> Right res- Nothing -> Left $ "Parameter" <+> paramname param <+> "should be set."+ Nothing -> perror $ "Parameter" <+> paramname param <+> "should be set." -- | Helper that takes a list of stuff and will generate a validator. parameterFunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] -> PuppetTypeValidate parameterFunctions argrules rs = foldM parameterFunctions' rs argrules where- parameterFunctions' :: Resource -> (T.Text, [T.Text -> PuppetTypeValidate]) -> Either Doc Resource+ parameterFunctions' :: Resource -> (T.Text, [T.Text -> PuppetTypeValidate]) -> Either PrettyError Resource parameterFunctions' r (param, validationfunctions) = foldM (parameterFunctions'' param) r validationfunctions- parameterFunctions'' :: T.Text -> Resource -> (T.Text -> PuppetTypeValidate) -> Either Doc Resource+ parameterFunctions'' :: T.Text -> Resource -> (T.Text -> PuppetTypeValidate) -> Either PrettyError Resource parameterFunctions'' param r validationfunction = validationfunction param r -- checks that a parameter is fully qualified@@ -174,7 +180,7 @@ noTrailingSlash :: T.Text -> PuppetTypeValidate noTrailingSlash param res = case res ^. rattributes . at param of Just (PString x) -> if T.last x == '/'- then Left ("Parameter" <+> paramname param <+> "should not have a trailing slash")+ then perror ("Parameter" <+> paramname param <+> "should not have a trailing slash") else Right res _ -> Right res @@ -183,11 +189,11 @@ fullyQualified' :: T.Text -> PValue -> PuppetTypeValidate fullyQualified' param path res = case path of- PString ("") -> Left $ "Empty path for parameter" <+> paramname param+ PString ("") -> perror $ "Empty path for parameter" <+> paramname param PString p -> if T.head p == '/' then Right res- else Left $ "Path must be absolute, not" <+> ttext p <+> "for parameter" <+> paramname param- x -> Left $ "SHOULD NOT HAPPEN: path is not a resolved string, but" <+> pretty x <+> "for parameter" <+> paramname param+ else perror $ "Path must be absolute, not" <+> ttext p <+> "for parameter" <+> paramname param+ x -> perror $ "SHOULD NOT HAPPEN: path is not a resolved string, but" <+> pretty x <+> "for parameter" <+> paramname param rarray :: T.Text -> PuppetTypeValidate rarray param res = case res ^. rattributes . at param of@@ -201,8 +207,8 @@ Just (PString ip) -> if checkipv4 ip 0 then Right res- else Left $ "Invalid IP address for parameter" <+> paramname param- Just x -> Left $ "Parameter" <+> paramname param <+> "should be an IP address string, not" <+> pretty x+ else perror $ "Invalid IP address for parameter" <+> paramname param+ Just x -> perror $ "Parameter" <+> paramname param <+> "should be an IP address string, not" <+> pretty x checkipv4 :: T.Text -> Int -> Bool checkipv4 _ 4 = False -- means that there are more than 4 groups@@ -218,14 +224,11 @@ inrange :: Integer -> Integer -> T.Text -> PuppetTypeValidate inrange mi ma param res = let va = res ^. rattributes . at param- na = va >>= puppet2number+ na = va ^? traverse . _Number in case (va,na) of (Nothing, _) -> Right res- (_,Just (D v)) -> if (v >= fromIntegral mi) && (v <= fromIntegral ma)- then Right res- else Left $ "Parameter" <+> paramname param P.<> "'s value should be between" <+> P.integer mi <+> "and" <+> P.integer ma- (_,Just (I v)) -> if (v>=mi) && (v<=ma)- then Right res- else Left $ "Parameter" <+> paramname param P.<> "'s value should be between" <+> P.integer mi <+> "and" <+> P.integer ma- (Just x,_) -> Left $ "Parameter" <+> paramname param <+> "should be an integer, and not" <+> pretty x+ (_,Just v) -> if (v >= fromIntegral mi) && (v <= fromIntegral ma)+ then Right res+ else perror $ "Parameter" <+> paramname param P.<> "'s value should be between" <+> P.integer mi <+> "and" <+> P.integer ma+ (Just x,_) -> perror $ "Parameter" <+> paramname param <+> "should be an integer, and not" <+> pretty x
Puppet/NativeTypes/Host.hs view
@@ -32,24 +32,24 @@ checkhostname :: T.Text -> PuppetTypeValidate checkhostname param res = case res ^. rattributes . at param of- Nothing -> Right res+ Nothing -> Right res Just (PArray xs) -> V.foldM (checkhostname' param) res xs Just x@(PString _) -> checkhostname' param res x- Just x -> Left $ paramname param <+> "should be an array or a single string, not" <+> pretty x+ Just x -> perror $ paramname param <+> "should be an array or a single string, not" <+> pretty x -checkhostname' :: T.Text -> Resource -> PValue -> Either Doc Resource-checkhostname' prm _ (PString "") = Left $ "Empty hostname for parameter" <+> paramname prm+checkhostname' :: T.Text -> Resource -> PValue -> Either PrettyError Resource+checkhostname' prm _ (PString "") = perror $ "Empty hostname for parameter" <+> paramname prm checkhostname' prm res (PString x ) = checkhostname'' prm res x-checkhostname' prm _ x = Left $ "Parameter " <+> paramname prm <+> "should be an string or an array of strings, but this was found :" <+> pretty x+checkhostname' prm _ x = perror $ "Parameter " <+> paramname prm <+> "should be an string or an array of strings, but this was found :" <+> pretty x -checkhostname'' :: T.Text -> Resource -> T.Text -> Either Doc Resource-checkhostname'' prm _ "" = Left $ "Empty hostname part in parameter" <+> paramname prm+checkhostname'' :: T.Text -> Resource -> T.Text -> Either PrettyError Resource+checkhostname'' prm _ "" = perror $ "Empty hostname part in parameter" <+> paramname prm checkhostname'' prm res prt = let (cur,nxt) = T.break (=='.') prt nextfunc = if T.null nxt then Right res else checkhostname'' prm res (T.tail nxt) in if T.null cur || (T.head cur == '-') || not (T.all (\x -> isAlphaNum x || (x=='-')) cur)- then Left $ "Invalid hostname part for parameter" <+> paramname prm+ then perror $ "Invalid hostname part for parameter" <+> paramname prm else nextfunc
Puppet/NativeTypes/Package.hs view
@@ -71,14 +71,14 @@ ,("uninstall_options", [rarray]) ] -getFeature :: Resource -> Either Doc (HS.HashSet PackagingFeatures, Resource)+getFeature :: Resource -> Either PrettyError (HS.HashSet PackagingFeatures, Resource) getFeature res = case res ^. rattributes . at "provider" of Just (PString x) -> case HM.lookup x isFeatureSupported of Just s -> Right (s,res)- Nothing -> Left ("Do not know provider" <+> ttext x)+ Nothing -> Left $ PrettyError ("Do not know provider" <+> ttext x) _ -> Left "Can't happen at Puppet.NativeTypes.Package" -checkFeatures :: (HS.HashSet PackagingFeatures, Resource) -> Either Doc Resource+checkFeatures :: (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError Resource checkFeatures = checkAdminFile >=> checkEnsure@@ -86,17 +86,17 @@ >=> checkParam "uninstall_options" UninstallOptions >=> decap where- checkFeature :: HS.HashSet PackagingFeatures -> Resource -> PackagingFeatures -> Either Doc (HS.HashSet PackagingFeatures, Resource)+ checkFeature :: HS.HashSet PackagingFeatures -> Resource -> PackagingFeatures -> Either PrettyError (HS.HashSet PackagingFeatures, Resource) checkFeature s r f = if HS.member f s then Right (s, r)- else Left ("Feature" <+> text (show f) <+> "is required for the current configuration")- checkParam :: T.Text -> PackagingFeatures -> (HS.HashSet PackagingFeatures, Resource) -> Either Doc (HS.HashSet PackagingFeatures, Resource)+ else Left $ PrettyError ("Feature" <+> text (show f) <+> "is required for the current configuration")+ checkParam :: T.Text -> PackagingFeatures -> (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError (HS.HashSet PackagingFeatures, Resource) checkParam pn f (s,r) = if has (ix pn) (r ^. rattributes) then checkFeature s r f else Right (s,r)- checkAdminFile :: (HS.HashSet PackagingFeatures, Resource) -> Either Doc (HS.HashSet PackagingFeatures, Resource)+ checkAdminFile :: (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError (HS.HashSet PackagingFeatures, Resource) checkAdminFile = Right -- TODO, check that it only works for aix- checkEnsure :: (HS.HashSet PackagingFeatures, Resource) -> Either Doc (HS.HashSet PackagingFeatures, Resource)+ checkEnsure :: (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError (HS.HashSet PackagingFeatures, Resource) checkEnsure (s, res) = case res ^. rattributes . at "ensure" of Just (PString "latest") -> checkFeature s res Installable >> checkFeature s res Versionable Just (PString "purged") -> checkFeature s res Purgeable@@ -105,7 +105,7 @@ Just (PString "present") -> checkFeature s res Installable Just (PString "held") -> checkFeature s res Installable >> checkFeature s res Holdable _ -> Right (s, res)- decap :: (HS.HashSet PackagingFeatures, Resource) -> Either Doc Resource+ decap :: (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError Resource decap = Right . snd validatePackage :: PuppetTypeValidate
Puppet/NativeTypes/ZoneRecord.hs view
@@ -38,8 +38,8 @@ validateMandatories :: PuppetTypeValidate validateMandatories res = case res ^. rattributes . at "rtype" of- Nothing -> Left "The rtype parameter is mandatory."+ Nothing -> perror "The rtype parameter is mandatory." Just (PString "SOA") -> foldM (flip mandatory) res ["nsname", "email", "serial", "slave_refresh", "slave_retry", "slave_expiration", "min_ttl"] Just (PString "NS") -> foldM (flip mandatory) res ["owner", "rclass", "rtype", "dest"] Just (PString _) -> foldM (flip mandatory) res ["owner", "rclass", "rtype", "dest", "ttl"]- Just x -> Left $ "Can't use this for the rtype parameter" <+> pretty x+ Just x -> perror $ "Can't use this for the rtype parameter" <+> pretty x
Puppet/Parser.hs view
@@ -19,6 +19,7 @@ import Control.Lens hiding (noneOf) import Puppet.Parser.Types+import Puppet.Utils import Text.Parsec.Expr import Text.Parser.Token hiding (stringLiteral')@@ -31,6 +32,7 @@ import Text.Parsec.Text () import qualified Text.Parsec.Prim as PP import Text.Parsec.Text ()+import Data.Scientific newtype ParserT m a = ParserT { unParser :: m a } deriving (Functor, Applicative, Alternative)@@ -61,6 +63,9 @@ <|> (skipSome (noneOf "*/") >> inComment) <|> (oneOf "*/" >> inComment) +variable :: Parser Expression+variable = PValue . UVariableReference <$> variableReference+ stringLiteral' :: Parser T.Text stringLiteral' = char '\'' *> interior <* symbolic '\'' where@@ -147,15 +152,15 @@ many (fmap UVariableReference interpolableVariableReference <|> doubleQuotedStringContent <|> fmap (UString . T.singleton) (char '$')) where doubleQuotedStringContent = fmap (UString . T.pack . concat) $- some ((char '\\' *> anyChar >>= stringEscape) <|> some (noneOf "\"\\$"))- stringEscape :: Char -> Parser String- stringEscape 'n' = return "\n"- stringEscape 't' = return "\t"- stringEscape 'r' = return "\r"- stringEscape '"' = return "\""- stringEscape '\\' = return "\\"- stringEscape '$' = return "$"- stringEscape x = fail $ "unknown escape pattern \\" ++ [x]+ some ((char '\\' *> fmap stringEscape anyChar) <|> some (noneOf "\"\\$"))+ stringEscape :: Char -> String+ stringEscape 'n' = "\n"+ stringEscape 't' = "\t"+ stringEscape 'r' = "\r"+ stringEscape '"' = "\""+ stringEscape '\\' = "\\"+ stringEscape '$' = "$"+ stringEscape x = ['\\',x] -- this is specialized because we can't be "tokenized" here variableAccept x = isAsciiLower x || isAsciiUpper x || isDigit x || x == '_' interpolableVariableReference = do@@ -177,13 +182,6 @@ void $ symbolic '/' return $! T.pack $! concat v -variableOrHash :: Parser Expression-variableOrHash = do- varname <- variableReference <?> "Variable reference"- -- chained lookups are resolved here- hr <- many (brackets expression)- return $! foldl Lookup (PValue (UVariableReference varname)) hr- puppetArray :: Parser UValue puppetArray = fmap (UArray . V.fromList) (brackets (expression `sepEndBy` comma)) <?> "Array" @@ -240,12 +238,12 @@ (fname, args) <- genFunctionCall False return $ UFunctionCall fname args -literalValue :: Parser T.Text-literalValue = token (stringLiteral' <|> bareword <|> numericalvalue <?> "Literal Value")+literalValue :: Parser UValue+literalValue = token (fmap UString stringLiteral' <|> fmap UString bareword <|> fmap UNumber numericalvalue <?> "Literal Value") where numericalvalue = integerOrDouble >>= \case- Left x -> return (T.pack $ show x)- Right y -> return (T.pack $ show y)+ Left x -> return (fromIntegral x)+ Right y -> return (fromFloatDigits y) -- this is a hack for functions :( terminalG :: Parser Expression -> Parser Expression@@ -253,13 +251,13 @@ <|> fmap (PValue . UInterpolable) interpolableString <|> (reserved "undef" *> return (PValue UUndef)) <|> fmap PValue termRegexp- <|> variableOrHash+ <|> variable <|> fmap PValue puppetArray <|> fmap PValue puppetHash <|> fmap (PValue . UBoolean) puppetBool <|> fmap PValue resourceReference <|> g- <|> fmap (PValue . UString) literalValue+ <|> fmap PValue literalValue compileRegexp :: T.Text -> Parser Regex compileRegexp p = case compile' compBlank execBlank (T.encodeUtf8 p) of@@ -285,7 +283,7 @@ c <- (symbol "default" *> return SelectorDefault) -- default case <|> fmap SelectorValue (fmap UVariableReference variableReference <|> fmap UBoolean puppetBool- <|> fmap UString literalValue+ <|> literalValue <|> fmap UInterpolable interpolableString <|> termRegexp) void $ symbol "=>"@@ -295,8 +293,8 @@ return (ConditionalValue selectedExpression (V.fromList cases)) expressionTable :: [[Operator T.Text () Identity Expression]]-expressionTable = [ -- [ Infix ( operator "?" >> return ConditionalValue ) AssocLeft ]- [ Prefix ( operator' "-" >> return Negate ) ]+expressionTable = [ [ Postfix (chainl1 checkLookup (return (flip (.)))) ] -- http://stackoverflow.com/questions/10475337/parsec-expr-repeated-prefix-postfix-operator-not-supported+ , [ Prefix ( operator' "-" >> return Negate ) ] , [ Prefix ( operator' "!" >> return Not ) ] , [ Infix ( operator' "." >> return FunctionApplication ) AssocLeft ] , [ Infix ( reserved' "in" >> return Contains ) AssocLeft ]@@ -312,6 +310,9 @@ , [ Infix ( operator' "==" >> return Equal ) AssocLeft , Infix ( operator' "!=" >> return Different ) AssocLeft ]+ , [ Infix ( operator' "=~" >> return RegexMatch ) AssocLeft+ , Infix ( operator' "!~" >> return NotRegexMatch ) AssocLeft+ ] , [ Infix ( operator' ">=" >> return MoreEqualThan ) AssocLeft , Infix ( operator' "<=" >> return LessEqualThan ) AssocLeft , Infix ( operator' ">" >> return MoreThan ) AssocLeft@@ -320,18 +321,17 @@ , [ Infix ( reserved' "and" >> return And ) AssocLeft , Infix ( reserved' "or" >> return Or ) AssocLeft ]- , [ Infix ( operator' "=~" >> return RegexMatch ) AssocLeft- , Infix ( operator' "!~" >> return NotRegexMatch ) AssocLeft- ] ] where+ checkLookup :: OP (Expression -> Expression)+ checkLookup = flip Lookup <$> unParser (between (operator "[") (operator "]") expression) operator' :: String -> OP () operator' = unParser . operator reserved' :: String -> OP () reserved' = unParser . reserved stringExpression :: Parser Expression-stringExpression = fmap (PValue . UInterpolable) interpolableString <|> (reserved "undef" *> return (PValue UUndef)) <|> fmap (PValue . UBoolean) puppetBool <|> variableOrHash <|> fmap (PValue . UString) literalValue+stringExpression = fmap (PValue . UInterpolable) interpolableString <|> (reserved "undef" *> return (PValue UUndef)) <|> fmap (PValue . UBoolean) puppetBool <|> variable <|> fmap PValue literalValue variableAssignment :: Parser [Statement] variableAssignment = do@@ -349,7 +349,10 @@ reserved "node" let nm (URegexp nn nr) = return (NodeMatch nn nr) nm _ = fail "? can't happen, termRegexp didn't return a URegexp ?"- let nodename = (reserved "default" >> return NodeDefault) <|> fmap NodeName literalValue+ toString (UString s) = s+ toString (UNumber n) = scientific2text n+ toString _ = error "Can't happen at nodeStmt"+ nodename = (reserved "default" >> return NodeDefault) <|> fmap (NodeName . toString) literalValue ns <- ((termRegexp >>= nm) <|> nodename) `sepBy1` comma inheritance <- option S.Nothing (fmap S.Just (reserved "inherits" *> nodename)) st <- braces statementList
Puppet/Parser/PrettyPrinter.hs view
@@ -2,8 +2,8 @@ module Puppet.Parser.PrettyPrinter where import Puppet.PP-import Data.Monoid import Puppet.Parser.Types+import Puppet.Utils import qualified Data.Vector as V import qualified Data.Text as T import Data.Tuple.Strict (Pair ( (:!:) ))@@ -83,6 +83,7 @@ pretty (UBoolean True) = dullmagenta $ text "true" pretty (UBoolean False) = dullmagenta $ text "false" pretty (UString s) = char '"' <> dullcyan (ttext (stringEscape s)) <> char '"'+ pretty (UNumber n) = cyan (ttext (scientific2text n)) pretty (UInterpolable v) = char '"' <> hcat (map specific (V.toList v)) <> char '"' where specific (UString s) = dullcyan (ttext (stringEscape s))
Puppet/Parser/Types.hs view
@@ -41,6 +41,8 @@ import Data.Char (toUpper) import Text.Regex.PCRE.String import Control.Lens+import Data.String+import Data.Scientific import Text.Parsec.Pos @@ -115,7 +117,11 @@ | UVariableReference !T.Text | UFunctionCall !T.Text !(V.Vector Expression) | UHFunctionCall !HFunctionCall+ | UNumber Scientific +instance IsString UValue where+ fromString = UString . T.pack+ -- The Eq instance is manual, because of the 'Regex' comparison problem instance Eq UValue where (==) (UBoolean a) (UBoolean b) = a == b@@ -128,6 +134,7 @@ (==) (URegexp a _) (URegexp b _) = a == b (==) (UVariableReference a) (UVariableReference b) = a == b (==) (UFunctionCall a1 a2) (UFunctionCall b1 b2) = (a1 == b1) && (a2 == b2)+ (==) (UNumber a) (UNumber b) = a == b (==) _ _ = False -- | A helper function for writing 'array's.@@ -164,7 +171,25 @@ | ConditionalValue !Expression !(V.Vector (Pair SelectorCase Expression)) -- ^ All conditionals are stored in this format. | FunctionApplication !Expression !Expression -- ^ This is for /higher order functions/. | PValue !UValue- deriving (Eq)+ deriving Eq++instance Num Expression where+ (+) = Addition+ (-) = Substraction+ (*) = Multiplication+ fromInteger = PValue . UNumber . fromInteger+ abs x = ConditionalValue (MoreEqualThan x 0) (V.fromList [SelectorValue (UBoolean True) :!: x, SelectorDefault :!: negate x])+ signum x = ConditionalValue (MoreThan x 0) (V.fromList [SelectorValue (UBoolean True) :!: 1, SelectorDefault :!:+ ConditionalValue (Equal x 0) (V.fromList [SelectorValue (UBoolean True) :!: 0, SelectorDefault :!: (-1)])+ ])++instance Fractional Expression where+ (/) = Division+ recip x = 1 / x+ fromRational = PValue . UNumber . fromRational++instance IsString Expression where+ fromString = PValue . fromString data SearchExpression = EqualitySearch !T.Text !Expression
Puppet/Plugins.hs view
@@ -41,6 +41,7 @@ import Control.Concurrent import Control.Monad.Error import Control.Monad.Operational (singleton)+import Data.Scientific import Puppet.Interpreter.Types import Puppet.Utils@@ -53,12 +54,13 @@ push l (PArray arr) = Lua.push l (V.toList arr) push l (PHash m) = Lua.push l (Map.fromList $ HM.toList m) push l (PUndef) = Lua.push l ("undefined" :: T.Text)+ push l (PNumber b) = Lua.push l (fromRational (toRational b) :: Double) peek l n = do Lua.ltype l n >>= \case Lua.TBOOLEAN -> fmap (fmap PBoolean) (Lua.peek l n) Lua.TSTRING -> fmap (fmap PString) (Lua.peek l n)- Lua.TNUMBER -> fmap (fmap (PString . tshow)) (Lua.peek l n :: IO (Maybe Double))+ Lua.TNUMBER -> fmap (fmap (PNumber . fromFloatDigits)) (Lua.peek l n :: IO (Maybe Double)) Lua.TNIL -> return (Just PUndef) Lua.TNONE -> return (Just PUndef) Lua.TTABLE -> fmap (fmap (PArray . V.fromList)) (Lua.peek l n)
Puppet/Stdlib.hs view
@@ -40,11 +40,14 @@ , singleArgument "is_array" isArray , singleArgument "is_domain_name" isDomainName , singleArgument "is_integer" isInteger+ , singleArgument "is_hash" isHash , singleArgument "is_string" isString , singleArgument "keys" keys+ , ("has_key", hasKey) , ("lstrip", stringArrayFunction T.stripStart) , ("merge", merge) , ("rstrip", stringArrayFunction T.stripEnd)+ , singleArgument "size" size , singleArgument "str2bool" str2Bool , ("strip", stringArrayFunction T.strip) , ("upcase", stringArrayFunction T.toUpper)@@ -54,6 +57,7 @@ , ("validate_hash", validateHash) , ("validate_re", validateRe) , ("validate_string", validateString)+ , singleArgument "values" pvalues ] singleArgument :: T.Text -> (PValue -> InterpreterMonad PValue) -> (T.Text, [PValue] -> InterpreterMonad PValue )@@ -204,6 +208,9 @@ isInteger :: PValue -> InterpreterMonad PValue isInteger = return . PBoolean . has _Integer +isHash :: PValue -> InterpreterMonad PValue+isHash = return . PBoolean . has _PHash+ isString :: PValue -> InterpreterMonad PValue isString pv = return $ PBoolean $ case (pv ^? _PString, pv ^? _Number) of (_, Just _) -> False@@ -214,11 +221,23 @@ keys (PHash h) = return (PArray $ V.fromList $ map PString $ HM.keys h) keys x = throwPosError ("keys(): Expects a Hash, not" <+> pretty x) +hasKey :: [PValue] -> InterpreterMonad PValue+hasKey [PHash h, k] = do+ k' <- resolvePValueString k+ return (PBoolean (has (ix k') h))+hasKey [a, _] = throwPosError ("has_key(): expected a Hash, not" <+> pretty a)+hasKey _ = throwPosError ("has_key(): expected two arguments.")+ merge :: [PValue] -> InterpreterMonad PValue merge [PHash a, PHash b] = return (PHash (b `HM.union` a)) merge [a,b] = throwPosError ("merge(): Expects two hashes, not" <+> pretty a <+> pretty b) merge _ = throwPosError "merge(): Expects two hashes" +size :: PValue -> InterpreterMonad PValue+size (PHash h) = return (_Integer # fromIntegral (HM.size h))+size (PArray v) = return (_Integer # fromIntegral (V.length v))+size x = throwPosError ("size(): Expects a hash, not" <+> pretty x)+ str2Bool :: PValue -> InterpreterMonad PValue str2Bool PUndef = return (PBoolean False) str2Bool a@(PBoolean _) = return a@@ -274,3 +293,7 @@ validateString :: [PValue] -> InterpreterMonad PValue validateString [] = throwPosError "validate_string(): wrong number of arguments, must be > 0" validateString x = mapM_ resolvePValueString x >> return PUndef++pvalues :: PValue -> InterpreterMonad PValue+pvalues (PHash h) = return $ PArray (V.fromList (h ^.. traverse))+pvalues x = throwPosError ("values(): expected a hash, not" <+> pretty x)
Puppet/Testing.hs view
@@ -7,6 +7,7 @@ , module Puppet.Lens , H.hspec , basicTest+ , usersGroupsDefined , testingDaemon , defaultDaemon , testCatalog@@ -25,13 +26,14 @@ import Prelude hiding (notElem,all) import Control.Lens-import Data.Foldable hiding (forM_)+import Data.Foldable hiding (forM_,mapM_) import Data.Maybe import Data.Monoid import Control.Monad.Error import Control.Monad.Reader import Control.Applicative import System.Posix.Files+import qualified Data.HashSet as HS import qualified Data.Either.Strict as S import qualified Data.Text as T import qualified System.Log.Logger as LOG@@ -79,6 +81,37 @@ basicTest :: PSpec basicTest = hTestFileSources +-- | This tests that all users and groups used as resource parameters are+-- defined+usersGroupsDefined :: PSpec+usersGroupsDefined = do+ c <- view lCatalog+ let getResourceType t = c ^.. traverse . filtered (\r -> r ^. rid . itype == t && r ^. rattributes . at "ensure" /= Just "absent")+ users = getResourceType "user"+ groups = getResourceType "group"+ knownUsers = HS.fromList $ map (view (rid . iname)) users ++ ["root","","syslog","mysql","puppet"]+ knownGroups = HS.fromList $ map (view (rid . iname)) groups ++ ["root", "adm", "syslog", "mysql", "nagios","puppet",""]+ checkResource lensU lensG = mapM_ (checkResource' lensU lensG)+ checkResource' lensU lensG res = do+ let d = "Resource " <> show (pretty res) <> " should have a valid "+ case lensU of+ Just lensU' -> do+ let u = res ^. rattributes . lensU' . _PString+ H.it (d <> "username (" ++ T.unpack u ++ ")") (HS.member u knownUsers)+ Nothing -> return ()+ case lensG of+ Just lensG' -> do+ let g = res ^. rattributes . lensG' . _PString+ H.it (d <> "group (" ++ T.unpack g ++ ")") (HS.member g knownGroups)+ Nothing -> return ()+ lift $ do+ checkResource (Just $ ix "owner") (Just $ ix "group") (getResourceType "file")+ checkResource (Just $ ix "user") (Just $ ix "group") (getResourceType "exec")+ checkResource (Just $ ix "user") Nothing (getResourceType "cron")+ checkResource (Just $ ix "user") Nothing (getResourceType "ssh_authorized_key")+ checkResource (Just $ ix "user") Nothing (getResourceType "ssh_authorized_key_secure")+ checkResource (Nothing) (Just $ ix "gid") users+ it :: HC.Example a => String -> PSpecM a -> PSpec it n tst = tst >>= lift . H.it n @@ -118,7 +151,7 @@ withFileContent desc fn action = withResource desc "file" fn $ \r -> case r ^? rattributes . ix "content" . _PString of Just v -> action v- Nothing -> H.expectationFailure "Contentnot found"+ Nothing -> H.expectationFailure "Content not found" hTestFileSources :: PSpec hTestFileSources = do@@ -132,32 +165,32 @@ pdir <- view lPuppetdir forM_ files $ \(r,filesource) -> it ("should have a source for " ++ r ^. rid . iname . to T.unpack) $ do let- testFile :: FilePath -> ErrorT Doc IO ()- testFile fp = liftIO (fileExist fp) >>= (`unless` (throwError $ "Searched in" <+> string fp))- checkFile :: PValue -> ErrorT Doc IO ()- checkFile res@(PArray ar) = asum [checkFile x | x <- toList ar] <|> throwError ("Could not find the file in" <+> pretty res)- checkFile (PString f) = do- stringdir <- case T.stripPrefix "puppet:///" f of- Just o -> return o- Nothing -> throwError ("The source does not start with puppet:///, but is" <+> ttext f)- case T.splitOn "/" stringdir of- ("modules":modulename:rest) -> testFile (pdir <> "/modules/" <> T.unpack modulename <> "/files/" <> T.unpack (T.intercalate "/" rest))- ("files":rest) -> testFile (pdir <> "/files/" <> T.unpack (T.intercalate "/" rest))- ("private":_) -> return ()- _ -> throwError ("Invalid file source:" <+> ttext f)- checkFile x = throwError ("Source was not a string, but" <+> pretty x)+ testFile :: FilePath -> ErrorT PrettyError IO ()+ testFile fp = liftIO (fileExist fp) >>= (`unless` (throwError $ PrettyError $ "Searched in" <+> string fp))+ checkFile :: PValue -> ErrorT PrettyError IO ()+ checkFile res@(PArray ar) = asum [checkFile x | x <- toList ar] <|> throwError (PrettyError $ "Could not find the file in" <+> pretty res)+ checkFile (PString f) =+ case (T.stripPrefix "puppet:///" f, T.stripPrefix "file:///" f) of+ (Just stringdir, _) -> case T.splitOn "/" stringdir of+ ("modules":modulename:rest) -> testFile (pdir <> "/modules/" <> T.unpack modulename <> "/files/" <> T.unpack (T.intercalate "/" rest))+ ("files":rest) -> testFile (pdir <> "/files/" <> T.unpack (T.intercalate "/" rest))+ ("private":_) -> return ()+ _ -> throwError (PrettyError $ "Invalid file source:" <+> ttext f)+ (Nothing, Just _) -> return ()+ _ -> throwError (PrettyError $ "The source does not start with puppet:///, but is" <+> ttext f)+ checkFile x = throwError (PrettyError $ "Source was not a string, but" <+> pretty x) return $ do rs <- runErrorT (checkFile filesource) case rs of Right () -> return ()- Left rr -> fail (show rr)+ Left rr -> fail (show (getError rr)) -- | Initializes a daemon made for running tests, using the specific test -- puppetDB testingDaemon :: PuppetDBAPI IO -- ^ Contains the puppetdb API functions -> FilePath -- ^ Path to the manifests- -> (T.Text -> IO (Container T.Text)) -- ^ The facter function- -> IO (T.Text -> IO (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog, [Resource])))+ -> (T.Text -> IO Facts) -- ^ The facter function+ -> IO (T.Text -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))) testingDaemon pdb pdir allFacts = do LOG.updateGlobalLogger "Puppet.Daemon" (LOG.setLevel LOG.WARNING) prefs <- genPreferences pdir@@ -165,10 +198,10 @@ return (\nodname -> allFacts nodname >>= _dGetCatalog q nodname) -- | A default testing daemon.-defaultDaemon :: FilePath -> IO (T.Text -> IO (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog, [Resource])))+defaultDaemon :: FilePath -> IO (T.Text -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))) defaultDaemon pdir = do pdb <- getDefaultDB PDBTest >>= \case- S.Left x -> error (show x)+ S.Left x -> error (show (getError x)) S.Right y -> return y testingDaemon pdb pdir (flip puppetDBFacts pdb)
Puppet/Utils.hs view
@@ -1,12 +1,14 @@+-- | Those are utility functions, most of them being pretty much self+-- explanatory. module Puppet.Utils- ( puppet2number- , textElem+ ( textElem , module Data.Monoid , getDirectoryContents , takeBaseName , takeDirectory , strictifyEither , nameThread+ , scientific2text ) where import qualified Data.Text as T@@ -17,17 +19,18 @@ import qualified Data.Either.Strict as S import Control.Concurrent (myThreadId) import GHC.Conc (labelThread)+import Data.Scientific+import Control.Lens+import Data.Aeson.Lens -import Data.Attoparsec.Number-import Puppet.Interpreter.Types+scientific2text :: Scientific -> T.Text+scientific2text n = T.pack $ case n ^? _Integer of+ Just i -> show i+ _ -> show n strictifyEither :: Either a b -> S.Either a b strictifyEither (Left x) = S.Left x strictifyEither (Right x) = S.Right x--puppet2number :: PValue -> Maybe Number-puppet2number (PString s) = text2Number s-puppet2number _ = Nothing textElem :: Char -> T.Text -> Bool textElem c = T.any (==c)
PuppetDB/Common.hs view
@@ -2,7 +2,6 @@ -- | Common data types for PuppetDB. module PuppetDB.Common where -import Puppet.PP import Puppet.Interpreter.Types import PuppetDB.Remote import PuppetDB.Dummy@@ -38,7 +37,7 @@ tsts = stripPrefix "test" r -- | Given a 'PDBType', will try return a sane default implementation.-getDefaultDB :: PDBType -> IO (S.Either Doc (PuppetDBAPI IO))+getDefaultDB :: PDBType -> IO (S.Either PrettyError (PuppetDBAPI IO)) getDefaultDB PDBDummy = return (S.Right dummyPuppetDB) getDefaultDB PDBRemote = pdbConnect "http://localhost:8080" getDefaultDB PDBTest = lookupEnv "HOME" >>= \case
PuppetDB/Remote.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-} module PuppetDB.Remote (pdbConnect) where import Puppet.Utils@@ -18,19 +19,20 @@ import qualified Data.Text.Encoding as T import qualified Data.Either.Strict as S +runRequest :: (Monad m, MonadIO m, FromJSON b, MonadError PrettyError m) => Request -> m b runRequest req = do let doRequest = withManager (fmap responseBody . httpLbs req) :: IO L.ByteString- eHandler :: X.SomeException -> IO (Either Doc L.ByteString)- eHandler e = return $ Left $ string (show e) <> ", with queryString " <+> string (BC.unpack (queryString req))+ eHandler :: X.SomeException -> IO (Either PrettyError L.ByteString)+ eHandler e = return $ Left $ PrettyError $ string (show e) <> ", with queryString " <+> string (BC.unpack (queryString req)) liftIO (fmap Right doRequest `X.catch` eHandler) >>= \case Right o -> do let utf8 = IConv.convert "LATIN1" "UTF-8" o case decode' utf8 of Just x -> return x- Nothing -> throwError ("Json decoding has failed " <> string (show utf8))+ Nothing -> throwError (PrettyError ("Json decoding has failed " <> string (show utf8))) Left err -> throwError err -pdbRequest :: (FromJSON a, ToJSON b) => T.Text -> T.Text -> b -> IO (S.Either Doc a)+pdbRequest :: (FromJSON a, ToJSON b) => T.Text -> T.Text -> b -> IO (S.Either PrettyError a) pdbRequest url querytype query = fmap strictifyEither $ runErrorT $ do let jsonquery = L.toStrict (encode query) q = case toJSON query of@@ -39,12 +41,12 @@ let fullurl = url <> "/v3/" <> querytype <> q initReq <- case parseUrl (T.unpack fullurl) of Right r -> return (r :: Request)- Left rr -> throwError ("Something failed when parsing the PuppetDB URL" <+> string (show (rr :: HttpException)))+ Left rr -> throwError (PrettyError ("Something failed when parsing the PuppetDB URL" <+> string (show rr))) let req = initReq { requestHeaders = [("Accept", "application/json")] } runRequest req -- | Given an URL (ie. @http://localhost:8080@), will return an incomplete 'PuppetDBAPI'.-pdbConnect :: T.Text -> IO (S.Either Doc (PuppetDBAPI IO))+pdbConnect :: T.Text -> IO (S.Either PrettyError (PuppetDBAPI IO)) pdbConnect url = return $ S.Right $ PuppetDBAPI (return (ttext url)) (const (return (S.Left "operation not supported")))
PuppetDB/TestDB.hs view
@@ -32,23 +32,17 @@ type DB = TVar DBContent instance FromJSON DBContent where- parseJSON (Object v) = do- let toText :: Value -> Parser T.Text- toText (String m) = pure m- toText (Number n) = pure (T.pack (show n))- toText x = fail ("Could not convert " ++ show x ++ " to a string when parsing facts")- fcts <- v .: "facts" >>= traverse (traverse toText)- DBContent <$> v .: "resources" <*> pure fcts <*> pure Nothing+ parseJSON (Object v) = DBContent <$> v .: "resources" <*> v .: "facts" <*> pure Nothing parseJSON _ = mempty instance ToJSON DBContent where toJSON (DBContent r f _) = object [("resources", toJSON r), ("facts", toJSON f)] -- | Initializes the test DB using a file to back its content-loadTestDB :: FilePath -> IO (S.Either Doc (PuppetDBAPI IO))+loadTestDB :: FilePath -> IO (S.Either PrettyError (PuppetDBAPI IO)) loadTestDB fp = decodeFileEither fp >>= \case- Left (OtherParseException rr) -> return (S.Left (string (show rr)))+ Left (OtherParseException rr) -> return (S.Left (PrettyError (string (show rr)))) Left (InvalidYaml Nothing) -> baseError "Unknown error" Left (InvalidYaml (Just (YamlException s))) -> if take 21 s == "Yaml file not found: " then newFile@@ -57,7 +51,7 @@ Left _ -> newFile Right x -> fmap S.Right (genDBAPI (x & backingFile ?~ fp )) where- baseError r = return $ S.Left $ "Could not parse" <+> string fp <> ":" <+> r+ baseError r = return $ S.Left $ PrettyError $ "Could not parse" <+> string fp <> ":" <+> r newFile = S.Right <$> genDBAPI (newDB & backingFile ?~ fp ) -- | Starts a new PuppetDB, without any backing file.@@ -114,21 +108,21 @@ _ -> False _ -> False -mustWork :: IO () -> IO (S.Either Doc ())+mustWork :: IO () -> IO (S.Either PrettyError ()) mustWork a = a >> return (S.Right ()) -replCat :: DB -> WireCatalog -> IO (S.Either Doc ())+replCat :: DB -> WireCatalog -> IO (S.Either PrettyError ()) replCat db wc = mustWork $ atomically $ modifyTVar db (resources . at (wc ^. nodename) ?~ wc) -replFacts :: DB -> [(Nodename, Facts)] -> IO (S.Either Doc ())+replFacts :: DB -> [(Nodename, Facts)] -> IO (S.Either PrettyError ()) replFacts db lst = mustWork $ atomically $ modifyTVar db $ facts %~ (\r -> foldl' (\curr (n,f) -> curr & at n ?~ f) r lst) -deactivate :: DB -> Nodename -> IO (S.Either Doc ())+deactivate :: DB -> Nodename -> IO (S.Either PrettyError ()) deactivate db n = mustWork $ atomically $ modifyTVar db $ (resources . at n .~ Nothing) . (facts . at n .~ Nothing) -getFcts :: DB -> Query FactField -> IO (S.Either Doc [PFactInfo])+getFcts :: DB -> Query FactField -> IO (S.Either PrettyError [PFactInfo]) getFcts db f = fmap (S.Right . filter (resolveQuery factQuery f) . toFactInfo) (readTVarIO db) where toFactInfo :: DBContent -> [PFactInfo]@@ -142,7 +136,7 @@ where l = case t of FName -> factname- FValue -> factval+ FValue -> factval . _PString FCertname -> nodename resourceQuery :: ResourceField -> Resource -> Extracted@@ -159,25 +153,25 @@ resourceQuery RFile r = r ^. rpos . _1 . to sourceName . to T.pack . to EText resourceQuery RLine r = r ^. rpos . _1 . to sourceLine . to show . to T.pack . to EText -getRes :: DB -> Query ResourceField -> IO (S.Either Doc [Resource])+getRes :: DB -> Query ResourceField -> IO (S.Either PrettyError [Resource]) getRes db f = fmap (S.Right . filter (resolveQuery resourceQuery f) . toResources) (readTVarIO db) where toResources :: DBContent -> [Resource] toResources = concatMap (V.toList . view wResources) . HM.elems . view resources -getResNode :: DB -> Nodename -> Query ResourceField -> IO (S.Either Doc [Resource])+getResNode :: DB -> Nodename -> Query ResourceField -> IO (S.Either PrettyError [Resource]) getResNode db nn f = do c <- readTVarIO db return $ case c ^. resources . at nn of Just cnt -> S.Right $ filter (resolveQuery resourceQuery f) $ V.toList $ cnt ^. wResources Nothing -> S.Left "Unknown node" -commit :: DB -> IO (S.Either Doc ())+commit :: DB -> IO (S.Either PrettyError ()) commit db = do dbc <- atomically $ readTVar db case dbc ^. backingFile of Nothing -> return (S.Left "No backing file defined") Just bf -> fmap S.Right (encodeFile bf dbc) `catches` [ ] -getNds :: DB -> Query NodeField -> IO (S.Either Doc [PNodeInfo])+getNds :: DB -> Query NodeField -> IO (S.Either PrettyError [PNodeInfo]) getNds _ _ = return (S.Left "getNds not implemented")
language-puppet.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet-version: 0.12.3+version: 0.13.0 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/@@ -55,6 +55,7 @@ , Erb.Evaluate , Puppet.Lens , Puppet.Interpreter.IO+ , Puppet.Interpreter.Pure other-modules: Puppet.Utils , Puppet.NativeTypes.File , Erb.Compute@@ -90,7 +91,7 @@ , parsec == 3.1.* , mtl == 2.1.* , lens >= 4 && < 5- , parsers >= 0.10.3 && < 0.11+ , parsers == 0.11.* , ansi-wl-pprint == 0.6.* , unix >= 2.6 && < 2.8 , aeson == 0.7.*@@ -105,20 +106,27 @@ , process >= 1.1 && < 1.3 , iconv == 0.4.* , http-types == 0.8.*- , http-conduit >= 2.0 && < 2.1+ , http-conduit >= 2.1 && < 2.2 , attoparsec == 0.11.*- , case-insensitive == 1.1.*+ , case-insensitive == 1.2.* , cryptohash >= 0.10 && < 0.12 , base16-bytestring == 0.1.* , containers == 0.5.* , stm == 2.4.*- , hspec >= 1.7.0 && < 1.9.0- , yaml >= 0.8.0 && < 0.9+ , hspec >= 1.9.0 && < 2.0.0+ , yaml >= 0.8.8 && < 0.9 , stateWriter >= 0.2.1 && < 0.3 , split == 0.2.* , scientific == 0.2.* , operational +Test-Suite test-evals+ hs-source-dirs: tests+ type: exitcode-stdio-1.0+ ghc-options: -Wall -rtsopts -threaded+ extensions: OverloadedStrings+ build-depends: language-puppet,base,text,lens,parsers+ main-is: evals.hs Test-Suite test-lexer hs-source-dirs: tests type: exitcode-stdio-1.0@@ -160,7 +168,7 @@ extensions: BangPatterns, OverloadedStrings ghc-options: -Wall -rtsopts -threaded -with-rtsopts "-A2M" -eventlog ghc-prof-options: -auto-all -caf-all -fprof-auto- build-depends: language-puppet,base,text,parsec,vector,ansi-wl-pprint,bytestring,mtl,hslogger,Diff,unordered-containers,strict-base-types,optparse-applicative,regex-pcre-builtin,lens,aeson,yaml,parallel-io,containers,Glob,hspec+ build-depends: language-puppet,base,text,parsec,vector,ansi-wl-pprint,bytestring,mtl,hslogger,Diff,unordered-containers,strict-base-types,optparse-applicative==0.8.*,regex-pcre-builtin,lens,aeson,yaml,parallel-io,containers,Glob,hspec >= 1.9 main-is: PuppetResources.hs executable pdbquery
progs/PuppetResources.hs view
@@ -114,6 +114,7 @@ import qualified Data.Vector as V import qualified Data.Either.Strict as S import Options.Applicative as O hiding ((&))+import Options.Applicative.Help.Chunk (stringChunk,Chunk(..)) import Control.Monad import Text.Regex.PCRE.String import Data.Text.Strict.Lens@@ -149,10 +150,10 @@ tshow :: Show a => a -> T.Text tshow = T.pack . show -type QueryFunc = T.Text -> IO (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog, [Resource]))+type QueryFunc = T.Text -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) -checkErrorStrict :: S.Either Doc x -> IO x-checkErrorStrict (S.Left rr) = putDoc rr >> putStrLn "" >> error "error!"+checkErrorStrict :: S.Either PrettyError x -> IO x+checkErrorStrict (S.Left rr) = putDoc (getError rr) >> putStrLn "" >> error "error!" checkErrorStrict (S.Right x) = return x {-| Does all the work of initializing a daemon for querying.@@ -289,14 +290,7 @@ loadFactsOverrides :: FilePath -> IO Facts loadFactsOverrides fp = decodeFileEither fp >>= \case Left rr -> error ("Error when parsing " ++ fp ++ ": " ++ show rr)- Right x -> case traverse tv x of- Just y -> return y- Nothing -> error ("Error when parsing " ++ fp ++ ": some of the values were not strings")- where- tv x = x ^? _PString <|> isBool x- isBool (PBoolean True) = Just "true"- isBool (PBoolean False) = Just "false"- isBool _ = Nothing+ Right x -> return x -- this finds the dead code findDeadCode :: String -> [Resource] -> Set.Set FilePath -> IO ()@@ -347,7 +341,7 @@ Left rr -> error ("parse error:" ++ show rr) Right s -> putDoc (vcat (map pretty (V.toList s))) run c@(CommandLine puppeturl _ _ _ _ puppetdir (Just ndename) mpdbf prio hpath fcts fdef docommit _) = do- let checkError r (S.Left rr) = error (show (red r <> ":" <+> rr))+ let checkError r (S.Left rr) = error (show (red r <> ":" <+> getError rr)) checkError _ (S.Right x) = return x tnodename = T.pack ndename pdbapi <- case (puppeturl, mpdbf) of@@ -420,8 +414,8 @@ computeCatalogs testOnly queryfunc pdbapi printFunc (CommandLine _ showjson showcontent mrt mrn puppetdir _ _ _ _ _ _ _ checkExported) tnodename = queryfunc tnodename >>= \case S.Left rr -> do if testOnly- then putDoc ("Problem with" <+> ttext tnodename <+> ":" <+> rr </> mempty)- else putDoc rr >> putStrLn "" >> error "error!"+ then putDoc ("Problem with" <+> ttext tnodename <+> ":" <+> getError rr </> mempty)+ else putDoc (getError rr) >> putStrLn "" >> error "error!" return (Nothing, Just (H.Summary 1 1)) S.Right (rawcatalog,m,rawexported,knownRes) -> do let wireCatalog = generateWireCatalog tnodename (rawcatalog <> rawexported) m@@ -448,7 +442,7 @@ _ -> do catalog <- filterCatalog rawcatalog exported <- filterCatalog rawexported- r <- testCatalog tnodename puppetdir rawcatalog basicTest+ r <- testCatalog tnodename puppetdir rawcatalog (basicTest >> usersGroupsDefined) printFunc (pretty (HM.elems catalog)) unless (HM.null exported) $ do printFunc (mempty <+> dullyellow "Exported:" <+> mempty)@@ -460,4 +454,9 @@ main = execParser pinfo >>= run where pinfo :: ParserInfo CommandLine- pinfo = ParserInfo (helper <*> cmdlineParser) True "A useful program for parsing puppet files, generating and inspecting catalogs" "puppetresources - a useful utility for dealing with Puppet" "" 3+ pinfo = ParserInfo (helper <*> cmdlineParser)+ True+ (stringChunk "A useful program for parsing puppet files, generating and inspecting catalogs")+ (stringChunk "puppetresources - a useful utility for dealing with Puppet")+ (Chunk Nothing)+ 3 True
progs/pdbQuery.hs view
@@ -8,6 +8,7 @@ import Facter import Options.Applicative as O hiding ((&))+import Options.Applicative.Help.Chunk (stringChunk,Chunk(..)) import qualified Data.Text as T import Data.Monoid import Data.Yaml hiding (Parser)@@ -59,13 +60,14 @@ <> value PDBTest <> help "PuppetDB types : test, remote, dummy" )- cmd = subparser ( command "dumpfacts" (ParserInfo (pure DumpFacts) True "Dump all facts" "Dump all facts, and store them in /tmp/allfacts.yaml" "" 4)- <> command "editfact" (ParserInfo factedit True "Edit a fact corresponding to a node" "" "" 7)- <> command "dumpres" (ParserInfo resourcesparser True "Dump resources" "Dump resources" "" 5)- <> command "delnode" (ParserInfo delnodeparser True "Deactivate node" "Deactivate node" "" 6)- <> command "nodes" (ParserInfo (pure DumpNodes) True "Dump all nodes" "Dump all nodes" "" 8)- <> command "snapshot" (ParserInfo createtestdb True "Create a test DB from the current DB" "" "" 10)- <> command "addfacts" (ParserInfo addfacts True "Adds facts to the test DB for the given node name, if they are not already defined" "" "" 11)+ ec = Chunk Nothing+ cmd = subparser ( command "dumpfacts" (ParserInfo (pure DumpFacts) True (stringChunk "Dump all facts") (stringChunk "Dump all facts, and store them in /tmp/allfacts.yaml") ec 4 True)+ <> command "editfact" (ParserInfo factedit True (stringChunk "Edit a fact corresponding to a node") ec ec 7 True)+ <> command "dumpres" (ParserInfo resourcesparser True (stringChunk "Dump resources") (stringChunk "Dump resources") ec 5 True)+ <> command "delnode" (ParserInfo delnodeparser True (stringChunk "Deactivate node")(stringChunk "Deactivate node") ec 6 True)+ <> command "nodes" (ParserInfo (pure DumpNodes) True (stringChunk "Dump all nodes") (stringChunk "Dump all nodes") ec 8 True)+ <> command "snapshot" (ParserInfo createtestdb True (stringChunk "Create a test DB from the current DB") ec ec 10 True)+ <> command "addfacts" (ParserInfo addfacts True (stringChunk "Adds facts to the test DB for the given node name, if they are not already defined") ec ec 11 True) ) display :: (Show r, ToJSON a) => String -> S.Either r a -> IO ()@@ -83,7 +85,7 @@ (Just l, PDBTest) -> loadTestDB l (_, x) -> getDefaultDB x pdbapi <- case epdbapi of- S.Left r -> error (show r)+ S.Left r -> error (show (getError r)) S.Right x -> return x let getOrError s (S.Left rr) = error (s <> " " <> show rr) getOrError _ (S.Right x) = return x@@ -122,4 +124,4 @@ main = execParser pinfo >>= run where pinfo :: ParserInfo CommandLine- pinfo = ParserInfo (helper <*> cmdlineParser) True "A program to work with PuppetDB implementations" "pdbQuery - work with PuppetDB implementations" "" 3+ pinfo = ParserInfo (helper <*> cmdlineParser) True (stringChunk "A program to work with PuppetDB implementations") (stringChunk "pdbQuery - work with PuppetDB implementations") (Chunk Nothing) 3 True
ruby/hrubyerb.rb view
@@ -35,6 +35,10 @@ true end end++ def to_hash+ vl('~g~e~t_h~a~s~h~')+ end end class ErbBinding
+ tests/evals.hs view
@@ -0,0 +1,34 @@+module Main where++import qualified Data.Text as T+import Puppet.PP+import Puppet.Parser+import Puppet.Interpreter.Pure+import Puppet.Interpreter.Types+import Puppet.Interpreter.Resolve++import Control.Applicative+import Text.Parser.Combinators (eof)+import Data.Either (lefts)++pureTests :: [T.Text]+pureTests = [ "4 + 2 == 6"+ , "[1,2][1] == 2"+ , "[1,[1,2]][1][0] == 1"+ , "[1,2,3] + [4,5,6] == [1,2,3,4,5,6]"+ , "{a => 1} + {b => 2} == {a=>1, b=>2 }"+ , "[1,2,3] << 10 == [1,2,3,10]"+ , "[1,2,3] << [4,5] == [1,2,3,[4,5]]"+ , "4 / 3.0 == 0.75"+ ]++main :: IO ()+main = do+ let check :: T.Text -> Either String ()+ check t = case runMyParser (expression <* eof) "dummy" t of+ Left rr -> Left (T.unpack t ++ " -> " ++ show rr)+ Right e -> case dummyEval (resolveExpression e) of+ Right (PBoolean True) -> Right ()+ Right x -> Left (T.unpack t ++ " -> " ++ show (pretty x))+ Left rr -> Left (T.unpack t ++ " -> " ++ show rr)+ mapM_ putStrLn (lefts $ map check pureTests)
tests/expr.hs view
@@ -14,17 +14,15 @@ testcases :: [(T.Text, Expression)] testcases =- [ ("5 + 3 * 2", Addition (PValue $ UString "5") (Multiplication (PValue $ UString "3") (PValue $ UString "2")) )- , ("5+2 == 7", Equal ( Addition (PValue $ UString "5") (PValue $ UString "2") ) (PValue $ UString "7") )- , ("include foo::bar", PValue (UFunctionCall "include" (V.fromList [PValue (UString "foo::bar")])) )+ [ ("5 + 3 * 2", 5 + 3 * 2)+ , ("5+2 == 7", Equal (5 + 2) 7)+ , ("include(foo::bar)", PValue (UFunctionCall "include" (V.singleton "foo::bar") )) ] main :: IO () main = do- testres <- forM testcases $ \(a,b) -> do- na <- runMyParser (expression <* eof) "tests" a- return (na, b)- let isFailure (Left x, _) = Just (show x)+ let testres = map (\(a,b) -> (runMyParser (expression <* eof) "tests" a, b)) testcases+ isFailure (Left x, _) = Just (show x) isFailure (Right x, e) = if x == e then Nothing else Just (displayS (renderPretty 0.4 80 (pretty x)) "" ++ "\n" ++ displayS (renderPretty 0.4 80 (pretty e)) "")
tests/hiera.hs view
@@ -12,48 +12,45 @@ import qualified Data.HashMap.Strict as HM import qualified Data.Text as T -import Puppet.Parser.Types import Puppet.Interpreter.Types main :: IO () main = withSystemTempDirectory "hieratest" $ \tmpfp -> do let ndname = "node.site.com"- newscope = HM.singleton "::" (ScopeInformation vars mempty mempty (CurContainer ContRoot mempty) mempty S.Nothing)- vars = HM.fromList [ ("environment", ("production" :!: initialPPos "dummy" :!: ContRoot))- , ("fqdn" , (PString ndname :!: initialPPos "dummy" :!: ContRoot))+ vars = HM.fromList [ ("::environment", "production")+ , ("::fqdn" , ndname) ] writeFile (tmpfp ++ "/hiera.yaml") $ "---\n:backends:\n - \"yaml\"\n - \"json\"\n:logger: \"console\"\n:hierarchy:\n - \"%{::fqdn}\"\n - \"%{::environment}\"\n - \"global\"\n\n:yaml:\n :datadir: " ++ show tmpfp ++ "\n:json:\n :datadir: " ++ show tmpfp ++ "\n" writeFile (tmpfp ++ "/global.yaml") "---\nhttp_port: 8080\nntp_servers: ['0.ntp.puppetlabs.com', '1.ntp.puppetlabs.com']\nusers:\n pete:\n uid: 2000\n tom:\n uid: 2001\nglobal: \"glob\"" writeFile (tmpfp ++ "/production.yaml") "---\nhttp_port: 9090\nntp_servers: ['2.ntp.puppetlabs.com', '3.ntp.puppetlabs.com']\ninterp1: '**%{::fqdn}**'\nusers:\n bob:\n uid: 100\n tom:\n uid: 12\n" writeFile (tmpfp ++ "/" ++ T.unpack ndname ++ ".json") "{\"testnode\":{\"1\":\"**%{::fqdn}**\",\"2\":\"nothing special\"},\"testjson\":\"ok\",\"arraytest\":[\"a\",\"%{::fqdn}\",\"c\"]}\n"- let users = HM.fromList [ ("pete", PHash (HM.singleton "uid" "2000"))- , ("tom" , PHash (HM.singleton "uid" "2001"))+ let users = HM.fromList [ ("pete", PHash (HM.singleton "uid" (PNumber 2000)))+ , ("tom" , PHash (HM.singleton "uid" (PNumber 2001))) ]- pusers = HM.fromList [ ("bob", PHash (HM.singleton "uid" "100"))- , ("tom" , PHash (HM.singleton "uid" "12"))+ pusers = HM.fromList [ ("bob", PHash (HM.singleton "uid" (PNumber 100)))+ , ("tom" , PHash (HM.singleton "uid" (PNumber 12))) ]- Right rq <- startHiera (tmpfp ++ "/hiera.yaml")+ Right q <- startHiera (tmpfp ++ "/hiera.yaml") let checkOutput v (S.Right (_ :!: x)) = x @?= v checkOutput _ (S.Left rr) = assertFailure (show rr)- q = rq hspec $ do describe "lookup data without a key" $ do it "returns an error when called with an empty string" $ q mempty "" Priority >>= checkOutput S.Nothing describe "lookup data with no options" $ do- it "can get string data" $ q mempty "http_port" Priority >>= checkOutput (S.Just "8080")+ it "can get string data" $ q mempty "http_port" Priority >>= checkOutput (S.Just (PNumber 8080)) it "can get arrays" $ q mempty "ntp_servers" Priority >>= checkOutput (S.Just (PArray (V.fromList ["0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"]))) it "can get hashes" $ q mempty "users" Priority >>= checkOutput (S.Just (PHash users)) describe "lookup data with a scope" $ do- it "overrides some values" $ q newscope "http_port" Priority >>= checkOutput (S.Just "9090")- it "doesn't fail on others" $ q newscope "global" Priority >>= checkOutput (S.Just "glob")+ it "overrides some values" $ q vars "http_port" Priority >>= checkOutput (S.Just (PNumber 9090))+ it "doesn't fail on others" $ q vars "global" Priority >>= checkOutput (S.Just "glob") describe "json backend" $ do- it "resolves in json" $ q newscope "testjson" Priority >>= checkOutput (S.Just "ok")+ it "resolves in json" $ q vars "testjson" Priority >>= checkOutput (S.Just "ok") describe "deep interpolation" $ do- it "resolves in strings" $ q newscope "interp1" Priority >>= checkOutput (S.Just (PString ("**" <> ndname <> "**")))- it "resolves in objects" $ q newscope "testnode" Priority >>= checkOutput (S.Just (PHash (HM.fromList [("1",PString ("**" <> ndname <> "**")),("2",PString "nothing special")])))- it "resolves in arrays" $ q newscope "arraytest" Priority >>= checkOutput (S.Just (PArray (V.fromList [PString "a", PString ndname, PString "c"])))+ it "resolves in strings" $ q vars "interp1" Priority >>= checkOutput (S.Just (PString ("**" <> ndname <> "**")))+ it "resolves in objects" $ q vars "testnode" Priority >>= checkOutput (S.Just (PHash (HM.fromList [("1",PString ("**" <> ndname <> "**")),("2",PString "nothing special")])))+ it "resolves in arrays" $ q vars "arraytest" Priority >>= checkOutput (S.Just (PArray (V.fromList [PString "a", PString ndname, PString "c"]))) describe "other merge modes" $ do- it "catenates arrays" $ q newscope "ntp_servers" ArrayMerge >>= checkOutput (S.Just (PArray (V.fromList ["2.ntp.puppetlabs.com","3.ntp.puppetlabs.com","0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"])))- it "puts single values in arrays" $ q newscope "http_port" ArrayMerge >>= checkOutput (S.Just (PArray (V.fromList ["9090","8080"])))- it "merges hashes" $ q newscope "users" HashMerge >>= checkOutput (S.Just (PHash (pusers <> users)))+ it "catenates arrays" $ q vars "ntp_servers" ArrayMerge >>= checkOutput (S.Just (PArray (V.fromList ["2.ntp.puppetlabs.com","3.ntp.puppetlabs.com","0.ntp.puppetlabs.com","1.ntp.puppetlabs.com"])))+ it "puts single values in arrays" $ q vars "http_port" ArrayMerge >>= checkOutput (S.Just (PArray (V.fromList [PNumber 9090, PNumber 8080])))+ it "merges hashes" $ q vars "users" HashMerge >>= checkOutput (S.Just (PHash (pusers <> users)))
tests/lexer.hs view
@@ -25,7 +25,7 @@ -- returns errors testparser :: FilePath -> IO (String, Bool) testparser fp = do- T.readFile fp >>= runMyParser puppetParser fp >>= \case+ fmap (runMyParser puppetParser fp) (T.readFile fp) >>= \case Right _ -> return ("PASS", True) Left rr -> return (show rr, False) @@ -33,7 +33,7 @@ check fname = do putStr fname putStr ": "- res <- T.readFile fname >>= runMyParser puppetParser fname+ res <- fmap (runMyParser puppetParser fname) (T.readFile fname) is <- queryTerminal (Fd 1) let rfunc = if is then renderPretty 0.2 200