diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -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 diff --git a/Erb/Compute.hs b/Erb/Compute.hs --- a/Erb/Compute.hs +++ b/Erb/Compute.hs @@ -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 diff --git a/Facter.hs b/Facter.hs --- a/Facter.hs +++ b/Facter.hs @@ -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]) diff --git a/Puppet/Interpreter.hs b/Puppet/Interpreter.hs --- a/Puppet/Interpreter.hs +++ b/Puppet/Interpreter.hs @@ -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) diff --git a/Puppet/Interpreter/IO.hs b/Puppet/Interpreter/IO.hs --- a/Puppet/Interpreter/IO.hs +++ b/Puppet/Interpreter/IO.hs @@ -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 diff --git a/Puppet/Interpreter/Resolve.hs b/Puppet/Interpreter/Resolve.hs --- a/Puppet/Interpreter/Resolve.hs +++ b/Puppet/Interpreter/Resolve.hs @@ -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 diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs --- a/Puppet/Interpreter/Types.hs +++ b/Puppet/Interpreter/Types.hs @@ -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 () -- ^ - , replaceFacts :: [(NodeName, Facts)] -> EitherT PrettyError m () -- ^ - , deactivateNode :: NodeName -> EitherT PrettyError m () -- ^ - , getFacts :: Query FactField -> EitherT PrettyError m [FactInfo] -- ^ - , getResources :: Query ResourceField -> EitherT PrettyError m [Resource] -- ^ - , 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 () -- ^ + , replaceFacts :: [(NodeName, Facts)] -> ExceptT PrettyError m () -- ^ + , deactivateNode :: NodeName -> ExceptT PrettyError m () -- ^ + , getFacts :: Query FactField -> ExceptT PrettyError m [FactInfo] -- ^ + , getResources :: Query ResourceField -> ExceptT PrettyError m [Resource] -- ^ + , 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 diff --git a/Puppet/Parser.hs b/Puppet/Parser.hs --- a/Puppet/Parser.hs +++ b/Puppet/Parser.hs @@ -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 diff --git a/Puppet/Parser/Types.hs b/Puppet/Parser/Types.hs --- a/Puppet/Parser/Types.hs +++ b/Puppet/Parser/Types.hs @@ -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" diff --git a/Puppet/Stdlib.hs b/Puppet/Stdlib.hs --- a/Puppet/Stdlib.hs +++ b/Puppet/Stdlib.hs @@ -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"] diff --git a/PuppetDB/Common.hs b/PuppetDB/Common.hs --- a/PuppetDB/Common.hs +++ b/PuppetDB/Common.hs @@ -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 diff --git a/PuppetDB/Dummy.hs b/PuppetDB/Dummy.hs --- a/PuppetDB/Dummy.hs +++ b/PuppetDB/Dummy.hs @@ -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 [] ) diff --git a/PuppetDB/Remote.hs b/PuppetDB/Remote.hs --- a/PuppetDB/Remote.hs +++ b/PuppetDB/Remote.hs @@ -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) diff --git a/PuppetDB/TestDB.hs b/PuppetDB/TestDB.hs --- a/PuppetDB/TestDB.hs +++ b/PuppetDB/TestDB.hs @@ -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" 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: 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 diff --git a/progs/PuppetResources.hs b/progs/PuppetResources.hs --- a/progs/PuppetResources.hs +++ b/progs/PuppetResources.hs @@ -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 diff --git a/progs/pdbQuery.hs b/progs/pdbQuery.hs --- a/progs/pdbQuery.hs +++ b/progs/pdbQuery.hs @@ -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) diff --git a/tests/puppetdb.hs b/tests/puppetdb.hs --- a/tests/puppetdb.hs +++ b/tests/puppetdb.hs @@ -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