diff --git a/Erb/Compute.hs b/Erb/Compute.hs --- a/Erb/Compute.hs +++ b/Erb/Compute.hs @@ -57,7 +57,7 @@ type TemplateAnswer = S.Either Doc T.Text initTemplateDaemon :: Preferences -> MStats -> IO (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text)) -initTemplateDaemon (Preferences _ modpath templatepath _ _ _ _ _) mvstats = do +initTemplateDaemon (Preferences _ modpath templatepath _ _ _ _ _ _) mvstats = do controlchan <- newChan templatecache <- newFileCache #ifdef HRUBY @@ -105,7 +105,7 @@ Right x -> (x, T.unpack x) 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))) + Left content -> measure mstats ("parsing - " <> filename) $ return (runParser erbparser () "inline" (T.unpack content)) case parsed of Left err -> do let !msg = "template " ++ ufilename ++ " could not be parsed " ++ show err @@ -149,20 +149,22 @@ Right r -> toRuby r computeTemplateWRuby :: Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO TemplateAnswer -computeTemplateWRuby fileinfo curcontext variables = freezeGC $ do +computeTemplateWRuby fileinfo curcontext variables = freezeGC $ eitherDocIO $ do rscp <- embedHaskellValue curcontext rvariables <- embedHaskellValue variables let varlist = variables ^. ix curcontext . scopeVariables + let withBinding f = do + erbBinding <- safeMethodCall "ErbBinding" "new" [rscp,rvariables] + case erbBinding of + Left x -> return (Left x) + Right v -> do + forM_ (itoList varlist) $ \(varname, (varval :!: _ :!: _)) -> toRuby varval >>= rb_iv_set v (T.unpack varname) + f v o <- case fileinfo of Right fname -> do rfname <- toRuby fname - erbBinding <- safeMethodCall "ErbBinding" "new" [rscp,rvariables] - case erbBinding of - Left x -> return (Left x) - Right v -> do - forM_ (itoList varlist) $ \(varname, (varval :!: _ :!: _)) -> toRuby varval >>= rb_iv_set v (T.unpack varname) - safeMethodCall "Controller" "runFromFile" [rfname,v] - Left content -> toRuby content >>= safeMethodCall "Controller" "runFromContent" . (:[]) + withBinding $ \v -> safeMethodCall "Controller" "runFromFile" [rfname,v] + Left content -> withBinding $ \v -> toRuby content >>= safeMethodCall "Controller" "runFromContent" . (:[v]) freeHaskellValue rvariables freeHaskellValue rscp case o of diff --git a/Erb/Parser.hs b/Erb/Parser.hs --- a/Erb/Parser.hs +++ b/Erb/Parser.hs @@ -9,9 +9,12 @@ import Text.Parsec.Language (emptyDef) import Erb.Ruby import Text.Parsec.Expr +import Text.Parsec.Pos import qualified Text.Parsec.Token as P import qualified Data.Text as T +import qualified Data.Text.IO as T import Control.Monad.Identity +import Control.Exception (catch,SomeException) def :: P.GenLanguageDef String u Identity def = emptyDef @@ -152,6 +155,10 @@ erbparser = textblock parseErbFile :: FilePath -> IO (Either ParseError [RubyStatement]) -parseErbFile fname = do - input <- readFile fname - return (runParser erbparser () fname input) +parseErbFile fname = parseContent `catch` handler + where + parseContent = (runParser erbparser () fname . T.unpack) `fmap` T.readFile fname + handler e = let msg = show (e :: SomeException) + in return $ Left $ newErrorMessage (Message msg) (initialPos fname) + + diff --git a/Erb/Ruby.hs b/Erb/Ruby.hs --- a/Erb/Ruby.hs +++ b/Erb/Ruby.hs @@ -49,3 +49,4 @@ data RubyStatement = Puts !Expression deriving(Show) + diff --git a/Facter.hs b/Facter.hs --- a/Facter.hs +++ b/Facter.hs @@ -119,6 +119,7 @@ , ("puppetversion", "language-puppet") , ("virtual", "xenu") , ("clientcert", nodename) + , ("is_virtual", "true") ] allfacts = nfacts `HM.union` ofacts genFacts = HM.fromList diff --git a/Hiera/Server.hs b/Hiera/Server.hs new file mode 100644 --- /dev/null +++ b/Hiera/Server.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE LambdaCase, TemplateHaskell, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-} +{- | This module runs a Hiera server that caches Hiera data. There is +a huge caveat : only the data files are watched for changes, not the main configuration file. + +A minor bug is that interpolation will not work for inputs containing the % character when it isn't used for interpolation. +-} +module Hiera.Server (startHiera,dummyHiera,HieraQueryFunc) where + +import qualified Data.FileCache as F +import qualified Data.Yaml as Y +import qualified Data.Aeson as A +import Data.Aeson (FromJSON,Value(..),(.:?),(.!=)) +import qualified Data.Either.Strict as S +import qualified Data.Maybe.Strict as S +import qualified Data.Text as T +import qualified Data.Attoparsec.Text as AT +import qualified Data.ByteString.Lazy as BS +import qualified Data.Vector as V +import qualified Data.HashMap.Strict as HM +import Data.Tuple.Strict +import Control.Monad.Writer.Strict + +import Control.Applicative +import Control.Lens +import Control.Lens.Aeson +import System.FilePath.Lens (directory) +import Control.Exception + +import Puppet.PP hiding ((<$>)) +import Puppet.Interpreter.Types +import Puppet.Interpreter.Resolve +import Puppet.Utils (strictifyEither) + +data HieraConfig = HieraConfig { _hieraconfigBackends :: [HieraBackend] + , _hieraconfigHierarchy :: [InterpolableHieraString] + , _hieraconfigBasedir :: FilePath + } deriving Show + +data HieraBackend = YamlBackend FilePath + | JsonBackend FilePath + deriving Show + +newtype InterpolableHieraString = InterpolableHieraString [HieraStringPart] + deriving Show + +data HieraStringPart = HString T.Text + | HVariable T.Text + deriving Show + +instance Pretty HieraStringPart where + pretty (HString t) = ttext t + pretty (HVariable v) = dullred (string "%{" <> ttext v <> string "}") + prettyList = mconcat . map pretty + +type HieraCache = F.FileCacheR Doc Y.Value + +makeFields ''HieraConfig + +instance FromJSON InterpolableHieraString where + parseJSON (String s) = case parseInterpolableString s of + Right x -> return (InterpolableHieraString x) + Left rr -> fail rr + parseJSON _ = fail "Invalid value type" + +instance FromJSON HieraConfig where + parseJSON (Object v) = do + let genBackend :: T.Text -> Y.Parser HieraBackend + genBackend backendname = do + (backendConstructor, skey) <- case backendname of + "yaml" -> return (YamlBackend, ":yaml") + "json" -> return (JsonBackend, ":json") + _ -> fail ("Unknown backend " ++ T.unpack backendname) + datadir <- case (Object v) ^? key skey . key ":datadir" of + Just (String dtdir) -> return dtdir + Just _ -> fail ":datadir should be a string" + Nothing -> return "/etc/puppet/hieradata" + return (backendConstructor (T.unpack datadir)) + HieraConfig + <$> (v .:? ":backends" .!= ["yaml"] >>= mapM genBackend) + <*> (v .:? ":hierarchy" .!= [InterpolableHieraString [HString "common"]]) + <*> pure "/etc/puppet/hieradata" + parseJSON _ = fail "Not a valid Hiera configuration" + +-- | An attoparsec parser that turns text into parts that are ready for +-- interpolation +interpolableString :: AT.Parser [HieraStringPart] +interpolableString = AT.many1 (fmap HString rawPart <|> fmap HVariable interpPart) + where + rawPart = AT.takeWhile1 (/= '%') + interpPart = AT.string "%{" *> AT.takeWhile1 (/= '}') <* AT.char '}' + +parseInterpolableString :: T.Text -> Either String [HieraStringPart] +parseInterpolableString t = AT.parseOnly interpolableString t + +-- | The only method you'll ever need. It runs a Hiera server and gives you +-- a querying function. The 'Nil' output is explicitely given as a Maybe +-- type. +startHiera :: FilePath -> IO (Either String (HieraQueryFunc)) +startHiera hieraconfig = Y.decodeFileEither hieraconfig >>= \case + Left ex -> return (Left (show ex)) + Right cfg -> do + let ncfg = cfg & basedir .~ (hieraconfig ^. directory) <> "/" + cache <- F.newFileCache + return (Right (query ncfg cache)) + +-- | A dummy hiera function that will be used when hiera is not detected +dummyHiera :: HieraQueryFunc +dummyHiera _ _ _ = return (S.Right ([] :!: S.Nothing)) + +-- | The combinator for "normal" queries +queryCombinator :: [LogWriter (S.Maybe PValue)] -> LogWriter (S.Maybe PValue) +queryCombinator [] = return S.Nothing +queryCombinator (x:xs) = x >>= \case + v@(S.Just _) -> return v + S.Nothing -> queryCombinator xs + +-- | The combinator for hiera_array +queryCombinatorArray :: [LogWriter (S.Maybe PValue)] -> LogWriter (S.Maybe PValue) +queryCombinatorArray = fmap rejoin . sequence + where + rejoin = S.Just . PArray . V.concat . map toA + toA S.Nothing = V.empty + toA (S.Just (PArray r)) = r + toA (S.Just a) = V.singleton a + +-- | The combinator for hiera_array +queryCombinatorHash :: [LogWriter (S.Maybe PValue)] -> LogWriter (S.Maybe PValue) +queryCombinatorHash = fmap (S.Just . PHash . mconcat . map toH) . sequence + where + toH S.Nothing = mempty + toH (S.Just (PHash h)) = h + toH _ = throw (ErrorCall "The hiera value was not a hash") + +interpolateText :: Container ScopeInformation -> T.Text -> T.Text +interpolateText vars t = case (parseInterpolableString t ^? _Right) >>= resolveInterpolable vars of + Just x -> x + Nothing -> t + +resolveInterpolable :: Container ScopeInformation -> [HieraStringPart] -> Maybe T.Text +resolveInterpolable vars = fmap T.concat . mapM (resolveInterpolablePart vars) + +resolveInterpolablePart :: Container ScopeInformation -> HieraStringPart -> Maybe T.Text +resolveInterpolablePart _ (HString x) = Just x +resolveInterpolablePart vars (HVariable v) = getVariable vars "::" v ^? _Right . _PString + +interpolatePValue :: Container ScopeInformation -> PValue -> PValue +interpolatePValue v (PHash h) = PHash . HM.fromList . map ( (_1 %~ interpolateText v) . (_2 %~ interpolatePValue v) ) . HM.toList $ h +interpolatePValue v (PArray r) = PArray (fmap (interpolatePValue v) r) +interpolatePValue v (PString t) = PString (interpolateText v t) +interpolatePValue _ x = x + +type LogWriter = WriterT InterpreterWriter IO + +query :: HieraConfig -> HieraCache -> HieraQueryFunc +query (HieraConfig b h bd) cache vars hquery qtype = fmap (S.Right . prepout) (runWriterT (sequencerFunction (map query' h))) `catch` (\e -> return . S.Left . string . show $ (e :: SomeException)) + where + prepout (a,s) = s :!: a + sequencerFunction = case qtype of + Priority -> queryCombinator + ArrayMerge -> queryCombinatorArray + HashMerge -> queryCombinatorHash + query' :: InterpolableHieraString -> LogWriter (S.Maybe PValue) + query' (InterpolableHieraString strs) = + case resolveInterpolable vars strs of + Just s -> sequencerFunction (map (query'' s) b) + Nothing -> warn ("Hiera: could not interpolate " <> pretty strs) >> return S.Nothing + query'' :: T.Text -> HieraBackend -> LogWriter (S.Maybe PValue) + query'' hieraname backend = do + let (decodefunction, datadir, extension) = case backend of + (JsonBackend d) -> (fmap (strictifyEither . (_Left %~ string). A.eitherDecode') . BS.readFile , d, ".json") + (YamlBackend d) -> (fmap (strictifyEither . (_Left %~ string . show)) . Y.decodeFileEither, d, ".yaml") + filename = mbd <> datadir <> "/" <> T.unpack hieraname <> extension + where + mbd = case datadir of + '/' : _ -> mempty + _ -> bd + mfromJSON :: Maybe Value -> LogWriter (S.Maybe PValue) + mfromJSON Nothing = return S.Nothing + mfromJSON (Just v) = case A.fromJSON v of + A.Success a -> return (S.Just (interpolatePValue vars a)) + _ -> warn ("Hiera: could not convert this Value to a Puppet type: " <> string (show v)) >> return S.Nothing + v <- liftIO (F.query cache filename (decodefunction filename)) + case v of + S.Left r -> debug ("Hiera: error when reading file " <> string filename <+> r) >> return S.Nothing + S.Right x -> mfromJSON (x ^? key hquery) diff --git a/Puppet/Daemon.hs b/Puppet/Daemon.hs --- a/Puppet/Daemon.hs +++ b/Puppet/Daemon.hs @@ -1,5 +1,5 @@ {-# LANGUAGE LambdaCase #-} -module Puppet.Daemon (initDaemon, DaemonQuery(..), logDebug, logInfo, logWarning, logError) where +module Puppet.Daemon (initDaemon, logDebug, logInfo, logWarning, logError) where import Puppet.Parser import Puppet.Utils @@ -10,6 +10,7 @@ import Puppet.Manifests import Puppet.Interpreter import Puppet.Plugins +import Hiera.Server import Erb.Compute import Puppet.PP @@ -65,7 +66,7 @@ Known bugs : -* It might be buggy when top level statements that are not class/define/nodes +* It might be buggy when top level statements that are not class\/define\/nodes are altered, or when files loaded with require are changed. * Exported resources are supported through the PuppetDB interface. @@ -90,18 +91,23 @@ catalogStats <- newStats getStatements <- initParserDaemon prefs parserStats getTemplate <- initTemplateDaemon prefs templateStats + hquery <- case prefs ^. hieraPath of + Just p -> startHiera p >>= \case + Left _ -> return dummyHiera + Right x -> return x + Nothing -> return dummyHiera let runMaster = do (luastate, luafunctions) <- initLua (T.pack (prefs ^. modulesPath)) let luacontainer = HM.fromList [ (fname, puppetFunc luastate fname) | fname <- luafunctions ] myprefs = prefs & prefExtFuncs %~ HM.union luacontainer - master myprefs controlChan getStatements getTemplate catalogStats + master myprefs controlChan getStatements getTemplate catalogStats hquery replicateM_ (prefs ^. compilePoolSize) (forkIO runMaster) return (DaemonMethods (gCatalog controlChan) parserStats catalogStats templateStats) gCatalog :: Chan DaemonQuery -> T.Text -> Facts -> IO (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog)) -gCatalog q nodename fcts = do +gCatalog q ndename fcts = do t <- newEmptyMVar - writeChan q (DaemonQuery nodename fcts t) + writeChan q (DaemonQuery ndename fcts t) readMVar t data DaemonQuery = DaemonQuery @@ -117,14 +123,15 @@ -> ( TopLevelType -> T.Text -> IO (S.Either Doc Statement) ) -> (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text)) -> MStats + -> HieraQueryFunc -> IO () -master prefs controlQ getStatements getTemplate stats = forever $ do - (DaemonQuery nodename facts q) <- readChan controlQ - logDebug ("Received query for node " <> nodename) - traceEventIO ("Received query for node " <> T.unpack nodename) - (stmts :!: warnings) <- measure stats nodename $ getCatalog getStatements getTemplate (prefs ^. prefPDB) nodename facts (prefs ^. natTypes) (prefs ^. prefExtFuncs) +master prefs controlQ getStatements getTemplate stats hquery = forever $ do + (DaemonQuery ndename facts q) <- readChan controlQ + logDebug ("Received query for node " <> ndename) + traceEventIO ("Received query for node " <> T.unpack ndename) + (stmts :!: warnings) <- measure stats ndename $ getCatalog getStatements getTemplate (prefs ^. prefPDB) ndename facts (prefs ^. natTypes) (prefs ^. prefExtFuncs) hquery mapM_ (\(p :!: m) -> LOG.logM loggerName p (displayS (renderCompact m) "")) warnings - traceEventIO ("getCatalog finished for " <> T.unpack nodename) + traceEventIO ("getCatalog finished for " <> T.unpack ndename) putMVar q stmts initParserDaemon :: Preferences -> MStats -> IO ( TopLevelType -> T.Text -> IO (S.Either Doc Statement) ) diff --git a/Puppet/Interpreter.hs b/Puppet/Interpreter.hs --- a/Puppet/Interpreter.hs +++ b/Puppet/Interpreter.hs @@ -20,14 +20,14 @@ import qualified Data.Either.Strict as S import qualified Data.HashSet as HS import qualified Data.HashMap.Strict as HM -import Control.Monad.Trans.RWS.Strict -import Control.Monad.Error hiding (mapM) +import Control.Monad.Trans.RSS.Strict +import Control.Monad.Error hiding (mapM,forM) import Control.Lens import qualified Data.Maybe.Strict as S import qualified Data.Graph as G import qualified Data.Tree as T import Data.Foldable (toList,foldl',Foldable,foldlM) -import Data.Traversable (mapM) +import Data.Traversable (mapM,forM) -- helpers vmapM :: (Monad m, Foldable t) => (a -> m b) -> t a -> m [b] @@ -40,21 +40,23 @@ -> Facts -- ^ Facts ... -> Container PuppetTypeMethods -- ^ List of native types -> Container ( [PValue] -> InterpreterMonad PValue ) + -> HieraQueryFunc -- ^ Hiera query function -> IO (Pair (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog)) [Pair Priority Doc]) -getCatalog gtStatement gtTemplate pdbQuery ndename facts nTypes extfuncs = do - let rdr = InterpreterReader nTypes gtStatement gtTemplate pdbQuery extfuncs ndename +getCatalog gtStatement gtTemplate pdbQuery ndename facts nTypes extfuncs hquery = do + let rdr = InterpreterReader nTypes gtStatement gtTemplate pdbQuery extfuncs ndename hquery dummypos = initialPPos "dummy" initialclass = mempty & at "::" ?~ (IncludeStandard :!: dummypos) - stt = InterpreterState baseVars initialclass mempty ["::"] dummypos mempty [] [] + 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) - (output, _, warnings) <- runRWST (runErrorT (computeCatalog ndename)) rdr stt - return (strictifyEither output :!: _warnings warnings) + (output, _, warnings) <- runRSST (runErrorT (computeCatalog ndename)) rdr stt + return (strictifyEither output :!: warnings) isParent :: T.Text -> CurContainerDesc -> InterpreterMonad Bool -isParent _ ContRoot = return False -isParent _ ContImported = return False +isParent _ (ContImport _ _) = return False -- no relationship through import +isParent _ ContRoot = return False +isParent _ (ContImported _) = return False isParent _ (ContDefine _ _) = return False isParent cur (ContClass possibleparent) = do preuse (scopes . ix cur . scopeParent) >>= \case @@ -67,7 +69,7 @@ finalize :: [Resource] -> InterpreterMonad [Resource] finalize rlist = do -- step 1, apply defaults - scp <- getScope + scp <- getScopeName defs <- use (scopes . ix scp . scopeDefaults) let getOver = use (scopes . ix scp . scopeOverrides) -- retrieves current overrides addDefaults r = do @@ -81,12 +83,17 @@ addOverrides' r x Nothing -> return r addOverrides' r (ResRefOverride _ prms p) = do - let inter = (r ^. rattributes) `HM.intersection` prms - unless (fnull inter) $ do - s <- getScope - i <- isParent s (r ^. rcontainer) - unless i $ throwPosError ("You are not allowed to override the following parameters " <+> containerComma inter <+> "already defined at" <+> showPPos p) - return (r & rattributes %~ (<>) prms) + let forb = throwPosError ("Override of parameters of the following resource is forbidden in the current context:" pretty r <+> showPPos p) + s <- getScope + overrideType <- case r ^. rscope of + [] -> forb -- we could not get the current resource context + (x:_) -> if x == s + then return CantOverride -- we are in the same context : can't replace, but add stuff + else isParent (scopeName s) x >>= \i -> + if i + then return Replace -- we can override what's defined in a parent + else forb + foldM (\cr a -> addAttribute overrideType cr a) r (HM.toList prms) withDefaults <- mapM (addOverrides >=> addDefaults) rlist -- There might be some overrides that could not be applied. The only -- valid reason is that they override something in exported resources. @@ -113,12 +120,12 @@ popScope :: InterpreterMonad () popScope = curScope %= tail -pushScope :: T.Text -> InterpreterMonad () +pushScope :: CurContainerDesc -> InterpreterMonad () pushScope s = curScope %= (s :) evalTopLevel :: Statement -> InterpreterMonad ([Resource], Statement) evalTopLevel (TopContainer tops s) = do - pushScope "::" + pushScope ContRoot r <- vmapM evaluateStatement tops >>= finalize . concat -- popScope (nr, ns) <- evalTopLevel s @@ -170,7 +177,7 @@ makeEdgeMap :: FinalCatalog -> InterpreterMonad EdgeMap makeEdgeMap ct = do -- merge the looaded classes and resources - defs' <- use definedResources + defs' <- HM.map _rpos `fmap` use definedResources clss' <- use loadedClasses let defs = defs' <> classes' <> aliases' <> names' names' = HM.map _rpos ct @@ -188,11 +195,13 @@ let containerMap :: HM.HashMap RIdentifier [RIdentifier] !containerMap = ifromListWith (<>) $ do r <- toList ct - let toResource ContRoot = RIdentifier "class" "::" - toResource (ContClass cn) = RIdentifier "class" cn - toResource (ContDefine t n) = RIdentifier t n - toResource ContImported = RIdentifier "class" "::" - return (toResource (r ^. rcontainer), [r ^. rid]) + let toResource ContRoot = return $ RIdentifier "class" "::" + toResource (ContClass cn) = return $ RIdentifier "class" cn + toResource (ContDefine t n) = return $ RIdentifier t n + toResource (ContImported _) = mzero + toResource (ContImport _ _) = mzero + o <- toResource (rcurcontainer r) + return (o, [r ^. rid]) -- This function uses the previous map in order to resolve to non -- container resources. resolveDestinations :: RIdentifier -> [RIdentifier] @@ -273,7 +282,7 @@ evaluateNode :: Statement -> InterpreterMonad [Resource] evaluateNode (Node _ stmts inheritance p) = do curPos .= p - pushScope "::" + pushScope ContRoot unless (S.isNothing inheritance) $ throwPosError "Node inheritance is not handled yet, and will probably never be" vmapM evaluateStatement stmts >>= finalize . concat evaluateNode x = throwPosError ("Asked for a node evaluation, but got this instead:" <$> pretty x) @@ -296,7 +305,7 @@ if "::" `T.isInfixOf` cname then nestedDeclarations . at (TopClass, cname) ?= r >> return [] else do - scp <- getScope + scp <- getScopeName if scp == "::" then nestedDeclarations . at (TopClass, cname) ?= r >> return [] else nestedDeclarations . at (TopClass, scp <> "::" <> cname) ?= r >> return [] @@ -304,7 +313,7 @@ if "::" `T.isInfixOf` dname then nestedDeclarations . at (TopDefine, dname) ?= r >> return [] else do - scp <- getScope + scp <- getScopeName if scp == "::" then nestedDeclarations . at (TopDefine, dname) ?= r >> return [] else nestedDeclarations . at (TopDefine, scp <> "::" <> dname) ?= r >> return [] @@ -321,7 +330,19 @@ then do let q = searchExpressionToPuppetDB resType rsearch pdb <- view pdbAPI - interpreterIO (getResources pdb q) + fqdn <- view thisNodename + -- we must filter the resources that originated from this host + -- here ! They are also turned into "normal" resources + res <- ( map (rvirtuality .~ Normal) + . filter ((/= fqdn) . _rnode) + ) `fmap` interpreterIO (getResources pdb q) + scpdesc <- ContImported `fmap` getScope + void $ enterScope S.Nothing scpdesc + pushScope scpdesc + o <- finalize res + popScope + return o + else return [] evaluateStatement (Dependency (t1 :!: n1) (t2 :!: n2) p) = do curPos .= p @@ -356,7 +377,7 @@ curPos .= p let resolveDefaultValue (prm :!: v) = fmap (prm :!:) (resolveExpression v) rdecls <- vmapM resolveDefaultValue decls >>= fromArgumentList - scp <- getScope + scp <- getScopeName -- invariant that must be respected : the current scope must me create -- in "scopes", or nothing gets saved let newDefaults = ResDefaults resType scp rdecls p @@ -373,9 +394,10 @@ curPos .= p raassignements <- vmapM resolveArgument eargs >>= fromArgumentList rn <- resolveExpressionString urn - scp <- getScope + scp <- getScopeName curoverrides <- use (scopes . ix scp . scopeOverrides) let rident = RIdentifier rt rn + -- check that we didn't already override those values withAssignements <- case curoverrides ^. at rident of Just (ResRefOverride _ prevass prevpos) -> do let cm = prevass `HM.intersection` raassignements @@ -394,7 +416,7 @@ loadVariable :: T.Text -> PValue -> InterpreterMonad () loadVariable varname varval = do curcont <- getCurContainer - scp <- getScope + scp <- getScopeName p <- use curPos scopeDefined <- use (scopes . contains scp) variableDefined <- preuse (scopes . ix scp . scopeVariables . ix varname) @@ -403,11 +425,11 @@ (_, Just (_ :!: pp :!: ctx)) -> do isParent scp (curcont ^. cctype) >>= \case True -> do - warn ("The variable" - <+> pretty (UVariableReference varname) - <+> "had been overriden because of some arbitrary inheritance rule that was set up to emulate puppet behaviour. It was defined at" - <+> showPPos pp - ) + debug ("The variable" + <+> pretty (UVariableReference varname) + <+> "had been overriden because of some arbitrary inheritance rule that was set up to emulate puppet behaviour. It was defined at" + <+> showPPos pp + ) scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype) False -> throwPosError ("Variable" <+> pretty (UVariableReference varname) <+> "already defined at" <+> showPPos pp "Context:" <+> pretty ctx @@ -416,22 +438,44 @@ ) _ -> scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype) -loadParameters :: Foldable f => Container PValue -> f (Pair T.Text (S.Maybe Expression)) -> PPosition -> InterpreterMonad () -loadParameters params classParams defaultPos = do +-- | This function loads class and define parameters into scope. It checks +-- that all mandatory parameters are set, that no extra parameter is +-- declared. +-- +-- It is able to fill unset parameters with values from Hiera (for classes +-- only) or default values. +loadParameters :: Foldable f => Container PValue -> f (Pair T.Text (S.Maybe Expression)) -> PPosition -> S.Maybe T.Text -> InterpreterMonad () +loadParameters params classParams defaultPos wHiera = do + params' <- case wHiera of + S.Just classname -> do + -- pass 1 : with classes, we retrieve the parameters that have no default values and + -- that are not set, to try to get them with Hiera + let !classParamSet = HS.fromList (fmap S.fst (classParams ^.. folded)) + !definedParamSet = ikeys params + !unsetParams = classParamSet `HS.difference` definedParamSet + loadHieraParam curprms paramname = do + v <- runHiera (classname <> "::" <> paramname) Priority + case v of + S.Nothing -> return curprms + S.Just vl -> return (curprms & at paramname ?~ vl) + foldM loadHieraParam params (toList unsetParams) + S.Nothing -> return params + -- pass 2 : we check that everything is right let !classParamSet = HS.fromList (map S.fst (toList classParams)) !mandatoryParamSet = HS.fromList (map S.fst (classParams ^.. folded . filtered (S.isNothing . S.snd))) - !definedParamSet = ikeys params + !definedParamSet = ikeys params' !unsetParams = mandatoryParamSet `HS.difference` definedParamSet !spuriousParams = definedParamSet `HS.difference` classParamSet - unless (fnull unsetParams) $ throwPosError ("The following mandatory parameters where not set:" <+> tupled (map ttext $ toList unsetParams)) - unless (fnull spuriousParams) $ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ttext) $ toList spuriousParams)) + 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 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) + mapM_ (uncurry loadVariable) (itoList params') curPos .= defaultPos forM_ (filter isDefault (toList classParams)) $ \(k :!: v) -> do rv <- case v of S.Nothing -> throwPosError "Internal error: invalid invariant at loadParameters" - S.Just e -> resolveExpression e + S.Just e -> resolveExpression e loadVariable k rv -- | Enters a new scope, checks it is not already defined, and inherits the @@ -442,25 +486,26 @@ -- expanding the defines without the defaults applied enterScope :: S.Maybe T.Text -> CurContainerDesc -> InterpreterMonad T.Text enterScope parent cont = do - let scopename = case cont of - ContRoot -> "::" - ContImported -> "::" - ContClass x -> x - ContDefine dt dn -> "#define/" <> dt <> "/" <> dn + let scopename = scopeName cont scopeAlreadyDefined <- use (scopes . contains scopename) - when scopeAlreadyDefined (throwPosError ("Internal error: scope already defined when loading scope for" <+> pretty cont)) - scp <- getScope - -- TODO fill tags - basescope <- case parent of - S.Nothing -> do - curdefs <- use (scopes . ix scp . scopeDefaults) - return $ ScopeInformation mempty curdefs mempty (CurContainer cont mempty) mempty parent - S.Just p -> do - parentscope <- use (scopes . at p) - when (isNothing parentscope) (throwPosError ("Internal error: could not find parent scope" <+> ttext p)) - let Just psc = parentscope - return (psc & scopeParent .~ parent) - scopes . at scopename ?= basescope + let isImported = case cont of + ContImported _ -> True + _ -> False + -- it is OK to reuse a scope related to imported stuff + unless (scopeAlreadyDefined && isImported) $ do + when scopeAlreadyDefined (throwPosError ("Internal error: scope" <+> brackets (ttext scopename) <+> "already defined when loading scope for" <+> pretty cont)) + scp <- getScopeName + -- TODO fill tags + basescope <- case parent of + S.Nothing -> do + curdefs <- use (scopes . ix scp . scopeDefaults) + return $ ScopeInformation mempty curdefs mempty (CurContainer cont mempty) mempty parent + S.Just p -> do + parentscope <- use (scopes . at p) + when (isNothing parentscope) (throwPosError ("Internal error: could not find parent scope" <+> ttext p)) + let Just psc = parentscope + return (psc & scopeParent .~ parent) + scopes . at scopename ?= basescope return scopename dropInitialColons :: T.Text -> T.Text @@ -477,25 +522,32 @@ let curContType = ContDefine deftype defname scopename <- enterScope S.Nothing curContType (spurious, dls) <- getstt TopDefine deftype + let isImported (ContImported _) = True + isImported _ = False + isImportedDefine <- isImported `fmap` getScope case dls of (DefineDeclaration _ defineParams stmts cp) -> do p <- use curPos curPos .= r ^. rpos - pushScope scopename + curscp <- getScope + when isImportedDefine (pushScope (ContImport (r ^. rnode) curscp )) + pushScope curContType loadVariable "title" (PString defname) loadVariable "name" (PString defname) -- not done through loadvariable because of override -- errors scopes . ix scopename . scopeVariables . at "module_name" ?= (PString modulename :!: p :!: curContType) scopes . ix scopename . scopeVariables . at "callermodule_name" ?= (curcaller :!: p :!: curContType) - loadParameters (r ^. rattributes) defineParams cp + loadParameters (r ^. rattributes) defineParams cp S.Nothing curPos .= cp res <- evaluateStatementsVector stmts out <- finalize (spurious ++ res) + when isImportedDefine popScope popScope return out _ -> throwPosError ("Internal error: we did not retrieve a DefineDeclaration, but had" <+> pretty dls) + loadClass :: T.Text -> Container PValue -> ClassIncludeType @@ -507,7 +559,7 @@ -- http://docs.puppetlabs.com/puppet/3/reference/lang_classes.html#using-resource-like-declarations use (loadedClasses . at classname) >>= \case Just (_ :!: pp) -> do - when (cincludetype == IncludeResource) (throwPosError ("Can't include class" <+> ttext classname <+> "twice when using the resource-like syntax (first occurance at" <+> showPPos pp <> ")")) + when (cincludetype == IncludeResource) (throwPosError ("Can't include class" <+> ttext classname <+> "twice when using the resource-like syntax (first occurence at" <+> showPPos pp <> ")")) return [] -- already loaded, go on Nothing -> do @@ -522,20 +574,23 @@ inhstmts <- case inh of S.Nothing -> return [] S.Just ihname -> loadClass ihname mempty IncludeResource - scopename <- enterScope inh (ContClass classname) + let !scopedesc = ContClass classname + scopename <- enterScope inh scopedesc classresource <- if cincludetype == IncludeStandard then do scp <- use curScope - return [Resource (RIdentifier "class" classname) (HS.singleton classname) mempty mempty scp ContRoot Normal mempty p Nothing] + fqdn <- view thisNodename + return [Resource (RIdentifier "class" classname) (HS.singleton classname) mempty mempty scp Normal mempty p fqdn] else return [] - pushScope scopename + pushScope scopedesc let modulename = case T.splitOn "::" classname of [] -> classname (x:_) -> x -- not done through loadvariable because of override -- errors scopes . ix scopename . scopeVariables . at "module_name" ?= (PString modulename :!: p :!: ContClass classname) - loadParameters params classParams cp + scopes . ix "::" . scopeVariables . at "calling_module" ?= (PString modulename :!: p :!: ContClass classname) -- hiera compatibility :( + loadParameters params classParams cp (S.Just classname) curPos .= cp res <- evaluateStatementsVector stmts out <- finalize (classresource ++ spurious ++ inhstmts ++ res) @@ -577,11 +632,11 @@ _ -> do -- we must check if the resource scope is -- a parent of the current scope - curscope <- getScope - i <- isParent curscope (r ^. rcontainer) + curscope <- getScopeName + i <- isParent curscope (rcurcontainer r) if i then return (r & rattributes . at t ?~ v) - else throwPosError ("Attribute" <+> ttext t <+> "defined multiple times for" <+> pretty (r ^. rid) <+> showPPos (r ^. rpos)) + else throwPosError ("Attribute" <+> dullmagenta (ttext t) <+> "defined multiple times for" <+> pretty (r ^. rid) <+> showPPos (r ^. rpos)) registerResource :: T.Text -> T.Text -> Container PValue -> Virtuality -> PPosition -> InterpreterMonad [Resource] registerResource "class" _ _ Virtual p = curPos .= p >> throwPosError "Cannot declare a virtual class (or perhaps you can, but I do not know what this means)" @@ -594,24 +649,29 @@ -- http://docs.puppetlabs.com/puppet/3/reference/lang_tags.html#containment let !defaulttags = {-# SCC "rrGetTags" #-} HS.fromList (rt : classtags) <> tgs allsegs x = x : T.splitOn "::" x - !classtags = case cnt of - ContRoot -> [] - ContImported -> [] - ContClass cn -> allsegs cn - ContDefine dt _ -> allsegs dt + !classtags = getClassTags cnt + getClassTags (ContClass cn ) = allsegs cn + getClassTags (ContDefine dt _) = allsegs dt + getClassTags (ContRoot ) = [] + getClassTags (ContImported _ ) = [] + getClassTags (ContImport _ _ ) = [] allScope <- use curScope - let baseresource = Resource (RIdentifier rt rn) (HS.singleton rn) mempty mempty allScope cnt vrt defaulttags p Nothing + fqdn <- view thisNodename + let baseresource = Resource (RIdentifier rt rn) (HS.singleton rn) mempty mempty allScope vrt defaulttags p fqdn r <- foldM (addAttribute CantOverride) baseresource (itoList arg) let resid = RIdentifier rt rn case rt of "class" -> {-# SCC "rrClass" #-} do - definedResources . at resid ?= p + definedResources . at resid ?= r fmap (r:) $ loadClass rn (r ^. rattributes) IncludeResource _ -> {-# SCC "rrGeneralCase" #-} use (definedResources . at resid) >>= \case - Just apos -> throwPosError ("Resource" <+> pretty resid <+> "already defined at" <+> showPPos apos) + Just otheres -> throwPosError ("Resource" <+> pretty resid <+> "already defined:" <$> + pretty r <$> + pretty otheres + ) Nothing -> do - definedResources . at resid ?= p + definedResources . at resid ?= r return [r] -- A helper function for the various loggers @@ -626,7 +686,7 @@ -- functions : this can't really be exported as it uses a lot of stuff from -- this module ... mainFunctionCall :: T.Text -> [PValue] -> InterpreterMonad [Resource] -mainFunctionCall "showscope" _ = use curScope >>= warn . list . map ttext >> return [] +mainFunctionCall "showscope" _ = use curScope >>= warn . pretty >> return [] -- The logging functions mainFunctionCall "alert" a = logWithModifier ALERT red a mainFunctionCall "crit" a = logWithModifier CRITICAL red a @@ -653,12 +713,23 @@ realiz x = throwPosError ("realize(): all arguments must be resource references, not" <+> pretty x) mapM_ realiz args >> return [] mainFunctionCall "tag" args = do - scp <- getScope + scp <- getScopeName let addTag x = scopes . ix scp . scopeExtraTags . contains x .= True mapM_ (resolvePValueString >=> addTag) args return [] mainFunctionCall "fail" [x] = fmap (("fail:" <+>) . dullred . ttext) (resolvePValueString x) >>= throwPosError mainFunctionCall "fail" _ = throwPosError "fail(): This function takes a single argument" +mainFunctionCall "hiera_include" [x] = do + ndname <- resolvePValueString x + classes <- runHiera ndname ArrayMerge >>= \case + S.Just (PArray r) -> return (toList r) + _ -> return [] + p <- use curPos + curPos %= (_1 . lSourceName %~ (<> " [hiera_include call]")) + o <- mainFunctionCall "include" classes + curPos .= p + return o +mainFunctionCall "hiera_include" _ = throwPosError "hiera_include(): This function takes a single argument" mainFunctionCall fname args = do p <- use curPos let representation = MainFunctionCall fname mempty p @@ -668,7 +739,6 @@ Nothing -> throwPosError ("Unknown function:" <+> pretty representation) unless (rs == PUndef) $ throwPosError ("This function call should return" <+> pretty PUndef <+> "and not" <+> pretty rs <$> pretty representation) return [] - -- Method stuff evaluateHFC :: HFunctionCall -> InterpreterMonad [Resource] diff --git a/Puppet/Interpreter/PrettyPrinter.hs b/Puppet/Interpreter/PrettyPrinter.hs --- a/Puppet/Interpreter/PrettyPrinter.hs +++ b/Puppet/Interpreter/PrettyPrinter.hs @@ -50,15 +50,10 @@ pretty (RIdentifier t n) = pretty (PResourceReference t n) meta :: Resource -> Doc -meta r = showPPos (r ^. rpos) <+> (green (node <> brackets cont <+> brackets scp) ) +meta r = showPPos (r ^. rpos) <+> (green (node <+> brackets scp) ) where - node = maybe mempty ((<+> mempty) . red . ttext) (r ^. rnode) - cont = case r ^. rcontainer of - ContRoot -> magenta "top level" - ContClass cname -> magenta "class" <+> ttext cname - ContDefine t n -> pretty (PResourceReference t n) - ContImported -> magenta "imported" - scp = "Scope" <+> pretty (r ^.. rscope . folded . filtered (/="::") . to (white . ttext)) + node = red (ttext (r ^. rnode)) + scp = "Scope" <+> pretty (r ^.. rscope . folded . filtered (/=ContRoot) . to pretty) resourceBody :: Resource -> Doc resourceBody r = virtuality <> blue (ttext (r ^. rid . iname)) <> ":" <+> meta r <$> containerComma'' insde <> ";" @@ -73,8 +68,8 @@ attriblist1 = sortWith fst $ HM.toList (r ^. rattributes) ++ aliasdiff aliasWithoutTitle = r ^. ralias & contains (r ^. rid . iname) .~ False aliasPValue = aliasWithoutTitle & PArray . V.fromList . map PString . HS.toList - aliasdiff | HS.null aliasWithoutTitle = [("alias", aliasPValue)] - | otherwise = [] + aliasdiff | HS.null aliasWithoutTitle = [] + | otherwise = [("alias", aliasPValue)] attriblist2 = map totext (resourceRelations r) totext (RIdentifier t n, lt) = (rel2text lt , PResourceReference t n) maxalign = max (maxalign' attriblist1) (maxalign' attriblist2) @@ -91,7 +86,8 @@ pretty r = dullyellow (ttext (r ^. rid . itype)) <+> lbrace <$> indent 2 (resourceBody r) <$> rbrace instance Pretty CurContainerDesc where - pretty ContImported = magenta "imported" + pretty (ContImport p x) = magenta "import" <> braces (ttext p) <> braces (pretty x) + pretty (ContImported x) = magenta "imported" <> braces (pretty x) pretty ContRoot = dullyellow (text "::") pretty (ContClass cname) = dullyellow (text "class") <+> dullgreen (text (T.unpack cname)) pretty (ContDefine dtype dname) = pretty (PResourceReference dtype dname) diff --git a/Puppet/Interpreter/Resolve.hs b/Puppet/Interpreter/Resolve.hs --- a/Puppet/Interpreter/Resolve.hs +++ b/Puppet/Interpreter/Resolve.hs @@ -1,5 +1,33 @@ {-# LANGUAGE LambdaCase #-} -module Puppet.Interpreter.Resolve where +-- | This module is all about converting and resolving foreign data into +-- the fully exploitable corresponding data type. The main use case is the +-- conversion of 'Expression' to 'PValue'. +module Puppet.Interpreter.Resolve + ( -- * Pure resolution functions and prisms + _PString, + _PInteger, + pvnum, + getVariable, + pValue2Bool, + -- * Monadic resolution functions + resolveVariable, + resolveExpression, + resolveValue, + resolvePValueString, + resolveExpressionString, + resolveExpressionStrings, + resolveArgument, + runHiera, + isNativeType, + -- * Search expression management + resolveSearchExpression, + checkSearchExpression, + searchExpressionToPuppetDB, + -- * Higher order puppet functions handling + hfGenerateAssociations, + hfSetvars, + hfRestorevars, + ) where import Puppet.PP import Puppet.Interpreter.Types @@ -10,6 +38,7 @@ import Data.Version (parseVersion) import Text.ParserCombinators.ReadP (readP_to_S) +import Data.Maybe (fromMaybe) import Data.Aeson hiding ((.=)) import Data.CaseInsensitive ( mk ) import qualified Data.Vector as V @@ -37,10 +66,35 @@ import qualified Data.ByteString.Base16 as B16 import Text.Regex.PCRE.ByteString.Utils import Data.Bits +import Control.Monad.Writer (tell) +-- | A useful type that is used when trying to perform arithmetic on Puppet +-- numbers. type NumberPair = S.Either (Pair Integer Integer) (Pair Double Double) --- | Tries to convert a pair of PValues into numbers, as defined in +-- | A hiera helper function, that will throw all Hiera errors and log +-- messages to the main monad. +runHiera :: T.Text -> HieraQueryType -> InterpreterMonad (S.Maybe PValue) +runHiera q t = do + hquery <- view hieraQuery + scps <- use scopes + (w :!: o) <- interpreterIO (hquery scps q t) + tell w + return o + +-- | The implementation of all hiera_* functions +hieraCall :: HieraQueryType -> PValue -> (Maybe PValue) -> (Maybe PValue) -> InterpreterMonad PValue +hieraCall _ _ _ (Just _) = throwPosError "Overriding the hierarchy is not yet supported" +hieraCall qt q df _ = do + qs <- resolvePValueString q + o <- runHiera qs qt + case o of + S.Just p -> return p + S.Nothing -> case df of + Just d -> return d + Nothing -> throwPosError ("Lookup for " <> ttext qs <> " failed") + +-- | Tries to convert a pair of 'PValue's into 'Number's, as defined in -- 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 @@ -53,7 +107,14 @@ _ -> S.Nothing toNumbers _ _ = S.Nothing -binaryOperation :: Expression -> Expression -> (Integer -> Integer -> Integer) -> (Double -> Double -> Double) -> InterpreterMonad PValue +-- | This tries to run a numerical binary operation on two puppet +-- expressions. It will try to resolve them, then convert them to numbers +-- (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 + -> InterpreterMonad PValue binaryOperation a b opi opd = do ra <- resolveExpression a rb <- resolveExpression b @@ -62,6 +123,8 @@ S.Just (S.Right (na :!: nb)) -> return (pvnum # D (opd na nb)) S.Just (S.Left (na :!: nb)) -> return (pvnum # I (opi na nb)) +-- | 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 @@ -71,7 +134,7 @@ S.Just (S.Right _) -> throwPosError ("Expected integer values, not" <+> pretty ra <+> "or" <+> pretty rb) S.Just (S.Left (na :!: nb)) -> return (pvnum # I (opr na nb)) --- | Converting PValue to and from Number with a prism! +-- | A prism between 'PValue' and 'Number' pvnum :: Prism' PValue Number pvnum = prism num2PValue toNumber where @@ -84,28 +147,36 @@ _ -> Left p toNumber p = Left p +-- | A prism between 'PValue' and 'T.Text' _PString :: Prism' PValue T.Text _PString = prism PString $ \x -> case x of PString s -> Right s n -> Left n +-- | A prism between 'PValue' and 'Integer' _PInteger :: Prism' PValue Integer _PInteger = prism (PString . T.pack . show) $ \x -> case x ^? pvnum of Just (I z) -> Right z _ -> Left x +-- | Resolves a variable, or throws an error if it can't. resolveVariable :: T.Text -> InterpreterMonad PValue resolveVariable fullvar = do scps <- use scopes - scp <- getScope + scp <- getScopeName case getVariable scps scp fullvar of Left rr -> throwPosError rr Right x -> return x +-- | A simple helper that checks if a given type is native or a define. isNativeType :: T.Text -> InterpreterMonad Bool isNativeType t = view (nativeTypes . contains t) -getVariable :: Container ScopeInformation -> T.Text -> T.Text -> Either Doc PValue +-- | A pure function for resolving variables. +getVariable :: Container ScopeInformation -- ^ The whole scope data. + -> T.Text -- ^ Current scope name. + -> T.Text -- ^ Full variable name. + -> Either Doc PValue getVariable scps scp fullvar = do (varscope, varname) <- case T.splitOn "::" fullvar of [] -> throwError "This doesn't make any sense in resolveVariable" @@ -119,6 +190,7 @@ Just pp -> extractVariable pp 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 @@ -128,6 +200,7 @@ S.Just (S.Right (na :!: nb)) -> return (PBoolean (compd na nb)) S.Just (S.Left (na :!: nb)) -> return (PBoolean (compi na nb)) +-- | Handles the wonders of puppet equality checks. puppetEquality :: PValue -> PValue -> Bool puppetEquality ra rb = case toNumbers ra rb of @@ -144,6 +217,8 @@ -- for case insensitive matching _ -> ra == rb +-- | The main resolution function : turns an 'Expression' into a 'PValue', +-- if possible. resolveExpression :: Expression -> InterpreterMonad PValue resolveExpression (PValue v) = resolveValue v resolveExpression (Not e) = fmap (PBoolean . not . pValue2Bool) (resolveExpression e) @@ -232,6 +307,8 @@ resolveExpression (FunctionApplication _ x) = throwPosError ("Expected function application here, not" <+> pretty x) resolveExpression x = throwPosError ("Don't know how to resolve this expression:" <$> pretty x) +-- | Resolves an 'UValue' (terminal for the 'Expression' data type) into +-- a 'PValue' resolveValue :: UValue -> InterpreterMonad PValue resolveValue n@(URegexp _ _) = throwPosError ("Regular expressions are not allowed in this context: " <+> pretty n) resolveValue (UBoolean x) = return (PBoolean x) @@ -247,33 +324,41 @@ resolveValue (UFunctionCall fname args) = resolveFunction fname args resolveValue (UHFunctionCall hf) = evaluateHFCPure hf -resolveValueString :: UValue -> InterpreterMonad T.Text -resolveValueString = resolveValue >=> resolvePValueString - +-- | Turns strings 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 x = throwPosError ("Don't know how to convert this to a string:" <$> pretty x) +-- | > resolveValueString = resolveValue >=> resolvePValueString +resolveValueString :: UValue -> InterpreterMonad T.Text +resolveValueString = resolveValue >=> resolvePValueString + +-- | > resolveExpressionString = resolveExpression >=> resolvePValueString resolveExpressionString :: Expression -> InterpreterMonad T.Text resolveExpressionString = resolveExpression >=> resolvePValueString +-- | Just like 'resolveExpressionString', but accepts arrays. resolveExpressionStrings :: Expression -> InterpreterMonad [T.Text] resolveExpressionStrings x = resolveExpression x >>= \case PArray a -> mapM resolvePValueString (V.toList a) y -> fmap return (resolvePValueString y) +-- | A special helper function for argument like argument like pairs. resolveArgument :: Pair T.Text Expression -> InterpreterMonad (Pair T.Text PValue) resolveArgument (argname :!: argval) = (:!:) `fmap` pure argname <*> resolveExpression argval +-- | Turns a 'PValue' into a 'Bool', as explained in the reference +-- documentation. pValue2Bool :: PValue -> Bool pValue2Bool PUndef = False pValue2Bool (PString "") = False pValue2Bool (PBoolean x) = x pValue2Bool _ = True +-- | This resolve function calls at the expression level. resolveFunction :: T.Text -> V.Vector Expression -> InterpreterMonad PValue resolveFunction "fqdn_rand" args = do let nbargs = V.length args @@ -341,7 +426,7 @@ file (x:xs) = fmap S.Right (T.readFile (T.unpack x)) `catch` (\SomeException{} -> file xs) resolveFunction' "tagged" ptags = do tags <- fmap HS.fromList (mapM resolvePValueString ptags) - scp <- getScope + scp <- getScopeName scpset <- use (scopes . ix scp . scopeExtraTags) return (PBoolean (scpset `HS.intersection` tags == tags)) resolveFunction' "template" [templatename] = calcTemplate Right templatename @@ -363,6 +448,17 @@ resolveFunction' "pdbresourcequery" [q] = pdbresourcequery q Nothing resolveFunction' "pdbresourcequery" [q,k] = fmap Just (resolvePValueString k) >>= pdbresourcequery q resolveFunction' "pdbresourcequery" _ = throwPosError "pdbresourcequery(): Expects one or two arguments" +resolveFunction' "hiera" [q] = hieraCall Priority q Nothing Nothing +resolveFunction' "hiera" [q,d] = hieraCall Priority q (Just d) Nothing +resolveFunction' "hiera" [q,d,o] = hieraCall Priority q (Just d) (Just o) +resolveFunction' "hiera_array" [q] = hieraCall ArrayMerge q Nothing Nothing +resolveFunction' "hiera_array" [q,d] = hieraCall ArrayMerge q (Just d) Nothing +resolveFunction' "hiera_array" [q,d,o] = hieraCall ArrayMerge q (Just d) (Just o) +resolveFunction' "hiera_hash" [q] = hieraCall HashMerge q Nothing Nothing +resolveFunction' "hiera_hash" [q,d] = hieraCall HashMerge q (Just d) Nothing +resolveFunction' "hiera_hash" [q,d,o] = hieraCall HashMerge q (Just d) (Just o) +resolveFunction' "hiera" _ = throwPosError "hiera(): Expects one, two or three arguments" + -- user functions resolveFunction' fname args = do external <- view externalFunctions @@ -391,10 +487,17 @@ calcTemplate :: (T.Text -> Either T.Text T.Text) -> PValue -> InterpreterMonad PValue calcTemplate templatetype templatename = do fname <- resolvePValueString templatename + classes <- (PArray . V.fromList . map PString . HM.keys) `fmap` use loadedClasses + scp <- getScopeName scps <- use scopes - scp <- getScope + -- inject the special template variables (just classes for now) + let cd = fromMaybe ContRoot (scps ^? ix scp . scopeContainer . cctype) -- get the current containder description + -- 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 ) computeFunc <- view computeTemplateFunction - liftIO (computeFunc (templatetype fname) scp scps) + liftIO (computeFunc (templatetype fname) scp cscps) >>= \case S.Left rr -> throwPosError ("template error for" <+> ttext fname <+> ":" <$> rr) S.Right r -> return (PString r) @@ -406,6 +509,8 @@ PHash _ -> throwPosError "The use of an array in a search expression is undefined" resolved -> return resolved +-- | Turns an unresolved 'SearchExpression' from the parser into a fully +-- resolved 'RSearchExpression'. resolveSearchExpression :: SearchExpression -> InterpreterMonad RSearchExpression resolveSearchExpression AlwaysTrue = return RAlwaysTrue resolveSearchExpression (EqualitySearch a e) = REqualitySearch `fmap` pure a <*> resolveExpressionSE e @@ -413,8 +518,10 @@ resolveSearchExpression (AndSearch e1 e2) = RAndSearch `fmap` resolveSearchExpression e1 <*> resolveSearchExpression e2 resolveSearchExpression (OrSearch e1 e2) = ROrSearch `fmap` resolveSearchExpression e1 <*> resolveSearchExpression e2 +-- | Turns a resource type and 'RSearchExpression' into something that can +-- be used in a PuppetDB query. searchExpressionToPuppetDB :: T.Text -> RSearchExpression -> Query ResourceField -searchExpressionToPuppetDB rtype res = QAnd ( QEqual RType rtype : mkSE res ) +searchExpressionToPuppetDB rtype res = QAnd ( QEqual RType (capitalizeRT rtype) : mkSE res ) where mkSE (RAndSearch a b) = [QAnd (mkSE a ++ mkSE b)] mkSE (ROrSearch a b) = [QOr (mkSE a ++ mkSE b)] @@ -425,6 +532,9 @@ mkFld "title" = RTitle mkFld z = RParameter z +-- | Checks whether a given 'Resource' matches a 'RSearchExpression'. Note +-- that the expression doesn't check for type, so you must filter the +-- resources by type beforehand, if needs be. checkSearchExpression :: RSearchExpression -> Resource -> Bool checkSearchExpression RAlwaysTrue _ = True checkSearchExpression (RAndSearch a b) r = checkSearchExpression a r && checkSearchExpression b r @@ -442,11 +552,8 @@ Nothing -> False Just x -> puppetEquality x v -{--------------------------------------- -- Higher order functions part -----------------------------------------} - --- | Generates associations for evaluation of blocks +-- | Generates variable associations for evaluation of blocks. Each item +-- corresponds to an iteration in the calling block. hfGenerateAssociations :: HFunctionCall -> InterpreterMonad [[(T.Text, PValue)]] hfGenerateAssociations hf = do sourceexpression <- case hf ^. hfexpr of @@ -467,11 +574,15 @@ (invalid, _) -> throwPosError ("Can't iterate on this data type:" <+> pretty invalid) -- | Sets the proper variables, and returns the scope variables the way --- they were before being modified. +-- they were before being modified. This is a hack that ensures that +-- variables are local to the new scope. +-- +-- It doesn't work at all like other Puppet parts, but consistency isn't +-- really expected here ... hfSetvars :: [(T.Text, PValue)] -> InterpreterMonad (Container (Pair (Pair PValue PPosition) CurContainerDesc)) hfSetvars vals = do - scp <- getScope + scp <- getScopeName p <- use curPos container <- getCurContainer save <- use (scopes . ix scp . scopeVariables) @@ -479,14 +590,14 @@ mapM_ hfSetvar vals return save --- | Restores what needs restoring. This will erase all allocation. +-- | Restores what needs restoring. This will erase all allocations. hfRestorevars :: Container (Pair (Pair PValue PPosition) CurContainerDesc) -> InterpreterMonad () hfRestorevars save = do - scp <- getScope + scp <- getScopeName scopes . ix scp . scopeVariables .= save --- | Evaluates a statement in "pure" mode. +-- | Evaluates a statement in "pure" mode. TODO evalPureStatement :: Statement -> InterpreterMonad () evalPureStatement = undefined diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs --- a/Puppet/Interpreter/Types.hs +++ b/Puppet/Interpreter/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveGeneric, TemplateHaskell, CPP, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-} +{-# LANGUAGE DeriveGeneric, TemplateHaskell, CPP, ScopedTypeVariables, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase, FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Puppet.Interpreter.Types where @@ -15,7 +15,8 @@ import qualified Data.Text.Encoding as T import qualified Data.Vector as V import Data.Tuple.Strict -import Control.Monad.RWS.Strict hiding ((<>)) +import Control.Monad.Trans.RSS.Strict +import Control.Monad.Writer hiding ((<>)) import Control.Monad.Error import Control.Lens import Data.String (IsString(..)) @@ -31,6 +32,7 @@ import Control.Applicative hiding (empty) import Data.Time.Clock import GHC.Stack +import Data.Maybe (fromMaybe) #ifdef HRUBY import Foreign.Ruby @@ -51,6 +53,14 @@ | PHash !(Container PValue) deriving (Eq, Show) +-- | The different kind of hiera queries +data HieraQueryType = Priority -- ^ standard hiera query + | ArrayMerge -- ^ hiera_array + | HashMerge -- ^ hiera_hash + +-- | The type of the Hiera API function +type HieraQueryFunc = Container ScopeInformation -> T.Text -> HieraQueryType -> IO (S.Either Doc (Pair InterpreterWriter (S.Maybe PValue))) + data RSearchExpression = REqualitySearch !T.Text !PValue | RNonEqualitySearch !T.Text !PValue @@ -93,8 +103,12 @@ , _defPos :: !PPosition } -data CurContainerDesc = ContRoot | ContClass !T.Text | ContDefine !T.Text !T.Text | ContImported - deriving Eq +data CurContainerDesc = ContRoot -- ^ Contained at node or root level + | ContClass !T.Text -- ^ Contained in a class + | ContDefine !T.Text !T.Text -- ^ Contained in a define + | ContImported !CurContainerDesc -- ^ Dummy container for imported resources, so that we know we must update the nodename + | ContImport !Nodename !CurContainerDesc -- ^ This one is used when finalizing imported resources, and contains the current node name + deriving (Eq, Generic, Ord) data CurContainer = CurContainer { _cctype :: !CurContainerDesc , _cctags :: !(HS.HashSet T.Text) @@ -117,8 +131,8 @@ data InterpreterState = InterpreterState { _scopes :: !(Container ScopeInformation) , _loadedClasses :: !(Container (Pair ClassIncludeType PPosition)) - , _definedResources :: !(HM.HashMap RIdentifier PPosition) - , _curScope :: ![Scope] + , _definedResources :: !(HM.HashMap RIdentifier Resource) + , _curScope :: ![CurContainerDesc] , _curPos :: !PPosition , _nestedDeclarations :: !(HM.HashMap (TopLevelType, T.Text) Statement) , _extraRelations :: ![LinkInformation] @@ -131,23 +145,24 @@ , _pdbAPI :: PuppetDBAPI , _externalFunctions :: Container ( [PValue] -> InterpreterMonad PValue ) , _thisNodename :: T.Text + , _hieraQuery :: HieraQueryFunc } -data Warning = Warning !Doc +newtype Warning = Warning Doc -data InterpreterWriter = InterpreterWriter { _warnings :: ![Pair Priority Doc] } +type InterpreterLog = Pair Priority Doc +type InterpreterWriter = [InterpreterLog] -warn :: Doc -> InterpreterMonad () -warn d = tell (InterpreterWriter [WARNING :!: d]) +warn :: (Monad m, MonadWriter InterpreterWriter m) => Doc -> m () +warn d = tell [WARNING :!: d] -logWriter :: Priority -> Doc -> InterpreterMonad () -logWriter prio d = tell (InterpreterWriter [prio :!: d]) +debug :: (Monad m, MonadWriter InterpreterWriter m) => Doc -> m () +debug d = tell [DEBUG :!: d] -instance Monoid InterpreterWriter where - mempty = InterpreterWriter [] - mappend (InterpreterWriter a) (InterpreterWriter b) = {-# SCC "mappendInterpreterWriter" #-} InterpreterWriter (a ++ b) +logWriter :: (Monad m, MonadWriter InterpreterWriter m) => Priority -> Doc -> m () +logWriter prio d = tell [prio :!: d] -type InterpreterMonad = ErrorT Doc (RWST InterpreterReader InterpreterWriter InterpreterState IO) +type InterpreterMonad = ErrorT Doc (RSST InterpreterReader InterpreterWriter InterpreterState IO) instance Error Doc where noMsg = empty @@ -169,7 +184,7 @@ data OverrideType = CantOverride -- ^ Overriding forbidden, will throw an error | Replace -- ^ Can silently replace - | CantReplace + | CantReplace -- ^ Silently ignore errors data ResourceCollectorType = RealizeVirtual | RealizeCollected @@ -200,12 +215,11 @@ , _ralias :: !(HS.HashSet T.Text) -- ^ All the resource aliases , _rattributes :: !(Container PValue) -- ^ Resource parameters. , _rrelations :: !(HM.HashMap RIdentifier (HS.HashSet LinkType)) -- ^ Resource relations. - , _rscope :: ![T.Text] -- ^ Resource scope when it was defined - , _rcontainer :: !CurContainerDesc -- ^ The class that contains this resource + , _rscope :: ![CurContainerDesc] -- ^ Resource scope when it was defined, the real container will be the first item , _rvirtuality :: !Virtuality , _rtags :: !(HS.HashSet T.Text) , _rpos :: !PPosition -- ^ Source code position of the resource definition. - , _rnode :: !(Maybe T.Text) -- ^ The node were this resource was created, if remote + , _rnode :: !Nodename -- ^ The node were this resource was created, if remote } deriving Eq @@ -303,6 +317,9 @@ makeFields ''PFactInfo makeFields ''PNodeInfo +rcurcontainer :: Resource -> CurContainerDesc +rcurcontainer r = fromMaybe ContRoot (r ^? rscope . _head) + throwPosError :: Doc -> InterpreterMonad a throwPosError s = do p <- use (curPos . _1) @@ -315,12 +332,22 @@ getCurContainer :: InterpreterMonad CurContainer {-# INLINE getCurContainer #-} getCurContainer = do - scp <- getScope + scp <- getScopeName preuse (scopes . ix scp . scopeContainer) >>= \case Just x -> return x - Nothing -> throwPosError ("Internal error: can't find the current container for" <+> string (show scp)) + Nothing -> throwPosError ("Internal error: can't find the current container for" <+> green (string (T.unpack scp))) -getScope :: InterpreterMonad Scope +scopeName :: CurContainerDesc -> T.Text +scopeName (ContRoot ) = "::" +scopeName (ContImported x ) = "::imported::" `T.append` scopeName x +scopeName (ContClass x ) = x +scopeName (ContDefine dt dn) = "#define/" `T.append` dt `T.append` "/" `T.append` dn +scopeName (ContImport _ x ) = "::import::" `T.append` scopeName x + +getScopeName :: InterpreterMonad T.Text +getScopeName = fmap scopeName getScope + +getScope :: InterpreterMonad CurContainerDesc {-# INLINE getScope #-} getScope = use curScope >>= \s -> if null s then throwPosError "Internal error: empty scope!" @@ -355,10 +382,16 @@ 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)) + where + check (S.Left r) = return (S.Left r) + check (S.Right x) = return (S.Right x) + interpreterIO :: IO (S.Either Doc a) -> InterpreterMonad a {-# INLINE interpreterIO #-} interpreterIO f = do - liftIO (f `catch` (\e -> return $ S.Left $ dullred $ text $ show (e :: SomeException))) >>= \case + liftIO (eitherDocIO f) >>= \case S.Right x -> return x S.Left rr -> throwPosError rr @@ -416,7 +449,11 @@ rel2text RSubscribe = "subscribe" rid2text :: RIdentifier -> T.Text -rid2text (RIdentifier t n) = t `T.append` "[" `T.append` n `T.append` "]" +rid2text (RIdentifier t n) = capitalizeRT t `T.append` "[" `T.append` capn `T.append` "]" + where + capn = if t == "classe" + then capitalizeRT n + else n instance ToJSON Resource where toJSON r = object [ ("type", String $ r ^. rid . itype) @@ -443,21 +480,34 @@ let virtuality = if isExported then Exported else Normal + getResourceIdentifier :: PValue -> Maybe RIdentifier + getResourceIdentifier (PString x) = + let (restype, brckts) = T.breakOn "[" x + rna | T.null brckts = Nothing + | T.null restype = Nothing + | T.last brckts == ']' = Just (T.tail (T.init brckts)) + | otherwise = Nothing + in case rna of + Just resname -> Just (RIdentifier (T.toLower restype) (T.toLower resname)) + _ -> Nothing + getResourceIdentifier _ = Nothing -- TODO : properly handle metaparameters separate :: (Container PValue, HM.HashMap RIdentifier (HS.HashSet LinkType)) -> T.Text -> PValue -> (Container PValue, HM.HashMap RIdentifier (HS.HashSet LinkType)) - separate (curAttribs, curRelations) k val = (curAttribs & at k ?~ val, curRelations) + separate (curAttribs, curRelations) k val = case (fromJSON (String k), getResourceIdentifier val) of + (Success rel, Just ri) -> (curAttribs, curRelations & at ri . non mempty . contains rel .~ True) + _ -> (curAttribs & at k ?~ val, curRelations) (attribs,relations) <- HM.foldlWithKey' separate (mempty,mempty) <$> v .: "parameters" + contimport <- v .:? "certname" .!= "unknown" Resource - <$> (RIdentifier <$> v .: "type" <*> v .: "title") + <$> (RIdentifier <$> fmap T.toLower (v .: "type") <*> v .: "title") <*> v .:? "aliases" .!= mempty <*> pure attribs <*> pure relations - <*> pure ["JSON"] - <*> pure ContImported + <*> pure [ContImport contimport ContRoot] <*> pure virtuality <*> v .: "tags" - <*> (toPPos <$> v .:? "sourcefile" .!= "dummy" <*> v .:? "sourceline" .!= 0) - <*> pure Nothing + <*> (toPPos <$> v .:? "sourcefile" .!= "null" <*> v .:? "sourceline" .!= 0) + <*> pure contimport parseJSON _ = mempty diff --git a/Puppet/Manifests.hs b/Puppet/Manifests.hs --- a/Puppet/Manifests.hs +++ b/Puppet/Manifests.hs @@ -19,14 +19,14 @@ -- TODO pre-triage stuff filterStatements :: TopLevelType -> T.Text -> V.Vector Statement -> IO (S.Either Doc Statement) -- the most complicated case, node matching -filterStatements TopNode nodename stmts = +filterStatements TopNode ndename stmts = -- this operation should probably get cached let (!spurious, !directnodes, !regexpmatches, !defaultnode) = V.foldl' triage (V.empty, HM.empty, V.empty, Nothing) stmts triage curstuff n@(Node (NodeName !nm) _ _ _) = curstuff & _2 . at nm ?~ n triage curstuff n@(Node (NodeMatch _ !rg) _ _ _) = curstuff & _3 %~ (|> (rg :!: n)) triage curstuff n@(Node NodeDefault _ _ _) = curstuff & _4 ?~ n triage curstuff x = curstuff & _1 %~ (|> x) - bsnodename = T.encodeUtf8 nodename + bsnodename = T.encodeUtf8 ndename checkRegexp :: [Pair Regex Statement] -> ErrorT Doc IO (Maybe Statement) checkRegexp [] = return Nothing checkRegexp ((regexp :!: s):xs) = do @@ -36,14 +36,14 @@ Right (Just _) -> return (Just s) strictEither (Left x) = S.Left x strictEither (Right x) = S.Right x - in case directnodes ^. at nodename of -- check if there is a node specifically called after my name + in case directnodes ^. at ndename of -- check if there is a node specifically called after my name Just r -> return (S.Right (TopContainer spurious r)) Nothing -> fmap strictEither $ runErrorT $ do 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 nodename) -filterStatements x nodename stmts = + Nothing -> throwError ("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 triage curstuff n@(DefineDeclaration cname _ _ _) = curstuff & _2 . at cname ?~ n @@ -54,9 +54,9 @@ in case x of TopNode -> return (S.Left "Case already covered, shoudln't happen in Puppet.Manifests") TopSpurious -> return (S.Left "Should not ask for a TopSpurious!!!") - TopDefine -> case defines ^. at nodename of + TopDefine -> case defines ^. at ndename of Just n -> return (S.Right (tc n)) - Nothing -> return (S.Left ("Couldn't find define " <+> ttext nodename)) - TopClass -> case classes ^. at nodename of + Nothing -> return (S.Left ("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 nodename)) + Nothing -> return (S.Left ("Couldn't find class " <+> ttext ndename)) diff --git a/Puppet/NativeTypes/Cron.hs b/Puppet/NativeTypes/Cron.hs --- a/Puppet/NativeTypes/Cron.hs +++ b/Puppet/NativeTypes/Cron.hs @@ -19,8 +19,8 @@ parameterfunctions :: [(T.Text, [T.Text -> PuppetTypeValidate])] parameterfunctions = - [("command" , [string, mandatory]) - ,("ensure" , [defaultvalue "present", string, values ["present","absent"]]) + [("ensure" , [defaultvalue "present", string, values ["present","absent"]]) + ,("command" , [string, mandatoryIfNotAbsent]) ,("environment" , []) ,("hour" , [vrange 0 23 [] ]) ,("minute" , [vrange 0 59 [] ]) diff --git a/Puppet/NativeTypes/File.hs b/Puppet/NativeTypes/File.hs --- a/Puppet/NativeTypes/File.hs +++ b/Puppet/NativeTypes/File.hs @@ -37,7 +37,7 @@ ,("replace" , [string, values ["true","false"]]) ,("sourceselect", [values ["first","all"]]) ,("target" , [string]) - ,("source" , []) + ,("source" , [rarray, strings, flip runarray checkSource]) ] validateFile :: PuppetTypeValidate @@ -63,3 +63,9 @@ in if source && content then Left "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) diff --git a/Puppet/NativeTypes/Group.hs b/Puppet/NativeTypes/Group.hs --- a/Puppet/NativeTypes/Group.hs +++ b/Puppet/NativeTypes/Group.hs @@ -18,7 +18,7 @@ [("allowdupe" , [string, defaultvalue "false", values ["true","false"]]) ,("attribute_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]]) ,("attributes" , [strings]) - ,("auth_membership" , [defaultvalue "true"]) + ,("auth_membership" , [defaultvalue "minimum", string, values ["inclusive","minimum"]]) ,("ensure" , [defaultvalue "present", string, values ["present","absent"]]) ,("gid" , [integer]) ,("ia_load_module" , [string]) diff --git a/Puppet/NativeTypes/Helpers.hs b/Puppet/NativeTypes/Helpers.hs --- a/Puppet/NativeTypes/Helpers.hs +++ b/Puppet/NativeTypes/Helpers.hs @@ -20,9 +20,11 @@ , integer , integers , mandatory + , mandatoryIfNotAbsent , inrange , faketype , defaulttype + , runarray ) where import Puppet.PP hiding (string,integer) @@ -64,15 +66,14 @@ keyset = HS.fromList $ HM.keys (res ^. rattributes) setdiff = HS.difference keyset (metaparameters `HS.union` validparameters) --- | This validator always accept the resources, but add the default parameters --- (such as title). +-- | This validator always accept the resources, but add the default parameters (to be defined :) addDefaults :: PuppetTypeValidate addDefaults res = Right (res & rattributes %~ newparams) where def PUndef = False def _ = True newparams p = HM.filter def $ HM.union p defaults - defaults = HM.fromList [("title", PString (res ^. rid ^. iname))] + defaults = HM.empty -- | Helper function that runs a validor on a PArray runarray :: T.Text -> (T.Text -> PValue -> PuppetTypeValidate) -> PuppetTypeValidate @@ -141,6 +142,14 @@ Just (PString al) -> Right (res & rid . iname .~ al) Just x -> Left ("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 +mandatoryIfNotAbsent :: T.Text -> PuppetTypeValidate +mandatoryIfNotAbsent param res = case res ^. rattributes . at param of + Just _ -> Right res + Nothing -> case res ^. rattributes . at "ensure" of + Just "absent" -> Right res + _ -> Left $ "Parameter" <+> paramname param <+> "should be set." -- | Checks that a given parameter is set. mandatory :: T.Text -> PuppetTypeValidate diff --git a/Puppet/NativeTypes/User.hs b/Puppet/NativeTypes/User.hs --- a/Puppet/NativeTypes/User.hs +++ b/Puppet/NativeTypes/User.hs @@ -17,7 +17,7 @@ [("allowdupe" , [string, defaultvalue "false", values ["true","false"]]) ,("attribute_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]]) ,("attributes" , [rarray,strings]) - ,("auth_membership" , [defaultvalue "true"]) + ,("auth_membership" , [defaultvalue "minimum", string, values ["inclusive","minimum"]]) ,("auths" , [rarray,strings]) ,("comment" , [string]) ,("ensure" , [defaultvalue "present", string, values ["present","absent","role"]]) diff --git a/Puppet/Parser/Types.hs b/Puppet/Parser/Types.hs --- a/Puppet/Parser/Types.hs +++ b/Puppet/Parser/Types.hs @@ -1,5 +1,37 @@ {-# LANGUAGE DeriveGeneric, TemplateHaskell #-} -module Puppet.Parser.Types where +-- | All the types used for parsing, and helpers working on these types. +module Puppet.Parser.Types + ( -- * Position management + Position, + PPosition, + initialPPos, + toPPos, + -- ** Lenses + lSourceName, + lSourceLine, + lSourceColumn, + -- * Helpers + capitalize', + capitalizeRT, + array, + toBool, + -- * Types + -- ** Expressions + Expression(..), + SelectorCase(..), + UValue(..), + HigherFuncType(..), + HFunctionCall(..), + HasHFunctionCall(..), + BlockParameters(..), + CollectorType(..), + Virtuality(..), + NodeDesc(..), + -- ** Search Expressions + SearchExpression(..), + -- ** Statements + Statement(..) + ) where import qualified Data.Text as T import qualified Data.Vector as V @@ -20,20 +52,34 @@ capitalize' t | T.null t = T.empty | otherwise = T.cons (toUpper (T.head t)) (T.tail t) +-- | A pair containing the start and end of a given token. type PPosition = Pair Position Position +-- | Position in a puppet file. Currently an alias to 'SourcePos'. type Position = SourcePos +lSourceName :: Lens' Position SourceName +lSourceName = lens sourceName setSourceName + +lSourceLine :: Lens' Position Line +lSourceLine = lens sourceLine setSourceLine + +lSourceColumn :: Lens' Position Column +lSourceColumn = lens sourceColumn setSourceColumn + +-- | Generates an initial position based on a filename. initialPPos :: T.Text -> PPosition initialPPos x = let i = initialPos (T.unpack x) in (i :!: i) +-- | Generates a 'PPosition' based on a filename and line number. toPPos :: T.Text -> Int -> PPosition toPPos fl ln = let p = newPos (T.unpack fl) ln (-1) in (p :!: p) +-- | The distinct Puppet /higher order functions/ data HigherFuncType = HFEach | HFMap | HFReduce @@ -41,11 +87,13 @@ | HFSlice deriving Eq -data BlockParameters = BPSingle !T.Text - | BPPair !T.Text !T.Text +-- | Currently only two types of block parameters are supported, single +-- values and pairs. +data BlockParameters = BPSingle !T.Text -- ^ @|k|@ + | BPPair !T.Text !T.Text -- ^ @|k,v|@ deriving Eq --- used for the each/filter/etc. "higher level functions" +-- The description of the /higher level function/ call. data HFunctionCall = HFunctionCall { _hftype :: !HigherFuncType , _hfexpr :: !(S.Maybe Expression) , _hfparams :: !BlockParameters @@ -54,20 +102,21 @@ } deriving Eq +-- | An unresolved value, typically the parser's output. data UValue - = UBoolean !Bool - | UString !T.Text - | UInterpolable !(V.Vector UValue) - | UUndef - | UResourceReference !T.Text !Expression + = UBoolean !Bool -- ^ Special tokens generated when parsing the @true@ or @false@ literals. + | UString !T.Text -- ^ Raw string. + | UInterpolable !(V.Vector UValue) -- ^ A string that might contain variable references. The type should be refined at one point. + | UUndef -- ^ Special token that is generated when parsing the @undef@ literal. + | UResourceReference !T.Text !Expression -- ^ A Resource[reference] | UArray !(V.Vector Expression) | UHash !(V.Vector (Pair Expression Expression)) - | URegexp !T.Text !Regex + | URegexp !T.Text !Regex -- ^ The regular expression compilation is performed during parsing. | UVariableReference !T.Text | UFunctionCall !T.Text !(V.Vector Expression) | UHFunctionCall !HFunctionCall --- manual instance because of the Regex problem +-- The Eq instance is manual, because of the 'Regex' comparison problem instance Eq UValue where (==) (UBoolean a) (UBoolean b) = a == b (==) (UString a) (UString b) = a == b @@ -81,6 +130,7 @@ (==) (UFunctionCall a1 a2) (UFunctionCall b1 b2) = (a1 == b1) && (a2 == b2) (==) _ _ = False +-- | A helper function for writing 'array's. array :: [Expression] -> UValue array = UArray . V.fromList @@ -88,6 +138,7 @@ | SelectorDefault deriving (Eq) +-- | The 'Expression's data Expression = Equal !Expression !Expression | Different !Expression !Expression @@ -110,8 +161,8 @@ | LeftShift !Expression !Expression | Lookup !Expression !Expression | Negate !Expression - | ConditionalValue !Expression !(V.Vector (Pair SelectorCase Expression)) - | FunctionApplication !Expression !Expression + | 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) @@ -126,6 +177,7 @@ data CollectorType = Collector | ExportedCollector deriving (Eq) +-- | Tries to turn an unresolved value into a 'Bool' without any context. toBool :: UValue -> Bool toBool (UString "") = False toBool (UInterpolable v) = not (V.null v) @@ -133,7 +185,10 @@ toBool (UBoolean x) = x toBool _ = True -data Virtuality = Normal | Virtual | Exported | ExportedRealized +data Virtuality = Normal -- ^ Normal resource, that will be included in the catalog + | Virtual -- ^ Type for virtual resources + | Exported -- ^ Type for exported resources + | ExportedRealized -- ^ These are resources that are exported AND included in the catalog deriving (Generic, Eq) data NodeDesc = NodeName !T.Text @@ -146,20 +201,21 @@ (==) (NodeMatch a _) (NodeMatch b _) = a == b (==) _ _ = False +-- | All the possible statements data Statement = ResourceDeclaration !T.Text !Expression !(V.Vector (Pair T.Text Expression)) !Virtuality !PPosition | DefaultDeclaration !T.Text !(V.Vector (Pair T.Text Expression)) !PPosition | ResourceOverride !T.Text !Expression !(V.Vector (Pair T.Text Expression)) !PPosition - | ConditionalStatement !(V.Vector (Pair Expression (V.Vector Statement))) !PPosition + | ConditionalStatement !(V.Vector (Pair Expression (V.Vector Statement))) !PPosition -- ^ All types of conditional statements are stored that way (@case@, @if@, etc.) | ClassDeclaration !T.Text !(V.Vector (Pair T.Text (S.Maybe Expression))) !(S.Maybe T.Text) !(V.Vector Statement) !PPosition | DefineDeclaration !T.Text !(V.Vector (Pair T.Text (S.Maybe Expression))) !(V.Vector Statement) !PPosition | Node !NodeDesc !(V.Vector Statement) !(S.Maybe NodeDesc) !PPosition | VariableAssignment !T.Text !Expression !PPosition | MainFunctionCall !T.Text !(V.Vector Expression) !PPosition - | SHFunctionCall !HFunctionCall !PPosition - | ResourceCollection !CollectorType !T.Text !SearchExpression !(V.Vector (Pair T.Text Expression)) !PPosition + | SHFunctionCall !HFunctionCall !PPosition -- ^ /Higher order function/ call. + | ResourceCollection !CollectorType !T.Text !SearchExpression !(V.Vector (Pair T.Text Expression)) !PPosition -- ^ For all types of collectors. | Dependency !(Pair T.Text Expression) !(Pair T.Text Expression) !PPosition - | TopContainer !(V.Vector Statement) !Statement + | TopContainer !(V.Vector Statement) !Statement -- ^ This is a special statement that is used to include the expressions that are top level. This is certainly buggy, but probably just like the original implementation. deriving Eq makeClassy ''HFunctionCall diff --git a/Puppet/Preferences.hs b/Puppet/Preferences.hs --- a/Puppet/Preferences.hs +++ b/Puppet/Preferences.hs @@ -22,6 +22,7 @@ , _prefPDB :: PuppetDBAPI , _natTypes :: Container PuppetTypeMethods -- ^ The list of native types. , _prefExtFuncs :: Container ( [PValue] -> InterpreterMonad PValue ) + , _hieraPath :: Maybe FilePath } makeClassy ''Preferences @@ -34,4 +35,4 @@ templatedir = basedir <> "/templates" typenames <- fmap (map takeBaseName) (getFiles (T.pack modulesdir) "lib/puppet/type" ".rb") let loadedTypes = HM.fromList (map defaulttype typenames) - return $ Preferences manifestdir modulesdir templatedir 4 4 dummyPuppetDB (baseNativeTypes `HM.union` loadedTypes) (stdlibFunctions) + return $ Preferences manifestdir modulesdir templatedir 4 4 dummyPuppetDB (baseNativeTypes `HM.union` loadedTypes) (stdlibFunctions) (Just (basedir <> "/hiera.yaml")) diff --git a/Puppet/Stats.hs b/Puppet/Stats.hs --- a/Puppet/Stats.hs +++ b/Puppet/Stats.hs @@ -1,7 +1,9 @@ {-| A quickly done module that exports utility functions used to collect various statistics. All statistics are stored in a MVar holding a HashMap. + +This is not accurate in the presence of lazy evaluation. Nothing is forced. -} -module Puppet.Stats where +module Puppet.Stats (measure, measure_, newStats, getStats, StatsTable, StatsPoint(..), MStats) where import Data.Time.Clock.POSIX (getPOSIXTime) import Control.Monad @@ -10,20 +12,32 @@ import qualified Data.Text as T import Control.Lens -data StatsPoint = StatsPoint !Int !Double !Double !Double - deriving(Show) +data StatsPoint = StatsPoint { _statspointCount :: !Int -- ^ Total number of calls to a computation + , _statspointTotal :: !Double -- ^ Total time spent during this computation + , _statspointMin :: !Double -- ^ Minimum execution time + , _statspointMax :: !Double -- ^ Maximum execution time + } deriving(Show) + +-- | A table where keys are the names of the computations, and values are +-- 'StatsPoint's. type StatsTable = HM.HashMap T.Text StatsPoint -type MStats = MVar StatsTable +newtype MStats = MStats { unMStats :: MVar StatsTable } +-- | Returns the actual statistical values. getStats :: MStats -> IO StatsTable -getStats = readMVar +getStats = readMVar . unMStats +-- | Create a new statistical container. newStats :: IO MStats -newStats = newMVar HM.empty +newStats = MStats `fmap` newMVar HM.empty -measure :: MStats -> T.Text -> IO a -> IO a -measure mtable statsname action = do +-- | Wraps a computation, and measures related execution statistics. +measure :: MStats -- ^ Statistics container + -> T.Text -- ^ Action identifier + -> IO a -- ^ Computation + -> IO a +measure (MStats mtable) statsname action = do (!tm, !out) <- time action !stats <- takeMVar mtable let nstats :: StatsTable @@ -40,6 +54,7 @@ putMVar mtable nstats return out +-- | Just like 'measure', discarding the result value. measure_ :: MStats -> T.Text -> IO a -> IO () measure_ mtable statsname action = void ( measure mtable statsname action ) diff --git a/Puppet/Stdlib.hs b/Puppet/Stdlib.hs --- a/Puppet/Stdlib.hs +++ b/Puppet/Stdlib.hs @@ -19,6 +19,7 @@ import Data.Attoparsec.Number import qualified Data.ByteString.Base16 as B16 +-- | Contains the implementation of the StdLib functions. stdlibFunctions :: Container ( [PValue] -> InterpreterMonad PValue ) stdlibFunctions = HM.fromList [ singleArgument "abs" puppetAbs , ("any2array", any2array) @@ -34,6 +35,7 @@ , ("delete_at", deleteAt) , singleArgument "delete_undef_values" deleteUndefValues , ("downcase", stringArrayFunction T.toLower) + , singleArgument "flatten" flatten , singleArgument "getvar" getvar , ("getparam", const $ throwPosError "The getparam function is uncool and shall not be implemented in language-puppet") , singleArgument "is_array" isArray @@ -43,8 +45,10 @@ , ("lstrip", stringArrayFunction T.stripStart) , ("merge", merge) , ("rstrip", stringArrayFunction T.stripEnd) + , singleArgument "str2bool" str2Bool , ("strip", stringArrayFunction T.strip) , ("upcase", stringArrayFunction T.toUpper) + , ("validate_absolute_path", validateAbsolutePath) , ("validate_array", validateArray) , ("validate_bool", validateBool) , ("validate_hash", validateHash) @@ -165,6 +169,14 @@ deleteUndefValues (PHash h) = return $ PHash $ HM.filter (/= PUndef) h deleteUndefValues x = throwPosError ("delete_undef_values(): Expects an Array or a Hash, not" <+> pretty x) +flatten :: PValue -> InterpreterMonad PValue +flatten r@(PArray _) = return $ PArray (flatten' r) + where + flatten' :: PValue -> V.Vector PValue + flatten' (PArray x) = V.concatMap flatten' x + flatten' x = V.singleton x +flatten x = throwPosError ("flatten(): Expects an Array, not" <+> pretty x) + getvar :: PValue -> InterpreterMonad PValue getvar = resolvePValueString >=> resolveVariable @@ -197,6 +209,25 @@ 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" + +str2Bool :: PValue -> InterpreterMonad PValue +str2Bool PUndef = return (PBoolean False) +str2Bool a@(PBoolean _) = return a +str2Bool a = do + s <- resolvePValueString a + let b | s `elem` ["", "1", "t", "y", "true", "yes"] = Just True + | s `elem` [ "0", "f", "n", "false", "no"] = Just False + | otherwise = Nothing + case b of + Just x -> return (PBoolean x) + Nothing -> throwPosError "str2bool(): Unknown type of boolean given" + +validateAbsolutePath :: [PValue] -> InterpreterMonad PValue +validateAbsolutePath [] = throwPosError "validateAbsolutePath(): wrong number of arguments, must be > 0" +validateAbsolutePath a = mapM_ (resolvePValueString >=> validate) a >> return PUndef + where + validate x | T.head x == '/' = return () + | otherwise = throwPosError (ttext x <+> "is not an absolute path") validateArray :: [PValue] -> InterpreterMonad PValue validateArray [] = throwPosError "validate_array(): wrong number of arguments, must be > 0" diff --git a/Puppet/Testing.hs b/Puppet/Testing.hs --- a/Puppet/Testing.hs +++ b/Puppet/Testing.hs @@ -1,11 +1,13 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, LambdaCase #-} module Puppet.Testing ( module Control.Lens , module Data.Monoid , module Puppet.PP , module Puppet.Interpreter.Types + , H.hspec , basicTest , testingDaemon + , defaultDaemon , testCatalog , describeCatalog , it @@ -13,7 +15,6 @@ ) where import Prelude hiding (notElem,all) -import Control.Monad.RWS.Strict hiding ((<>)) import Control.Lens import Data.Foldable hiding (forM_) import Data.Maybe @@ -29,6 +30,8 @@ import qualified Test.Hspec.Formatters as H import qualified Test.Hspec.Runner as H import qualified Test.Hspec.Core as HC +import Facter +import PuppetDB.Common import Puppet.Preferences import Puppet.PP @@ -94,14 +97,21 @@ -- | Initializes a daemon made for running tests, using the specific test -- puppetDB -testingDaemon :: Maybe T.Text -- ^ Might contain the URL of the actual PuppetDB, used for getting facts. +testingDaemon :: PuppetDBAPI -- ^ 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))) -testingDaemon purl pdir allFacts = do +testingDaemon pdb pdir allFacts = do LOG.updateGlobalLogger "Puppet.Daemon" (LOG.setLevel LOG.WARNING) prefs <- genPreferences pdir - q <- initDaemon (prefs { _compilePoolSize = 8, _parsePoolSize = 2 }) + q <- initDaemon (prefs { _compilePoolSize = 8, _parsePoolSize = 2, _prefPDB = pdb }) return (\nodname -> allFacts nodname >>= _dGetCatalog q nodname) +-- | A default testing daemon. +defaultDaemon :: FilePath -> IO (T.Text -> IO (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog))) +defaultDaemon pdir = do + pdb <- getDefaultDB PDBTest >>= \case + S.Left x -> error (show x) + S.Right y -> return y + testingDaemon pdb pdir (flip puppetDBFacts pdb) diff --git a/PuppetDB/Common.hs b/PuppetDB/Common.hs --- a/PuppetDB/Common.hs +++ b/PuppetDB/Common.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +-- | Common data types for PuppetDB. module PuppetDB.Common where import Puppet.PP @@ -14,7 +15,11 @@ import qualified Data.Either.Strict as S import Data.Vector.Lens -data PDBType = PDBRemote | PDBDummy | PDBTest +-- | The supported PuppetDB implementations. +data PDBType = PDBRemote -- ^ Your standard PuppetDB, queried through the HTTP interface. + | PDBDummy -- ^ A stupid stub, this is the default choice. + | PDBTest -- ^ A slow but handy PuppetDB implementation that is backed by a YAML file. + deriving Eq instance Read PDBType where readsPrec _ r | isJust reml = [(PDBRemote, fromJust reml)] @@ -32,6 +37,7 @@ tstl = stripPrefix "PDBTest" r tsts = stripPrefix "test" r +-- | Given a 'PDBType', will try return a sane default implementation. getDefaultDB :: PDBType -> IO (S.Either Doc PuppetDBAPI) getDefaultDB PDBDummy = return (S.Right dummyPuppetDB) getDefaultDB PDBRemote = pdbConnect "http://localhost:8080" @@ -39,6 +45,8 @@ Just h -> loadTestDB (h ++ "/.testdb") Nothing -> fmap S.Right initTestDB +-- | Turns a 'FinalCatalog' and 'EdgeMap' into a document that can be +-- serialized and fed to @puppet apply@. generateWireCatalog :: Nodename -> FinalCatalog -> EdgeMap -> WireCatalog generateWireCatalog ndename finalcat edgemap = WireCatalog ndename "version" edges resources "uiid" where diff --git a/PuppetDB/Dummy.hs b/PuppetDB/Dummy.hs --- a/PuppetDB/Dummy.hs +++ b/PuppetDB/Dummy.hs @@ -1,3 +1,5 @@ +-- | A dummy implementation of 'PuppetDBAPI', that will return empty +-- responses. module PuppetDB.Dummy where import Puppet.Interpreter.Types diff --git a/PuppetDB/Remote.hs b/PuppetDB/Remote.hs --- a/PuppetDB/Remote.hs +++ b/PuppetDB/Remote.hs @@ -1,5 +1,5 @@ {-# LANGUAGE LambdaCase #-} -module PuppetDB.Remote where +module PuppetDB.Remote (pdbConnect) where import Puppet.Utils import Puppet.PP @@ -43,6 +43,7 @@ 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) pdbConnect url = return $ S.Right $ PuppetDBAPI (return (ttext url)) diff --git a/PuppetDB/TestDB.hs b/PuppetDB/TestDB.hs --- a/PuppetDB/TestDB.hs +++ b/PuppetDB/TestDB.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, LambdaCase #-} +-- | A stub implementation of PuppetDB, backed by a YAML file. module PuppetDB.TestDB (loadTestDB,initTestDB) where --- import Data.Aeson import Data.Yaml import qualified Data.Text as T import qualified Data.Either.Strict as S @@ -14,7 +14,6 @@ import Data.List (foldl') import Text.Parsec.Pos import Data.CaseInsensitive -import Debug.Trace import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS @@ -32,7 +31,13 @@ type DB = TVar DBContent instance FromJSON DBContent where - parseJSON (Object v) = DBContent <$> v .: "resources" <*> v .: "facts" <*> pure Nothing + 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 _ = mempty instance ToJSON DBContent where @@ -43,10 +48,15 @@ loadTestDB fp = decodeFileEither fp >>= \case Left (OtherParseException rr) -> return (S.Left (string (show rr))) - Left rr -> trace ("Warning: could not decode " ++ fp ++ " :" ++ show rr) (S.Right <$> genDBAPI (newDB & backingFile ?~ fp )) + Left (InvalidYaml Nothing) -> baseError "Unknown error" + Left (InvalidYaml (Just (YamlException s))) -> baseError (string s) + Left (InvalidYaml (Just (YamlParseException pb ctx (YamlMark _ l c)))) -> baseError $ red (string pb <+> string ctx) <+> "at line" <+> int l <> ", column" <+> int c + Left _ -> S.Right <$> genDBAPI (newDB & backingFile ?~ fp ) Right x -> fmap S.Right (genDBAPI (x & backingFile ?~ fp )) - + where + baseError r = return $ S.Left $ "Could not parse" <+> string fp <> ":" <+> r +-- | Starts a new PuppetDB, without any backing file. initTestDB :: IO PuppetDBAPI initTestDB = genDBAPI newDB @@ -133,9 +143,7 @@ resourceQuery :: ResourceField -> Resource -> Extracted resourceQuery RTag r = r ^. rtags . to ESet -resourceQuery RCertname r = case r ^. rnode of - Just t -> EText t - Nothing -> ENil +resourceQuery RCertname r = r ^. rnode . to EText resourceQuery (RParameter p) r = case r ^? rattributes . ix p . _PString of Just s -> EText s Nothing -> ENil diff --git a/language-puppet.cabal b/language-puppet.cabal --- a/language-puppet.cabal +++ b/language-puppet.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet -version: 0.10.2 +version: 0.10.3 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/ @@ -41,6 +41,7 @@ , Puppet.NativeTypes , Puppet.NativeTypes.Helpers , Puppet.Interpreter + , Puppet.Interpreter.Resolve , SafeProcess , Puppet.Stdlib , Puppet.Testing @@ -48,6 +49,7 @@ , PuppetDB.TestDB , PuppetDB.Dummy , PuppetDB.Common + , Hiera.Server other-modules: Text.Parser.Parsec , Puppet.Utils , Puppet.NativeTypes.File @@ -56,7 +58,6 @@ , Erb.Ruby , Erb.Evaluate , Erb.Compute - , Puppet.Interpreter.Resolve , Puppet.Manifests , Puppet.NativeTypes.ZoneRecord , Puppet.NativeTypes.Cron @@ -112,6 +113,9 @@ , stm == 2.4.* , hspec >= 1.7.0 && <1.8.0 , yaml >= 0.8.0 && <0.9 + , lens-aeson >= 0.1.2 && <0.2 + , stateWriter == 0.2.* + Test-Suite test-lexer hs-source-dirs: tests type: exitcode-stdio-1.0 @@ -126,13 +130,30 @@ extensions: OverloadedStrings build-depends: language-puppet,base,text,parsec,vector,ansi-wl-pprint main-is: expr.hs +Test-Suite test-hiera + hs-source-dirs: tests + type: exitcode-stdio-1.0 + ghc-options: -Wall -rtsopts -threaded + extensions: OverloadedStrings + build-depends: language-puppet,base,hspec,temporary,strict-base-types,HUnit,lens,vector,unordered-containers,text + main-is: hiera.hs +Test-Suite test-puppetdb + hs-source-dirs: tests + type: exitcode-stdio-1.0 + ghc-options: -Wall -rtsopts -threaded + extensions: OverloadedStrings + build-depends: language-puppet,base,temporary,strict-base-types,lens,text + main-is: puppetdb.hs + + + executable puppetresources hs-source-dirs: progs extensions: BangPatterns, OverloadedStrings ghc-options: -Wall -rtsopts -threaded 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 + 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 main-is: PuppetResources.hs executable pdbquery diff --git a/progs/PuppetResources.hs b/progs/PuppetResources.hs --- a/progs/PuppetResources.hs +++ b/progs/PuppetResources.hs @@ -112,11 +112,13 @@ import qualified Text.Parsec as P import qualified Data.Vector as V import qualified Data.Either.Strict as S -import Options.Applicative as O +import Options.Applicative as O hiding ((&)) import Control.Monad import Text.Regex.PCRE.String import Data.Text.Strict.Lens --- import Data.Aeson +import Data.Aeson (encode) +import Data.Yaml (decodeFileEither) +import Control.Lens as L import Facter @@ -128,6 +130,7 @@ import Puppet.Parser import Puppet.Parser.PrettyPrinter() import Puppet.Interpreter.PrettyPrinter() +import Puppet.Interpreter.Resolve (_PString) import PuppetDB.Remote import PuppetDB.Dummy import PuppetDB.TestDB @@ -142,11 +145,11 @@ hackish as it will generate facts from the local computer ! -} -initializedaemonWithPuppet :: LOG.Priority -> PuppetDBAPI -> FilePath -> IO (T.Text -> IO (FinalCatalog, EdgeMap, FinalCatalog)) -initializedaemonWithPuppet prio pdbapi puppetdir = do +initializedaemonWithPuppet :: LOG.Priority -> PuppetDBAPI -> FilePath -> Maybe FilePath -> (Facts -> Facts) -> IO (T.Text -> IO (FinalCatalog, EdgeMap, FinalCatalog)) +initializedaemonWithPuppet prio pdbapi puppetdir hierapath overrideFacts = do LOG.updateGlobalLogger "Puppet.Daemon" (LOG.setLevel prio) - q <- fmap (prefPDB .~ pdbapi) (genPreferences puppetdir) >>= initDaemon - let f ndename = puppetDBFacts ndename pdbapi + q <- fmap ((prefPDB .~ pdbapi) . (hieraPath .~ hierapath)) (genPreferences puppetdir) >>= initDaemon + let f ndename = fmap overrideFacts (puppetDBFacts ndename pdbapi) >>= _dGetCatalog q ndename >>= \case S.Left rr -> putDoc rr >> putStrLn "" >> error "error!" @@ -174,10 +177,55 @@ , _nodename :: Maybe String , _pdbfile :: Maybe FilePath , _loglevel :: LOG.Priority + , _hieraFile :: Maybe FilePath + , _factsFile :: Maybe FilePath + , _factsDef :: Maybe FilePath } deriving Show +prepareForPuppetApply :: WireCatalog -> WireCatalog +prepareForPuppetApply w = + let res = V.filter (\r -> r ^. rvirtuality == Normal) (w ^. wResources) :: V.Vector Resource + -- step 1 : capitalize resources types (and names in case of + -- classes), and filter out exported stuff + capi :: RIdentifier -> RIdentifier + capi r = r & itype %~ capitalizeRT & if r ^. itype == "class" + then iname %~ capitalizeRT + else id + aliasMap :: HM.HashMap RIdentifier T.Text + aliasMap = HM.fromList $ concatMap genAliasList (res ^.. folded) + genAliasList r = map (\n -> (RIdentifier (r ^. rid . itype) n, r ^. rid . iname)) (r ^. rid . iname : r ^.. ralias . folded) + nr = V.map (rid %~ capi) res + ne = V.map capEdge (w ^. wEdges) + capEdge (PuppetEdge a b x) = PuppetEdge (capi a) (capi b) x + -- step 2 : replace all references with the resource title in case + -- of aliases - yes this sucks + knownEdge :: PuppetEdge -> Bool + knownEdge (PuppetEdge s d _) = (aliasMap ^. contains s) && (aliasMap ^. contains d) + correctEdges = V.map correctEdge $ V.filter knownEdge ne + correctResources = V.map correctResource nr + correct :: RIdentifier -> RIdentifier + correct ri = ri & iname %~ \n -> HM.lookupDefault n ri aliasMap + correctEdge :: PuppetEdge -> PuppetEdge + correctEdge (PuppetEdge s d x) = PuppetEdge (correct s) (correct d) x + correctResource :: Resource -> Resource + correctResource r = r & rrelations %~ HM.fromList . filter (\(x,_) -> aliasMap ^. contains x) . map (_1 %~ correct) . HM.toList + in (wResources .~ correctResources) + . (wEdges .~ correctEdges) + $ w + cmdlineParser :: Parser CommandLine -cmdlineParser = CommandLine <$> optional remotepdb <*> sj <*> sc <*> optional (T.pack <$> rt) <*> optional (T.pack <$> rn) <*> pdir <*> optional nn <*> optional pdbfile <*> priority +cmdlineParser = CommandLine <$> optional remotepdb + <*> sj + <*> sc + <*> optional (T.pack <$> rt) + <*> optional (T.pack <$> rn) + <*> pdir + <*> optional nn + <*> optional pdbfile + <*> priority + <*> optional hiera + <*> optional fcts + <*> optional fco where sc = switch ( long "showcontent" <> short 'c' @@ -201,16 +249,36 @@ <> help "Node name") pdbfile = strOption ( long "pdbfile" <> help "Path to the testing PuppetDB file.") + hiera = strOption ( long "hiera" + <> help "Path to the Hiera configuration file (default hiera.yaml)" + <> value "hiera.yaml" + ) priority = option ( long "loglevel" <> short 'v' <> help "Values are : DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY" <> value LOG.WARNING ) + fcts = strOption ( long "facts-override" + <> help "Path to a Yaml file containing a list of 'facts' that will override locally resolved facts" + ) + fco = strOption ( long "facts-defaults" + <> help "Path to a Yaml file containing a list of 'facts' that will be used as defaults" + ) + +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 + run :: CommandLine -> IO () -run (CommandLine _ _ _ _ _ f Nothing _ _) = parseFile f >>= \case +run (CommandLine _ _ _ _ _ f Nothing _ _ _ _ _) = parseFile f >>= \case Left rr -> error ("parse error:" ++ show rr) Right s -> putDoc (vcat (map pretty (V.toList s))) -run (CommandLine puppeturl showjson showcontent mrt mrn puppetdir (Just ndename) mpdbf prio) = do +run (CommandLine puppeturl showjson showcontent mrt mrn puppetdir (Just ndename) mpdbf prio hpath fcts fdef) = do let checkError r (S.Left rr) = error (show (red r <> ":" <+> rr)) checkError _ (S.Right x) = return x tnodename = T.pack ndename @@ -219,13 +287,19 @@ (Just _, Just _) -> error "You must choose between a testing PuppetDB and a remote one" (Just url, _) -> pdbConnect (T.pack url) >>= checkError "Error when connecting to the remote PuppetDB" (_, Just file) -> loadTestDB file >>= checkError "Error when initializing the PuppetDB API" - queryfunc <- initializedaemonWithPuppet prio pdbapi puppetdir + !factsOverrides <- case (fcts, fdef) of + (Just _, Just _) -> error "You can't use --facts-override and --facts-defaults at the same time" + (Just p, Nothing) -> HM.union `fmap` loadFactsOverrides p + (Nothing, Just p) -> (flip HM.union) `fmap` loadFactsOverrides p + (Nothing, Nothing) -> return id + queryfunc <- initializedaemonWithPuppet prio pdbapi puppetdir hpath factsOverrides printFunc <- hIsTerminalDevice stdout >>= \isterm -> return $ \x -> if isterm then putDoc x >> putStrLn "" else displayIO stdout (renderCompact x) >> putStrLn "" (rawcatalog,m,rawexported) <- queryfunc tnodename - void $ replaceCatalog pdbapi (generateWireCatalog tnodename (rawcatalog <> rawexported) m) + let wireCatalog = generateWireCatalog tnodename (rawcatalog <> rawexported) m + void $ replaceCatalog pdbapi wireCatalog void $ commitDB pdbapi let cmpMatch Nothing _ curcat = return curcat cmpMatch (Just rg) lns curcat = compile compBlank execBlank (T.unpack rg) >>= \case @@ -238,8 +312,8 @@ filterCatalog = cmpMatch mrt (_1 . itype . unpacked) >=> cmpMatch mrn (_1 . iname . unpacked) catalog <- filterCatalog rawcatalog exported <- filterCatalog rawexported - case (showcontent, showjson) of - (_, True) -> BSL.putStrLn ("TODO JSON MODE") + case (showcontent, showjson) of + (_, True) -> BSL.putStrLn (encode (prepareForPuppetApply wireCatalog)) (True, _) -> do unless (mrt == Just "file" || mrt == Nothing) (error $ "Show content only works for file, not for " ++ show mrt) case mrn of diff --git a/progs/pdbQuery.hs b/progs/pdbQuery.hs --- a/progs/pdbQuery.hs +++ b/progs/pdbQuery.hs @@ -5,6 +5,7 @@ import PuppetDB.Common import PuppetDB.TestDB import PuppetDB.Remote +import Facter import Options.Applicative as O import qualified Data.Text as T @@ -14,7 +15,7 @@ import qualified Data.Either.Strict as S import Control.Lens import qualified Data.HashMap.Strict as HM -import Control.Monad (forM_) +import Control.Monad (forM_,unless) import qualified Data.Vector as V data CommandLine = CommandLine { _pdbloc :: Maybe FilePath @@ -28,6 +29,7 @@ | DeactivateNode T.Text | DumpResources T.Text | CreateTestDB FilePath + | AddFacts T.Text factedit :: Parser Command factedit = EditFact <$> O.argument (Just . T.pack) mempty <*> O.argument (Just . T.pack) mempty @@ -41,6 +43,9 @@ createtestdb :: Parser Command createtestdb = CreateTestDB <$> O.argument Just mempty +addfacts :: Parser Command +addfacts = AddFacts <$> O.argument (Just . T.pack) mempty + cmdlineParser :: Parser CommandLine cmdlineParser = CommandLine <$> optional pl <*> pt <*> cmd where @@ -59,6 +64,7 @@ <> 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) ) display :: (Show r, ToJSON a) => String -> S.Either r a -> IO () @@ -74,12 +80,17 @@ pdbapi <- case epdbapi of S.Left r -> error (show r) S.Right x -> return x + let getOrError s (S.Left rr) = error (s <> " " <> show rr) + getOrError _ (S.Right x) = return x case _pdbcmd cmdl of DumpFacts -> getFacts pdbapi QEmpty >>= display "get facts" DumpNodes -> getNodes pdbapi QEmpty >>= display "dump nodes" + AddFacts n -> do + unless (_pdbtype cmdl == PDBTest) (error "This option only works with the test puppetdb") + fcts <- puppetDBFacts n pdbapi + replaceFacts pdbapi [(n, fcts)] >>= getOrError "replace facts" + commitDB pdbapi >>= getOrError "commit db" CreateTestDB destfile -> do - let getOrError s (S.Left rr) = error (s <> " " <> show rr) - getOrError _ (S.Right x) = return x ndb <- loadTestDB destfile >>= getOrError "puppetdb load" allnodes <- getNodes pdbapi QEmpty >>= getOrError "get nodes" allfacts <- getFacts pdbapi QEmpty >>= getOrError "get facts" diff --git a/ruby/calcerb.rb b/ruby/calcerb.rb --- a/ruby/calcerb.rb +++ b/ruby/calcerb.rb @@ -7,6 +7,10 @@ @context = ctx end + def [](key) + lookupvar(key) + end + def lookupvar(name) if name.start_with?("::") name = name[2..-1] diff --git a/ruby/hrubyerb.rb b/ruby/hrubyerb.rb --- a/ruby/hrubyerb.rb +++ b/ruby/hrubyerb.rb @@ -7,6 +7,10 @@ @variables = variables end + def [](key) + lookupvar(key) + end + def vl(name) if name.start_with?("::") name = name[2..-1] diff --git a/tests/hiera.hs b/tests/hiera.hs new file mode 100644 --- /dev/null +++ b/tests/hiera.hs @@ -0,0 +1,59 @@ +module Main where + +import Test.Hspec +import System.IO.Temp +import Hiera.Server +import Data.Monoid +import qualified Data.Either.Strict as S +import qualified Data.Maybe.Strict as S +import Data.Tuple.Strict +import Test.HUnit +import qualified Data.Vector as V +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)) + ] + 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")) + ] + pusers = HM.fromList [ ("bob", PHash (HM.singleton "uid" "100")) + , ("tom" , PHash (HM.singleton "uid" "12")) + ] + Right rq <- 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 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") + describe "json backend" $ do + it "resolves in json" $ q newscope "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"]))) + 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))) + diff --git a/tests/lexer.hs b/tests/lexer.hs --- a/tests/lexer.hs +++ b/tests/lexer.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} module Main where import Control.Monad diff --git a/tests/puppetdb.hs b/tests/puppetdb.hs new file mode 100644 --- /dev/null +++ b/tests/puppetdb.hs @@ -0,0 +1,45 @@ +module Main where + +import Control.Monad +import System.IO.Temp +import Data.Monoid +import qualified Data.Either.Strict as S +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Control.Lens + +import Puppet.Interpreter.Types +import PuppetDB.Common +import PuppetDB.TestDB +import Facter + +checkError :: Show x => String -> S.Either x a -> IO a +checkError _ (S.Right x) = return x +checkError step (S.Left rr) = error (step ++ ": " ++ show rr) + +main :: IO () +main = withSystemTempDirectory "hieratest" $ \tmpfp -> do + let ndname = "node.site.com" + pdbfile = tmpfp <> "/puppetdb.yaml" + -- generate an empty puppetdb + pdb <- loadTestDB pdbfile >>= checkError "loadTestDB" + -- get some dummy facts + facts <- puppetDBFacts ndname pdb + -- and add a custom fact + let nfacts = facts & at "customfact" ?~ "MyCustomFactValue" + -- save the facts + replaceFacts pdb [(ndname, nfacts)] >>= checkError "replaceFacts" + commitDB pdb >>= checkError "commitDB" + -- check that our custom fact was indeed saved + dblines <- T.lines `fmap` T.readFile pdbfile + unless (" customfact: MyCustomFactValue" `elem` dblines) (error "could not find my fact") + -- now we initiate a new puppetdbapi + fpdb <- loadTestDB pdbfile >>= checkError "loadTestDB" + ffacts <- puppetDBFacts ndname pdb + unless (ffacts == nfacts) (error "facts are distinct") + replaceCatalog fpdb (generateWireCatalog ndname mempty mempty) >>= checkError "replaceCatalog" + commitDB fpdb >>= checkError "commit 2" + -- and check for our facts again + fdblines <- T.lines `fmap` T.readFile pdbfile + unless (" customfact: MyCustomFactValue" `elem` fdblines) (error "could not find my fact") +