language-puppet 1.1.5.1 → 1.2
raw patch · 18 files changed
+193/−122 lines, 18 filesdep +http-api-datadep +http-clientdep ~basedep ~eitherdep ~megaparsec
Dependencies added: http-api-data, http-client
Dependency ranges changed: base, either, megaparsec, mtl, servant, servant-client, transformers
Files
- CHANGELOG.markdown +10/−0
- Erb/Compute.hs +2/−1
- Facter.hs +2/−2
- Puppet/Interpreter.hs +16/−3
- Puppet/Interpreter/IO.hs +10/−10
- Puppet/Interpreter/Resolve.hs +12/−1
- Puppet/Interpreter/Types.hs +18/−18
- Puppet/Parser.hs +4/−4
- Puppet/Parser/Types.hs +6/−6
- Puppet/Stdlib.hs +17/−1
- PuppetDB/Common.hs +5/−2
- PuppetDB/Dummy.hs +3/−3
- PuppetDB/Remote.hs +20/−17
- PuppetDB/TestDB.hs +12/−12
- language-puppet.cabal +18/−10
- progs/PuppetResources.hs +21/−18
- progs/pdbQuery.hs +14/−11
- tests/puppetdb.hs +3/−3
CHANGELOG.markdown view
@@ -1,3 +1,13 @@+#v1.2 (2016/05/31)++## New features+* `validate_numeric` function+* Preliminary implementation of variable captures in regexp matches+* Ready for GHC 8 and corresponding stackage nightly++## Bugs fixed+* Fixed a deadlock when template code called the `template` or `inline_template` functions. It just stops now :(+ # v1.1.5.1 (2016/03/14) ## New features
Erb/Compute.hs view
@@ -176,7 +176,8 @@ let err :: String -> IO RValue err rr = fmap (either Prelude.snd id) (FR.toRuby (T.pack rr) >>= FR.safeMethodCall "MyError" "new" . (:[])) case (,) <$> efname <*> eargs of- Right (fname, varray) -> do+ Right (fname, varray) | fname `elem` ["template", "inline_template"] -> err "Can't call template from a Ruby function, as this will stall (yes it sucks ...)"+ | otherwise -> do let args = case varray of [PArray vargs] -> V.toList vargs _ -> varray
Facter.hs view
@@ -16,7 +16,7 @@ import System.Environment import System.Directory (doesFileExist) import Data.Maybe (mapMaybe)-import Control.Monad.Trans.Either+import Control.Monad.Trans.Except storageunits :: [(String, Int)] storageunits = [ ("", 0), ("K", 1), ("M", 2), ("G", 3), ("T", 4) ]@@ -169,7 +169,7 @@ puppetDBFacts :: NodeName -> PuppetDBAPI IO -> IO (Container PValue) puppetDBFacts node pdbapi =- runEitherT (getFacts pdbapi (QEqual FCertname node)) >>= \case+ runExceptT (getFacts pdbapi (QEqual FCertname node)) >>= \case Right facts@(_:_) -> return (HM.fromList (map (\f -> (f ^. factInfoName, f ^. factInfoVal)) facts)) _ -> do rawFacts <- fmap concat (sequence [factNET, factRAM, factOS, fversion, factMountPoints, factOS, factUser, factUName, fenv, factProcessor])
Puppet/Interpreter.hs view
@@ -12,6 +12,7 @@ import Control.Monad.Except import Control.Monad.Operational hiding (view) import Control.Monad.Trans.Except+import Data.Char (isDigit) import qualified Data.Either.Strict as S import Data.Foldable (foldl', foldlM, toList) import qualified Data.Graph as G@@ -358,6 +359,17 @@ pv <- resolveExpression v return (acc & at k ?~ pv) +saveCaptureVariables :: InterpreterMonad (HM.HashMap T.Text (Pair (Pair PValue PPosition) CurContainerDesc))+saveCaptureVariables = do+ scp <- getScopeName+ vars <- use (scopes . ix scp . scopeVariables)+ return $ HM.filterWithKey (\k _ -> T.all isDigit k) vars++restoreCaptureVariables :: HM.HashMap T.Text (Pair (Pair PValue PPosition) CurContainerDesc) -> InterpreterMonad ()+restoreCaptureVariables vars = do+ scp <- getScopeName+ scopes . ix scp . scopeVariables %= HM.union vars . HM.filterWithKey (\k _ -> not (T.all isDigit k))+ evaluateStatement :: Statement -> InterpreterMonad [Resource] evaluateStatement r@(ClassDeclaration (ClassDecl cname _ _ _ _)) = if "::" `T.isInfixOf` cname@@ -427,10 +439,11 @@ curPos .= p let checkCond [] = return [] checkCond ((e :!: stmts) : xs) = do+ sv <- saveCaptureVariables result <- pValue2Bool <$> resolveExpression e if result- then evaluateStatementsFoldable stmts- else checkCond xs+ then evaluateStatementsFoldable stmts <* restoreCaptureVariables sv+ else restoreCaptureVariables sv *> checkCond xs checkCond (toList conds) evaluateStatement (ResourceDefaultDeclaration (ResDefaultDecl rtype decls p)) = do curPos .= p@@ -747,7 +760,7 @@ (!classtags, !defaultLink) = getClassTags cnt getClassTags (ContClass cn ) = (allsegs cn,RIdentifier "class" cn) getClassTags (ContDefine dt dn _) = (allsegs dt,normalizeRIdentifier dt dn)- getClassTags (ContRoot ) = ([],RIdentifier "class" "::")+ getClassTags ContRoot = ([],RIdentifier "class" "::") getClassTags (ContImported _ ) = ([],RIdentifier "class" "::") getClassTags (ContImport _ _ ) = ([],RIdentifier "class" "::") defaultRelation = HM.singleton defaultLink (HS.singleton RRequire)
Puppet/Interpreter/IO.hs view
@@ -15,7 +15,7 @@ import Control.Lens import Control.Monad.Operational import Control.Monad.State.Strict-import Control.Monad.Trans.Either+import Control.Monad.Trans.Except import qualified Data.Either.Strict as S import Data.Monoid import qualified Data.Text as T@@ -67,7 +67,7 @@ canFail iof = iof >>= \case S.Left err -> thpe err S.Right x -> runInstr x- canFailE iof = runEitherT iof >>= \case+ canFailX iof = runExceptT iof >>= \case Left err -> thpe err Right x -> runInstr x logStuff x c = (_3 %~ (x <>)) <$> c@@ -89,14 +89,14 @@ GetNodeName -> runInstr (r ^. readerNodename) HieraQuery scps q t -> canFail ((r ^. readerHieraQuery) scps q t) PDBInformation -> pdbInformation pdb >>= runInstr- PDBReplaceCatalog w -> canFailE (replaceCatalog pdb w)- PDBReplaceFacts fcts -> canFailE (replaceFacts pdb fcts)- PDBDeactivateNode nn -> canFailE (deactivateNode pdb nn)- PDBGetFacts q -> canFailE (getFacts pdb q)- PDBGetResources q -> canFailE (getResources pdb q)- PDBGetNodes q -> canFailE (getNodes pdb q)- PDBCommitDB -> canFailE (commitDB pdb)- PDBGetResourcesOfNode nn q -> canFailE (getResourcesOfNode pdb nn q)+ PDBReplaceCatalog w -> canFailX (replaceCatalog pdb w)+ PDBReplaceFacts fcts -> canFailX (replaceFacts pdb fcts)+ PDBDeactivateNode nn -> canFailX (deactivateNode pdb nn)+ PDBGetFacts q -> canFailX (getFacts pdb q)+ PDBGetResources q -> canFailX (getResources pdb q)+ PDBGetNodes q -> canFailX (getNodes pdb q)+ PDBCommitDB -> canFailX (commitDB pdb)+ PDBGetResourcesOfNode nn q -> canFailX (getResourcesOfNode pdb nn q) GetCurrentCallStack -> (r ^. readerIoMethods . ioGetCurrentCallStack) >>= runInstr ReadFile fls -> strFail ((r ^. readerIoMethods . ioReadFile) fls) (const $ PrettyError ("No file found in " <> list (map ttext fls))) TraceEvent e -> (r ^. readerIoMethods . ioTraceEvent) e >>= runInstr
Puppet/Interpreter/Resolve.hs view
@@ -11,6 +11,7 @@ resolveExpression, resolveValue, resolvePValueString,+ resolvePValueNumber, resolveExpressionString, resolveExpressionStrings, resolveFunction',@@ -220,7 +221,17 @@ case execute' rv ra of Left (_,rr) -> throwPosError ("Error when evaluating" <+> pretty v <+> ":" <+> string rr) Right Nothing -> return $ PBoolean False- Right (Just _) -> return $ PBoolean True+ Right (Just matches) -> do+ -- A bit of logic to save the capture variables.+ -- Note that this will pollute the namespace, as it should only+ -- happen in conditional expressions ...+ p <- use curPos+ ctype <- view cctype <$> getCurContainer+ let captures = Prelude.zip (map (T.pack . show) [(0 :: Int)..]) (map mkMatch (F.toList matches))+ mkMatch (offset, len) = PString (T.decodeUtf8 (BS.take len (BS.drop offset ra))) :!: p :!: ctype+ scp <- getScopeName+ scopes . ix scp . scopeVariables %= HM.union (HM.fromList captures)+ return $ PBoolean True resolveExpression (RegexMatch _ t) = throwPosError ("The regexp matching operator expects a regular expression, not" <+> pretty t) resolveExpression (NotRegexMatch a v) = resolveExpression (Not (RegexMatch a v)) resolveExpression (Equal a b) = do
Puppet/Interpreter/Types.hs view
@@ -85,7 +85,6 @@ import Control.Monad.Except import Control.Monad.Operational import Control.Monad.State.Strict-import Control.Monad.Trans.Either import Control.Monad.Writer.Class import Data.Aeson as A import Data.Aeson.Lens@@ -97,9 +96,9 @@ import Data.Monoid import Data.Scientific import Data.String (IsString (..))-import Data.Text (Text)+import Data.Text (Text) import qualified Data.Text as T-import qualified Data.Text.Encoding as T+import Data.Text.Encoding (decodeUtf8) import Data.Time.Clock import qualified Data.Traversable as TR import Data.Tuple.Strict@@ -108,9 +107,9 @@ import GHC.Generics hiding (to) import GHC.Stack import qualified Scripting.Lua as Lua-import Servant.Common.Text import qualified System.Log.Logger as LOG import Text.Megaparsec.Pos+import Web.HttpApiData (ToHttpApiData(..)) import Puppet.Parser.PrettyPrinter import Puppet.Parser.Types@@ -434,14 +433,14 @@ data PuppetDBAPI m = PuppetDBAPI { pdbInformation :: m Doc- , replaceCatalog :: WireCatalog -> EitherT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-catalog-version-3>- , replaceFacts :: [(NodeName, Facts)] -> EitherT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-facts-version-1>- , deactivateNode :: NodeName -> EitherT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#deactivate-node-version-1>- , getFacts :: Query FactField -> EitherT PrettyError m [FactInfo] -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/facts.html#get-v3facts>- , getResources :: Query ResourceField -> EitherT PrettyError m [Resource] -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/resources.html#get-v3resources>- , getNodes :: Query NodeField -> EitherT PrettyError m [NodeInfo]- , commitDB :: EitherT PrettyError m () -- ^ This is only here to tell the test PuppetDB to save its content to disk.- , getResourcesOfNode :: NodeName -> Query ResourceField -> EitherT PrettyError m [Resource]+ , replaceCatalog :: WireCatalog -> ExceptT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-catalog-version-3>+ , replaceFacts :: [(NodeName, Facts)] -> ExceptT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#replace-facts-version-1>+ , deactivateNode :: NodeName -> ExceptT PrettyError m () -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/commands.html#deactivate-node-version-1>+ , getFacts :: Query FactField -> ExceptT PrettyError m [FactInfo] -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/facts.html#get-v3facts>+ , getResources :: Query ResourceField -> ExceptT PrettyError m [Resource] -- ^ <http://docs.puppetlabs.com/puppetdb/1.5/api/query/v3/resources.html#get-v3resources>+ , getNodes :: Query NodeField -> ExceptT PrettyError m [NodeInfo]+ , commitDB :: ExceptT PrettyError m () -- ^ This is only here to tell the test PuppetDB to save its content to disk.+ , getResourcesOfNode :: NodeName -> Query ResourceField -> ExceptT PrettyError m [Resource] } -- | Pretty straightforward way to define the various PuppetDB queries@@ -550,8 +549,8 @@ , ("exported", Bool $ r ^. rvirtuality == Exported) , ("tags", toJSON $ r ^. rtags) , ("parameters", Object ( HM.map toJSON (r ^. rattributes) `HM.union` relations ))- , ("sourceline", r ^. rpos . _1 . to sourceLine . to toJSON)- , ("sourcefile", r ^. rpos . _1 . to sourceName . to toJSON)+ , ("sourceline", r ^. rpos . _1 . lSourceLine . to (toJSON . unPos))+ , ("sourcefile", r ^. rpos . _1 . lSourceName . to toJSON) ] where relations = r ^. rrelations & HM.fromListWith (V.++) . concatMap changeRelations . HM.toList & HM.map toValue@@ -600,7 +599,7 @@ <*> pure [ContImport contimport ContRoot] <*> pure virtuality <*> v .: "tags"- <*> (toPPos <$> v .:? "sourcefile" .!= "null" <*> v .:? "sourceline" .!= 0)+ <*> (toPPos <$> v .:? "sourcefile" .!= "null" <*> v .:? "sourceline" .!= 1) <*> pure contimport parseJSON _ = mempty@@ -615,10 +614,11 @@ toJSON (QG flds val) = toJSON [ ">", toJSON flds, toJSON val ] toJSON (QLE flds val) = toJSON [ "<=", toJSON flds, toJSON val ] toJSON (QGE flds val) = toJSON [ ">=", toJSON flds, toJSON val ]- toJSON (QEmpty) = Null+ toJSON QEmpty = Null -instance ToJSON a => ToText (Query a) where- toText = T.decodeUtf8 . Control.Lens.view strict . encode+instance ToJSON a => ToHttpApiData (Query a) where+ toHeader = Control.Lens.view strict . encode+ toUrlPiece = decodeUtf8 . toHeader instance FromJSON a => FromJSON (Query a) where parseJSON Null = pure QEmpty
Puppet/Parser.hs view
@@ -29,7 +29,7 @@ import Puppet.Utils -- | Run a puppet parser against some 'T.Text' input.-runPParser :: String -> T.Text -> Either ParseError (V.Vector Statement)+runPParser :: String -> T.Text -> Either (ParseError Char Dec) (V.Vector Statement) runPParser = parse puppetParser someSpace :: Parser ()@@ -105,7 +105,7 @@ stringLiteral' :: Parser T.Text stringLiteral' = char '\'' *> interior <* symbolic '\'' where- interior = T.pack . concat <$> many (some (noneOf "'\\") <|> (char '\\' *> fmap escape anyChar))+ interior = T.pack . concat <$> many (some (noneOf ['\'', '\\']) <|> (char '\\' *> fmap escape anyChar)) escape '\'' = "'" escape x = ['\\',x] @@ -181,7 +181,7 @@ ( many (interpolableVariableReference <|> doubleQuotedStringContent <|> fmap (Terminal . UString . T.singleton) (char '$')) ) where doubleQuotedStringContent = Terminal . UString . T.pack . concat <$>- some ((char '\\' *> fmap stringEscape anyChar) <|> some (noneOf "\"\\$"))+ some ((char '\\' *> fmap stringEscape anyChar) <|> some (noneOf [ '"', '\\', '$' ])) stringEscape :: Char -> String stringEscape 'n' = "\n" stringEscape 't' = "\t"@@ -213,7 +213,7 @@ regexp :: Parser T.Text regexp = do void (char '/')- T.pack . concat <$> many ( do { void (char '\\') ; x <- anyChar; return ['\\', x] } <|> some (noneOf "/\\") )+ T.pack . concat <$> many ( do { void (char '\\') ; x <- anyChar; return ['\\', x] } <|> some (noneOf [ '/', '\\' ]) ) <* symbolic '/' puppetArray :: Parser UnresolvedValue
Puppet/Parser/Types.hs view
@@ -83,13 +83,13 @@ type Position = SourcePos lSourceName :: Lens' Position String-lSourceName = lens sourceName setSourceName+lSourceName = lens sourceName (\s n -> s { sourceName = n }) -lSourceLine :: Lens' Position Int-lSourceLine = lens sourceLine setSourceLine+lSourceLine :: Lens' Position Pos+lSourceLine = lens sourceLine (\s l -> s { sourceLine = l }) -lSourceColumn :: Lens' Position Int-lSourceColumn = lens sourceColumn setSourceColumn+lSourceColumn :: Lens' Position Pos+lSourceColumn = lens sourceColumn (\s c -> s { sourceColumn = c }) -- | Generates an initial position based on a filename. initialPPos :: Text -> PPosition@@ -100,7 +100,7 @@ -- | Generates a 'PPosition' based on a filename and line number. toPPos :: Text -> Int -> PPosition toPPos fl ln =- let p = newPos (T.unpack fl) ln (-1)+ let p = (initialPos (T.unpack fl)) { sourceLine = unsafePos $ fromIntegral (max 1 ln) } in (p :!: p) -- | High Order "lambdas"
Puppet/Stdlib.hs view
@@ -135,7 +135,7 @@ -- validate_ip_address -- validate_ipv4_address -- validate_ipv6_address- -- validate_numeric+ , ("validate_numeric", validateNumeric) , ("validate_re", validateRe) -- validate_slength , ("validate_string", validateString)@@ -436,6 +436,22 @@ where vb (PHash _) = return () vb y = throwPosError (pretty y <+> "is not a hash.")++validateNumeric :: [PValue] -> InterpreterMonad PValue+validateNumeric [] = throwPosError "validate_numeric: invalid arguments"+validateNumeric (arr:extra) = do+ (mn, mx) <- case extra of+ [mx'] -> (Nothing,) . Just <$> resolvePValueNumber mx'+ [PUndef, mi'] -> (,Nothing) . Just <$> resolvePValueNumber mi'+ [mx',mi'] -> (,) <$> (Just <$> resolvePValueNumber mi') <*> (Just <$> resolvePValueNumber mx')+ [] -> pure (Nothing, Nothing)+ _ -> throwPosError "validate_numeric: invalid arguments"+ numbers <- case arr of+ PArray lst -> mapM resolvePValueNumber (V.toList lst)+ _ -> pure <$> resolvePValueNumber arr+ forM_ mn $ \mn' -> unless (all (>= mn') numbers) $ throwPosError "validate_numeric: failure"+ forM_ mx $ \mx' -> unless (all (<= mx') numbers) $ throwPosError "validate_numeric: failure"+ return PUndef validateRe :: [PValue] -> InterpreterMonad PValue validateRe [str, reg] = validateRe [str, reg, PString "Match failed"]
PuppetDB/Common.hs view
@@ -13,6 +13,7 @@ import System.Environment import Data.Vector.Lens import Servant.Common.BaseUrl+import Network.HTTP.Client -- | The supported PuppetDB implementations. data PDBType = PDBRemote -- ^ Your standard PuppetDB, queried through the HTTP interface.@@ -39,8 +40,10 @@ -- | Given a 'PDBType', will try return a sane default implementation. getDefaultDB :: PDBType -> IO (Either PrettyError (PuppetDBAPI IO)) getDefaultDB PDBDummy = return (Right dummyPuppetDB)-getDefaultDB PDBRemote = let Right url = parseBaseUrl "http://localhost:8080"- in pdbConnect url+getDefaultDB PDBRemote = do+ url <- parseBaseUrl "http://localhost:8080"+ mgr <- newManager defaultManagerSettings+ pdbConnect mgr url getDefaultDB PDBTest = lookupEnv "HOME" >>= \case Just h -> loadTestDB (h ++ "/.testdb") Nothing -> fmap Right initTestDB
PuppetDB/Dummy.hs view
@@ -3,7 +3,7 @@ module PuppetDB.Dummy where import Puppet.Interpreter.Types-import Control.Monad.Trans.Either+import Control.Monad.Except dummyPuppetDB :: Monad m => PuppetDBAPI m dummyPuppetDB = PuppetDBAPI@@ -11,9 +11,9 @@ (const (return ())) (const (return ())) (const (return ()))- (const (left "not implemented"))+ (const (throwError "not implemented")) (const (return [] )) (const (return [] ))- (left "not implemented")+ (throwError "not implemented") (\_ _ -> return [] )
PuppetDB/Remote.hs view
@@ -8,8 +8,11 @@ import Puppet.PP import Puppet.Interpreter.Types+import Network.HTTP.Client (Manager) import Data.Text (Text)-import Control.Monad.Trans.Either+import Control.Monad.Except+import Control.Monad.Trans.Except+import Control.Lens import Servant.API import Servant.Client import Data.Aeson@@ -26,26 +29,26 @@ api = Proxy -- | Given an URL (ie. @http://localhost:8080@), will return an incomplete 'PuppetDBAPI'.-pdbConnect :: BaseUrl -> IO (Either PrettyError (PuppetDBAPI IO))-pdbConnect url =+pdbConnect :: Manager -> BaseUrl -> IO (Either PrettyError (PuppetDBAPI IO))+pdbConnect mgr url = return $ Right $ PuppetDBAPI (return (string $ show url))- (const (left "operation not supported"))- (const (left "operation not supported"))- (const (left "operation not supported"))+ (const (throwError "operation not supported"))+ (const (throwError "operation not supported"))+ (const (throwError "operation not supported")) (q1 sgetFacts) (q1 sgetResources) (q1 sgetNodes)- (left "operation not supported")- (\ndename q -> prettyError $ sgetNodeResources ndename (Just q))+ (throwError "operation not supported")+ (\ndename q -> prettyError $ sgetNodeResources ndename (Just q) mgr url) where- sgetNodes :: Maybe (Query NodeField) -> EitherT ServantError IO [NodeInfo]- sgetNodeResources :: Text -> Maybe (Query ResourceField) -> EitherT ServantError IO [Resource]- sgetFacts :: Maybe (Query FactField) -> EitherT ServantError IO [FactInfo]- sgetResources :: Maybe (Query ResourceField) -> EitherT ServantError IO [Resource]- (sgetNodes :<|> sgetNodeResources :<|> sgetFacts :<|> sgetResources) = client api url+ sgetNodes :: Maybe (Query NodeField) -> Manager -> BaseUrl -> ClientM [NodeInfo]+ sgetNodeResources :: Text -> Maybe (Query ResourceField) -> Manager -> BaseUrl -> ClientM [Resource]+ sgetFacts :: Maybe (Query FactField) -> Manager -> BaseUrl -> ClientM [FactInfo]+ sgetResources :: Maybe (Query ResourceField) -> Manager -> BaseUrl -> ClientM [Resource]+ (sgetNodes :<|> sgetNodeResources :<|> sgetFacts :<|> sgetResources) = client api - prettyError :: EitherT ServantError IO b -> EitherT PrettyError IO b- prettyError = bimapEitherT (PrettyError . string. show) id- q1 :: (ToText a, FromJSON b) => (Maybe a -> EitherT ServantError IO b) -> a -> EitherT PrettyError IO b- q1 f = prettyError . f . Just+ prettyError :: ExceptT ServantError IO b -> ExceptT PrettyError IO b+ prettyError = mapExceptT (fmap (_Left %~ PrettyError . string. show))+ q1 :: FromJSON b => (Maybe a -> Manager -> BaseUrl -> ClientM b) -> a -> ExceptT PrettyError IO b+ q1 f a = prettyError (f (Just a) mgr url)
PuppetDB/TestDB.hs view
@@ -14,7 +14,7 @@ import Control.Exception import Control.Lens import Control.Monad.IO.Class-import Control.Monad.Trans.Either+import Control.Monad.Except import Data.Aeson.Lens import Data.CaseInsensitive import qualified Data.HashMap.Strict as HM@@ -119,18 +119,18 @@ _ -> False _ -> False -replCat :: DB -> WireCatalog -> EitherT PrettyError IO ()+replCat :: DB -> WireCatalog -> ExceptT PrettyError IO () replCat db wc = liftIO $ atomically $ modifyTVar db (resources . at (wc ^. wireCatalogNodename) ?~ wc) -replFacts :: DB -> [(NodeName, Facts)] -> EitherT PrettyError IO ()+replFacts :: DB -> [(NodeName, Facts)] -> ExceptT PrettyError IO () replFacts db lst = liftIO $ atomically $ modifyTVar db $ facts %~ (\r -> foldl' (\curr (n,f) -> curr & at n ?~ f) r lst) -deactivate :: DB -> NodeName -> EitherT PrettyError IO ()+deactivate :: DB -> NodeName -> ExceptT PrettyError IO () deactivate db n = liftIO $ atomically $ modifyTVar db $ (resources . at n .~ Nothing) . (facts . at n .~ Nothing) -getFcts :: DB -> Query FactField -> EitherT PrettyError IO [FactInfo]+getFcts :: DB -> Query FactField -> ExceptT PrettyError IO [FactInfo] getFcts db f = fmap (filter (resolveQuery factQuery f) . toFactInfo) (liftIO $ readTVarIO db) where toFactInfo :: DBContent -> [FactInfo]@@ -161,27 +161,27 @@ resourceQuery RFile r = r ^. rpos . _1 . to sourceName . to T.pack . to EText resourceQuery RLine r = r ^. rpos . _1 . to sourceLine . to show . to T.pack . to EText -getRes :: DB -> Query ResourceField -> EitherT PrettyError IO [Resource]+getRes :: DB -> Query ResourceField -> ExceptT PrettyError IO [Resource] getRes db f = fmap (filter (resolveQuery resourceQuery f) . toResources) (liftIO $ readTVarIO db) where toResources :: DBContent -> [Resource] toResources = concatMap (V.toList . view wireCatalogResources) . HM.elems . view resources -getResNode :: DB -> NodeName -> Query ResourceField -> EitherT PrettyError IO [Resource]+getResNode :: DB -> NodeName -> Query ResourceField -> ExceptT PrettyError IO [Resource] getResNode db nn f = do c <- liftIO $ readTVarIO db case c ^. resources . at nn of Just cnt -> return $ filter (resolveQuery resourceQuery f) $ V.toList $ cnt ^. wireCatalogResources- Nothing -> left "Unknown node"+ Nothing -> throwError "Unknown node" -commit :: DB -> EitherT PrettyError IO ()+commit :: DB -> ExceptT PrettyError IO () commit db = do dbc <- liftIO $ atomically $ readTVar db case dbc ^. backingFile of- Nothing -> left "No backing file defined"+ Nothing -> throwError "No backing file defined" Just bf -> liftIO (encodeFile bf dbc `catches` [ ]) -getNds :: DB -> Query NodeField -> EitherT PrettyError IO [NodeInfo]+getNds :: DB -> Query NodeField -> ExceptT PrettyError IO [NodeInfo] getNds db QEmpty = fmap toNodeInfo (liftIO $ readTVarIO db) where toNodeInfo :: DBContent -> [NodeInfo]@@ -190,4 +190,4 @@ g :: NodeName -> NodeInfo g = \n -> NodeInfo n False S.Nothing S.Nothing S.Nothing -getNds _ _ = left "getNds with query not implemented"+getNds _ _ = throwError "getNds with query not implemented"
language-puppet.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet-version: 1.1.5.1+version: 1.2 synopsis: Tools to parse and evaluate the Puppet DSL. description: This is a set of tools that is supposed to fill all your Puppet needs : syntax checks, catalog compilation, PuppetDB queries, simulationg of complex interactions between nodes, Puppet master replacement, and more ! homepage: http://lpuppet.banquise.net/@@ -15,6 +15,8 @@ build-type: Simple cabal-version: >=1.8 +Tested-With: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1+ extra-source-files: CHANGELOG.markdown README.adoc@@ -84,7 +86,7 @@ build-depends: aeson >= 0.8 , ansi-wl-pprint == 0.6.* , attoparsec >= 0.12- , base >=4.8 && < 4.9+ , base >=4.8 && < 5 , base16-bytestring == 0.1.* , bytestring , case-insensitive == 1.2.*@@ -96,15 +98,17 @@ , filecache >= 0.2.9 && < 0.3 , formatting , hashable == 1.2.*+ , http-api-data == 0.2.*+ , http-client == 0.4.* , hruby >= 0.3.2 && < 0.4 , hslogger == 1.2.* , hslua >= 0.4.1 && < 0.5 , hspec , lens >= 4.12 && < 5 , lens-aeson >= 1.0- , megaparsec == 4.3.*+ , megaparsec == 5.0.* , memory >= 0.7- , mtl >= 2.2 && < 2.3+ , mtl >= 2.2.1 && < 2.3 , operational >= 0.2.3 && < 0.3 , parsec == 3.1.* , pcre-utils >= 0.1.7 && < 0.2@@ -113,14 +117,14 @@ , regex-pcre-builtin >= 0.94.4 , scientific >= 0.2 && < 0.4 , semigroups- , servant == 0.4.*- , servant-client == 0.4.*+ , servant == 0.7.*+ , servant-client == 0.7.* , split == 0.2.* , stm == 2.4.* , strict-base-types >= 0.3 , text >= 0.11 , time >= 1.5 && < 2- , transformers == 0.4.*+ , transformers >= 0.4 && < 0.6 , unix >= 2.7 && < 2.8 , unordered-containers == 0.2.* , vector >= 0.10@@ -158,7 +162,7 @@ type: exitcode-stdio-1.0 ghc-options: -Wall -rtsopts -threaded extensions: OverloadedStrings- build-depends: language-puppet,base,temporary,strict-base-types,lens,text,either+ build-depends: language-puppet,base,temporary,strict-base-types,lens,text,transformers,mtl main-is: puppetdb.hs Test-Suite erbparser hs-source-dirs: tests@@ -194,8 +198,10 @@ , aeson , bytestring , containers- , either+ , transformers+ , mtl , hslogger+ , http-client , language-puppet , lens , megaparsec@@ -216,13 +222,15 @@ -- ghc-prof-options: -auto-all -caf-all -fprof-auto build-depends: base , bytestring- , either+ , http-client , language-puppet , lens+ , mtl , optparse-applicative , servant-client , strict-base-types , text+ , transformers , unordered-containers , vector , yaml
progs/PuppetResources.hs view
@@ -6,7 +6,7 @@ import Control.Concurrent.ParallelIO (parallel) import Control.Lens hiding (Strict) import Control.Monad-import Control.Monad.Trans.Either+import Control.Monad.Trans.Except import Data.Aeson (encode) import qualified Data.ByteString.Lazy.Char8 as BSL import Data.Either (partitionEithers)@@ -22,6 +22,7 @@ import Data.Text.Strict.Lens import Data.Tuple (swap) import qualified Data.Vector as V+import Network.HTTP.Client import Options.Applicative import Servant.Common.BaseUrl (parseBaseUrl) import System.Exit (exitFailure, exitSuccess)@@ -45,6 +46,7 @@ import PuppetDB.TestDB (loadTestDB) +type ParseError' = P.ParseError Char P.Dec type QueryFunc = NodeName -> IO (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) data MultNodes = MultNodes [T.Text] | AllNodes deriving Show@@ -158,12 +160,13 @@ initializedaemonWithPuppet :: FilePath -> Options -> IO (QueryFunc, PuppetDBAPI IO, MStats, MStats, MStats)-initializedaemonWithPuppet workingdir (Options {..}) = do+initializedaemonWithPuppet workingdir Options {..} = do+ mgr <- newManager defaultManagerSettings pdbapi <- case (_optPdburl, _optPdbfile) of (Nothing, Nothing) -> return dummyPuppetDB (Just _, Just _) -> error "You must choose between a testing PuppetDB and a remote one" (Just url, _) -> checkError "Error when parsing url" (parseBaseUrl url)- >>= pdbConnect+ >>= pdbConnect mgr >>= checkError "Error when connecting to the remote PuppetDB" (_, Just file) -> loadTestDB file >>= checkError "Error when initializing the PuppetDB API" pref <- dfPreferences workingdir <&> prefPDB .~ pdbapi@@ -180,7 +183,7 @@ unifyFacts :: Container PValue -> Container PValue -> Container PValue -> Container PValue unifyFacts defaults override c = override `HM.union` c `HM.union` defaults -parseFile :: FilePath -> IO (Either P.ParseError (V.Vector Statement))+parseFile :: FilePath -> IO (Either ParseError' (V.Vector Statement)) parseFile fp = runPParser fp <$> T.readFile fp printContent :: T.Text -> FinalCatalog -> IO ()@@ -240,12 +243,12 @@ unless (null parseFailed) $ do putDoc ("The following" <+> int (length parseFailed) <+> "files could not be parsed:" </> indent 4 (vcat (map (string . show) parseFailed))) putStrLn ""- let getSubStatements s@(ResourceDeclaration{}) = [s]+ let getSubStatements s@ResourceDeclaration{} = [s] getSubStatements (ConditionalDeclaration (ConditionalDecl conds _)) = conds ^.. traverse . _2 . tgt- getSubStatements s@(ClassDeclaration{}) = extractPrism s- getSubStatements s@(DefineDeclaration{}) = extractPrism s- getSubStatements s@(NodeDeclaration{}) = extractPrism s- getSubStatements s@(HigherOrderLambdaDeclaration{}) = extractPrism s+ getSubStatements s@ClassDeclaration{} = extractPrism s+ getSubStatements s@DefineDeclaration{} = extractPrism s+ getSubStatements s@NodeDeclaration{} = extractPrism s+ getSubStatements s@HigherOrderLambdaDeclaration{} = extractPrism s getSubStatements (TopContainer v s) = getSubStatements s ++ v ^.. tgt getSubStatements _ = [] tgt = folded . to getSubStatements . folded@@ -269,7 +272,7 @@ -- | For each node, queryfunc the catalog and return stats computeStats :: FilePath -> Options -> QueryFunc -> (MStats, MStats, MStats) -> [NodeName] -> IO ()-computeStats workingdir (Options {..})+computeStats workingdir Options {..} queryfunc (parsingStats, catalogStats, templateStats) topnodes = do -- the parsing statistics, so that we known which files@@ -312,7 +315,7 @@ -- | Queryfunc the catalog for the node and PP the result computeNodeCatalog :: Options -> QueryFunc -> PuppetDBAPI IO -> NodeName -> IO ()-computeNodeCatalog (Options {..}) queryfunc pdbapi node =+computeNodeCatalog Options {..} queryfunc pdbapi node = queryfunc node >>= \case S.Left rr -> do putDoc (line <> red "ERROR:" <+> parens (ttext node) <+> getError rr)@@ -326,7 +329,7 @@ exported <- filterCatalog _optResourceType _optResourceName rawexported let wirecatalog = generateWireCatalog node (catalog <> exported ) edgemap rawWireCatalog = generateWireCatalog node (rawcatalog <> rawexported) edgemap- when _optCheckExport $ void $ runEitherT $ replaceCatalog pdbapi rawWireCatalog+ when _optCheckExport $ void $ runExceptT $ replaceCatalog pdbapi rawWireCatalog case (_optShowContent, _optShowjson) of (_, True) -> BSL.putStrLn (encode (prepareForPuppetApply wirecatalog)) (True, _) -> do@@ -359,25 +362,25 @@ run :: Options -> IO () -- | Parse mode-run (Options {_optParse = Just fp, ..}) = parseFile fp >>= \case+run Options {_optParse = Just fp, ..} = parseFile fp >>= \case Left rr -> error ("parse error:" ++ show rr) Right s -> if _optLoglevel == LOG.DEBUG then mapM_ print s else putDoc $ ppStatements s -run (Options {_optPuppetdir = Nothing, _optParse = Nothing }) =+run Options {_optPuppetdir = Nothing, _optParse = Nothing } = error "Without a puppet dir, only the `--parse` option can be supported"-run (Options {_optPuppetdir = Just _, _optNodename = Nothing, _optMultnodes = Nothing}) =+run Options {_optPuppetdir = Just _, _optNodename = Nothing, _optMultnodes = Nothing} = error "You need to choose between single or multiple node" -- | Single node mode (`--node` option)-run cmd@(Options {_optNodename = Just node, _optPuppetdir = Just workingdir, ..}) = do+run cmd@Options {_optNodename = Just node, _optPuppetdir = Just workingdir, ..} = do (queryfunc, pdbapi, _, _, _ ) <- initializedaemonWithPuppet workingdir cmd computeNodeCatalog cmd queryfunc pdbapi node- when _optCommitDB $ void $ runEitherT $ commitDB pdbapi+ when _optCommitDB $ void $ runExceptT $ commitDB pdbapi -- | Multiple nodes mode (`--all`) option-run cmd@(Options {_optNodename = Nothing , _optMultnodes = Just nodes, _optPuppetdir = Just workingdir}) = do+run cmd@Options {_optNodename = Nothing , _optMultnodes = Just nodes, _optPuppetdir = Just workingdir} = do (queryfunc, _, mPStats,mCStats,mTStats) <- initializedaemonWithPuppet workingdir cmd computeStats workingdir cmd queryfunc (mPStats, mCStats, mTStats) =<< retrieveNodes nodes where
progs/pdbQuery.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-} module Main where import Puppet.Interpreter.Types@@ -10,7 +11,7 @@ import Control.Lens import Control.Monad (forM_,unless,(>=>))-import Control.Monad.Trans.Either+import Control.Monad.Trans.Except import qualified Data.ByteString.Char8 as BS import qualified Data.Either.Strict as S import qualified Data.HashMap.Strict as HM@@ -19,6 +20,7 @@ import qualified Data.Text as T import qualified Data.Vector as V import Data.Yaml hiding (Parser)+import Network.HTTP.Client import Options.Applicative as O import Servant.Common.BaseUrl @@ -68,7 +70,7 @@ delnodeparser = DeactivateNode <$> O.argument auto mempty createtestdb :: Parser Command-createtestdb = CreateTestDB <$> O.argument auto mempty+createtestdb = CreateTestDB <$> O.argument str (metavar "FILE") addfacts :: Parser Command addfacts = AddFacts <$> O.argument auto mempty@@ -86,20 +88,21 @@ checkError s (Left rr) = error (s <> " " <> show rr) checkError _ (Right a) = return a -runCheck :: Show r => String -> EitherT r IO a -> IO a-runCheck s = runEitherT >=> checkError s+runCheck :: Show r => String -> ExceptT r IO a -> IO a+runCheck s = runExceptT >=> checkError s run :: Options -> IO ()-run cmdl = do- epdbapi <- case (_pdbloc cmdl, _pdbtype cmdl) of- (Just l, PDBRemote) -> pdbConnect $ either error id $ parseBaseUrl l+run Options{..} = do+ mgr <- newManager defaultManagerSettings+ epdbapi <- case (_pdbloc, _pdbtype) of+ (Just l, PDBRemote) -> pdbConnect mgr $ either (error . show) id $ parseBaseUrl l (Just l, PDBTest) -> loadTestDB l (_, x) -> getDefaultDB x pdbapi <- case epdbapi of Left r -> error (show r) Right x -> return x- case _pdbcmd cmdl of- DumpFacts -> if _pdbtype cmdl == PDBDummy+ case _pdbcmd of+ DumpFacts -> if _pdbtype == PDBDummy then puppetDBFacts "dummy" pdbapi >>= mapM_ print . HM.toList else do allfacts <- runCheck "get facts" (getFacts pdbapi QEmpty)@@ -109,9 +112,9 @@ curmap & at ndname . non HM.empty %~ (at fctname ?~ fctval) runCheck "replace facts in dummy db" (replaceFacts tmpdb (HM.toList groupfacts)) runCheck "commit db" (commitDB tmpdb)- DumpNodes -> runEitherT (getNodes pdbapi QEmpty) >>= display "dump nodes"+ DumpNodes -> runExceptT (getNodes pdbapi QEmpty) >>= display "dump nodes" AddFacts n -> do- unless (_pdbtype cmdl == PDBTest) (error "This option only works with the test puppetdb")+ unless (_pdbtype == PDBTest) (error "This option only works with the test puppetdb") fcts <- puppetDBFacts n pdbapi runCheck "replace facts" (replaceFacts pdbapi [(n, fcts)]) runCheck "commit db" (commitDB pdbapi)
tests/puppetdb.hs view
@@ -6,7 +6,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Control.Lens-import Control.Monad.Trans.Either+import Control.Monad.Trans.Except import Puppet.Interpreter.Types import PuppetDB.Common@@ -17,8 +17,8 @@ checkError _ (Right x) = return x checkError step (Left rr) = error (step ++ ": " ++ show rr) -checkErrorE :: Show x => String -> EitherT x IO a -> IO a-checkErrorE msg = runEitherT >=> either (error . ((msg ++ " ") ++) . show) return+checkErrorE :: Show x => String -> ExceptT x IO a -> IO a+checkErrorE msg = runExceptT >=> either (error . ((msg ++ " ") ++) . show) return main :: IO () main = withSystemTempDirectory "hieratest" $ \tmpfp -> do