diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,13 @@ +language-puppet (1.3.14) UNRELEASED; urgency=medium + + * Allow declaring type of variables during assignment + * The `lookup` function now fails if an input strategy is unknown + * Display all errors when testing file sources in optional tests (not just the first one). + * Fix haddock rendering + * Re-organize haskell modules to strengthen dependency paths + + -- Simon Marechal Tue, 06 Feb 2018 17:54:51 +0100 + language-puppet (1.3.13) xenial; urgency=medium * Support for a "rebasefile" option to make file() calls with absolute files relative to another directory. diff --git a/README.adoc b/README.adoc --- a/README.adoc +++ b/README.adoc @@ -23,9 +23,9 @@ cd language-puppet # Using nix cabal2nix . > default.nix -nix-build shell.nix # or nix-shell +nix-build shell.nix # Using stack -ln -s stack-9.yaml stack.yaml +ln -s stack-10.yaml stack.yaml stack build ``` 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.3.13 +version: 1.3.14 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/ @@ -14,6 +14,7 @@ category: System build-type: Simple cabal-version: >=1.8 +bug-reports: https://github.com/bartavelle/language-puppet/issues Tested-With: GHC == 8.0.2, GHC == 8.2.2 @@ -31,60 +32,67 @@ library hs-source-dirs: src - exposed-modules: Erb.Evaluate - , Erb.Parser - , Erb.Ruby + exposed-modules: XPrelude + , Erb , Facter , Hiera.Server - , Puppet.Daemon - , PuppetDB.Common - , PuppetDB.Dummy + , PuppetDB + , Puppet.Language + , Puppet.Parser + , Puppet.Interpreter + , Puppet.Runner + other-modules: XPrelude.Extra + , XPrelude.PP + , Erb.Ruby + , Erb.Parser , PuppetDB.Remote + , PuppetDB.Core , PuppetDB.TestDB - , Puppet.Interpreter - , Puppet.Interpreter.IO - , Puppet.Interpreter.PrettyPrinter - , Puppet.Interpreter.Pure - , Puppet.Interpreter.Resolve - , Puppet.Interpreter.Resolve.Sprintf - , Puppet.Interpreter.Types - , Puppet.Interpreter.Utils - , Puppet.Lens - , Puppet.NativeTypes - , Puppet.NativeTypes.Helpers - , Puppet.Parser + , Puppet.Language.Core + , Puppet.Language.NativeTypes + , Puppet.Language.NativeTypes.Helpers + , Puppet.Language.NativeTypes.Concat + , Puppet.Language.NativeTypes.Cron + , Puppet.Language.NativeTypes.Exec + , Puppet.Language.NativeTypes.File + , Puppet.Language.NativeTypes.Group + , Puppet.Language.NativeTypes.Host + , Puppet.Language.NativeTypes.Mount + , Puppet.Language.NativeTypes.Notify + , Puppet.Language.NativeTypes.Package + , Puppet.Language.NativeTypes.SshSecure + , Puppet.Language.NativeTypes.User + , Puppet.Language.NativeTypes.ZoneRecord + , Puppet.Language.Paths + , Puppet.Language.Resource + , Puppet.Language.Value + , Puppet.Language.WireCatalog , Puppet.Parser.PrettyPrinter , Puppet.Parser.Types - , Puppet.PP - , Puppet.Preferences - , Puppet.Puppetlabs - , Puppet.Stats - , Puppet.Stdlib - , Puppet.OptionalTests - , Puppet.Prelude - other-modules: Erb.Compute + , Puppet.Parser.Lens , Paths_language_puppet + , Puppet.Interpreter.Types + , Puppet.Interpreter.PrettyPrinter + , Puppet.Interpreter.Helpers , Puppet.Interpreter.RubyRandom - , Puppet.Manifests - , Puppet.NativeTypes.Concat - , Puppet.NativeTypes.Cron - , Puppet.NativeTypes.Exec - , Puppet.NativeTypes.File - , Puppet.NativeTypes.Group - , Puppet.NativeTypes.Host - , Puppet.NativeTypes.Mount - , Puppet.NativeTypes.Notify - , Puppet.NativeTypes.Package - , Puppet.NativeTypes.SshSecure - , Puppet.NativeTypes.User - , Puppet.NativeTypes.ZoneRecord - , Puppet.Parser.Utils - , Puppet.Paths - extensions: OverloadedStrings, BangPatterns, NoImplicitPrelude + , Puppet.Interpreter.Resolve.Sprintf + , Puppet.Interpreter.Resolve + , Puppet.Interpreter.IO + , Puppet.Runner.Stdlib + , Puppet.Runner.Stats + , Puppet.Runner.Puppetlabs + , Puppet.Runner.Preferences + , Puppet.Runner.Erb.Evaluate + , Puppet.Runner.Erb + , Puppet.Runner.Pure + , Puppet.Runner.Daemon.FileParser + , Puppet.Runner.Daemon.OptionalTests + , Puppet.Runner.Daemon + extensions: OverloadedStrings, BangPatterns, LambdaCase, NoImplicitPrelude ghc-options: -Wall -funbox-strict-fields -j1 -- ghc-prof-options: -auto-all -caf-all build-depends: aeson >= 0.8 - , ansi-wl-pprint == 0.6.* + , ansi-wl-pprint >= 0.6.8 , attoparsec >= 0.12 , base >=4.9 && < 5 , base16-bytestring == 0.1.* @@ -116,16 +124,15 @@ , random , regex-pcre-builtin >= 0.94.4 , scientific >= 0.2 && < 0.4 - , semigroups - , servant >= 0.9 && < 0.12 - , servant-client >= 0.9 && < 0.12 + , servant >= 0.9 + , servant-client >= 0.9 , split == 0.2.* , stm == 2.4.* , strict-base-types >= 0.3 , text >= 0.11 , time >= 1.5 && < 2 , transformers >= 0.4 && < 0.6 - , unix >= 2.7 && < 2.8 + , unix >= 2.7 && < 2.8 , unordered-containers == 0.2.* , vector >= 0.10 , yaml >= 0.8.8 && < 0.9 @@ -134,7 +141,7 @@ type: exitcode-stdio-1.0 ghc-options: -Wall -rtsopts -threaded extensions: OverloadedStrings - build-depends: language-puppet,base,text,lens,megaparsec,hspec + build-depends: language-puppet,base,text,lens,megaparsec,hspec,vector main-is: evals.hs Test-Suite test-lexer hs-source-dirs: tests @@ -215,7 +222,6 @@ , optparse-applicative , parallel-io , regex-pcre-builtin - , servant-client , strict-base-types , text , unordered-containers @@ -249,11 +255,10 @@ , lens , mtl , optparse-applicative - , servant-client , strict-base-types , text , transformers , unordered-containers , vector , yaml - main-is: pdbQuery.hs + main-is: pdbQuery.hs diff --git a/progs/PuppetResources.hs b/progs/PuppetResources.hs --- a/progs/PuppetResources.hs +++ b/progs/PuppetResources.hs @@ -5,11 +5,11 @@ {-# LANGUAGE StrictData #-} module Main where -import Puppet.Prelude hiding (option) +import XPrelude hiding (option) import Control.Concurrent.ParallelIO (parallel) import qualified Data.Aeson as Aeson -import qualified Data.HashMap.Strict as HM +import qualified Data.HashMap.Strict as Map import qualified Data.HashSet as HS import qualified Data.List as List import qualified Data.Set as Set @@ -20,57 +20,52 @@ import qualified Network.HTTP.Client as Http import Options.Applicative import qualified Paths_language_puppet as Meta -import qualified Servant.Common.BaseUrl as Servant import qualified System.FilePath.Glob as Glob import System.IO (hIsTerminalDevice) import qualified System.Log.Logger as Log -import qualified Text.Megaparsec as P +import qualified Text.Megaparsec as Megaparsec import qualified Text.Regex.PCRE.String as Reg -import qualified Facter -import Puppet.Daemon -import Puppet.Lens import Puppet.Parser hiding (Parser) -import Puppet.Parser.PrettyPrinter (ppStatements) -import Puppet.Parser.Types -import Puppet.Preferences -import Puppet.Stats -import PuppetDB.Common (generateWireCatalog) -import PuppetDB.Dummy (dummyPuppetDB) -import PuppetDB.Remote (pdbConnect) -import PuppetDB.TestDB (loadTestDB) +import Puppet.Runner +import PuppetDB (PuppetDBAPI, dummyPuppetDB, pdbConnect, + puppetDBFacts) +import qualified PuppetDB -type ParseError' = P.ParseError Char Void +type ParseError' = Megaparsec.ParseError Char Void type QueryFunc = NodeName -> IO (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) -data MultNodes = MultNodes [Text] | AllNodes deriving Show +data MultNodes + = MultNodes [Text] + | AllNodes + deriving (Show) readMultNodes:: String -> Maybe MultNodes readMultNodes "allnodes" = Just AllNodes readMultNodes n = Just (MultNodes (Text.splitOn "," (toS n))) data Options = Options - { _optShowjson :: Bool - , _optShowContent :: Bool - , _optResourceType :: Maybe Text - , _optResourceName :: Maybe Text - , _optPuppetdir :: Maybe FilePath - , _optNodename :: Maybe NodeName - , _optMultnodes :: Maybe MultNodes - , _optDeadcode :: Bool - , _optPdburl :: Maybe String - , _optPdbfile :: Maybe FilePath - , _optLoglevel :: Log.Priority - , _optHieraFile :: Maybe FilePath - , _optCommitDB :: Bool - , _optCheckExport :: Bool - , _optIgnoredMods :: Maybe (HS.HashSet Text) - , _optParse :: Maybe FilePath - , _optStrictMode :: Bool - , _optNoExtraTests :: Bool - , _optVersion :: Bool - , _optRebaseFile :: Maybe FilePath - } deriving (Show) + { _optShowjson :: Bool + , _optShowContent :: Bool + , _optResourceType :: Maybe Text + , _optResourceName :: Maybe Text + , _optPuppetdir :: Maybe FilePath + , _optNodename :: Maybe NodeName + , _optMultnodes :: Maybe MultNodes + , _optDeadcode :: Bool + , _optPdburl :: Maybe String + , _optPdbfile :: Maybe FilePath + , _optLoglevel :: Log.Priority + , _optHieraFile :: Maybe FilePath + , _optCommitDB :: Bool + , _optCheckExport :: Bool + , _optIgnoredMods :: Maybe (HS.HashSet Text) + , _optParse :: Maybe FilePath + , _optStrictMode :: Bool + , _optNoExtraTests :: Bool + , _optVersion :: Bool + , _optRebaseFile :: Maybe FilePath + } deriving (Show) options :: Parser Options options = Options @@ -148,7 +143,8 @@ -- | Like catMaybes, but it counts the Nothing values catMaybesCount :: [Maybe a] -> ([a], Sum Int) -catMaybesCount = foldMap f where +catMaybesCount = foldMap f + where f Nothing = ([ ], Sum 1) f (Just x) = ([x], Sum 0) @@ -163,12 +159,10 @@ initializedaemonWithPuppet workingdir Options {..} = do mgr <- Http.newManager Http.defaultManagerSettings pdbapi <- case (_optPdburl, _optPdbfile) of - (Nothing, Nothing) -> return dummyPuppetDB - (Just _, Just _) -> panic "You must choose between a testing PuppetDB and a remote one" - (Just url, _) -> checkError "Error when parsing url" (Servant.parseBaseUrl url) - >>= pdbConnect mgr - >>= checkError "Error when connecting to the remote PuppetDB" - (_, Just file) -> loadTestDB file >>= checkError "Error when initializing the PuppetDB API" + (Nothing, Nothing) -> return dummyPuppetDB + (Just _, Just _) -> panic "You must choose between a testing PuppetDB and a remote one" + (Just url, _) -> pdbConnect mgr url >>= unwrapError "Error when connecting to the remote PuppetDB" + (_, Just file) -> PuppetDB.loadTestDB file >>= unwrapError "Error when initializing the PuppetDB API" pref <- dfPreferences workingdir <&> prefPDB .~ pdbapi <&> prefHieraPath .~ _optHieraFile <&> prefIgnoredmodules %~ (`fromMaybe` _optIgnoredMods) @@ -177,57 +171,57 @@ <&> prefLogLevel .~ _optLoglevel <&> prefRebaseFile .~ _optRebaseFile d <- initDaemon pref - let queryfunc = \node -> fmap (unifyFacts (pref ^. prefFactsDefault) (pref ^. prefFactsOverride)) (Facter.puppetDBFacts node pdbapi) >>= getCatalog d node + let queryfunc = \node -> fmap (unifyFacts (pref ^. prefFactsDefault) (pref ^. prefFactsOverride)) (puppetDBFacts node pdbapi) >>= getCatalog d node pure (queryfunc, pdbapi, parserStats d, catalogStats d, templateStats d) where -- merge 3 sets of facts : some defaults, the original set and some override unifyFacts :: Container PValue -> Container PValue -> Container PValue -> Container PValue - unifyFacts defaults override c = override `HM.union` c `HM.union` defaults + unifyFacts defaults override c = override `Map.union` c `Map.union` defaults parseFile :: FilePath -> IO (Either ParseError' (V.Vector Statement)) parseFile fp = runPParser fp <$> readFile fp printContent :: Text -> FinalCatalog -> IO () printContent filename catalog = - case HM.lookup (RIdentifier "file" filename) catalog of - Nothing -> panic "File not found" - Just r -> case HM.lookup "content" (r ^. rattributes) of - Nothing -> panic "This file has no content" - Just (PString c) -> putText c - Just x -> print x + case Map.lookup (RIdentifier "file" filename) catalog of + Nothing -> panic "File not found" + Just r -> + case Map.lookup "content" (r ^. rattributes) of + Nothing -> panic "This file has no content" + Just (PString c) -> putText c + Just x -> print x prepareForPuppetApply :: WireCatalog -> WireCatalog prepareForPuppetApply wcat = - let res = V.filter (\r -> r ^. rvirtuality == Normal) (wcat ^. wireCatalogResources) :: 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 identity - aliasMap :: HM.HashMap RIdentifier 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 (wcat ^. wireCatalogEdges) - 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 & has (ix s)) && (aliasMap & has (ix 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 & has (ix x)) . map (_1 %~ correct) . HM.toList - in wcat & (wireCatalogResources .~ correctResources) - & (wireCatalogEdges .~ correctEdges) + let res = V.filter (\r -> r ^. rvirtuality == Normal) (wcat ^. wireCatalogResources) :: 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 identity + aliasMap :: HashMap RIdentifier Text + aliasMap = Map.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 (wcat ^. wireCatalogEdges) + 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 & has (ix s)) && (aliasMap & has (ix d)) + correctEdges = V.map correctEdge $ V.filter knownEdge ne + correctResources = V.map correctResource nr + correct :: RIdentifier -> RIdentifier + correct ri = ri & iname %~ \n -> Map.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 %~ Map.fromList . filter (\(x,_) -> aliasMap & has (ix x)) . map (_1 %~ correct) . Map.toList + in wcat & (wireCatalogResources .~ correctResources) + & (wireCatalogEdges .~ correctEdges) --- | Finds the dead code findDeadCode :: String -> [Resource] -> Set.Set FilePath -> IO () findDeadCode puppetdir catalogs allfiles = do -- first collect all files / positions from all the catalogs @@ -237,12 +231,12 @@ let deadfiles = Set.filter ("/manifests/" `List.isInfixOf`) $ puppetfiles `Set.difference` allfiles usedfiles = puppetfiles `Set.intersection` allfiles unless (Set.null deadfiles) $ do - putDoc ("The following files" <+> int (Set.size deadfiles) <+> "are not used: " <> list (map string $ Set.toList deadfiles)) + putDoc ("The following files" <+> pretty (Set.size deadfiles) <+> "are not used: " <> list (map ppstring $ Set.toList deadfiles)) putText "" allparses <- parallel (map parseFile (Set.toList usedfiles)) let (parseFailed, parseSucceeded) = partitionEithers allparses unless (null parseFailed) $ do - putDoc ("The following" <+> int (length parseFailed) <+> "files could not be parsed:" indent 4 (vcat (map (string . show) parseFailed))) + putDoc ("The following" <+> pretty (length parseFailed) <+> "files could not be parsed:" <> softline <> indent 4 (vcat (map (ppstring . show) parseFailed))) putText "" let getSubStatements s@ResourceDeclaration{} = [s] getSubStatements (ConditionalDeclaration (ConditionalDecl conds _)) = conds ^.. traverse . _2 . tgt @@ -257,151 +251,153 @@ allResources = parseSucceeded ^.. folded . folded . to getSubStatements . folded deadResources = filter isDead allResources isDead (ResourceDeclaration (ResDecl _ _ _ _ pp)) = not $ Set.member pp allpositions - isDead _ = True + isDead _ = True unless (null deadResources) $ do - putDoc ("The following" <+> int (length deadResources) <+> "resource declarations are not used:" indent 4 (vcat (map pretty deadResources)) <> line ) + putDoc ("The following" <+> pretty (length deadResources) <+> "resource declarations are not used:" <> softline <> indent 4 (vcat (map pretty deadResources)) <> line ) newtype Maximum a = Maximum { getMaximum :: Maybe a } instance (Ord a) => Monoid (Maximum a) where - mempty = Maximum Nothing - mappend (Maximum Nothing) m2 = m2 - mappend m1 (Maximum Nothing) = m1 - mappend (Maximum (Just a1)) (Maximum (Just a2)) = Maximum (Just (max a1 a2)) + mempty = Maximum Nothing + mappend (Maximum Nothing) m2 = m2 + mappend m1 (Maximum Nothing) = m1 + mappend (Maximum (Just a1)) (Maximum (Just a2)) = Maximum (Just (max a1 a2)) --- | For each node, queryfunc the catalog and return stats +-- For each node, queryfunc the catalog and return stats computeStats :: FilePath -> Options -> QueryFunc -> (MStats, MStats, MStats) -> [NodeName] -> IO () computeStats workingdir Options {..} queryfunc (parsingStats, catalogStats, templateStats) topnodes = do - -- the parsing statistics, so that we known which files - (cats, Sum failures) <- catMaybesCount <$> parallel (map (computeCatalog queryfunc) topnodes) - pStats <- getStats parsingStats - cStats <- getStats catalogStats - tStats <- getStats templateStats - let allres = (cats ^.. folded . _1 . folded) ++ (cats ^.. folded . _2 . folded) - allfiles = Set.fromList $ map Text.unpack $ HM.keys pStats - when _optDeadcode $ findDeadCode workingdir allres allfiles - -- compute statistics - let (parsing, Just (wPName, wPMean)) = worstAndSum pStats - (cataloging, Just (wCName, wCMean)) = worstAndSum cStats - (templating, Just (wTName, wTMean)) = worstAndSum tStats - parserShare = 100 * parsing / cataloging - templateShare = 100 * templating / cataloging - formatDouble = take 5 . show -- yeah, well ... - nbnodes = length topnodes - worstAndSum = (_1 %~ getSum) - . (_2 %~ fmap swap . getMaximum) - . ifoldMap (\k (StatsPoint cnt total _ _) -> (Sum total, Maximum $ Just (total / fromIntegral cnt, k))) - putStr ("\nTested " ++ show nbnodes ++ " nodes. ") - unless (nbnodes == 0) $ do - putStrLn (formatDouble parserShare <> "% of total CPU time spent parsing, " <> formatDouble templateShare <> "% spent computing templates") - when (_optLoglevel <= Log.NOTICE) $ do - putStrLn ("Slowest template: " <> Text.unpack wTName <> ", taking " <> formatDouble wTMean <> "s on average") - putStrLn ("Slowest file to parse: " <> Text.unpack wPName <> ", taking " <> formatDouble wPMean <> "s on average") - putStrLn ("Slowest catalog to compute: " <> Text.unpack wCName <> ", taking " <> formatDouble wCMean <> "s on average") + -- the parsing statistics, so that we known which files + (cats, Sum failures) <- catMaybesCount <$> parallel (map (compute queryfunc) topnodes) + pStats <- getStats parsingStats + cStats <- getStats catalogStats + tStats <- getStats templateStats + let allres = (cats ^.. folded . _1 . folded) ++ (cats ^.. folded . _2 . folded) + allfiles = Set.fromList $ map Text.unpack $ Map.keys pStats + when _optDeadcode $ findDeadCode workingdir allres allfiles + -- compute statistics + let (parsing, Just (wPName, wPMean)) = worstAndSum pStats + (cataloging, Just (wCName, wCMean)) = worstAndSum cStats + (templating, Just (wTName, wTMean)) = worstAndSum tStats + parserShare = 100 * parsing / cataloging + templateShare = 100 * templating / cataloging + formatDouble = Text.take 5 . show -- yeah, well ... + nbnodes = length topnodes + worstAndSum = (_1 %~ getSum) + . (_2 %~ fmap swap . getMaximum) + . ifoldMap (\k (StatsPoint cnt total _ _) -> (Sum total, Maximum $ Just (total / fromIntegral cnt, k))) + putStr ("\nTested " ++ show nbnodes ++ " nodes. ") + unless (nbnodes == 0) $ do + putText (formatDouble parserShare <> "% of total CPU time spent parsing, " <> formatDouble templateShare <> "% spent computing templates") + when (_optLoglevel <= Log.NOTICE) $ do + putText ("Slowest template: " <> wTName <> ", taking " <> formatDouble wTMean <> "s on average") + putText ("Slowest file to parse: " <> wPName <> ", taking " <> formatDouble wPMean <> "s on average") + putText ("Slowest catalog to compute: " <> wCName <> ", taking " <> formatDouble wCMean <> "s on average") - if failures > 0 - then do {putDoc ("Found" <+> red (int failures) <+> "failure(s)." <> line) ; exitFailure} - else do {putDoc (dullgreen "All green." <> line) ; exitSuccess} + if failures > 0 + then do {putDoc ("Found" <+> red (pretty failures) <+> "failure(s)." <> line) ; exitFailure} + else do {putDoc (dullgreen "All green." <> line) ; exitSuccess} - where - computeCatalog :: QueryFunc -> NodeName -> IO (Maybe (FinalCatalog, [Resource])) - computeCatalog func node = - func node >>= \case - Left err -> putDoc (line <> red "ERROR:" <+> parens (ttext node) <+> ":" <+> getError err) >> return Nothing - Right (rawcatalog, _ , rawexported, knownRes) -> return (Just (rawcatalog <> rawexported, knownRes)) + where + compute :: QueryFunc -> NodeName -> IO (Maybe (FinalCatalog, [Resource])) + compute func node = + func node >>= \case + Left err -> putDoc (line <> red "ERROR:" <+> parens (ppline node) <+> ":" <+> getError err) >> return Nothing + Right (rawcatalog, _ , rawexported, knownRes) -> return (Just (rawcatalog <> rawexported, knownRes)) --- | Queryfunc the catalog for the node and PP the result +-- Queryfunc the catalog for the node and PP the result computeNodeCatalog :: Options -> QueryFunc -> PuppetDBAPI IO -> NodeName -> IO () computeNodeCatalog Options {..} queryfunc pdbapi node = - queryfunc node >>= \case - Left rr -> do - putDoc (line <> red "ERROR:" <+> parens (ttext node) <+> getError rr) - exitFailure - Right (rawcatalog, edgemap, rawexported, _) -> do - printFunc <- hIsTerminalDevice stdout >>= \isterm -> return $ \x -> - if isterm - then putDoc (x <> line) - else displayIO stdout (renderCompact (x <> line)) - catalog <- filterCatalog _optResourceType _optResourceName rawcatalog - exported <- filterCatalog _optResourceType _optResourceName rawexported - let wirecatalog = generateWireCatalog node (catalog <> exported ) edgemap - rawWireCatalog = generateWireCatalog node (rawcatalog <> rawexported) edgemap - when _optCheckExport $ void $ runExceptT $ replaceCatalog pdbapi rawWireCatalog - case (_optShowContent, _optShowjson) of - (_, True) -> putLByteString (Aeson.encode (prepareForPuppetApply wirecatalog)) - (True, _) -> do - unless (_optResourceType == Just "file" || isNothing _optResourceType) $ do - putDoc "Show content only works with resource of type file. It is an error to provide another filter type" - exitFailure - case _optResourceName of - Just f -> printContent f catalog - Nothing -> die "You should supply a resource name when using showcontent" - _ -> do - printFunc (pretty (HM.elems catalog)) - unless (HM.null exported) $ do - printFunc (mempty <+> dullyellow "Exported:" <+> mempty) - printFunc (pretty (HM.elems exported)) + queryfunc node >>= \case + Left rr -> do + putDoc (line <> red "ERROR:" <+> parens (ppline node) <+> getError rr) + exitFailure + Right (rawcatalog, edgemap, rawexported, _) -> do + printFunc <- hIsTerminalDevice stdout >>= \isterm -> return $ \x -> + if isterm + then putDoc (x <> line) + else displayIO stdout (renderCompact (x <> line)) + catalog <- filterCatalog _optResourceType _optResourceName rawcatalog + exported <- filterCatalog _optResourceType _optResourceName rawexported + let wirecatalog = PuppetDB.generateWireCatalog node (catalog <> exported ) edgemap + rawWireCatalog = PuppetDB.generateWireCatalog node (rawcatalog <> rawexported) edgemap + when _optCheckExport $ void $ runExceptT $ PuppetDB.replaceCatalog pdbapi rawWireCatalog + case (_optShowContent, _optShowjson) of + (_, True) -> putLByteString (Aeson.encode (prepareForPuppetApply wirecatalog)) + (True, _) -> do + unless (_optResourceType == Just "file" || isNothing _optResourceType) $ do + putDoc "Show content only works with resource of type file. It is an error to provide another filter type" + exitFailure + case _optResourceName of + Just f -> printContent f catalog + Nothing -> die "You should supply a resource name when using showcontent" + _ -> do + printFunc (pretty (Map.elems catalog)) + unless (Map.null exported) $ do + printFunc (mempty <+> dullyellow "Exported:" <+> mempty) + printFunc (pretty (Map.elems exported)) --- | Filter according to the type and name regex from the command line option +-- Filter according to the type and name regex from the command line option filterCatalog :: Maybe Text -> Maybe Text -> FinalCatalog -> IO FinalCatalog -filterCatalog typeFilter nameFilter = filterC typeFilter (_1 . itype . unpacked) >=> filterC nameFilter (_1 . iname . unpacked) - where - -- filter catalog using the adhoc lens - filterC Nothing _ c = return c - filterC (Just regexp) l c = Reg.compile Reg.compBlank Reg.execBlank (Text.unpack regexp) >>= \case - Left rr -> panic ("Error compiling regexp 're': " <> show rr) - Right reg -> HM.fromList <$> filterM (filterResource reg l) (HM.toList c) - filterResource reg l v = Reg.execute reg (v ^. l) >>= \case - Left rr -> panic ("Error when applying regexp: " <> show rr) - Right Nothing -> return False - _ -> return True +filterCatalog typeFilter nameFilter = + filterC typeFilter (_1 . itype . unpacked) >=> filterC nameFilter (_1 . iname . unpacked) + where + -- filter catalog using the adhoc lens + filterC Nothing _ c = return c + filterC (Just regexp) l c = Reg.compile Reg.compBlank Reg.execBlank (Text.unpack regexp) >>= \case + Left rr -> panic ("Error compiling regexp 're': " <> show rr) + Right reg -> Map.fromList <$> filterM (filterResource reg l) (Map.toList c) + filterResource reg l v = Reg.execute reg (v ^. l) >>= \case + Left rr -> panic ("Error when applying regexp: " <> show rr) + Right Nothing -> return False + _ -> return True run :: Options -> IO () run Options {_optVersion = True, ..} = putStrLn ("language-puppet " ++ Data.Version.showVersion Meta.version) --- | Parse mode +-- Parse mode run Options {_optParse = Just fp, ..} = parseFile fp >>= \case - Left rr -> panic (toS $ P.parseErrorPretty rr) - Right s -> if _optLoglevel == Log.DEBUG - then mapM_ print s - else putDoc $ ppStatements s + Left rr -> panic (toS $ Megaparsec.parseErrorPretty rr) + Right s -> if _optLoglevel == Log.DEBUG + then mapM_ print s + else putDoc $ ppStatements s run Options {_optPuppetdir = Nothing, _optParse = Nothing } = panic "Without a puppet dir, only the `--parse` option can be supported" run Options {_optPuppetdir = Just _, _optNodename = Nothing, _optMultnodes = Nothing} = panic "You need to choose between single or multiple node" --- | Single node mode (`--node` option) +-- Single node mode (`--node` option) run cmd@Options {_optNodename = Just node, _optPuppetdir = Just workingdir, ..} = do - (queryfunc, pdbapi, _, _, _ ) <- initializedaemonWithPuppet workingdir cmd - computeNodeCatalog cmd queryfunc pdbapi node - when _optCommitDB $ void $ runExceptT $ commitDB pdbapi + (queryfunc, pdbapi, _, _, _ ) <- initializedaemonWithPuppet workingdir cmd + computeNodeCatalog cmd queryfunc pdbapi node + when _optCommitDB $ void $ runExceptT $ PuppetDB.commitDB pdbapi --- | Multiple nodes mode (`--all`) option -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 +-- Multiple nodes mode (`--all`) option +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 - retrieveNodes :: MultNodes -> IO [NodeName] - retrieveNodes AllNodes = do - allstmts <- parseFile (workingdir <> "/manifests/site.pp") >>= \case Left err -> panic (show err) - Right x -> return x - let getNodeName (NodeDeclaration (NodeDecl (NodeName n) _ _ _)) = Just n - getNodeName _ = Nothing - return $ mapMaybe getNodeName (V.toList allstmts) - retrieveNodes (MultNodes xs) = pure xs + retrieveNodes :: MultNodes -> IO [NodeName] + retrieveNodes AllNodes = do + allstmts <- parseFile (workingdir <> "/manifests/site.pp") >>= \case + Left err -> panic (show err) + Right x -> return x + let getNodeName (NodeDeclaration (NodeDecl (NodeName n) _ _ _)) = Just n + getNodeName _ = Nothing + return $ mapMaybe getNodeName (V.toList allstmts) + retrieveNodes (MultNodes xs) = pure xs main :: IO () main = execParser opts >>= run - where - opts :: ParserInfo Options - opts = info (helper <*> options) - (fullDesc - <> progDesc "A program for parsing puppet files, generating and inspecting catalogs" - <> header "puppetresources - a development tool for Puppet" - <> failureCode 3) + where + opts :: ParserInfo Options + opts = info (helper <*> options) + (fullDesc + <> progDesc "A program for parsing puppet files, generating and inspecting catalogs" + <> header "puppetresources - a development tool for Puppet" + <> failureCode 3) diff --git a/progs/pdbQuery.hs b/progs/pdbQuery.hs --- a/progs/pdbQuery.hs +++ b/progs/pdbQuery.hs @@ -1,28 +1,23 @@ {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} module Main where -import Puppet.Prelude hiding (option) +import XPrelude hiding (option) -import qualified Data.Aeson as Aeson -import qualified Data.Either.Strict as S -import qualified Data.HashMap.Strict as HM -import qualified Data.Text as Text -import qualified Data.Vector as V -import qualified Data.Version as Version -import qualified Network.HTTP.Client as Http -import Options.Applicative as O -import qualified Paths_language_puppet as Meta -import qualified Servant.Common.BaseUrl as Servant +import qualified Data.Aeson as Aeson +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as Text +import qualified Data.Vector as Vector +import qualified Data.Version as Meta +import qualified Network.HTTP.Client as Http +import Options.Applicative as O +import qualified Paths_language_puppet as Meta import Facter -import Puppet.Interpreter.Types -import PuppetDB.Common -import PuppetDB.Remote -import PuppetDB.TestDB +import Puppet.Interpreter +import PuppetDB data Options = Options @@ -32,42 +27,42 @@ , _pdbversion :: Bool } -data Command = DumpFacts - | DumpFact Text - | DumpNodes - | EditFact Text Text - | DeactivateNode Text - | DumpResources Text - | CreateTestDB FilePath - | AddFacts Text +data Command + = DumpFacts + | DumpFact Text + | DumpNodes + | EditFact Text Text + | DeactivateNode Text + | DumpResources Text + | CreateTestDB FilePath + | AddFacts Text options :: Parser Options options = Options - <$> optional (strOption - ( long "location" - <> short 'l' - <> metavar "FILE|URL" - <> help "Location of the PuppetDB, a file for type 'test' or an URL for type 'remote'")) - <*> option auto - ( long "pdbtype" - <> short 't' - <> value PDBTest - <> help "PuppetDB types : test, remote, dummy") - <*> optional cmd - - <*> switch - ( long "version" - <> help "Output version information and exit") - where - cmd = subparser ( command "resources" (info resourcesparser (progDesc "Output resources for one node" <> failureCode 5)) - <> command "facts" (info factparser (progDesc "Output facts for one node" <> failureCode 12 )) - <> command "nodes" (info (pure DumpNodes)(progDesc "Output all nodes" <> failureCode 8)) - <> command "dumpfacts" (info (pure DumpFacts)(progDesc "Dump all facts, store in /tmp/allfacts.yaml" <> failureCode 4)) - <> command "snapshot" (info createtestdb (progDesc "Create a test DB from the current DB" <> failureCode 10)) - <> command "delnode" (info delnodeparser (progDesc "Deactivate node" <> failureCode 6)) - <> command "editfact" (info factedit (progDesc "Edit a fact corresponding to a node" <> failureCode 7 )) - <> command "addfacts" (info addfacts (progDesc "Adds facts to the test DB for the given node name, if they are not already defined" <> failureCode 11)) - ) + <$> optional (strOption + ( long "location" + <> short 'l' + <> metavar "FILE|URL" + <> help "Location of the PuppetDB, a file for type 'test' or an URL for type 'remote'")) + <*> option auto + ( long "pdbtype" + <> short 't' + <> value PDBTest + <> help "PuppetDB types : test, remote, dummy") + <*> optional cmd + <*> switch + ( long "version" + <> help "Output version information and exit") + where + cmd = subparser ( command "resources" (info resourcesparser (progDesc "Output resources for one node" <> failureCode 5)) + <> command "facts" (info factparser (progDesc "Output facts for one node" <> failureCode 12 )) + <> command "nodes" (info (pure DumpNodes)(progDesc "Output all nodes" <> failureCode 8)) + <> command "dumpfacts" (info (pure DumpFacts)(progDesc "Dump all facts, store in /tmp/allfacts.yaml" <> failureCode 4)) + <> command "snapshot" (info createtestdb (progDesc "Create a test DB from the current DB" <> failureCode 10)) + <> command "delnode" (info delnodeparser (progDesc "Deactivate node" <> failureCode 6)) + <> command "editfact" (info factedit (progDesc "Edit a fact corresponding to a node" <> failureCode 7 )) + <> command "addfacts" (info addfacts (progDesc "Adds facts to the test DB for the given node name, if they are not already defined" <> failureCode 11)) + ) factedit :: Parser Command factedit = EditFact <$> O.argument auto mempty <*> O.argument auto mempty @@ -92,16 +87,8 @@ display s (Left rr) = panic (s <> " " <> show rr) display _ (Right a) = putLByteString (Aeson.encode a) -checkErrorS :: (Show r) => Text -> S.Either r a -> IO a -checkErrorS s (S.Left rr) = panic (s <> " " <> show rr) -checkErrorS _ (S.Right a) = return a - -checkError :: (Show r) => Text -> Either r a -> IO a -checkError s (Left rr) = panic (s <> " " <> show rr) -checkError _ (Right a) = return a - -runCheck :: Show r => Text -> ExceptT r IO a -> IO a -runCheck s = runExceptT >=> checkError s +runCheck :: Doc -> ExceptT PrettyError IO a -> IO a +runCheck s = runExceptT >=> unwrapError s showHelpText :: ParserPrefs -> ParserInfo a -> IO () showHelpText pprefs pinfo = handleParseResult . Failure $ @@ -110,56 +97,57 @@ run :: Options -> IO () run Options {_pdbversion = False, _pdbcmd = Nothing} = putText "Please provide one of the available command (see --help for more information) " *> exitFailure -run Options {_pdbversion = True, ..} = putStrLn ("language-puppet " ++ Version.showVersion Meta.version) +run Options {_pdbversion = True, ..} = putStrLn ("language-puppet " ++ Meta.showVersion Meta.version) run Options{_pdbcmd = Just pdbcmd, ..} = do - mgr <- Http.newManager Http.defaultManagerSettings - epdbapi <- case (_pdbloc, _pdbtype) of - (Just l, PDBRemote) -> pdbConnect mgr $ either (panic . show) identity $ Servant.parseBaseUrl l - (Just l, PDBTest) -> loadTestDB l - (_, x) -> getDefaultDB x - pdbapi <- case epdbapi of - Left r -> panic (show r) - Right x -> return x - case pdbcmd of - DumpFacts -> if _pdbtype == PDBDummy - then puppetDBFacts "dummy" pdbapi >>= mapM_ print . HM.toList - else do - allfacts <- runCheck "get facts" (getFacts pdbapi QEmpty) - tmpdb <- loadTestDB "/tmp/allfacts.yaml" >>= checkError "load test db" - let groupfacts = foldl' groupfact HM.empty allfacts - groupfact curmap (FactInfo ndname fctname fctval) = - 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) - DumpFact n -> runExceptT (getFacts pdbapi (QEqual FCertname n ) ) >>= display "dump fact" - DumpNodes -> runExceptT (getNodes pdbapi QEmpty) >>= display "dump nodes" - DumpResources n -> runExceptT (getResourcesOfNode pdbapi n QEmpty) >>= display "get resources" - AddFacts n -> do - unless (_pdbtype == PDBTest) (panic "This option only works with the test puppetdb") - fcts <- puppetDBFacts n pdbapi - runCheck "replace facts" (replaceFacts pdbapi [(n, fcts)]) - runCheck "commit db" (commitDB pdbapi) - CreateTestDB destfile -> do - ndb <- loadTestDB destfile >>= checkError "puppetdb load" - allnodes <- runCheck "get nodes" (getNodes pdbapi QEmpty) - allfacts <- runCheck "get facts" (getFacts pdbapi QEmpty) - let factsGrouped = HM.toList $ HM.fromListWith (<>) $ map (\x -> (x ^. factInfoNodename, HM.singleton (x ^. factInfoName) (x ^. factInfoVal))) allfacts - runCheck "replace facts" (replaceFacts ndb factsGrouped) - forM_ allnodes $ \pnodename -> do - let ndename = pnodename ^. nodeInfoName - res <- runCheck ("get resources for " <> show ndename) (getResourcesOfNode pdbapi ndename QEmpty) - let wirecatalog = WireCatalog ndename "version" V.empty (V.fromList res) ndename - runCheck "replace catalog" (replaceCatalog ndb wirecatalog) - runCheck "commit db" (commitDB ndb) - _ -> panic "Not yet implemented" + mgr <- Http.newManager Http.defaultManagerSettings + epdbapi <- case (_pdbloc, _pdbtype) of + (Just url, PDBRemote) -> pdbConnect mgr url + (Just l, PDBTest) -> loadTestDB l + (_, x) -> getDefaultDB x + pdbapi <- case epdbapi of + Left r -> panic (show r) + Right x -> return x + case pdbcmd of + DumpFacts -> if _pdbtype == PDBDummy + then puppetDBFacts "dummy" pdbapi >>= mapM_ print . HM.toList + else do + allfacts <- runCheck "get facts" (getFacts pdbapi QEmpty) + tmpdb <- loadTestDB "/tmp/allfacts.yaml" >>= unwrapError "load test db" + let groupfacts = foldl' groupfact HM.empty allfacts + groupfact curmap (FactInfo ndname fctname fctval) = + 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) + DumpFact n -> runExceptT (getFacts pdbapi (QEqual FCertname n ) ) >>= display "dump fact" + DumpNodes -> runExceptT (getNodes pdbapi QEmpty) >>= display "dump nodes" + DumpResources n -> runExceptT (getResourcesOfNode pdbapi n QEmpty) >>= display "get resources" + AddFacts n -> do + unless (_pdbtype == PDBTest) (panic "This option only works with the test puppetdb") + fcts <- puppetDBFacts n pdbapi + runCheck "replace facts" (replaceFacts pdbapi [(n, fcts)]) + runCheck "commit db" (commitDB pdbapi) + CreateTestDB destfile -> do + ndb <- loadTestDB destfile >>= unwrapError "puppetdb load" + allnodes <- runCheck "get nodes" (getNodes pdbapi QEmpty) + allfacts <- runCheck "get facts" (getFacts pdbapi QEmpty) + let factsGrouped = HM.toList $ HM.fromListWith (<>) $ map (\x -> (x ^. factInfoNodename, HM.singleton (x ^. factInfoName) (x ^. factInfoVal))) allfacts + runCheck "replace facts" (replaceFacts ndb factsGrouped) + forM_ allnodes $ \pnodename -> do + let ndename = pnodename ^. nodeInfoName + res <- runCheck ("get resources for " <> ppline ndename) (getResourcesOfNode pdbapi ndename QEmpty) + let wirecatalog = WireCatalog ndename "version" Vector.empty (Vector.fromList res) ndename + runCheck "replace catalog" (replaceCatalog ndb wirecatalog) + runCheck "commit db" (commitDB ndb) + _ -> panic "Not yet implemented" main :: IO () -main = execParser opts >>= run - where - opts :: ParserInfo Options - opts = info (helper <*> options) - (fullDesc - <> progDesc "A program to work with PuppetDB implementations" - <> header "pdbQuery - work with PuppetDB implementations" - <> failureCode 3) +main = + execParser opts >>= run + where + opts :: ParserInfo Options + opts = info (helper <*> options) + (fullDesc + <> progDesc "A program to work with PuppetDB implementations" + <> header "pdbQuery - work with PuppetDB implementations" + <> failureCode 3) diff --git a/progs/yera.hs b/progs/yera.hs --- a/progs/yera.hs +++ b/progs/yera.hs @@ -3,18 +3,14 @@ {-# LANGUAGE StrictData #-} module Main (main) where -import Puppet.Prelude hiding (option) +import XPrelude hiding (option) -import qualified Data.Either.Strict as S -import qualified Data.HashMap.Strict as HM -import qualified Data.List as List +import qualified Data.Either.Strict as S +import qualified Data.HashMap.Strict as Map +import qualified Data.List as List import Options.Applicative -import Text.PrettyPrint.ANSI.Leijen (pretty) import Hiera.Server -import Puppet.Interpreter.PrettyPrinter () -import Puppet.Interpreter.Types -import Puppet.Interpreter.Utils (readQueryType) data Config = Config @@ -46,7 +42,7 @@ main = do Config fp query qtype vars <- execParser configInfo hiera <- startHiera fp - hiera (HM.fromList vars) (toS query) qtype >>= \case + hiera (Map.fromList vars) (toS query) qtype >>= \case S.Left rr -> panic (show rr) S.Right Nothing -> die "no match" S.Right (Just res) -> print (pretty res) diff --git a/src/Erb.hs b/src/Erb.hs new file mode 100644 --- /dev/null +++ b/src/Erb.hs @@ -0,0 +1,9 @@ +-- | Entry point to general Erb service +-- This module share no dependency with Puppet modules +module Erb ( + module Erb.Ruby + , module Erb.Parser +) where + +import Erb.Parser +import Erb.Ruby diff --git a/src/Erb/Compute.hs b/src/Erb/Compute.hs deleted file mode 100644 --- a/src/Erb/Compute.hs +++ /dev/null @@ -1,228 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -module Erb.Compute ( - initTemplateDaemon -) where - -import Puppet.Prelude - -import Data.Aeson.Lens (_Number) -import qualified Data.Either.Strict as S -import qualified Data.FileCache as Cache -import qualified Data.List as List -import Data.String -import qualified Data.Text as Text -import Data.Tuple.Strict (Pair (..)) -import qualified Data.Vector as V -import Debug.Trace -import Foreign.Ruby -import qualified Foreign.Ruby.Bindings as FR -import qualified Foreign.Ruby.Helpers as FR -import GHC.Conc (labelThread) -import Paths_language_puppet (getDataFileName) -import System.Environment (getExecutablePath) -import System.Posix.Files -import Text.Parsec hiding (string) -import Text.Parsec.Error -import Text.Parsec.Pos - -import Erb.Evaluate -import Erb.Parser -import Erb.Ruby -import Puppet.Interpreter.IO -import Puppet.Interpreter.Resolve -import Puppet.Interpreter.Types -import Puppet.PP -import Puppet.Preferences -import Puppet.Stats - -instance IsString TemplateParseError where - fromString s = TemplateParseError $ newErrorMessage (Message s) (initialPos "dummy") - -newtype TemplateParseError = TemplateParseError { tgetError :: ParseError } - -type TemplateQuery = (Chan TemplateAnswer, Either Text Text, InterpreterState, InterpreterReader IO) -type TemplateAnswer = S.Either PrettyError Text - -showRubyError :: RubyError -> PrettyError -showRubyError (Stack msg stk) = PrettyError $ dullred (string msg) dullyellow (string stk) -showRubyError (WithOutput str _) = PrettyError $ dullred (string str) -showRubyError (OtherError rr) = PrettyError (dullred (text rr)) - -initTemplateDaemon :: RubyInterpreter -> Preferences IO -> MStats -> IO (Either Text Text -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError Text)) -initTemplateDaemon intr prefs mvstats = do - controlchan <- newChan - templatecache <- Cache.newFileCache - let returnError rs = return $ \_ _ _ -> return (S.Left (showRubyError rs)) - x <- runExceptT $ do - liftIO (getRubyScriptPath "hrubyerb.rb") >>= ExceptT . loadFile intr - ExceptT (registerGlobalFunction4 intr "varlookup" hrresolveVariable) - ExceptT (registerGlobalFunction5 intr "callextfunc" hrcallfunction) - liftIO $ void $ forkIO $ templateDaemon intr - (Text.pack (prefs ^. prefPuppetPaths.modulesPath)) - (Text.pack (prefs ^. prefPuppetPaths.templatesPath)) - controlchan - mvstats - templatecache - pure $! templateQuery controlchan - either returnError return x - -templateQuery :: Chan TemplateQuery -> Either Text Text -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError Text) -templateQuery qchan filename stt rdr = do - rchan <- newChan - writeChan qchan (rchan, filename, stt, rdr) - readChan rchan - -templateDaemon :: RubyInterpreter -> Text -> Text -> Chan TemplateQuery -> MStats -> Cache.FileCacheR TemplateParseError [RubyStatement] -> IO () -templateDaemon intr modpath templatepath qchan mvstats filecache = do - let nameThread :: String -> IO () - nameThread n = myThreadId >>= flip labelThread n - nameThread "RubyTemplateDaemon" - - (respchan, fileinfo, stt, rdr) <- readChan qchan - case fileinfo of - Right filename -> do - let prts = Text.splitOn "/" filename - searchpathes | length prts > 1 = [modpath <> "/" <> List.head prts <> "/templates/" <> Text.intercalate "/" (List.tail prts), templatepath <> "/" <> filename] - | otherwise = [templatepath <> "/" <> filename] - acceptablefiles <- filterM (fileExist . Text.unpack) searchpathes - if null acceptablefiles - then writeChan respchan (S.Left $ PrettyError $ "Can't find template file for" <+> ttext filename <+> ", looked in" <+> list (map ttext searchpathes)) - else measure mvstats filename (computeTemplate intr (Right (List.head acceptablefiles)) stt rdr mvstats filecache) >>= writeChan respchan - Left _ -> measure mvstats "inline" (computeTemplate intr fileinfo stt rdr mvstats filecache) >>= writeChan respchan - templateDaemon intr modpath templatepath qchan mvstats filecache - -computeTemplate :: RubyInterpreter -> Either Text Text -> InterpreterState -> InterpreterReader IO -> MStats -> Cache.FileCacheR TemplateParseError [RubyStatement] -> IO TemplateAnswer -computeTemplate intr fileinfo stt rdr mstats filecache = do - let (curcontext, fvariables) = case extractFromState stt of - Nothing -> (mempty, mempty) - Just (c,v) -> (c,v) - let (filename, ufilename) = case fileinfo of - Left _ -> ("inline", "inline") - Right x -> (x, Text.unpack x) - mkSafe a = makeSafe intr a >>= \case - Left rr -> return (S.Left (showRubyError rr)) - Right x -> return x - encapsulateError = _Left %~ TemplateParseError - variables = fvariables & traverse . scopeVariables . traverse . _1 . _1 %~ toStr - toStr (PNumber n) = PString (scientific2text n) - toStr x = x - traceEventIO ("START template " ++ Text.unpack filename) - parsed <- case fileinfo of - Right _ -> measure mstats ("parsing - " <> filename) $ Cache.lazyQuery filecache ufilename $ fmap encapsulateError (parseErbFile ufilename) - Left content -> measure mstats ("parsing - " <> filename) $ return $ encapsulateError (runParser erbparser () "inline" (Text.unpack content)) - o <- case parsed of - Left err -> do - let msg = "Template '" <> toS ufilename <> "' could not be parsed " <> show (tgetError err) - logDebug msg - measure mstats ("ruby - " <> filename) $ mkSafe $ computeTemplateWRuby fileinfo curcontext variables stt rdr - Right ast -> case rubyEvaluate variables curcontext ast of - Right ev -> return (S.Right ev) - Left err -> do - let !msg = "Template '" <> toS ufilename <> "' evaluation failed with: " <> show err - logDebug msg - measure mstats ("ruby efail - " <> filename) $ mkSafe $ computeTemplateWRuby fileinfo curcontext variables stt rdr - traceEventIO ("STOP template " ++ Text.unpack filename) - return o - -getRubyScriptPath :: String -> IO String -getRubyScriptPath rubybin = do - let checkpath :: FilePath -> IO FilePath -> IO FilePath - checkpath fp nxt = do - e <- fileExist fp - if e - then return fp - else nxt - withExecutablePath = do - path <- fmap (Text.unpack . takeDirectory . Text.pack) getExecutablePath - let fullpath = path <> "/" <> rubybin - checkpath fullpath $ checkpath ("/usr/local/bin/" <> rubybin) (return rubybin) - cabalPath <- getDataFileName $ "ruby/" ++ rubybin :: IO FilePath - checkpath cabalPath withExecutablePath - --- This must be called from the proper thread. As this is callback, this --- should be ok. -hrresolveVariable :: RValue -> RValue -> RValue -> RValue -> IO RValue --- Text -> Container PValue -> RValue -> RValue -> IO RValue -hrresolveVariable _ rscp rvariables rtoresolve = do - scope <- FR.extractHaskellValue rscp - variables <- FR.extractHaskellValue rvariables - toresolve <- FR.fromRuby rtoresolve - let answer = case toresolve of - Right "~g~e~t_h~a~s~h~" -> - let getvars ctx = (variables ^. ix ctx . scopeVariables) & traverse %~ view (_1 . _1) - vars = getvars "::" <> getvars scope - in Right (PHash vars) - Right t -> getVariable variables scope t - Left rr -> Left ("The variable name is not a string" <+> text rr) - case answer of - Left _ -> getSymbol "undef" - Right r -> FR.toRuby r - -hrcallfunction :: RValue -> RValue -> RValue -> RValue -> RValue -> IO RValue -hrcallfunction _ rfname rargs rstt rrdr = do - efname <- FR.fromRuby rfname - eargs <- FR.fromRuby rargs - rdr <- FR.extractHaskellValue rrdr - stt <- FR.extractHaskellValue rstt - let err :: String -> IO RValue - err rr = fmap (either snd identity) (FR.toRuby (Text.pack rr) >>= FR.safeMethodCall "MyError" "new" . (:[])) - case (,) <$> efname <*> eargs of - Right (fname, varray) | fname `elem` ["template", "inline_template"] -> do - logError $ "Can't parse a call to the external ruby function '" <> fname <> "' n an erb file.\n\tIt is not possible to call it from a Ruby function. It would stall (yes it sucks ...).\n\tChoosing to output \"undef\" !" - getSymbol "undef" - | otherwise -> do - let args = case varray of - [PArray vargs] -> V.toList vargs - _ -> varray - (x,_,_) <- interpretMonad rdr stt (resolveFunction' fname args) - case x of - Right o -> case o ^? _Number of - Just n -> FR.toRuby n - Nothing -> FR.toRuby o - Left rr -> err (show rr) - Left rr -> err rr - -computeTemplateWRuby :: Either Text Text -> Text -> Container ScopeInformation -> InterpreterState -> InterpreterReader IO -> IO TemplateAnswer -computeTemplateWRuby fileinfo curcontext variables stt rdr = FR.freezeGC $ eitherDocIO $ do - rscp <- FR.embedHaskellValue curcontext - rvariables <- FR.embedHaskellValue variables - rstt <- FR.embedHaskellValue stt - rrdr <- FR.embedHaskellValue rdr - let varlist = variables ^. ix curcontext . scopeVariables - -- must be called from a "makeSafe" thingie - contentinfo <- case fileinfo of - Right fname -> FR.toRuby fname - Left _ -> FR.toRuby ("-" :: Text) - let withBinding f = do - erbBinding <- FR.safeMethodCall "ErbBinding" "new" [rscp,rvariables,rstt,rrdr,contentinfo] - case erbBinding of - Left x -> return (Left x) - Right v -> do - forM_ (itoList varlist) $ \(varname, varval :!: _ :!: _) -> FR.toRuby varval >>= FR.rb_iv_set v (Text.unpack varname) - f v - o <- case fileinfo of - Right fname -> do - rfname <- FR.toRuby fname - withBinding $ \v -> FR.safeMethodCall "Controller" "runFromFile" [rfname,v] - Left content -> withBinding $ \v -> FR.toRuby content >>= FR.safeMethodCall "Controller" "runFromContent" . (:[v]) - FR.freeHaskellValue rrdr - FR.freeHaskellValue rstt - FR.freeHaskellValue rvariables - FR.freeHaskellValue rscp - case o of - Left (rr, _) -> - let fname = case fileinfo of - Right f -> Text.unpack f - Left _ -> "inline_template" - in return (S.Left $ PrettyError (dullred (text rr) <+> "in" <+> dullgreen (text fname))) - Right r -> FR.fromRuby r >>= \case - Right result -> return (S.Right result) - Left rr -> return (S.Left $ PrettyError ("Could not deserialiaze ruby output" <+> text rr)) - -eitherDocIO :: IO (S.Either PrettyError a) -> IO (S.Either PrettyError a) -eitherDocIO computation = (computation >>= check) `catch` (\e -> return $ S.Left $ PrettyError $ dullred $ text $ show (e :: SomeException)) - where - check (S.Left r) = return (S.Left r) - check (S.Right x) = return (S.Right x) diff --git a/src/Erb/Evaluate.hs b/src/Erb/Evaluate.hs deleted file mode 100644 --- a/src/Erb/Evaluate.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE LambdaCase #-} --- | Evaluates a ruby template from what's generated by "Erb.Parser". -module Erb.Evaluate ( - rubyEvaluate - , extractFromState - ) where - -import Puppet.Prelude - -import Data.Aeson.Lens -import qualified Data.Char as Char -import qualified Data.HashMap.Strict as HM -import qualified Data.List as List -import Data.Maybe (fromMaybe) -import qualified Data.Text as Text -import Data.Tuple.Strict (Pair (..)) -import qualified Data.Vector as V - -import Erb.Ruby -import Puppet.Interpreter.Resolve -import Puppet.Interpreter.Types -import Puppet.Interpreter.Utils -import Puppet.Parser.Utils -import Puppet.PP -import qualified Text.PrettyPrint.ANSI.Leijen as P - -extractFromState :: InterpreterState -> Maybe (Text, Container ScopeInformation) -extractFromState stt = - let cs = stt ^. curScope - in if null cs - then Nothing - else let scp = scopeName (List.head cs) - classes = (PArray . V.fromList . map PString . HM.keys) (stt ^. loadedClasses) - scps = stt ^. scopes - cd = fromMaybe ContRoot (scps ^? ix scp . scopeContainer . cctype) -- get the current containder description - cscps = scps & ix scp . scopeVariables . at "classes" ?~ ( classes :!: dummyppos :!: cd ) - in Just (scp, cscps) - -rubyEvaluate :: Container ScopeInformation -> Text -> [RubyStatement] -> Either Doc Text -rubyEvaluate vars ctx = foldl (evalruby vars ctx) (Right "") . optimize - where - optimize [] = [] - optimize (Puts x : DropPrevSpace' : xs) = optimize $ DropPrevSpace (Puts x) : xs - optimize (x:xs) = x : optimize xs - -spaceNotCR :: Char -> Bool -spaceNotCR c = Char.isSpace c && c /= '\n' && c /= '\r' - -evalruby :: Container ScopeInformation -> Text -> Either Doc Text -> RubyStatement -> Either Doc Text -evalruby _ _ (Left err) _ = Left err -evalruby _ _ (Right _) (DropPrevSpace') = Left "Could not evaluate a non optimize DropPrevSpace'" -evalruby mp ctx (Right curstr) (DropNextSpace x) = - case evalruby mp ctx (Right curstr) x of - Left err -> Left err - Right y -> Right (Text.dropWhile spaceNotCR y) -evalruby mp ctx (Right curstr) (DropPrevSpace x) = - case evalruby mp ctx (Right curstr) x of - Left err -> Left err - Right y -> Right (Text.dropWhileEnd spaceNotCR y) -evalruby mp ctx (Right curstr) (Puts e) = case evalExpression mp ctx e of - Left err -> Left err - Right ex -> Right (curstr <> ex) - -evalExpression :: Container ScopeInformation -> Text -> Expression -> Either Doc Text -evalExpression mp ctx (LookupOperation varname varindex) = do - rvname <- evalExpression mp ctx varname - rvindx <- evalExpression mp ctx varindex - getVariable mp ctx rvname >>= \case - PArray arr -> - case a2i rvindx of - Nothing -> Left $ "Can't convert index to integer when resolving" <+> ttext rvname P.<> brackets (ttext rvindx) - Just i -> if fromIntegral (V.length arr) <= i - then Left $ "Array out of bound" <+> ttext rvname P.<> brackets (ttext rvindx) - else evalValue (arr V.! fromIntegral i) - PHash hs -> case hs ^. at rvindx of - Just x -> evalValue x - _ -> Left $ "Can't index variable" <+> ttext rvname <+> ", it is " <+> pretty (PHash hs) - varvalue -> Left $ "Can't index variable" <+> ttext rvname <+> ", it is " <+> pretty varvalue -evalExpression _ _ (Value (Literal x)) = Right x -evalExpression mp ctx (Object (Value (Literal x))) = getVariable mp ctx x >>= evalValue -evalExpression _ _ x = Left $ "Can't evaluate" <+> pretty x - -evalValue :: PValue -> Either Doc Text -evalValue (PString x) = Right x -evalValue (PNumber x) = Right (scientific2text x) -evalValue x = Right $ show x - -a2i :: Text -> Maybe Integer -a2i x = case text2Scientific x of - Just y -> y ^? _Integer - _ -> Nothing diff --git a/src/Erb/Parser.hs b/src/Erb/Parser.hs --- a/src/Erb/Parser.hs +++ b/src/Erb/Parser.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE LambdaCase #-} module Erb.Parser where -import Puppet.Prelude hiding (option, try) +import XPrelude.Extra hiding (option, try) import Control.Exception (catch) import qualified Data.Text as Text @@ -172,11 +171,12 @@ erbparser = textblock parseErbFile :: FilePath -> IO (Either ParseError [RubyStatement]) -parseErbFile fname = parseContent `catch` handler - where - parseContent = (runParser erbparser () fname . Text.unpack) `fmap` readFile fname - handler e = let msg = show (e :: SomeException) - in return $ Left $ newErrorMessage (Message msg) (initialPos fname) +parseErbFile fname = + parseContent `catch` handler + where + parseContent = (runParser erbparser () fname . Text.unpack) `fmap` readFile fname + handler e = let msg = show (e :: SomeException) + in return $ Left $ newErrorMessage (Message msg) (initialPos fname) parseErbString :: String -> Either ParseError [RubyStatement] parseErbString = runParser erbparser () "dummy" diff --git a/src/Erb/Ruby.hs b/src/Erb/Ruby.hs --- a/src/Erb/Ruby.hs +++ b/src/Erb/Ruby.hs @@ -1,9 +1,7 @@ -- | Base types for the internal ruby parser ("Erb.Parser"). module Erb.Ruby where -import Puppet.Prelude hiding ((<>)) - -import Text.PrettyPrint.ANSI.Leijen +import XPrelude data Value = Literal !Text @@ -44,11 +42,11 @@ instance Pretty Expression where pretty (LookupOperation a b) = pretty a <> brackets (pretty b) - pretty (PlusOperation a b) = parens (pretty a <+> text "+" <+> pretty b) - pretty (MinusOperation a b) = parens (pretty a <+> text "-" <+> pretty b) - pretty (DivOperation a b) = parens (pretty a <+> text "/" <+> pretty b) - pretty (MultiplyOperation a b) = parens (pretty a <+> text "*" <+> pretty b) - pretty op = text (show op) + pretty (PlusOperation a b) = parens (pretty a <+> "+" <+> pretty b) + pretty (MinusOperation a b) = parens (pretty a <+> "-" <+> pretty b) + pretty (DivOperation a b) = parens (pretty a <+> "/" <+> pretty b) + pretty (MultiplyOperation a b) = parens (pretty a <+> "*" <+> pretty b) + pretty op = ppline (show op) data RubyStatement = Puts !Expression diff --git a/src/Facter.hs b/src/Facter.hs --- a/src/Facter.hs +++ b/src/Facter.hs @@ -1,39 +1,55 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} module Facter where import Prelude -import Control.Arrow import Control.Lens -import Control.Monad.Trans.Except +import Data.Aeson import Data.Char -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import Data.List (intercalate, stripPrefix) -import Data.List.Split (splitOn) -import Data.Maybe (mapMaybe) -import qualified Data.Text as T -import Puppet.Interpreter.Types -import System.Directory (doesFileExist) +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import Data.List (intercalate, stripPrefix) +import Data.List.Split (splitOn) +import Data.Maybe (mapMaybe) +import qualified Data.Text as T +import System.Directory (doesFileExist) import System.Environment -import System.Posix.Unistd (SystemID (..), getSystemID) +import System.Posix.Unistd (SystemID (..), getSystemID) import System.Posix.User import Text.Printf +import Puppet.Language + +type Facts = HM.HashMap T.Text PValue + +data FactInfo = FactInfo + { _factInfoNodename :: !NodeName + , _factInfoName :: !T.Text + , _factInfoVal :: !PValue + } +makeClassy ''FactInfo + +instance ToJSON FactInfo where + toJSON (FactInfo n f v) = object [("certname", String n), ("name", String f), ("value", toJSON v)] + +instance FromJSON FactInfo where + parseJSON (Object v) = FactInfo <$> v .: "certname" <*> v .: "name" <*> v .: "value" + parseJSON _ = fail "invalid fact info" + storageunits :: [(String, Int)] storageunits = [ ("", 0), ("K", 1), ("M", 2), ("G", 3), ("T", 4) ] getPrefix :: Int -> String getPrefix n | null fltr = error $ "Could not get unit prefix for order " ++ show n | otherwise = fst $ head fltr - where fltr = filter (\(_, x) -> x == n) storageunits + where fltr = filter (\(_, x) -> x == n) storageunits getOrder :: String -> Int getOrder n | null fltr = error $ "Could not get order for unit prefix " ++ show n | otherwise = snd $ head fltr - where - nu = map toUpper n - fltr = filter (\(x, _) -> x == nu) storageunits + where + nu = map toUpper n + fltr = filter (\(x, _) -> x == nu) storageunits normalizeUnit :: (Double, Int) -> Double -> (Double, Int) normalizeUnit (unit, order) base | unit > base = normalizeUnit (unit/base, order + 1) base @@ -41,12 +57,12 @@ storagedesc :: (String, String) -> String storagedesc (ssize, unit) = let - size = read ssize :: Double - uprefix | unit == "B" = "" - | otherwise = [head unit] - uorder = getOrder uprefix - (osize, oorder) = normalizeUnit (size, uorder) 1024 - in printf "%.2f %sB" osize (getPrefix oorder) + size = read ssize :: Double + uprefix | unit == "B" = "" + | otherwise = [head unit] + uorder = getOrder uprefix + (osize, oorder) = normalizeUnit (size, uorder) 1024 + in printf "%.2f %sB" osize (getPrefix oorder) factRAM :: IO [(String, String)] factRAM = do @@ -170,29 +186,3 @@ let cpuinfos = zip [ "processor" ++ show (n :: Int) | n <- [0..]] modelnames modelnames = mapMaybe (fmap (dropWhile (`elem` ("\t :" :: String))) . stripPrefix "model name") (lines cpuinfo) return $ ("processorcount", show (length cpuinfos)) : cpuinfos - -puppetDBFacts :: NodeName -> PuppetDBAPI IO -> IO (Container PValue) -puppetDBFacts node pdbapi = - 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]) - let ofacts = genFacts $ map (T.pack *** T.pack) rawFacts - (hostname, ddomainname) = T.break (== '.') node - domainname = if T.null ddomainname - then "" - else T.tail ddomainname - nfacts = genFacts [ ("fqdn", node) - , ("hostname", hostname) - , ("domain", domainname) - , ("rootrsa", "xxx") - , ("operatingsystem", "Ubuntu") - , ("puppetversion", "language-puppet") - , ("virtual", "xenu") - , ("clientcert", node) - , ("is_virtual", "true") - , ("concat_basedir", "/var/lib/puppet/concat") - ] - allfacts = nfacts `HM.union` ofacts - genFacts = HM.fromList - return (allfacts & traverse %~ PString) diff --git a/src/Hiera/Server.hs b/src/Hiera/Server.hs --- a/src/Hiera/Server.hs +++ b/src/Hiera/Server.hs @@ -1,8 +1,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} @@ -15,69 +15,109 @@ module Hiera.Server ( startHiera , dummyHiera - -- * Query API + , HieraQueryType (..) + , readQueryType , HieraQueryFunc ) where -import Puppet.Prelude +import XPrelude -import Control.Monad.Except -import Data.Aeson (FromJSON, Value (..), (.!=), (.:), - (.:?)) -import qualified Data.Aeson as Aeson +import Data.Aeson +import qualified Data.Aeson as Aeson import Data.Aeson.Lens -import qualified Data.Attoparsec.Text as AT -import qualified Data.ByteString.Lazy as BS -import qualified Data.Either.Strict as S -import qualified Data.FileCache as Cache -import qualified Data.List as List -import Data.String (fromString) -import qualified Data.Text as Text -import qualified Data.Vector as Vector -import qualified Data.Yaml as Yaml -import qualified System.FilePath as FilePath -import System.FilePath.Lens (directory) +import qualified Data.Attoparsec.Text as AT +import qualified Data.ByteString.Lazy as BS +import qualified Data.Either.Strict as S +import qualified Data.FileCache as Cache +import qualified Data.List as List +import Data.String (fromString) +import qualified Data.Text as Text +import qualified Data.Vector as Vector +import qualified Data.Yaml as Yaml +import qualified System.FilePath as FilePath +import System.FilePath.Lens (directory) -import Puppet.Interpreter.Types -import Puppet.PP +import Puppet.Language -data HieraConfigFile = HieraConfigFile - { _version :: Int - , _backends :: [Backend] - , _hierarchy :: [InterpolableHieraString] - } deriving (Show) +-- | The different kind of hiera queries. +data HieraQueryType + = QFirst -- ^ The first match in the hierarchy is returned. + | QUnique -- ^ Combines array and scalar values to return a merged, flattened array with all duplicate removed. + | QHash -- ^ Combines the keys and values of any number of hashes to return a merged hash. + -- | Use of an Hash to specify the merge behavior + | QDeep { _knockoutPrefix :: Maybe Text + , _sortMerged :: Bool + , _mergeHashArray :: Bool + } deriving (Show) +readQueryType :: Text -> Maybe HieraQueryType +readQueryType s = + case s of + "first" -> Just QFirst + "unique" -> Just QUnique + "hash" -> Just QHash + _ -> Nothing +-- | The type of the Hiera API function associated to given hierarchy. +type HieraQueryFunc m = Container Text -- ^ Scope: all variables that Hiera can interpolate (the top level ones are prefixed with '::') + -> Text -- ^ The query + -> HieraQueryType + -> m (S.Either PrettyError (Maybe PValue)) + data Backend = YamlBackend FilePath | JsonBackend FilePath - deriving Show + deriving (Show) -newtype InterpolableHieraString - = InterpolableHieraString +data HieraStringPart + = HPString Text + | HPVariable Text + deriving (Show) + +instance Pretty HieraStringPart where + pretty (HPString t) = ppline t + pretty (HPVariable v) = dullred (ppline ("%{" <> v <> "}")) + prettyList = mconcat . map pretty + +newtype InterpolableHieraString = InterpolableHieraString { getInterpolableHieraString :: [HieraStringPart] - } deriving Show + } deriving (Show) -data HieraStringPart = HPString Text - | HPVariable Text - deriving Show +resolveString :: Container Text -> InterpolableHieraString -> Maybe Text +resolveString vars = fmap Text.concat . mapM resolve . getInterpolableHieraString + where + resolve (HPString x) = Just x + resolve (HPVariable v) = vars ^? ix v -instance Pretty HieraStringPart where - pretty (HPString t) = ttext t - pretty (HPVariable v) = dullred (string "%{" <> ttext v <> string "}") - prettyList = mconcat . map pretty +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" -type Cache = Cache.FileCacheR String Value +-- | An attoparsec parser that turns text into parts that are ready for interpolation. +interpolableString :: AT.Parser [HieraStringPart] +interpolableString = AT.many1 (fmap HPString rawPart <|> fmap HPVariable interpPart) + where + rawPart = AT.takeWhile1 (/= '%') + interpPart = AT.string "%{" *> AT.takeWhile1 (/= '}') <* AT.char '}' -data QRead - = QRead - { _qvars :: Container Text - , _qtype :: HieraQueryType - , _qhier :: [Value] - } +parseInterpolableString :: Text -> Either String [HieraStringPart] +parseInterpolableString = AT.parseOnly interpolableString -makeClassy ''HieraConfigFile +data HieraConfigFile = HieraConfigFile + { _version :: Int + , _backends :: [Backend] + , _hierarchy :: [InterpolableHieraString] + } deriving (Show) + +data QRead = QRead + { _qvars :: Container Text + , _qtype :: HieraQueryType + , _qhier :: [Value] + } + makeLenses ''QRead instance FromJSON HieraConfigFile where @@ -87,7 +127,7 @@ [hierarchy_value] <- v .: "hierarchy" datadir <- case Object v ^? key "defaults" . key "datadir" of Just (String dir) -> pure dir - Just _ -> fail ("datadir should be a string") + Just _ -> fail "datadir should be a string" Nothing -> hierarchy_value .: "datadir" .!= "hieradata" HieraConfigFile <$> pure 5 @@ -104,36 +144,21 @@ (backendConstructor, skey) <- case name of "yaml" -> return (YamlBackend, ":yaml") "json" -> return (JsonBackend, ":json") - _ -> fail ("Unknown backend " ++ Text.unpack name) + _ -> fail ("Unknown backend " <> toS name) datadir <- case Object v ^? key skey . key ":datadir" of - Just (String dir) -> return dir - Just _ -> fail ":datadir should be a string" - Nothing -> return "/etc/puppet/hieradata" - pure (backendConstructor (Text.unpack datadir)) + Just (String dir) -> return dir + Just _ -> fail ":datadir should be a string" + Nothing -> return "/etc/puppet/hieradata" + pure (backendConstructor (toS datadir)) in - Aeson.withObject "v3 or v5" $ \o -> do + Aeson.withObject "v3 or v5" $ \o -> o .:? "version" >>= \case Just (5::Int) -> mkHiera5 o Just _ -> fail "Hiera configuration version different than 5 is not supported." Nothing -> mkHiera3 o -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" - - --- | An attoparsec parser that turns text into parts that are ready for interpolation -interpolableString :: AT.Parser [HieraStringPart] -interpolableString = AT.many1 (fmap HPString rawPart <|> fmap HPVariable interpPart) - where - rawPart = AT.takeWhile1 (/= '%') - interpPart = AT.string "%{" *> AT.takeWhile1 (/= '}') <* AT.char '}' - -parseInterpolableString :: Text -> Either String [HieraStringPart] -parseInterpolableString = AT.parseOnly interpolableString +type Cache = Cache.FileCacheR String Value -- | The only method you'll ever need. It runs a Hiera server and gives you a querying function. -- | All IO exceptions are thrown directly including ParsingException. @@ -144,55 +169,50 @@ logInfoStr ("Detect a hiera configuration format in " <> fp <> " at version 4. This format is not recognized. Using a dummy hiera.") pure dummyHiera Left ex -> panic (show ex) - Right cfg -> do - logInfoStr ("Detect a hiera configuration format in " <> fp <> " at version " <> show(cfg^.version)) + Right cfg@HieraConfigFile{..} -> do + logInfoStr ("Detect a hiera configuration format in " <> fp <> " at version " <> show _version) cache <- Cache.newFileCache pure (query cfg fp cache) --- | A dummy hiera function that will be used when hiera is not detected +-- | A dummy hiera function that will be used when hiera is not detected. dummyHiera :: Monad m => HieraQueryFunc m dummyHiera _ _ _ = return $ S.Right Nothing -resolveString :: Container Text -> InterpolableHieraString -> Maybe Text -resolveString vars = fmap Text.concat . mapM resolve . getInterpolableHieraString - where - resolve (HPString x) = Just x - resolve (HPVariable v) = vars ^? ix v query :: HieraConfigFile -> FilePath -> Cache -> HieraQueryFunc IO query HieraConfigFile {_version, _backends, _hierarchy} fp cache vars hquery qt = do - -- step 1, resolve hierarchies - let searchin = do - mhierarchy <- resolveString vars <$> _hierarchy - Just h <- [mhierarchy] - backend <- _backends - let decodeInfo :: (FilePath -> IO (S.Either String Value), String, String) - decodeInfo = do - case backend of - JsonBackend dir -> (fmap (strictifyEither . Aeson.eitherDecode') . BS.readFile , dir, ".json") - YamlBackend dir -> (fmap (strictifyEither . (_Left %~ show)) . Yaml.decodeFileEither, dir, ".yaml") - return (decodeInfo, Text.unpack h) - -- step 2, read all the files, returning a raw data structure - mvals <- forM searchin $ \((decodefunction, datadir, extension), h) -> do - let extension' = if snd (FilePath.splitExtension h) == ".yaml" - then "" - else extension - filename = basedir <> datadir <> "/" <> h <> extension' - basedir = case datadir of - '/' : _ -> mempty - _ -> fp ^. directory <> "/" - efilecontent <- Cache.query cache filename (decodefunction filename) - case efilecontent of - S.Left r -> do - let errs = "Hiera: error when reading file " <> string filename <+> string r - if "Yaml file not found: " `List.isInfixOf` r - then logDebug (show errs) - else logWarning (show errs) - return Nothing - S.Right val -> return (Just val) - let vals = catMaybes mvals - -- step 3, query through all the results - return (strictifyEither $ runReader (runExceptT (recursiveQuery hquery [])) (QRead vars qt vals)) + -- step 1, resolve hierarchies + let searchin = do + mhierarchy <- resolveString vars <$> _hierarchy + Just h <- [mhierarchy] + backend <- _backends + let decodeInfo :: (FilePath -> IO (S.Either String Value), String, String) + decodeInfo = + case backend of + JsonBackend dir -> (fmap (strictifyEither . Aeson.eitherDecode') . BS.readFile , dir, ".json") + YamlBackend dir -> (fmap (strictifyEither . (_Left %~ show)) . Yaml.decodeFileEither, dir, ".yaml") + return (decodeInfo, Text.unpack h) + -- step 2, read all the files, returning a raw data structure + mvals <- forM searchin $ \((decodefunction, datadir, extension), h) -> do + let extension' = if snd (FilePath.splitExtension h) == ".yaml" + then "" + else extension + filename = basedir <> datadir <> "/" <> h <> extension' + basedir = case datadir of + '/' : _ -> mempty + _ -> fp ^. directory <> "/" + efilecontent <- Cache.query cache filename (decodefunction filename) + case efilecontent of + S.Left r -> do + let errs = "Hiera: error when reading file " <> ppstring filename <+> ppstring r + if "Yaml file not found: " `List.isInfixOf` r + then logDebug (show errs) + else logWarning (show errs) + return Nothing + S.Right val -> return (Just val) + let vals = catMaybes mvals + -- step 3, query through all the results + return (strictifyEither $ runReader (runExceptT (recursiveQuery hquery [])) (QRead vars qt vals)) type QM a = ExceptT PrettyError (Reader QRead) a @@ -208,54 +228,54 @@ case lookups of [] -> return Nothing (x:xs) -> do - qt <- view qtype - let evalue = foldM (mergeWith qt) x xs - case Aeson.fromJSON <$> evalue of - Left _ -> return Nothing - Right (Aeson.Success o) -> return o - Right (Aeson.Error rr) -> throwError ("Something horrible happened in recursiveQuery: " <> fromString (show rr)) + qt <- view qtype + let evalue = foldM (mergeWith qt) x xs + case Aeson.fromJSON <$> evalue of + Left _ -> return Nothing + Right (Aeson.Success o) -> return o + Right (Aeson.Error rr) -> throwError ("Something horrible happened in recursiveQuery: " <> fromString (show rr)) resolveValue :: [Text] -> Value -> QM Value resolveValue prevqueries value = - case value of - String t -> String <$> resolveText prevqueries t - Array arr -> Array <$> mapM (resolveValue prevqueries) arr - Object hh -> Object <$> mapM (resolveValue prevqueries) hh - _ -> return value + case value of + String t -> String <$> resolveText prevqueries t + Array arr -> Array <$> mapM (resolveValue prevqueries) arr + Object hh -> Object <$> mapM (resolveValue prevqueries) hh + _ -> return value resolveText :: [Text] -> Text -> QM Text -resolveText prevqueries t - = case parseInterpolableString t of - Right qparts -> Text.concat <$> mapM (resolveStringPart prevqueries) qparts - Left _ -> return t +resolveText prevqueries t = + case parseInterpolableString t of + Right qparts -> Text.concat <$> mapM (resolveStringPart prevqueries) qparts + Left _ -> return t resolveStringPart :: [Text] -> HieraStringPart -> QM Text -resolveStringPart prevqueries sp - = case sp of - HPString s -> return s - HPVariable varname -> do - let varsolve = fmap PString . preview (ix varname) <$> view qvars - r <- case Text.stripPrefix "lookup('" varname >>= Text.stripSuffix "')" of - Just lk -> recursiveQuery lk prevqueries - Nothing -> varsolve - case r of - Just (PString v) -> return v - _ -> return mempty +resolveStringPart prevqueries sp = + case sp of + HPString s -> return s + HPVariable varname -> do + let varsolve = fmap PString . preview (ix varname) <$> view qvars + r <- case Text.stripPrefix "lookup('" varname >>= Text.stripSuffix "')" of + Just lk -> recursiveQuery lk prevqueries + Nothing -> varsolve + case r of + Just (PString v) -> return v + _ -> return mempty mergeWith :: HieraQueryType -> Value -> Value -> Either PrettyError Value -mergeWith qt cur new - = case qt of +mergeWith qt cur new = + case qt of QFirst -> return cur QUnique -> - let getArray x = case x of - Array array -> Vector.toList array - _ -> [x] - curarray = getArray cur - newarray = getArray new - in case new of - Object _ -> throwError "Tried to merge a hash" - _ -> return (Array (Vector.fromList (List.nub (curarray ++ newarray)))) + let getArray x = case x of + Array array -> Vector.toList array + _ -> [x] + curarray = getArray cur + newarray = getArray new + in case new of + Object _ -> throwError "Tried to merge a hash" + _ -> return (Array (Vector.fromList (List.nub (curarray ++ newarray)))) QHash -> case (cur, new) of - (Object curh, Object newh) -> return (Object (curh <> newh)) - _ -> throwError (PrettyError ("Tried to merge things that are not hashes: " <> text (show cur) <+> text (show new))) + (Object curh, Object newh) -> return (Object (curh <> newh)) + _ -> throwError (PrettyError ("Tried to merge things that are not hashes: " <> ppline (show cur) <+> ppline (show new))) QDeep{} -> throwError "deep queries not supported" diff --git a/src/Puppet/Daemon.hs b/src/Puppet/Daemon.hs deleted file mode 100644 --- a/src/Puppet/Daemon.hs +++ /dev/null @@ -1,216 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE TupleSections #-} -module Puppet.Daemon ( - Daemon(..) - , initDaemon - -- * Utils - , checkError - -- * Re-exports - , module Puppet.Interpreter.Types - , module Puppet.PP -) where - -import Puppet.Prelude - -import qualified Data.Either.Strict as S -import Data.FileCache as FileCache -import qualified Data.HashMap.Strict as HM -import qualified Data.List as List -import qualified Data.Text as Text -import qualified Data.Vector as V -import Debug.Trace (traceEventIO) -import Foreign.Ruby.Safe -import qualified System.Directory as Directory -import qualified System.Log.Formatter as Log (simpleLogFormatter) -import qualified System.Log.Handler as Log (setFormatter) -import qualified System.Log.Handler.Simple as Log (streamHandler) -import qualified System.Log.Logger as Log -import qualified Text.Megaparsec as Megaparsec - -import Erb.Compute -import Hiera.Server -import Puppet.Interpreter -import Puppet.Interpreter.IO -import Puppet.Interpreter.Types -import Puppet.Lens (_PrettyError) -import Puppet.Manifests -import Puppet.OptionalTests -import Puppet.Parser -import Puppet.Parser.Types -import Puppet.PP -import Puppet.Preferences -import Puppet.Stats - - -{-| API for the Daemon. -The main method is `getCatalog`: given a node and a list of facts, it returns the result of the compilation. -This will be either an error, or a tuple containing: - -- all the resources in this catalog -- the dependency map -- the exported resources -- a list of known resources, that might not be up to date, but are here for code coverage tests. - -Notes : - -* It might be buggy when top level statements that are not class\/define\/nodes are altered. --} -data Daemon = Daemon - { getCatalog :: NodeName -> Facts -> IO (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) - , parserStats :: MStats - , catalogStats :: MStats - , templateStats :: MStats - } - -{-| Entry point to get a Daemon -It will initialize the parsing and interpretation infrastructure from the 'Preferences'. - -Internally it initializes a thread for the Ruby interpreter. -It should cache the AST of every .pp file, and could use a bit of memory. As a comparison, it -fits in 60 MB with the author's manifests, but really breathes when given 300 MB -of heap space. In this configuration, even if it spawns a ruby process for every -template evaluation, it is way faster than the puppet stack. - -It can optionally talk with PuppetDB, by setting an URL via the 'prefPDB'. -The recommended way to set it to http://localhost:8080 and set a SSH tunnel : - -> ssh -L 8080:localhost:8080 puppet.host --} -initDaemon :: Preferences IO - -> IO Daemon -initDaemon pref = do - setupLogger (pref ^. prefLogLevel) - logDebug "Initialize daemon" - traceEventIO "initDaemon" - hquery <- hQueryApis pref - fcache <- newFileCache - intr <- startRubyInterpreter - templStats <- newStats - getTemplate <- initTemplateDaemon intr pref templStats - catStats <- newStats - parseStats <- newStats - return (Daemon - (getCatalog' pref (parseFunc (pref ^. prefPuppetPaths) fcache parseStats) getTemplate catStats hquery) - parseStats - catStats - templStats - ) - -hQueryApis :: Preferences IO -> IO (HieraQueryLayers IO) -hQueryApis pref = do - api0 <- case pref ^. prefHieraPath of - Just p -> startHiera p - Nothing -> pure dummyHiera - modapis <- getModApis pref - pure (HieraQueryLayers api0 modapis) - -getModApis :: Preferences IO -> IO (Container (HieraQueryFunc IO)) -getModApis pref = do - let ignored_modules = pref^.prefIgnoredmodules - modpath = pref^.prefPuppetPaths.modulesPath - dirs <- Directory.listDirectory modpath - (HM.fromList . catMaybes) <$> - for dirs (\dir -> runMaybeT $ do - let modname = toS dir - path = modpath <> "/" <> dir <> "/hiera.yaml" - guard (modname `notElem` ignored_modules) - guard =<< liftIO (Directory.doesFileExist path) - liftIO $ (modname, ) <$> startHiera path) - --- | In case of a Left value, print the error and exit immediately -checkError :: Show e => Doc -> Either e a -> IO a -checkError desc = either exit return - where - exit = \err -> putDoc (display err) >> exitFailure - display err = red desc <> ": " <+> (string . show) err - - --- Internal functions - -getCatalog' :: Preferences IO - -> ( TopLevelType -> Text -> IO (S.Either PrettyError Statement) ) - -> (Either Text Text -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError Text)) - -> MStats - -> HieraQueryLayers IO - -> NodeName - -> Facts - -> IO (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) -getCatalog' pref parsingfunc getTemplate stats hquery node facts = do - logDebug ("Received query for node " <> node) - traceEventIO ("START getCatalog' " <> Text.unpack node) - let catalogComputation = interpretCatalog (InterpreterReader - (pref ^. prefNatTypes) - parsingfunc - getTemplate - (pref ^. prefPDB) - (pref ^. prefExtFuncs) - node - hquery - defaultImpureMethods - (pref ^. prefIgnoredmodules) - (pref ^. prefExternalmodules) - (pref ^. prefStrictness == Strict) - (pref ^. prefPuppetPaths) - (pref ^. prefRebaseFile) - ) - node - facts - (pref ^. prefPuppetSettings) - (stmts :!: warnings) <- measure stats node catalogComputation - mapM_ (\(p :!: m) -> Log.logM loggerName p (displayS (renderCompact (ttext node <> ":" <+> m)) "")) warnings - traceEventIO ("STOP getCatalog' " <> Text.unpack node) - if pref ^. prefExtraTests - then runOptionalTests stmts - else pure stmts - where - runOptionalTests stm = case stm ^? _Right._1 of - Nothing -> pure stm - (Just c) -> catching _PrettyError - (do {testCatalog pref c; pure stm}) - (pure . Left) - --- | Return an HOF that would parse the file associated with a toplevel. --- The toplevel is defined by the tuple (type, name) --- The result of the parsing is a single Statement (which recursively contains others statements) -parseFunc :: PuppetDirPaths -> FileCache (V.Vector Statement) -> MStats -> TopLevelType -> Text -> IO (S.Either PrettyError Statement) -parseFunc ppath filecache stats = \toptype topname -> - let nameparts = Text.splitOn "::" topname in - let topLevelFilePath :: TopLevelType -> Text -> Either PrettyError Text - topLevelFilePath TopNode _ = Right $ Text.pack (ppath^.manifestPath <> "/site.pp") - topLevelFilePath _ name - | length nameparts == 1 = Right $ Text.pack (ppath^.modulesPath) <> "/" <> name <> "/manifests/init.pp" - | null nameparts = Left $ PrettyError ("Invalid toplevel" <+> squotes (ttext name)) - | otherwise = Right $ Text.pack (ppath^.modulesPath) <> "/" <> List.head nameparts <> "/manifests/" <> Text.intercalate "/" (List.tail nameparts) <> ".pp" - in - case topLevelFilePath toptype topname of - Left rr -> return (S.Left rr) - Right fname -> do - let sfname = Text.unpack fname - handleFailure :: SomeException -> IO (S.Either String (V.Vector Statement)) - handleFailure e = return (S.Left (show e)) - x <- measure stats fname (FileCache.query filecache sfname (parseFile sfname `catch` handleFailure)) - case x of - S.Right stmts -> filterStatements toptype topname stmts - S.Left rr -> return (S.Left (PrettyError (red (text rr)))) - - -parseFile :: FilePath -> IO (S.Either String (V.Vector Statement)) -parseFile fname = do - traceEventIO ("START parsing " ++ fname) - cnt <- readFile fname - o <- case runPParser fname cnt of - Right r -> traceEventIO ("Stopped parsing " ++ fname) >> return (S.Right r) - Left rr -> traceEventIO ("Stopped parsing " ++ fname ++ " (failure: " ++ Megaparsec.parseErrorPretty rr ++ ")") >> return (S.Left (Megaparsec.parseErrorPretty rr)) - traceEventIO ("STOP parsing " ++ fname) - return o - - -setupLogger :: Log.Priority -> IO () -setupLogger p = do - Log.updateGlobalLogger loggerName (Log.setLevel p) - hs <- consoleLogHandler - Log.updateGlobalLogger Log.rootLoggerName $ Log.setHandlers [hs] - where - consoleLogHandler = Log.setFormatter - <$> Log.streamHandler stdout Log.DEBUG - <*> pure (Log.simpleLogFormatter "$prio: $msg") diff --git a/src/Puppet/Interpreter.hs b/src/Puppet/Interpreter.hs --- a/src/Puppet/Interpreter.hs +++ b/src/Puppet/Interpreter.hs @@ -1,19 +1,27 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} module Puppet.Interpreter ( interpretCatalog - , evaluateStatement , computeCatalog + , evaluateStatement + -- * Utils + , initialState + , extractFromState + , containerModName + , module Puppet.Interpreter.Types + , module Puppet.Interpreter.Resolve + , module Puppet.Interpreter.IO ) where -import Puppet.Prelude +import XPrelude.Extra +import XPrelude.PP import Control.Monad.Operational hiding (view) import qualified Data.Char as Char -import qualified Data.Graph as G -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS +import qualified Data.Graph as Graph +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set import qualified Data.List as List import qualified Data.Maybe.Strict as S import Data.Semigroup (Max (..)) @@ -22,24 +30,21 @@ import qualified Data.Vector as V import qualified System.Log.Logger as Log +import Facter +import Hiera.Server +import Puppet.Interpreter.Helpers import Puppet.Interpreter.IO -import Puppet.Interpreter.PrettyPrinter (containerComma) +import Puppet.Interpreter.PrettyPrinter () import Puppet.Interpreter.Resolve import Puppet.Interpreter.Types -import Puppet.Interpreter.Utils -import Puppet.Lens -import Puppet.NativeTypes -import Puppet.Parser.PrettyPrinter -import Puppet.Parser.Types -import Puppet.Parser.Utils -import Puppet.PP +import Puppet.Parser {-| Call the operational 'interpretMonad' function to compute the catalog. Returns either an error, or a tuple containing all the resources, dependency map, exported resources, and defined resources alongside with all messages that have been generated by the compilation process. - The later 'definedResources' (eg. all class declarations) are pulled out of the + The later defined resources (eg. all class declarations) are pulled out of the 'InterpreterState' and might not be up to date. There are only useful for coverage testing (checking dependencies for instance). -} @@ -56,7 +61,7 @@ isParent :: Text -> CurContainerDesc -> InterpreterMonad Bool isParent cur (ContClass possibleparent) = preuse (scopes . ix cur . scopeParent) >>= \case - Nothing -> throwPosError ("Internal error: could not find scope" <+> ttext cur <+> "possible parent" <+> ttext possibleparent) + Nothing -> throwPosError ("Internal error: could not find scope" <+> ppline cur <+> "possible parent" <+> ppline possibleparent) Just S.Nothing -> return False Just (S.Just p) -> if p == possibleparent then return True @@ -76,7 +81,7 @@ -- we used this override, so we discard it scopes . ix scp . scopeOverrides . at (r ^. rid) .= Nothing let forb msg = throwPosError ("Override of parameters (" - <> list (map (ttext . fst) $ itoList prms) + <> list (map (ppline . fst) $ itoList prms) <> ") of the following resource is forbidden in the current context:" pretty r <+> showPPos p @@ -98,7 +103,7 @@ -- valid reason is that they override something in exported resources. -- -- it probably do something unexpected on defines, but let's keep it that way for now. - let keepforlater (ResRefOverride resid resprms ropos) = resMod %= (appended : ) + let keepforlater (ResRefOverride resid resprms ropos) = resModifiers %= (appended : ) where appended = ResourceModifier (resid ^. itype) ModifierMustMatch DontRealize (REqualitySearch "title" (PString (resid ^. iname))) overrider ropos overrider r = do @@ -209,9 +214,9 @@ -- Classify sorts resources between exported and normal ones. It -- drops virtual resources, and puts in both categories resources -- that are at the same time exported and realized. - classify :: Pair (HM.HashMap RIdentifier Resource) (HM.HashMap RIdentifier Resource) + classify :: Pair (HashMap RIdentifier Resource) (HashMap RIdentifier Resource) -> Resource - -> Pair (HM.HashMap RIdentifier Resource) (HM.HashMap RIdentifier Resource) + -> Pair (HashMap RIdentifier Resource) (HashMap RIdentifier Resource) classify (curr :!: cure) r = let i curm = curm & at (r ^. rid) ?~ r in case r ^. rvirtuality of @@ -219,15 +224,15 @@ Exported -> curr :!: i cure ExportedRealized -> i curr :!: i cure _ -> curr :!: cure - verified <- HM.fromList . map (\r -> (r ^. rid, r)) <$> mapM validateNativeType (HM.elems real) + verified <- Map.fromList . map (\r -> (r ^. rid, r)) <$> mapM validateNativeType (Map.elems real) withResourceDependentRelations <- traverse getResourceDependentRelations verified edgemap <- makeEdgeMap withResourceDependentRelations definedRes <- use definedResources - return (withResourceDependentRelations, edgemap, exported, HM.elems definedRes) + return (withResourceDependentRelations, edgemap, exported, Map.elems definedRes) -- | This extracts additional relationships between resources, that are -- dependent on whether some resources are defined. A canonical example is --- is the 'owner' field in a File, that can create problems if it's +-- is the owner field in a File, that can create problems if it's -- defined! -- -- For this reason, this function only adds dependencies when the resources @@ -242,9 +247,9 @@ _ -> [] where extract actions = do - newrelations <- fmap (foldl' (HM.unionWith (<>)) (res ^. rrelations)) (sequence actions) + newrelations <- fmap (foldl' (Map.unionWith (<>)) (res ^. rrelations)) (sequence actions) return (res & rrelations .~ newrelations) - depOn :: Text -> Text -> InterpreterMonad (HM.HashMap RIdentifier (HS.HashSet LinkType)) + depOn :: Text -> Text -> InterpreterMonad (HashMap RIdentifier (HashSet LinkType)) depOn resType attributeName = case res ^? rattributes . ix attributeName of Just (PString usr) -> do @@ -252,17 +257,17 @@ existing <- has (ix targetResourceId) <$> use definedResources return $ if existing - then HM.singleton targetResourceId (HS.singleton RRequire) - else HM.empty - _ -> return HM.empty + then Map.singleton targetResourceId (Set.singleton RRequire) + else Map.empty + _ -> return Map.empty makeEdgeMap :: FinalCatalog -> InterpreterMonad EdgeMap makeEdgeMap ct = do -- merge the loaded classes and resources - defs' <- HM.map (view rpos) <$> use definedResources + defs' <- fmap (view rpos) <$> use definedResources clss' <- use loadedClasses let defs = defs' <> classes' <> aliases' <> names' - names' = HM.map (view rpos) ct + names' = (view rpos) <$> ct -- generate fake resources for all extra aliases aliases' = ifromList $ do r <- ct ^.. traversed :: [Resource] @@ -291,7 +296,7 @@ lt <- toList lts let (nsrc, ndst, nlt) = reorderlink (resid, rawdst, lt) return (nsrc, [LinkInformation nsrc ndst nlt respos]) - step1 :: HM.HashMap RIdentifier [LinkInformation] + step1 :: HashMap RIdentifier [LinkInformation] step1 = foldl' addRR mempty ct -- step 2 - add other relations (mainly stuff made from the "->" -- operator) @@ -317,9 +322,9 @@ ds <- mapM genlnk lifs return (ri, ri, ds) edgeList <- mapM checkResDef (itoList step2) - let (graph, gresolver) = G.graphFromEdges' edgeList + let (graph, gresolver) = Graph.graphFromEdges' edgeList -- now check for scc - let sccs = filter ((>1) . length . Tree.flatten) (G.scc graph) + let sccs = filter ((>1) . length . Tree.flatten) (Graph.scc graph) unless (null sccs) $ do let trees = vcat (map showtree sccs) showtree = indent 2 . vcat . map (mkp . gresolver) . Tree.flatten @@ -331,12 +336,12 @@ lnks = pretty links throwPosError $ "Dependency error, the following resources are strongly connected!" trees -- let edgePairs = concatMap (\(_,k,ls) -> [(k,l) | l <- ls]) edgeList - -- throwPosError (vcat (map (\(RIdentifier st sn, RIdentifier dt dn) -> "\"" <> ttext st <> ttext sn <> "\" -> \"" <> ttext dt <> ttext dn <> "\"") edgePairs)) + -- throwPosError (vcat (map (\(RIdentifier st sn, RIdentifier dt dn) -> "\"" <> pretty st <> ttext sn <> "\" -> \"" <> ttext dt <> ttext dn <> "\"") edgePairs)) return step2 -- | This functions performs all the actions triggered by calls to the -- realize function or other collectors. It returns a pair of --- "finalcatalogs", where the first part is the new catalog, and the second +-- 'FinalCatalog', where the first part is the new catalog, and the second -- part the map of all modified resources. The second part is needed so -- that we know for example which resources we should test for expansion -- (custom types). @@ -368,8 +373,8 @@ when (rmod ^. rmModifierType == ModifierMustMatch && null filtrd) (throwError (PrettyError ("Could not apply this resource override :" <+> pretty rmod <> ",no matching resource was found."))) return result equalModifier (ResourceModifier a1 b1 c1 d1 _ e1) (ResourceModifier a2 b2 c2 d2 _ e2) = a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2 && e1 == e2 - result <- use resMod >>= foldM mutate (rma :!: mempty) . reverse . List.nubBy equalModifier - resMod .= [] + result <- use resModifiers >>= foldM mutate (rma :!: mempty) . reverse . List.nubBy equalModifier + resModifiers .= [] pure result -- | Fold all attribute declarations @@ -380,21 +385,21 @@ where resolve acc (AttributeDecl k _ v) = case acc ^. at k of - Just _ -> throwPosError ("Parameter" <+> dullyellow (ttext k) <+> "already defined!") + Just _ -> throwPosError ("Parameter" <+> dullyellow (ppline k) <+> "already defined!") Nothing -> do pv <- resolveExpression v return (acc & at k ?~ pv) -saveCaptureVariables :: InterpreterMonad (HM.HashMap Text (Pair (Pair PValue PPosition) CurContainerDesc)) +saveCaptureVariables :: InterpreterMonad (HashMap Text (Pair (Pair PValue PPosition) CurContainerDesc)) saveCaptureVariables = do scp <- getScopeName vars <- use (scopes . ix scp . scopeVariables) - return $ HM.filterWithKey (\k _ -> Text.all Char.isDigit k) vars + return $ Map.filterWithKey (\k _ -> Text.all Char.isDigit k) vars -restoreCaptureVariables :: HM.HashMap Text (Pair (Pair PValue PPosition) CurContainerDesc) -> InterpreterMonad () +restoreCaptureVariables :: HashMap Text (Pair (Pair PValue PPosition) CurContainerDesc) -> InterpreterMonad () restoreCaptureVariables vars = do scp <- getScopeName - scopes . ix scp . scopeVariables %= HM.union vars . HM.filterWithKey (\k _ -> not (Text.all Char.isDigit k)) + scopes . ix scp . scopeVariables %= Map.union vars . Map.filterWithKey (\k _ -> not (Text.all Char.isDigit k)) evaluateStatement :: Statement -> InterpreterMonad [Resource] evaluateStatement r@(ClassDeclaration (ClassDecl cname _ _ _ _)) = @@ -424,7 +429,7 @@ let et = case ct of Collector -> RealizeVirtual ExportedCollector -> RealizeCollected - resMod %= (ResourceModifier rtype ModifierCollector et rsearch (\r' -> foldM modifyCollectedAttribute r' mods) p : ) + resModifiers %= (ResourceModifier rtype ModifierCollector et rsearch (\r' -> foldM modifyCollectedAttribute r' mods) p : ) -- Now collected from the PuppetDB ! if et == RealizeCollected then do @@ -457,9 +462,10 @@ evaluateStatement (MainFunctionDeclaration (MainFuncDecl funcname funcargs p)) = do curPos .= p mapM resolveExpression (toList funcargs) >>= mainFunctionCall funcname -evaluateStatement (VarAssignmentDeclaration (VarAssignDecl varname varexpr p)) = do +evaluateStatement (VarAssignmentDeclaration (VarAssignDecl mt varname varexpr p)) = do curPos .= p varval <- resolveExpression varexpr + mapM_ (resolveDataType >=> (`checkMatch` varval)) mt loadVariable varname varval return [] evaluateStatement (ConditionalDeclaration (ConditionalDecl conds p)) = do @@ -478,7 +484,7 @@ scp <- getScopeName -- invariant that must be respected : the current scope must be created -- in "scopes", or nothing gets saved - preuse (scopes . ix scp) >>= maybe (throwPosError ("INTERNAL ERROR in evaluateStatement ResourceDefaultDeclaration: scope wasn't created - " <> pretty scp)) (const (return ())) + preuse (scopes . ix scp) >>= maybe (throwPosError ("INTERNAL ERROR in evaluateStatement ResourceDefaultDeclaration: scope wasn't created - " <> ppline scp)) (const (return ())) let newDefaults = ResDefaults rtype scp rdecls p addDefaults x = scopes . ix scp . scopeResDefaults . at rtype ?= x -- default merging with parent @@ -486,7 +492,7 @@ preuse (scopes . ix scp . scopeResDefaults . ix rtype) >>= \case Nothing -> addDefaults newDefaults Just d -> if d ^. resDefSrcScope == scp - then throwPosError ("Defaults for resource" <+> ttext rtype <+> "already declared at" <+> showPPos (d ^. resDefPos)) + then throwPosError ("Defaults for resource" <+> ppline rtype <+> "already declared at" <+> showPPos (d ^. resDefPos)) else addDefaults (mergedDefaults d) return [] evaluateStatement (ResourceOverrideDeclaration (ResOverrideDecl t urn eargs p)) = do @@ -499,9 +505,9 @@ -- 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 + let cm = prevass `Map.intersection` raassignements unless (isEmpty cm) - (throwPosError ("The following parameters were already overriden at" <+> showPPos prevpos <+> ":" <+> containerComma cm)) + (throwPosError ("The following parameters were already overriden at" <+> showPPos prevpos <+> ":" <+> pretty cm)) return (prevass <> raassignements) Nothing -> return raassignements scopes . ix scp . scopeOverrides . at rident ?= ResRefOverride rident withAssignements p @@ -534,7 +540,7 @@ scopeDefined <- has (ix scp) <$> use scopes variableDefined <- preuse (scopes . ix scp . scopeVariables . ix varname) case (scopeDefined, variableDefined) of - (False, _) -> throwPosError ("Internal error: trying to save a variable in unknown scope" <+> ttext scp) + (False, _) -> throwPosError ("Internal error: trying to save a variable in unknown scope" <+> ppline scp) (_, Just (_ :!: pp :!: ctx)) -> isParent scp (curcont ^. cctype) >>= \case True -> do debug("The variable" @@ -546,7 +552,7 @@ False -> throwPosError ("Variable" <+> pretty (UVariableReference varname) <+> "already defined at" <+> showPPos pp "Context:" <+> pretty ctx "Value:" <+> pretty varval - "Current scope:" <+> ttext scp + "Current scope:" <+> ppline scp ) _ -> scopes . ix scp . scopeVariables . at varname ?= (varval :!: p :!: curcont ^. cctype) @@ -560,9 +566,9 @@ loadParameters params classParams defaultPos wHiera = do p <- use curPos curPos .= defaultPos - let classParamSet = HS.fromList (classParams ^.. folded . _1 . _1) - spuriousParams = ikeys params `HS.difference` classParamSet - mclassdesc = S.maybe mempty ((\x -> mempty <+> "when including class" <+> x) . ttext) wHiera + let classParamSet = Set.fromList (classParams ^.. folded . _1 . _1) + spuriousParams = ikeys params `Set.difference` classParamSet + mclassdesc = S.maybe mempty ((\x -> mempty <+> "when including class" <+> x) . ppline) wHiera -- the following functions `throwE (Max False)` when there is no value, and `throwE (Max True)` when this value -- in PUndef. @@ -583,7 +589,7 @@ checkDefault S.Nothing = throwE (Max False) checkDefault (S.Just expr) = lift (resolveExpression expr) - unless (isEmpty spuriousParams) $ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ttext) $ toList spuriousParams) <> mclassdesc) + unless (isEmpty spuriousParams) $ throwPosError ("The following parameters are unknown:" <+> tupled (map (dullyellow . ppline) $ toList spuriousParams) <> mclassdesc) -- try to set a value to all parameters -- The order of evaluation is defined / hiera / default @@ -593,18 +599,18 @@ Right v -> do forM_ mtype $ \udt -> do dt <- resolveDataType udt - unless (datatypeMatch dt v) (throwPosError ("Expected type" <+> pretty dt <+> "for parameter" <+> pretty k <+> "but its value was:" <+> pretty v)) + unless (datatypeMatch dt v) (throwPosError ("Expected type" <+> pretty dt <+> "for parameter" <+> ppline k <+> "but its value was:" <+> pretty v)) loadVariable k v >> return [] Left (Max True) -> loadVariable k PUndef >> return [] Left (Max False) -> return [k] curPos .= p - unless (isEmpty unsetParams) $ throwPosError ("The following mandatory parameters were not set:" <+> tupled (map ttext $ toList unsetParams) <> mclassdesc) + unless (isEmpty unsetParams) $ throwPosError ("The following mandatory parameters were not set:" <+> tupled (map ppline $ toList unsetParams) <> mclassdesc) -- | Enters a new scope, checks it is not already defined, and inherits the -- defaults from the current scope -- -- Inheriting the defaults is necessary for non native types, because they --- will be expanded in "finalize", so if this was not done, we would be +-- will be expanded in 'finalize', so if this was not done, we would be -- expanding the defines without the defaults applied enterScope :: ScopeEnteringContext -> CurContainerDesc @@ -617,20 +623,20 @@ -- have not properly stacked the scopes. curcaller <- case secontext of SEParent l -> return (PString $ Text.takeWhile (/=':') l) - _ -> resolveVariable "module_name" + _ -> resolveVariable "module_name" scopeAlreadyDefined <- has (ix scopename) <$> use scopes 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)) + when scopeAlreadyDefined (throwPosError ("Internal error: scope" <+> brackets (ppline scopename) <+> "already defined when loading scope for" <+> pretty cont)) scp <- getScopeName -- TODO fill tags basescope <- case secontext of SEChild prt -> do parentscope <- use (scopes . at prt) - when (isNothing parentscope) (throwPosError ("Internal error: could not find parent scope" <+> ttext prt)) + when (isNothing parentscope) (throwPosError ("Internal error: could not find parent scope" <+> ppline prt)) let Just psc = parentscope return (psc & scopeParent .~ S.Just prt) _ -> do @@ -640,7 +646,7 @@ scopes . ix scopename . scopeVariables . at "caller_module_name" ?= (curcaller :!: p :!: cont) scopes . ix "::" . scopeVariables . at "calling_module" ?= (curcaller :!: p :!: cont) scopes . ix scopename . scopeVariables . at "module_name" ?= (PString modulename :!: p :!: cont) - debug ("enterScope, scopename=" <> ttext scopename <+> "caller_module_name=" <> pretty curcaller <+> "module_name=" <> ttext modulename) + debug ("enterScope, scopename=" <> ppline scopename <+> "caller_module_name=" <> pretty curcaller <+> "module_name=" <> ppline modulename) return scopename loadClass :: Text @@ -659,7 +665,7 @@ Just pp -> case incltype of ClassIncludeLike -> return [] _ -> throwPosError - $ "Can't include class" <+> ttext name' <+> "twice when using the resource-like syntax (first occurence at" + $ "Can't include class" <+> ppline name' <+> "twice when using the resource-like syntax (first occurence at" <+> showPPos pp <> ")" Nothing -> do loadedClasses . at name' ?= (incltype :!: p) @@ -680,13 +686,13 @@ secontext = case (inh, loadedfrom) of (S.Just x,_) -> SEChild (dropInitialColons x) (_,S.Just x) -> SEParent (dropInitialColons x) - _ -> SENormal + _ -> SENormal void $ enterScope secontext scopedesc modulename p classresource <- if incltype == ClassIncludeLike then do scp <- use curScope fqdn <- getNodeName - return [Resource (RIdentifier "class" name') (HS.singleton name') mempty mempty scp Normal mempty p fqdn] + return [Resource (RIdentifier "class" name') (Set.singleton name') mempty mempty scp Normal mempty p fqdn] else return [] pushScope scopedesc loadVariable "title" (PString name') @@ -705,7 +711,7 @@ addRelationship :: LinkType -> PValue -> Resource -> InterpreterMonad Resource addRelationship lt (PResourceReference dt dn) r = return (r & rrelations %~ insertLt) where - insertLt = iinsertWith (<>) (normalizeRIdentifier dt dn) (HS.singleton lt) + insertLt = iinsertWith (<>) (normalizeRIdentifier dt dn) (Set.singleton lt) addRelationship lt (PArray vals) r = foldlM (flip (addRelationship lt)) r vals addRelationship _ PUndef r = return r addRelationship _ notrr _ = throwPosError ("Expected a resource reference, not:" <+> pretty notrr) @@ -729,9 +735,9 @@ where go = case b of - CantOverride -> setAttribute - Replace -> overrideAttribute - CantReplace -> defaultAttribute + CantOverride -> setAttribute + Replace -> overrideAttribute + CantReplace -> defaultAttribute AppendAttribute -> appendAttribute setAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource @@ -747,7 +753,7 @@ else do -- We will not bark if the same attribute is -- defined multiple times with identical values. - let errmsg = "Attribute" <+> dullmagenta (ttext attributename) <+> "defined multiple times for" <+> pretty res + let errmsg = "Attribute" <+> dullmagenta (ppline attributename) <+> "defined multiple times for" <+> pretty res if curval == value then checkStrict errmsg errmsg else throwPosError errmsg @@ -759,18 +765,18 @@ appendAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource appendAttribute attributename res value = do nvalue <- case (res ^. rattributes . at attributename, value) of - (Nothing, _) -> return value + (Nothing, _) -> return value (Just (PArray a), PArray b) -> return (PArray (a <> b)) - (Just (PArray a), b) -> return (PArray (V.snoc a b)) - (Just a, PArray b) -> return (PArray (V.cons a b)) - (Just a, b) -> return (PArray (V.fromList [a,b])) + (Just (PArray a), b) -> return (PArray (V.snoc a b)) + (Just a, PArray b) -> return (PArray (V.cons a b)) + (Just a, b) -> return (PArray (V.fromList [a,b])) return (res & rattributes . at attributename ?~ nvalue) defaultAttribute :: Text -> Resource -> PValue -> InterpreterMonad Resource defaultAttribute attributename res value = return $ case res ^. rattributes . at attributename of Nothing -> res & rattributes . at attributename ?~ value - Just _ -> res + Just _ -> res modifyCollectedAttribute :: Resource -> AttributeDecl -> InterpreterMonad Resource modifyCollectedAttribute res (AttributeDecl attributename arrowop expr) = do @@ -789,7 +795,7 @@ -- default tags -- http://docs.puppetlabs.com/puppet/3/reference/lang_tags.html#automatic-tagging -- http://docs.puppetlabs.com/puppet/3/reference/lang_tags.html#containment - let !defaulttags = {-# SCC "rrGetTags" #-} HS.fromList (t : classtags) <> tgs + let !defaulttags = {-# SCC "rrGetTags" #-} Set.fromList (t : classtags) <> tgs allsegs x = x : Text.splitOn "::" x (!classtags, !defaultLink) = getClassTags cnt getClassTags (ContClass cn ) = (allsegs cn,RIdentifier "class" cn) @@ -797,10 +803,10 @@ getClassTags ContRoot = ([],RIdentifier "class" "::") getClassTags (ContImported _ ) = ([],RIdentifier "class" "::") getClassTags (ContImport _ _ ) = ([],RIdentifier "class" "::") - defaultRelation = HM.singleton defaultLink (HS.singleton RRequire) + defaultRelation = Map.singleton defaultLink (Set.singleton RRequire) allScope <- use curScope fqdn <- getNodeName - let baseresource = Resource (normalizeRIdentifier t rn) (HS.singleton rn) mempty defaultRelation allScope vrt defaulttags p fqdn + let baseresource = Resource (normalizeRIdentifier t rn) (Set.singleton rn) mempty defaultRelation allScope vrt defaulttags p fqdn r <- ifoldlM (addAttribute CantOverride) baseresource arg let resid = normalizeRIdentifier t rn case t of @@ -855,15 +861,15 @@ _ -> throwPosError "Too many @'s" p <- use curPos let genRes rname (PHash rargs) = registerResource t' rname (rargs <> defparams) virtuality p - genRes rname x = throwPosError ("create_resource(): the value corresponding to key" <+> ttext rname <+> "should be a hash, not" <+> pretty x) - concat . HM.elems <$> itraverse genRes hs + genRes rname x = throwPosError ("create_resource(): the value corresponding to key" <+> ppline rname <+> "should be a hash, not" <+> pretty x) + concat . Map.elems <$> itraverse genRes hs mainFunctionCall "create_resources" args = throwPosError ("create_resource(): expects between two and three arguments, of type [string,hash,hash], and not:" <+> pretty args) mainFunctionCall "ensure_packages" args = ensurePackages args mainFunctionCall "ensure_resource" args = ensureResource args mainFunctionCall "realize" args = do pos <- use curPos let updateMod (PResourceReference t rn) = - resMod %= (ResourceModifier t ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString rn)) return pos : ) + resModifiers %= (ResourceModifier t ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString rn)) return pos : ) updateMod x = throwPosError ("realize(): all arguments must be resource references, not" <+> pretty x) mapM_ updateMod args return [] @@ -872,14 +878,14 @@ let addTag x = scopes . ix scp . scopeExtraTags . contains x .= True mapM_ (resolvePValueString >=> addTag) args return [] -mainFunctionCall "fail" [x] = ("fail:" <+>) . dullred . ttext <$> resolvePValueString x >>= throwPosError +mainFunctionCall "fail" [x] = ("fail:" <+>) . dullred . ppline <$> resolvePValueString x >>= throwPosError mainFunctionCall "fail" _ = throwPosError "fail(): This function takes a single argument" -- hiera_include does a unique merge lookup for the requested key, then calls the include function on the resulting array. mainFunctionCall "hiera_include" [x] = do ndname <- resolvePValueString x classes <- toListOf (traverse . _PArray . traverse) <$> runHiera ndname QUnique p <- use curPos - curPos . _1 . lSourceName <>= " [hiera_include call]" + curPos . _1 . _sourceName <>= " [hiera_include call]" o <- mainFunctionCall "include" classes curPos .= p return o @@ -894,7 +900,7 @@ prntline "Variables in local scope :" scp <- getScopeName vars <- use (scopes . ix scp . scopeVariables) - forM_ (sortBy (comparing fst) (itoList vars)) $ \(idx, pv :!: _ :!: _) -> prntline $ indentln $ ttext idx <> " -> " <> pretty pv + forM_ (sortBy (comparing fst) (itoList vars)) $ \(idx, pv :!: _ :!: _) -> prntline $ indentln $ ppline idx <> " -> " <> pretty pv pure [] mainFunctionCall "assert_type" [PType dt, v] = if datatypeMatch dt v @@ -915,13 +921,14 @@ checkStrict "The use of the 'ensure_packages' function is a code smell." "The 'ensure_packages' function is not allowed in strict mode." - concat <$> for packages (resolvePValueString >=> ensureResource' "package" (HM.singleton "ensure" "present" <> defparams)) + concat <$> for packages (resolvePValueString >=> ensureResource' "package" (Map.singleton "ensure" "present" <> defparams)) ensurePackages [PArray _,_] = throwPosError "ensure_packages(): the second argument must be a hash." ensurePackages [_,_] = throwPosError "ensure_packages(): the first argument must be a string or an array of strings." ensurePackages _ = throwPosError "ensure_packages(): requires one or two arguments." --- | Takes a resource type, title, and a hash of attributes that describe the resource --- Create the resource if it does not exist alreadyTakes a resource type, title, and a hash of attributes that describe the resource(s). +-- | Takes a resource type, title, and a hash of attributes that describe the resource. +-- Create the resource if it does not exist already. +-- Takes a resource type, title, and a hash of attributes that describe the resource(s). ensureResource :: [PValue] -> InterpreterMonad [Resource] ensureResource [PString t, PString title, PHash params] = do checkStrict @@ -935,7 +942,7 @@ ensureResource [PString _, PString _, _] = throwPosError "ensureResource(): The thrid argument must be a hash." ensureResource _ = throwPosError "ensureResource(): expects 2 or 3 arguments." -ensureResource' :: Text -> HM.HashMap Text PValue -> Text -> InterpreterMonad [Resource] +ensureResource' :: Text -> HashMap Text PValue -> Text -> InterpreterMonad [Resource] ensureResource' t params title = do isdefined <- has (ix (normalizeRIdentifier t title)) <$> use definedResources if isdefined @@ -955,6 +962,16 @@ logWithModifier prio m [v] = do p <- use curPos v' <- resolvePValueString v - logWriter prio (m (ttext v') <+> showPPos p) + logWriter prio (m (ppline v') <+> showPPos p) return [] logWithModifier _ _ _ = throwPosError "This function takes a single argument" + +-- | Contrary to the previous iteration, this will let non native types pass. +validateNativeType :: Resource -> InterpreterMonad Resource +validateNativeType r = do + tps <- singleton GetNativeTypes + case tps ^. at (r ^. rid . itype) of + Just x -> case (x ^. puppetValidate) r of + Right nr -> return nr + Left err -> throwPosError ("Invalid resource" <+> pretty r getError err) + Nothing -> return r diff --git a/src/Puppet/Interpreter/Helpers.hs b/src/Puppet/Interpreter/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Interpreter/Helpers.hs @@ -0,0 +1,166 @@ +{-# OPTIONS_HADDOCK hide, prune, ignore-exports #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} + +-- | Internal helpers module. +module Puppet.Interpreter.Helpers where + +import XPrelude + +import Control.Monad.Operational +import Control.Monad.Writer.Class +import qualified Data.HashMap.Strict as Map +import qualified Data.Vector as Vector +import qualified Data.List as List +import qualified Data.Maybe.Strict as S +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified System.Log.Logger as Log + +import Facter +import Puppet.Interpreter.Types +import Puppet.Parser + + +initialState :: Facts + -> Container Text -- ^ Server settings + -> InterpreterState +initialState facts settings = + InterpreterState baseVars initialclass mempty [ContRoot] dummyppos mempty [] [] + where + callervars = Map.fromList [("caller_module_name", PString "::" :!: dummyppos :!: ContRoot), ("module_name", PString "::" :!: dummyppos :!: ContRoot)] + factvars = + -- add the `facts` key: https://docs.puppet.com/puppet/4.10/lang_facts_and_builtin_vars.html#accessing-facts-from-puppet-code + let facts' = Map.insert "facts" (PHash facts) facts + in fmap (\x -> x :!: initialPPos "facts" :!: ContRoot) facts' + settingvars = fmap (\x -> PString x :!: initialPPos "settings" :!: ContClass "settings") settings + baseVars = Map.fromList [ ("::", ScopeInformation (factvars `mappend` callervars) mempty mempty (CurContainer ContRoot mempty) mempty S.Nothing) + , ("settings", ScopeInformation settingvars mempty mempty (CurContainer (ContClass "settings") mempty) mempty S.Nothing) + ] + initialclass = mempty & at "::" ?~ (ClassIncludeLike :!: dummyppos) + +getModulename :: RIdentifier -> Text +getModulename (RIdentifier t n) = + let gm x = + case Text.splitOn "::" x of + [] -> x + (y:_) -> y + in case t of + "class" -> gm n + _ -> gm t + +extractPrism :: Doc -> Prism' a b -> a -> InterpreterMonad b +extractPrism msg p a = + case preview p a of + Just b -> return b + Nothing -> throwPosError ("Could not extract prism in" <+> msg) + +-- Scope +popScope :: InterpreterMonad () +popScope = curScope %= List.tail + +pushScope :: CurContainerDesc -> InterpreterMonad () +pushScope s = curScope %= (s :) + +getScopeName :: InterpreterMonad Text +getScopeName = scopeName <$> getScope + +scopeName :: CurContainerDesc -> Text +scopeName (ContRoot ) = "::" +scopeName (ContImported x ) = "::imported::" `Text.append` scopeName x +scopeName (ContClass x ) = x +scopeName (ContDefine dt dn _) = "#define/" `Text.append` dt `Text.append` "/" `Text.append` dn +scopeName (ContImport _ x ) = "::import::" `Text.append` scopeName x + +containerModName :: CurContainerDesc -> Text +containerModName (ContRoot ) = "::" +containerModName (ContImported x ) = containerModName x +containerModName (ContClass x ) = x +containerModName (ContDefine dt _ _) = dt +containerModName (ContImport _ x ) = containerModName x + +getScope :: InterpreterMonad CurContainerDesc +{-# INLINABLE getScope #-} +getScope = + use curScope >>= \s -> + if null s + then throwPosError "Internal error: empty scope!" + else pure (List.head s) + +getCurContainer :: InterpreterMonad CurContainer +{-# INLINABLE getCurContainer #-} +getCurContainer = do + scp <- getScopeName + preuse (scopes . ix scp . scopeContainer) >>= \case + Just x -> return x + Nothing -> throwPosError ("Internal error: can't find the current container for" <+> green (ppline scp)) + +rcurcontainer :: Resource -> CurContainerDesc +rcurcontainer r = fromMaybe ContRoot (r ^? rscope . _head) + +-- Singleton getters available in the InterpreterMonad -- +getPuppetPaths :: InterpreterMonad PuppetDirPaths +getPuppetPaths = singleton PuppetPaths + +getNodeName:: InterpreterMonad NodeName +getNodeName = singleton GetNodeName + +isIgnoredModule :: Text -> InterpreterMonad Bool +isIgnoredModule m = singleton (IsIgnoredModule m) + +-- | Throws an error if we are in strict mode +-- A warning in permissive mode +checkStrict :: Doc -- ^ The warning message. + -> Doc -- ^ The error message. + -> InterpreterMonad () +checkStrict wrn err = do + extMod <- isExternalModule + let priority = + if extMod + then Log.NOTICE + else Log.WARNING + str <- singleton IsStrict + if str && not extMod + then throwPosError err + else do + srcname <- use (curPos . _1 . _sourceName) + logWriter priority (wrn <+> "at" <+> ppstring srcname) + +isExternalModule :: InterpreterMonad Bool +isExternalModule = + getScope >>= \case + ContClass n -> isExternal n + ContDefine n _ _ -> isExternal n + _ -> return False + where + isExternal = singleton . IsExternalModule . List.head . Text.splitOn "::" + +-- Logging -- +warn :: MonadWriter InterpreterWriter m => Doc -> m () +warn d = tell [Log.WARNING :!: d] + +debug :: MonadWriter InterpreterWriter m => Doc -> m () +debug d = tell [Log.DEBUG :!: d] + +logWriter :: MonadWriter InterpreterWriter m => Log.Priority -> Doc -> m () +logWriter prio d = tell [prio :!: d] + +safeDecodeUtf8 :: ByteString -> InterpreterMonad Text +{-# INLINABLE safeDecodeUtf8 #-} +safeDecodeUtf8 i = return (Text.decodeUtf8 i) + +normalizeRIdentifier :: Text -> Text -> RIdentifier +normalizeRIdentifier = RIdentifier . dropInitialColons + + +extractFromState :: InterpreterState -> Maybe (Text, Container ScopeInformation) +extractFromState s = + let cscope = s ^. curScope + in if null cscope + then Nothing + else let scope_name = scopeName (List.head cscope) + classes = (PArray . Vector.fromList . map PString . Map.keys) (s ^. loadedClasses) + scps = s ^. scopes + container_desc = fromMaybe ContRoot (scps ^? ix scope_name . scopeContainer . cctype) -- get the current containder description + cscps = scps & ix scope_name . scopeVariables . at "classes" ?~ ( classes :!: dummyppos :!: container_desc ) + in Just (scope_name, cscps) diff --git a/src/Puppet/Interpreter/IO.hs b/src/Puppet/Interpreter/IO.hs --- a/src/Puppet/Interpreter/IO.hs +++ b/src/Puppet/Interpreter/IO.hs @@ -1,35 +1,23 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -- | This is an internal module. module Puppet.Interpreter.IO ( - defaultImpureMethods - , interpretMonad + interpretMonad ) where -import Puppet.Prelude +import XPrelude import Control.Monad.Operational import Control.Monad.State.Strict import qualified Data.Either.Strict as S import qualified Data.Text as Text -import qualified Data.Text.IO as Text -import Debug.Trace (traceEventIO) +import Hiera.Server import Puppet.Interpreter.PrettyPrinter () import Puppet.Interpreter.Types -import Puppet.PP - -defaultImpureMethods :: MonadIO m => IoMethods m -defaultImpureMethods = IoMethods (liftIO currentCallStack) - (liftIO . file) - (liftIO . traceEventIO) - where - file [] = return $ Left "" - file (x:xs) = (Right <$> Text.readFile (Text.unpack x)) `catch` (\SomeException{} -> file xs) +import PuppetDB -- | The operational interpreter function @@ -53,7 +41,7 @@ thpe = interpretMonad r s . throwPosError . getError pdb = r^.readerPdbApi strFail iof errf = iof >>= \case - Left rr -> thpe (errf (string rr)) + Left rr -> thpe (errf (ppstring rr)) Right x -> runInstr x canFail iof = iof >>= \case S.Left err -> thpe err @@ -66,7 +54,7 @@ IsStrict -> runInstr (r ^. readerIsStrict) ExternalFunction fname args -> case r ^. readerExternalFunc . at fname of Just fn -> interpretMonad r s ( fn args >>= k) - Nothing -> thpe (PrettyError ("Unknown function: " <> ttext fname)) + Nothing -> thpe (PrettyError ("Unknown function: " <> ppline fname)) GetStatement topleveltype toplevelname -> canFail ((r ^. readerGetStatement) topleveltype toplevelname) ComputeTemplate fn stt -> canFail ((r ^. readerGetTemplate) fn stt r) @@ -89,7 +77,7 @@ 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))) + ReadFile fls -> strFail ((r ^. readerIoMethods . ioReadFile) fls) (const $ PrettyError ("No file found in " <> list (map ppline fls))) TraceEvent e -> (r ^. readerIoMethods . ioTraceEvent) e >>= runInstr IsIgnoredModule m -> runInstr (r ^. readerIgnoredModules . contains m) IsExternalModule m -> runInstr (r ^. readerExternalModules . contains m) @@ -101,7 +89,7 @@ Right x -> logStuff w (interpretMonad r s' (k x)) --- | Query hiera layers +-- query hiera layers queryHiera :: Monad m => HieraQueryLayers m -> Container Text -> Text -> HieraQueryType -> m (S.Either PrettyError (Maybe PValue)) queryHiera layers scps q t = do val <- (layers^.globalLayer) scps q t @@ -110,9 +98,9 @@ let modname = case Text.splitOn "::" (Text.dropWhile (==':') q) of - [] -> Nothing - [_] -> Nothing - (m:_) -> Just m + [] -> Nothing + [_] -> Nothing + (m:_) -> Just m layer = modname >>= (\n -> layers ^.moduleLayer.at n) maybe (pure val) (\hq -> hq scps q t) layer _ -> pure val diff --git a/src/Puppet/Interpreter/PrettyPrinter.hs b/src/Puppet/Interpreter/PrettyPrinter.hs --- a/src/Puppet/Interpreter/PrettyPrinter.hs +++ b/src/Puppet/Interpreter/PrettyPrinter.hs @@ -1,188 +1,74 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE GADTs #-} -module Puppet.Interpreter.PrettyPrinter(containerComma) where +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +module Puppet.Interpreter.PrettyPrinter () where -import Puppet.Prelude hiding (empty, (<$>)) +import XPrelude -import Data.Aeson (ToJSON, encode) -import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import qualified Data.Text as Text -import qualified Data.Vector as V -import qualified GHC.Exts as Exts -import Text.PrettyPrint.ANSI.Leijen ((<$>)) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy.Char8 as BSL import Puppet.Interpreter.Types -import Puppet.Parser.PrettyPrinter -import Puppet.Parser.Types -import Puppet.PP - -containerComma'' :: Pretty a => [(Doc, a)] -> Doc -containerComma'' x = indent 2 ins - where - ins = mconcat $ intersperse (comma <$> empty) (fmap showC x) - showC (a,b) = a <+> text "=>" <+> pretty b - -containerComma' :: Pretty a => [(Doc, a)] -> Doc -containerComma' = braces . containerComma'' - -containerComma :: Pretty a => Container a -> Doc -containerComma hm = containerComma' (fmap (\(a,b) -> (fill maxalign (pretty a), b)) hml) - where - hml = HM.toList hm - maxalign = maximum (fmap (Text.length . fst) hml) - -instance Pretty Text where - pretty = ttext - -instance Pretty PValue where - pretty (PBoolean True) = dullmagenta $ text "true" - pretty (PBoolean False) = dullmagenta $ text "false" - pretty (PString s) = dullcyan (ttext (stringEscape s)) - pretty (PNumber n) = cyan (ttext (scientific2text n)) - pretty PUndef = dullmagenta (text "undef") - pretty (PResourceReference t n) = capitalize t <> brackets (text (Text.unpack n)) - pretty (PArray v) = list (map pretty (V.toList v)) - pretty (PHash g) = containerComma g - pretty (PType dt) = pretty dt +import PuppetDB instance Pretty TopLevelType where - pretty TopNode = dullyellow (text "node") - pretty TopDefine = dullyellow (text "define") - pretty TopClass = dullyellow (text "class") - -instance Pretty RIdentifier where - pretty (RIdentifier t n) = pretty (PResourceReference t n) - -meta :: Resource -> Doc -meta r = showPPos (r ^. rpos) <+> green (node <+> brackets scp) - where - 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 <> ";" - where - virtuality = case r ^. rvirtuality of - Normal -> empty - Virtual -> dullred "@" - Exported -> dullred "@@" - ExportedRealized -> dullred "<@@>" - insde = alignlst dullblue attriblist1 ++ alignlst dullmagenta attriblist2 - alignlst col = map (first (fill maxalign . col . ttext)) - attriblist1 = Exts.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 = [] - | otherwise = [("alias", aliasPValue)] - attriblist2 = map totext (resourceRelations r) - totext (RIdentifier t n, lt) = (rel2text lt , PResourceReference t n) - maxalign = max (maxalign' attriblist1) (maxalign' attriblist2) - maxalign' [] = 0 - maxalign' x = maximum . map (Text.length . fst) $ x - -resourceRelations :: Resource -> [(RIdentifier, LinkType)] -resourceRelations = concatMap expandSet . HM.toList . view rrelations - where - expandSet (ri, lts) = [(ri, lt) | lt <- HS.toList lts] - -instance Pretty Resource where - prettyList lst = - let grouped = HM.toList $ HM.fromListWith (++) [ (r ^. rid . itype, [r]) | r <- lst ] :: [ (Text, [Resource]) ] - sorted = Exts.sortWith fst (map (second (Exts.sortWith (view (rid.iname)))) grouped) - showGroup :: (Text, [Resource]) -> Doc - showGroup (rt, res) = dullyellow (ttext rt) <+> lbrace <$> indent 2 (vcat (map resourceBody res)) <$> rbrace - in vcat (map showGroup sorted) - pretty r = dullyellow (ttext (r ^. rid . itype)) <+> lbrace <$> indent 2 (resourceBody r) <$> rbrace - -instance Pretty CurContainerDesc where - 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 (Text.unpack cname)) - pretty (ContDefine dtype dname _) = pretty (PResourceReference dtype dname) + pretty TopNode = dullyellow "node" + pretty TopDefine = dullyellow "define" + pretty TopClass = dullyellow "class" instance Pretty ResDefaults where - pretty (ResDefaults t _ v p) = capitalize t <+> showPPos p <$> containerComma v + pretty (ResDefaults t _ v p) = capitalizeR t <+> showPPos p <> line <> containerComma v instance Pretty ResourceModifier where pretty (ResourceModifier rt ModifierMustMatch RealizeVirtual (REqualitySearch "title" (PString x)) _ p) = "realize" <> parens (pretty (PResourceReference rt x)) <+> showPPos p - -- pretty (ResourceModifier rt ModifierCollector ct (REqualitySearch _ (PString x)) _ p) = "collect" <> parens (pretty (PResourceReference rt x)) <+> showPPos p pretty _ = "TODO pretty ResourceModifier" instance Pretty RSearchExpression where - pretty (REqualitySearch a v) = ttext a <+> "==" <+> pretty v - pretty (RNonEqualitySearch a v) = ttext a <+> "!=" <+> pretty v - pretty (RAndSearch a b) = parens (pretty a) <+> "&&" <+> parens (pretty b) - pretty (ROrSearch a b) = parens (pretty a) <+> "||" <+> parens (pretty b) - pretty RAlwaysTrue = mempty + pretty (REqualitySearch a v) = ppline a <+> "==" <+> pretty v + pretty (RNonEqualitySearch a v) = ppline a <+> "!=" <+> pretty v + pretty (RAndSearch a b) = parens (pretty a) <+> "&&" <+> parens (pretty b) + pretty (ROrSearch a b) = parens (pretty a) <+> "||" <+> parens (pretty b) + pretty RAlwaysTrue = mempty pf :: Doc -> [Doc] -> Doc pf fn args = bold (red fn) <> tupled (map pretty args) showQuery :: ToJSON a => Query a -> Doc -showQuery = string . BSL.unpack . encode +showQuery = ppstring . BSL.unpack . Aeson.encode instance Pretty (InterpreterInstr a) where - pretty PuppetPaths = pf "PuppetPathes" [] - pretty RebaseFile = pf "RebaseFile" [] - pretty IsStrict = pf "IsStrict" [] - pretty GetNativeTypes = pf "GetNativeTypes" [] - pretty (GetStatement tlt nm) = pf "GetStatement" [pretty tlt,ttext nm] - pretty (ComputeTemplate fn _) = pf "ComputeTemplate" [fn'] - where - fn' = case fn of - Left content -> pretty (PString content) - Right filena -> ttext filena - pretty (ExternalFunction fn args) = pf (ttext fn) (map pretty args) - pretty GetNodeName = pf "GetNodeName" [] - pretty (HieraQuery _ q _) = pf "HieraQuery" [ttext q] - pretty GetCurrentCallStack = pf "GetCurrentCallStack" [] - pretty (ErrorThrow rr) = pf "ErrorThrow" [getError rr] - pretty (ErrorCatch _ _) = pf "ErrorCatch" [] - pretty (WriterTell t) = pf "WriterTell" (map (pretty . view _2) t) - pretty (WriterPass _) = pf "WriterPass" [] - pretty (WriterListen _) = pf "WriterListen" [] - pretty PDBInformation = pf "PDBInformation" [] - pretty (PDBReplaceCatalog _) = pf "PDBReplaceCatalog" ["..."] - pretty (PDBReplaceFacts _) = pf "PDBReplaceFacts" ["..."] - pretty (PDBDeactivateNode n) = pf "PDBDeactivateNode" [ttext n] - pretty (PDBGetFacts q) = pf "PDBGetFacts" [showQuery q] - pretty (PDBGetResources q) = pf "PDBGetResources" [showQuery q] - pretty (PDBGetNodes q) = pf "PDBGetNodes" [showQuery q] - pretty PDBCommitDB = pf "PDBCommitDB" [] - pretty (PDBGetResourcesOfNode n q) = pf "PDBGetResourcesOfNode" [ttext n, showQuery q] - pretty (ReadFile f) = pf "ReadFile" (map ttext f) - pretty (TraceEvent e) = pf "TraceEvent" [string e] - pretty (IsIgnoredModule m) = pf "IsIgnoredModule" [ttext m] - pretty (IsExternalModule m) = pf "IsExternalModule" [ttext m] + pretty PuppetPaths = pf "PuppetPathes" [] + pretty RebaseFile = pf "RebaseFile" [] + pretty IsStrict = pf "IsStrict" [] + pretty GetNativeTypes = pf "GetNativeTypes" [] + pretty (GetStatement tlt nm) = pf "GetStatement" [pretty tlt,ppline nm] + pretty (ComputeTemplate fn _) = pf "ComputeTemplate" [fn'] + where + fn' = case fn of + Left content -> pretty (PString content) + Right filena -> ppline filena + pretty (ExternalFunction fn args) = pf (ppline fn) (map pretty args) + pretty GetNodeName = pf "GetNodeName" [] + pretty (HieraQuery _ q _) = pf "HieraQuery" [ppline q] + pretty GetCurrentCallStack = pf "GetCurrentCallStack" [] + pretty (ErrorThrow rr) = pf "ErrorThrow" [getError rr] + pretty (ErrorCatch _ _) = pf "ErrorCatch" [] + pretty (WriterTell t) = pf "WriterTell" (map (pretty . view _2) t) + pretty (WriterPass _) = pf "WriterPass" [] + pretty (WriterListen _) = pf "WriterListen" [] + pretty PDBInformation = pf "PDBInformation" [] + pretty (PDBReplaceCatalog _) = pf "PDBReplaceCatalog" ["..."] + pretty (PDBReplaceFacts _) = pf "PDBReplaceFacts" ["..."] + pretty (PDBDeactivateNode n) = pf "PDBDeactivateNode" [ppline n] + pretty (PDBGetFacts q) = pf "PDBGetFacts" [showQuery q] + pretty (PDBGetResources q) = pf "PDBGetResources" [showQuery q] + pretty (PDBGetNodes q) = pf "PDBGetNodes" [showQuery q] + pretty PDBCommitDB = pf "PDBCommitDB" [] + pretty (PDBGetResourcesOfNode n q) = pf "PDBGetResourcesOfNode" [ppline n, showQuery q] + pretty (ReadFile f) = pf "ReadFile" (map ppline f) + pretty (TraceEvent e) = pf "TraceEvent" [ppstring e] + pretty (IsIgnoredModule m) = pf "IsIgnoredModule" [ppline m] + pretty (IsExternalModule m) = pf "IsExternalModule" [ppline m] instance Pretty LinkInformation where pretty (LinkInformation lsrc ldst ltype lpos) = pretty lsrc <+> pretty ltype <+> pretty ldst <+> showPPos lpos - -instance Pretty DataType where - pretty t = case t of - DTType -> "Type" - DTString ma mb -> bounded "String" ma mb - DTInteger ma mb -> bounded "Integer" ma mb - DTFloat ma mb -> bounded "Float" ma mb - DTBoolean -> "Boolean" - DTArray dt mi mmx -> "Array" <> list (pretty dt : pretty mi : maybe [] (pure . pretty) mmx) - DTHash kt dt mi mmx -> "Hash" <> list (pretty kt : pretty dt : pretty mi : maybe [] (pure . pretty) mmx) - DTUndef -> "Undef" - DTScalar -> "Scalar" - DTData -> "Data" - DTOptional o -> "Optional" <> brackets (pretty o) - NotUndef -> "NotUndef" - DTVariant vs -> "Variant" <> list (foldMap (pure . pretty) vs) - DTPattern vs -> "Pattern" <> list (foldMap (pure . pretty) vs) - DTEnum tx -> "Enum" <> list (foldMap (pure . pretty) tx) - DTAny -> "Any" - DTCollection -> "Collection" - where - bounded :: (Pretty a, Pretty b) => Doc -> Maybe a -> Maybe b -> Doc - bounded s ma mb = s <> case (ma, mb) of - (Just a, Nothing) -> list [pretty a] - (Just a, Just b) -> list [pretty a, pretty b] - _ -> mempty diff --git a/src/Puppet/Interpreter/Pure.hs b/src/Puppet/Interpreter/Pure.hs deleted file mode 100644 --- a/src/Puppet/Interpreter/Pure.hs +++ /dev/null @@ -1,166 +0,0 @@ --- | This is a set of pure helpers for evaluation the 'InterpreterMonad' --- function that can be found in "Puppet.Interpreter" and --- "Puppet.Interpreter.Resolve". They are used to power some prisms from --- "Puppet.Lens". --- --- > > dummyEval (resolveExpression (Addition "1" "2")) --- > Right (PString "3") -module Puppet.Interpreter.Pure ( - dummyEval - , dummyFacts - , pureEval - , pureReader -) where - -import Puppet.Prelude - -import qualified Data.Either.Strict as S -import qualified Data.HashMap.Strict as HM -import qualified Data.Text as Text - -import Erb.Evaluate -import Erb.Parser -import Puppet.Interpreter.IO -import Puppet.Interpreter.Types -import Puppet.Interpreter.Utils -import Puppet.NativeTypes -import Puppet.Parser.Types -import Puppet.Paths -import Puppet.PP -import PuppetDB.Dummy - - --- | Worst name ever, this is a set of pure stub for the 'ImpureMethods' --- type. -impurePure :: IoMethods Identity -impurePure = IoMethods (return []) (const (return (Left "Can't read file"))) (\_ -> return ()) - --- | A pure 'InterpreterReader', that can only evaluate a subset of the --- templates, and that can include only the supplied top level statements. -pureReader :: HM.HashMap (TopLevelType, Text) Statement -- ^ A top-level statement map - -> InterpreterReader Identity -pureReader sttmap = InterpreterReader - baseNativeTypes - getstatementdummy - templatedummy - dummyPuppetDB - mempty - "dummy" - hieradummy - impurePure - mempty - mempty - True - (puppetPaths "/etc/puppet") - Nothing - where - templatedummy (Right _) _ _ = return (S.Left "Can't interpret files") - templatedummy (Left cnt) stt _ = return $ case extractFromState stt of - Nothing -> S.Left "Context retrieval error (pureReader)" - Just (ctx, scope) -> case parseErbString (Text.unpack cnt) of - Left rr -> S.Left (PrettyError (text (show rr))) - Right stmts -> case rubyEvaluate scope ctx stmts of - Right x -> S.Right x - Left rr -> S.Left (PrettyError rr) - pure_hiera :: HieraQueryFunc Identity - pure_hiera _ _ _ = pure (S.Right (Just "pure")) - hieradummy = HieraQueryLayers pure_hiera mempty - getstatementdummy tlt n = return $ case HM.lookup (tlt,n) sttmap of - Just x -> S.Right x - Nothing -> S.Left "Can't get statement" - --- | Evaluates an interpreter expression in a pure context. -pureEval :: Facts -- ^ A list of facts that will be used during evaluation - -> HM.HashMap (TopLevelType, Text) Statement -- ^ A top-level map - -> InterpreterMonad a -- ^ The action to evaluate - -> (Either PrettyError a, InterpreterState, InterpreterWriter) -pureEval facts sttmap action = runIdentity (interpretMonad (pureReader sttmap) startingState action) - where - startingState = initialState facts $ HM.fromList [ ("confdir", "/etc/puppet") - ] - --- | A bunch of facts that can be used for pure evaluation. -dummyFacts :: Facts -dummyFacts = HM.fromList - [ ("architecture", "amd64") - , ("augeasversion", "0.10.0") - , ("bios_release_date", "07/06/2010") - , ("bios_vendor", "Dell Inc.") - , ("bios_version", "2.2.0") - , ("boardmanufacturer", "Dell Inc.") - , ("domain", "dummy.domain") - , ("facterversion", "1.7.5") - , ("filesystems", "ext2,ext3,ext4,vfat") - , ("fqdn", "dummy.dummy.domain") - , ("hardwareisa", "x86_64") - , ("hardwaremodel", "x86_64") - , ("hostname", "dummy") - , ("id", "root") - , ("interfaces", "eth0,lo") - , ("ipaddress", "172.17.42.1") - , ("ipaddress_eth0", "172.17.42.1") - , ("ipaddress_lo", "127.0.0.1") - , ("is_virtual", "false") - , ("kernel", "Linux") - , ("kernelmajversion", "3.8") - , ("kernelrelease", "3.8.0-37-generic") - , ("kernelversion", "3.8.0") - , ("lsbdistcodename", "precise") - , ("lsbdistdescription", "Ubuntu 12.04.4 LTS") - , ("lsbdistid", "Ubuntu") - , ("lsbdistrelease", "12.04") - , ("lsbmajdistrelease", "12") - , ("macaddress", "a5:cb:10:b0:9a:4b") - , ("macaddress_eth0", "72:53:10:c1:eb:70") - , ("manufacturer", "Dell Inc.") - , ("memoryfree", "12.57 GB") - , ("memoryfree_mb", "12869.89") - , ("memorysize", "15.63 GB") - , ("memorysize_mb", "16009.07") - , ("memorytotal", "15.63 GB") - , ("mtu_eth0", "1500") - , ("mtu_lo", "65536") - , ("netmask", "255.255.0.0") - , ("netmask_eth0", "255.255.255.0") - , ("netmask_lo", "255.0.0.0") - , ("network_eth0", "172.17.42.0") - , ("network_lo", "127.0.0.0") - , ("operatingsystem", "Ubuntu") - , ("operatingsystemrelease", "12.04") - , ("osfamily", "Debian") - , ("path", "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin") - , ("physicalprocessorcount", "1") - , ("processor0", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz") - , ("processor1", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz") - , ("processor2", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz") - , ("processor3", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz") - , ("processor4", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz") - , ("processor5", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz") - , ("processor6", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz") - , ("processor7", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz") - , ("processorcount", "8") - , ("productname", "Vostro 430") - , ("ps", "ps -ef") - , ("puppetversion", "3.4.3") - , ("rubysitedir", "/usr/local/lib/site_ruby/1.8") - , ("rubyversion", "1.8.7") - , ("selinux", "false") - , ("serialnumber", "9L3FW4J") - , ("swapfree", "15.96 GB") - , ("swapfree_mb", "16340.00") - , ("swapsize", "15.96 GB") - , ("swapsize_mb", "16340.00") - , ("timezone", "CEST") - , ("type", "Desktop") - , ("uniqueid", "007f0101") - , ("uptime", "5:48 hours") - , ("uptime_days", "0") - , ("uptime_hours", "5") - , ("uptime_seconds", "20932") - , ("uuid", "97b75940-be55-11e3-b1b6-0800200c9a66") - , ("virtual", "physical") - ] - --- | A default evaluation function for arbitrary interpreter actions. -dummyEval :: InterpreterMonad a -> Either PrettyError a -dummyEval action = pureEval dummyFacts mempty action ^. _1 diff --git a/src/Puppet/Interpreter/Resolve.hs b/src/Puppet/Interpreter/Resolve.hs --- a/src/Puppet/Interpreter/Resolve.hs +++ b/src/Puppet/Interpreter/Resolve.hs @@ -1,10 +1,13 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} + +{-# LANGUAGE FlexibleContexts #-} + -- | 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'. +-- the fully exploitable corresponding data type. +-- +-- The main use case is the conversion of 'Expression' to 'PValue'. module Puppet.Interpreter.Resolve ( -- * Pure resolution functions getVariable, @@ -29,14 +32,13 @@ hfGenerateAssociations, hfSetvars, hfRestorevars, - toNumbers, fixResourceName, datatypeMatch, - -- * Synonym - NumberPair + checkMatch ) where -import Puppet.Prelude +import XPrelude.Extra +import XPrelude.PP import qualified Control.Monad.Operational as Operational import "cryptonite" Crypto.Hash @@ -59,17 +61,16 @@ import qualified Data.Vector as V import Data.Version (Version (..), parseVersion) import Text.ParserCombinators.ReadP (readP_to_S) -import qualified Text.PrettyPrint.ANSI.Leijen as PP import qualified Text.Regex.PCRE.ByteString.Utils as Regex +import Hiera.Server +import Puppet.Interpreter.Helpers import Puppet.Interpreter.PrettyPrinter () import Puppet.Interpreter.Resolve.Sprintf (sprintf) import Puppet.Interpreter.RubyRandom import Puppet.Interpreter.Types -import Puppet.Interpreter.Utils -import Puppet.Parser.Types -import Puppet.Paths -import Puppet.PP +import Puppet.Parser +import PuppetDB sha1 :: ByteString -> ByteString sha1 = ByteArray.convert . (hash :: ByteString -> Digest SHA1) @@ -109,10 +110,10 @@ runHiera qs qt >>= \case Just p -> case dt of Just dt' | not (datatypeMatch dt' p) -> throwPosError "Datatype mismatched" - _ -> pure p + _ -> pure p Nothing -> case df of Just d -> pure d - Nothing -> throwPosError ("Lookup for " <> ttext qs <> " failed") + Nothing -> throwPosError ("Lookup for " <> ppline qs <> " failed") -- | Tries to convert a pair of 'PValue's into a 'NumberPair', as defined in -- attoparsec. If the two values can be converted, it will convert them so @@ -142,7 +143,7 @@ rb <- resolveExpressionNumber b case (preview _Integer ra, preview _Integer rb) of (Just na, Just nb) -> pure (PNumber $ fromIntegral (opr na nb)) - _ -> throwPosError ("Expected integer values, not" <+> string (show ra) <+> "or" <+> string (show rb)) + _ -> throwPosError ("Expected integer values, not" <+> pretty ra <+> "or" <+> pretty rb) -- | Resolves a variable, or throws an error if it can't. resolveVariable :: Text -> InterpreterMonad PValue @@ -173,7 +174,7 @@ Nothing -> -- check top level scope case scps ^? ix "::" . scopeVariables . ix varname of Just pp -> extractVariable pp - Nothing -> Left ("Could not resolve variable" <+> pretty (UVariableReference fullvar) <+> "in context" <+> ttext varscope <+> "or root") + Nothing -> Left ("Could not resolve variable" <+> pretty (UVariableReference fullvar) <+> "in context" <+> ppline varscope <+> "or root") -- | A helper for numerical comparison functions. numberCompare :: Expression -> Expression -> (Scientific -> Scientific -> Bool) -> InterpreterMonad PValue @@ -221,7 +222,7 @@ resolveExpression (RegexMatch a v@(Terminal (URegexp (CompRegex _ rv)))) = do ra <- fmap Text.encodeUtf8 (resolveExpressionString a) case Regex.execute' rv ra of - Left (_,rr) -> throwPosError ("Error when evaluating" <+> pretty v <+> ":" <+> string rr) + Left (_,rr) -> throwPosError ("Error when evaluating" <+> pretty v <+> ":" <+> ppstring rr) Right Nothing -> pure $ PBoolean False Right (Just matches) -> do -- A bit of logic to save the capture variables. @@ -263,8 +264,8 @@ Just v -> pure v Nothing -> do checkStrict - ("Look up for an hash with the unknown key '" <> ttext ridx <> "' for" <+> pretty (PHash h)) - ("Can't find index '" <> ttext ridx <> "' in" <+> pretty (PHash h)) + ("Look up for an hash with the unknown key '" <> ppline ridx <> "' for" <+> pretty (PHash h)) + ("Can't find index '" <> ppline ridx <> "' in" <+> pretty (PHash h)) pure PUndef PArray ar -> do ridx <- resolveExpression idx @@ -273,7 +274,7 @@ _ -> throwPosError ("Need an integral number for indexing an array, not" <+> pretty ridx) let arl = V.length ar if arl <= i - then throwPosError ("Out of bound indexing, array size is" <+> int arl <+> "index is" <+> int i) + then throwPosError ("Out of bound indexing, array size is" <+> pretty arl <+> "index is" <+> pretty i) else pure (ar V.! i) src -> throwPosError ("This data can't be indexed:" <+> pretty src) resolveExpression stmt@(ConditionalValue e conds) = do @@ -283,7 +284,7 @@ checkCond ((SelectorValue v@(URegexp (CompRegex _ rg)) :!: ce) : xs) = do rs <- fmap Text.encodeUtf8 (resolvePValueString rese) case Regex.execute' rg rs of - Left (_,rr) -> throwPosError ("Could not match" <+> pretty v <+> ":" <+> string rr) + Left (_,rr) -> throwPosError ("Could not match" <+> pretty v <+> ":" <+> ppstring rr) Right Nothing -> checkCond xs Right (Just _) -> resolveExpression ce checkCond ((SelectorType udt :!: ce) : xs) = do @@ -364,14 +365,14 @@ "Resolving the keyword `undef` to the string \"undef\"" "Strict mode won't convert the keyword `undef` to the string \"undef\"" pure "undef" -resolvePValueString x = throwPosError ("Don't know how to convert this to a string:" PP.<$> pretty x) +resolvePValueString x = throwPosError ("Don't know how to convert this to a string:" <> line <> pretty x) -- | Turns everything it can into a number, or throws an error resolvePValueNumber :: PValue -> InterpreterMonad Scientific resolvePValueNumber x = case x ^? _Number of - Just n -> pure n - Nothing -> throwPosError ("Don't know how to convert this to a number:" PP.<$> pretty x) + Just n -> pure n + Nothing -> throwPosError ("Don't know how to convert this to a number:" <> line <> pretty x) -- | > resolveExpressionString = resolveExpression >=> resolvePValueString resolveExpressionString :: Expression -> InterpreterMonad Text @@ -388,8 +389,7 @@ PArray a -> mapM resolvePValueString (V.toList a) y -> fmap pure (resolvePValueString y) --- | Turns a 'PValue' into a 'Bool', as explained in the reference --- documentation. +-- | Turns a 'PValue' into a 'Bool' as explained in the reference documentation. pValue2Bool :: PValue -> Bool pValue2Bool PUndef = False pValue2Bool (PString "") = False @@ -405,7 +405,7 @@ (mx:targs) <- mapM resolveExpressionString (V.toList args) curmax <- case PString mx ^? _Integer of Just x -> pure x - _ -> throwPosError ("fqdn_rand(): the first argument must be an integer, not" <+> ttext mx) + _ -> throwPosError ("fqdn_rand(): the first argument must be an integer, not" <+> ppline mx) let rargs = if null targs then [fqdn, ""] else fqdn : targs @@ -467,7 +467,7 @@ let sub t = do t' <- fmap Text.encodeUtf8 (resolvePValueString t) case Regex.substituteCompile' regexp t' replacement of - Left rr -> throwPosError ("regsubst():" <+> string rr) + Left rr -> throwPosError ("regsubst():" <+> ppstring rr) Right x -> fmap PString (safeDecodeUtf8 x) case ptarget of PArray a -> fmap PArray (traverse sub a) @@ -477,7 +477,7 @@ src <- fmap Text.encodeUtf8 (resolvePValueString psrc) splt <- fmap Text.encodeUtf8 (resolvePValueString psplt) case Regex.splitCompile' splt src of - Left rr -> throwPosError ("splitCompile():" <+> string rr) + Left rr -> throwPosError ("splitCompile():" <+> ppstring rr) Right x -> fmap (PArray . V.fromList) (mapM (fmap PString . safeDecodeUtf8) x) resolveFunction' "sha1" [pstr] = fmap (PString . Text.decodeUtf8 . B16.encode . sha1 . Text.encodeUtf8) (resolvePValueString pstr) resolveFunction' "sha1" _ = throwPosError "sha1(): Expects a single argument" @@ -507,7 +507,7 @@ (md:x:rst) -> do moduledir <- view modulesPath <$> getPuppetPaths pure (Text.intercalate "/" (Text.pack moduledir : md : "files" : x : rst)) - _ -> throwPosError ("file() argument invalid: " <> ttext s) + _ -> throwPosError ("file() argument invalid: " <> ppline s) mapM (resolvePValueString >=> fixFilePath) args >>= fmap PString . Operational.singleton . ReadFile resolveFunction' "tagged" ptags = do @@ -549,7 +549,10 @@ resolveFunction' "hiera_hash" [q,d,o] = hieraCall QHash q (Just d) Nothing (Just o) resolveFunction' "lookup" [q] = hieraCall QFirst q Nothing Nothing Nothing resolveFunction' "lookup" [q, PType dt] = hieraCall QFirst q Nothing (Just dt) Nothing -resolveFunction' "lookup" [q, PType dt, PString t,d] = hieraCall (fromMaybe QFirst (readQueryType t)) q (Just d) (Just dt) Nothing +resolveFunction' "lookup" [q, PType dt, PString t,d] = + case readQueryType t of + Nothing -> throwPosError ("Unknown merge strategy " <> ppline t) + Just qt -> hieraCall qt q (Just d) (Just dt) Nothing resolveFunction' "lookup" _ = throwPosError "lookup(): Wrong set of arguments" -- user functions @@ -559,15 +562,15 @@ pdbresourcequery q mkey = do rrv <- case fromJSON (toJSON q) of Aeson.Success rq -> Operational.singleton (PDBGetResources rq) - Aeson.Error rr -> throwPosError ("Invalid resource query:" <+> Puppet.PP.string rr) + Aeson.Error rr -> throwPosError ("Invalid resource query:" <+> ppstring rr) rv <- case fromJSON (toJSON rrv) of Aeson.Success x -> pure x - Aeson.Error rr -> throwPosError ("For some reason we could not convert a resource list to Puppet internal values!!" <+> Puppet.PP.string rr <+> pretty rrv) + Aeson.Error rr -> throwPosError ("For some reason we could not convert a resource list to Puppet internal values!!" <+> ppstring rr <+> pretty rrv) let extractSubHash :: Text -> PValue -> InterpreterMonad PValue extractSubHash ky (PHash h) = case h ^. at ky of Just val -> pure val - Nothing -> throwPosError ("pdbresourcequery strange error, could not find key" <+> ttext ky <+> "in" <+> pretty (PHash h)) + Nothing -> throwPosError ("pdbresourcequery strange error, could not find key" <+> ppline ky <+> "in" <+> pretty (PHash h)) extractSubHash _ x = throwPosError ("pdbresourcequery strange error, expected a hash, had" <+> pretty x) case mkey of Nothing -> pure (PArray rv) @@ -601,17 +604,17 @@ 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)] - mkSE (RNonEqualitySearch a b) = fmap QNot (mkSE (REqualitySearch a b)) + mkSE (RAndSearch a b) = [QAnd (mkSE a ++ mkSE b)] + mkSE (ROrSearch a b) = [QOr (mkSE a ++ mkSE b)] + mkSE (RNonEqualitySearch a b) = fmap QNot (mkSE (REqualitySearch a b)) mkSE (REqualitySearch a (PString b)) = [QEqual (mkFld a) b] - mkSE _ = [] + mkSE _ = [] mkFld "tag" = RTag 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 +-- | 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 @@ -662,12 +665,12 @@ UDTAny -> pure DTAny UDTCollection -> pure DTCollection --- | Generates variable associations for evaluation of blocks. Each item --- corresponds to an iteration in the calling block. +-- | Generates variable associations for evaluation of blocks. +-- Each item corresponds to an iteration in the calling block. hfGenerateAssociations :: HOLambdaCall -> InterpreterMonad [[(Text, PValue)]] hfGenerateAssociations hol = do sourceexpression <- case hol ^. hoLambdaExpr of - S.Just x -> pure x + S.Just x -> pure x S.Nothing -> throwPosError ("No expression to run the function on" <+> pretty hol) sourcevalue <- resolveExpression sourceexpression let check Nothing _ = pure () @@ -759,7 +762,7 @@ case sourcevalue of PArray ar -> pure $ PArray $ V.map fst $ V.filter snd $ V.zip ar (V.fromList res) PHash hh -> pure $ PHash $ HM.fromList $ map fst $ filter snd $ zip (HM.toList hh) res - x -> throwPosError ("Can't iterate on this data type:" <+> pretty x) + x -> throwPosError ("Can't iterate on this data type:" <+> pretty x) x -> throwPosError ("This type of function is not supported yet by language-puppet!" <+> pretty x) -- | Checks that a value matches a puppet datatype @@ -798,3 +801,6 @@ fromMaybe False $ do vr <- f <$> v ^? prm pure $ and (catMaybes [fmap (vr >=) mmin, fmap (vr <=) mmax]) + +checkMatch :: DataType -> PValue -> InterpreterMonad () +checkMatch dt pv = unless (datatypeMatch dt pv) (throwPosError (pretty pv <+> "does not match type" <+> pretty dt)) diff --git a/src/Puppet/Interpreter/Resolve/Sprintf.hs b/src/Puppet/Interpreter/Resolve/Sprintf.hs --- a/src/Puppet/Interpreter/Resolve/Sprintf.hs +++ b/src/Puppet/Interpreter/Resolve/Sprintf.hs @@ -2,8 +2,9 @@ sprintf ) where -import Puppet.Prelude +import XPrelude + import Data.Attoparsec.Text import qualified Data.Text as Text import qualified Data.Text.Lazy as TL @@ -11,11 +12,9 @@ import qualified Data.Text.Lazy.Builder.Int as TB import qualified Data.Text.Lazy.Builder.Scientific as TB - +import Puppet.Interpreter.Helpers +import Puppet.Interpreter.PrettyPrinter () import Puppet.Interpreter.Types -import Puppet.Interpreter.Utils -import Puppet.PP (pretty) -import Puppet.Interpreter.PrettyPrinter() data Flag = Minus | Plus | Space | Zero | Hash deriving (Show, Eq) @@ -26,16 +25,18 @@ data FType = TPct | Td | Tu | Tf | TF | Te | TE | Tg | TG | Tx | TX | To | Ts | Tc | Tp | Ta | TA deriving (Show, Eq) -data PrintfFormat = PrintfFormat { _pfFlags :: [Flag] - , _pfWidth :: Maybe Int - , _pfPrec :: Maybe Int - , _pfLen :: Maybe FLen - , _pfType :: FType - } deriving (Show, Eq) +data PrintfFormat = PrintfFormat + { _pfFlags :: [Flag] + , _pfWidth :: Maybe Int + , _pfPrec :: Maybe Int + , _pfLen :: Maybe FLen + , _pfType :: FType + } deriving (Show, Eq) -data FormatStringPart = Raw Text - | Format PrintfFormat - deriving (Show, Eq) +data FormatStringPart + = Raw Text + | Format PrintfFormat + deriving (Show, Eq) parseFormat :: Text -> [FormatStringPart] parseFormat t | Text.null t = [] @@ -45,10 +46,10 @@ (raw, nxt) = Text.break (== '%') t tryNext = case parseFormat (Text.tail nxt) of (Raw nt : nxt') -> Raw (Text.cons '%' nt) : nxt' - nxt' -> Raw (Text.singleton '%') : nxt' + nxt' -> Raw (Text.singleton '%') : nxt' rformat = case parse format nxt of - Fail _ _ _ -> tryNext - Partial _ -> tryNext + Fail _ _ _ -> tryNext + Partial _ -> tryNext Done remaining f -> Format f : parseFormat remaining flag :: Parser Flag diff --git a/src/Puppet/Interpreter/RubyRandom.hs b/src/Puppet/Interpreter/RubyRandom.hs --- a/src/Puppet/Interpreter/RubyRandom.hs +++ b/src/Puppet/Interpreter/RubyRandom.hs @@ -1,26 +1,32 @@ -module Puppet.Interpreter.RubyRandom (rbGenrandInt32, randInit, limitedRand) where +module Puppet.Interpreter.RubyRandom + ( rbGenrandInt32 + , randInit + , limitedRand + ) where -import Puppet.Prelude +import XPrelude -import qualified Data.Vector.Unboxed as V +import qualified Data.List as List +import qualified Data.Vector.Unboxed as V import qualified Data.Vector.Unboxed.Mutable as VM -import qualified Data.List as List -data RandState = RandState { _array :: V.Vector Int - , _left :: Int - , _initf :: Int - , _next :: Int - } deriving (Show) +data RandState = RandState + { _array :: V.Vector Int + , _left :: Int + , _initf :: Int + , _next :: Int + } deriving (Show) mixbits :: Int -> Int -> Int mixbits u v = (u .&. 0x80000000) .|. (v .&. 0x7fffffff) twist :: Int -> Int -> Int twist u v = (mixbits u v `shiftR` 1) `xor` ma - where - ma = if (v .&. 1) == 1 - then 0x9908b0df - else 0 + where + ma = + if (v .&. 1) == 1 + then 0x9908b0df + else 0 valN :: Int valN = 624 @@ -28,11 +34,11 @@ valM = 397 initGenrand :: Integer -> RandState -initGenrand rseed = RandState (V.fromList (scanl genfunc seed [1..(valN - 1)])) 1 1 0 - where - seed = fromIntegral rseed .&. 0xffffffff - genfunc :: Int -> Int -> Int - genfunc curval x = (1812433253 * (curval `xor` (curval `shiftR` 30)) + x) .&. 0xffffffff +initGenrand rseed = RandState (V.fromList (scanl genfunc seed [1 .. (valN - 1)])) 1 1 0 + where + seed = fromIntegral rseed .&. 0xffffffff + genfunc :: Int -> Int -> Int + genfunc curval x = (1812433253 * (curval `xor` (curval `shiftR` 30)) + x) .&. 0xffffffff nextState :: RandState -> RandState nextState (RandState array _ initf _) = RandState narray valN 1 0 diff --git a/src/Puppet/Interpreter/Types.hs b/src/Puppet/Interpreter/Types.hs --- a/src/Puppet/Interpreter/Types.hs +++ b/src/Puppet/Interpreter/Types.hs @@ -4,347 +4,259 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Puppet.Interpreter.Types ( - -- * Record & lenses - HasResource(..) - , Resource(Resource) - , HasResDefaults(..) - , ResDefaults(ResDefaults) - , HasLinkInformation(..) - , LinkInformation(LinkInformation) - , HasRIdentifier(..) - , HieraQueryLayers(HieraQueryLayers) - , HasHieraQueryLayers(..) - , RIdentifier(RIdentifier) - , HasScopeInformation(..) - , ScopeInformation(ScopeInformation) - , ScopeEnteringContext(..) - , HasResourceModifier(..) - , ResourceModifier(ResourceModifier) - , HasIoMethods(..) - , IoMethods(IoMethods) - , HasCurContainer(..) - , CurContainer(CurContainer) - , HasNativeTypeMethods(..) - , NativeTypeMethods(NativeTypeMethods) - , NodeInfo(NodeInfo) - , HasNodeInfo(..) - , FactInfo(FactInfo) - , HasFactInfo(..) - , HasWireCatalog(..) - -- ** Operational instructions - , InterpreterInstr(..) - , HasInterpreterReader(..) + -- * Operational state + InterpreterState(InterpreterState) + , scopes + , definedResources + , nestedDeclarations + , resModifiers + , extraRelations + , curScope + , curPos + , loadedClasses + -- * Operational reader , InterpreterReader(InterpreterReader) - , HasInterpreterState(..) - , InterpreterState(InterpreterState) - -- * Sum types - -- ** PValue - , PValue(..) - , _PType - , _PBoolean - , _PString - , _PResourceReference - , _PArray - , _PHash - , _PNumber - , _PUndef - -- ** Misc - , DataType(..) - , CurContainerDesc(..) - , ResourceCollectorType(..) - , RSearchExpression(..) - , Query(..) - , ModifierType(..) - , NodeField - , Strictness(..) - , HieraQueryType(..) - , WireCatalog(..) - , TopLevelType(..) - , FactField(..) - , ResRefOverride(..) - , ResourceField(..) - , OverrideType(..) - , ClassIncludeType(..) - -- ** PuppetDB - , PuppetEdge(PuppetEdge) - , PuppetDBAPI(..) - -- * newtype & synonym - , PrettyError(..) + , readerNativeTypes + , readerGetStatement + , readerGetTemplate + , readerPdbApi + , readerExternalFunc + , readerNodename + , readerHieraQuery + , readerIoMethods + , readerIgnoredModules + , readerExternalModules + , readerIsStrict + , readerPuppetPaths + , readerRebaseFile + -- * Interpreter monad , InterpreterMonad , InterpreterWriter - , FinalCatalog - , NativeTypeValidate - , NodeName - , Container - , HieraQueryFunc - , Scope - , Facts - , EdgeMap - -- * Classes + , InterpreterInstr(..) + , Strictness(..) + -- * Io methods + , IoMethods(IoMethods) + , ioGetCurrentCallStack + , ioReadFile + , ioTraceEvent , MonadThrowPos(..) - -- * Definitions - , metaparameters - , showPos + -- * Resource modifier + , ResourceModifier(ResourceModifier) + , rmResType + , rmDeclaration + , rmSearch + , rmType + , rmMutation + , rmModifierType + , ModifierType(..) + , OverrideType(..) + , ResourceCollectorType(..) + , ClassIncludeType(..) + , RSearchExpression(..) + -- * Scope information + , ScopeInformation(ScopeInformation) + , scopeResDefaults + , scopeVariables + , scopeParent + , scopeOverrides + , scopeContainer + , scopeExtraTags + , CurContainer(CurContainer) + , cctype + , cctags + -- * Resource default + , ResDefaults(ResDefaults) + , resDefValues + , resDefSrcScope + , resDefPos + , resDefType + , ResRefOverride(..) + , ScopeEnteringContext(..) + , TopLevelType(..) + -- * Hiera + , HieraQueryLayers(..) + , globalLayer + , moduleLayer + -- * Re-export + , module Puppet.Language ) where -import Puppet.Prelude hiding (show) +import XPrelude.Extra +import XPrelude.PP -import Control.Lens hiding (Strict) import Control.Monad.Operational import Control.Monad.State.Strict import Control.Monad.Writer.Class -import Data.Aeson as A -import Data.Aeson.TH -import Data.Aeson.Lens -import qualified Data.Either.Strict as S -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import qualified Data.Maybe.Strict as S -import Data.String (IsString (..)) -import qualified Data.Text as Text -import qualified Data.List as List -import Data.Time.Clock -import qualified Data.Traversable as TR -import qualified Data.Vector as V -import Foreign.Ruby.Helpers -import GHC.Show (Show (..)) -import GHC.Stack -import qualified System.Log.Logger as Log -import Text.Megaparsec.Pos -import Web.HttpApiData (ToHttpApiData (..)) +import Data.Aeson as A +import qualified Data.Either.Strict as S +import qualified Data.HashMap.Strict as HM +import qualified Data.List as List +import qualified Data.Maybe.Strict as S +import qualified GHC.Show +import qualified GHC.Stack +import qualified System.Log.Logger as Log -import Puppet.Parser.PrettyPrinter +import Facter +import Hiera.Server +import Puppet.Language import Puppet.Parser.Types -import Puppet.Paths -import Puppet.PP hiding (rational) - -metaparameters :: HS.HashSet Text -metaparameters = HS.fromList ["tag","stage","name","title","alias","audit","check","loglevel","noop","schedule", "EXPORTEDSOURCE", "require", "before", "register", "notify"] - -type NodeName = Text -type Container = HM.HashMap Text -type Scope = Text -type Facts = Container PValue - -newtype PrettyError = PrettyError { getError :: Doc } - -instance Show PrettyError where - show = show . getError - -instance Monoid PrettyError where - mempty = PrettyError mempty - mappend a b = PrettyError $ getError a <+> getError b - -instance IsString PrettyError where - fromString = PrettyError . string - -instance Exception PrettyError - -instance Pretty PrettyError where - pretty = getError - -data PValue = PBoolean !Bool - | PUndef - | PString !Text -- integers and doubles are internally serialized as strings by puppet - | PResourceReference !Text !Text - | PArray !(V.Vector PValue) - | PHash !(Container PValue) - | PNumber !Scientific - | PType DataType - deriving (Eq, Show) - -instance IsString PValue where - fromString = PString . Text.pack - -instance AsNumber PValue where - _Number = prism num2PValue toNumber - where - num2PValue :: Scientific -> PValue - num2PValue = PNumber - toNumber :: PValue -> Either PValue Scientific - toNumber (PNumber n) = Right n - toNumber p@(PString x) = case text2Scientific x of - Just o -> Right o - _ -> Left p - toNumber p = Left p - --- | The different kind of hiera queries. -data HieraQueryType - = QFirst -- ^ standard hiera query - | QUnique -- ^ hiera_array - | QHash -- ^ hiera_hash - | QDeep - { _knockoutPrefix :: Maybe Text - , _sortMerged :: Bool - , _mergeHashArray :: Bool - } deriving (Show) - --- | The type of the Hiera API function associated to given hierarchy. -type HieraQueryFunc m = Container Text -- ^ Scope: all variables that Hiera can interpolate (the top level ones are prefixed with ::) - -> Text -- ^ The query - -> HieraQueryType - -> m (S.Either PrettyError (Maybe PValue)) - --- | All available queries including the global and module layer --- The environment layer is not implemented -data HieraQueryLayers m - = HieraQueryLayers - { - _globalLayer :: HieraQueryFunc m - , _moduleLayer :: Container (HieraQueryFunc m) - } +import PuppetDB -- | The intepreter can run in two modes : a strict mode (recommended), and -- a permissive mode. -data Strictness = Strict | Permissive - deriving (Show, Eq) +data Strictness + = Strict + | Permissive + deriving (Show, Eq) instance FromJSON Strictness where parseJSON (Bool True) = pure Strict parseJSON (Bool False) = pure Permissive parseJSON _ = mzero -data RSearchExpression = REqualitySearch !Text !PValue - | RNonEqualitySearch !Text !PValue - | RAndSearch !RSearchExpression !RSearchExpression - | ROrSearch !RSearchExpression !RSearchExpression - | RAlwaysTrue - deriving (Show, Eq) +data RSearchExpression + = REqualitySearch !Text !PValue + | RNonEqualitySearch !Text !PValue + | RAndSearch !RSearchExpression !RSearchExpression + | ROrSearch !RSearchExpression !RSearchExpression + | RAlwaysTrue + deriving (Show, Eq) --- | Puppet has two main ways to declare classes: include-like and resource-like --- See -data ClassIncludeType = ClassIncludeLike -- ^ using the include or contain function - | ClassResourceLike -- ^ resource like declaration - deriving (Eq) +-- | Puppet has two main ways to declare classes: include-like and resource-like. +-- +-- See . +data ClassIncludeType + = ClassIncludeLike -- ^ Using the include or contain function + | ClassResourceLike -- ^ Resource like declaration + deriving (Eq) --- | This type is used to differenciate the distinct top level types that are exposed by the DSL. +-- | Differentiate the distinct top level types such as node, define or class. data TopLevelType - -- |This is for node entries. - = TopNode - -- |This is for defines. - | TopDefine - -- |This is for classes. - | TopClass - deriving (Generic,Eq) + = TopNode -- ^ For node entries + | TopDefine -- ^ For defines + | TopClass -- ^ For classes + deriving (Generic, Eq) instance Hashable TopLevelType --- | From the evaluation of Resource Default Declaration +-- | From the evaluation of Resource Default Declaration. data ResDefaults = ResDefaults - { _resDefType :: !Text - , _resDefSrcScope :: !Text - , _resDefValues :: !(Container PValue) - , _resDefPos :: !PPosition - } + { _resDefType :: !Text + , _resDefSrcScope :: !Text + , _resDefValues :: !(Container PValue) + , _resDefPos :: !PPosition + } --- | From the evaluation of Resource Override Declaration +-- | From the evaluation of Resource Override Declaration. data ResRefOverride = ResRefOverride - { _rrid :: !RIdentifier - , _rrparams :: !(Container PValue) - , _rrpos :: !PPosition - } deriving (Eq) - -data CurContainerDesc = ContRoot -- ^ Contained at node or root level - | ContClass !Text -- ^ Contained in a class - | ContDefine !Text !Text !PPosition -- ^ Contained in a define, along with the position where this define was ... defined - | 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, Show) + { _rrid :: !RIdentifier + , _rrparams :: !(Container PValue) + , _rrpos :: !PPosition + } deriving (Eq) -data ScopeEnteringContext = SENormal - | SEChild !Text -- ^ We enter the scope as the child of another class - | SEParent !Text -- ^ We enter the scope as the parent of another class +data ScopeEnteringContext + = SENormal + | SEChild !Text -- ^ We enter the scope as the child of another class + | SEParent !Text -- ^ We enter the scope as the parent of another class --- TODO related to Scope: explain ... +-- | The type of the container together with its tags. data CurContainer = CurContainer - { _cctype :: !CurContainerDesc - , _cctags :: !(HS.HashSet Text) - } deriving (Eq) + { _cctype :: !CurContainerDesc + , _cctags :: !(HashSet Text) + } deriving (Eq) data ScopeInformation = ScopeInformation - { _scopeVariables :: !(Container (Pair (Pair PValue PPosition) CurContainerDesc)) - , _scopeResDefaults :: !(Container ResDefaults) - , _scopeExtraTags :: !(HS.HashSet Text) - , _scopeContainer :: !CurContainer - , _scopeOverrides :: !(HM.HashMap RIdentifier ResRefOverride) - , _scopeParent :: !(S.Maybe Text) - } + { _scopeVariables :: !(Container (Pair (Pair PValue PPosition) CurContainerDesc)) + , _scopeResDefaults :: !(Container ResDefaults) + , _scopeExtraTags :: !(HashSet Text) + , _scopeContainer :: !CurContainer + , _scopeOverrides :: !(HashMap RIdentifier ResRefOverride) + , _scopeParent :: !(S.Maybe Text) + } data InterpreterState = InterpreterState - { _scopes :: !(Container ScopeInformation) - , _loadedClasses :: !(Container (Pair ClassIncludeType PPosition)) - , _definedResources :: !(HM.HashMap RIdentifier Resource) - , _curScope :: ![CurContainerDesc] - , _curPos :: !PPosition - , _nestedDeclarations :: !(HM.HashMap (TopLevelType,Text) Statement) - , _extraRelations :: ![LinkInformation] - , _resMod :: ![ResourceModifier] - } - -data InterpreterReader m = InterpreterReader - { _readerNativeTypes :: !(Container NativeTypeMethods) - , _readerGetStatement :: TopLevelType -> Text -> m (S.Either PrettyError Statement) - , _readerGetTemplate :: Either Text Text -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError Text) - , _readerPdbApi :: PuppetDBAPI m - , _readerExternalFunc :: Container ([PValue] -> InterpreterMonad PValue) -- ^ external func such as stdlib or puppetlabs - , _readerNodename :: Text - , _readerHieraQuery :: HieraQueryLayers m - , _readerIoMethods :: IoMethods m - , _readerIgnoredModules :: HS.HashSet Text - , _readerExternalModules :: HS.HashSet Text - , _readerIsStrict :: Bool - , _readerPuppetPaths :: PuppetDirPaths - , _readerRebaseFile :: Maybe FilePath - } + { _scopes :: !(Container ScopeInformation) + , _loadedClasses :: !(Container (Pair ClassIncludeType PPosition)) + , _definedResources :: !(HM.HashMap RIdentifier Resource) + , _curScope :: ![CurContainerDesc] + , _curPos :: !PPosition + , _nestedDeclarations :: !(HashMap (TopLevelType, Text) Statement) + , _extraRelations :: ![LinkInformation] + , _resModifiers :: ![ResourceModifier] + } data IoMethods m = IoMethods - { _ioGetCurrentCallStack :: m [String] - , _ioReadFile :: [Text] -> m (Either String Text) - , _ioTraceEvent :: String -> m () - } + { _ioGetCurrentCallStack :: m [String] + , _ioReadFile :: [Text] -> m (Either String Text) + , _ioTraceEvent :: String -> m () + } +-- | All available queries including the global and module layer +-- The environment layer is not implemented. +-- +-- The datatype belongs to the "Puppet.Interpreter" module because it serves to implement how Hiera is used within Puppet. +data HieraQueryLayers m = HieraQueryLayers + { _globalLayer :: HieraQueryFunc m + , _moduleLayer :: Container (HieraQueryFunc m) + } + +data InterpreterReader m = InterpreterReader + { _readerNativeTypes :: !(Container NativeTypeMethods) + , _readerGetStatement :: TopLevelType -> Text -> m (S.Either PrettyError Statement) + , _readerGetTemplate :: Either Text Text -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError Text) + , _readerPdbApi :: PuppetDBAPI m + , _readerExternalFunc :: Container ([PValue] -> InterpreterMonad PValue) -- ^ External func such as stdlib or puppetlabs + , _readerNodename :: Text + , _readerHieraQuery :: HieraQueryLayers m + , _readerIoMethods :: IoMethods m + , _readerIgnoredModules :: HashSet Text + , _readerExternalModules :: HashSet Text + , _readerIsStrict :: Bool + , _readerPuppetPaths :: PuppetDirPaths + , _readerRebaseFile :: Maybe FilePath + } + data InterpreterInstr a where - -- Utility for using what's in "InterpreterReader" - GetNativeTypes :: InterpreterInstr (Container NativeTypeMethods) - GetStatement :: TopLevelType -> Text -> InterpreterInstr Statement - ComputeTemplate :: Either Text Text -> InterpreterState -> InterpreterInstr Text - ExternalFunction :: Text -> [PValue] -> InterpreterInstr PValue - GetNodeName :: InterpreterInstr Text - HieraQuery :: Container Text -> Text -> HieraQueryType -> InterpreterInstr (Maybe PValue) - GetCurrentCallStack :: InterpreterInstr [String] - IsIgnoredModule :: Text -> InterpreterInstr Bool - IsExternalModule :: Text -> InterpreterInstr Bool - IsStrict :: InterpreterInstr Bool - PuppetPaths :: InterpreterInstr PuppetDirPaths - RebaseFile :: InterpreterInstr (Maybe FilePath) - -- error - ErrorThrow :: PrettyError -> InterpreterInstr a - ErrorCatch :: InterpreterMonad a -> (PrettyError -> InterpreterMonad a) -> InterpreterInstr a - -- writer - WriterTell :: InterpreterWriter -> InterpreterInstr () - WriterPass :: InterpreterMonad (a, InterpreterWriter -> InterpreterWriter) -> InterpreterInstr a - WriterListen :: InterpreterMonad a -> InterpreterInstr (a, InterpreterWriter) - -- puppetdb wrappers, see 'PuppetDBAPI' for details - PDBInformation :: InterpreterInstr Doc - PDBReplaceCatalog :: WireCatalog -> InterpreterInstr () - PDBReplaceFacts :: [(NodeName, Facts)] -> InterpreterInstr () - PDBDeactivateNode :: NodeName -> InterpreterInstr () - PDBGetFacts :: Query FactField -> InterpreterInstr [FactInfo] - PDBGetResources :: Query ResourceField -> InterpreterInstr [Resource] - PDBGetNodes :: Query NodeField -> InterpreterInstr [NodeInfo] - PDBCommitDB :: InterpreterInstr () - PDBGetResourcesOfNode :: NodeName -> Query ResourceField -> InterpreterInstr [Resource] - -- Reading the first file that can be read in a list - ReadFile :: [Text] -> InterpreterInstr Text - -- Tracing events - TraceEvent :: String -> InterpreterInstr () + -- Utility for using what's in 'InterpreterReader' + GetNativeTypes :: InterpreterInstr (Container NativeTypeMethods) + GetStatement :: TopLevelType -> Text -> InterpreterInstr Statement + ComputeTemplate :: Either Text Text -> InterpreterState -> InterpreterInstr Text + ExternalFunction :: Text -> [PValue] -> InterpreterInstr PValue + GetNodeName :: InterpreterInstr Text + HieraQuery :: Container Text -> Text -> HieraQueryType -> InterpreterInstr (Maybe PValue) + GetCurrentCallStack :: InterpreterInstr [String] + IsIgnoredModule :: Text -> InterpreterInstr Bool + IsExternalModule :: Text -> InterpreterInstr Bool + IsStrict :: InterpreterInstr Bool + PuppetPaths :: InterpreterInstr PuppetDirPaths + RebaseFile :: InterpreterInstr (Maybe FilePath) + -- error + ErrorThrow :: PrettyError -> InterpreterInstr a + ErrorCatch :: InterpreterMonad a -> (PrettyError -> InterpreterMonad a) -> InterpreterInstr a + -- writer + WriterTell :: InterpreterWriter -> InterpreterInstr () + WriterPass :: InterpreterMonad (a, InterpreterWriter -> InterpreterWriter) -> InterpreterInstr a + WriterListen :: InterpreterMonad a -> InterpreterInstr (a, InterpreterWriter) + -- puppetdb wrappers, see 'PuppetDBAPI' for details + PDBInformation :: InterpreterInstr Doc + PDBReplaceCatalog :: WireCatalog -> InterpreterInstr () + PDBReplaceFacts :: [(NodeName, Facts)] -> InterpreterInstr () + PDBDeactivateNode :: NodeName -> InterpreterInstr () + PDBGetFacts :: Query FactField -> InterpreterInstr [FactInfo] + PDBGetResources :: Query ResourceField -> InterpreterInstr [Resource] + PDBGetNodes :: Query NodeField -> InterpreterInstr [NodeInfo] + PDBCommitDB :: InterpreterInstr () + PDBGetResourcesOfNode :: NodeName -> Query ResourceField -> InterpreterInstr [Resource] + -- Reading the first file that can be read in a list + ReadFile :: [Text] -> InterpreterInstr Text + -- Tracing events + TraceEvent :: String -> InterpreterInstr () -- | The main monad type InterpreterMonad = ProgramT InterpreterInstr (State InterpreterState) @@ -360,186 +272,49 @@ pass = singleton . WriterPass listen = singleton . WriterListen -data RIdentifier = RIdentifier - { _itype :: !Text - , _iname :: !Text - } deriving (Show,Eq,Generic,Ord) -instance Hashable RIdentifier - data ResourceModifier = ResourceModifier - { _rmResType :: !Text - , _rmModifierType :: !ModifierType - , _rmType :: !ResourceCollectorType - , _rmSearch :: !RSearchExpression - , _rmMutation :: !(Resource -> InterpreterMonad Resource) - , _rmDeclaration :: !PPosition - } + { _rmResType :: !Text + , _rmModifierType :: !ModifierType + , _rmType :: !ResourceCollectorType + , _rmSearch :: !RSearchExpression + , _rmMutation :: !(Resource -> InterpreterMonad Resource) + , _rmDeclaration :: !PPosition + } instance Show ResourceModifier where show (ResourceModifier rt mt ct se _ p) = List.unwords ["ResourceModifier", show rt, show mt, show ct, "(" ++ show se ++ ")", "???", show p] -data ModifierType = ModifierCollector -- ^ For collectors, optional resources - | ModifierMustMatch -- ^ For stuff like realize - deriving (Show, Eq) +data ModifierType + = ModifierCollector -- ^ For collectors, optional resources + | ModifierMustMatch -- ^ For stuff like realize + deriving (Show, Eq) -data OverrideType = CantOverride -- ^ Overriding forbidden, will throw an error - | Replace -- ^ Can silently replace - | CantReplace -- ^ Silently ignore errors - | AppendAttribute -- ^ Can append values - deriving (Show, Eq) +data OverrideType + = CantOverride -- ^ Overriding forbidden, will throw an error + | Replace -- ^ Can silently replace + | CantReplace -- ^ Silently ignore errors + | AppendAttribute -- ^ Can append values + deriving (Show, Eq) -data ResourceCollectorType = RealizeVirtual - | RealizeCollected - | DontRealize - deriving (Show, Eq) +data ResourceCollectorType + = RealizeVirtual + | RealizeCollected + | DontRealize + deriving (Show, Eq) -data LinkInformation = LinkInformation - { _linksrc :: !RIdentifier - , _linkdst :: !RIdentifier - , _linkType :: !LinkType - , _linkPos :: !PPosition - } deriving Show +makeLenses ''ResDefaults +makeLenses ''HieraQueryLayers +makeLenses ''ResourceModifier +makeLenses ''InterpreterReader +makeLenses ''IoMethods +makeLenses ''CurContainer +makeLenses ''ScopeInformation +makeLenses ''InterpreterState -type EdgeMap = HM.HashMap RIdentifier [LinkInformation] -{-| A fully resolved puppet resource that will be used in the 'FinalCatalog'. -} -data Resource = Resource - { _rid :: !RIdentifier -- ^ Resource name. - , _ralias :: !(HS.HashSet Text) -- ^ All the resource aliases - , _rattributes :: !(Container PValue) -- ^ Resource parameters. - , _rrelations :: !(HM.HashMap RIdentifier (HS.HashSet LinkType)) -- ^ Resource relations. - , _rscope :: ![CurContainerDesc] -- ^ Resource scope when it was defined, the real container will be the first item - , _rvirtuality :: !Virtuality - , _rtags :: !(HS.HashSet Text) - , _rpos :: !PPosition -- ^ Source code position of the resource definition. - , _rnode :: !NodeName -- ^ The node were this resource was created, if remote - } - deriving (Eq, Show) - -type NativeTypeValidate = Resource -> Either PrettyError Resource - --- | Attributes (and providers) of a puppet resource type bundled with validation rules -data NativeTypeMethods = NativeTypeMethods - { _puppetValidate :: NativeTypeValidate - , _puppetFields :: HS.HashSet Text - } - -type FinalCatalog = HM.HashMap RIdentifier Resource - --- | Used to represent a relationship between two resources within the wired format (json). --- See -data PuppetEdge = PuppetEdge RIdentifier RIdentifier LinkType deriving Show - --- | Wire format --- --- See . -data WireCatalog = WireCatalog - { _wireCatalogNodename :: !NodeName - , _wireCatalogVersion :: !Text - , _wireCatalogEdges :: !(V.Vector PuppetEdge) - , _wireCatalogResources :: !(V.Vector Resource) - , _wireCatalogTransactionUUID :: !Text - } deriving Show - -data FactInfo = FactInfo - { _factInfoNodename :: !NodeName - , _factInfoName :: !Text - , _factInfoVal :: !PValue - } - -data NodeInfo = NodeInfo - { _nodeInfoName :: !NodeName - , _nodeInfoDeactivated :: !Bool - , _nodeInfoCatalogT :: !(S.Maybe UTCTime) - , _nodeInfoFactsT :: !(S.Maybe UTCTime) - , _nodeInfoReportT :: !(S.Maybe UTCTime) - } - -data PuppetDBAPI m = PuppetDBAPI - { pdbInformation :: m Doc - , 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 -data Query a = QEqual a Text - | QG a Integer - | QL a Integer - | QGE a Integer - | QLE a Integer - | QMatch Text Text - | QAnd [Query a] - | QOr [Query a] - | QNot (Query a) - | QEmpty - --- | Fields for the fact endpoint -data FactField = FName - | FValue - | FCertname - --- | Fields for the node endpoint -data NodeField = NName | NFact Text - --- | Fields for the resource endpoint -data ResourceField = RTag - | RCertname - | RParameter Text - | RType - | RTitle - | RExported - | RFile - | RLine - -data DataType - = DTType - | DTString (Maybe Int) (Maybe Int) - | DTInteger (Maybe Int) (Maybe Int) - | DTFloat (Maybe Double) (Maybe Double) - | DTBoolean - | DTArray DataType Int (Maybe Int) - | DTHash DataType DataType Int (Maybe Int) - | DTUndef - | DTScalar - | DTData - | DTOptional DataType - | NotUndef - | DTVariant (NonEmpty DataType) - | DTPattern (NonEmpty CompRegex) - | DTEnum (NonEmpty Text) - | DTAny - | DTCollection - deriving (Show, Eq) - -makeClassy ''RIdentifier -makeClassy ''ResRefOverride -makeClassy ''LinkInformation -makeClassy ''ResDefaults -makeClassy ''ResourceModifier -makeClassy ''NativeTypeMethods -makeClassy ''ScopeInformation -makeClassy ''Resource -makeClassy ''InterpreterState -makeClassy ''InterpreterReader -makeClassy ''IoMethods -makeClassy ''CurContainer -makeClassy ''NodeInfo -makeClassy ''WireCatalog -makeClassy ''FactInfo -makeClassy ''HieraQueryLayers -makePrisms ''PValue - -$(deriveJSON defaultOptions ''DataType) - class Monad m => MonadThrowPos m where - throwPosError :: Doc -> m a + throwPosError :: Doc -> m a -- Useful for mocking for instance in a REPL instance MonadThrowPos (Either Doc) where @@ -549,239 +324,13 @@ getCurrentCallStack :: m [String] instance MonadStack InterpreterMonad where - getCurrentCallStack = singleton GetCurrentCallStack + getCurrentCallStack = singleton GetCurrentCallStack instance MonadThrowPos InterpreterMonad where - throwPosError s = do - p <- use (curPos . _1) - stack <- getCurrentCallStack - let dstack = if null stack - then line - else mempty string (renderStack stack) - throwError (PrettyError (s <+> "at" <+> showPos p <> dstack)) - -instance ToRuby PValue where - toRuby = toRuby . toJSON -instance FromRuby PValue where - fromRuby = fmap chk . fromRuby - where - chk (Left x) = Left x - chk (Right x) = case fromJSON x of - Error rr -> Left rr - - Success suc -> Right suc - --- JSON INSTANCES -- - -instance FromJSON PValue where - parseJSON Null = return PUndef - parseJSON (Number n) = return $ PNumber n - parseJSON (String s) = return (PString s) - parseJSON (Bool b) = return (PBoolean b) - parseJSON (Array v) = fmap PArray (V.mapM parseJSON v) - parseJSON (Object o) = fmap PHash (TR.mapM parseJSON o) - -instance ToJSON PValue where - toJSON (PType t) = toJSON t - toJSON (PBoolean b) = Bool b - toJSON PUndef = Null - toJSON (PString s) = String s - toJSON (PResourceReference _ _) = Null -- TODO - toJSON (PArray r) = Array (V.map toJSON r) - toJSON (PHash x) = Object (HM.map toJSON x) - toJSON (PNumber n) = Number n - -instance ToJSON Resource where - toJSON r = object [ ("type", String $ r ^. rid . itype) - , ("title", String $ r ^. rid . iname) - , ("aliases", toJSON $ r ^. ralias) - , ("exported", Bool $ r ^. rvirtuality == Exported) - , ("tags", toJSON $ r ^. rtags) - , ("parameters", Object ( HM.map toJSON (r ^. rattributes) `HM.union` relations )) - , ("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 - toValue v | V.length v == 1 = V.head v - | otherwise = Array v - changeRelations :: (RIdentifier, HS.HashSet LinkType) -> [(Text, V.Vector Value)] - changeRelations (k,v) = do - c <- HS.toList v - return (rel2text c, V.singleton (String (rid2text k))) - rid2text :: RIdentifier -> Text - rid2text (RIdentifier t n) = capitalizeRT t `Text.append` "[" `Text.append` capn `Text.append` "]" - where - capn = if t == "classe" - then capitalizeRT n - else n - -instance FromJSON Resource where - parseJSON (Object v) = do - isExported <- v .: "exported" - let virtuality = if isExported - then Exported - else Normal - getResourceIdentifier :: PValue -> Maybe RIdentifier - getResourceIdentifier (PString x) = - let (restype, brckts) = Text.breakOn "[" x - rna | Text.null brckts = Nothing - | Text.null restype = Nothing - | Text.last brckts == ']' = Just (Text.tail (Text.init brckts)) - | otherwise = Nothing - in case rna of - Just resname -> Just (RIdentifier (Text.toLower restype) (Text.toLower resname)) - _ -> Nothing - getResourceIdentifier _ = Nothing - -- TODO : properly handle metaparameters - separate :: (Container PValue, HM.HashMap RIdentifier (HS.HashSet LinkType)) -> Text -> PValue -> (Container PValue, HM.HashMap RIdentifier (HS.HashSet LinkType)) - 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 <$> fmap Text.toLower (v .: "type") <*> v .: "title") - <*> v .:? "aliases" .!= mempty - <*> pure attribs - <*> pure relations - <*> pure [ContImport contimport ContRoot] - <*> pure virtuality - <*> v .: "tags" - <*> (toPPos <$> v .:? "sourcefile" .!= "null" <*> v .:? "sourceline" .!= 1) - <*> pure contimport - - parseJSON _ = mempty - -instance ToJSON a => ToJSON (Query a) where - toJSON (QOr qs) = toJSON ("or" : map toJSON qs) - toJSON (QAnd qs) = toJSON ("and" : map toJSON qs) - toJSON (QNot q) = toJSON [ "not" , toJSON q ] - toJSON (QEqual flds val) = toJSON [ "=", toJSON flds, toJSON val ] - toJSON (QMatch flds val) = toJSON [ "~", toJSON flds, toJSON val ] - toJSON (QL flds val) = toJSON [ "<", toJSON flds, toJSON val ] - 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 - -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 - parseJSON (Array elems) = case V.toList elems of - ("or":xs) -> QOr <$> mapM parseJSON xs - ("and":xs) -> QAnd <$> mapM parseJSON xs - ["not",x] -> QNot <$> parseJSON x - [ "=", flds, val ] -> QEqual <$> parseJSON flds <*> parseJSON val - [ "~", flds, val ] -> QEqual <$> parseJSON flds <*> parseJSON val - [ ">", flds, val ] -> QG <$> parseJSON flds <*> parseJSON val - [ "<", flds, val ] -> QL <$> parseJSON flds <*> parseJSON val - [">=", flds, val ] -> QGE <$> parseJSON flds <*> parseJSON val - ["<=", flds, val ] -> QLE <$> parseJSON flds <*> parseJSON val - x -> fail ("unknown query" ++ show x) - parseJSON _ = fail "Expected an array" - -instance ToJSON FactField where - toJSON FName = "name" - toJSON FValue = "value" - toJSON FCertname = "certname" - -instance FromJSON FactField where - parseJSON "name" = pure FName - parseJSON "value" = pure FValue - parseJSON "certname" = pure FCertname - parseJSON _ = fail "Can't parse fact field" - -instance ToJSON NodeField where - toJSON NName = "name" - toJSON (NFact t) = toJSON [ "fact", t ] - -instance FromJSON NodeField where - parseJSON (Array xs) = case V.toList xs of - ["fact", x] -> NFact <$> parseJSON x - _ -> fail "Invalid field syntax" - parseJSON (String "name") = pure NName - parseJSON _ = fail "invalid field" - -instance ToJSON ResourceField where - toJSON RTag = "tag" - toJSON RCertname = "certname" - toJSON (RParameter t) = toJSON ["parameter", t] - toJSON RType = "type" - toJSON RTitle = "title" - toJSON RExported = "exported" - toJSON RFile = "file" - toJSON RLine = "line" - -instance FromJSON ResourceField where - parseJSON (Array xs) = case V.toList xs of - ["parameter", x] -> RParameter <$> parseJSON x - _ -> fail "Invalid field syntax" - parseJSON (String "tag" ) = pure RTag - parseJSON (String "certname") = pure RCertname - parseJSON (String "type" ) = pure RType - parseJSON (String "title" ) = pure RTitle - parseJSON (String "exported") = pure RExported - parseJSON (String "file" ) = pure RFile - parseJSON (String "line" ) = pure RLine - parseJSON _ = fail "invalid field" - -instance FromJSON RIdentifier where - parseJSON (Object v) = RIdentifier <$> v .: "type" <*> v .: "title" - parseJSON _ = fail "invalid resource" - -instance ToJSON RIdentifier where - toJSON (RIdentifier t n) = object [("type", String t), ("title", String n)] - -instance FromJSON PuppetEdge where - parseJSON (Object v) = PuppetEdge <$> v .: "source" <*> v .: "target" <*> v .: "relationship" - parseJSON _ = fail "invalid puppet edge" - -instance ToJSON PuppetEdge where - toJSON (PuppetEdge s t r) = object [("source", toJSON s), ("target", toJSON t), ("relationship", toJSON r)] - -instance FromJSON WireCatalog where - parseJSON (Object d) = d .: "data" >>= \case - (Object v) -> WireCatalog - <$> v .: "name" - <*> v .: "version" - <*> v .: "edges" - <*> v .: "resources" - <*> v .: "transaction-uuid" - _ -> fail "Data is not an object" - parseJSON _ = fail "invalid wire catalog" - -instance ToJSON WireCatalog where - toJSON (WireCatalog n v e r t) = object [("metadata", object [("api_version", Number 1)]), ("data", object d)] - where d = [ ("name", String n) - , ("version", String v) - , ("edges", toJSON e) - , ("resources", toJSON r) - , ("transaction-uuid", String t) - ] - -instance ToJSON FactInfo where - toJSON (FactInfo n f v) = object [("certname", String n), ("name", String f), ("value", toJSON v)] - -instance FromJSON FactInfo where - parseJSON (Object v) = FactInfo <$> v .: "certname" <*> v .: "name" <*> v .: "value" - parseJSON _ = fail "invalid fact info" - -instance ToJSON NodeInfo where - toJSON p = object [ ("name" , toJSON (p ^. nodeInfoName)) - , ("deactivated" , toJSON (p ^. nodeInfoDeactivated)) - , ("catalog_timestamp", toJSON (p ^. nodeInfoCatalogT)) - , ("facts_timestamp" , toJSON (p ^. nodeInfoFactsT)) - , ("report_timestamp" , toJSON (p ^. nodeInfoReportT)) - ] - -instance FromJSON NodeInfo where - parseJSON (Object v) = NodeInfo <$> v .: "name" - <*> v .:? "deactivated" .!= False - <*> v .: "catalog_timestamp" - <*> v .: "facts_timestamp" - <*> v .: "report_timestamp" - parseJSON _ = fail "invalide node info" + throwPosError s = do + p <- use (curPos . _1) + stack <- getCurrentCallStack + let dstack = if null stack + then line + else mempty ppstring (GHC.Stack.renderStack stack) + throwError (PrettyError (s <+> "at" <+> showPos p <> dstack)) diff --git a/src/Puppet/Interpreter/Utils.hs b/src/Puppet/Interpreter/Utils.hs deleted file mode 100644 --- a/src/Puppet/Interpreter/Utils.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} - --- | The module should not depend on the Interpreter module. It is an --- internal module and should not be used if expecting a stable API. -module Puppet.Interpreter.Utils where - -import Puppet.Prelude - -import Control.Monad.Operational -import Control.Monad.Writer.Class -import qualified Data.HashMap.Strict as HM -import qualified Data.List as List -import qualified Data.Maybe.Strict as S -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified System.Log.Logger as Log - -import Puppet.Interpreter.Types -import Puppet.Parser.Types -import Puppet.Parser.Utils -import Puppet.Paths -import Puppet.PP - - -initialState :: Facts - -> Container Text -- ^ Server settings - -> InterpreterState -initialState facts settings = - InterpreterState baseVars initialclass mempty [ContRoot] dummyppos mempty [] [] - where - callervars = HM.fromList [("caller_module_name", PString "::" :!: dummyppos :!: ContRoot), ("module_name", PString "::" :!: dummyppos :!: ContRoot)] - factvars = - -- add the `facts` key: https://docs.puppet.com/puppet/4.10/lang_facts_and_builtin_vars.html#accessing-facts-from-puppet-code - let facts' = HM.insert "facts" (PHash facts) facts - in fmap (\x -> x :!: initialPPos "facts" :!: ContRoot) facts' - settingvars = fmap (\x -> PString x :!: initialPPos "settings" :!: ContClass "settings") settings - baseVars = HM.fromList [ ("::", ScopeInformation (factvars `mappend` callervars) mempty mempty (CurContainer ContRoot mempty) mempty S.Nothing) - , ("settings", ScopeInformation settingvars mempty mempty (CurContainer (ContClass "settings") mempty) mempty S.Nothing) - ] - initialclass = mempty & at "::" ?~ (ClassIncludeLike :!: dummyppos) - -getModulename :: RIdentifier -> Text -getModulename (RIdentifier t n) = - let gm x = - case Text.splitOn "::" x of - [] -> x - (y:_) -> y - in case t of - "class" -> gm n - _ -> gm t - -extractPrism :: Doc -> Prism' a b -> a -> InterpreterMonad b -extractPrism msg p a = - case preview p a of - Just b -> return b - Nothing -> throwPosError ("Could not extract prism in" <+> msg) - --- Scope -popScope :: InterpreterMonad () -popScope = curScope %= List.tail - -pushScope :: CurContainerDesc -> InterpreterMonad () -pushScope s = curScope %= (s :) - -getScopeName :: InterpreterMonad Text -getScopeName = scopeName <$> getScope - -scopeName :: CurContainerDesc -> Text -scopeName (ContRoot ) = "::" -scopeName (ContImported x ) = "::imported::" `Text.append` scopeName x -scopeName (ContClass x ) = x -scopeName (ContDefine dt dn _) = "#define/" `Text.append` dt `Text.append` "/" `Text.append` dn -scopeName (ContImport _ x ) = "::import::" `Text.append` scopeName x - -moduleName :: CurContainerDesc -> Text -moduleName (ContRoot ) = "::" -moduleName (ContImported x ) = moduleName x -moduleName (ContClass x ) = x -moduleName (ContDefine dt _ _) = dt -moduleName (ContImport _ x ) = moduleName x - -getScope :: InterpreterMonad CurContainerDesc -{-# INLINABLE getScope #-} -getScope = - use curScope >>= \s -> - if null s - then throwPosError "Internal error: empty scope!" - else pure (List.head s) - -getCurContainer :: InterpreterMonad CurContainer -{-# INLINABLE getCurContainer #-} -getCurContainer = do - scp <- getScopeName - preuse (scopes . ix scp . scopeContainer) >>= \case - Just x -> return x - Nothing -> throwPosError ("Internal error: can't find the current container for" <+> green (string (Text.unpack scp))) - -rcurcontainer :: Resource -> CurContainerDesc -rcurcontainer r = fromMaybe ContRoot (r ^? rscope . _head) - --- Singleton getters available in the InterpreterMonad -- -getPuppetPaths :: InterpreterMonad PuppetDirPaths -getPuppetPaths = singleton PuppetPaths - -getNodeName:: InterpreterMonad NodeName -getNodeName = singleton GetNodeName - -isIgnoredModule :: Text -> InterpreterMonad Bool -isIgnoredModule m = singleton (IsIgnoredModule m) - --- | Throws an error if we are in strict mode --- A warning in permissive mode -checkStrict :: Doc -- ^ The warning message. - -> Doc -- ^ The error message. - -> InterpreterMonad () -checkStrict wrn err = do - extMod <- isExternalModule - let priority = - if extMod - then Log.NOTICE - else Log.WARNING - str <- singleton IsStrict - if str && not extMod - then throwPosError err - else do - srcname <- use (curPos . _1 . lSourceName) - logWriter priority (wrn <+> "at" <+> string srcname) - -isExternalModule :: InterpreterMonad Bool -isExternalModule = - getScope >>= \case - ContClass n -> isExternal n - ContDefine n _ _ -> isExternal n - _ -> return False - where - isExternal = singleton . IsExternalModule . List.head . Text.splitOn "::" - --- Logging -- -warn :: MonadWriter InterpreterWriter m => Doc -> m () -warn d = tell [Log.WARNING :!: d] - -debug :: MonadWriter InterpreterWriter m => Doc -> m () -debug d = tell [Log.DEBUG :!: d] - -logWriter :: MonadWriter InterpreterWriter m => Log.Priority -> Doc -> m () -logWriter prio d = tell [prio :!: d] - -safeDecodeUtf8 :: ByteString -> InterpreterMonad Text -{-# INLINABLE safeDecodeUtf8 #-} -safeDecodeUtf8 i = return (Text.decodeUtf8 i) - -normalizeRIdentifier :: Text -> Text -> RIdentifier -normalizeRIdentifier = RIdentifier . dropInitialColons - -readQueryType :: Text -> Maybe HieraQueryType -readQueryType s = - case s of - "first" -> Just QFirst - "unique" -> Just QUnique - "hash" -> Just QHash - _ -> Nothing diff --git a/src/Puppet/Language.hs b/src/Puppet/Language.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Language.hs @@ -0,0 +1,21 @@ +-- | General puppet language specification. +-- +-- This module doesn't depend on any other project modules (except for "XPrelude"). +-- It serves as a common bridge that can be used in "PuppetDB" or "Facter" as well as in +-- "Puppet.Interpreter" or "Puppet.Parser". +module Puppet.Language( + module Puppet.Language.Core + , module Puppet.Language.NativeTypes + , module Puppet.Language.Paths + , module Puppet.Language.Resource + , module Puppet.Language.Value + , module Puppet.Language.WireCatalog +) +where + +import Puppet.Language.Core +import Puppet.Language.Resource +import Puppet.Language.Value +import Puppet.Language.WireCatalog +import Puppet.Language.NativeTypes +import Puppet.Language.Paths diff --git a/src/Puppet/Language/Core.hs b/src/Puppet/Language/Core.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Language/Core.hs @@ -0,0 +1,101 @@ +module Puppet.Language.Core + +where + +import XPrelude + +import Data.Aeson +import qualified Data.Char as Char +import qualified Data.HashMap.Strict as Map +import qualified Data.Text as Text +import qualified Data.Tuple.Strict as Tuple +import qualified GHC.Show as Show (Show (..)) +import Text.Megaparsec.Pos + + +showPos :: Position -> Doc +showPos p = green (pretty '#' <+> ppline (show p)) + +showPPos :: PPosition -> Doc +showPPos p = green (pretty '#' <+> ppline (show (Tuple.fst p))) + +-- | 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 + +type NodeName = Text +type Scope = Text + +data CompRegex = CompRegex !Text !Regex + +instance Show CompRegex where + show (CompRegex t _) = show t + +instance Eq CompRegex where + (CompRegex a _) == (CompRegex b _) = a == b + +instance FromJSON CompRegex where + parseJSON = panic "Can't deserialize a regular expression" + +instance ToJSON CompRegex where + toJSON (CompRegex t _) = toJSON t + +instance Pretty CompRegex where + pretty (CompRegex r _) = pretty '/' <> ppline r <> pretty '/' + +-- | Extremely hacky escaping system for text values. +stringEscape :: Text -> Text +stringEscape = Text.concatMap escapeChar + where + escapeChar '"' = "\\\"" + escapeChar '\n' = "\\n" + escapeChar '\t' = "\\t" + escapeChar '\r' = "\\r" + escapeChar x = Text.singleton x +{-# INLINE stringEscape #-} + +-- | Capitalize resource type and convert into a 'Doc'. +capitalizeR :: Text -> Doc +capitalizeR = dullyellow . ppline . capitalizeRT + +-- | Properly capitalizes resource types. +capitalizeRT :: Text -> Text +capitalizeRT = Text.intercalate "::" . map capitalize' . Text.splitOn "::" + where + capitalize' :: Text -> Text + capitalize' t | Text.null t = Text.empty + | otherwise = Text.cons (Char.toUpper (Text.head t)) (Text.tail t) + +containerComma'' :: Pretty a => [(Doc, a)] -> Doc +containerComma'' x = indent 2 ins + where + ins = mconcat $ intersperse (comma <> line <> mempty) (fmap showC x) + showC (a,b) = a <+> "=>" <+> pretty b + +containerComma' :: Pretty a => [(Doc, a)] -> Doc +containerComma' = braces . containerComma'' + +containerComma :: Pretty a => Container a -> Doc +containerComma hm = containerComma' (fmap (\(a,b) -> (fill maxalign (ppline a), b)) hml) + where + hml = Map.toList hm + maxalign = maximum (fmap (Text.length . fst) hml) + + +-- Lens +_sourceName :: Lens' Position String +_sourceName = lens sourceName (\s n -> s { sourceName = n }) + +_sourceLine :: Lens' Position Pos +_sourceLine = lens sourceLine (\s l -> s { sourceLine = l }) + +_sourceColumn :: Lens' Position Pos +_sourceColumn = lens sourceColumn (\s c -> s { sourceColumn = c }) + +-- | Generates a 'PPosition' based on a filename and line number. +toPPos :: Text -> Int -> PPosition +toPPos fl ln = + let p = (initialPos (toS fl)) { sourceLine = mkPos $ fromIntegral (max 1 ln) } + in (p :!: p) diff --git a/src/Puppet/Language/NativeTypes.hs b/src/Puppet/Language/NativeTypes.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Language/NativeTypes.hs @@ -0,0 +1,48 @@ +-- | This exposed module holds the /native/ Puppet resource types. +module Puppet.Language.NativeTypes ( + baseNativeTypes + , defaulttype + , NativeTypeMethods + , NativeTypeName + , HasNativeTypeMethods(..) +) where + +import qualified Data.HashMap.Strict as HM + +import Puppet.Language.NativeTypes.Concat +import Puppet.Language.NativeTypes.Cron +import Puppet.Language.NativeTypes.Exec +import Puppet.Language.NativeTypes.File +import Puppet.Language.NativeTypes.Group +import Puppet.Language.NativeTypes.Helpers +import Puppet.Language.NativeTypes.Host +import Puppet.Language.NativeTypes.Mount +import Puppet.Language.NativeTypes.Notify +import Puppet.Language.NativeTypes.Package +import Puppet.Language.NativeTypes.SshSecure +import Puppet.Language.NativeTypes.User +import Puppet.Language.NativeTypes.ZoneRecord + +fakeTypes :: [(NativeTypeName, NativeTypeMethods)] +fakeTypes = map faketype ["class"] + +defaultTypes :: [(NativeTypeName, NativeTypeMethods)] +defaultTypes = map defaulttype ["augeas","computer","filebucket","interface","k5login","macauthorization","mailalias","maillist","mcx","nagios_command","nagios_contact","nagios_contactgroup","nagios_host","nagios_hostdependency","nagios_hostescalation","nagios_hostextinfo","nagios_hostgroup","nagios_service","nagios_servicedependency","nagios_serviceescalation","nagios_serviceextinfo","nagios_servicegroup","nagios_timeperiod","resources","router","schedule","scheduledtask","selboolean","selmodule","service","ssh_authorized_key","sshkey","stage","tidy","vlan","yumrepo","zfs","zone","zpool"] + +-- | The map of native types. +baseNativeTypes :: Container NativeTypeMethods +baseNativeTypes = HM.fromList + ( nativeConcat + : nativeConcatFragment + : nativeCron + : nativeExec + : nativeFile + : nativeGroup + : nativeHost + : nativeMount + : nativeNotify + : nativePackage + : nativeSshSecure + : nativeUser + : nativeZoneRecord + : fakeTypes ++ defaultTypes) diff --git a/src/Puppet/Language/NativeTypes/Concat.hs b/src/Puppet/Language/NativeTypes/Concat.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Language/NativeTypes/Concat.hs @@ -0,0 +1,46 @@ +module Puppet.Language.NativeTypes.Concat ( + nativeConcat + , nativeConcatFragment +) where + +import Puppet.Language.NativeTypes.Helpers + +nativeConcat :: (NativeTypeName, NativeTypeMethods) +nativeConcat = ("concat", nativetypemethods concatparamfunctions pure) + +nativeConcatFragment :: (NativeTypeName, NativeTypeMethods) +nativeConcatFragment = ("concat::fragment", nativetypemethods fragmentparamfunctions validateSourceOrContent) + +concatparamfunctions :: [(Text, [Text -> NativeTypeValidate])] +concatparamfunctions = + [("name" , [nameval]) + ,("ensure" , [defaultvalue "present", string, values ["present","absent"]]) + ,("path" , [string]) + ,("owner" , [string]) + ,("group" , [string]) + ,("mode" , [defaultvalue "0644", string]) + ,("warn" , [defaultvalue "false", string, values ["false", "true"]]) + ,("force" , [defaultvalue "false", string, values ["false", "true"]]) + ,("backup" , [defaultvalue "puppet", string]) + ,("replace" , [defaultvalue "true", string, values ["false", "true"]]) + ,("order" , [defaultvalue "alpha", string, values ["alpha","numeric"]]) + ,("ensure_newline" , [defaultvalue "false", string, values ["false", "true"]]) + -- deprecated + -- ,("gnu" , [string]) + ] + +fragmentparamfunctions :: [(Text, [Text -> NativeTypeValidate])] +fragmentparamfunctions = + [("name" , [nameval]) + ,("target" , [string, mandatory]) + ,("content" , [string]) + ,("source" , [string]) + -- order should be an int or a string + ,("order" , [defaultvalue "10", string]) + ,("ensure" , [string, values ["present","absent"]]) + -- deprecated field + -- ,("mode" , [string]) + -- ,("owner" , [string]) + -- ,("group" , [string]) + -- ,("backup" , [string]) + ] diff --git a/src/Puppet/Language/NativeTypes/Cron.hs b/src/Puppet/Language/NativeTypes/Cron.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Language/NativeTypes/Cron.hs @@ -0,0 +1,61 @@ +module Puppet.Language.NativeTypes.Cron + (nativeCron) +where + +import qualified Data.Text as Text + +import Puppet.Language.NativeTypes.Helpers + +nativeCron :: (NativeTypeName, NativeTypeMethods) +nativeCron = ("cron", nativetypemethods parameterfunctions return ) + +-- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them. +parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] +parameterfunctions = + [("ensure" , [defaultvalue "present", string, values ["present","absent"]]) + ,("command" , [string, mandatoryIfNotAbsent]) + ,("environment" , []) + ,("hour" , [vrange 0 23 [] ]) + ,("minute" , [vrange 0 59 [] ]) + ,("month" , [vrange 1 12 ["January","February","March","April","May","June","July","August","September","October","November","December"] ]) + ,("monthday" , [vrange 1 31 [] ]) + ,("name" , [nameval]) + ,("provider" , [defaultvalue "crontab", string, values ["crontab"]]) + ,("special" , [string]) + ,("target" , [string]) + ,("user" , [defaultvalue "root", string]) + ,("weekday" , [vrange 0 7 ["Monday","Tuesday","Wednesday","Thursday","Friday","Saturday","Sunday"]]) + ] + + +vrange :: Integer -> Integer -> [Text] -> Text -> NativeTypeValidate +vrange mi ma valuelist param res = case res ^. rattributes . at param of + Just (PArray xs) -> foldM (vrange' mi ma valuelist param) res xs + Just x -> vrange' mi ma valuelist param res x + Nothing -> defaultvalue "*" param res + +vrange' :: Integer -> Integer -> [Text] -> Text -> Resource -> PValue -> Either PrettyError Resource +vrange' mi ma valuelist param res y = case y of + PString "*" -> Right res + PString "absent" -> Right res + PNumber n -> checkint' n mi ma param res + PString x -> if x `elem` valuelist + then Right res + else parseval x mi ma param res + x -> perror $ "Parameter" <+> paramname param <+> "value should be a valid cron declaration and not" <+> pretty x + +parseval :: Text -> Integer -> Integer -> Text -> NativeTypeValidate +parseval resval mi ma pname res | "*/" `Text.isPrefixOf` resval = checkint (Text.drop 2 resval) 1 ma pname res + | otherwise = checkint resval mi ma pname res + +checkint :: Text -> Integer -> Integer -> Text -> NativeTypeValidate +checkint st mi ma pname res = + case text2Scientific st of + Just n -> checkint' n mi ma pname res + Nothing -> perror $ "Invalid value type for parameter" <+> paramname pname <+> ": " <+> red (ppline st) + +checkint' :: Scientific -> Integer -> Integer -> Text -> NativeTypeValidate +checkint' i mi ma param res = + if (i >= fromIntegral mi) && (i <= fromIntegral ma) + then Right res + else perror $ "Parameter" <+> paramname param <+> "value is out of bound, should satisfy" <+> pretty mi <+> "<=" <+> pplines (show i) <+> "<=" <+> pretty ma diff --git a/src/Puppet/Language/NativeTypes/Exec.hs b/src/Puppet/Language/NativeTypes/Exec.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Language/NativeTypes/Exec.hs @@ -0,0 +1,38 @@ +module Puppet.Language.NativeTypes.Exec (nativeExec) where + +import qualified Data.Text as Text + +import Puppet.Language.NativeTypes.Helpers + +nativeExec :: (NativeTypeName, NativeTypeMethods) +nativeExec = ("exec", nativetypemethods parameterfunctions fullyQualifiedOrPath) + +-- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them. +parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] +parameterfunctions = + [("command" , [nameval]) + ,("creates" , [rarray, strings, fullyQualifieds]) + ,("cwd" , [string, fullyQualified]) + ,("environment" , [rarray, strings]) + ,("group" , [string]) + ,("logoutput" , [defaultvalue "false", string, values ["true","false","on_failure"]]) + ,("onlyif" , [string]) + ,("path" , [rarray, strings, fullyQualifieds]) + ,("provider" , [string, values ["posix","shell","windows"]]) + ,("refresh" , [string]) + ,("refreshonly" , [defaultvalue "false", string, values ["true","false"]]) + ,("returns" , [defaultvalue "0", rarray, integers]) + ,("timeout" , [defaultvalue "300", integer]) + ,("tries" , [defaultvalue "1", integer]) + ,("try_sleep" , [defaultvalue "0", integer]) + ,("unless" , [string]) + ,("user" , [string]) + ] + +fullyQualifiedOrPath :: NativeTypeValidate +fullyQualifiedOrPath res = + case (res ^. rattributes . at "path", res ^. rattributes . at "command") of + (Nothing, Just (PString x)) -> if Text.head x == '/' + then Right res + else Left "Command must be fully qualified if path is not defined" + _ -> Right res diff --git a/src/Puppet/Language/NativeTypes/File.hs b/src/Puppet/Language/NativeTypes/File.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Language/NativeTypes/File.hs @@ -0,0 +1,108 @@ +module Puppet.Language.NativeTypes.File (nativeFile) where + +import qualified Data.Attoparsec.Text as AT +import qualified Data.Char as Char +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Text as Text + +import Puppet.Language.NativeTypes.Helpers + + +nativeFile :: (NativeTypeName, NativeTypeMethods) +nativeFile = ("file", nativetypemethods parameterfunctions (validateSourceOrContent >=> validateMode)) + + +-- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them. + +parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] +parameterfunctions = + [("backup" , [string]) + ,("checksum" , [values ["md5", "md5lite", "mtime", "ctime", "none"]]) + ,("content" , [string]) + --,("ensure" , [defaultvalue "present", string, values ["directory","file","present","absent","link"]]) + ,("ensure" , [defaultvalue "present", string]) + ,("force" , [string, values ["true","false"]]) + ,("group" , [defaultvalue "root", string]) + ,("ignore" , [strings]) + ,("links" , [string]) + ,("mode" , [defaultvalue "0644", string]) + ,("owner" , [string]) + ,("path" , [nameval, fullyQualified, noTrailingSlash']) + ,("provider" , [values ["posix","windows"]]) + ,("purge" , [string, values ["true","false"]]) + ,("recurse" , [string, values ["inf","true","false","remote"]]) + ,("recurselimit" , [integer]) + ,("replace" , [string, values ["true","false","yes","no"]]) + ,("sourceselect" , [values ["first","all"]]) + ,("seltype" , [string]) + ,("selrange" , [string]) + ,("selinux_ignore_defaults", [string, values ["true","false"]]) + ,("selrole" , [string]) + ,("target" , [string]) + ,("source" , [rarray, strings, flip runarray checkSource]) + ,("seluser" , [string]) + ,("validate_cmd" , [string]) + ,("validate_replacement" , [string]) + ] + +noTrailingSlash' :: Text -> NativeTypeValidate +noTrailingSlash' param res + | res ^? rattributes . ix "ensure" == Just "directory" = Right res + | otherwise = noTrailingSlash param res + +validateMode :: NativeTypeValidate +validateMode res = do + modestr <- case res ^. rattributes . at "mode" of + Just (PString s) -> return s + Just x -> throwError $ PrettyError ("Invalide mode type, should be a string " <+> pretty x) + Nothing -> throwError "Could not find mode!" + (numeric modestr <|> except (ugo modestr)) & runExcept & _Right %~ ($ res) + +numeric :: Text -> Except PrettyError (Resource -> Resource) +numeric modestr = do + when ((Text.length modestr /= 3) && (Text.length modestr /= 4)) (throwError "Invalid mode size") + unless (Text.all Char.isDigit modestr) (throwError "The mode should only be made of digits") + return $ if Text.length modestr == 3 + then rattributes . at "mode" ?~ PString (Text.cons '0' modestr) + else identity + +checkSource :: Text -> PValue -> NativeTypeValidate +checkSource _ (PString x) res | any (`Text.isPrefixOf` x) ["puppet://", "file://", "/"] = Right res + | otherwise = throwError "A source should start with either puppet:// or file:// or an absolute path" +checkSource _ x _ = throwError $ PrettyError ("Expected a string, not" <+> pretty x) + +data PermParts = Special | User | Group | Other + deriving (Eq, Ord) + +data PermSet = R | W | X + deriving (Ord, Eq) + +ugo :: Text -> Either PrettyError (Resource -> Resource) +ugo t = AT.parseOnly (modestring <* AT.endOfInput) t + & _Left %~ (\rr -> PrettyError $ "Could not parse the mode string: " <> ppstring rr) + & _Right %~ (\s -> rattributes . at "mode" ?~ PString (mkmode Special s <> mkmode User s <> mkmode Group s <> mkmode Other s)) + +mkmode :: PermParts -> Map PermParts (Set PermSet) -> Text +mkmode p m = let s = m ^. at p . non mempty + in Text.pack $ show $ fromEnum (Set.member R s) * 4 + + fromEnum (Set.member W s) * 2 + + fromEnum (Set.member X s) + +modestring :: AT.Parser (Map PermParts (Set.Set PermSet)) +modestring = Map.fromList . mconcat <$> (modepart `AT.sepBy` AT.char ',') + +-- TODO suid, sticky and other funky things are not yet supported +modepart :: AT.Parser [(PermParts, Set PermSet)] +modepart = do + let permpart = (AT.char 'u' *> pure [User]) + <|> (AT.char 'g' *> pure [Group]) + <|> (AT.char 'o' *> pure [Other]) + <|> (AT.char 'a' *> pure [User,Group,Other]) + permission = (AT.char 'r' *> pure R) + <|> (AT.char 'w' *> pure W) + <|> (AT.char 'x' *> pure X) + pp <- mconcat <$> some permpart + void $ AT.char '=' + pr <- Set.fromList <$> some permission + return (map (\p -> (p, pr)) pp) diff --git a/src/Puppet/Language/NativeTypes/Group.hs b/src/Puppet/Language/NativeTypes/Group.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Language/NativeTypes/Group.hs @@ -0,0 +1,22 @@ +module Puppet.Language.NativeTypes.Group (nativeGroup) where + +import Puppet.Language.NativeTypes.Helpers + +nativeGroup :: (NativeTypeName, NativeTypeMethods) +nativeGroup = ("group", nativetypemethods parameterfunctions return) + +-- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them. +parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] +parameterfunctions = + [("allowdupe" , [string, defaultvalue "false", values ["true","false"]]) + ,("attribute_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]]) + ,("attributes" , [strings]) + ,("auth_membership" , [defaultvalue "minimum", string, values ["inclusive","minimum"]]) + ,("ensure" , [defaultvalue "present", string, values ["present","absent"]]) + ,("gid" , [integer]) + ,("ia_load_module" , [string]) + ,("members" , [strings]) + ,("name" , [nameval]) + ,("provider" , [string, values ["aix","directoryservice","groupadd","ldap","pw","window_adsi"]]) + ,("system" , [string, defaultvalue "false", values ["true","false"]]) + ] diff --git a/src/Puppet/Language/NativeTypes/Helpers.hs b/src/Puppet/Language/NativeTypes/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Language/NativeTypes/Helpers.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE TemplateHaskell #-} +-- Private modules. +-- Function and data types that are used to define the native types. +module Puppet.Language.NativeTypes.Helpers + ( module Exports + , ipaddr + , nativetypemethods + , NativeTypeName + , NativeTypeValidate + , NativeTypeMethods + , HasNativeTypeMethods(..) + , paramname + , rarray + , string + , strings + , string_s + , noTrailingSlash + , fullyQualified + , fullyQualifieds + , values + , defaultvalue + , concattype + , nameval + , defaultValidate + , parameterFunctions + , integer + , integers + , mandatory + , mandatoryIfNotAbsent + , inrange + , faketype + , defaulttype + , runarray + , perror + , validateSourceOrContent + ) where + +import XPrelude as Exports + +import Data.Aeson.Lens (_Integer, _Number) +import Data.Char (isDigit) +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as HS +import qualified Data.Text as Text +import qualified Data.Vector as V + +import Puppet.Language.Core as Exports +import Puppet.Language.Resource as Exports +import Puppet.Language.Value as Exports +import qualified Text.Read + + +metaparameters :: HS.HashSet Text +metaparameters = HS.fromList ["tag","stage","name","title","alias","audit","check","loglevel","noop","schedule", "EXPORTEDSOURCE", "require", "before", "register", "notify"] + +type NativeTypeName = Text +type NativeTypeValidate = Resource -> Either PrettyError Resource + +-- | Attributes (and providers) of a puppet resource type bundled with validation rules +data NativeTypeMethods = NativeTypeMethods + { _puppetValidate :: NativeTypeValidate + , _puppetFields :: HS.HashSet Text + } + +makeClassy ''NativeTypeMethods + +paramname :: Text -> Doc +paramname = red . ppline + +-- | Useful helper for buiding error messages +perror :: Doc -> Either PrettyError Resource +perror = Left . PrettyError + +-- | Smart constructor for 'NativeTypeMethods'. +nativetypemethods :: [(Text, [Text -> NativeTypeValidate])] -> NativeTypeValidate -> NativeTypeMethods +nativetypemethods def extraV = + let params = fromKeys def + in NativeTypeMethods (defaultValidate params >=> parameterFunctions def >=> extraV) params + where + fromKeys = HS.fromList . map fst + +faketype :: NativeTypeName -> (NativeTypeName, NativeTypeMethods) +faketype tname = (tname, NativeTypeMethods Right HS.empty) + +concattype :: NativeTypeName -> (NativeTypeName, NativeTypeMethods) +concattype tname = (tname, NativeTypeMethods (defaultValidate HS.empty) HS.empty) + +defaulttype :: NativeTypeName -> (NativeTypeName, NativeTypeMethods) +defaulttype tname = (tname, NativeTypeMethods (defaultValidate HS.empty) HS.empty) + +{-| Validate resources given a list of valid parameters: + + * checks that no unknown parameters have been set (except metaparameters) +-} +defaultValidate :: HS.HashSet Text -> NativeTypeValidate +defaultValidate validparameters = checkParameterList validparameters >=> addDefaults + +checkParameterList :: HS.HashSet Text -> NativeTypeValidate +checkParameterList validparameters res | HS.null validparameters = Right res + | otherwise = if HS.null setdiff + then Right res + else perror $ "Unknown parameters: " <+> list (map paramname $ HS.toList setdiff) + where + keyset = HS.fromList $ Map.keys (res ^. rattributes) + setdiff = HS.difference keyset (metaparameters `HS.union` validparameters) + +-- | This validator always accept the resources, but add the default parameters (to be defined :) +addDefaults :: NativeTypeValidate +addDefaults res = Right (res & rattributes %~ newparams) + where + def PUndef = False + def _ = True + newparams p = Map.filter def $ Map.union p defaults + defaults = Map.empty + +-- | Helper function that runs a validor on a 'PArray' +runarray :: Text -> (Text -> PValue -> NativeTypeValidate) -> NativeTypeValidate +runarray param func res = case res ^. rattributes . at param of + Just (PArray x) -> V.foldM (flip (func param)) res x + Just x -> perror $ "Parameter" <+> paramname param <+> "should be an array, not" <+> pretty x + Nothing -> Right res + +{-| This checks that a given parameter is a string. If it is a 'PBoolean' or +'PNumber' it will convert them to a string. +-} +string :: Text -> NativeTypeValidate +string param res = case res ^. rattributes . at param of + Just x -> string' param x res + Nothing -> Right res + +strings :: Text -> NativeTypeValidate +strings param = runarray param string' + +-- | Validates a string or an array of strings +string_s :: Text -> NativeTypeValidate +string_s param res = case res ^. rattributes . at param of + Nothing -> Right res + Just (PArray _) -> strings param res + Just _ -> string param res + +string' :: Text -> PValue -> NativeTypeValidate +string' param rev res = case rev of + PString _ -> Right res + PBoolean True -> Right (res & rattributes . at param ?~ PString "true") + PBoolean False -> Right (res & rattributes . at param ?~ PString "false") + PNumber n -> Right (res & rattributes . at param ?~ PString (scientific2text n)) + x -> perror $ "Parameter" <+> paramname param <+> "should be a string, and not" <+> pretty x + + + +-- | Makes sure that the parameter, if defined, has a value among this list. +values :: [Text] -> Text -> NativeTypeValidate +values valuelist param res = case res ^. rattributes . at param of + Just (PString x) -> if x `elem` valuelist + then Right res + else perror $ "Parameter" <+> paramname param <+> "value should be one of" <+> list (map ppline valuelist) <+> "and not" <+> ppline x + Just x -> perror $ "Parameter" <+> paramname param <+> "value should be one of" <+> list (map ppline valuelist) <+> "and not" <+> pretty x + Nothing -> Right res + +-- | This fills the default values of unset parameters. +defaultvalue :: Text -> Text -> NativeTypeValidate +defaultvalue value param = Right . over (rattributes . at param) (Just . fromMaybe (PString value)) + +-- | Checks that a given parameter, if set, is a 'PNumber'. +-- If it is a 'PString' it will attempt to parse it. +integer :: Text -> NativeTypeValidate +integer prm res = string prm res >>= integer' prm + where + integer' pr rs = case rs ^. rattributes . at pr of + Just x -> integer'' prm x res + Nothing -> Right rs + +integers :: Text -> NativeTypeValidate +integers param = runarray param integer'' + +integer'' :: Text -> PValue -> NativeTypeValidate +integer'' param val res = case val ^? _Integer of + Just v -> Right (res & rattributes . at param ?~ PNumber (fromIntegral v)) + _ -> perror $ "Parameter" <+> paramname param <+> "must be an integer" + +-- | Copies the "name" value into the parameter if this is not set. +-- It implies the `string` validator. +nameval :: Text -> NativeTypeValidate +nameval prm res = + string prm res >>= \r -> + case r ^. rattributes . at prm of + Just (PString al) -> Right (res & rid . iname .~ al) + Just x -> perror ("The alias must be a string, not" <+> pretty x) + Nothing -> Right (r & rattributes . at prm ?~ PString (r ^. rid . iname)) + +-- | Checks that a given parameter is set unless the resources "ensure" is set to absent +mandatoryIfNotAbsent :: Text -> NativeTypeValidate +mandatoryIfNotAbsent param res = + case res ^. rattributes . at param of + Just _ -> Right res + Nothing -> case res ^. rattributes . at "ensure" of + Just "absent" -> Right res + _ -> perror $ "Parameter" <+> paramname param <+> "should be set." + +-- | Checks that a given parameter is set. +mandatory :: Text -> NativeTypeValidate +mandatory param res = case res ^. rattributes . at param of + Just _ -> Right res + Nothing -> perror $ "Parameter" <+> paramname param <+> "should be set." + +-- | Helper that takes a list of stuff and will generate a validator. +parameterFunctions :: [(Text, [Text -> NativeTypeValidate])] -> NativeTypeValidate +parameterFunctions argrules rs = foldM parameterFunctions' rs argrules + where + parameterFunctions' :: Resource -> (Text, [Text -> NativeTypeValidate]) -> Either PrettyError Resource + parameterFunctions' r (param, validationfunctions) = foldM (parameterFunctions'' param) r validationfunctions + parameterFunctions'' :: Text -> Resource -> (Text -> NativeTypeValidate) -> Either PrettyError Resource + parameterFunctions'' param r validationfunction = validationfunction param r + +-- checks that a parameter is fully qualified +fullyQualified :: Text -> NativeTypeValidate +fullyQualified param res = case res ^. rattributes . at param of + Just path -> fullyQualified' param path res + Nothing -> Right res + +noTrailingSlash :: Text -> NativeTypeValidate +noTrailingSlash param res = + case res ^. rattributes . at param of + Just (PString x) -> if Text.last x == '/' + then perror ("Parameter" <+> paramname param <+> "should not have a trailing slash") + else Right res + _ -> Right res + +fullyQualifieds :: Text -> NativeTypeValidate +fullyQualifieds param = runarray param fullyQualified' + +fullyQualified' :: Text -> PValue -> NativeTypeValidate +fullyQualified' param path res = + case path of + PString ("") -> perror $ "Empty path for parameter" <+> paramname param + PString p -> if Text.head p == '/' + then Right res + else perror $ "Path must be absolute, not" <+> ppline p <+> "for parameter" <+> paramname param + x -> perror $ "SHOULD NOT HAPPEN: path is not a resolved string, but" <+> pretty x <+> "for parameter" <+> paramname param + +rarray :: Text -> NativeTypeValidate +rarray param res = case res ^. rattributes . at param of + Just (PArray _) -> Right res + Just x -> Right $ res & rattributes . at param ?~ PArray (V.singleton x) + Nothing -> Right res + +ipaddr :: Text -> NativeTypeValidate +ipaddr param res = + case res ^. rattributes . at param of + Nothing -> Right res + Just (PString ip) -> + if checkipv4 ip 0 + then Right res + else perror $ "Invalid IP address for parameter" <+> paramname param + Just x -> perror $ "Parameter" <+> paramname param <+> "should be an IP address string, not" <+> pretty x + +checkipv4 :: Text -> Int -> Bool +checkipv4 _ 4 = False -- means that there are more than 4 groups +checkipv4 "" _ = False -- should never get an empty string +checkipv4 ip v = + let (cur, nxt) = Text.break (=='.') ip + nextfunc = if Text.null nxt + then v == 3 + else checkipv4 (Text.tail nxt) (v+1) + goodcur = not (Text.null cur) && Text.all isDigit cur && (let rcur = Text.Read.read (Text.unpack cur) :: Int in (rcur >= 0) && (rcur <= 255)) + in goodcur && nextfunc + +inrange :: Integer -> Integer -> Text -> NativeTypeValidate +inrange mi ma param res = + let va = res ^. rattributes . at param + na = va ^? traverse . _Number + in case (va,na) of + (Nothing, _) -> Right res + (_,Just v) -> if (v >= fromIntegral mi) && (v <= fromIntegral ma) + then Right res + else perror $ "Parameter" <+> paramname param <> "'s value should be between" <+> pretty mi <+> "and" <+> pretty ma + (Just x,_) -> perror $ "Parameter" <+> paramname param <+> "should be an integer, and not" <+> pretty x + +validateSourceOrContent :: NativeTypeValidate +validateSourceOrContent res = let + parammap = res ^. rattributes + source = Map.member "source" parammap + content = Map.member "content" parammap + in if source && content + then perror "Source and content can't be specified at the same time" + else Right res diff --git a/src/Puppet/Language/NativeTypes/Host.hs b/src/Puppet/Language/NativeTypes/Host.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Language/NativeTypes/Host.hs @@ -0,0 +1,44 @@ +module Puppet.Language.NativeTypes.Host (nativeHost) where + +import qualified Data.Char as Char +import qualified Data.Text as Text + +import Puppet.Language.NativeTypes.Helpers + +nativeHost :: (NativeTypeName, NativeTypeMethods) +nativeHost = ("host", nativetypemethods parameterfunctions return) + +-- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them. +parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] +parameterfunctions = + [("comment" , [string, values ["true","false"]]) + ,("ensure" , [defaultvalue "present", string, values ["present","absent"]]) + ,("host_aliases" , [rarray, strings, checkhostname]) + ,("ip" , [string, mandatory, ipaddr]) + ,("name" , [nameval, checkhostname]) + ,("provider" , [string, values ["parsed"]]) + ,("target" , [string, fullyQualified]) + ] + +checkhostname :: Text -> NativeTypeValidate +checkhostname param res = case res ^. rattributes . at param of + Nothing -> Right res + Just (PArray xs) -> foldM (checkhostname' param) res xs + Just x@(PString _) -> checkhostname' param res x + Just x -> perror $ paramname param <+> "should be an array or a single string, not" <+> pretty x + +checkhostname' :: Text -> Resource -> PValue -> Either PrettyError Resource +checkhostname' prm _ (PString "") = perror $ "Empty hostname for parameter" <+> paramname prm +checkhostname' prm res (PString x ) = checkhostname'' prm res x +checkhostname' prm _ x = perror $ "Parameter " <+> paramname prm <+> "should be an string or an array of strings, but this was found :" <+> pretty x + +checkhostname'' :: Text -> Resource -> Text -> Either PrettyError Resource +checkhostname'' prm _ "" = perror $ "Empty hostname part in parameter" <+> paramname prm +checkhostname'' prm res prt = + let (cur,nxt) = Text.break (=='.') prt + nextfunc = if Text.null nxt + then Right res + else checkhostname'' prm res (Text.tail nxt) + in if Text.null cur || (Text.head cur == '-') || not (Text.all (\x -> Char.isAlphaNum x || (x=='-')) cur) + then perror $ "Invalid hostname part for parameter" <+> paramname prm + else nextfunc diff --git a/src/Puppet/Language/NativeTypes/Mount.hs b/src/Puppet/Language/NativeTypes/Mount.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Language/NativeTypes/Mount.hs @@ -0,0 +1,22 @@ +module Puppet.Language.NativeTypes.Mount (nativeMount) where + +import Puppet.Language.NativeTypes.Helpers + +nativeMount :: (NativeTypeName, NativeTypeMethods) +nativeMount = ("mount", nativetypemethods parameterfunctions return) + +parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] +parameterfunctions = + [("atboot" , [string, values ["true","false"]]) + ,("blockdevice" , [string]) + ,("device" , [string, mandatoryIfNotAbsent]) + ,("dump" , [integer, inrange 0 2]) + ,("ensure" , [defaultvalue "present", string, values ["present","absent","mounted"]]) + ,("fstype" , [string, mandatoryIfNotAbsent]) + ,("name" , [nameval]) + ,("options" , [string]) + ,("pass" , [defaultvalue "0", integer]) + ,("provider" , [defaultvalue "parsed", string, values ["parsed"]]) + ,("remounts" , [string, values ["true","false"]]) + ,("target" , [string, fullyQualified]) + ] diff --git a/src/Puppet/Language/NativeTypes/Notify.hs b/src/Puppet/Language/NativeTypes/Notify.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Language/NativeTypes/Notify.hs @@ -0,0 +1,12 @@ +module Puppet.Language.NativeTypes.Notify (nativeNotify) where + +import Puppet.Language.NativeTypes.Helpers + +nativeNotify :: (NativeTypeName, NativeTypeMethods) +nativeNotify = ("notify", nativetypemethods parameterfunctions return) + +parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] +parameterfunctions = + [("message" , []) + ,("withpath" , [string, defaultvalue "false", values ["true","false"]]) + ] diff --git a/src/Puppet/Language/NativeTypes/Package.hs b/src/Puppet/Language/NativeTypes/Package.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Language/NativeTypes/Package.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE DeriveGeneric #-} +module Puppet.Language.NativeTypes.Package + ( nativePackage + ) where + +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as Set + +import Puppet.Language.NativeTypes.Helpers + +nativePackage :: (NativeTypeName, NativeTypeMethods) +nativePackage = ("package", nativetypemethods parameterfunctions (getFeature >=> checkFeatures)) + +-- Features are abilities that some providers may not support. +data PackagingFeatures + = Holdable + | InstallOptions + | Installable + | Purgeable + | UninstallOptions + | Uninstallable + | Upgradeable + | Versionable + deriving (Show, Eq, Generic) + +instance Pretty PackagingFeatures where + pretty = ppline . show + +instance Hashable PackagingFeatures + +isFeatureSupported :: HashMap Text (HashSet PackagingFeatures) +isFeatureSupported = HM.fromList [ ("aix", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]) + , ("appdmg", Set.fromList [Installable]) + , ("apple", Set.fromList [Installable]) + , ("apt", Set.fromList [Holdable, InstallOptions, Installable, Purgeable, Uninstallable, Upgradeable, Versionable]) + , ("aptitude", Set.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable]) + , ("aptrpm", Set.fromList [Installable, Purgeable, Uninstallable, Upgradeable, Versionable]) + , ("blastwave", Set.fromList [Installable, Uninstallable, Upgradeable]) + , ("dpkg", Set.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable]) + , ("fink", Set.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable]) + , ("freebsd", Set.fromList [Installable, Uninstallable]) + , ("gem", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]) + , ("hpux", Set.fromList [Installable, Uninstallable]) + , ("macports", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]) + , ("msi", Set.fromList [InstallOptions, Installable, UninstallOptions, Uninstallable]) + , ("nim", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]) + , ("openbsd", Set.fromList [Installable, Uninstallable, Versionable]) + , ("pacman", Set.fromList [Installable, Uninstallable, Upgradeable]) + , ("pip", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]) + , ("pkg", Set.fromList [Holdable, Installable, Uninstallable, Upgradeable, Versionable]) + , ("pkgdmg", Set.fromList [Installable]) + , ("pkgin", Set.fromList [Installable, Uninstallable]) + , ("pkgutil", Set.fromList [Installable, Uninstallable, Upgradeable]) + , ("portage", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]) + , ("ports", Set.fromList [Installable, Uninstallable, Upgradeable]) + , ("portupgrade", Set.fromList [Installable, Uninstallable, Upgradeable]) + , ("rpm", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]) + , ("rug", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]) + , ("sun", Set.fromList [InstallOptions, Installable, Uninstallable, Upgradeable]) + , ("sunfreeware", Set.fromList [Installable, Uninstallable, Upgradeable]) + , ("up2date", Set.fromList [Installable, Uninstallable, Upgradeable]) + , ("urpmi", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]) + , ("windows", Set.fromList [InstallOptions, Installable, UninstallOptions, Uninstallable]) + , ("yum", Set.fromList [Installable, Purgeable, Uninstallable, Upgradeable, Versionable]) + , ("zypper", Set.fromList [Installable, Uninstallable, Upgradeable, Versionable]) + ] + +parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] +parameterfunctions = + [("adminfile" , [string, fullyQualified]) + ,("allowcdrom" , [string, values ["true","false"]]) + ,("configfiles" , [string, values ["keep","replace"]]) + --,("ensure" , [defaultvalue "present", string, values ["present","absent","latest","held","purged","installed"]]) + ,("ensure" , [defaultvalue "present", string]) + ,("flavor" , []) + ,("install_options" , [rarray]) + ,("name" , [nameval]) + ,("provider" , [defaultvalue "apt", string]) + ,("responsefile" , [string, fullyQualified]) + ,("source" , [string]) + ,("uninstall_options", [rarray]) + ] + +getFeature :: Resource -> Either PrettyError (HashSet PackagingFeatures, Resource) +getFeature res = + case res ^. rattributes . at "provider" of + Just (PString x) -> + case HM.lookup x isFeatureSupported of + Just s -> Right (s, res) + Nothing -> Left $ PrettyError ("Do not know provider" <+> ppline x) + _ -> Left "Can't happen at Puppet.NativeTypes.Package" + +checkFeatures :: (HashSet PackagingFeatures, Resource) -> Either PrettyError Resource +checkFeatures = + checkAdminFile + >=> checkEnsure + >=> checkParam "install_options" InstallOptions + >=> checkParam "uninstall_options" UninstallOptions + >=> decap + where + checkFeature :: HashSet PackagingFeatures -> Resource -> PackagingFeatures -> Either PrettyError (HashSet PackagingFeatures, Resource) + checkFeature s r f = if Set.member f s + then Right (s, r) + else Left $ PrettyError ("Feature" <+> pretty f <+> "is required for the current configuration") + checkParam :: Text -> PackagingFeatures -> (HashSet PackagingFeatures, Resource) -> Either PrettyError (HashSet PackagingFeatures, Resource) + checkParam pn f (s,r) = if has (ix pn) (r ^. rattributes) + then checkFeature s r f + else Right (s,r) + checkAdminFile :: (HashSet PackagingFeatures, Resource) -> Either PrettyError (HashSet PackagingFeatures, Resource) + checkAdminFile = Right -- TODO, check that it only works for aix + checkEnsure :: (HashSet PackagingFeatures, Resource) -> Either PrettyError (HashSet PackagingFeatures, Resource) + checkEnsure (s, res) = case res ^. rattributes . at "ensure" of + Just (PString "latest") -> checkFeature s res Installable + Just (PString "purged") -> checkFeature s res Purgeable + Just (PString "absent") -> checkFeature s res Uninstallable + Just (PString "installed") -> checkFeature s res Installable + Just (PString "present") -> checkFeature s res Installable + Just (PString "held") -> checkFeature s res Installable >> checkFeature s res Holdable + _ -> checkFeature s res Versionable + decap :: (HashSet PackagingFeatures, Resource) -> Either PrettyError Resource + decap = Right . snd diff --git a/src/Puppet/Language/NativeTypes/SshSecure.hs b/src/Puppet/Language/NativeTypes/SshSecure.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Language/NativeTypes/SshSecure.hs @@ -0,0 +1,33 @@ +module Puppet.Language.NativeTypes.SshSecure + ( nativeSshSecure + ) where + +import Puppet.Language.NativeTypes.Helpers + +nativeSshSecure :: (NativeTypeName, NativeTypeMethods) +nativeSshSecure = ("ssh_authorized_key_secure", nativetypemethods parameterfunctions (userOrTarget >=> keyIfPresent)) + +-- Autorequires: If Puppet is managing the user or user that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them. +parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] +parameterfunctions = + [ ("type", [string, defaultvalue "ssh-rsa", values ["rsa", "dsa", "ssh-rsa", "ssh-dss"]]) + , ("key", [string]) + , ("user", [string]) + , ("ensure", [defaultvalue "present", string, values ["present", "absent", "role"]]) + , ("target", [string]) + , ("options", [rarray, strings]) + ] + +userOrTarget :: NativeTypeValidate +userOrTarget res = + case (res ^. rattributes & has (ix "user"), res ^. rattributes & has (ix "target")) of + (False, False) -> Left "Parameters user or target are mandatory" + _ -> Right res + + +keyIfPresent :: NativeTypeValidate +keyIfPresent res = + case (res ^. rattributes . at "key", res ^. rattributes . at "ensure") of + (Just _, Just "present") -> Right res + (_, Just "absent") -> Right res + _ -> Left "Parameter key is mandatory when the resource is present" diff --git a/src/Puppet/Language/NativeTypes/User.hs b/src/Puppet/Language/NativeTypes/User.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Language/NativeTypes/User.hs @@ -0,0 +1,43 @@ +module Puppet.Language.NativeTypes.User (nativeUser) where + +import Puppet.Language.NativeTypes.Helpers + +nativeUser :: (NativeTypeName, NativeTypeMethods) +nativeUser = ("user", nativetypemethods parameterfunctions return) + +-- Autorequires: If Puppet is managing the user or user that owns a file, the file resource will autorequire them. +-- If Puppet is managing any parent directories of a file, the file resource will autorequire them. +parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] +parameterfunctions = + [("allowdupe" , [string, defaultvalue "false", values ["true","false"]]) + ,("attribute_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]]) + ,("attributes" , [rarray,strings]) + ,("auth_membership" , [defaultvalue "minimum", string, values ["inclusive","minimum"]]) + ,("auths" , [rarray,strings]) + ,("comment" , [string]) + ,("ensure" , [defaultvalue "present", string, values ["present","absent","role"]]) + ,("expiry" , [string]) + ,("gid" , [string]) + ,("groups" , [rarray,strings]) + ,("home" , [string, fullyQualified, noTrailingSlash]) + ,("ia_load_module" , [string]) + ,("iterations" , [integer]) + ,("key_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]]) + ,("keys" , []) + ,("managehome" , [string, defaultvalue "false", values ["true","false"]]) + ,("membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]]) + ,("name" , [nameval]) + ,("password" , [string]) + ,("password_max_age" , [integer]) + ,("password_min_age" , [integer]) + ,("profile_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]]) + ,("profiles" , [rarray,strings]) + ,("project" , [string]) + ,("provider" , [string, values ["aix","directoryservice","hpuxuseradd","useradd","ldap","pw","user_role_add","window_adsi"]]) + ,("role_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]]) + ,("roles" , [rarray,strings]) + ,("salt" , [string]) + ,("shell" , [string, fullyQualified, noTrailingSlash]) + ,("system" , [string, defaultvalue "false", values ["true","false"]]) + ,("uid" , [integer]) + ] diff --git a/src/Puppet/Language/NativeTypes/ZoneRecord.hs b/src/Puppet/Language/NativeTypes/ZoneRecord.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Language/NativeTypes/ZoneRecord.hs @@ -0,0 +1,38 @@ +module Puppet.Language.NativeTypes.ZoneRecord (nativeZoneRecord) where + +import Puppet.Language.NativeTypes.Helpers + + +nativeZoneRecord :: (NativeTypeName, NativeTypeMethods) +nativeZoneRecord = ("zone_record", nativetypemethods parameterfunctions validateMandatories) + +-- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. +-- If Puppet is managing any parent directories of a file, the file resource will autorequire them. +parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] +parameterfunctions = + [("name" , [nameval]) + ,("owner" , [string]) + ,("dest" , [string]) + ,("ensure" , [defaultvalue "present", string, values ["present","absent"]]) + ,("rtype" , [string, defaultvalue "A", values ["SOA", "A", "AAAA", "MX", "NS", "CNAME", "PTR", "SRV"]]) + ,("rclass" , [defaultvalue "IN", string]) + ,("ttl" , [defaultvalue "2d", string]) + ,("target" , [string, mandatory]) + ,("nsname" , [string]) + ,("serial" , [string]) + ,("slave_refresh" , [string]) + ,("slave_retry" , [string]) + ,("slave_expiration" , [string]) + ,("min_ttl" , [string]) + ,("email" , [string]) + ] + +validateMandatories :: NativeTypeValidate +validateMandatories res = + case res ^. rattributes . at "rtype" of + Nothing -> perror "The rtype parameter is mandatory." + Just (PString "SOA") -> + foldM (flip mandatory) res ["nsname", "email", "serial", "slave_refresh", "slave_retry", "slave_expiration", "min_ttl"] + Just (PString "NS") -> foldM (flip mandatory) res ["owner", "rclass", "rtype", "dest"] + Just (PString _) -> foldM (flip mandatory) res ["owner", "rclass", "rtype", "dest", "ttl"] + Just x -> perror $ "Can't use this for the rtype parameter" <+> pretty x diff --git a/src/Puppet/Language/Paths.hs b/src/Puppet/Language/Paths.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Language/Paths.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TemplateHaskell #-} +module Puppet.Language.Paths where + +import XPrelude + +data PuppetDirPaths = PuppetDirPaths + { _baseDir :: FilePath -- ^ Puppet base working directory + , _manifestPath :: FilePath -- ^ The path to the manifests. + , _modulesPath :: FilePath -- ^ The path to the modules. + , _templatesPath :: FilePath -- ^ The path to the template. + , _testPath :: FilePath -- ^ The path to a tests folders to hold tests files such as the pdbfiles. + } + +makeClassy ''PuppetDirPaths + +puppetPaths :: FilePath -> PuppetDirPaths +puppetPaths basedir = PuppetDirPaths basedir manifestdir modulesdir templatedir testdir + where + manifestdir = basedir <> "/manifests" + modulesdir = basedir <> "/modules" + templatedir = basedir <> "/templates" + testdir = basedir <> "/tests" diff --git a/src/Puppet/Language/Resource.hs b/src/Puppet/Language/Resource.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Language/Resource.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} + +module Puppet.Language.Resource + ( Resource(..) + , HasResource(..) + , RIdentifier(..) + , HasRIdentifier(..) + , LinkInformation(..) + , HasLinkInformation(..) + , LinkType(..) + , Virtuality(..) + , CurContainerDesc(..) + , FinalCatalog + , EdgeMap + ) where + +import XPrelude + +import Data.Aeson +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as Set +import qualified Data.Text as Text +import qualified Data.Vector as Vector +import qualified GHC.Exts as Exts +import qualified Text.Megaparsec.Pos as Pos + +import Puppet.Language.Core +import Puppet.Language.Value + + +rel2text :: LinkType -> Text +rel2text RNotify = "notify" +rel2text RRequire = "require" +rel2text RBefore = "before" +rel2text RSubscribe = "subscribe" + +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 realized in the catalog. + deriving (Eq, Show) + +data CurContainerDesc + = ContRoot -- ^ Contained at node or root level. + | ContClass !Text -- ^ Contained in a class. + | ContDefine !Text + !Text + !PPosition -- ^ Contained in a define, along with the position where this define was ... defined + | 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, Show) + +instance Pretty CurContainerDesc where + pretty (ContImport p x) = magenta "import" <> braces (ppline p) <> braces (pretty x) + pretty (ContImported x) = magenta "imported" <> braces (pretty x) + pretty ContRoot = dullyellow "::" + pretty (ContClass cname) = dullyellow "class" <+> dullgreen (ppline cname) + pretty (ContDefine dtype dname _) = pretty (PResourceReference dtype dname) + +-- | Relationship/ordering between resources. +data LinkType + = RRequire -- ^ Applies a resource after the target resource. + | RBefore -- ^ Applies a resource before the target resource. + | RNotify -- ^ Applies a resource before the target resource. The target resource refreshes if the notifying resource changes. + | RSubscribe -- ^ Applies a resource after the target resource. The subscribing resource refreshes if the target resource changes. + deriving (Show, Eq, Generic) + +instance Hashable LinkType + +instance FromJSON LinkType where + parseJSON (String "require") = return RRequire + parseJSON (String "notify") = return RNotify + parseJSON (String "subscribe") = return RSubscribe + parseJSON (String "before") = return RBefore + parseJSON _ = panic "invalid linktype" + +instance ToJSON LinkType where + toJSON = String . rel2text + +instance Pretty LinkType where + pretty RNotify = "~>" + pretty RRequire = "<-" + pretty RBefore = "->" + pretty RSubscribe = "<~" + +-- | In Puppet, a resource is identified by a name and a type. +data RIdentifier = RIdentifier + { _itype :: !Text + , _iname :: !Text + } deriving (Show, Eq, Generic, Ord) + +instance Pretty RIdentifier where + pretty (RIdentifier t n) = pretty (PResourceReference t n) + +instance FromJSON RIdentifier where + parseJSON (Object v) = RIdentifier <$> v .: "type" <*> v .: "title" + parseJSON _ = fail "invalid resource" + +instance ToJSON RIdentifier where + toJSON (RIdentifier t n) = object [("type", String t), ("title", String n)] + +instance Hashable RIdentifier + +-- | A fully resolved puppet resource that will be used in the 'FinalCatalog'. +data Resource = Resource + { _rid :: !RIdentifier -- ^ Resource name. + , _ralias :: !(HashSet Text) -- ^ All the resource aliases + , _rattributes :: !(Container PValue) -- ^ Resource parameters. + , _rrelations :: !(HashMap RIdentifier (HashSet LinkType)) -- ^ Resource relations. + , _rscope :: ![CurContainerDesc] -- ^ Resource scope when it was defined, the real container will be the first item + , _rvirtuality :: !Virtuality -- ^ Virtuality. + , _rtags :: !(HashSet Text) -- ^ Tags. + , _rpos :: !PPosition -- ^ Source code position of the resource definition. + , _rnode :: !NodeName -- ^ The node were this resource was created, if remote + } deriving (Eq, Show) + +makeClassy ''Resource +makeClassy ''RIdentifier + +resourceRelations :: Resource -> [(RIdentifier, LinkType)] +resourceRelations = concatMap expandSet . Map.toList . view rrelations + where + expandSet (ri, lts) = [(ri, lt) | lt <- Set.toList lts] + +meta :: Resource -> Doc +meta r = showPPos (r ^. rpos) <+> green (node <+> brackets scp) + where + node = red (ppline (r ^. rnode)) + scp = "Scope" <+> pretty (r ^.. rscope . folded . filtered (/=ContRoot) . to pretty) + +resourceBody :: Resource -> Doc +resourceBody r = + virtuality <> blue (ppline (r ^. rid . iname)) <> ":" <+> meta r <> line <> containerComma'' insde <> ";" + where + virtuality = case r ^. rvirtuality of + Normal -> mempty + Virtual -> dullred "@" + Exported -> dullred "@@" + ExportedRealized -> dullred "<@@>" + insde = alignlst dullblue attriblist1 ++ alignlst dullmagenta attriblist2 + alignlst col = map (first (fill maxalign . col . ppline)) + attriblist1 = Exts.sortWith fst $ Map.toList (r ^. rattributes) ++ aliasdiff + aliasWithoutTitle = r ^. ralias & contains (r ^. rid . iname) .~ False + aliasPValue = aliasWithoutTitle & PArray . Vector.fromList . map PString . Set.toList + aliasdiff | Set.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) + maxalign' [] = 0 + maxalign' x = maximum . map (Text.length . fst) $ x + +instance Pretty Resource where + prettyList lst = + let grouped = Map.toList $ Map.fromListWith (++) [ (r ^. rid . itype, [r]) | r <- lst ] :: [ (Text, [Resource]) ] + sorted = Exts.sortWith fst (map (second (Exts.sortWith (view (rid.iname)))) grouped) + showGroup :: (Text, [Resource]) -> Doc + showGroup (rt, res) = dullyellow (ppline rt) <+> lbrace <> line <> indent 2 (vcat (map resourceBody res)) <> line <> rbrace + in vcat (map showGroup sorted) + pretty r = dullyellow (ppline (r ^. rid . itype)) <+> lbrace <> line <> indent 2 (resourceBody r) <> line <> rbrace + + +instance ToJSON Resource where + toJSON r = + object [ ("type", String $ r ^. rid . itype) + , ("title", String $ r ^. rid . iname) + , ("aliases", toJSON $ r ^. ralias) + , ("exported", Bool $ r ^. rvirtuality == Exported) + , ("tags", toJSON $ r ^. rtags) + , ("parameters", Object ( fmap toJSON (r ^. rattributes) `Map.union` relations )) + , ("sourceline", r ^. rpos . _1 . _sourceLine . to (toJSON . Pos.unPos)) + , ("sourcefile", r ^. rpos . _1 . _sourceName . to toJSON) + ] + where + relations = r ^. rrelations & Map.fromListWith (Vector.++) . concatMap changeRelations . Map.toList & fmap toValue + toValue v | Vector.length v == 1 = Vector.head v + | otherwise = Array v + changeRelations :: (RIdentifier, HashSet LinkType) -> [(Text, Vector Value)] + changeRelations (k,v) = do + c <- Set.toList v + return (rel2text c, Vector.singleton (String (rid2text k))) + rid2text :: RIdentifier -> Text + rid2text (RIdentifier t n) = capitalizeRT t `Text.append` "[" `Text.append` capn `Text.append` "]" + where + capn = if t == "classe" + then capitalizeRT n + else n + +instance FromJSON Resource where + parseJSON (Object v) = do + isExported <- v .: "exported" + let virtuality = if isExported + then Exported + else Normal + getResourceIdentifier :: PValue -> Maybe RIdentifier + getResourceIdentifier (PString x) = + let (restype, brckts) = Text.breakOn "[" x + rna | Text.null brckts = Nothing + | Text.null restype = Nothing + | Text.last brckts == ']' = Just (Text.tail (Text.init brckts)) + | otherwise = Nothing + in case rna of + Just resname -> Just (RIdentifier (Text.toLower restype) (Text.toLower resname)) + _ -> Nothing + getResourceIdentifier _ = Nothing + -- TODO : properly handle metaparameters + separate :: (Container PValue, HashMap RIdentifier (HashSet LinkType)) -> Text -> PValue -> (Container PValue, HashMap RIdentifier (HashSet LinkType)) + 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) <- Map.foldlWithKey' separate (mempty,mempty) <$> v .: "parameters" + contimport <- v .:? "certname" .!= "unknown" + Resource <$> (RIdentifier <$> fmap Text.toLower (v .: "type") <*> v .: "title") + <*> v .:? "aliases" .!= mempty + <*> pure attribs + <*> pure relations + <*> pure [ContImport contimport ContRoot] + <*> pure virtuality + <*> v .: "tags" + <*> (toPPos <$> v .:? "sourcefile" .!= "null" <*> v .:? "sourceline" .!= 1) + <*> pure contimport + + parseJSON _ = mempty + +type FinalCatalog = HashMap RIdentifier Resource + +-- | Relationship/ordering information between two resources (used in the 'EdgeMap'). +data LinkInformation = LinkInformation + { _linksrc :: !RIdentifier + , _linkdst :: !RIdentifier + , _linkType :: !LinkType + , _linkPos :: !PPosition + } deriving (Show) + +makeClassy ''LinkInformation + +type EdgeMap = HashMap RIdentifier [LinkInformation] diff --git a/src/Puppet/Language/Value.hs b/src/Puppet/Language/Value.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Language/Value.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +module Puppet.Language.Value + +where + +import XPrelude + +import Data.Aeson +import Data.Aeson.Lens +import Data.Aeson.TH +import Foreign.Ruby.Helpers + +import Puppet.Language.Core + +data DataType + = DTType + | DTString (Maybe Int) (Maybe Int) + | DTInteger (Maybe Int) (Maybe Int) + | DTFloat (Maybe Double) (Maybe Double) + | DTBoolean + | DTArray DataType Int (Maybe Int) + | DTHash DataType DataType Int (Maybe Int) + | DTUndef + | DTScalar + | DTData + | DTOptional DataType + | NotUndef + | DTVariant (NonEmpty DataType) + | DTPattern (NonEmpty CompRegex) + | DTEnum (NonEmpty Text) + | DTAny + | DTCollection + deriving (Show, Eq) + +instance Pretty DataType where + pretty t = case t of + DTType -> "Type" + DTString ma mb -> bounded "String" ma mb + DTInteger ma mb -> bounded "Integer" ma mb + DTFloat ma mb -> bounded "Float" ma mb + DTBoolean -> "Boolean" + DTArray dt mi mmx -> "Array" <> list (pretty dt : pretty mi : maybe [] (pure . pretty) mmx) + DTHash kt dt mi mmx -> "Hash" <> list (pretty kt : pretty dt : pretty mi : maybe [] (pure . pretty) mmx) + DTUndef -> "Undef" + DTScalar -> "Scalar" + DTData -> "Data" + DTOptional o -> "Optional" <> brackets (pretty o) + NotUndef -> "NotUndef" + DTVariant vs -> "Variant" <> list (foldMap (pure . pretty) vs) + DTPattern vs -> "Pattern" <> list (foldMap (pure . pretty) vs) + DTEnum tx -> "Enum" <> list (foldMap (pure . ppline) tx) + DTAny -> "Any" + DTCollection -> "Collection" + where + bounded :: (Pretty a, Pretty b) => Doc -> Maybe a -> Maybe b -> Doc + bounded s ma mb = s <> case (ma, mb) of + (Just a, Nothing) -> list [pretty a] + (Just a, Just b) -> list [pretty a, pretty b] + _ -> mempty + +$(deriveJSON defaultOptions ''DataType) + +-- | A puppet value. +data PValue + = PBoolean !Bool + | PUndef + | PString !Text + | PResourceReference !Text !Text + | PArray !(Vector PValue) + | PHash !(Container PValue) + | PNumber !Scientific + | PType DataType + deriving (Eq, Show) + +makePrisms ''PValue + +instance Pretty PValue where + pretty (PBoolean True) = dullmagenta $ "true" + pretty (PBoolean False) = dullmagenta $ "false" + pretty (PString s) = dullcyan (ppline (stringEscape s)) + pretty (PNumber n) = cyan (ppline (scientific2text n)) + pretty PUndef = dullmagenta "undef" + pretty (PResourceReference t n) = capitalizeR t <> brackets (ppline n) + pretty (PArray v) = list (map pretty (toList v)) + pretty (PHash g) = containerComma g + pretty (PType dt) = pretty dt + +instance IsString PValue where + fromString = PString . toS + +instance Pretty (HashMap Text PValue) where + pretty = containerComma + +instance AsNumber PValue where + _Number = prism num2PValue toNumber + where + num2PValue :: Scientific -> PValue + num2PValue = PNumber + toNumber :: PValue -> Either PValue Scientific + toNumber (PNumber n) = Right n + toNumber p@(PString x) = case text2Scientific x of + Just o -> Right o + _ -> Left p + toNumber p = Left p + +instance FromJSON PValue where + parseJSON Null = return PUndef + parseJSON (Number n) = return $ PNumber n + parseJSON (String s) = return (PString s) + parseJSON (Bool b) = return (PBoolean b) + parseJSON (Array v) = fmap PArray (mapM parseJSON v) + parseJSON (Object o) = fmap PHash (mapM parseJSON o) + +instance ToJSON PValue where + toJSON (PType t) = toJSON t + toJSON (PBoolean b) = Bool b + toJSON PUndef = Null + toJSON (PString s) = String s + toJSON (PResourceReference _ _) = Null -- TODO + toJSON (PArray r) = Array (fmap toJSON r) + toJSON (PHash x) = Object (fmap toJSON x) + toJSON (PNumber n) = Number n + +instance ToRuby PValue where + toRuby = toRuby . toJSON +instance FromRuby PValue where + fromRuby = fmap chk . fromRuby + where + chk (Left x) = Left x + chk (Right x) = case fromJSON x of + Error rr -> Left rr + Success suc -> Right suc diff --git a/src/Puppet/Language/WireCatalog.hs b/src/Puppet/Language/WireCatalog.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Language/WireCatalog.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE TemplateHaskell #-} +module Puppet.Language.WireCatalog + +where + +import XPrelude + +import Data.Aeson + +import Puppet.Language.Core +import Puppet.Language.Resource + +-- | Used to represent a relationship between two resources within the wired format (json). +-- +-- See +data PuppetEdge = PuppetEdge RIdentifier RIdentifier LinkType deriving Show + +instance FromJSON PuppetEdge where + parseJSON (Object v) = PuppetEdge <$> v .: "source" <*> v .: "target" <*> v .: "relationship" + parseJSON _ = fail "invalid puppet edge" + +instance ToJSON PuppetEdge where + toJSON (PuppetEdge s t r) = object [("source", toJSON s), ("target", toJSON t), ("relationship", toJSON r)] + +-- | See . +data WireCatalog = WireCatalog + { _wireCatalogNodename :: !NodeName + , _wireCatalogVersion :: !Text + , _wireCatalogEdges :: !(Vector PuppetEdge) + , _wireCatalogResources :: !(Vector Resource) + , _wireCatalogTransactionUUID :: !Text +} deriving Show + +makeClassy ''WireCatalog + +instance FromJSON WireCatalog where + parseJSON (Object d) = d .: "data" >>= \case + (Object v) -> WireCatalog + <$> v .: "name" + <*> v .: "version" + <*> v .: "edges" + <*> v .: "resources" + <*> v .: "transaction-uuid" + _ -> fail "Data is not an object" + parseJSON _ = fail "invalid wire catalog" + +instance ToJSON WireCatalog where + toJSON (WireCatalog n v e r t) = object [("metadata", object [("api_version", Number 1)]), ("data", object d)] + where d = [ ("name", String n) + , ("version", String v) + , ("edges", toJSON e) + , ("resources", toJSON r) + , ("transaction-uuid", String t) + ] diff --git a/src/Puppet/Lens.hs b/src/Puppet/Lens.hs deleted file mode 100644 --- a/src/Puppet/Lens.hs +++ /dev/null @@ -1,178 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} -module Puppet.Lens - ( -- * Pure resolution prisms - _PResolveExpression - , _PResolveValue - -- * Prisms for PValues (reexport from "Puppet.Interpreter.Types") - , _PHash - , _PBoolean - , _PString - , _PNumber - , _PResourceReference - , _PUndef - , _PArray - -- * Lenses and prims for 'Statement's - , _Statements - , _ResDecl - , _ResDefaultDecl - , _ResOverrDecl - , _ResCollDecl - , _ConditionalDecl - , _ClassDecl - , _DefineDecl - , _NodeDecl - , _VarAssignDecl - , _MainFuncDecl - , _HigherOrderLambdaDecl - , _DepDecl - -- * Prim for 'Expression's - , _Equal - , _Different - , _Not - , _And - , _Or - , _LessThan - , _MoreThan - , _LessEqualThan - , _MoreEqualThan - , _RegexMatch - , _NotRegexMatch - , _Contains - , _Addition - , _Substraction - , _Division - , _Multiplication - , _Modulo - , _RightShift - , _LeftShift - , _Lookup - , _Negate - , _ConditionalValue - , _FunctionApplication - , _Terminal - -- * Prisms for exceptions - , _PrettyError - ) where - -import Puppet.Prelude - -import qualified Data.HashMap.Strict as HM -import qualified Data.List as List -import qualified Data.Vector as V -import Text.Megaparsec (parse) -import Text.PrettyPrint.ANSI.Leijen (pretty) - -import Puppet.Interpreter.Pure -import Puppet.Interpreter.Resolve -import Puppet.Interpreter.Types -import Puppet.Parser (puppetParser) -import qualified Puppet.Parser.PrettyPrinter () -import Puppet.Parser.Types - -makePrisms ''Expression - -_PuppetParser :: Prism' Text (V.Vector Statement) -_PuppetParser = prism' (toS . List.unlines . V.toList . fmap (show . pretty)) $ \t -> case parse puppetParser "dummy" t of - Left _ -> Nothing - Right r -> Just r - -_PrettyError :: Prism' SomeException PrettyError -_PrettyError = prism' toException fromException - -_ResDecl :: Prism' Statement ResDecl -_ResDecl = prism ResourceDeclaration $ \x -> case x of - ResourceDeclaration a -> Right a - _ -> Left x -_ResDefaultDecl :: Prism' Statement ResDefaultDecl -_ResDefaultDecl = prism ResourceDefaultDeclaration $ \x -> case x of - ResourceDefaultDeclaration a -> Right a - _ -> Left x -_ResOverrDecl :: Prism' Statement ResOverrideDecl -_ResOverrDecl = prism ResourceOverrideDeclaration $ \x -> case x of - ResourceOverrideDeclaration a -> Right a - _ -> Left x -_ResCollDecl :: Prism' Statement ResCollDecl -_ResCollDecl = prism ResourceCollectionDeclaration $ \x -> case x of - ResourceCollectionDeclaration a -> Right a - _ -> Left x -_ConditionalDecl :: Prism' Statement ConditionalDecl -_ConditionalDecl = prism ConditionalDeclaration $ \x -> case x of - ConditionalDeclaration a -> Right a - _ -> Left x -_ClassDecl :: Prism' Statement ClassDecl -_ClassDecl = prism ClassDeclaration $ \x -> case x of - ClassDeclaration a -> Right a - _ -> Left x -_DefineDecl :: Prism' Statement DefineDecl -_DefineDecl = prism DefineDeclaration $ \x -> case x of - DefineDeclaration a -> Right a - _ -> Left x -_NodeDecl :: Prism' Statement NodeDecl -_NodeDecl = prism NodeDeclaration $ \x -> case x of - NodeDeclaration a -> Right a - _ -> Left x - -_VarAssignDecl :: Prism' Statement VarAssignDecl -_VarAssignDecl = prism VarAssignmentDeclaration $ \x -> case x of - VarAssignmentDeclaration a -> Right a - _ -> Left x -_MainFuncDecl :: Prism' Statement MainFuncDecl -_MainFuncDecl = prism MainFunctionDeclaration $ \x -> case x of - MainFunctionDeclaration a -> Right a - _ -> Left x -_HigherOrderLambdaDecl :: Prism' Statement HigherOrderLambdaDecl -_HigherOrderLambdaDecl = prism HigherOrderLambdaDeclaration $ \x -> case x of - HigherOrderLambdaDeclaration a -> Right a - _ -> Left x -_DepDecl :: Prism' Statement DepDecl -_DepDecl = prism DependencyDeclaration $ \x -> case x of - DependencyDeclaration a -> Right a - _ -> Left x - -_TopContainer :: Prism' Statement (V.Vector Statement, Statement) -_TopContainer = prism (uncurry TopContainer) $ \x -> case x of - TopContainer vs s -> Right (vs,s) - _ -> Left x - --- | Incomplete -_PResolveExpression :: Prism' Expression PValue -_PResolveExpression = prism reinject extract - where - extract e = case dummyEval (resolveExpression e) of - Right x -> Right x - Left _ -> Left e - reinject = Terminal . review _PResolveValue - -_PResolveValue :: Prism' UnresolvedValue PValue -_PResolveValue = prism toU toP - where - toP uv = case dummyEval (resolveValue uv) of - Right x -> Right x - Left _ -> Left uv - toU (PBoolean x) = UBoolean x - toU (PNumber x) = UNumber x - toU PUndef = UUndef - toU (PString s) = UString s - toU (PResourceReference t n) = UResourceReference t (Terminal (UString n)) - toU (PArray r) = UArray (fmap (Terminal . toU) r) - toU (PHash h) = UHash (V.fromList $ map (\(k,v) -> (Terminal (UString k) :!: Terminal (toU v))) $ HM.toList h) - toU (PType _) = panic "TODO, _PResolveValue PType undefined" - -_Statements :: Lens' Statement [Statement] -_Statements = lens (V.toList . sget) (\s v -> sset s (V.fromList v)) - where - sget :: Statement -> V.Vector Statement - sget (ClassDeclaration (ClassDecl _ _ _ s _)) = s - sget (DefineDeclaration (DefineDecl _ _ s _)) = s - sget (NodeDeclaration (NodeDecl _ s _ _)) = s - sget (TopContainer s _) = s - sget (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall _ _ _ s _) _)) = s - sget _ = V.empty - sset :: Statement -> V.Vector Statement -> Statement - sset (ClassDeclaration (ClassDecl n args inh _ p)) s = ClassDeclaration (ClassDecl n args inh s p) - sset (NodeDeclaration (NodeDecl ns _ nd' p)) s = NodeDeclaration (NodeDecl ns s nd' p) - sset (DefineDeclaration (DefineDecl n args _ p)) s = DefineDeclaration (DefineDecl n args s p) - sset (TopContainer _ p) s = TopContainer s p - sset (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall t e pr _ e2) p)) s = HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall t e pr s e2) p) - sset x _ = x diff --git a/src/Puppet/Manifests.hs b/src/Puppet/Manifests.hs deleted file mode 100644 --- a/src/Puppet/Manifests.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -module Puppet.Manifests (filterStatements) where - -import Puppet.Prelude - -import qualified Data.Either.Strict as S -import qualified Data.HashMap.Strict as HM -import qualified Data.Text.Encoding as Text -import qualified Data.Vector as V -import Text.Regex.PCRE.ByteString.Utils - -import Puppet.Interpreter.Types -import Puppet.Parser.Types -import Puppet.PP - --- TODO pre-triage stuff -filterStatements :: TopLevelType -> Text -> V.Vector Statement -> IO (S.Either PrettyError Statement) --- the most complicated case, node matching -filterStatements TopNode ndename stmts = - -- this operation should probably get cached - let (!spurious, !directnodes, !regexpmatches, !defaultnode) = V.foldl' triage (V.empty, HM.empty, V.empty, Nothing) stmts - triage curstuff n@(NodeDeclaration (NodeDecl (NodeName !nm) _ _ _)) = curstuff & _2 . at nm ?~ n - triage curstuff n@(NodeDeclaration (NodeDecl (NodeMatch (CompRegex _ !rg)) _ _ _)) = curstuff & _3 %~ (|> (rg :!: n)) - triage curstuff n@(NodeDeclaration (NodeDecl NodeDefault _ _ _)) = curstuff & _4 ?~ n - triage curstuff x = curstuff & _1 %~ (|> x) - bsnodename = Text.encodeUtf8 ndename - checkRegexp :: [Pair Regex Statement] -> ExceptT PrettyError IO (Maybe Statement) - checkRegexp [] = return Nothing - checkRegexp ((regexp :!: s):xs) = - case execute' regexp bsnodename of - Left rr -> throwError (PrettyError ("Regexp match error:" <+> text (show rr))) - Right Nothing -> checkRegexp xs - Right (Just _) -> return (Just s) - strictEither (Left x) = S.Left x - strictEither (Right x) = S.Right x - 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 $ runExceptT $ 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 (PrettyError ("Couldn't find node" <+> ttext ndename)) -filterStatements x ndename stmts = - let (!spurious, !defines, !classes) = V.foldl' triage (V.empty, HM.empty, HM.empty) stmts - triage curstuff n@(ClassDeclaration (ClassDecl cname _ _ _ _)) = curstuff & _3 . at cname ?~ n - triage curstuff n@(DefineDeclaration (DefineDecl cname _ _ _)) = curstuff & _2 . at cname ?~ n - triage curstuff n = curstuff & _1 %~ (|> n) - tc n = if V.null spurious - then n - else TopContainer spurious n - in case x of - TopNode -> return (S.Left "Case already covered, shoudln't happen in Puppet.Manifests") - TopDefine -> case defines ^. at ndename of - Just n -> return (S.Right (tc n)) - Nothing -> return (S.Left (PrettyError ("Couldn't find define " <+> ttext ndename))) - TopClass -> case classes ^. at ndename of - Just n -> return (S.Right (tc n)) - Nothing -> return (S.Left (PrettyError ("Couldn't find class " <+> ttext ndename))) diff --git a/src/Puppet/NativeTypes.hs b/src/Puppet/NativeTypes.hs deleted file mode 100644 --- a/src/Puppet/NativeTypes.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-| This module holds the /native/ Puppet resource types. -} -module Puppet.NativeTypes ( - baseNativeTypes - , validateNativeType -) where - -import Puppet.Prelude - -import Control.Monad.Operational -import qualified Data.HashMap.Strict as HM - -import Puppet.Interpreter.Types -import Puppet.NativeTypes.Concat -import Puppet.NativeTypes.Cron -import Puppet.NativeTypes.Exec -import Puppet.NativeTypes.File -import Puppet.NativeTypes.Group -import Puppet.NativeTypes.Helpers -import Puppet.NativeTypes.Host -import Puppet.NativeTypes.Mount -import Puppet.NativeTypes.Notify -import Puppet.NativeTypes.Package -import Puppet.NativeTypes.SshSecure -import Puppet.NativeTypes.User -import Puppet.NativeTypes.ZoneRecord - -fakeTypes :: [(NativeTypeName, NativeTypeMethods)] -fakeTypes = map faketype ["class"] - -defaultTypes :: [(NativeTypeName, NativeTypeMethods)] -defaultTypes = map defaulttype ["augeas","computer","filebucket","interface","k5login","macauthorization","mailalias","maillist","mcx","nagios_command","nagios_contact","nagios_contactgroup","nagios_host","nagios_hostdependency","nagios_hostescalation","nagios_hostextinfo","nagios_hostgroup","nagios_service","nagios_servicedependency","nagios_serviceescalation","nagios_serviceextinfo","nagios_servicegroup","nagios_timeperiod","resources","router","schedule","scheduledtask","selboolean","selmodule","service","ssh_authorized_key","sshkey","stage","tidy","vlan","yumrepo","zfs","zone","zpool"] - --- | The map of native types. They are described in "Puppet.NativeTypes.Helpers". -baseNativeTypes :: Container NativeTypeMethods -baseNativeTypes = HM.fromList - ( nativeConcat - : nativeConcatFragment - : nativeCron - : nativeExec - : nativeFile - : nativeGroup - : nativeHost - : nativeMount - : nativeNotify - : nativePackage - : nativeSshSecure - : nativeUser - : nativeZoneRecord - : fakeTypes ++ defaultTypes) - --- | Contrary to the previous iteration, this will let non native types pass. -validateNativeType :: Resource -> InterpreterMonad Resource -validateNativeType r = do - tps <- singleton GetNativeTypes - case tps ^. at (r ^. rid . itype) of - Just x -> case (x ^. puppetValidate) r of - Right nr -> return nr - Left err -> throwPosError ("Invalid resource" <+> pretty r getError err) - Nothing -> return r diff --git a/src/Puppet/NativeTypes/Concat.hs b/src/Puppet/NativeTypes/Concat.hs deleted file mode 100644 --- a/src/Puppet/NativeTypes/Concat.hs +++ /dev/null @@ -1,49 +0,0 @@ -module Puppet.NativeTypes.Concat ( - nativeConcat - , nativeConcatFragment -) where - -import Puppet.Prelude - -import Puppet.NativeTypes.Helpers -import Puppet.Interpreter.Types - -nativeConcat :: (NativeTypeName, NativeTypeMethods) -nativeConcat = ("concat", nativetypemethods concatparamfunctions pure) - -nativeConcatFragment :: (NativeTypeName, NativeTypeMethods) -nativeConcatFragment = ("concat::fragment", nativetypemethods fragmentparamfunctions validateSourceOrContent) - -concatparamfunctions :: [(Text, [Text -> NativeTypeValidate])] -concatparamfunctions = - [("name" , [nameval]) - ,("ensure" , [defaultvalue "present", string, values ["present","absent"]]) - ,("path" , [string]) - ,("owner" , [string]) - ,("group" , [string]) - ,("mode" , [defaultvalue "0644", string]) - ,("warn" , [defaultvalue "false", string, values ["false", "true"]]) - ,("force" , [defaultvalue "false", string, values ["false", "true"]]) - ,("backup" , [defaultvalue "puppet", string]) - ,("replace" , [defaultvalue "true", string, values ["false", "true"]]) - ,("order" , [defaultvalue "alpha", string, values ["alpha","numeric"]]) - ,("ensure_newline" , [defaultvalue "false", string, values ["false", "true"]]) - -- deprecated - -- ,("gnu" , [string]) - ] - -fragmentparamfunctions :: [(Text, [Text -> NativeTypeValidate])] -fragmentparamfunctions = - [("name" , [nameval]) - ,("target" , [string, mandatory]) - ,("content" , [string]) - ,("source" , [string]) - -- order should be an int or a string - ,("order" , [defaultvalue "10", string]) - ,("ensure" , [string, values ["present","absent"]]) - -- deprecated field - -- ,("mode" , [string]) - -- ,("owner" , [string]) - -- ,("group" , [string]) - -- ,("backup" , [string]) - ] diff --git a/src/Puppet/NativeTypes/Cron.hs b/src/Puppet/NativeTypes/Cron.hs deleted file mode 100644 --- a/src/Puppet/NativeTypes/Cron.hs +++ /dev/null @@ -1,66 +0,0 @@ -module Puppet.NativeTypes.Cron - (nativeCron) -where - -import Puppet.Prelude - -import qualified Data.Text as Text -import qualified Data.Vector as V -import qualified Text.PrettyPrint.ANSI.Leijen as P - -import Puppet.Interpreter.Types -import Puppet.NativeTypes.Helpers - -nativeCron :: (NativeTypeName, NativeTypeMethods) -nativeCron = ("cron", nativetypemethods parameterfunctions return ) - --- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them. -parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] -parameterfunctions = - [("ensure" , [defaultvalue "present", string, values ["present","absent"]]) - ,("command" , [string, mandatoryIfNotAbsent]) - ,("environment" , []) - ,("hour" , [vrange 0 23 [] ]) - ,("minute" , [vrange 0 59 [] ]) - ,("month" , [vrange 1 12 ["January","February","March","April","May","June","July","August","September","October","November","December"] ]) - ,("monthday" , [vrange 1 31 [] ]) - ,("name" , [nameval]) - ,("provider" , [defaultvalue "crontab", string, values ["crontab"]]) - ,("special" , [string]) - ,("target" , [string]) - ,("user" , [defaultvalue "root", string]) - ,("weekday" , [vrange 0 7 ["Monday","Tuesday","Wednesday","Thursday","Friday","Saturday","Sunday"]]) - ] - - -vrange :: Integer -> Integer -> [Text] -> Text -> NativeTypeValidate -vrange mi ma valuelist param res = case res ^. rattributes . at param of - Just (PArray xs) -> V.foldM (vrange' mi ma valuelist param) res xs - Just x -> vrange' mi ma valuelist param res x - Nothing -> defaultvalue "*" param res - -vrange' :: Integer -> Integer -> [Text] -> Text -> Resource -> PValue -> Either PrettyError Resource -vrange' mi ma valuelist param res y = case y of - PString "*" -> Right res - PString "absent" -> Right res - PNumber n -> checkint' n mi ma param res - PString x -> if x `elem` valuelist - then Right res - else parseval x mi ma param res - x -> perror $ "Parameter" <+> paramname param <+> "value should be a valid cron declaration and not" <+> pretty x - -parseval :: Text -> Integer -> Integer -> Text -> NativeTypeValidate -parseval resval mi ma pname res | "*/" `Text.isPrefixOf` resval = checkint (Text.drop 2 resval) 1 ma pname res - | otherwise = checkint resval mi ma pname res - -checkint :: Text -> Integer -> Integer -> Text -> NativeTypeValidate -checkint st mi ma pname res = - case text2Scientific st of - Just n -> checkint' n mi ma pname res - Nothing -> perror $ "Invalid value type for parameter" <+> paramname pname <+> ": " <+> red (ttext st) - -checkint' :: Scientific -> Integer -> Integer -> Text -> NativeTypeValidate -checkint' i mi ma param res = - if (i >= fromIntegral mi) && (i <= fromIntegral ma) - then Right res - else perror $ "Parameter" <+> paramname param <+> "value is out of bound, should satisfy" <+> P.integer mi <+> "<=" <+> P.string (show i) <+> "<=" <+> P.integer ma diff --git a/src/Puppet/NativeTypes/Exec.hs b/src/Puppet/NativeTypes/Exec.hs deleted file mode 100644 --- a/src/Puppet/NativeTypes/Exec.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Puppet.NativeTypes.Exec (nativeExec) where - -import qualified Data.Text as Text -import Puppet.Prelude - -import Puppet.Interpreter.Types -import Puppet.NativeTypes.Helpers - -nativeExec :: (NativeTypeName, NativeTypeMethods) -nativeExec = ("exec", nativetypemethods parameterfunctions fullyQualifiedOrPath) - --- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them. -parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] -parameterfunctions = - [("command" , [nameval]) - ,("creates" , [rarray, strings, fullyQualifieds]) - ,("cwd" , [string, fullyQualified]) - ,("environment" , [rarray, strings]) - ,("group" , [string]) - ,("logoutput" , [defaultvalue "false", string, values ["true","false","on_failure"]]) - ,("onlyif" , [string]) - ,("path" , [rarray, strings, fullyQualifieds]) - ,("provider" , [string, values ["posix","shell","windows"]]) - ,("refresh" , [string]) - ,("refreshonly" , [defaultvalue "false", string, values ["true","false"]]) - ,("returns" , [defaultvalue "0", rarray, integers]) - ,("timeout" , [defaultvalue "300", integer]) - ,("tries" , [defaultvalue "1", integer]) - ,("try_sleep" , [defaultvalue "0", integer]) - ,("unless" , [string]) - ,("user" , [string]) - ] - -fullyQualifiedOrPath :: NativeTypeValidate -fullyQualifiedOrPath res = - case (res ^. rattributes . at "path", res ^. rattributes . at "command") of - (Nothing, Just (PString x)) -> if Text.head x == '/' - then Right res - else Left "Command must be fully qualified if path is not defined" - _ -> Right res diff --git a/src/Puppet/NativeTypes/File.hs b/src/Puppet/NativeTypes/File.hs deleted file mode 100644 --- a/src/Puppet/NativeTypes/File.hs +++ /dev/null @@ -1,111 +0,0 @@ -module Puppet.NativeTypes.File (nativeFile) where - -import Puppet.Prelude - -import Control.Monad.Trans.Except -import qualified Data.Attoparsec.Text as AT -import qualified Data.Char as Char -import qualified Data.Map.Strict as M -import qualified Data.Set as Set -import qualified Data.Text as Text - -import Puppet.Interpreter.Types -import Puppet.NativeTypes.Helpers - -nativeFile :: (NativeTypeName, NativeTypeMethods) -nativeFile = ("file", nativetypemethods parameterfunctions (validateSourceOrContent >=> validateMode)) - - --- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them. - -parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] -parameterfunctions = - [("backup" , [string]) - ,("checksum" , [values ["md5", "md5lite", "mtime", "ctime", "none"]]) - ,("content" , [string]) - --,("ensure" , [defaultvalue "present", string, values ["directory","file","present","absent","link"]]) - ,("ensure" , [defaultvalue "present", string]) - ,("force" , [string, values ["true","false"]]) - ,("group" , [defaultvalue "root", string]) - ,("ignore" , [strings]) - ,("links" , [string]) - ,("mode" , [defaultvalue "0644", string]) - ,("owner" , [string]) - ,("path" , [nameval, fullyQualified, noTrailingSlash']) - ,("provider" , [values ["posix","windows"]]) - ,("purge" , [string, values ["true","false"]]) - ,("recurse" , [string, values ["inf","true","false","remote"]]) - ,("recurselimit" , [integer]) - ,("replace" , [string, values ["true","false","yes","no"]]) - ,("sourceselect" , [values ["first","all"]]) - ,("seltype" , [string]) - ,("selrange" , [string]) - ,("selinux_ignore_defaults", [string, values ["true","false"]]) - ,("selrole" , [string]) - ,("target" , [string]) - ,("source" , [rarray, strings, flip runarray checkSource]) - ,("seluser" , [string]) - ,("validate_cmd" , [string]) - ,("validate_replacement" , [string]) - ] - -noTrailingSlash' :: Text -> NativeTypeValidate -noTrailingSlash' param res - | res ^? rattributes . ix "ensure" == Just "directory" = Right res - | otherwise = noTrailingSlash param res - -validateMode :: NativeTypeValidate -validateMode res = do - modestr <- case res ^. rattributes . at "mode" of - Just (PString s) -> return s - Just x -> throwError $ PrettyError ("Invalide mode type, should be a string " <+> pretty x) - Nothing -> throwError "Could not find mode!" - (numeric modestr <|> except (ugo modestr)) & runExcept & _Right %~ ($ res) - -numeric :: Text -> Except PrettyError (Resource -> Resource) -numeric modestr = do - when ((Text.length modestr /= 3) && (Text.length modestr /= 4)) (throwError "Invalid mode size") - unless (Text.all Char.isDigit modestr) (throwError "The mode should only be made of digits") - return $ if Text.length modestr == 3 - then rattributes . at "mode" ?~ PString (Text.cons '0' modestr) - else identity - -checkSource :: Text -> PValue -> NativeTypeValidate -checkSource _ (PString x) res | any (`Text.isPrefixOf` x) ["puppet://", "file://", "/"] = Right res - | otherwise = throwError "A source should start with either puppet:// or file:// or an absolute path" -checkSource _ x _ = throwError $ PrettyError ("Expected a string, not" <+> pretty x) - -data PermParts = Special | User | Group | Other - deriving (Eq, Ord) - -data PermSet = R | W | X - deriving (Ord, Eq) - -ugo :: Text -> Either PrettyError (Resource -> Resource) -ugo t = AT.parseOnly (modestring <* AT.endOfInput) t - & _Left %~ (\rr -> PrettyError $ "Could not parse the mode string: " <> text rr) - & _Right %~ (\s -> rattributes . at "mode" ?~ PString (mkmode Special s <> mkmode User s <> mkmode Group s <> mkmode Other s)) - -mkmode :: PermParts -> M.Map PermParts (Set PermSet) -> Text -mkmode p m = let s = m ^. at p . non mempty - in Text.pack $ show $ fromEnum (Set.member R s) * 4 - + fromEnum (Set.member W s) * 2 - + fromEnum (Set.member X s) - -modestring :: AT.Parser (M.Map PermParts (Set.Set PermSet)) -modestring = M.fromList . mconcat <$> (modepart `AT.sepBy` AT.char ',') - --- TODO suid, sticky and other funky things are not yet supported -modepart :: AT.Parser [(PermParts, Set PermSet)] -modepart = do - let permpart = (AT.char 'u' *> pure [User]) - <|> (AT.char 'g' *> pure [Group]) - <|> (AT.char 'o' *> pure [Other]) - <|> (AT.char 'a' *> pure [User,Group,Other]) - permission = (AT.char 'r' *> pure R) - <|> (AT.char 'w' *> pure W) - <|> (AT.char 'x' *> pure X) - pp <- mconcat <$> some permpart - void $ AT.char '=' - pr <- Set.fromList <$> some permission - return (map (\p -> (p, pr)) pp) diff --git a/src/Puppet/NativeTypes/Group.hs b/src/Puppet/NativeTypes/Group.hs deleted file mode 100644 --- a/src/Puppet/NativeTypes/Group.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Puppet.NativeTypes.Group (nativeGroup) where - -import Puppet.Prelude - -import Puppet.Interpreter.Types -import Puppet.NativeTypes.Helpers - -nativeGroup :: (NativeTypeName, NativeTypeMethods) -nativeGroup = ("group", nativetypemethods parameterfunctions return) - --- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them. -parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] -parameterfunctions = - [("allowdupe" , [string, defaultvalue "false", values ["true","false"]]) - ,("attribute_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]]) - ,("attributes" , [strings]) - ,("auth_membership" , [defaultvalue "minimum", string, values ["inclusive","minimum"]]) - ,("ensure" , [defaultvalue "present", string, values ["present","absent"]]) - ,("gid" , [integer]) - ,("ia_load_module" , [string]) - ,("members" , [strings]) - ,("name" , [nameval]) - ,("provider" , [string, values ["aix","directoryservice","groupadd","ldap","pw","window_adsi"]]) - ,("system" , [string, defaultvalue "false", values ["true","false"]]) - ] diff --git a/src/Puppet/NativeTypes/Helpers.hs b/src/Puppet/NativeTypes/Helpers.hs deleted file mode 100644 --- a/src/Puppet/NativeTypes/Helpers.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-| These are the function and data types that are used to define the Puppet -native types. --} -module Puppet.NativeTypes.Helpers - ( module Puppet.PP - , ipaddr - , nativetypemethods - , paramname - , rarray - , string - , strings - , string_s - , noTrailingSlash - , fullyQualified - , fullyQualifieds - , values - , defaultvalue - , concattype - , nameval - , defaultValidate - , NativeTypeName - , parameterFunctions - , integer - , integers - , mandatory - , mandatoryIfNotAbsent - , inrange - , faketype - , defaulttype - , runarray - , perror - , validateSourceOrContent - ) where - -import Puppet.Prelude - -import qualified Text.Read -import Data.Aeson.Lens (_Integer, _Number) -import Data.Char (isDigit) -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import qualified Data.Text as Text -import qualified Data.Vector as V -import Puppet.Interpreter.PrettyPrinter () -import Puppet.Interpreter.Types -import Puppet.PP hiding (integer, string) -import qualified Text.PrettyPrint.ANSI.Leijen as P - -type NativeTypeName = Text - -paramname :: Text -> Doc -paramname = red . ttext - --- | Useful helper for buiding error messages -perror :: Doc -> Either PrettyError Resource -perror = Left . PrettyError - --- | Smart constructor for 'NativeTypeMethods'. -nativetypemethods :: [(Text, [Text -> NativeTypeValidate])] -> NativeTypeValidate -> NativeTypeMethods -nativetypemethods def extraV = - let params = fromKeys def - in NativeTypeMethods (defaultValidate params >=> parameterFunctions def >=> extraV) params - where - fromKeys = HS.fromList . map fst - -faketype :: NativeTypeName -> (NativeTypeName, NativeTypeMethods) -faketype tname = (tname, NativeTypeMethods Right HS.empty) - -concattype :: NativeTypeName -> (NativeTypeName, NativeTypeMethods) -concattype tname = (tname, NativeTypeMethods (defaultValidate HS.empty) HS.empty) - -defaulttype :: NativeTypeName -> (NativeTypeName, NativeTypeMethods) -defaulttype tname = (tname, NativeTypeMethods (defaultValidate HS.empty) HS.empty) - -{-| Validate resources given a list of valid parameters: - - * checks that no unknown parameters have been set (except metaparameters) --} -defaultValidate :: HS.HashSet Text -> NativeTypeValidate -defaultValidate validparameters = checkParameterList validparameters >=> addDefaults - -checkParameterList :: HS.HashSet Text -> NativeTypeValidate -checkParameterList validparameters res | HS.null validparameters = Right res - | otherwise = if HS.null setdiff - then Right res - else perror $ "Unknown parameters: " <+> list (map paramname $ HS.toList setdiff) - where - keyset = HS.fromList $ HM.keys (res ^. rattributes) - setdiff = HS.difference keyset (metaparameters `HS.union` validparameters) - --- | This validator always accept the resources, but add the default parameters (to be defined :) -addDefaults :: NativeTypeValidate -addDefaults res = Right (res & rattributes %~ newparams) - where - def PUndef = False - def _ = True - newparams p = HM.filter def $ HM.union p defaults - defaults = HM.empty - --- | Helper function that runs a validor on a 'PArray' -runarray :: Text -> (Text -> PValue -> NativeTypeValidate) -> NativeTypeValidate -runarray param func res = case res ^. rattributes . at param of - Just (PArray x) -> V.foldM (flip (func param)) res x - Just x -> perror $ "Parameter" <+> paramname param <+> "should be an array, not" <+> pretty x - Nothing -> Right res - -{-| This checks that a given parameter is a string. If it is a 'ResolvedInt' or -'ResolvedBool' it will convert them to strings. --} -string :: Text -> NativeTypeValidate -string param res = case res ^. rattributes . at param of - Just x -> string' param x res - Nothing -> Right res - -strings :: Text -> NativeTypeValidate -strings param = runarray param string' - --- | Validates a string or an array of strings -string_s :: Text -> NativeTypeValidate -string_s param res = case res ^. rattributes . at param of - Nothing -> Right res - Just (PArray _) -> strings param res - Just _ -> string param res - -string' :: Text -> PValue -> NativeTypeValidate -string' param rev res = case rev of - PString _ -> Right res - PBoolean True -> Right (res & rattributes . at param ?~ PString "true") - PBoolean False -> Right (res & rattributes . at param ?~ PString "false") - PNumber n -> Right (res & rattributes . at param ?~ PString (scientific2text n)) - x -> perror $ "Parameter" <+> paramname param <+> "should be a string, and not" <+> pretty x - - - --- | Makes sure that the parameter, if defined, has a value among this list. -values :: [Text] -> Text -> NativeTypeValidate -values valuelist param res = case res ^. rattributes . at param of - Just (PString x) -> if x `elem` valuelist - then Right res - else perror $ "Parameter" <+> paramname param <+> "value should be one of" <+> list (map ttext valuelist) <+> "and not" <+> ttext x - Just x -> perror $ "Parameter" <+> paramname param <+> "value should be one of" <+> list (map ttext valuelist) <+> "and not" <+> pretty x - Nothing -> Right res - --- | This fills the default values of unset parameters. -defaultvalue :: Text -> Text -> NativeTypeValidate -defaultvalue value param = Right . over (rattributes . at param) (Just . fromMaybe (PString value)) - --- | Checks that a given parameter, if set, is a 'ResolvedInt'. --- If it is a 'PString' it will attempt to parse it. -integer :: Text -> NativeTypeValidate -integer prm res = string prm res >>= integer' prm - where - integer' pr rs = case rs ^. rattributes . at pr of - Just x -> integer'' prm x res - Nothing -> Right rs - -integers :: Text -> NativeTypeValidate -integers param = runarray param integer'' - -integer'' :: Text -> PValue -> NativeTypeValidate -integer'' param val res = case val ^? _Integer of - Just v -> Right (res & rattributes . at param ?~ PNumber (fromIntegral v)) - _ -> perror $ "Parameter" <+> paramname param <+> "must be an integer" - --- | Copies the "name" value into the parameter if this is not set. --- It implies the `string` validator. -nameval :: Text -> NativeTypeValidate -nameval prm res = string prm res - >>= \r -> case r ^. rattributes . at prm of - Just (PString al) -> Right (res & rid . iname .~ al) - Just x -> perror ("The alias must be a string, not" <+> pretty x) - Nothing -> Right (r & rattributes . at prm ?~ PString (r ^. rid . iname)) - --- | Checks that a given parameter is set unless the resources "ensure" is set to absent -mandatoryIfNotAbsent :: Text -> NativeTypeValidate -mandatoryIfNotAbsent param res = case res ^. rattributes . at param of - Just _ -> Right res - Nothing -> case res ^. rattributes . at "ensure" of - Just "absent" -> Right res - _ -> perror $ "Parameter" <+> paramname param <+> "should be set." - --- | Checks that a given parameter is set. -mandatory :: Text -> NativeTypeValidate -mandatory param res = case res ^. rattributes . at param of - Just _ -> Right res - Nothing -> perror $ "Parameter" <+> paramname param <+> "should be set." - --- | Helper that takes a list of stuff and will generate a validator. -parameterFunctions :: [(Text, [Text -> NativeTypeValidate])] -> NativeTypeValidate -parameterFunctions argrules rs = foldM parameterFunctions' rs argrules - where - parameterFunctions' :: Resource -> (Text, [Text -> NativeTypeValidate]) -> Either PrettyError Resource - parameterFunctions' r (param, validationfunctions) = foldM (parameterFunctions'' param) r validationfunctions - parameterFunctions'' :: Text -> Resource -> (Text -> NativeTypeValidate) -> Either PrettyError Resource - parameterFunctions'' param r validationfunction = validationfunction param r - --- checks that a parameter is fully qualified -fullyQualified :: Text -> NativeTypeValidate -fullyQualified param res = case res ^. rattributes . at param of - Just path -> fullyQualified' param path res - Nothing -> Right res - -noTrailingSlash :: Text -> NativeTypeValidate -noTrailingSlash param res = case res ^. rattributes . at param of - Just (PString x) -> if Text.last x == '/' - then perror ("Parameter" <+> paramname param <+> "should not have a trailing slash") - else Right res - _ -> Right res - -fullyQualifieds :: Text -> NativeTypeValidate -fullyQualifieds param = runarray param fullyQualified' - -fullyQualified' :: Text -> PValue -> NativeTypeValidate -fullyQualified' param path res = case path of - PString ("") -> perror $ "Empty path for parameter" <+> paramname param - PString p -> if Text.head p == '/' - then Right res - else perror $ "Path must be absolute, not" <+> ttext p <+> "for parameter" <+> paramname param - x -> perror $ "SHOULD NOT HAPPEN: path is not a resolved string, but" <+> pretty x <+> "for parameter" <+> paramname param - -rarray :: Text -> NativeTypeValidate -rarray param res = case res ^. rattributes . at param of - Just (PArray _) -> Right res - Just x -> Right $ res & rattributes . at param ?~ PArray (V.singleton x) - Nothing -> Right res - -ipaddr :: Text -> NativeTypeValidate -ipaddr param res = case res ^. rattributes . at param of - Nothing -> Right res - Just (PString ip) -> - if checkipv4 ip 0 - then Right res - else perror $ "Invalid IP address for parameter" <+> paramname param - Just x -> perror $ "Parameter" <+> paramname param <+> "should be an IP address string, not" <+> pretty x - -checkipv4 :: Text -> Int -> Bool -checkipv4 _ 4 = False -- means that there are more than 4 groups -checkipv4 "" _ = False -- should never get an empty string -checkipv4 ip v = - let (cur, nxt) = Text.break (=='.') ip - nextfunc = if Text.null nxt - then v == 3 - else checkipv4 (Text.tail nxt) (v+1) - goodcur = not (Text.null cur) && Text.all isDigit cur && (let rcur = Text.Read.read (Text.unpack cur) :: Int in (rcur >= 0) && (rcur <= 255)) - in goodcur && nextfunc - -inrange :: Integer -> Integer -> Text -> NativeTypeValidate -inrange mi ma param res = - let va = res ^. rattributes . at param - na = va ^? traverse . _Number - in case (va,na) of - (Nothing, _) -> Right res - (_,Just v) -> if (v >= fromIntegral mi) && (v <= fromIntegral ma) - then Right res - else perror $ "Parameter" <+> paramname param P.<> "'s value should be between" <+> P.integer mi <+> "and" <+> P.integer ma - (Just x,_) -> perror $ "Parameter" <+> paramname param <+> "should be an integer, and not" <+> pretty x - -validateSourceOrContent :: NativeTypeValidate -validateSourceOrContent res = let - parammap = res ^. rattributes - source = HM.member "source" parammap - content = HM.member "content" parammap - in if source && content - then perror "Source and content can't be specified at the same time" - else Right res diff --git a/src/Puppet/NativeTypes/Host.hs b/src/Puppet/NativeTypes/Host.hs deleted file mode 100644 --- a/src/Puppet/NativeTypes/Host.hs +++ /dev/null @@ -1,48 +0,0 @@ -module Puppet.NativeTypes.Host (nativeHost) where - -import Puppet.Prelude - -import qualified Data.Char as Char -import qualified Data.Text as Text -import qualified Data.Vector as V - -import Puppet.NativeTypes.Helpers -import Puppet.Interpreter.Types - -nativeHost :: (NativeTypeName, NativeTypeMethods) -nativeHost = ("host", nativetypemethods parameterfunctions return) - --- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them. -parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] -parameterfunctions = - [("comment" , [string, values ["true","false"]]) - ,("ensure" , [defaultvalue "present", string, values ["present","absent"]]) - ,("host_aliases" , [rarray, strings, checkhostname]) - ,("ip" , [string, mandatory, ipaddr]) - ,("name" , [nameval, checkhostname]) - ,("provider" , [string, values ["parsed"]]) - ,("target" , [string, fullyQualified]) - ] - -checkhostname :: Text -> NativeTypeValidate -checkhostname param res = case res ^. rattributes . at param of - Nothing -> Right res - Just (PArray xs) -> V.foldM (checkhostname' param) res xs - Just x@(PString _) -> checkhostname' param res x - Just x -> perror $ paramname param <+> "should be an array or a single string, not" <+> pretty x - -checkhostname' :: Text -> Resource -> PValue -> Either PrettyError Resource -checkhostname' prm _ (PString "") = perror $ "Empty hostname for parameter" <+> paramname prm -checkhostname' prm res (PString x ) = checkhostname'' prm res x -checkhostname' prm _ x = perror $ "Parameter " <+> paramname prm <+> "should be an string or an array of strings, but this was found :" <+> pretty x - -checkhostname'' :: Text -> Resource -> Text -> Either PrettyError Resource -checkhostname'' prm _ "" = perror $ "Empty hostname part in parameter" <+> paramname prm -checkhostname'' prm res prt = - let (cur,nxt) = Text.break (=='.') prt - nextfunc = if Text.null nxt - then Right res - else checkhostname'' prm res (Text.tail nxt) - in if Text.null cur || (Text.head cur == '-') || not (Text.all (\x -> Char.isAlphaNum x || (x=='-')) cur) - then perror $ "Invalid hostname part for parameter" <+> paramname prm - else nextfunc diff --git a/src/Puppet/NativeTypes/Mount.hs b/src/Puppet/NativeTypes/Mount.hs deleted file mode 100644 --- a/src/Puppet/NativeTypes/Mount.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Puppet.NativeTypes.Mount (nativeMount) where - -import Puppet.Prelude - -import Puppet.NativeTypes.Helpers -import Puppet.Interpreter.Types - -nativeMount :: (NativeTypeName, NativeTypeMethods) -nativeMount = ("mount", nativetypemethods parameterfunctions return) - -parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] -parameterfunctions = - [("atboot" , [string, values ["true","false"]]) - ,("blockdevice" , [string]) - ,("device" , [string, mandatoryIfNotAbsent]) - ,("dump" , [integer, inrange 0 2]) - ,("ensure" , [defaultvalue "present", string, values ["present","absent","mounted"]]) - ,("fstype" , [string, mandatoryIfNotAbsent]) - ,("name" , [nameval]) - ,("options" , [string]) - ,("pass" , [defaultvalue "0", integer]) - ,("provider" , [defaultvalue "parsed", string, values ["parsed"]]) - ,("remounts" , [string, values ["true","false"]]) - ,("target" , [string, fullyQualified]) - ] diff --git a/src/Puppet/NativeTypes/Notify.hs b/src/Puppet/NativeTypes/Notify.hs deleted file mode 100644 --- a/src/Puppet/NativeTypes/Notify.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Puppet.NativeTypes.Notify (nativeNotify) where - -import Puppet.Prelude - -import Puppet.Interpreter.Types -import Puppet.NativeTypes.Helpers - -nativeNotify :: (NativeTypeName, NativeTypeMethods) -nativeNotify = ("notify", nativetypemethods parameterfunctions return) - -parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] -parameterfunctions = - [("message" , []) - ,("withpath" , [string, defaultvalue "false", values ["true","false"]]) - ] diff --git a/src/Puppet/NativeTypes/Package.hs b/src/Puppet/NativeTypes/Package.hs deleted file mode 100644 --- a/src/Puppet/NativeTypes/Package.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Puppet.NativeTypes.Package (nativePackage) where - -import Puppet.Prelude - -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS - -import Puppet.Interpreter.Types -import Puppet.NativeTypes.Helpers - -nativePackage :: (NativeTypeName, NativeTypeMethods) -nativePackage = ("package", nativetypemethods parameterfunctions (getFeature >=> checkFeatures)) - --- Features are abilities that some providers may not support. -data PackagingFeatures = Holdable | InstallOptions | Installable | Purgeable | UninstallOptions | Uninstallable | Upgradeable | Versionable deriving (Show, Eq, Generic) - -instance Hashable PackagingFeatures - -isFeatureSupported :: HM.HashMap Text (HS.HashSet PackagingFeatures) -isFeatureSupported = HM.fromList [ ("aix", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable]) - , ("appdmg", HS.fromList [Installable]) - , ("apple", HS.fromList [Installable]) - , ("apt", HS.fromList [Holdable, InstallOptions, Installable, Purgeable, Uninstallable, Upgradeable, Versionable]) - , ("aptitude", HS.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable]) - , ("aptrpm", HS.fromList [Installable, Purgeable, Uninstallable, Upgradeable, Versionable]) - , ("blastwave", HS.fromList [Installable, Uninstallable, Upgradeable]) - , ("dpkg", HS.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable]) - , ("fink", HS.fromList [Holdable, Installable, Purgeable, Uninstallable, Upgradeable, Versionable]) - , ("freebsd", HS.fromList [Installable, Uninstallable]) - , ("gem", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable]) - , ("hpux", HS.fromList [Installable, Uninstallable]) - , ("macports", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable]) - , ("msi", HS.fromList [InstallOptions, Installable, UninstallOptions, Uninstallable]) - , ("nim", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable]) - , ("openbsd", HS.fromList [Installable, Uninstallable, Versionable]) - , ("pacman", HS.fromList [Installable, Uninstallable, Upgradeable]) - , ("pip", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable]) - , ("pkg", HS.fromList [Holdable, Installable, Uninstallable, Upgradeable, Versionable]) - , ("pkgdmg", HS.fromList [Installable]) - , ("pkgin", HS.fromList [Installable, Uninstallable]) - , ("pkgutil", HS.fromList [Installable, Uninstallable, Upgradeable]) - , ("portage", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable]) - , ("ports", HS.fromList [Installable, Uninstallable, Upgradeable]) - , ("portupgrade", HS.fromList [Installable, Uninstallable, Upgradeable]) - , ("rpm", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable]) - , ("rug", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable]) - , ("sun", HS.fromList [InstallOptions, Installable, Uninstallable, Upgradeable]) - , ("sunfreeware", HS.fromList [Installable, Uninstallable, Upgradeable]) - , ("up2date", HS.fromList [Installable, Uninstallable, Upgradeable]) - , ("urpmi", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable]) - , ("windows", HS.fromList [InstallOptions, Installable, UninstallOptions, Uninstallable]) - , ("yum", HS.fromList [Installable, Purgeable, Uninstallable, Upgradeable, Versionable]) - , ("zypper", HS.fromList [Installable, Uninstallable, Upgradeable, Versionable]) - ] - -parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] -parameterfunctions = - [("adminfile" , [string, fullyQualified]) - ,("allowcdrom" , [string, values ["true","false"]]) - ,("configfiles" , [string, values ["keep","replace"]]) - --,("ensure" , [defaultvalue "present", string, values ["present","absent","latest","held","purged","installed"]]) - ,("ensure" , [defaultvalue "present", string]) - ,("flavor" , []) - ,("install_options" , [rarray]) - ,("name" , [nameval]) - ,("provider" , [defaultvalue "apt", string]) - ,("responsefile" , [string, fullyQualified]) - ,("source" , [string]) - ,("uninstall_options", [rarray]) - ] - -getFeature :: Resource -> Either PrettyError (HS.HashSet PackagingFeatures, Resource) -getFeature res = case res ^. rattributes . at "provider" of - Just (PString x) -> case HM.lookup x isFeatureSupported of - Just s -> Right (s,res) - Nothing -> Left $ PrettyError ("Do not know provider" <+> ttext x) - _ -> Left "Can't happen at Puppet.NativeTypes.Package" - -checkFeatures :: (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError Resource -checkFeatures = - checkAdminFile - >=> checkEnsure - >=> checkParam "install_options" InstallOptions - >=> checkParam "uninstall_options" UninstallOptions - >=> decap - where - checkFeature :: HS.HashSet PackagingFeatures -> Resource -> PackagingFeatures -> Either PrettyError (HS.HashSet PackagingFeatures, Resource) - checkFeature s r f = if HS.member f s - then Right (s, r) - else Left $ PrettyError ("Feature" <+> text (show f) <+> "is required for the current configuration") - checkParam :: Text -> PackagingFeatures -> (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError (HS.HashSet PackagingFeatures, Resource) - checkParam pn f (s,r) = if has (ix pn) (r ^. rattributes) - then checkFeature s r f - else Right (s,r) - checkAdminFile :: (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError (HS.HashSet PackagingFeatures, Resource) - checkAdminFile = Right -- TODO, check that it only works for aix - checkEnsure :: (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError (HS.HashSet PackagingFeatures, Resource) - checkEnsure (s, res) = case res ^. rattributes . at "ensure" of - Just (PString "latest") -> checkFeature s res Installable - Just (PString "purged") -> checkFeature s res Purgeable - Just (PString "absent") -> checkFeature s res Uninstallable - Just (PString "installed") -> checkFeature s res Installable - Just (PString "present") -> checkFeature s res Installable - Just (PString "held") -> checkFeature s res Installable >> checkFeature s res Holdable - _ -> checkFeature s res Versionable - decap :: (HS.HashSet PackagingFeatures, Resource) -> Either PrettyError Resource - decap = Right . snd diff --git a/src/Puppet/NativeTypes/SshSecure.hs b/src/Puppet/NativeTypes/SshSecure.hs deleted file mode 100644 --- a/src/Puppet/NativeTypes/SshSecure.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Puppet.NativeTypes.SshSecure (nativeSshSecure) where - -import Puppet.Prelude - -import Puppet.Interpreter.Types -import Puppet.NativeTypes.Helpers - -nativeSshSecure :: (NativeTypeName, NativeTypeMethods) -nativeSshSecure = ("ssh_authorized_key_secure", nativetypemethods parameterfunctions (userOrTarget >=> keyIfPresent)) - --- Autorequires: If Puppet is managing the user or user that owns a file, the file resource will autorequire them. If Puppet is managing any parent directories of a file, the file resource will autorequire them. -parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] -parameterfunctions = - [("type" , [string, defaultvalue "ssh-rsa", values ["rsa","dsa","ssh-rsa","ssh-dss"]]) - ,("key" , [string]) - ,("user" , [string]) - ,("ensure" , [defaultvalue "present", string, values ["present","absent","role"]]) - ,("target" , [string]) - ,("options" , [rarray, strings]) - ] - -userOrTarget :: NativeTypeValidate -userOrTarget res = case (res ^. rattributes & has (ix "user"), res ^. rattributes & has (ix "target")) of - (False, False) -> Left "Parameters user or target are mandatory" - _ -> Right res - - -keyIfPresent :: NativeTypeValidate -keyIfPresent res = case (res ^. rattributes . at "key", res ^. rattributes . at "ensure") of - (Just _, Just "present") -> Right res - (_, Just "absent") -> Right res - _ -> Left "Parameter key is mandatory when the resource is present" diff --git a/src/Puppet/NativeTypes/User.hs b/src/Puppet/NativeTypes/User.hs deleted file mode 100644 --- a/src/Puppet/NativeTypes/User.hs +++ /dev/null @@ -1,47 +0,0 @@ -module Puppet.NativeTypes.User (nativeUser) where - - -import Puppet.Prelude - -import Puppet.NativeTypes.Helpers -import Puppet.Interpreter.Types - -nativeUser :: (NativeTypeName, NativeTypeMethods) -nativeUser = ("user", nativetypemethods parameterfunctions return) - --- Autorequires: If Puppet is managing the user or user that owns a file, the file resource will autorequire them. --- If Puppet is managing any parent directories of a file, the file resource will autorequire them. -parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] -parameterfunctions = - [("allowdupe" , [string, defaultvalue "false", values ["true","false"]]) - ,("attribute_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]]) - ,("attributes" , [rarray,strings]) - ,("auth_membership" , [defaultvalue "minimum", string, values ["inclusive","minimum"]]) - ,("auths" , [rarray,strings]) - ,("comment" , [string]) - ,("ensure" , [defaultvalue "present", string, values ["present","absent","role"]]) - ,("expiry" , [string]) - ,("gid" , [string]) - ,("groups" , [rarray,strings]) - ,("home" , [string, fullyQualified, noTrailingSlash]) - ,("ia_load_module" , [string]) - ,("iterations" , [integer]) - ,("key_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]]) - ,("keys" , []) - ,("managehome" , [string, defaultvalue "false", values ["true","false"]]) - ,("membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]]) - ,("name" , [nameval]) - ,("password" , [string]) - ,("password_max_age" , [integer]) - ,("password_min_age" , [integer]) - ,("profile_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]]) - ,("profiles" , [rarray,strings]) - ,("project" , [string]) - ,("provider" , [string, values ["aix","directoryservice","hpuxuseradd","useradd","ldap","pw","user_role_add","window_adsi"]]) - ,("role_membership" , [string, defaultvalue "minimum", values ["inclusive","minimum"]]) - ,("roles" , [rarray,strings]) - ,("salt" , [string]) - ,("shell" , [string, fullyQualified, noTrailingSlash]) - ,("system" , [string, defaultvalue "false", values ["true","false"]]) - ,("uid" , [integer]) - ] diff --git a/src/Puppet/NativeTypes/ZoneRecord.hs b/src/Puppet/NativeTypes/ZoneRecord.hs deleted file mode 100644 --- a/src/Puppet/NativeTypes/ZoneRecord.hs +++ /dev/null @@ -1,38 +0,0 @@ -module Puppet.NativeTypes.ZoneRecord (nativeZoneRecord) where - -import Puppet.Prelude - -import Puppet.Interpreter.Types -import Puppet.NativeTypes.Helpers - -nativeZoneRecord :: (NativeTypeName, NativeTypeMethods) -nativeZoneRecord = ("zone_record", nativetypemethods parameterfunctions validateMandatories) - --- Autorequires: If Puppet is managing the user or group that owns a file, the file resource will autorequire them. --- If Puppet is managing any parent directories of a file, the file resource will autorequire them. -parameterfunctions :: [(Text, [Text -> NativeTypeValidate])] -parameterfunctions = - [("name" , [nameval]) - ,("owner" , [string]) - ,("dest" , [string]) - ,("ensure" , [defaultvalue "present", string, values ["present","absent"]]) - ,("rtype" , [string, defaultvalue "A", values ["SOA", "A", "AAAA", "MX", "NS", "CNAME", "PTR", "SRV"]]) - ,("rclass" , [defaultvalue "IN", string]) - ,("ttl" , [defaultvalue "2d", string]) - ,("target" , [string, mandatory]) - ,("nsname" , [string]) - ,("serial" , [string]) - ,("slave_refresh" , [string]) - ,("slave_retry" , [string]) - ,("slave_expiration" , [string]) - ,("min_ttl" , [string]) - ,("email" , [string]) - ] - -validateMandatories :: NativeTypeValidate -validateMandatories res = case res ^. rattributes . at "rtype" of - Nothing -> perror "The rtype parameter is mandatory." - Just (PString "SOA") -> foldM (flip mandatory) res ["nsname", "email", "serial", "slave_refresh", "slave_retry", "slave_expiration", "min_ttl"] - Just (PString "NS") -> foldM (flip mandatory) res ["owner", "rclass", "rtype", "dest"] - Just (PString _) -> foldM (flip mandatory) res ["owner", "rclass", "rtype", "dest", "ttl"] - Just x -> perror $ "Can't use this for the rtype parameter" <+> pretty x diff --git a/src/Puppet/OptionalTests.hs b/src/Puppet/OptionalTests.hs deleted file mode 100644 --- a/src/Puppet/OptionalTests.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE LambdaCase #-} --- | The module works in IO and throws a 'PrettyError' exception at each failure. --- These exceptions can be caught (see the exceptions package). -module Puppet.OptionalTests (testCatalog) where - -import Puppet.Prelude - -import Control.Monad.Catch (throwM) -import qualified Data.HashSet as HS -import qualified Data.Text as Text -import System.Posix.Files (fileExist) - -import Puppet.Interpreter.Types -import Puppet.Lens (_PString) -import Puppet.PP -import Puppet.Preferences - - --- | Entry point for all optional tests -testCatalog :: Preferences IO -> FinalCatalog -> IO () -testCatalog prefs c = - testFileSources (prefs ^. prefPuppetPaths.baseDir) c - *> testUsersGroups (prefs ^. prefKnownusers) (prefs ^. prefKnowngroups) c - --- | Tests that all users and groups are defined -testUsersGroups :: [Text] -> [Text] -> FinalCatalog -> IO () -testUsersGroups kusers kgroups c = do - let users = HS.fromList $ "" : "0" : map (view (rid . iname)) (getResourceFrom "user") ++ kusers - groups = HS.fromList $ "" : "0" : map (view (rid . iname)) (getResourceFrom "group") ++ kgroups - checkResource lu lg = mapM_ (checkResource' lu lg) - checkResource' lu lg res = do - let msg att name = align (vsep [ "Resource" <+> ttext (res^.rid.itype) - <+> ttext (res^.rid.iname) <+> showPos (res^.rpos._1) - , "references the unknown" <+> string att <+> squotes (ttext name)]) - <> line - case lu of - Just lu' -> do - let u = res ^. rattributes . lu' . _PString - unless (HS.member u users) $ throwM $ PrettyError (msg "user" u) - Nothing -> pure () - case lg of - Just lg' -> do - let g = res ^. rattributes . lg' . _PString - unless (HS.member g groups) $ throwM $ PrettyError (msg "group" g) - Nothing -> pure () - do - checkResource (Just $ ix "owner") (Just $ ix "group") (getResourceFrom "file") - checkResource (Just $ ix "user") (Just $ ix "group") (getResourceFrom "exec") - checkResource (Just $ ix "user") Nothing (getResourceFrom "cron") - checkResource (Just $ ix "user") Nothing (getResourceFrom "ssh_authorized_key") - checkResource (Just $ ix "user") Nothing (getResourceFrom "ssh_authorized_key_secure") - checkResource Nothing (Just $ ix "gid") (getResourceFrom "users") - where - getResourceFrom t = c ^.. traverse . filtered (\r -> r ^. rid . itype == t && r ^. rattributes . at "ensure" /= Just "absent") - --- | Test source for every file resources in the catalog. -testFileSources :: FilePath -> FinalCatalog -> IO () -testFileSources basedir c = do - let getfiles = filter presentFile . toList - presentFile r = r ^. rid . itype == "file" - && (r ^. rattributes . at "ensure") `elem` [Nothing, Just "present"] - && r ^. rattributes . at "source" /= Just PUndef - getsource = mapMaybe (\r -> (,) <$> pure r <*> r ^. rattributes . at "source") - checkAllSources basedir $ (getsource . getfiles) c - --- | Check source for all file resources and append failures along. -checkAllSources :: FilePath -> [(Resource, PValue)] -> IO () -checkAllSources fp fs = go fs [] - where - go ((res, filesource):xs) es = - runExceptT (checkFile fp filesource) >>= \case - Right () -> go xs es - Left err -> go xs ((PrettyError $ "Could not find " <+> pretty filesource <> semi - <+> align (vsep [getError err, showPos (res^.rpos^._1)])):es) - go [] [] = pure () - go [] es = traverse_ throwM es - -testFile :: FilePath -> ExceptT PrettyError IO () -testFile fp = do - p <- liftIO (fileExist fp) - unless p (throwE $ PrettyError $ "searched in" <+> squotes (string fp)) - --- | Only test the `puppet:///` protocol (files managed by the puppet server) --- we don't test absolute path (puppet client files) -checkFile :: FilePath -> PValue -> ExceptT PrettyError IO () -checkFile basedir (PString f) = case Text.stripPrefix "puppet:///" f of - Just stringdir -> case Text.splitOn "/" stringdir of - ("modules":modname:rest) -> testFile (basedir <> "/modules/" <> toS modname <> "/files/" <> toS (Text.intercalate "/" rest)) - ("files":rest) -> testFile (basedir <> "/files/" <> toS (Text.intercalate "/" rest)) - ("private":_) -> pure () - _ -> throwE (PrettyError $ "Invalid file source:" <+> ttext f) - Nothing -> return () --- source is always an array of possible paths. We only fails if none of them check. -checkFile basedir (PArray xs) = asum [checkFile basedir x | x <- toList xs] -checkFile _ x = throwE (PrettyError $ "Source was not a string, but" <+> pretty x) diff --git a/src/Puppet/PP.hs b/src/Puppet/PP.hs deleted file mode 100644 --- a/src/Puppet/PP.hs +++ /dev/null @@ -1,32 +0,0 @@ -module Puppet.PP - ( ttext - , prettyToText - , displayNocolor - -- * Re-exports - , module Text.PrettyPrint.ANSI.Leijen - ) where - -import Puppet.Prelude - -import qualified Data.Text as Text -import Text.PrettyPrint.ANSI.Leijen hiding ((<$>), (<>)) - -ttext :: Text -> Doc -ttext = text . Text.unpack - -prettyToText :: Doc -> Text -prettyToText = Text.pack . prettyToShow - -prettyToShow :: Doc -> String -prettyToShow d = displayS (renderCompact d) "" - --- | A rendering function that drops colors. -displayNocolor :: Doc -> String -displayNocolor = flip displayS "" . dropEffects . renderPretty 0.4 180 - where - dropEffects :: SimpleDoc -> SimpleDoc - dropEffects (SSGR _ x) = dropEffects x - dropEffects (SLine l d) = SLine l (dropEffects d) - dropEffects (SText v t d) = SText v t (dropEffects d) - dropEffects (SChar c d) = SChar c (dropEffects d) - dropEffects x = x diff --git a/src/Puppet/Parser.hs b/src/Puppet/Parser.hs --- a/src/Puppet/Parser.hs +++ b/src/Puppet/Parser.hs @@ -9,32 +9,40 @@ , puppetParser , expression , datatype + -- * Position + , initialPPos + , dummypos + , dummyppos + -- * Pretty Printer + , module Puppet.Parser.PrettyPrinter + , module Puppet.Parser.Types + , module Puppet.Parser.Lens ) where -import Puppet.Prelude hiding (option, try) +import XPrelude.Extra hiding (option, try, many, some) -import Control.Monad (fail) import qualified Data.Char as Char import qualified Data.List as List -import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE import qualified Data.Maybe.Strict as S import qualified Data.Scientific as Scientific import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text import qualified Data.Vector as V import Text.Megaparsec hiding (token) import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L import Text.Megaparsec.Expr -import Text.Regex.PCRE.ByteString.Utils +import qualified Text.Regex.PCRE.ByteString.Utils as Regex +import Puppet.Language +import Puppet.Parser.Lens +import Puppet.Parser.PrettyPrinter import Puppet.Parser.Types type Parser = Parsec Void Text -- | Run a puppet parser against some 'Text' input. -runPParser :: String -> Text -> Either (ParseError Char Void) (V.Vector Statement) +runPParser :: String -> Text -> Either (ParseError Char Void) (Vector Statement) runPParser = parse puppetParser someSpace :: Parser () @@ -73,37 +81,38 @@ sepComma1 p = p `sepEndBy1` comma -- | Parse a collection of puppet 'Statement'. -puppetParser :: Parser (V.Vector Statement) +puppetParser :: Parser (Vector Statement) puppetParser = optional someSpace >> statementList -- | Parse a puppet 'Expression'. expression :: Parser Expression -expression = condExpression - <|> makeExprParser (token terminal) expressionTable - "expression" - where - condExpression = do - selectedExpression <- try $ do - trm <- token terminal - lookups <- optional indexLookupChain - symbolic '?' - return $ maybe trm ($ trm) lookups - let cas = do - c <- (SelectorDefault <$ symbol "default") -- default case - <|> fmap SelectorType (try datatype) - <|> fmap SelectorValue - ( fmap UVariableReference variableReference - <|> fmap UBoolean puppetBool - <|> (UUndef <$ symbol "undef") - <|> literalValue - <|> fmap UInterpolable interpolableString - <|> (URegexp <$> termRegexp) - ) - void $ symbol "=>" - e <- expression - return (c :!: e) - cases <- braces (sepComma1 cas) - return (ConditionalValue selectedExpression (V.fromList cases)) +expression = + condExpression + <|> makeExprParser (token terminal) expressionTable + "expression" + where + condExpression = do + selectedExpression <- try $ do + trm <- token terminal + lookups <- optional indexLookupChain + symbolic '?' + return $ maybe trm ($ trm) lookups + let cas = do + c <- (SelectorDefault <$ symbol "default") -- default case + <|> fmap SelectorType (try datatype) + <|> fmap SelectorValue + ( fmap UVariableReference variableReference + <|> fmap UBoolean puppetBool + <|> (UUndef <$ symbol "undef") + <|> literalValue + <|> fmap UInterpolable interpolableString + <|> (URegexp <$> termRegexp) + ) + void $ symbol "=>" + e <- expression + return (c :!: e) + cases <- braces (sepComma1 cas) + return (ConditionalValue selectedExpression (V.fromList cases)) variable :: Parser Expression variable = Terminal . UVariableReference <$> variableReference @@ -123,15 +132,16 @@ identl :: Parser Char -> Parser Char -> Parser Text identl fstl nxtl = do - f <- fstl - nxt <- token $ many nxtl - return $ Text.pack $ f : nxt + f <- fstl + nxt <- token $ many nxtl + return $ Text.pack $ f : nxt operator :: Text -> Parser () operator = void . try . symbol reserved :: Text -> Parser () -reserved s = try $ do +reserved s = + try $ do void (string s) notFollowedBy (satisfy identifierPart) someSpace @@ -182,20 +192,20 @@ variableReference :: Parser Text variableReference = char '$' *> variableName -interpolableString :: Parser (V.Vector Expression) +interpolableString :: Parser (Vector Expression) interpolableString = V.fromList <$> between (char '"') (symbolic '"') ( many (interpolableVariableReference <|> doubleQuotedStringContent <|> fmap (Terminal . UString . Text.singleton) (char '$')) ) where doubleQuotedStringContent = Terminal . UString . Text.pack . concat <$> - some ((char '\\' *> fmap stringEscape anyChar) <|> some (noneOf [ '"', '\\', '$' ])) - stringEscape :: Char -> String - stringEscape 'n' = "\n" - stringEscape 't' = "\t" - stringEscape 'r' = "\r" - stringEscape '"' = "\"" - stringEscape '\\' = "\\" - stringEscape '$' = "$" - stringEscape x = ['\\',x] + some ((char '\\' *> fmap escaper anyChar) <|> some (noneOf [ '"', '\\', '$' ])) + escaper :: Char -> String + escaper 'n' = "\n" + escaper 't' = "\t" + escaper 'r' = "\r" + escaper '"' = "\"" + escaper '\\' = "\\" + escaper '$' = "$" + escaper x = ['\\',x] -- this is specialized because we can't be "tokenized" here variableAccept x = Char.isAsciiLower x || Char.isAsciiUpper x || Char.isDigit x || x == '_' rvariableName = do @@ -250,7 +260,7 @@ acceptable x = Char.isAsciiLower x || Char.isAsciiUpper x || Char.isDigit x || (x == '_') || (x == '-') -- The first argument defines if non-parenthesized arguments are acceptable -genFunctionCall :: Bool -> Parser (Text, V.Vector Expression) +genFunctionCall :: Bool -> Parser (Text, Vector Expression) genFunctionCall nonparens = do fname <- moduleName "Function name" -- this is a hack. Contrary to what the documentation says, @@ -290,7 +300,7 @@ <|> fmap Terminal literalValue compileRegexp :: Text -> Parser CompRegex -compileRegexp p = case compile' compBlank execBlank (Text.encodeUtf8 p) of +compileRegexp p = case Regex.compile' Regex.compBlank Regex.execBlank (encodeUtf8 p) of Right r -> return $ CompRegex p r Left ms -> fail ("Can't parse regexp /" ++ Text.unpack p ++ "/ : " ++ show ms) @@ -347,12 +357,13 @@ varAssign :: Parser VarAssignDecl varAssign = do p <- getPosition + mt <- optional datatype v <- variableReference void $ symbolic '=' e <- expression when (Text.all Char.isDigit v) (fail "Can't assign fully numeric variables") pe <- getPosition - return (VarAssignDecl v e (p :!: pe)) + return (VarAssignDecl mt v e (p :!: pe)) nodeDecl :: Parser [NodeDecl] nodeDecl = do @@ -379,7 +390,7 @@ pe <- getPosition return (DefineDecl name params st (p :!: pe)) -puppetClassParameters :: Parser (V.Vector (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression))) +puppetClassParameters :: Parser (Vector (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression))) puppetClassParameters = V.fromList <$> parens (sepComma var) where toStrictMaybe (Just x) = S.Just x @@ -391,7 +402,7 @@ df <- toStrictMaybe <$> optional (symbolic '=' *> expression) return (n :!: tp :!: df) -puppetIfStyleCondition :: Parser (Pair Expression (V.Vector Statement)) +puppetIfStyleCondition :: Parser (Pair Expression (Vector Statement)) puppetIfStyleCondition = (:!:) <$> expression <*> braces statementList unlessCondition :: Parser ConditionalDecl @@ -556,10 +567,10 @@ return [ ResOverrideDecl restype n assignments (p :!: pe) | n <- names ] -- | Heterogeneous chain (interleaving resource declarations with --- resource references)needs to be supported: +-- resource references) needs to be supported: -- --- class { 'docker::service': } -> --- Class['docker'] +-- class { 'docker::service': } -> +-- Class['docker'] chainableResources :: Parser [Statement] chainableResources = do let withresname = do @@ -713,7 +724,7 @@ <|> reserved "Nginx::ErrorLogSeverity" $> UDTData -statementList :: Parser (V.Vector Statement) +statementList :: Parser (Vector Statement) statementList = (V.fromList . concat) <$> many statement lambdaCall :: Parser HOLambdaCall @@ -745,3 +756,15 @@ [a] -> return (BPSingle a) [a,b] -> return (BPPair a b) _ -> fail "Invalid number of variables between the pipes" + +-- | Generates an initial position based on a filename. +initialPPos :: Text -> PPosition +initialPPos x = + let i = initialPos (toS x) + in (i :!: i) + +dummyppos :: PPosition +dummyppos = initialPPos "dummy" + +dummypos :: Position +dummypos = initialPos "dummy" diff --git a/src/Puppet/Parser/Lens.hs b/src/Puppet/Parser/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Parser/Lens.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} +module Puppet.Parser.Lens + ( + -- * Prism for 'Statement's + _Statements + , _ResDecl + , _ResDefaultDecl + , _ResOverrDecl + , _ResCollDecl + , _ConditionalDecl + , _ClassDecl + , _DefineDecl + , _NodeDecl + , _VarAssignDecl + , _MainFuncDecl + , _HigherOrderLambdaDecl + , _DepDecl + -- * Prism for 'Expression's + , _Equal + , _Different + , _Not + , _And + , _Or + , _LessThan + , _MoreThan + , _LessEqualThan + , _MoreEqualThan + , _RegexMatch + , _NotRegexMatch + , _Contains + , _Addition + , _Substraction + , _Division + , _Multiplication + , _Modulo + , _RightShift + , _LeftShift + , _Lookup + , _Negate + , _ConditionalValue + , _FunctionApplication + , _Terminal + ) where + + +import XPrelude + +import qualified Data.Vector as V + +import Puppet.Parser.Types + +makePrisms ''Expression + +_ResDecl :: Prism' Statement ResDecl +_ResDecl = + prism ResourceDeclaration $ \x -> + case x of + ResourceDeclaration a -> Right a + _ -> Left x + +_ResDefaultDecl :: Prism' Statement ResDefaultDecl +_ResDefaultDecl = + prism ResourceDefaultDeclaration $ \x -> + case x of + ResourceDefaultDeclaration a -> Right a + _ -> Left x + +_ResOverrDecl :: Prism' Statement ResOverrideDecl +_ResOverrDecl = + prism ResourceOverrideDeclaration $ \x -> + case x of + ResourceOverrideDeclaration a -> Right a + _ -> Left x + +_ResCollDecl :: Prism' Statement ResCollDecl +_ResCollDecl = + prism ResourceCollectionDeclaration $ \x -> + case x of + ResourceCollectionDeclaration a -> Right a + _ -> Left x + +_ConditionalDecl :: Prism' Statement ConditionalDecl +_ConditionalDecl = + prism ConditionalDeclaration $ \x -> + case x of + ConditionalDeclaration a -> Right a + _ -> Left x + +_ClassDecl :: Prism' Statement ClassDecl +_ClassDecl = + prism ClassDeclaration $ \x -> + case x of + ClassDeclaration a -> Right a + _ -> Left x + +_DefineDecl :: Prism' Statement DefineDecl +_DefineDecl = + prism DefineDeclaration $ \x -> + case x of + DefineDeclaration a -> Right a + _ -> Left x + +_NodeDecl :: Prism' Statement NodeDecl +_NodeDecl = + prism NodeDeclaration $ \x -> + case x of + NodeDeclaration a -> Right a + _ -> Left x + +_VarAssignDecl :: Prism' Statement VarAssignDecl +_VarAssignDecl = + prism VarAssignmentDeclaration $ \x -> + case x of + VarAssignmentDeclaration a -> Right a + _ -> Left x + +_MainFuncDecl :: Prism' Statement MainFuncDecl +_MainFuncDecl = + prism MainFunctionDeclaration $ \x -> + case x of + MainFunctionDeclaration a -> Right a + _ -> Left x + +_HigherOrderLambdaDecl :: Prism' Statement HigherOrderLambdaDecl +_HigherOrderLambdaDecl = + prism HigherOrderLambdaDeclaration $ \x -> + case x of + HigherOrderLambdaDeclaration a -> Right a + _ -> Left x + +_DepDecl :: Prism' Statement DepDecl +_DepDecl = + prism DependencyDeclaration $ \x -> + case x of + DependencyDeclaration a -> Right a + _ -> Left x + +_TopContainer :: Prism' Statement (V.Vector Statement, Statement) +_TopContainer = + prism (uncurry TopContainer) $ \x -> + case x of + TopContainer vs s -> Right (vs, s) + _ -> Left x + +_Statements :: Lens' Statement [Statement] +_Statements = + lens (V.toList . sget) (\s v -> sset s (V.fromList v)) + where + sget :: Statement -> V.Vector Statement + sget (ClassDeclaration (ClassDecl _ _ _ s _)) = s + sget (DefineDeclaration (DefineDecl _ _ s _)) = s + sget (NodeDeclaration (NodeDecl _ s _ _)) = s + sget (TopContainer s _) = s + sget (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall _ _ _ s _) _)) = s + sget _ = V.empty + sset :: Statement -> V.Vector Statement -> Statement + sset (ClassDeclaration (ClassDecl n args inh _ p)) s = ClassDeclaration (ClassDecl n args inh s p) + sset (NodeDeclaration (NodeDecl ns _ nd' p)) s = NodeDeclaration (NodeDecl ns s nd' p) + sset (DefineDeclaration (DefineDecl n args _ p)) s = DefineDeclaration (DefineDecl n args s p) + sset (TopContainer _ p) s = TopContainer s p + sset (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall t e pr _ e2) p)) s = + HigherOrderLambdaDeclaration (HigherOrderLambdaDecl (HOLambdaCall t e pr s e2) p) + sset x _ = x diff --git a/src/Puppet/Parser/PrettyPrinter.hs b/src/Puppet/Parser/PrettyPrinter.hs --- a/src/Puppet/Parser/PrettyPrinter.hs +++ b/src/Puppet/Parser/PrettyPrinter.hs @@ -1,7 +1,10 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module Puppet.Parser.PrettyPrinter where +module Puppet.Parser.PrettyPrinter + ( ppStatements + ) where -import Puppet.Prelude hiding (empty, (<$>)) +import XPrelude.Extra hiding ((<$>)) +import XPrelude.PP import qualified Data.Maybe.Strict as S import qualified Data.Text as Text @@ -9,232 +12,215 @@ import qualified Data.Vector as V import Text.PrettyPrint.ANSI.Leijen ((<$>)) +import Puppet.Language import Puppet.Parser.Types -import Puppet.PP -capitalize :: Text -> Doc -capitalize = dullyellow . text . Text.unpack . capitalizeRT -parensList :: Pretty a => V.Vector a -> Doc +parensList :: Pretty a => Vector a -> Doc parensList = tupled . fmap pretty . V.toList -hashComma :: (Pretty a, Pretty b) => V.Vector (Pair a b) -> Doc +hashComma :: (Pretty a, Pretty b) => Vector (Pair a b) -> Doc hashComma = encloseSep lbrace rbrace comma . fmap showC . V.toList - where - showC (a :!: b) = pretty a <+> text "=>" <+> pretty b + where + showC (a :!: b) = pretty a <+> "=>" <+> pretty b --- Extremely hacky escaping system -stringEscape :: Text -> Text -stringEscape = Text.concatMap escapeChar - where - escapeChar '"' = "\\\"" - escapeChar '\n' = "\\n" - escapeChar '\t' = "\\t" - escapeChar '\r' = "\\r" - escapeChar x = Text.singleton x -{-# INLINE stringEscape #-} instance Pretty UDataType where pretty t = case t of - UDTType -> "Type" - UDTString ma mb -> bounded "String" ma mb - UDTInteger ma mb -> bounded "Integer" ma mb - UDTFloat ma mb -> bounded "Float" ma mb - UDTBoolean -> "Boolean" - UDTArray dt mi mmx -> "Array" <> list (pretty dt : pretty mi : maybe [] (pure . pretty) mmx) - UDTHash kt dt mi mmx -> "Hash" <> list (pretty kt : pretty dt : pretty mi : maybe [] (pure . pretty) mmx) - UDTUndef -> "Undef" - UDTScalar -> "Scalar" - UDTData -> "Data" - UDTOptional o -> "Optional" <> brackets (pretty o) - UNotUndef -> "NotUndef" - UDTVariant vs -> "Variant" <> list (foldMap (pure . pretty) vs) - UDTPattern vs -> "Pattern" <> list (foldMap (pure . pretty) vs) - UDTEnum tx -> "Enum" <> list (foldMap (pure . pretty) tx) - UDTAny -> "Any" - UDTCollection -> "Collection" + UDTType -> "Type" + UDTString ma mb -> bounded "String" ma mb + UDTInteger ma mb -> bounded "Integer" ma mb + UDTFloat ma mb -> bounded "Float" ma mb + UDTBoolean -> "Boolean" + UDTArray dt mi mmx -> "Array" <> list (pretty dt : pretty mi : maybe [] (pure . pretty) mmx) + UDTHash kt dt mi mmx -> "Hash" <> list (pretty kt : pretty dt : pretty mi : maybe [] (pure . pretty) mmx) + UDTUndef -> "Undef" + UDTScalar -> "Scalar" + UDTData -> "Data" + UDTOptional o -> "Optional" <> brackets (pretty o) + UNotUndef -> "NotUndef" + UDTVariant vs -> "Variant" <> list (foldMap (pure . pretty) vs) + UDTPattern vs -> "Pattern" <> list (foldMap (pure . pretty) vs) + UDTEnum tx -> "Enum" <> list (foldMap (pure . pretty) tx) + UDTAny -> "Any" + UDTCollection -> "Collection" where bounded :: (Pretty a, Pretty b) => Doc -> Maybe a -> Maybe b -> Doc bounded s ma mb = s <> case (ma, mb) of - (Just a, Nothing) -> list [pretty a] - (Just a, Just b) -> list [pretty a, pretty b] - _ -> mempty + (Just a, Nothing) -> list [pretty a] + (Just a, Just b) -> list [pretty a, pretty b] + _ -> mempty instance Pretty Expression where - pretty (Equal a b) = parens (pretty a <+> text "==" <+> pretty b) - pretty (Different a b) = parens (pretty a <+> text "!=" <+> pretty b) - pretty (And a b) = parens (pretty a <+> text "and" <+> pretty b) - pretty (Or a b) = parens (pretty a <+> text "or" <+> pretty b) - pretty (LessThan a b) = parens (pretty a <+> text "<" <+> pretty b) - pretty (MoreThan a b) = parens (pretty a <+> text ">" <+> pretty b) - pretty (LessEqualThan a b) = parens (pretty a <+> text "<=" <+> pretty b) - pretty (MoreEqualThan a b) = parens (pretty a <+> text ">=" <+> pretty b) - pretty (RegexMatch a b) = parens (pretty a <+> text "=~" <+> pretty b) - pretty (NotRegexMatch a b) = parens (pretty a <+> text "!~" <+> pretty b) - pretty (Contains a b) = parens (pretty a <+> text "in" <+> pretty b) - pretty (Addition a b) = parens (pretty a <+> text "+" <+> pretty b) - pretty (Substraction a b) = parens (pretty a <+> text "-" <+> pretty b) - pretty (Division a b) = parens (pretty a <+> text "/" <+> pretty b) - pretty (Multiplication a b) = parens (pretty a <+> text "*" <+> pretty b) - pretty (Modulo a b) = parens (pretty a <+> text "%" <+> pretty b) - pretty (RightShift a b) = parens (pretty a <+> text ">>" <+> pretty b) - pretty (LeftShift a b) = parens (pretty a <+> text "<<" <+> pretty b) - pretty (Lookup a b) = pretty a <> brackets (pretty b) - pretty (ConditionalValue a b) = parens (pretty a <+> text "?" <+> hashComma b) - pretty (Negate a) = text "-" <+> parens (pretty a) - pretty (Not a) = text "!" <+> parens (pretty a) - pretty (Terminal a) = pretty a - pretty (FunctionApplication e1 e2) = parens (pretty e1) <> text "." <> pretty e2 + pretty (Equal a b) = parens (pretty a <+> "==" <+> pretty b) + pretty (Different a b) = parens (pretty a <+>"!=" <+> pretty b) + pretty (And a b) = parens (pretty a <+> "and" <+> pretty b) + pretty (Or a b) = parens (pretty a <+> "or" <+> pretty b) + pretty (LessThan a b) = parens (pretty a <+> pretty '<' <+> pretty b) + pretty (MoreThan a b) = parens (pretty a <+> pretty '>' <+> pretty b) + pretty (LessEqualThan a b) = parens (pretty a <+> "<=" <+> pretty b) + pretty (MoreEqualThan a b) = parens (pretty a <+> ">=" <+> pretty b) + pretty (RegexMatch a b) = parens (pretty a <+> "=~" <+> pretty b) + pretty (NotRegexMatch a b) = parens (pretty a <+> "!~" <+> pretty b) + pretty (Contains a b) = parens (pretty a <+> "in" <+> pretty b) + pretty (Addition a b) = parens (pretty a <+> pretty '+' <+> pretty b) + pretty (Substraction a b) = parens (pretty a <+> pretty '-' <+> pretty b) + pretty (Division a b) = parens (pretty a <+> pretty '/' <+> pretty b) + pretty (Multiplication a b) = parens (pretty a <+> pretty '*' <+> pretty b) + pretty (Modulo a b) = parens (pretty a <+> pretty '%' <+> pretty b) + pretty (RightShift a b) = parens (pretty a <+> ">>" <+> pretty b) + pretty (LeftShift a b) = parens (pretty a <+> "<<" <+> pretty b) + pretty (Lookup a b) = pretty a <> brackets (pretty b) + pretty (ConditionalValue a b) = parens (pretty a <+> pretty '?' <+> hashComma b) + pretty (Negate a) = pretty '-' <+> parens (pretty a) + pretty (Not a) = pretty '!' <+> parens (pretty a) + pretty (Terminal a) = pretty a + pretty (FunctionApplication e1 e2) = parens (pretty e1) <> "." <> pretty e2 instance Pretty LambdaFunc where - pretty LambEach = bold $ red $ text "each" - pretty LambMap = bold $ red $ text "map" - pretty LambReduce = bold $ red $ text "reduce" - pretty LambFilter = bold $ red $ text "filter" - pretty LambSlice = bold $ red $ text "slice" - pretty LambLookup = bold $ red $ text "lookup" + pretty LambEach = bold $ red "each" + pretty LambMap = bold $ red "map" + pretty LambReduce = bold $ red "reduce" + pretty LambFilter = bold $ red "filter" + pretty LambSlice = bold $ red "slice" + pretty LambLookup = bold $ red "lookup" instance Pretty LambdaParameters where - pretty b = magenta (char '|') <+> vars <+> magenta (char '|') - where - pmspace = foldMap ((<> " ") . pretty) - vars = case b of - BPSingle (LParam mt v) -> pmspace mt <> pretty (UVariableReference v) - BPPair (LParam mt1 v1) (LParam mt2 v2) -> pmspace mt1 <> pretty (UVariableReference v1) <> comma <+> pmspace mt2 <> pretty (UVariableReference v2) + pretty b = magenta (pretty '|') <+> vars <+> magenta (pretty '|') + where + pmspace = foldMap ((<> " ") . pretty) + vars = + case b of + BPSingle (LParam mt v) -> pmspace mt <> pretty (UVariableReference v) + BPPair (LParam mt1 v1) (LParam mt2 v2) -> + pmspace mt1 <> pretty (UVariableReference v1) <> comma <+> pmspace mt2 <> pretty (UVariableReference v2) instance Pretty SearchExpression where - pretty (EqualitySearch t e) = text (Text.unpack t) <+> text "==" <+> pretty e - pretty (NonEqualitySearch t e) = text (Text.unpack t) <+> text "!=" <+> pretty e - pretty AlwaysTrue = empty - pretty (AndSearch s1 s2) = parens (pretty s1) <+> text "and" <+> parens (pretty s2) - pretty (OrSearch s1 s2) = parens (pretty s1) <+> text "and" <+> parens (pretty s2) + pretty (EqualitySearch t e) = ppline t <+> "==" <+> pretty e + pretty (NonEqualitySearch t e) = ppline t <+> "!=" <+> pretty e + pretty AlwaysTrue = mempty + pretty (AndSearch s1 s2) = parens (pretty s1) <+> "and" <+> parens (pretty s2) + pretty (OrSearch s1 s2) = parens (pretty s1) <+> "and" <+> parens (pretty s2) instance Pretty UnresolvedValue where - pretty (UBoolean True) = dullmagenta $ text "true" - pretty (UBoolean False) = dullmagenta $ text "false" - pretty (UString s) = char '"' <> dullcyan (ttext (stringEscape s)) <> char '"' - pretty (UNumber n) = cyan (ttext (scientific2text n)) - pretty (UInterpolable v) = char '"' <> hcat (map specific (V.toList v)) <> char '"' - where - specific (Terminal (UString s)) = dullcyan (ttext (stringEscape s)) - specific (Terminal (UVariableReference vr)) = dullblue (text "${" <> text (Text.unpack vr) <> char '}') - specific (Lookup (Terminal (UVariableReference vr)) (Terminal x)) = dullblue (text "${" <> text (Text.unpack vr) <> char '[' <> pretty x <> "]}") - specific x = bold (red (pretty x)) - pretty UUndef = dullmagenta (text "undef") - pretty (UResourceReference t n) = capitalize t <> brackets (pretty n) - pretty (UArray v) = list (map pretty (V.toList v)) - pretty (UHash g) = hashComma g - pretty (URegexp r) = pretty r - pretty (UVariableReference v) = dullblue (char '$' <> text (Text.unpack v)) - pretty (UFunctionCall f args) = showFunc f args - pretty (UHOLambdaCall c) = pretty c - pretty (UDataType dt) = pretty dt + pretty (UBoolean True) = dullmagenta $ "true" + pretty (UBoolean False) = dullmagenta $ "false" + pretty (UString s) = pretty '"' <> dullcyan (ppline (stringEscape s)) <> pretty '"' + pretty (UNumber n) = cyan (ppline (scientific2text n)) + pretty (UInterpolable v) = pretty '"' <> hcat (map specific (V.toList v)) <> pretty '"' + where + specific (Terminal (UString s)) = dullcyan (ppline (stringEscape s)) + specific (Terminal (UVariableReference vr)) = dullblue ("${" <> ppline vr <> "}") + specific (Lookup (Terminal (UVariableReference vr)) (Terminal x)) = + dullblue ("${" <> ppline vr <> "[" <> pretty x <> "]}") + specific x = bold (red (pretty x)) + pretty UUndef = dullmagenta (ppline "undef") + pretty (UResourceReference t n) = capitalizeR t <> brackets (pretty n) + pretty (UArray v) = list (map pretty (V.toList v)) + pretty (UHash g) = hashComma g + pretty (URegexp r) = pretty r + pretty (UVariableReference v) = dullblue (pretty '$' <> ppline v) + pretty (UFunctionCall f args) = showFunc f args + pretty (UHOLambdaCall c) = pretty c + pretty (UDataType dt) = pretty dt -instance Pretty CompRegex where - pretty (CompRegex r _) = char '/' <> text (Text.unpack r) <> char '/' instance Pretty HOLambdaCall where - pretty (HOLambdaCall hf me bp stts mee) = pretty hf <> mme <+> pretty bp <+> nest 2 (char '{' <$> ppStatements stts <> mmee) <$> char '}' - where - mme = case me of - S.Just x -> mempty <+> pretty x - S.Nothing -> mempty - mmee = case mee of - S.Just x -> mempty pretty x - S.Nothing -> mempty + pretty (HOLambdaCall hf me bp stts mee) = + pretty hf <> mme <+> pretty bp <+> nest 2 (pretty '{' <> line <> ppStatements stts <> mmee) <$> pretty '}' + where + mme = + case me of + S.Just x -> mempty <+> pretty x + S.Nothing -> mempty + mmee = + case mee of + S.Just x -> mempty pretty x + S.Nothing -> mempty instance Pretty SelectorCase where - pretty SelectorDefault = dullmagenta (text "default") - pretty (SelectorType t) = pretty t - pretty (SelectorValue v) = pretty v - -instance Pretty LinkType where - pretty RNotify = "~>" - pretty RRequire = "<-" - pretty RBefore = "->" - pretty RSubscribe = "<~" + pretty SelectorDefault = dullmagenta "default" + pretty (SelectorType t) = pretty t + pretty (SelectorValue v) = pretty v instance Pretty ArrowOp where - pretty AssignArrow = "=>" - pretty AppendArrow = "+>" + pretty AssignArrow = "=>" + pretty AppendArrow = "+>" -showPos :: Position -> Doc -showPos p = green (char '#' <+> string (show p)) -showPPos :: PPosition -> Doc -showPPos p = green (char '#' <+> string (show (Tuple.fst p))) - -showAss :: V.Vector AttributeDecl -> Doc -showAss vx = folddoc (\a b -> a <> char ',' <$> b) prettyDecl (V.toList vx) - where - folddoc _ _ [] = empty - folddoc acc docGen (x:xs) = foldl acc (docGen x) (map docGen xs) - maxlen = maximum (fmap (\(AttributeDecl k _ _) -> Text.length k) vx) - prettyDecl (AttributeDecl k op v) = dullblue (fill maxlen (ttext k)) <+> pretty op <+> pretty v +showAss :: Vector AttributeDecl -> Doc +showAss vx = folddoc (\a b -> a <> pretty ',' <$> b) prettyDecl (V.toList vx) + where + folddoc _ _ [] = mempty + folddoc acc docGen (x:xs) = foldl acc (docGen x) (map docGen xs) + maxlen = maximum (fmap (\(AttributeDecl k _ _) -> Text.length k) vx) + prettyDecl (AttributeDecl k op v) = dullblue (fill maxlen (ppline k)) <+> pretty op <+> pretty v -showArgs :: V.Vector (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression)) -> Doc +showArgs :: Vector (Pair (Pair Text (S.Maybe UDataType)) (S.Maybe Expression)) -> Doc showArgs vec = tupled (map ra lst) - where - lst = V.toList vec - maxlen = maximum (map (Text.length . Tuple.fst . Tuple.fst) lst) - ra (argname :!: mtype :!: rval) - = dullblue (char '$' <> foldMap (\t -> pretty t <+> empty) mtype - <> fill maxlen (text (Text.unpack argname))) - <> foldMap (\v -> empty <+> char '=' <+> pretty v) rval + where + lst = V.toList vec + maxlen = maximum (map (Text.length . Tuple.fst . Tuple.fst) lst) + ra (argname :!: mtype :!: rval) = + dullblue (pretty '$' <> foldMap (\t -> pretty t <+> mempty) mtype + <> fill maxlen (ppline argname)) + <> foldMap (\v -> mempty <+> pretty '=' <+> pretty v) rval -showFunc :: Text -> V.Vector Expression -> Doc -showFunc funcname args = bold (red (text (Text.unpack funcname))) <> parensList args -braceStatements :: V.Vector Statement -> Doc -braceStatements stts = nest 2 (char '{' <$> ppStatements stts) <$> char '}' +showFunc :: Text -> Vector Expression -> Doc +showFunc funcname args = bold (red (ppline funcname)) <> parensList args +braceStatements :: Vector Statement -> Doc +braceStatements stts = nest 2 (pretty '{' <$> ppStatements stts) <$> pretty '}' + instance Pretty NodeDesc where - pretty NodeDefault = dullmagenta (text "default") - pretty (NodeName n) = pretty (UString n) - pretty (NodeMatch r) = pretty (URegexp r) + pretty NodeDefault = dullmagenta "default" + pretty (NodeName n) = pretty (UString n) + pretty (NodeMatch r) = pretty (URegexp r) instance Pretty Statement where pretty (HigherOrderLambdaDeclaration (HigherOrderLambdaDecl c p)) = pretty c <+> showPPos p pretty (ConditionalDeclaration (ConditionalDecl conds p)) - | V.null conds = empty - | otherwise = text "if" <+> pretty firstcond <+> showPPos p <+> braceStatements firststts <$> vcat (map rendernexts xs) + | V.null conds = mempty + | otherwise = "if" <+> pretty firstcond <+> showPPos p <+> braceStatements firststts <$> vcat (map rendernexts xs) where ( (firstcond :!: firststts) : xs ) = V.toList conds - rendernexts (Terminal (UBoolean True) :!: st) = text "else" <+> braceStatements st - rendernexts (c :!: st) | V.null st = empty - | otherwise = text "elsif" <+> pretty c <+> braceStatements st + rendernexts (Terminal (UBoolean True) :!: st) = "else" <+> braceStatements st + rendernexts (c :!: st) | V.null st = mempty + | otherwise = "elsif" <+> pretty c <+> braceStatements st pretty (MainFunctionDeclaration (MainFuncDecl funcname args p)) = showFunc funcname args <+> showPPos p - pretty (ResourceDefaultDeclaration (ResDefaultDecl rtype defaults p)) = capitalize rtype <+> nest 2 (char '{' <+> showPPos p <$> showAss defaults) <$> char '}' - pretty (ResourceOverrideDeclaration (ResOverrideDecl rtype rnames overs p)) = pretty (UResourceReference rtype rnames) <+> nest 2 (char '{' <+> showPPos p <$> showAss overs) <$> char '}' - pretty (ResourceDeclaration (ResDecl rtype rname args virt p)) = nest 2 (red vrt <> dullgreen (text (Text.unpack rtype)) <+> char '{' <+> showPPos p - <$> nest 2 (pretty rname <> char ':' <$> showAss args)) - <$> char '}' + pretty (ResourceDefaultDeclaration (ResDefaultDecl rtype defaults p)) = capitalizeR rtype <+> nest 2 (pretty '{' <+> showPPos p <$> showAss defaults) <$> pretty '}' + pretty (ResourceOverrideDeclaration (ResOverrideDecl rtype rnames overs p)) = pretty (UResourceReference rtype rnames) <+> nest 2 (pretty '{' <+> showPPos p <$> showAss overs) <$> pretty '}' + pretty (ResourceDeclaration (ResDecl rtype rname args virt p)) = nest 2 (red vrt <> dullgreen (ppline rtype) <+> pretty '{' <+> showPPos p + <$> nest 2 (pretty rname <> pretty ':' <$> showAss args)) + <$> pretty '}' where vrt = case virt of - Normal -> empty - Virtual -> char '@' - Exported -> text "@@" - ExportedRealized -> text "!!" - pretty (DefineDeclaration (DefineDecl cname args stts p)) = dullyellow (text "define") <+> dullgreen (ttext cname) <> showArgs args <+> showPPos p <$> braceStatements stts - pretty (ClassDeclaration (ClassDecl cname args inherit stts p)) = dullyellow (text "class") <+> dullgreen (text (Text.unpack cname)) <> showArgs args <> inheritance <+> showPPos p + Normal -> mempty + Virtual -> pretty '@' + Exported -> "@@" + ExportedRealized -> "!!" + pretty (DefineDeclaration (DefineDecl cname args stts p)) = dullyellow "define" <+> dullgreen (ppline cname) <> showArgs args <+> showPPos p <$> braceStatements stts + pretty (ClassDeclaration (ClassDecl cname args inherit stts p)) = dullyellow "class" <+> dullgreen (ppline cname) <> showArgs args <> inheritance <+> showPPos p <$> braceStatements stts where - inheritance = case inherit of - S.Nothing -> empty - S.Just x -> empty <+> text "inherits" <+> text (Text.unpack x) - pretty (VarAssignmentDeclaration (VarAssignDecl a b p)) = dullblue (char '$' <> text (Text.unpack a)) <+> char '=' <+> pretty b <+> showPPos p - pretty (NodeDeclaration (NodeDecl nodename stmts i p)) = dullyellow (text "node") <+> pretty nodename <> inheritance <+> showPPos p <$> braceStatements stmts + inheritance = case inherit of + S.Nothing -> mempty + S.Just x -> mempty <+> "inherits" <+> ppline x + pretty (VarAssignmentDeclaration (VarAssignDecl mt a b p)) = foldMap (\t -> pretty t <+> mempty) mt <> dullblue (pretty '$' <> ppline a <+> pretty '=' <+> pretty b <+> showPPos p) + pretty (NodeDeclaration (NodeDecl nodename stmts i p)) = dullyellow "node" <+> pretty nodename <> inheritance <+> showPPos p <$> braceStatements stmts where - inheritance = case i of - S.Nothing -> empty - S.Just n -> empty <+> text "inherits" <+> pretty n + inheritance = case i of + S.Nothing -> mempty + S.Just n -> mempty <+> ppline "inherits" <+> pretty n pretty (DependencyDeclaration (DepDecl (st :!: sn) (dt :!: dn) lt p)) = pretty (UResourceReference st sn) <+> pretty lt <+> pretty (UResourceReference dt dn) <+> showPPos p - pretty (TopContainer a b) = text "TopContainer:" <+> braces ( nest 2 (string "TOP" <$> braceStatements a <$> string "STATEMENT" <$> pretty b)) - pretty (ResourceCollectionDeclaration (ResCollDecl coltype restype search overrides p)) = capitalize restype <> enc (pretty search) <+> overs + pretty (TopContainer a b) = "TopContainer:" <+> braces ( nest 2 ("TOP" <$> braceStatements a <$> "STATEMENT" <$> pretty b)) + pretty (ResourceCollectionDeclaration (ResCollDecl coltype restype search overrides p)) = capitalizeR restype <> enc (pretty search) <+> overs where overs | V.null overrides = showPPos p - | otherwise = nest 2 (char '{' <+> showPPos p <$> showAss overrides) <$> char '}' + | otherwise = nest 2 (pretty '{' <+> showPPos p <$> showAss overrides) <$> pretty '}' enc = case coltype of - Collector -> enclose (text "<|") (text "|>") - ExportedCollector -> enclose (text "<<|") (text "|>>") + Collector -> enclose "<|" "|>" + ExportedCollector -> enclose "<<|" "|>>" -ppStatements :: V.Vector Statement -> Doc +-- | Pretty print a series of statements. +ppStatements :: Vector Statement -> Doc ppStatements = vcat . map pretty . V.toList diff --git a/src/Puppet/Parser/Types.hs b/src/Puppet/Parser/Types.hs --- a/src/Puppet/Parser/Types.hs +++ b/src/Puppet/Parser/Types.hs @@ -3,20 +3,7 @@ {-# LANGUAGE TypeFamilies #-} -- | 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 - capitalizeRT, - rel2text, - -- * Types - -- ** Expressions + ( -- ** Expressions Expression(..), SelectorCase(..), UnresolvedValue(..), @@ -35,9 +22,9 @@ UDataType(..), -- ** Search Expressions SearchExpression(..), - -- ** Statements - ArrowOp(..), + -- ** Declaration AttributeDecl(..), + ArrowOp(..), ConditionalDecl(..), ClassDecl(..), ResDefaultDecl(..), @@ -48,62 +35,24 @@ DefineDecl(..), NodeDecl(..), VarAssignDecl(..), - vadname, - vadpos, - vadvalue, MainFuncDecl(..), HigherOrderLambdaDecl(..), ResCollDecl(..) ) where -import Puppet.Prelude hiding (show) +import XPrelude hiding (show) -import Data.Aeson -import qualified Data.Char as Char -import Data.List.NonEmpty (NonEmpty) -import qualified Data.Maybe.Strict as S -import Data.String -import qualified Data.Text as Text -import qualified Data.Vector as V -import qualified GHC.Exts as Exts -import GHC.Show (Show (..)) -import Text.Megaparsec.Pos +import Data.List.NonEmpty (NonEmpty) +import qualified Data.Maybe.Strict as S +import qualified Data.Text as Text +import qualified Data.Vector as V +import qualified GHC.Exts as Exts +import GHC.Show (Show (..)) --- | Properly capitalizes resource types. -capitalizeRT :: Text -> Text -capitalizeRT = Text.intercalate "::" . map capitalize' . Text.splitOn "::" - where - capitalize' :: Text -> Text - capitalize' t | Text.null t = Text.empty - | otherwise = Text.cons (Char.toUpper (Text.head t)) (Text.tail t) +import Puppet.Language --- | 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 String -lSourceName = lens sourceName (\s n -> s { sourceName = n }) - -lSourceLine :: Lens' Position Pos -lSourceLine = lens sourceLine (\s l -> s { sourceLine = l }) - -lSourceColumn :: Lens' Position Pos -lSourceColumn = lens sourceColumn (\s c -> s { sourceColumn = c }) - --- | Generates an initial position based on a filename. -initialPPos :: Text -> PPosition -initialPPos x = - let i = initialPos (toS x) - in (i :!: i) - --- | Generates a 'PPosition' based on a filename and line number. -toPPos :: Text -> Int -> PPosition -toPPos fl ln = - let p = (initialPos (toS fl)) { sourceLine = mkPos $ fromIntegral (max 1 ln) } - in (p :!: p) - -- | /High Order lambdas/. data LambdaFunc = LambEach @@ -149,16 +98,6 @@ | AssignArrow -- ^ `=>` deriving (Show, Eq) -data CompRegex = CompRegex !Text !Regex -instance Show CompRegex where - show (CompRegex t _) = show t -instance Eq CompRegex where - (CompRegex a _) == (CompRegex b _) = a == b -instance FromJSON CompRegex where - parseJSON = panic "Can't deserialize a regular expression" -instance ToJSON CompRegex where - toJSON (CompRegex t _) = toJSON t - -- | An unresolved value, typically the parser's output. data UnresolvedValue = UBoolean !Bool -- ^ Special tokens generated when parsing the @true@ or @false@ literals. @@ -282,44 +221,13 @@ | ExportedCollector deriving (Eq, Show) -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 catalogderiving (Generic, Eq, Show). - deriving (Eq, Show) - data NodeDesc = NodeName !Text | NodeMatch !CompRegex | NodeDefault deriving (Show, Eq) --- | Relationship link type. -data LinkType - = RNotify - | RRequire - | RBefore - | RSubscribe - deriving(Show, Eq,Generic) -instance Hashable LinkType -rel2text :: LinkType -> Text -rel2text RNotify = "notify" -rel2text RRequire = "require" -rel2text RBefore = "before" -rel2text RSubscribe = "subscribe" - -instance FromJSON LinkType where - parseJSON (String "require") = return RRequire - parseJSON (String "notify") = return RNotify - parseJSON (String "subscribe") = return RSubscribe - parseJSON (String "before") = return RBefore - parseJSON _ = panic "invalid linktype" - -instance ToJSON LinkType where - toJSON = String . rel2text - -- | Resource declaration: -- -- @ file { mode => 755} @ @@ -354,7 +262,8 @@ -- | @ $newvar = 'world' @ data VarAssignDecl = VarAssignDecl - { _vadname :: !Text + { _vadtype :: Maybe UDataType + , _vadname :: !Text , _vadvalue :: !Expression , _vadpos :: !PPosition } deriving (Eq, Show) @@ -391,4 +300,3 @@ deriving (Eq, Show) makeClassy ''HOLambdaCall -makeLenses ''VarAssignDecl diff --git a/src/Puppet/Parser/Utils.hs b/src/Puppet/Parser/Utils.hs deleted file mode 100644 --- a/src/Puppet/Parser/Utils.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Puppet.Parser.Utils where - -import Text.Megaparsec.Pos - -import Puppet.Parser.Types - - -dummyppos :: PPosition -dummyppos = initialPPos "dummy" - -dummypos :: Position -dummypos = initialPos "dummy" diff --git a/src/Puppet/Paths.hs b/src/Puppet/Paths.hs deleted file mode 100644 --- a/src/Puppet/Paths.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Puppet.Paths where - -import Puppet.Prelude - -data PuppetDirPaths = PuppetDirPaths - { _baseDir :: FilePath -- ^ Puppet base working directory - , _manifestPath :: FilePath -- ^ The path to the manifests. - , _modulesPath :: FilePath -- ^ The path to the modules. - , _templatesPath :: FilePath -- ^ The path to the template. - , _testPath :: FilePath -- ^ The path to a tests folders to hold tests files such as the pdbfiles. - } - -makeClassy ''PuppetDirPaths - -puppetPaths :: FilePath -> PuppetDirPaths -puppetPaths basedir = PuppetDirPaths basedir manifestdir modulesdir templatedir testdir - where - manifestdir = basedir <> "/manifests" - modulesdir = basedir <> "/modules" - templatedir = basedir <> "/templates" - testdir = basedir <> "/tests" diff --git a/src/Puppet/Preferences.hs b/src/Puppet/Preferences.hs deleted file mode 100644 --- a/src/Puppet/Preferences.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -module Puppet.Preferences ( - dfPreferences - , HasPreferences(..) - , Preferences(Preferences) - , PuppetDirPaths - , HasPuppetDirPaths(..) -) where - -import Puppet.Prelude - -import Data.Aeson -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import qualified Data.Text as Text -import qualified Data.Yaml as Yaml -import qualified System.Log.Logger as LOG -import System.Posix (fileExist) - -import Puppet.Interpreter.Types -import Puppet.NativeTypes -import Puppet.NativeTypes.Helpers -import Puppet.Paths -import qualified Puppet.Puppetlabs as Puppetlabs -import Puppet.Stdlib -import PuppetDB.Dummy - -data Preferences m = Preferences - { _prefPuppetPaths :: PuppetDirPaths - , _prefPDB :: PuppetDBAPI m - , _prefNatTypes :: Container NativeTypeMethods -- ^ The list of native types. - , _prefExtFuncs :: Container ( [PValue] -> InterpreterMonad PValue ) - , _prefHieraPath :: Maybe FilePath - , _prefIgnoredmodules :: HS.HashSet Text - , _prefStrictness :: Strictness - , _prefExtraTests :: Bool - , _prefKnownusers :: [Text] - , _prefKnowngroups :: [Text] - , _prefExternalmodules :: HS.HashSet Text - , _prefPuppetSettings :: Container Text - , _prefFactsOverride :: Container PValue - , _prefFactsDefault :: Container PValue - , _prefLogLevel :: LOG.Priority - , _prefRebaseFile :: Maybe FilePath -- ^ Make all calls to file() with absolute pathes relative to the given path. - } - -data Defaults = Defaults - { _dfKnownusers :: Maybe [Text] - , _dfKnowngroups :: Maybe [Text] - , _dfIgnoredmodules :: Maybe [Text] - , _dfStrictness :: Maybe Strictness - , _dfExtratests :: Maybe Bool - , _dfExternalmodules :: Maybe [Text] - , _dfPuppetSettings :: Maybe (Container Text) - , _dfFactsDefault :: Maybe (Container PValue) - , _dfFactsOverride :: Maybe (Container PValue) - , _dfRebaseFile :: Maybe FilePath - } deriving Show - - -makeClassy ''Preferences - -instance FromJSON Defaults where - parseJSON (Object v) = Defaults - <$> v .:? "knownusers" - <*> v .:? "knowngroups" - <*> v .:? "ignoredmodules" - <*> v .:? "strict" - <*> v .:? "extratests" - <*> v .:? "externalmodules" - <*> v .:? "settings" - <*> v .:? "factsdefault" - <*> v .:? "factsoverride" - <*> v .:? "rebasefile" - parseJSON _ = mzero - --- | generate default preferences -dfPreferences :: FilePath - -> IO (Preferences IO) -dfPreferences basedir = do - let dirpaths = puppetPaths basedir - modulesdir = dirpaths ^. modulesPath - testdir = dirpaths ^. testPath - hierafile = basedir <> "/hiera.yaml" - defaultfile = testdir <> "/defaults.yaml" - defaults <- ifM (fileExist defaultfile) (Yaml.decodeFile defaultfile) (pure Nothing) - hieradir <- ifM (fileExist hierafile) (pure $ Just hierafile) (pure Nothing) - loadedtypes <- loadedTypes modulesdir - labsFunctions <- Puppetlabs.extFunctions modulesdir - return $ Preferences dirpaths - dummyPuppetDB - (baseNativeTypes `HM.union` loadedtypes) - (HM.union stdlibFunctions labsFunctions) - hieradir - (getIgnoredmodules defaults) - (getStrictness defaults) - (getExtraTests defaults) - (getKnownusers defaults) - (getKnowngroups defaults) - (getExternalmodules defaults) - (getPuppetSettings dirpaths defaults) - (getFactsOverride defaults) - (getFactsDefault defaults) - LOG.NOTICE -- good default as INFO is quite noisy - Nothing - -loadedTypes :: FilePath -> IO (HM.HashMap NativeTypeName NativeTypeMethods) -loadedTypes modulesdir = do - typenames <- fmap (map takeBaseName) (getFiles (Text.pack modulesdir) "lib/puppet/type" ".rb") - pure $ HM.fromList (map defaulttype typenames) - --- Utilities for getting default values from the yaml file --- It provides (the same) static defaults (see the 'Nothing' case) when --- no default yaml file or --- not key/value for the option has been provided -getKnownusers :: Maybe Defaults -> [Text] -getKnownusers = fromMaybe ["mysql", "vagrant","nginx", "nagios", "postgres", "puppet", "root", "syslog", "www-data"] . (>>= _dfKnownusers) - -getKnowngroups :: Maybe Defaults -> [Text] -getKnowngroups = fromMaybe ["adm", "syslog", "mysql", "nagios","postgres", "puppet", "root", "www-data", "postfix"] . (>>= _dfKnowngroups) - -getStrictness :: Maybe Defaults -> Strictness -getStrictness = fromMaybe Permissive . (>>= _dfStrictness) - -getIgnoredmodules :: Maybe Defaults -> HS.HashSet Text -getIgnoredmodules = maybe mempty HS.fromList . (>>= _dfIgnoredmodules) - -getExtraTests :: Maybe Defaults -> Bool -getExtraTests = fromMaybe True . (>>= _dfExtratests) - -getExternalmodules :: Maybe Defaults -> HS.HashSet Text -getExternalmodules = maybe mempty HS.fromList . (>>= _dfExternalmodules) - -getPuppetSettings :: PuppetDirPaths -> Maybe Defaults -> Container Text -getPuppetSettings dirpaths = fromMaybe df . (>>= _dfPuppetSettings) - where - df :: Container Text - df = HM.fromList [ ("confdir", Text.pack $ dirpaths^.baseDir) - , ("strict_variables", "true") - ] - -getFactsOverride :: Maybe Defaults -> Container PValue -getFactsOverride = fromMaybe mempty . (>>= _dfFactsOverride) - -getFactsDefault :: Maybe Defaults -> Container PValue -getFactsDefault = fromMaybe mempty . (>>= _dfFactsDefault) diff --git a/src/Puppet/Prelude.hs b/src/Puppet/Prelude.hs deleted file mode 100644 --- a/src/Puppet/Prelude.hs +++ /dev/null @@ -1,222 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} --- | General specific prelude for language-puppet --- | Customization of the Protolude with extra specific utilities -module Puppet.Prelude ( - module Exports - , String - , isEmpty - , dropInitialColons - , textElem - , getDirectoryContents - , takeBaseName - , takeDirectory - , strictifyEither - , scientific2text - , text2Scientific - , getFiles - , loggerName - , logDebug - , logInfo - , logInfoStr - , logWarning - , logError - , logDebugStr - , ifromList, ikeys, isingleton, ifromListWith, iunionWith, iinsertWith -) where - -import Protolude as Exports hiding (Down, - Infix, Prefix, - Selector, State, - StateT, Strict, - break, check, - evalState, - evalStateT, - execState, - execStateT, from, - hash, list, - moduleName, - runState, - runStateT, - sourceColumn, - sourceLine, to, - uncons, unsnoc, - withState, (%), - (<&>), (<.>)) - -import Control.Exception.Lens as Exports (catching) -import Control.Lens as Exports hiding (Strict, - argument, noneOf, - op) -import Control.Monad.Trans.Except as Exports (throwE) -import Control.Monad.Trans.Maybe as Exports (runMaybeT) -import Data.Aeson as Exports (fromJSON, toJSON) -import Data.Scientific as Exports (Scientific) -import Data.Set as Exports (Set) -import Data.Tuple.Strict as Exports (Pair (..)) -import Data.Vector as Exports (Vector) -import Text.Regex.PCRE.ByteString.Utils as Exports (Regex) - -import Data.Attoparsec.Text (parseOnly, rational) -import qualified Data.ByteString as BS -import qualified Data.Either.Strict as S -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import qualified Data.List as List -import qualified Data.Scientific as Scientific -import Data.String (String) -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import qualified System.Log.Logger as Log -import System.Posix.Directory.ByteString - -text2Scientific :: Text -> Maybe Scientific -text2Scientific t = - case parseOnly rational t of - Left _ -> Nothing - Right s -> Just s - -scientific2text :: Scientific -> Text -scientific2text n = - Text.pack $ case Scientific.floatingOrInteger n of - Left r -> show (r :: Double) - Right i -> show (i :: Integer) - -strictifyEither :: Either a b -> S.Either a b -strictifyEither (Left x) = S.Left x -strictifyEither (Right x) = S.Right x - -textElem :: Char -> Text -> Bool -textElem c = Text.any (==c) - - --- | See System.FilePath.Posix -takeBaseName :: Text -> Text -takeBaseName fullname = - let afterLastSlash = List.last $ Text.splitOn "/" fullname - splitExtension = List.init $ Text.splitOn "." afterLastSlash - in Text.intercalate "." splitExtension - --- | See System.FilePath.Posix -takeDirectory :: Text -> Text -takeDirectory "" = "." -takeDirectory "/" = "/" -takeDirectory x = - let res = Text.dropWhileEnd (== '/') file - file = dropFileName x - in if Text.null res && not (Text.null file) - then file - else res - --- | Drop the filename. --- --- > dropFileName x == fst (splitFileName x) --- --- (See System.FilePath.Posix) -dropFileName :: Text -> Text -dropFileName = fst . splitFileName - --- | Split a filename into directory and file. 'combine' is the inverse. --- --- > Valid x => uncurry () (splitFileName x) == x || fst (splitFileName x) == "./" --- > Valid x => isValid (fst (splitFileName x)) --- > splitFileName "file/bob.txt" == ("file/", "bob.txt") --- > splitFileName "file/" == ("file/", "") --- > splitFileName "bob" == ("./", "bob") --- > Posix: splitFileName "/" == ("/","") --- > Windows: splitFileName "c:" == ("c:","") --- --- (See System.FilePath.Posix) -splitFileName :: Text -> (Text, Text) -splitFileName x = - (if Text.null dir then "./" else dir, name) - where - (dir, name) = splitFileName_ x - splitFileName_ y = - let (a,b) = Text.break (=='/') $ Text.reverse y - in (Text.reverse b, Text.reverse a) - --- | helper for hashmap, in case we want another kind of map .. -ifromList :: (Monoid m, At m, Foldable f) => f (Index m, IxValue m) -> m -{-# INLINABLE ifromList #-} -ifromList = foldl' (\curm (k,v) -> curm & at k ?~ v) mempty - -ikeys :: (Eq k, Hashable k) => HM.HashMap k v -> HS.HashSet k -{-# INLINABLE ikeys #-} -ikeys = HS.fromList . HM.keys - -isingleton :: (Monoid b, At b) => Index b -> IxValue b -> b -{-# INLINABLE isingleton #-} -isingleton k v = mempty & at k ?~ v - -ifromListWith :: (Monoid m, At m, Foldable f) => (IxValue m -> IxValue m -> IxValue m) -> f (Index m, IxValue m) -> m -{-# INLINABLE ifromListWith #-} -ifromListWith f = foldl' (\curmap (k,v) -> iinsertWith f k v curmap) mempty - -iinsertWith :: At m => (IxValue m -> IxValue m -> IxValue m) -> Index m -> IxValue m -> m -> m -{-# INLINABLE iinsertWith #-} -iinsertWith f k v m = - m & at k %~ mightreplace - where - mightreplace Nothing = Just v - mightreplace (Just x) = Just (f v x) - -iunionWith :: (Hashable k, Eq k) => (v -> v -> v) -> HM.HashMap k v -> HM.HashMap k v -> HM.HashMap k v -{-# INLINABLE iunionWith #-} -iunionWith = HM.unionWith - -getFiles :: Text -> Text -> Text -> IO [Text] -getFiles moduledir subdir extension = - fmap concat - $ getDirContents moduledir - >>= mapM ( checkForSubFiles extension . (\x -> moduledir <> "/" <> x <> "/" <> subdir)) - -checkForSubFiles :: Text -> Text -> IO [Text] -checkForSubFiles extension dir = - catch (fmap Right (getDirContents dir)) (\e -> return $ Left (e :: IOException)) >>= \case - Right o -> return ((map (\x -> dir <> "/" <> x) . filter (Text.isSuffixOf extension)) o ) - Left _ -> return [] - -getDirContents :: Text -> IO [Text] -getDirContents x = fmap (filter (not . Text.all (=='.'))) (getDirectoryContents x) - -getDirectoryContents :: Text -> IO [Text] -getDirectoryContents fpath = do - h <- openDirStream (Text.encodeUtf8 fpath) - let readHandle = do - fp <- readDirStream h - if BS.null fp - then return [] - else fmap (Text.decodeUtf8 fp :) readHandle - out <- readHandle - closeDirStream h - pure out - -isEmpty :: (Eq x, Monoid x) => x -> Bool -isEmpty = (== mempty) - --- | remove the '::' token from a text if any -dropInitialColons :: Text -> Text -dropInitialColons t = fromMaybe t (Text.stripPrefix "::" t) - -loggerName :: String -loggerName = "language-puppet" - -logDebug :: Text -> IO () -logDebug = Log.debugM "language-puppet" . toS - -logInfo :: Text -> IO () -logInfo = Log.infoM "language-puppet" . toS - -logInfoStr :: String -> IO () -logInfoStr = Log.infoM "language-puppet" - -logWarning :: Text -> IO () -logWarning = Log.warningM "language-puppet" . toS - -logError :: Text -> IO () -logError = Log.errorM "language-puppet" . toS - -logDebugStr :: String -> IO () -logDebugStr = Log.debugM "language-puppet" diff --git a/src/Puppet/Puppetlabs.hs b/src/Puppet/Puppetlabs.hs deleted file mode 100644 --- a/src/Puppet/Puppetlabs.hs +++ /dev/null @@ -1,124 +0,0 @@ --- | Contains an Haskell implementation (or mock implementation) of some ruby functions found in puppetlabs modules -module Puppet.Puppetlabs (extFunctions) where - -import Puppet.Prelude - -import Crypto.Hash as Crypto -import Data.ByteString (ByteString) -import Data.Foldable (foldlM) -import qualified Data.HashMap.Strict as HM -import Data.Scientific as Sci -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import Data.Vector (Vector) -import Formatting (scifmt, sformat, (%), (%.)) -import qualified Formatting as FMT -import System.Posix.Files (fileExist) -import System.Random (mkStdGen, randomRs) - -import Puppet.Interpreter.PrettyPrinter () -import Puppet.Interpreter.Types -import Puppet.PP - -md5 :: Text -> Text -md5 = Text.pack . show . (Crypto.hash :: ByteString -> Digest MD5) . Text.encodeUtf8 - -extFun :: [(FilePath, Text, [PValue] -> InterpreterMonad PValue)] -extFun = [ ("/apache", "bool2httpd", apacheBool2httpd) - , ("/docker", "docker_run_flags", mockDockerRunFlags) - , ("/jenkins", "jenkins_port", mockJenkinsPort) - , ("/jenkins", "jenkins_prefix", mockJenkinsPrefix) - , ("/postgresql", "postgresql_acls_to_resources_hash", pgAclsToHash) - , ("/postgresql", "postgresql_password", pgPassword) - , ("/extlib", "random_password", randomPassword) - , ("/extlib", "cache_data", mockCacheData) - ] - --- | Build the map of available ext functions --- If the ruby file is not found on the local filesystem the record is ignored. This is to avoid potential namespace conflict -extFunctions :: FilePath -> IO (Container ( [PValue] -> InterpreterMonad PValue)) -extFunctions modpath = foldlM f HM.empty extFun - where - f acc (modname, fname, fn) = do - test <- testFile modname fname - if test - then return $ HM.insert fname fn acc - else return acc - testFile modname fname = fileExist (modpath <> modname <> "/lib/puppet/parser/functions/" <> Text.unpack fname <>".rb") - -apacheBool2httpd :: MonadThrowPos m => [PValue] -> m PValue -apacheBool2httpd [PBoolean True] = return $ PString "On" -apacheBool2httpd [PString "true"] = return $ PString "On" -apacheBool2httpd [_] = return $ PString "Off" -apacheBool2httpd arg@_ = throwPosError $ "expect one single argument" <+> pretty arg - -pgPassword :: MonadThrowPos m => [PValue] -> m PValue -pgPassword [PString username, PString pwd] = - return $ PString $ "md5" <> md5 (pwd <> username) -pgPassword _ = throwPosError "expects 2 string arguments" - --- | The function is pure and always return the same "random" password -randomPassword :: MonadThrowPos m => [PValue] -> m PValue -randomPassword [PNumber s] = - PString . Text.pack . randomChars <$> scientificToInt s - where - randomChars n = take n $ randomRs ('a', 'z') (mkStdGen 1) - -randomPassword _ = throwPosError "expect one single string arguments" - - --- | To be implemented if needed -mockJenkinsPrefix :: MonadThrowPos m => [PValue] -> m PValue -mockJenkinsPrefix [] = return $ PString "" -mockJenkinsPrefix arg@_ = throwPosError $ "expect no argument" <+> pretty arg - --- | To be implemented if needed -mockJenkinsPort :: MonadThrowPos m => [PValue] -> m PValue -mockJenkinsPort [] = return $ PString "8080" -mockJenkinsPort arg@_ = throwPosError $ "expect no argument" <+> pretty arg - -mockCacheData :: MonadThrowPos m => [PValue] -> m PValue -mockCacheData [_, _, b] = return b -mockCacheData arg@_ = throwPosError $ "expect 3 string arguments" <+> pretty arg - --- | Simple implemenation that does not handle all cases. --- For instance 'auth_option' is currently not implemented. --- Please add cases as needed. -pgAclsToHash :: MonadThrowPos m => [PValue] -> m PValue -pgAclsToHash [PArray as, PString ident, PNumber offset] = do - x <- aclsToHash as ident offset - return $ PHash x -pgAclsToHash _ = throwPosError "expects 3 arguments; one array one string and one number" - -aclsToHash :: MonadThrowPos m => Vector PValue -> Text -> Scientific -> m (Container PValue) -aclsToHash vec ident offset = ifoldlM f HM.empty vec - where - f :: MonadThrowPos m => Int -> Container PValue -> PValue -> m (Container PValue) - f idx acc (PString acl) = do - let order = offset + scientific (toInteger idx) 0 - keymsg = sformat ("postgresql class generated rule " % FMT.stext % " " % FMT.int) ident idx - x <- aclToHash (Text.words acl) order - return $ HM.insert keymsg x acc - f _ _ pval = throwPosError $ "expect a string as acl but get" <+> pretty pval - -aclToHash :: (MonadThrowPos m) => [Text] -> Scientific -> m PValue -aclToHash [typ, db, usr, addr, auth] order = - return $ PHash $ HM.fromList [ ("type", PString typ) - , ("database", PString db ) - , ("user", PString usr) - , ("order", PString (sformat (FMT.left 3 '0' %. scifmt Sci.Fixed (Just 0)) order)) - , ("address", PString addr) - , ("auth_method", PString auth) - ] -aclToHash acl _ = throwPosError $ "Unable to parse acl line" <+> squotes (ttext (Text.unwords acl)) - --- faked implementation, replace by the correct one if you need so. -mockDockerRunFlags :: MonadThrowPos m => [PValue] -> m PValue -mockDockerRunFlags arg@[PHash _]= (return . PString . Text.pack . displayNocolor . pretty . head) arg -mockDockerRunFlags arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg - --- utils -scientificToInt :: MonadThrowPos m => Scientific -> m Int -scientificToInt s = maybe (throwPosError $ "Unable to convert" <+> string (show s) <+> "into an int.") - return - (Sci.toBoundedInteger s) diff --git a/src/Puppet/Runner.hs b/src/Puppet/Runner.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Runner.hs @@ -0,0 +1,31 @@ +-- | At the top of the abstraction level, the module exposes all high-end services: +-- +-- * the preferences container +-- * the puppet daemon +-- * the statistic module +-- * the stdlib functions +-- * a bunch of pure runners +-- +-- Naturally nothing from "Puppet.Runner" should be used in lower abstraction layers. +module Puppet.Runner( + -- * Preferences + module Puppet.Runner.Preferences + -- * Pure + , module Puppet.Runner.Pure + -- * Stats + , module Puppet.Runner.Stats + -- * Sdlib + , module Puppet.Runner.Stdlib + -- * Daemon + , module Puppet.Runner.Daemon + -- * Re-export + , module Puppet.Interpreter + ) + where + +import Puppet.Runner.Daemon +import Puppet.Runner.Preferences +import Puppet.Runner.Stats +import Puppet.Runner.Stdlib +import Puppet.Runner.Pure +import Puppet.Interpreter diff --git a/src/Puppet/Runner/Daemon.hs b/src/Puppet/Runner/Daemon.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Runner/Daemon.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TupleSections #-} +module Puppet.Runner.Daemon ( + Daemon(..) + , initDaemon +) where + +import XPrelude + +import qualified Data.Either.Strict as S +import Data.FileCache as FileCache +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as Text +import Debug.Trace (traceEventIO) +import Foreign.Ruby.Safe +import qualified System.Directory as Directory +import qualified System.Log.Formatter as Log (simpleLogFormatter) +import qualified System.Log.Handler as Log (setFormatter) +import qualified System.Log.Handler.Simple as Log (streamHandler) +import qualified System.Log.Logger as Log + +import Facter +import Hiera.Server +import Puppet.Runner.Daemon.FileParser +import Puppet.Runner.Daemon.OptionalTests +import Puppet.Runner.Erb +import Puppet.Interpreter +import Puppet.Parser +import Puppet.Runner.Preferences +import Puppet.Runner.Stats + + +{-| API for the Daemon. +The main method is `getCatalog`: given a node and a list of facts, it returns the result of the compilation. +This will be either an error, or a tuple containing: + +- all the resources in this catalog +- the dependency map +- the exported resources +- a list of known resources, that might not be up to date, but are here for code coverage tests. + +Notes : + +* It might be buggy when top level statements that are not class\/define\/nodes are altered. +-} +data Daemon = Daemon + { getCatalog :: NodeName -> Facts -> IO (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) + , parserStats :: MStats + , catalogStats :: MStats + , templateStats :: MStats + } + +{-| Entry point to get a Daemon. +It will initialize the parsing and interpretation infrastructure from the 'Preferences'. + +Cache the AST of every .pp file. It could use a bit of memory. As a comparison, it +fits in 60 MB with the author's manifests, but really breathes when given 300 MB +of heap space. In this configuration, even if it spawns a ruby process for every +template evaluation, it is way faster than the puppet stack. + +It can optionally talk with PuppetDB, by setting an URL via the 'prefPDB'. +The recommended way to set it to http://localhost:8080 and set a SSH tunnel : + +> ssh -L 8080:localhost:8080 puppet.host +-} +initDaemon :: Preferences IO + -> IO Daemon +initDaemon pref = do + setupLogger (pref ^. prefLogLevel) + logDebug "Initialize daemon" + traceEventIO "initDaemon" + hquery <- hieraQuery pref + fcache <- newFileCache + intr <- startRubyInterpreter + templStats <- newStats + getTemplate <- initTemplateDaemon intr pref templStats + catStats <- newStats + parseStats <- newStats + return (Daemon + (getCatalog' pref (parseFunc (pref ^. prefPuppetPaths) fcache parseStats) getTemplate catStats hquery) + parseStats + catStats + templStats + ) + +getCatalog' :: Preferences IO + -> ( TopLevelType -> Text -> IO (S.Either PrettyError Statement) ) + -> (Either Text Text -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError Text)) + -> MStats + -> HieraQueryLayers IO + -> NodeName + -> Facts + -> IO (Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) +getCatalog' pref parsingfunc getTemplate stats hquery node facts = do + logDebug ("Received query for node " <> node) + traceEventIO ("START getCatalog' " <> Text.unpack node) + let catalogComputation = interpretCatalog (InterpreterReader + (pref ^. prefNatTypes) + parsingfunc + getTemplate + (pref ^. prefPDB) + (pref ^. prefExtFuncs) + node + hquery + defaultImpureMethods + (pref ^. prefIgnoredmodules) + (pref ^. prefExternalmodules) + (pref ^. prefStrictness == Strict) + (pref ^. prefPuppetPaths) + (pref ^. prefRebaseFile) + ) + node + facts + (pref ^. prefPuppetSettings) + (stmts :!: warnings) <- measure stats node catalogComputation + mapM_ (\(p :!: m) -> Log.logM loggerName p (displayS (renderCompact (ppline node <> ":" <+> m)) "")) warnings + traceEventIO ("STOP getCatalog' " <> toS node) + case stmts of + Left _ -> pure stmts -- no catalog so we can't do the extra tests + Right r@(c,_,_,_) -> do + if pref ^. prefExtraTests + then second (const r) <$> (testCatalog pref c) + else pure stmts + +-- Build the 'HieraQueryLayers' needed by the interpreter to lookup hiera values. +hieraQuery :: Preferences IO -> IO (HieraQueryLayers IO) +hieraQuery pref = do + api0 <- case pref ^. prefHieraPath of + Just p -> startHiera p + Nothing -> pure dummyHiera + modapis <- getModApis + pure (HieraQueryLayers api0 modapis) + where + getModApis :: IO (Container (HieraQueryFunc IO)) + getModApis = do + let ignored_modules = pref^.prefIgnoredmodules + modpath = pref^.prefPuppetPaths.modulesPath + dirs <- Directory.listDirectory modpath + (HM.fromList . catMaybes) <$> + for dirs (\dir -> runMaybeT $ do + let modname = toS dir + path = modpath <> "/" <> dir <> "/hiera.yaml" + guard (modname `notElem` ignored_modules) + guard =<< liftIO (Directory.doesFileExist path) + liftIO $ (modname, ) <$> startHiera path) + + +defaultImpureMethods :: MonadIO m => IoMethods m +defaultImpureMethods = + IoMethods (liftIO currentCallStack) (liftIO . file) (liftIO . traceEventIO) + where + file [] = return $ Left "" + file (x:xs) = (Right <$> readFile (Text.unpack x)) `catch` (\SomeException {} -> file xs) + +setupLogger :: Log.Priority -> IO () +setupLogger p = do + Log.updateGlobalLogger loggerName (Log.setLevel p) + hs <- consoleLogHandler + Log.updateGlobalLogger Log.rootLoggerName $ Log.setHandlers [hs] + where + consoleLogHandler = Log.setFormatter + <$> Log.streamHandler stdout Log.DEBUG + <*> pure (Log.simpleLogFormatter "$prio: $msg") diff --git a/src/Puppet/Runner/Daemon/FileParser.hs b/src/Puppet/Runner/Daemon/FileParser.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Runner/Daemon/FileParser.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +module Puppet.Runner.Daemon.FileParser (parseFunc) where + +import XPrelude + +import qualified Data.Either.Strict as S +import Data.FileCache as FileCache +import qualified Data.HashMap.Strict as Map +import qualified Data.List as List +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Vector as V +import Debug.Trace (traceEventIO) +import qualified Text.Megaparsec as Megaparsec +import qualified Text.Regex.PCRE.ByteString.Utils as Regex + +import Puppet.Interpreter +import Puppet.Parser +import Puppet.Runner.Stats + +-- | Return an HOF that would parse the file associated with a toplevel. +-- The toplevel is defined by the tuple (type, name) +-- The result of the parsing is a single Statement (which recursively contains others statements) +parseFunc :: PuppetDirPaths -> FileCache (V.Vector Statement) -> MStats -> TopLevelType -> Text -> IO (S.Either PrettyError Statement) +parseFunc ppath filecache stats = \toptype topname -> + let nameparts = Text.splitOn "::" topname in + let topLevelFilePath :: TopLevelType -> Text -> Either PrettyError Text + topLevelFilePath TopNode _ = Right $ Text.pack (ppath^.manifestPath <> "/site.pp") + topLevelFilePath _ name + | length nameparts == 1 = Right $ Text.pack (ppath^.modulesPath) <> "/" <> name <> "/manifests/init.pp" + | null nameparts = Left $ PrettyError ("Invalid toplevel" <+> squotes (ppline name)) + | otherwise = Right $ Text.pack (ppath^.modulesPath) <> "/" <> List.head nameparts <> "/manifests/" <> Text.intercalate "/" (List.tail nameparts) <> ".pp" + in + case topLevelFilePath toptype topname of + Left rr -> return (S.Left rr) + Right fname -> do + let sfname = Text.unpack fname + handleFailure :: SomeException -> IO (S.Either String (V.Vector Statement)) + handleFailure e = return (S.Left (show e)) + x <- measure stats fname (FileCache.query filecache sfname (parseFile sfname `catch` handleFailure)) + case x of + S.Right stmts -> filterStatements toptype topname stmts + S.Left rr -> return (S.Left (PrettyError (red (pptext rr)))) + +parseFile :: FilePath -> IO (S.Either String (V.Vector Statement)) +parseFile fname = do + traceEventIO ("START parsing " ++ fname) + cnt <- readFile fname + o <- case runPParser fname cnt of + Right r -> traceEventIO ("Stopped parsing " ++ fname) >> return (S.Right r) + Left rr -> traceEventIO ("Stopped parsing " ++ fname ++ " (failure: " ++ Megaparsec.parseErrorPretty rr ++ ")") >> return (S.Left (Megaparsec.parseErrorPretty rr)) + traceEventIO ("STOP parsing " ++ fname) + return o + +-- TODO pre-triage stuff +filterStatements :: TopLevelType -> Text -> V.Vector Statement -> IO (S.Either PrettyError Statement) +-- the most complicated case, node matching +filterStatements TopNode ndename stmts = + -- this operation should probably get cached + let (!spurious, !directnodes, !regexpmatches, !defaultnode) = V.foldl' triage (V.empty, Map.empty, V.empty, Nothing) stmts + triage curstuff n@(NodeDeclaration (NodeDecl (NodeName !nm) _ _ _)) = curstuff & _2 . at nm ?~ n + triage curstuff n@(NodeDeclaration (NodeDecl (NodeMatch (CompRegex _ !rg)) _ _ _)) = curstuff & _3 %~ (|> (rg :!: n)) + triage curstuff n@(NodeDeclaration (NodeDecl NodeDefault _ _ _)) = curstuff & _4 ?~ n + triage curstuff x = curstuff & _1 %~ (|> x) + bsnodename = Text.encodeUtf8 ndename + checkRegexp :: [Pair Regex Statement] -> ExceptT PrettyError IO (Maybe Statement) + checkRegexp [] = return Nothing + checkRegexp ((regexp :!: s):xs) = + case Regex.execute' regexp bsnodename of + Left rr -> throwError (PrettyError ("Regexp match error:" <+> ppline (show rr))) + Right Nothing -> checkRegexp xs + Right (Just _) -> return (Just s) + strictEither (Left x) = S.Left x + strictEither (Right x) = S.Right x + 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 $ runExceptT $ 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 (PrettyError ("Couldn't find node" <+> ppline ndename)) +filterStatements x ndename stmts = + let (!spurious, !defines, !classes) = V.foldl' triage (V.empty, Map.empty, Map.empty) stmts + triage curstuff n@(ClassDeclaration (ClassDecl cname _ _ _ _)) = curstuff & _3 . at cname ?~ n + triage curstuff n@(DefineDeclaration (DefineDecl cname _ _ _)) = curstuff & _2 . at cname ?~ n + triage curstuff n = curstuff & _1 %~ (|> n) + tc n = if V.null spurious + then n + else TopContainer spurious n + in case x of + TopNode -> return (S.Left "Case already covered, shoudln't happen in Puppet.Manifests") + TopDefine -> case defines ^. at ndename of + Just n -> return (S.Right (tc n)) + Nothing -> return (S.Left (PrettyError ("Couldn't find define " <+> ppline ndename))) + TopClass -> case classes ^. at ndename of + Just n -> return (S.Right (tc n)) + Nothing -> return (S.Left (PrettyError ("Couldn't find class " <+> ppline ndename))) diff --git a/src/Puppet/Runner/Daemon/OptionalTests.hs b/src/Puppet/Runner/Daemon/OptionalTests.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Runner/Daemon/OptionalTests.hs @@ -0,0 +1,103 @@ +-- | The module accumulates 'PrettyError's in the ExceptT monad transformer. +module Puppet.Runner.Daemon.OptionalTests (testCatalog) where + +import XPrelude + +import qualified Data.HashSet as Set +import qualified Data.Text as Text +import System.Posix.Files (fileExist) + +import Puppet.Language +import Puppet.Runner.Preferences + + +-- | Entry point for all optional tests +testCatalog :: Preferences IO + -> FinalCatalog + -> IO (Either PrettyError ()) +testCatalog prefs c = + runExceptT + $ testFileSources (prefs ^. prefPuppetPaths.baseDir) c + *> testUsersGroups (prefs ^. prefKnownusers) (prefs ^. prefKnowngroups) c + +-- | Tests that all users and groups are defined +testUsersGroups :: [Text] -> [Text] -> FinalCatalog -> ExceptT PrettyError IO () +testUsersGroups kusers kgroups c = do + let users = Set.fromList $ "" : "0" : map (view (rid . iname)) (getResourceFrom "user") ++ kusers + groups = Set.fromList $ "" : "0" : map (view (rid . iname)) (getResourceFrom "group") ++ kgroups + checkResource lu lg = mapM_ (checkResource' lu lg) + checkResource' lu lg res = do + let msg att name = align (vsep [ "Resource" <+> ppline (res^.rid.itype) + <+> ppline (res^.rid.iname) <+> showPos (res^.rpos._1) + , "references the unknown" <+> att <+> squotes (ppline name)]) + <> line + case lu of + Just lu' -> do + let u = res ^. rattributes . lu' . _PString + unless (Set.member u users) $ throwE $ PrettyError (msg "user" u) + Nothing -> pure () + case lg of + Just lg' -> do + let g = res ^. rattributes . lg' . _PString + unless (Set.member g groups) $ throwE $ PrettyError (msg "group" g) + Nothing -> pure () + do + checkResource (Just $ ix "owner") (Just $ ix "group") (getResourceFrom "file") + checkResource (Just $ ix "user") (Just $ ix "group") (getResourceFrom "exec") + checkResource (Just $ ix "user") Nothing (getResourceFrom "cron") + checkResource (Just $ ix "user") Nothing (getResourceFrom "ssh_authorized_key") + checkResource (Just $ ix "user") Nothing (getResourceFrom "ssh_authorized_key_secure") + checkResource Nothing (Just $ ix "gid") (getResourceFrom "users") + where + getResourceFrom t = c ^.. traverse . filtered (\r -> r ^. rid . itype == t && r ^. rattributes . at "ensure" /= Just "absent") + +-- | Test source for every file resources in the catalog. +testFileSources :: FilePath -> FinalCatalog -> ExceptT PrettyError IO () +testFileSources basedir c = do + let getfiles = filter presentFile . toList + presentFile r = r ^. rid . itype == "file" + && (r ^. rattributes . at "ensure") `elem` [Nothing, Just "present"] + && r ^. rattributes . at "source" /= Just PUndef + getsource = mapMaybe (\r -> (,) <$> pure r <*> r ^. rattributes . at "source") + checkAllSources basedir $ (getsource . getfiles) c + +-- | Check source for all file resources and append failures along. +checkAllSources :: FilePath -> [(Resource, PValue)] -> ExceptT PrettyError IO () +checkAllSources fp fs = + -- we could just do : + -- traverse_ (\(res, src) -> catchE (checkFile fp src) (throwE ...)) fs + -- but that would print the first encountered failure. + go fs [] + where + go :: [(Resource, PValue)] -> [PrettyError] -> ExceptT PrettyError IO () + go ((res, filesrc):xs) es = ExceptT $ do + runExceptT (checkFile fp filesrc) >>= \case + Right () -> runExceptT $ go xs es + Left err -> + runExceptT + $ go xs ((PrettyError $ align (vsep [ "Could not find" <+> pretty filesrc + , getError err + , showPos (res^.rpos^._1) + ])):es) + go [] [] = pure () + go [] es = throwE (mconcat es) + +testFile :: FilePath -> ExceptT PrettyError IO () +testFile fp = do + p <- liftIO (fileExist fp) + unless p (throwE $ PrettyError $ "searched in" <+> squotes (pptext fp)) + +-- | Only test the `puppet:///` protocol (files managed by the puppet server) +-- we don't test absolute path (puppet client files) +checkFile :: FilePath -> PValue -> ExceptT PrettyError IO () +checkFile basedir (PString f) = + case Text.stripPrefix "puppet:///" f of + Just stringdir -> case Text.splitOn "/" stringdir of + ("modules":modname:rest) -> testFile (basedir <> "/modules/" <> toS modname <> "/files/" <> toS (Text.intercalate "/" rest)) + ("files":rest) -> testFile (basedir <> "/files/" <> toS (Text.intercalate "/" rest)) + ("private":_) -> pure () + _ -> throwE (PrettyError $ "Invalid file source:" <+> ppline f) + Nothing -> return () +-- source is always an array of possible paths. We only fails if none of them check. +checkFile basedir (PArray xs) = asum [checkFile basedir x | x <- toList xs] +checkFile _ x = throwE (PrettyError $ "Source was not a string, but" <+> pretty x) diff --git a/src/Puppet/Runner/Erb.hs b/src/Puppet/Runner/Erb.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Runner/Erb.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE NamedFieldPuns #-} +-- | Internal module used to initialize the erb template daemon. +module Puppet.Runner.Erb ( + initTemplateDaemon + , rubyEvaluate +) where + +import XPrelude + +import Data.Aeson.Lens (_Number) +import qualified Data.Either.Strict as S +import qualified Data.FileCache as Cache +import qualified Data.List as List +import qualified Data.Text as Text +import Data.Tuple.Strict (Pair (..)) +import qualified Data.Vector as V +import Debug.Trace +import Foreign.Ruby +import qualified Foreign.Ruby.Bindings as FR +import qualified Foreign.Ruby.Helpers as FR +import GHC.Conc (labelThread) +import Paths_language_puppet (getDataFileName) +import System.Environment (getExecutablePath) +import System.FilePath +import System.Posix.Files +import Text.Parsec hiding (string) +import Text.Parsec.Error +import Text.Parsec.Pos + +import Erb +import Puppet.Interpreter.Helpers +import Puppet.Interpreter.IO +import Puppet.Interpreter.Resolve +import Puppet.Interpreter.Types +import Puppet.Runner.Erb.Evaluate +import Puppet.Runner.Preferences +import Puppet.Runner.Stats + +instance IsString TemplateParseError where + fromString s = TemplateParseError $ newErrorMessage (Message s) (initialPos "dummy") + +newtype TemplateParseError = TemplateParseError { tgetError :: ParseError } + +type TemplateQuery = (Chan TemplateAnswer, Either Text Text, InterpreterState, InterpreterReader IO) +type TemplateAnswer = S.Either PrettyError Text + +showRubyError :: RubyError -> PrettyError +showRubyError (Stack msg stk) = PrettyError $ dullred (ppstring msg) <> softline <> dullyellow (ppstring stk) +showRubyError (WithOutput str _) = PrettyError $ dullred (ppstring str) +showRubyError (OtherError rr) = PrettyError (dullred (pptext rr)) + +-- | Parse and resolve erb files. Initializes a thread for the Ruby interpreter . +initTemplateDaemon :: RubyInterpreter -> Preferences IO -> MStats -> IO (Either Text Text -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError Text)) +initTemplateDaemon intr prefs mvstats = do + controlchan <- newChan + templatecache <- Cache.newFileCache + let returnError rs = return $ \_ _ _ -> return (S.Left (showRubyError rs)) + x <- runExceptT $ do + liftIO (getRubyScriptPath "hrubyerb.rb") >>= ExceptT . loadFile intr + ExceptT (registerGlobalFunction4 intr "varlookup" hrresolveVariable) + ExceptT (registerGlobalFunction5 intr "callextfunc" hrcallfunction) + liftIO $ void $ forkIO $ templateDaemon intr + (Text.pack (prefs ^. prefPuppetPaths.modulesPath)) + (Text.pack (prefs ^. prefPuppetPaths.templatesPath)) + controlchan + mvstats + templatecache + pure $! templateQuery controlchan + either returnError return x + +templateQuery :: Chan TemplateQuery -> Either Text Text -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError Text) +templateQuery qchan filename stt rdr = do + rchan <- newChan + writeChan qchan (rchan, filename, stt, rdr) + readChan rchan + +templateDaemon :: RubyInterpreter -> Text -> Text -> Chan TemplateQuery -> MStats -> Cache.FileCacheR TemplateParseError [RubyStatement] -> IO () +templateDaemon intr modpath templatepath qchan mvstats filecache = do + let nameThread :: String -> IO () + nameThread n = myThreadId >>= flip labelThread n + nameThread "RubyTemplateDaemon" + (respchan, fileinfo, stt, rdr) <- readChan qchan + case fileinfo of + Right filename -> do + let prts = Text.splitOn "/" filename + searchpathes | length prts > 1 = [modpath <> "/" <> List.head prts <> "/templates/" <> Text.intercalate "/" (List.tail prts), templatepath <> "/" <> filename] + | otherwise = [templatepath <> "/" <> filename] + acceptablefiles <- filterM (fileExist . Text.unpack) searchpathes + if null acceptablefiles + then writeChan respchan (S.Left $ PrettyError $ "Can't find template file for" <+> ppline filename <+> ", looked in" <+> list (map ppline searchpathes)) + else measure mvstats filename (computeTemplate intr (Right (List.head acceptablefiles)) stt rdr mvstats filecache) >>= writeChan respchan + Left _ -> measure mvstats "inline" (computeTemplate intr fileinfo stt rdr mvstats filecache) >>= writeChan respchan + templateDaemon intr modpath templatepath qchan mvstats filecache + +computeTemplate :: RubyInterpreter -> Either Text Text -> InterpreterState -> InterpreterReader IO -> MStats -> Cache.FileCacheR TemplateParseError [RubyStatement] -> IO TemplateAnswer +computeTemplate intr fileinfo stt rdr mstats filecache = do + let (curcontext, fvariables) = case extractFromState stt of + Nothing -> (mempty, mempty) + Just (c,v) -> (c,v) + let (filename, ufilename) = case fileinfo of + Left _ -> ("inline", "inline") + Right x -> (x, Text.unpack x) + mkSafe a = makeSafe intr a >>= \case + Left rr -> return (S.Left (showRubyError rr)) + Right x -> return x + encapsulateError = _Left %~ TemplateParseError + variables = fvariables & traverse . scopeVariables . traverse . _1 . _1 %~ toStr + toStr (PNumber n) = PString (scientific2text n) + toStr x = x + traceEventIO ("START template " ++ Text.unpack filename) + parsed <- case fileinfo of + Right _ -> measure mstats ("parsing - " <> filename) $ Cache.lazyQuery filecache ufilename $ fmap encapsulateError (parseErbFile ufilename) + Left content -> measure mstats ("parsing - " <> filename) $ return $ encapsulateError (runParser erbparser () "inline" (Text.unpack content)) + o <- case parsed of + Left err -> do + let msg = "Template '" <> toS ufilename <> "' could not be parsed " <> show (tgetError err) + logDebug msg + measure mstats ("ruby - " <> filename) $ mkSafe $ computeTemplateWRuby fileinfo curcontext variables stt rdr + Right ast -> case rubyEvaluate variables curcontext ast of + Right ev -> return (S.Right ev) + Left err -> do + let !msg = "Template '" <> toS ufilename <> "' evaluation failed with: " <> show err + logDebug msg + measure mstats ("ruby efail - " <> filename) $ mkSafe $ computeTemplateWRuby fileinfo curcontext variables stt rdr + traceEventIO ("STOP template " ++ Text.unpack filename) + return o + +getRubyScriptPath :: String -> IO String +getRubyScriptPath rubybin = do + let checkpath :: FilePath -> IO FilePath -> IO FilePath + checkpath fp nxt = do + e <- fileExist fp + if e + then return fp + else nxt + withExecutablePath = do + path <- fmap takeDirectory getExecutablePath + let fullpath = path rubybin + checkpath fullpath $ checkpath ("/usr/local/bin/" <> rubybin) (return rubybin) + cabalPath <- getDataFileName $ "ruby/" ++ rubybin :: IO FilePath + checkpath cabalPath withExecutablePath + +-- This must be called from the proper thread. As this is callback, this +-- should be ok. +hrresolveVariable :: RValue -> RValue -> RValue -> RValue -> IO RValue +-- Text -> Container PValue -> RValue -> RValue -> IO RValue +hrresolveVariable _ rscp rvariables rtoresolve = do + scope <- FR.extractHaskellValue rscp + variables <- FR.extractHaskellValue rvariables + toresolve <- FR.fromRuby rtoresolve + let answer = case toresolve of + Right "~g~e~t_h~a~s~h~" -> + let getvars ctx = (variables ^. ix ctx . scopeVariables) & traverse %~ view (_1 . _1) + vars = getvars "::" <> getvars scope + in Right (PHash vars) + Right t -> getVariable variables scope t + Left rr -> Left ("The variable name is not a string" <+> pptext rr) + case answer of + Left _ -> getSymbol "undef" + Right r -> FR.toRuby r + +hrcallfunction :: RValue -> RValue -> RValue -> RValue -> RValue -> IO RValue +hrcallfunction _ rfname rargs rstt rrdr = do + efname <- FR.fromRuby rfname + eargs <- FR.fromRuby rargs + rdr <- FR.extractHaskellValue rrdr + stt <- FR.extractHaskellValue rstt + let err :: String -> IO RValue + err rr = fmap (either snd identity) (FR.toRuby (Text.pack rr) >>= FR.safeMethodCall "MyError" "new" . (:[])) + case (,) <$> efname <*> eargs of + Right (fname, varray) | fname `elem` ["template", "inline_template"] -> do + logError $ "Can't parse a call to the external ruby function '" <> fname <> "' n an erb file.\n\tIt is not possible to call it from a Ruby function. It would stall (yes it sucks ...).\n\tChoosing to output \"undef\" !" + getSymbol "undef" + | otherwise -> do + let args = case varray of + [PArray vargs] -> V.toList vargs + _ -> varray + (x,_,_) <- interpretMonad rdr stt (resolveFunction' fname args) + case x of + Right o -> case o ^? _Number of + Just n -> FR.toRuby n + Nothing -> FR.toRuby o + Left rr -> err (show rr) + Left rr -> err rr + +computeTemplateWRuby :: Either Text Text -> Text -> Container ScopeInformation -> InterpreterState -> InterpreterReader IO -> IO TemplateAnswer +computeTemplateWRuby fileinfo curcontext variables stt rdr = FR.freezeGC $ eitherDocIO $ do + rscp <- FR.embedHaskellValue curcontext + rvariables <- FR.embedHaskellValue variables + rstt <- FR.embedHaskellValue stt + rrdr <- FR.embedHaskellValue rdr + let varlist = variables ^. ix curcontext . scopeVariables + -- must be called from a "makeSafe" thingie + contentinfo <- case fileinfo of + Right fname -> FR.toRuby fname + Left _ -> FR.toRuby ("-" :: Text) + let withBinding f = do + erbBinding <- FR.safeMethodCall "ErbBinding" "new" [rscp,rvariables,rstt,rrdr,contentinfo] + case erbBinding of + Left x -> return (Left x) + Right v -> do + forM_ (itoList varlist) $ \(varname, varval :!: _ :!: _) -> FR.toRuby varval >>= FR.rb_iv_set v (Text.unpack varname) + f v + o <- case fileinfo of + Right fname -> do + rfname <- FR.toRuby fname + withBinding $ \v -> FR.safeMethodCall "Controller" "runFromFile" [rfname,v] + Left content -> withBinding $ \v -> FR.toRuby content >>= FR.safeMethodCall "Controller" "runFromContent" . (:[v]) + FR.freeHaskellValue rrdr + FR.freeHaskellValue rstt + FR.freeHaskellValue rvariables + FR.freeHaskellValue rscp + case o of + Left (rr, _) -> + let fname = case fileinfo of + Right f -> Text.unpack f + Left _ -> "inline_template" + in return (S.Left $ PrettyError (dullred (pptext rr) <+> "in" <+> dullgreen (pptext fname))) + Right r -> FR.fromRuby r >>= \case + Right result -> return (S.Right result) + Left rr -> return (S.Left $ PrettyError ("Could not deserialiaze ruby output" <+> pptext rr)) + +eitherDocIO :: IO (S.Either PrettyError a) -> IO (S.Either PrettyError a) +eitherDocIO computation = + (computation >>= check) `catch` (\e -> return $ S.Left $ PrettyError $ dullred $ ppline $ show (e :: SomeException)) + where + check (S.Left r) = return (S.Left r) + check (S.Right x) = return (S.Right x) diff --git a/src/Puppet/Runner/Erb/Evaluate.hs b/src/Puppet/Runner/Erb/Evaluate.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Runner/Erb/Evaluate.hs @@ -0,0 +1,68 @@ +-- | Private module. Evaluates a ruby template from what's generated by "Erb.Parser". +module Puppet.Runner.Erb.Evaluate ( + rubyEvaluate + ) where + +import XPrelude + +import Data.Aeson.Lens +import qualified Data.Char as Char +import qualified Data.Text as Text +import qualified Data.Vector as V + +import Erb.Ruby +import Puppet.Interpreter + +rubyEvaluate :: Container ScopeInformation -> Text -> [RubyStatement] -> Either Doc Text +rubyEvaluate vars ctx = foldl (evalruby vars ctx) (Right "") . optimize + where + optimize [] = [] + optimize (Puts x : DropPrevSpace' : xs) = optimize $ DropPrevSpace (Puts x) : xs + optimize (x:xs) = x : optimize xs + +spaceNotCR :: Char -> Bool +spaceNotCR c = Char.isSpace c && c /= '\n' && c /= '\r' + +evalruby :: Container ScopeInformation -> Text -> Either Doc Text -> RubyStatement -> Either Doc Text +evalruby _ _ (Left err) _ = Left err +evalruby _ _ (Right _) (DropPrevSpace') = Left "Could not evaluate a non optimize DropPrevSpace'" +evalruby mp ctx (Right curstr) (DropNextSpace x) = + case evalruby mp ctx (Right curstr) x of + Left err -> Left err + Right y -> Right (Text.dropWhile spaceNotCR y) +evalruby mp ctx (Right curstr) (DropPrevSpace x) = + case evalruby mp ctx (Right curstr) x of + Left err -> Left err + Right y -> Right (Text.dropWhileEnd spaceNotCR y) +evalruby mp ctx (Right curstr) (Puts e) = case evalExpression mp ctx e of + Left err -> Left err + Right ex -> Right (curstr <> ex) + +evalExpression :: Container ScopeInformation -> Text -> Expression -> Either Doc Text +evalExpression mp ctx (LookupOperation varname varindex) = do + rvname <- evalExpression mp ctx varname + rvindx <- evalExpression mp ctx varindex + getVariable mp ctx rvname >>= \case + PArray arr -> + case a2i rvindx of + Nothing -> Left $ "Can't convert index to integer when resolving" <+> ppline rvname <> brackets (ppline rvindx) + Just i -> if fromIntegral (V.length arr) <= i + then Left $ "Array out of bound" <+> ppline rvname <> brackets (ppline rvindx) + else evalValue (arr V.! fromIntegral i) + PHash hs -> case hs ^. at rvindx of + Just x -> evalValue x + _ -> Left $ "Can't index variable" <+> ppline rvname <+> ", it is " <+> pretty (PHash hs) + varvalue -> Left $ "Can't index variable" <+> ppline rvname <+> ", it is " <+> pretty varvalue +evalExpression _ _ (Value (Literal x)) = Right x +evalExpression mp ctx (Object (Value (Literal x))) = getVariable mp ctx x >>= evalValue +evalExpression _ _ x = Left $ "Can't evaluate" <+> pretty x + +evalValue :: PValue -> Either Doc Text +evalValue (PString x) = Right x +evalValue (PNumber x) = Right (scientific2text x) +evalValue x = Right $ show x + +a2i :: Text -> Maybe Integer +a2i x = case text2Scientific x of + Just y -> y ^? _Integer + _ -> Nothing diff --git a/src/Puppet/Runner/Preferences.hs b/src/Puppet/Runner/Preferences.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Runner/Preferences.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +module Puppet.Runner.Preferences ( + Preferences(Preferences) + , prefPuppetPaths + , prefPDB + , prefNatTypes + , prefExtFuncs + , prefHieraPath + , prefIgnoredmodules + , prefStrictness + , prefExtraTests + , prefKnownusers + , prefKnowngroups + , prefExternalmodules + , prefPuppetSettings + , prefFactsOverride + , prefFactsDefault + , prefLogLevel + , prefRebaseFile + , dfPreferences + , PuppetDirPaths + , HasPuppetDirPaths(..) +) where + +import XPrelude + +import Data.Aeson +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import qualified Data.Text as Text +import qualified Data.Yaml as Yaml +import qualified System.Log.Logger as LOG +import System.Posix (fileExist) + +import Puppet.Interpreter +import qualified Puppet.Runner.Puppetlabs as Puppetlabs +import Puppet.Runner.Stdlib +import PuppetDB + +data Preferences m = Preferences + { _prefPuppetPaths :: PuppetDirPaths + , _prefPDB :: PuppetDBAPI m + , _prefNatTypes :: Container NativeTypeMethods -- ^ The list of native types. + , _prefExtFuncs :: Container ([PValue] -> InterpreterMonad PValue) + , _prefHieraPath :: Maybe FilePath + , _prefIgnoredmodules :: HS.HashSet Text + , _prefStrictness :: Strictness + , _prefExtraTests :: Bool + , _prefKnownusers :: [Text] + , _prefKnowngroups :: [Text] + , _prefExternalmodules :: HS.HashSet Text + , _prefPuppetSettings :: Container Text + , _prefFactsOverride :: Container PValue + , _prefFactsDefault :: Container PValue + , _prefLogLevel :: LOG.Priority + , _prefRebaseFile :: Maybe FilePath -- ^ Make all calls to file() with absolute pathes relative to the given path. + } + +data Defaults = Defaults + { _dfKnownusers :: Maybe [Text] + , _dfKnowngroups :: Maybe [Text] + , _dfIgnoredmodules :: Maybe [Text] + , _dfStrictness :: Maybe Strictness + , _dfExtratests :: Maybe Bool + , _dfExternalmodules :: Maybe [Text] + , _dfPuppetSettings :: Maybe (Container Text) + , _dfFactsDefault :: Maybe (Container PValue) + , _dfFactsOverride :: Maybe (Container PValue) + , _dfRebaseFile :: Maybe FilePath + } deriving (Show) + + +makeLenses ''Preferences + +instance FromJSON Defaults where + parseJSON (Object v) = Defaults + <$> v .:? "knownusers" + <*> v .:? "knowngroups" + <*> v .:? "ignoredmodules" + <*> v .:? "strict" + <*> v .:? "extratests" + <*> v .:? "externalmodules" + <*> v .:? "settings" + <*> v .:? "factsdefault" + <*> v .:? "factsoverride" + <*> v .:? "rebasefile" + parseJSON _ = mzero + +-- | Generate default preferences. +dfPreferences :: FilePath + -> IO (Preferences IO) +dfPreferences basedir = do + let dirpaths = puppetPaths basedir + modulesdir = dirpaths ^. modulesPath + testdir = dirpaths ^. testPath + hierafile = basedir <> "/hiera.yaml" + defaultfile = testdir <> "/defaults.yaml" + defaults <- ifM (fileExist defaultfile) (Yaml.decodeFile defaultfile) (pure Nothing) + hieradir <- ifM (fileExist hierafile) (pure $ Just hierafile) (pure Nothing) + loadedtypes <- loadedTypes modulesdir + labsFunctions <- Puppetlabs.extFunctions modulesdir + return $ Preferences dirpaths + dummyPuppetDB + (baseNativeTypes `HM.union` loadedtypes) + (HM.union stdlibFunctions labsFunctions) + hieradir + (getIgnoredmodules defaults) + (getStrictness defaults) + (getExtraTests defaults) + (getKnownusers defaults) + (getKnowngroups defaults) + (getExternalmodules defaults) + (getPuppetSettings dirpaths defaults) + (getFactsOverride defaults) + (getFactsDefault defaults) + LOG.NOTICE -- good default as INFO is quite noisy + Nothing + +loadedTypes :: FilePath -> IO (HM.HashMap NativeTypeName NativeTypeMethods) +loadedTypes modulesdir = do + typenames <- fmap (map takeBaseName) (getFiles (Text.pack modulesdir) "lib/puppet/type" ".rb") + pure $ HM.fromList (map defaulttype typenames) + +-- Utilities for getting default values from the yaml file +-- It provides (the same) static defaults (see the 'Nothing' case) when +-- no default yaml file or +-- not key/value for the option has been provided +getKnownusers :: Maybe Defaults -> [Text] +getKnownusers = fromMaybe ["mysql", "vagrant","nginx", "nagios", "postgres", "puppet", "root", "syslog", "www-data"] . (>>= _dfKnownusers) + +getKnowngroups :: Maybe Defaults -> [Text] +getKnowngroups = fromMaybe ["adm", "syslog", "mysql", "nagios","postgres", "puppet", "root", "www-data", "postfix"] . (>>= _dfKnowngroups) + +getStrictness :: Maybe Defaults -> Strictness +getStrictness = fromMaybe Permissive . (>>= _dfStrictness) + +getIgnoredmodules :: Maybe Defaults -> HS.HashSet Text +getIgnoredmodules = maybe mempty HS.fromList . (>>= _dfIgnoredmodules) + +getExtraTests :: Maybe Defaults -> Bool +getExtraTests = fromMaybe True . (>>= _dfExtratests) + +getExternalmodules :: Maybe Defaults -> HS.HashSet Text +getExternalmodules = maybe mempty HS.fromList . (>>= _dfExternalmodules) + +getPuppetSettings :: PuppetDirPaths -> Maybe Defaults -> Container Text +getPuppetSettings dirpaths = fromMaybe df . (>>= _dfPuppetSettings) + where + df :: Container Text + df = HM.fromList [ ("confdir", Text.pack $ dirpaths^.baseDir) + , ("strict_variables", "true") + ] + +getFactsOverride :: Maybe Defaults -> Container PValue +getFactsOverride = fromMaybe mempty . (>>= _dfFactsOverride) + +getFactsDefault :: Maybe Defaults -> Container PValue +getFactsDefault = fromMaybe mempty . (>>= _dfFactsDefault) diff --git a/src/Puppet/Runner/Puppetlabs.hs b/src/Puppet/Runner/Puppetlabs.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Runner/Puppetlabs.hs @@ -0,0 +1,123 @@ +-- | Contains an Haskell implementation (or mock implementation) of some ruby functions found in puppetlabs modules. +module Puppet.Runner.Puppetlabs (extFunctions) where + +import XPrelude + +import Crypto.Hash as Crypto +import Data.ByteString (ByteString) +import Data.Foldable (foldlM) +import qualified Data.HashMap.Strict as HM +import Data.Scientific as Sci +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Vector (Vector) +import Formatting (scifmt, sformat, (%), (%.)) +import qualified Formatting as FMT +import System.Posix.Files (fileExist) +import System.Random (mkStdGen, randomRs) + +import Puppet.Interpreter + +md5 :: Text -> Text +md5 = Text.pack . show . (Crypto.hash :: ByteString -> Digest MD5) . Text.encodeUtf8 + +extFun :: [(FilePath, Text, [PValue] -> InterpreterMonad PValue)] +extFun = [ ("/apache", "bool2httpd", apacheBool2httpd) + , ("/docker", "docker_run_flags", mockDockerRunFlags) + , ("/jenkins", "jenkins_port", mockJenkinsPort) + , ("/jenkins", "jenkins_prefix", mockJenkinsPrefix) + , ("/postgresql", "postgresql_acls_to_resources_hash", pgAclsToHash) + , ("/postgresql", "postgresql_password", pgPassword) + , ("/extlib", "random_password", randomPassword) + , ("/extlib", "cache_data", mockCacheData) + ] + +-- | Build the map of available external functions. +-- +-- If the ruby file is not found on the local filesystem the record is ignored. This is to avoid potential namespace conflict. +extFunctions :: FilePath -> IO (Container ( [PValue] -> InterpreterMonad PValue)) +extFunctions modpath = foldlM f HM.empty extFun + where + f acc (modname, fname, fn) = do + test <- testFile modname fname + if test + then return $ HM.insert fname fn acc + else return acc + testFile modname fname = fileExist (modpath <> modname <> "/lib/puppet/parser/functions/" <> Text.unpack fname <>".rb") + +apacheBool2httpd :: MonadThrowPos m => [PValue] -> m PValue +apacheBool2httpd [PBoolean True] = return $ PString "On" +apacheBool2httpd [PString "true"] = return $ PString "On" +apacheBool2httpd [_] = return $ PString "Off" +apacheBool2httpd arg@_ = throwPosError $ "expect one single argument" <+> pretty arg + +pgPassword :: MonadThrowPos m => [PValue] -> m PValue +pgPassword [PString username, PString pwd] = + return $ PString $ "md5" <> md5 (pwd <> username) +pgPassword _ = throwPosError "expects 2 string arguments" + +-- | The function is pure and always return the same "random" password. +randomPassword :: MonadThrowPos m => [PValue] -> m PValue +randomPassword [PNumber s] = + PString . Text.pack . randomChars <$> scientificToInt s + where + randomChars n = take n $ randomRs ('a', 'z') (mkStdGen 1) + +randomPassword _ = throwPosError "expect one single string arguments" + + +-- To be implemented if needed. +mockJenkinsPrefix :: MonadThrowPos m => [PValue] -> m PValue +mockJenkinsPrefix [] = return $ PString "" +mockJenkinsPrefix arg@_ = throwPosError $ "expect no argument" <+> pretty arg + +-- To be implemented if needed. +mockJenkinsPort :: MonadThrowPos m => [PValue] -> m PValue +mockJenkinsPort [] = return $ PString "8080" +mockJenkinsPort arg@_ = throwPosError $ "expect no argument" <+> pretty arg + +mockCacheData :: MonadThrowPos m => [PValue] -> m PValue +mockCacheData [_, _, b] = return b +mockCacheData arg@_ = throwPosError $ "expect 3 string arguments" <+> pretty arg + +-- | Simple implemenation that does not handle all cases. +-- For instance 'auth_option' is currently not implemented. +-- Please add cases as needed. +pgAclsToHash :: MonadThrowPos m => [PValue] -> m PValue +pgAclsToHash [PArray as, PString ident, PNumber offset] = do + x <- aclsToHash as ident offset + return $ PHash x +pgAclsToHash _ = throwPosError "expects 3 arguments; one array one string and one number" + +aclsToHash :: MonadThrowPos m => Vector PValue -> Text -> Scientific -> m (Container PValue) +aclsToHash vec ident offset = ifoldlM f HM.empty vec + where + f :: MonadThrowPos m => Int -> Container PValue -> PValue -> m (Container PValue) + f idx acc (PString acl) = do + let order = offset + scientific (toInteger idx) 0 + keymsg = sformat ("postgresql class generated rule " % FMT.stext % " " % FMT.int) ident idx + x <- aclToHash (Text.words acl) order + return $ HM.insert keymsg x acc + f _ _ pval = throwPosError $ "expect a string as acl but get" <+> pretty pval + +aclToHash :: (MonadThrowPos m) => [Text] -> Scientific -> m PValue +aclToHash [typ, db, usr, addr, auth] order = + return $ PHash $ HM.fromList [ ("type", PString typ) + , ("database", PString db ) + , ("user", PString usr) + , ("order", PString (sformat (FMT.left 3 '0' %. scifmt Sci.Fixed (Just 0)) order)) + , ("address", PString addr) + , ("auth_method", PString auth) + ] +aclToHash acl _ = throwPosError $ "Unable to parse acl line" <+> squotes (ppline (Text.unwords acl)) + +-- faked implementation, replace by the correct one if you need so. +mockDockerRunFlags :: MonadThrowPos m => [PValue] -> m PValue +mockDockerRunFlags arg@[PHash _]= (pure . PString . show . head) arg +mockDockerRunFlags arg@_ = throwPosError $ "Expect an hash as argument but was" <+> pretty arg + +-- utils +scientificToInt :: MonadThrowPos m => Scientific -> m Int +scientificToInt s = maybe (throwPosError $ "Unable to convert" <+> ppline (show s) <+> "into an int.") + return + (Sci.toBoundedInteger s) diff --git a/src/Puppet/Runner/Pure.hs b/src/Puppet/Runner/Pure.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Runner/Pure.hs @@ -0,0 +1,174 @@ +-- | Publicly exposed pure helpers to evaluate the 'InterpreterMonad' +-- functions that can be found in "Puppet.Interpreter" and +-- "Puppet.Interpreter.Resolve". +-- +-- >>> dummyEval (resolveExpression (Addition "1" "2")) +-- Right (PString "3") +module Puppet.Runner.Pure ( + dummyEval + , dummyFacts + , pureEval + , pureEval' + , pureReader +) where + +import XPrelude + +import qualified Data.Either.Strict as S +import qualified Data.HashMap.Strict as HM + +import Erb +import Facter +import Hiera.Server +import Puppet.Interpreter +import Puppet.Parser (Statement) +import Puppet.Runner.Erb +import PuppetDB (dummyPuppetDB) + + +dummyTemplate :: Monad m => Either Text Text -> InterpreterState -> InterpreterReader m -> m (S.Either PrettyError Text) +dummyTemplate (Right _) _ _ = return (S.Left "Can't interpret files") +dummyTemplate (Left cnt) s _ = + return $ case extractFromState s of + Nothing -> S.Left "Context retrieval error (pureReader)" + Just (ctx, scope) -> + case parseErbString (toS cnt) of + Left e -> S.Left (PrettyError (pplines (show e))) + Right stmts -> + case rubyEvaluate scope ctx stmts of + Right x -> S.Right x + Left e -> S.Left (PrettyError e) + +-- | A pure 'InterpreterReader', that can only evaluate a subset of the +-- templates, and that can include only the supplied top level statements. +pureReader :: HM.HashMap (TopLevelType, Text) Statement -- ^ A top-level statement map + -> InterpreterReader Identity +pureReader sttmap = + InterpreterReader + baseNativeTypes + getstatementdummy + dummyTemplate + dummyPuppetDB + mempty + "dummy" + hieradummy + iomethods_purestubs + mempty + mempty + True + (puppetPaths "/etc/puppet") + Nothing + where + pure_hiera :: HieraQueryFunc Identity + pure_hiera _ _ _ = pure (S.Right (Just "pure")) + hieradummy = HieraQueryLayers pure_hiera mempty + getstatementdummy tlt n = return $ case HM.lookup (tlt,n) sttmap of + Just x -> S.Right x + Nothing -> S.Left "Can't get statement" + iomethods_purestubs :: IoMethods Identity + iomethods_purestubs = IoMethods (return []) (const (return (Left "Can't read file"))) (\_ -> return ()) + +-- | Evaluates an interpreter expression in a pure context. +pureEval :: Facts -- ^ A list of facts that will be used during evaluation + -> HM.HashMap (TopLevelType, Text) Statement -- ^ A top-level map + -> InterpreterMonad a -- ^ The action to evaluate + -> (Either PrettyError a, InterpreterState, InterpreterWriter) +pureEval facts stmap action = + pureEval' stmap state0 action + where + state0 = initialState facts $ HM.fromList [("confdir", "/etc/puppet")] + +-- | More general version of 'pureEval' where you pass the initial state directly +pureEval' :: HM.HashMap (TopLevelType, Text) Statement -- ^ A top-level map + -> InterpreterState + -> InterpreterMonad a -- ^ The action to evaluate + -> (Either PrettyError a, InterpreterState, InterpreterWriter) +pureEval' stmap s0 action = + runIdentity (interpretMonad (pureReader stmap) s0 action) + + +-- | A bunch of facts that can be used for pure evaluation. +dummyFacts :: Facts +dummyFacts = HM.fromList + [ ("architecture", "amd64") + , ("augeasversion", "0.10.0") + , ("bios_release_date", "07/06/2010") + , ("bios_vendor", "Dell Inc.") + , ("bios_version", "2.2.0") + , ("boardmanufacturer", "Dell Inc.") + , ("domain", "dummy.domain") + , ("facterversion", "1.7.5") + , ("filesystems", "ext2,ext3,ext4,vfat") + , ("fqdn", "dummy.dummy.domain") + , ("hardwareisa", "x86_64") + , ("hardwaremodel", "x86_64") + , ("hostname", "dummy") + , ("id", "root") + , ("interfaces", "eth0,lo") + , ("ipaddress", "172.17.42.1") + , ("ipaddress_eth0", "172.17.42.1") + , ("ipaddress_lo", "127.0.0.1") + , ("is_virtual", "false") + , ("kernel", "Linux") + , ("kernelmajversion", "3.8") + , ("kernelrelease", "3.8.0-37-generic") + , ("kernelversion", "3.8.0") + , ("lsbdistcodename", "precise") + , ("lsbdistdescription", "Ubuntu 12.04.4 LTS") + , ("lsbdistid", "Ubuntu") + , ("lsbdistrelease", "12.04") + , ("lsbmajdistrelease", "12") + , ("macaddress", "a5:cb:10:b0:9a:4b") + , ("macaddress_eth0", "72:53:10:c1:eb:70") + , ("manufacturer", "Dell Inc.") + , ("memoryfree", "12.57 GB") + , ("memoryfree_mb", "12869.89") + , ("memorysize", "15.63 GB") + , ("memorysize_mb", "16009.07") + , ("memorytotal", "15.63 GB") + , ("mtu_eth0", "1500") + , ("mtu_lo", "65536") + , ("netmask", "255.255.0.0") + , ("netmask_eth0", "255.255.255.0") + , ("netmask_lo", "255.0.0.0") + , ("network_eth0", "172.17.42.0") + , ("network_lo", "127.0.0.0") + , ("operatingsystem", "Ubuntu") + , ("operatingsystemrelease", "12.04") + , ("osfamily", "Debian") + , ("path", "/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin") + , ("physicalprocessorcount", "1") + , ("processor0", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz") + , ("processor1", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz") + , ("processor2", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz") + , ("processor3", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz") + , ("processor4", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz") + , ("processor5", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz") + , ("processor6", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz") + , ("processor7", "Intel(R) Core(TM) i7 CPU 860 @ 2.80GHz") + , ("processorcount", "8") + , ("productname", "Vostro 430") + , ("ps", "ps -ef") + , ("puppetversion", "3.4.3") + , ("rubysitedir", "/usr/local/lib/site_ruby/1.8") + , ("rubyversion", "1.8.7") + , ("selinux", "false") + , ("serialnumber", "9L3FW4J") + , ("swapfree", "15.96 GB") + , ("swapfree_mb", "16340.00") + , ("swapsize", "15.96 GB") + , ("swapsize_mb", "16340.00") + , ("timezone", "CEST") + , ("type", "Desktop") + , ("uniqueid", "007f0101") + , ("uptime", "5:48 hours") + , ("uptime_days", "0") + , ("uptime_hours", "5") + , ("uptime_seconds", "20932") + , ("uuid", "97b75940-be55-11e3-b1b6-0800200c9a66") + , ("virtual", "physical") + ] + +-- | A default evaluation function for arbitrary interpreter actions. +dummyEval :: InterpreterMonad a -> Either PrettyError a +dummyEval action = pureEval dummyFacts mempty action ^. _1 diff --git a/src/Puppet/Runner/Stats.hs b/src/Puppet/Runner/Stats.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Runner/Stats.hs @@ -0,0 +1,71 @@ +{-| 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.Runner.Stats + ( measure + , newStats + , getStats + , StatsPoint(..) + , MStats + ) where + +import XPrelude + +import Data.Time.Clock.POSIX (getPOSIXTime) +import qualified Data.HashMap.Strict as Map + +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 = HashMap Text StatsPoint + +newtype MStats = MStats { unMStats :: MVar StatsTable } + +-- | Returns the actual statistical values. +getStats :: MStats -> IO StatsTable +getStats = readMVar . unMStats + +-- | Create a new statistical container. +newStats :: IO MStats +newStats = MStats `fmap` newMVar Map.empty + +-- | Wraps a computation, and measures related execution statistics. +measure :: MStats -- ^ Statistics container + -> Text -- ^ Action identifier + -> IO a -- ^ Computation + -> IO a +measure (MStats mtable) statsname action = do + (!tm, !out) <- time action + !stats <- takeMVar mtable + let nstats :: StatsTable + !nstats = case stats ^. at statsname of + Nothing -> stats & at statsname ?~ StatsPoint 1 tm tm tm + Just (StatsPoint sc st smi sma) -> + let !nmax = if tm > sma + then tm + else sma + !nmin = if tm < smi + then tm + else smi + in stats & at statsname ?~ StatsPoint (sc+1) (st+tm) nmin nmax + putMVar mtable nstats + return $! out + +getTime :: IO Double +getTime = realToFrac `fmap` getPOSIXTime + +time :: IO a -> IO (Double, a) +time action = do + start <- getTime + !result <- action + end <- getTime + let !delta = end - start + return (delta, result) diff --git a/src/Puppet/Runner/Stdlib.hs b/src/Puppet/Runner/Stdlib.hs new file mode 100644 --- /dev/null +++ b/src/Puppet/Runner/Stdlib.hs @@ -0,0 +1,495 @@ +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +module Puppet.Runner.Stdlib (stdlibFunctions) where + +import XPrelude hiding (sort) + +import Data.Aeson.Lens +import qualified Data.ByteString.Base16 as B16 +import qualified Data.Char as Char +import qualified Data.HashMap.Strict as HM +import qualified Data.List as List +import qualified Data.List.Split as List (chunksOf) +import qualified Data.Scientific as Scientific +import qualified Data.Text as Text +import qualified Data.Vector as V +import Data.Vector.Lens (toVectorOf) +import qualified Text.Regex.PCRE.ByteString.Utils as Regex + +import Puppet.Interpreter + +-- | Contains the implementation of the StdLib functions. +stdlibFunctions :: Container ( [PValue] -> InterpreterMonad PValue ) +stdlibFunctions = HM.fromList [ singleArgument "abs" puppetAbs + , ("any2array", any2array) + , ("assert_private", assertPrivate) + , ("base64", base64) + -- basename + , singleArgument "bool2num" bool2num + -- bool2str + -- camelcase + , ("capitalize", stringArrayFunction (safeEmptyString (\t -> Text.cons (Char.toUpper (Text.head t)) (Text.tail t)))) + -- ceiling + , ("chomp", stringArrayFunction (Text.dropWhileEnd (\c -> c == '\n' || c == '\r'))) + , ("chop", stringArrayFunction (safeEmptyString Text.init)) + -- clamp + , ("concat", puppetConcat) + -- convert_base + , ("count", puppetCount) + -- deep_merge + , ("defined_with_params", const (throwPosError "defined_with_params can't be implemented with language-puppet")) + , ("delete", delete) + , ("delete_at", deleteAt) + , singleArgument "delete_undef_values" deleteUndefValues + -- delete_values + -- difference + -- dirname + -- dos2unix + , ("downcase", stringArrayFunction Text.toLower) + , singleArgument "empty" _empty + -- ensure_packages (in main interpreter module) + -- ensure_resource (in main interpreter module) + , singleArgument "flatten" flatten + -- floor + -- fqdn_rand_string + -- fqdn_rotate + -- get_module_path + , ("getparam", const $ throwPosError "The getparam function is uncool and shall not be implemented in language-puppet") + , singleArgument "getvar" getvar + , ("grep", _grep) + , ("hash", hash) + -- has_interface_with + -- has_ip_address + -- has_ip_network + , ("has_key", hasKey) + -- intersection + -- is_absolute_path + , singleArgument "is_array" isArray + , singleArgument "is_bool" isBool + , singleArgument "is_domain_name" isDomainName + -- is_float + -- is_function_available + , singleArgument "is_hash" isHash + , singleArgument "is_integer" isInteger + -- is_ip_address + -- is_mac_address + -- is_numeric + , singleArgument "is_string" isString + , ("join", puppetJoin) + , ("join_keys_to_values", joinKeysToValues) + , singleArgument "keys" keys + -- load_module_metadata + -- loadyaml + , ("lstrip", stringArrayFunction Text.stripStart) + -- max + , ("member", member) + , ("merge", merge) + -- min + -- num2bool + -- parsejson + -- parseyaml + , ("pick", pick) + , ("pick_default", pickDefault) + -- prefix + -- private + -- pw_hash + -- range + -- reject + -- reverse + , ("rstrip", stringArrayFunction Text.stripEnd) + -- seeded_rand + -- shuffle + , singleArgument "size" size + , singleArgument "sort" sort + -- squeeze + , singleArgument "str2bool" str2Bool + -- strtosaltedshar512 + -- strftime + , ("strip", stringArrayFunction Text.strip) + -- suffix + -- swapcase + -- time + -- to_bytes + -- try_get_value + -- type3x + -- type + -- union + -- unique + -- unix2dos + , ("upcase", stringArrayFunction Text.toUpper) + -- uriescape + , ("validate_absolute_path", validateAbsolutePath) + , ("validate_array", validateArray) + -- validate_augeas + , ("validate_bool", validateBool) + -- validate_cmd + , ("validate_hash", validateHash) + , ("validate_integer", validateInteger) + -- validate_ip_address + -- validate_ipv4_address + -- validate_ipv6_address + , ("validate_numeric", validateNumeric) + , ("validate_re", validateRe) + -- validate_slength + , ("validate_string", validateString) + -- validate_x509_rsa_key_pair + -- values_at + , singleArgument "values" pvalues + -- zip + ] + +singleArgument :: Text -> (PValue -> InterpreterMonad PValue) -> (Text, [PValue] -> InterpreterMonad PValue ) +singleArgument fname ifunc = (fname, ofunc) + where + ofunc [x] = ifunc x + ofunc _ = throwPosError (ppline fname <> "(): Expects a single argument.") + +safeEmptyString :: (Text -> Text) -> Text -> Text +safeEmptyString _ "" = "" +safeEmptyString f x = f x + +stringArrayFunction :: (Text -> Text) -> [PValue] -> InterpreterMonad PValue +stringArrayFunction f [PString s] = return (PString (f s)) +stringArrayFunction f [PArray xs] = fmap PArray (V.mapM (fmap (PString . f) . resolvePValueString) xs) +stringArrayFunction _ [a] = throwPosError ("function expects a string or an array of strings, not" <+> pretty a) +stringArrayFunction _ _ = throwPosError "function expects a single argument" + +compileRE :: Text -> InterpreterMonad Regex +compileRE r = + case Regex.compile' Regex.compBlank Regex.execBlank (encodeUtf8 r) of + Left rr -> throwPosError ("Could not compile" <+> ppline r <+> ":" <+> ppline (show rr)) + Right x -> return x + +matchRE :: Regex -> Text -> InterpreterMonad Bool +matchRE r t = + case Regex.execute' r (encodeUtf8 t) of + Left rr -> throwPosError ("Could not match:" <+> pplines (show rr)) + Right m -> return (has _Just m) + +puppetAbs :: PValue -> InterpreterMonad PValue +puppetAbs y = case y ^? _Number of + Just x -> return $ _Number # abs x + Nothing -> throwPosError ("abs(): Expects a number, not" <+> pretty y) + +assertPrivate :: [PValue] -> InterpreterMonad PValue +assertPrivate args = + case args of + [] -> go Nothing + [pv] -> resolvePValueString pv >>= go . Just + _ -> throwPosError "assert_private: expects no or a single string argument" + where + go :: Maybe Text -> InterpreterMonad PValue + go msg = do + scp <- use curScope + case scp of + funScope:callerScope:_ -> + let takeModule = Text.takeWhile (/= ':') . containerModName + in if takeModule funScope == takeModule callerScope + then return PUndef + else throwPosError $ maybe ("assert_private: failed: " <> pretty funScope <> " is private") ppline msg + _ -> return PUndef + +any2array :: [PValue] -> InterpreterMonad PValue +any2array [PArray v] = return (PArray v) +any2array [PHash h] = return (PArray lst) + where + lst = V.fromList $ concatMap arraypair $ HM.toList h + arraypair (a,b) = [PString a, b] +any2array [x] = return (PArray (V.singleton x)) +any2array x = return (PArray (V.fromList x)) + +base64 :: [PValue] -> InterpreterMonad PValue +base64 [pa,pb] = do + b <- encodeUtf8 <$> (resolvePValueString pb) + r <- resolvePValueString pa >>= \case + "encode" -> return (B16.encode b) + "decode" -> case B16.decode b of + (x, "") -> return x + _ -> throwPosError ("base64(): could not decode" <+> pretty pb) + a -> throwPosError ("base64(): the first argument must be either 'encode' or 'decode', not" <+> ppline a) + pure $ PString (decodeUtf8 r) +base64 _ = throwPosError "base64(): Expects 2 arguments" + +bool2num :: PValue -> InterpreterMonad PValue +bool2num (PString "") = return (PBoolean False) +bool2num (PString "1") = return (PBoolean True) +bool2num (PString "t") = return (PBoolean True) +bool2num (PString "y") = return (PBoolean True) +bool2num (PString "true") = return (PBoolean True) +bool2num (PString "yes") = return (PBoolean True) +bool2num (PString "0") = return (PBoolean False) +bool2num (PString "f") = return (PBoolean False) +bool2num (PString "n") = return (PBoolean False) +bool2num (PString "false") = return (PBoolean False) +bool2num (PString "no") = return (PBoolean False) +bool2num (PString "undef") = return (PBoolean False) +bool2num (PString "undefined") = return (PBoolean False) +bool2num x@(PBoolean _) = return x +bool2num x = throwPosError ("bool2num(): Can't convert" <+> pretty x <+> "to boolean") + +puppetConcat :: [PValue] -> InterpreterMonad PValue +puppetConcat = return . PArray . V.concat . map toArr + where + toArr (PArray x) = x + toArr x = V.singleton x + +puppetCount :: [PValue] -> InterpreterMonad PValue +puppetCount [PArray x] = return (_Integer # V.foldl' cnt 0 x) + where + cnt cur (PString "") = cur + cnt cur PUndef = cur + cnt cur _ = cur + 1 +puppetCount [PArray x, y] = return (_Integer # V.foldl' cnt 0 x) + where + cnt cur z | y == z = cur + 1 + | otherwise = cur +puppetCount _ = throwPosError "count(): expects 1 or 2 arguments" + +delete :: [PValue] -> InterpreterMonad PValue +delete [PString x, y] = fmap (PString . Text.concat . (`Text.splitOn` x)) (resolvePValueString y) +delete [PArray r, z] = return $ PArray $ V.filter (/= z) r +delete [PHash h, z] = do + tz <- resolvePValueString z + return $ PHash (h & at tz .~ Nothing) +delete [a,_] = throwPosError ("delete(): First argument must be an Array, String, or Hash. Given:" <+> pretty a) +delete _ = throwPosError "delete(): expects 2 arguments" + +deleteAt :: [PValue] -> InterpreterMonad PValue +deleteAt [PArray r, z] = case z ^? _Integer of + Just gn -> + let n = fromInteger gn + lr = V.length r + s1 = V.slice 0 n r + s2 = V.slice (n+1) (lr - n - 1) r + in if V.length r <= n + then throwPosError ("delete_at(): Out of bounds access detected, tried to remove index" <+> pretty z <+> "wheras the array only has" <+> pplines (show lr) <+> "elements") + else return (PArray (s1 <> s2)) + _ -> throwPosError ("delete_at(): The second argument must be an integer, not" <+> pretty z) +deleteAt [x,_] = throwPosError ("delete_at(): expects its first argument to be an array, not" <+> pretty x) +deleteAt _ = throwPosError "delete_at(): expects 2 arguments" + +deleteUndefValues :: PValue -> InterpreterMonad PValue +deleteUndefValues (PArray r) = return $ PArray $ V.filter (/= PUndef) r +deleteUndefValues (PHash h) = return $ PHash $ HM.filter (/= PUndef) h +deleteUndefValues x = throwPosError ("delete_undef_values(): Expects an Array or a Hash, not" <+> pretty x) + +_empty :: PValue -> InterpreterMonad PValue +_empty = return . PBoolean . flip elem [PUndef, PString "", PString "undef", PArray V.empty, PHash HM.empty] + +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 + +_grep :: [PValue] -> InterpreterMonad PValue +_grep [PArray vls, rawre] = do + regexp <- resolvePValueString rawre >>= compileRE + rvls <- for vls $ \v -> do + r <- resolvePValueString v + ismatched <- matchRE regexp r + return (r, ismatched) + return $ PArray $ V.map (PString . fst) (V.filter snd rvls) +_grep [x,_] = throwPosError ("grep(): The first argument must be an Array, not" <+> pretty x) +_grep _ = throwPosError "grep(): Expected two arguments." + +hash :: [PValue] -> InterpreterMonad PValue +hash [PArray elems] = do + let xs = mapMaybe assocPairs $ List.chunksOf 2 $ V.toList elems + assocPairs [a,b] = Just (a,b) + assocPairs _ = Nothing + PHash . HM.fromList <$> mapM (\(k,v) -> (,v) <$> resolvePValueString k) xs +hash _ = throwPosError "hash(): Expected and array." + +isArray :: PValue -> InterpreterMonad PValue +isArray = return . PBoolean . has _PArray + +isDomainName :: PValue -> InterpreterMonad PValue +isDomainName s = do + rs <- resolvePValueString s + let ndrs = if Text.last rs == '.' + then Text.init rs + else rs + prts = Text.splitOn "." ndrs + checkPart x = not (Text.null x) + && (Text.length x <= 63) + && (Text.head x /= '-') + && (Text.last x /= '-') + && Text.all (\y -> Char.isAlphaNum y || y == '-') x + return $ PBoolean $ not (Text.null rs) && Text.length rs <= 255 && all checkPart prts + +isInteger :: PValue -> InterpreterMonad PValue +isInteger = return . PBoolean . has _Integer + +isHash :: PValue -> InterpreterMonad PValue +isHash = return . PBoolean . has _PHash + +isString :: PValue -> InterpreterMonad PValue +isString pv = return $ PBoolean $ case (pv ^? _PString, pv ^? _Number) of + (_, Just _) -> False + (Just _, _) -> True + _ -> False + +isBool :: PValue -> InterpreterMonad PValue +isBool = return . PBoolean . has _PBoolean + +puppetJoin :: [PValue] -> InterpreterMonad PValue +puppetJoin [PArray rr, PString interc] = do + rrt <- mapM resolvePValueString (V.toList rr) + return (PString (Text.intercalate interc rrt)) +puppetJoin [_,_] = throwPosError "join(): expected an array of strings, and a string" +puppetJoin _ = throwPosError "join(): expected two arguments" + +joinKeysToValues :: [PValue] -> InterpreterMonad PValue +joinKeysToValues [PHash h, separator] = do + ssep <- resolvePValueString separator + fmap (PArray . V.fromList) $ forM (itoList h) $ \(k,v) -> do + sv <- case v of + PUndef -> return "" + _ -> resolvePValueString v + return (PString (k <> ssep <> sv)) +joinKeysToValues _ = throwPosError "join_keys_to_values(): expects 2 arguments, an hash and a string" + +keys :: PValue -> InterpreterMonad PValue +keys (PHash h) = return (PArray $ V.fromList $ map PString $ HM.keys h) +keys x = throwPosError ("keys(): Expects a Hash, not" <+> pretty x) + +member :: [PValue] -> InterpreterMonad PValue +member [PArray v, x] = return $ PBoolean (x `V.elem` v) +member _ = throwPosError "member() expects 2 arguments" + +hasKey :: [PValue] -> InterpreterMonad PValue +hasKey [PHash h, k] = do + k' <- resolvePValueString k + return (PBoolean (has (ix k') h)) +hasKey [a, _] = throwPosError ("has_key(): expected a Hash, not" <+> pretty a) +hasKey _ = throwPosError "has_key(): expected two arguments." + +merge :: [PValue] -> InterpreterMonad PValue +merge xs | length xs < 2 = throwPosError "merge(): Expects at least two hashes" + | otherwise = let hashcontents = mapM (preview _PHash) xs + in case hashcontents of + Nothing -> throwPosError "merge(): Expects hashes" + Just hashes -> return $ PHash (getDual $ foldMap Dual hashes) + +pick :: [PValue] -> InterpreterMonad PValue +pick [] = throwPosError "pick(): must receive at least one non empty value" +pick xs = + case filter (`notElem` [PUndef, PString "", PString "undef"]) xs of + [] -> throwPosError "pick(): no value suitable to be picked" + (x:_) -> return x + +pickDefault :: [PValue] -> InterpreterMonad PValue +pickDefault [] = throwPosError "pick_default(): must receive at least one non empty value" +pickDefault xs = + case filter (`notElem` [PUndef, PString "", PString "undef"]) xs of + [] -> return (List.last xs) + (x:_) -> return x + +size :: PValue -> InterpreterMonad PValue +size (PHash h) = return (_Integer # fromIntegral (HM.size h)) +size (PArray v) = return (_Integer # fromIntegral (V.length v)) +size (PString s) = return (_Integer # fromIntegral (Text.length s)) +size x = throwPosError ("size(): Expects a hash, and array or a string, not" <+> pretty x) + +sort :: PValue -> InterpreterMonad PValue +sort (PArray s) = + let lst = V.toList s + msort :: Ord a => Prism' PValue a -> Maybe PValue + msort prsm = PArray . V.fromList . map (review prsm) . List.sort <$> mapM (preview prsm) lst + in case (msort _PString <|> msort _PNumber) of + Just x -> return x + _ -> throwPosError "sort(): only homogeneous arrays of numbers or strings are allowed" +sort x = throwPosError ("sort(): Expect to sort an array, not" <+> pretty x) + +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 | Text.head x == '/' = return () + | otherwise = throwPosError (ppline x <+> "is not an absolute path") + +validateArray :: [PValue] -> InterpreterMonad PValue +validateArray [] = throwPosError "validate_array(): wrong number of arguments, must be > 0" +validateArray x = mapM_ vb x >> return PUndef + where + vb (PArray _) = return () + vb y = throwPosError (pretty y <+> "is not an array.") + +validateBool :: [PValue] -> InterpreterMonad PValue +validateBool [] = throwPosError "validate_bool(): wrong number of arguments, must be > 0" +validateBool x = mapM_ vb x >> return PUndef + where + vb (PBoolean _) = return () + vb y = throwPosError (pretty y <+> "is not a boolean.") + +validateHash :: [PValue] -> InterpreterMonad PValue +validateHash [] = throwPosError "validate_hash(): wrong number of arguments, must be > 0" +validateHash x = mapM_ vb x >> return PUndef + 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"] +validateRe [str, PString reg, msg] = validateRe [str, PArray (V.singleton (PString reg)), msg] +validateRe [str, PArray v, msg] = do + rstr <- resolvePValueString str + rest <- mapM (resolvePValueString >=> compileRE >=> flip matchRE rstr) (V.toList v) + if or rest + then return PUndef + else throwPosError (pretty msg <> line <> "Source string:" <+> pretty str <> comma <+> "regexps:" <+> pretty (V.toList v)) +validateRe [_, r, _] = throwPosError ("validate_re(): expected a regexp or an array of regexps, but not" <+> pretty r) +validateRe _ = throwPosError "validate_re(): wrong number of arguments (#{args.length}; must be 2 or 3)" + +validateString :: [PValue] -> InterpreterMonad PValue +validateString [] = throwPosError "validate_string(): wrong number of arguments, must be > 0" +validateString x = mapM_ resolvePValueString x >> return PUndef + +validateInteger :: [PValue] -> InterpreterMonad PValue +validateInteger [] = throwPosError "validate_integer(): wrong number of arguments, must be > 0" +validateInteger x = PUndef <$ mapM_ vb x + where + msg d = pretty d <+> "is not an integer." + check n = unless (Scientific.isInteger n) $ throwPosError (msg n) + vb (PNumber n) = check n + vb (PString s) | Just n <- text2Scientific s = check n + vb a = throwPosError (msg a) + +pvalues :: PValue -> InterpreterMonad PValue +pvalues (PHash h) = return $ PArray (toVectorOf traverse h) +pvalues x = throwPosError ("values(): expected a hash, not" <+> pretty x) diff --git a/src/Puppet/Stats.hs b/src/Puppet/Stats.hs deleted file mode 100644 --- a/src/Puppet/Stats.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-| 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 (measure, newStats, getStats, StatsTable, StatsPoint(..), MStats) where - -import Puppet.Prelude - -import Data.Time.Clock.POSIX (getPOSIXTime) -import qualified Data.HashMap.Strict as HM - -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 Text StatsPoint - -newtype MStats = MStats { unMStats :: MVar StatsTable } --- | Returns the actual statistical values. -getStats :: MStats -> IO StatsTable -getStats = readMVar . unMStats - --- | Create a new statistical container. -newStats :: IO MStats -newStats = MStats `fmap` newMVar HM.empty - --- | Wraps a computation, and measures related execution statistics. -measure :: MStats -- ^ Statistics container - -> Text -- ^ Action identifier - -> IO a -- ^ Computation - -> IO a -measure (MStats mtable) statsname action = do - (!tm, !out) <- time action - !stats <- takeMVar mtable - let nstats :: StatsTable - !nstats = case stats ^. at statsname of - Nothing -> stats & at statsname ?~ StatsPoint 1 tm tm tm - Just (StatsPoint sc st smi sma) -> - let !nmax = if tm > sma - then tm - else sma - !nmin = if tm < smi - then tm - else smi - in stats & at statsname ?~ StatsPoint (sc+1) (st+tm) nmin nmax - putMVar mtable nstats - return $! out - -getTime :: IO Double -getTime = realToFrac `fmap` getPOSIXTime - -time :: IO a -> IO (Double, a) -time action = do - start <- getTime - !result <- action - end <- getTime - let !delta = end - start - return (delta, result) diff --git a/src/Puppet/Stdlib.hs b/src/Puppet/Stdlib.hs deleted file mode 100644 --- a/src/Puppet/Stdlib.hs +++ /dev/null @@ -1,494 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternGuards #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TupleSections #-} -module Puppet.Stdlib (stdlibFunctions) where - -import GHC.Show (Show (..)) -import Puppet.Prelude hiding (show, sort) - -import Data.Aeson.Lens -import qualified Data.ByteString.Base16 as B16 -import qualified Data.Char as Char -import qualified Data.HashMap.Strict as HM -import qualified Data.List as List -import qualified Data.List.Split as List (chunksOf) -import qualified Data.Scientific as Scientific -import qualified Data.Text as Text -import qualified Data.Vector as V -import Data.Vector.Lens (toVectorOf) -import qualified Text.PrettyPrint.ANSI.Leijen as PP -import qualified Text.Regex.PCRE.ByteString.Utils as Regex - -import Puppet.Interpreter.Resolve -import Puppet.Interpreter.Types -import Puppet.Interpreter.Utils -import Puppet.PP - --- | Contains the implementation of the StdLib functions. -stdlibFunctions :: Container ( [PValue] -> InterpreterMonad PValue ) -stdlibFunctions = HM.fromList [ singleArgument "abs" puppetAbs - , ("any2array", any2array) - , ("assert_private", assertPrivate) - , ("base64", base64) - -- basename - , singleArgument "bool2num" bool2num - -- bool2str - -- camelcase - , ("capitalize", stringArrayFunction (safeEmptyString (\t -> Text.cons (Char.toUpper (Text.head t)) (Text.tail t)))) - -- ceiling - , ("chomp", stringArrayFunction (Text.dropWhileEnd (\c -> c == '\n' || c == '\r'))) - , ("chop", stringArrayFunction (safeEmptyString Text.init)) - -- clamp - , ("concat", puppetConcat) - -- convert_base - , ("count", puppetCount) - -- deep_merge - , ("defined_with_params", const (throwPosError "defined_with_params can't be implemented with language-puppet")) - , ("delete", delete) - , ("delete_at", deleteAt) - , singleArgument "delete_undef_values" deleteUndefValues - -- delete_values - -- difference - -- dirname - -- dos2unix - , ("downcase", stringArrayFunction Text.toLower) - , singleArgument "empty" _empty - -- ensure_packages (in main interpreter module) - -- ensure_resource (in main interpreter module) - , singleArgument "flatten" flatten - -- floor - -- fqdn_rand_string - -- fqdn_rotate - -- get_module_path - , ("getparam", const $ throwPosError "The getparam function is uncool and shall not be implemented in language-puppet") - , singleArgument "getvar" getvar - , ("grep", _grep) - , ("hash", hash) - -- has_interface_with - -- has_ip_address - -- has_ip_network - , ("has_key", hasKey) - -- intersection - -- is_absolute_path - , singleArgument "is_array" isArray - , singleArgument "is_bool" isBool - , singleArgument "is_domain_name" isDomainName - -- is_float - -- is_function_available - , singleArgument "is_hash" isHash - , singleArgument "is_integer" isInteger - -- is_ip_address - -- is_mac_address - -- is_numeric - , singleArgument "is_string" isString - , ("join", puppetJoin) - , ("join_keys_to_values", joinKeysToValues) - , singleArgument "keys" keys - -- load_module_metadata - -- loadyaml - , ("lstrip", stringArrayFunction Text.stripStart) - -- max - , ("member", member) - , ("merge", merge) - -- min - -- num2bool - -- parsejson - -- parseyaml - , ("pick", pick) - , ("pick_default", pickDefault) - -- prefix - -- private - -- pw_hash - -- range - -- reject - -- reverse - , ("rstrip", stringArrayFunction Text.stripEnd) - -- seeded_rand - -- shuffle - , singleArgument "size" size - , singleArgument "sort" sort - -- squeeze - , singleArgument "str2bool" str2Bool - -- strtosaltedshar512 - -- strftime - , ("strip", stringArrayFunction Text.strip) - -- suffix - -- swapcase - -- time - -- to_bytes - -- try_get_value - -- type3x - -- type - -- union - -- unique - -- unix2dos - , ("upcase", stringArrayFunction Text.toUpper) - -- uriescape - , ("validate_absolute_path", validateAbsolutePath) - , ("validate_array", validateArray) - -- validate_augeas - , ("validate_bool", validateBool) - -- validate_cmd - , ("validate_hash", validateHash) - , ("validate_integer", validateInteger) - -- validate_ip_address - -- validate_ipv4_address - -- validate_ipv6_address - , ("validate_numeric", validateNumeric) - , ("validate_re", validateRe) - -- validate_slength - , ("validate_string", validateString) - -- validate_x509_rsa_key_pair - -- values_at - , singleArgument "values" pvalues - -- zip - ] - -singleArgument :: Text -> (PValue -> InterpreterMonad PValue) -> (Text, [PValue] -> InterpreterMonad PValue ) -singleArgument fname ifunc = (fname, ofunc) - where - ofunc [x] = ifunc x - ofunc _ = throwPosError (ttext fname <> "(): Expects a single argument.") - -safeEmptyString :: (Text -> Text) -> Text -> Text -safeEmptyString _ "" = "" -safeEmptyString f x = f x - -stringArrayFunction :: (Text -> Text) -> [PValue] -> InterpreterMonad PValue -stringArrayFunction f [PString s] = return (PString (f s)) -stringArrayFunction f [PArray xs] = fmap PArray (V.mapM (fmap (PString . f) . resolvePValueString) xs) -stringArrayFunction _ [a] = throwPosError ("function expects a string or an array of strings, not" <+> pretty a) -stringArrayFunction _ _ = throwPosError "function expects a single argument" - -compileRE :: Text -> InterpreterMonad Regex -compileRE r = case Regex.compile' Regex.compBlank Regex.execBlank (encodeUtf8 r) of - Left rr -> throwPosError ("Could not compile" <+> ttext r <+> ":" <+> string (show rr)) - Right x -> return x - -matchRE :: Regex -> Text -> InterpreterMonad Bool -matchRE r t = case Regex.execute' r (encodeUtf8 t) of - Left rr -> throwPosError ("Could not match:" <+> string (show rr)) - Right m -> return (has _Just m) - -puppetAbs :: PValue -> InterpreterMonad PValue -puppetAbs y = case y ^? _Number of - Just x -> return $ _Number # abs x - Nothing -> throwPosError ("abs(): Expects a number, not" <+> pretty y) - -assertPrivate :: [PValue] -> InterpreterMonad PValue -assertPrivate args = case args of - [] -> go Nothing - [t] -> resolvePValueString t >>= go . Just - _ -> throwPosError "assert_private: expects no or a single string argument" - where - go msg = do - scp <- use curScope - case scp of - funScope : callerScope : _ -> - let takeModule = Text.takeWhile (/= ':') . moduleName - in if takeModule funScope == takeModule callerScope - then return PUndef - else throwPosError $ maybe ("assert_private: failed: " <> pretty funScope <> " is private") ttext msg - _ -> return PUndef - -any2array :: [PValue] -> InterpreterMonad PValue -any2array [PArray v] = return (PArray v) -any2array [PHash h] = return (PArray lst) - where lst = V.fromList $ concatMap arraypair $ HM.toList h - arraypair (a,b) = [PString a, b] -any2array [x] = return (PArray (V.singleton x)) -any2array x = return (PArray (V.fromList x)) - -base64 :: [PValue] -> InterpreterMonad PValue -base64 [pa,pb] = do - b <- encodeUtf8 <$> (resolvePValueString pb) - r <- resolvePValueString pa >>= \case - "encode" -> return (B16.encode b) - "decode" -> case B16.decode b of - (x, "") -> return x - _ -> throwPosError ("base64(): could not decode" <+> pretty pb) - a -> throwPosError ("base64(): the first argument must be either 'encode' or 'decode', not" <+> ttext a) - fmap PString (safeDecodeUtf8 r) -base64 _ = throwPosError "base64(): Expects 2 arguments" - -bool2num :: PValue -> InterpreterMonad PValue -bool2num (PString "") = return (PBoolean False) -bool2num (PString "1") = return (PBoolean True) -bool2num (PString "t") = return (PBoolean True) -bool2num (PString "y") = return (PBoolean True) -bool2num (PString "true") = return (PBoolean True) -bool2num (PString "yes") = return (PBoolean True) -bool2num (PString "0") = return (PBoolean False) -bool2num (PString "f") = return (PBoolean False) -bool2num (PString "n") = return (PBoolean False) -bool2num (PString "false") = return (PBoolean False) -bool2num (PString "no") = return (PBoolean False) -bool2num (PString "undef") = return (PBoolean False) -bool2num (PString "undefined") = return (PBoolean False) -bool2num x@(PBoolean _) = return x -bool2num x = throwPosError ("bool2num(): Can't convert" <+> pretty x <+> "to boolean") - -puppetConcat :: [PValue] -> InterpreterMonad PValue -puppetConcat = return . PArray . V.concat . map toArr - where - toArr (PArray x) = x - toArr x = V.singleton x - -puppetCount :: [PValue] -> InterpreterMonad PValue -puppetCount [PArray x] = return (_Integer # V.foldl' cnt 0 x) - where - cnt cur (PString "") = cur - cnt cur PUndef = cur - cnt cur _ = cur + 1 -puppetCount [PArray x, y] = return (_Integer # V.foldl' cnt 0 x) - where - cnt cur z | y == z = cur + 1 - | otherwise = cur -puppetCount _ = throwPosError "count(): expects 1 or 2 arguments" - -delete :: [PValue] -> InterpreterMonad PValue -delete [PString x, y] = fmap (PString . Text.concat . (`Text.splitOn` x)) (resolvePValueString y) -delete [PArray r, z] = return $ PArray $ V.filter (/= z) r -delete [PHash h, z] = do - tz <- resolvePValueString z - return $ PHash (h & at tz .~ Nothing) -delete [a,_] = throwPosError ("delete(): First argument must be an Array, String, or Hash. Given:" <+> pretty a) -delete _ = throwPosError "delete(): expects 2 arguments" - -deleteAt :: [PValue] -> InterpreterMonad PValue -deleteAt [PArray r, z] = case z ^? _Integer of - Just gn -> - let n = fromInteger gn - lr = V.length r - s1 = V.slice 0 n r - s2 = V.slice (n+1) (lr - n - 1) r - in if V.length r <= n - then throwPosError ("delete_at(): Out of bounds access detected, tried to remove index" <+> pretty z <+> "wheras the array only has" <+> string (show lr) <+> "elements") - else return (PArray (s1 <> s2)) - _ -> throwPosError ("delete_at(): The second argument must be an integer, not" <+> pretty z) -deleteAt [x,_] = throwPosError ("delete_at(): expects its first argument to be an array, not" <+> pretty x) -deleteAt _ = throwPosError "delete_at(): expects 2 arguments" - -deleteUndefValues :: PValue -> InterpreterMonad PValue -deleteUndefValues (PArray r) = return $ PArray $ V.filter (/= PUndef) r -deleteUndefValues (PHash h) = return $ PHash $ HM.filter (/= PUndef) h -deleteUndefValues x = throwPosError ("delete_undef_values(): Expects an Array or a Hash, not" <+> pretty x) - -_empty :: PValue -> InterpreterMonad PValue -_empty = return . PBoolean . flip elem [PUndef, PString "", PString "undef", PArray V.empty, PHash HM.empty] - -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 - -_grep :: [PValue] -> InterpreterMonad PValue -_grep [PArray vls, rawre] = do - regexp <- resolvePValueString rawre >>= compileRE - rvls <- for vls $ \v -> do - r <- resolvePValueString v - ismatched <- matchRE regexp r - return (r, ismatched) - return $ PArray $ V.map (PString . fst) (V.filter snd rvls) -_grep [x,_] = throwPosError ("grep(): The first argument must be an Array, not" <+> pretty x) -_grep _ = throwPosError "grep(): Expected two arguments." - -hash :: [PValue] -> InterpreterMonad PValue -hash [PArray elems] = do - let xs = mapMaybe assocPairs $ List.chunksOf 2 $ V.toList elems - assocPairs [a,b] = Just (a,b) - assocPairs _ = Nothing - PHash . HM.fromList <$> mapM (\(k,v) -> (,v) <$> resolvePValueString k) xs -hash _ = throwPosError "hash(): Expected and array." - -isArray :: PValue -> InterpreterMonad PValue -isArray = return . PBoolean . has _PArray - -isDomainName :: PValue -> InterpreterMonad PValue -isDomainName s = do - rs <- resolvePValueString s - let ndrs = if Text.last rs == '.' - then Text.init rs - else rs - prts = Text.splitOn "." ndrs - checkPart x = not (Text.null x) - && (Text.length x <= 63) - && (Text.head x /= '-') - && (Text.last x /= '-') - && Text.all (\y -> Char.isAlphaNum y || y == '-') x - return $ PBoolean $ not (Text.null rs) && Text.length rs <= 255 && all checkPart prts - -isInteger :: PValue -> InterpreterMonad PValue -isInteger = return . PBoolean . has _Integer - -isHash :: PValue -> InterpreterMonad PValue -isHash = return . PBoolean . has _PHash - -isString :: PValue -> InterpreterMonad PValue -isString pv = return $ PBoolean $ case (pv ^? _PString, pv ^? _Number) of - (_, Just _) -> False - (Just _, _) -> True - _ -> False - -isBool :: PValue -> InterpreterMonad PValue -isBool = return . PBoolean . has _PBoolean - -puppetJoin :: [PValue] -> InterpreterMonad PValue -puppetJoin [PArray rr, PString interc] = do - rrt <- mapM resolvePValueString (V.toList rr) - return (PString (Text.intercalate interc rrt)) -puppetJoin [_,_] = throwPosError "join(): expected an array of strings, and a string" -puppetJoin _ = throwPosError "join(): expected two arguments" - -joinKeysToValues :: [PValue] -> InterpreterMonad PValue -joinKeysToValues [PHash h, separator] = do - ssep <- resolvePValueString separator - fmap (PArray . V.fromList) $ forM (itoList h) $ \(k,v) -> do - sv <- case v of - PUndef -> return "" - _ -> resolvePValueString v - return (PString (k <> ssep <> sv)) -joinKeysToValues _ = throwPosError "join_keys_to_values(): expects 2 arguments, an hash and a string" - -keys :: PValue -> InterpreterMonad PValue -keys (PHash h) = return (PArray $ V.fromList $ map PString $ HM.keys h) -keys x = throwPosError ("keys(): Expects a Hash, not" <+> pretty x) - -member :: [PValue] -> InterpreterMonad PValue -member [PArray v, x] = return $ PBoolean (x `V.elem` v) -member _ = throwPosError "member() expects 2 arguments" - -hasKey :: [PValue] -> InterpreterMonad PValue -hasKey [PHash h, k] = do - k' <- resolvePValueString k - return (PBoolean (has (ix k') h)) -hasKey [a, _] = throwPosError ("has_key(): expected a Hash, not" <+> pretty a) -hasKey _ = throwPosError "has_key(): expected two arguments." - -merge :: [PValue] -> InterpreterMonad PValue -merge xs | length xs < 2 = throwPosError "merge(): Expects at least two hashes" - | otherwise = let hashcontents = mapM (preview _PHash) xs - in case hashcontents of - Nothing -> throwPosError "merge(): Expects hashes" - Just hashes -> return $ PHash (getDual $ foldMap Dual hashes) - -pick :: [PValue] -> InterpreterMonad PValue -pick [] = throwPosError "pick(): must receive at least one non empty value" -pick xs = case filter (`notElem` [PUndef, PString "", PString "undef"]) xs of - [] -> throwPosError "pick(): no value suitable to be picked" - (x:_) -> return x - -pickDefault :: [PValue] -> InterpreterMonad PValue -pickDefault [] = throwPosError "pick_default(): must receive at least one non empty value" -pickDefault xs = case filter (`notElem` [PUndef, PString "", PString "undef"]) xs of - [] -> return (List.last xs) - (x:_) -> return x - -size :: PValue -> InterpreterMonad PValue -size (PHash h) = return (_Integer # fromIntegral (HM.size h)) -size (PArray v) = return (_Integer # fromIntegral (V.length v)) -size (PString s) = return (_Integer # fromIntegral (Text.length s)) -size x = throwPosError ("size(): Expects a hash, and array or a string, not" <+> pretty x) - -sort :: PValue -> InterpreterMonad PValue -sort (PArray s) = - let lst = V.toList s - msort :: Ord a => Prism' PValue a -> Maybe PValue - msort prsm = PArray . V.fromList . map (review prsm) . List.sort <$> mapM (preview prsm) lst - in case (msort _PString <|> msort _PNumber) of - Just x -> return x - _ -> throwPosError "sort(): only homogeneous arrays of numbers or strings are allowed" -sort x = throwPosError ("sort(): Expect to sort an array, not" <+> pretty x) - -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 | Text.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" -validateArray x = mapM_ vb x >> return PUndef - where - vb (PArray _) = return () - vb y = throwPosError (pretty y <+> "is not an array.") - -validateBool :: [PValue] -> InterpreterMonad PValue -validateBool [] = throwPosError "validate_bool(): wrong number of arguments, must be > 0" -validateBool x = mapM_ vb x >> return PUndef - where - vb (PBoolean _) = return () - vb y = throwPosError (pretty y <+> "is not a boolean.") - -validateHash :: [PValue] -> InterpreterMonad PValue -validateHash [] = throwPosError "validate_hash(): wrong number of arguments, must be > 0" -validateHash x = mapM_ vb x >> return PUndef - 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"] -validateRe [str, PString reg, msg] = validateRe [str, PArray (V.singleton (PString reg)), msg] -validateRe [str, PArray v, msg] = do - rstr <- resolvePValueString str - rest <- mapM (resolvePValueString >=> compileRE >=> flip matchRE rstr) (V.toList v) - if or rest - then return PUndef - else throwPosError (pretty msg PP.<$> "Source string:" <+> pretty str <> comma <+> "regexps:" <+> pretty (V.toList v)) -validateRe [_, r, _] = throwPosError ("validate_re(): expected a regexp or an array of regexps, but not" <+> pretty r) -validateRe _ = throwPosError "validate_re(): wrong number of arguments (#{args.length}; must be 2 or 3)" - -validateString :: [PValue] -> InterpreterMonad PValue -validateString [] = throwPosError "validate_string(): wrong number of arguments, must be > 0" -validateString x = mapM_ resolvePValueString x >> return PUndef - -validateInteger :: [PValue] -> InterpreterMonad PValue -validateInteger [] = throwPosError "validate_integer(): wrong number of arguments, must be > 0" -validateInteger x = PUndef <$ mapM_ vb x - where - msg d = pretty d <+> "is not an integer." - check n = unless (Scientific.isInteger n) $ throwPosError (msg (show n)) - vb (PNumber n) = check n - vb (PString s) | Just n <- text2Scientific s = check n - vb a = throwPosError (msg a) - -pvalues :: PValue -> InterpreterMonad PValue -pvalues (PHash h) = return $ PArray (toVectorOf traverse h) -pvalues x = throwPosError ("values(): expected a hash, not" <+> pretty x) diff --git a/src/PuppetDB.hs b/src/PuppetDB.hs new file mode 100644 --- /dev/null +++ b/src/PuppetDB.hs @@ -0,0 +1,88 @@ +-- | Common data types for PuppetDB. +module PuppetDB + ( dummyPuppetDB + , getDefaultDB + , pdbConnect + , loadTestDB + , generateWireCatalog + , puppetDBFacts + , module PuppetDB.Core + ) where + +import XPrelude + +import qualified Data.HashMap.Strict as Map +import Control.Arrow ((***)) +import qualified Data.Text as Text +import Data.Vector.Lens +import Network.HTTP.Client +import System.Environment + +import Facter +import Puppet.Language +import PuppetDB.Core +import PuppetDB.Remote +import PuppetDB.TestDB + + + +-- | Given a 'PDBType', will try return a sane default implementation. +getDefaultDB :: PDBType -> IO (Either PrettyError (PuppetDBAPI IO)) +getDefaultDB PDBDummy = return (Right dummyPuppetDB) +getDefaultDB PDBRemote = do + let url = "http://localhost:8080" + mgr <- newManager defaultManagerSettings + pdbConnect mgr url +getDefaultDB PDBTest = + lookupEnv "HOME" >>= \case + Just h -> loadTestDB (h <> "/.testdb") + Nothing -> fmap Right initTestDB + + +-- | A dummy implementation of 'PuppetDBAPI', that will return empty responses. +dummyPuppetDB :: Monad m => PuppetDBAPI m +dummyPuppetDB = + PuppetDBAPI + (return "dummy") + (const (return ())) + (const (return ())) + (const (return ())) + (const (throwError "not implemented")) + (const (return [])) + (const (return [])) + (throwError "not implemented") + (\_ _ -> return []) + +-- | Turns a 'FinalCatalog' and 'EdgeMap' into a document that can be +-- serialized and fed to @puppet apply@. +generateWireCatalog :: NodeName -> FinalCatalog -> EdgeMap -> WireCatalog +generateWireCatalog node cat edgemap = WireCatalog node "version" edges resources "uiid" + where + edges = toVectorOf (folded . to (\li -> PuppetEdge (li ^. linksrc) (li ^. linkdst) (li ^. linkType))) (concatOf folded edgemap) + resources = toVectorOf folded cat + +puppetDBFacts :: NodeName -> PuppetDBAPI IO -> IO (HashMap Text PValue) +puppetDBFacts node pdbapi = + runExceptT (getFacts pdbapi (QEqual FCertname node)) >>= \case + Right facts@(_:_) -> return (Map.fromList (map (\f -> (f ^. factInfoName, f ^. factInfoVal)) facts)) + _ -> do + rawFacts <- fmap concat (sequence [factNET, factRAM, factOS, fversion, factMountPoints, factOS, factUser, factUName, fenv, factProcessor]) + let ofacts = genFacts $ map (Text.pack *** Text.pack) rawFacts + (hostname, ddomainname) = Text.break (== '.') node + domainname = if Text.null ddomainname + then "" + else Text.tail ddomainname + nfacts = genFacts [ ("fqdn", node) + , ("hostname", hostname) + , ("domain", domainname) + , ("rootrsa", "xxx") + , ("operatingsystem", "Ubuntu") + , ("puppetversion", "language-puppet") + , ("virtual", "xenu") + , ("clientcert", node) + , ("is_virtual", "true") + , ("concat_basedir", "/var/lib/puppet/concat") + ] + allfacts = nfacts `Map.union` ofacts + genFacts = Map.fromList + return (allfacts & traverse %~ PString) diff --git a/src/PuppetDB/Common.hs b/src/PuppetDB/Common.hs deleted file mode 100644 --- a/src/PuppetDB/Common.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE LambdaCase #-} --- | Common data types for PuppetDB. -module PuppetDB.Common where - -import Puppet.Prelude hiding (Read) - -import Data.List (stripPrefix) -import Data.Maybe -import Data.Vector.Lens -import GHC.Read (Read (..)) -import Network.HTTP.Client -import Servant.Common.BaseUrl -import System.Environment - -import Puppet.Interpreter.Types -import PuppetDB.Dummy -import PuppetDB.Remote -import PuppetDB.TestDB - --- | 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)] - | isJust rems = [(PDBRemote, fromJust rems)] - | isJust duml = [(PDBDummy, fromJust duml)] - | isJust dums = [(PDBDummy, fromJust dums)] - | isJust tstl = [(PDBTest, fromJust tstl)] - | isJust tsts = [(PDBTest, fromJust tsts)] - | otherwise = [] - where - reml = stripPrefix "PDBRemote" r - rems = stripPrefix "remote" r - duml = stripPrefix "PDBDummy" r - dums = stripPrefix "dummy" r - tstl = stripPrefix "PDBTest" r - tsts = stripPrefix "test" r - --- | Given a 'PDBType', will try return a sane default implementation. -getDefaultDB :: PDBType -> IO (Either PrettyError (PuppetDBAPI IO)) -getDefaultDB PDBDummy = return (Right dummyPuppetDB) -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 - --- | Turns a 'FinalCatalog' and 'EdgeMap' into a document that can be - -- serialized and fed to @puppet apply@. -generateWireCatalog :: NodeName -> FinalCatalog -> EdgeMap -> WireCatalog -generateWireCatalog node cat edgemap = WireCatalog node "version" edges resources "uiid" - where - edges = toVectorOf (folded . to (\li -> PuppetEdge (li ^. linksrc) (li ^. linkdst) (li ^. linkType))) (concatOf folded edgemap) - resources = toVectorOf folded cat diff --git a/src/PuppetDB/Core.hs b/src/PuppetDB/Core.hs new file mode 100644 --- /dev/null +++ b/src/PuppetDB/Core.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE TemplateHaskell #-} +module PuppetDB.Core + +where + +import XPrelude hiding (Read) + +import Control.Lens +import Data.Aeson +import qualified Data.List as List +import Data.Maybe (fromJust) +import qualified Data.Maybe.Strict as S +import Data.Time.Clock +import GHC.Read (Read (..)) +import Web.HttpApiData (ToHttpApiData (..)) + +import Facter +import Puppet.Language + +-- | 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)] + | isJust rems = [(PDBRemote, fromJust rems)] + | isJust duml = [(PDBDummy, fromJust duml)] + | isJust dums = [(PDBDummy, fromJust dums)] + | isJust tstl = [(PDBTest, fromJust tstl)] + | isJust tsts = [(PDBTest, fromJust tsts)] + | otherwise = [] + where + reml = List.stripPrefix "PDBRemote" r + rems = List.stripPrefix "remote" r + duml = List.stripPrefix "PDBDummy" r + dums = List.stripPrefix "dummy" r + tstl = List.stripPrefix "PDBTest" r + tsts = List.stripPrefix "test" r + +data NodeInfo = NodeInfo + { _nodeInfoName :: !NodeName + , _nodeInfoDeactivated :: !Bool + , _nodeInfoCatalogT :: !(S.Maybe UTCTime) + , _nodeInfoFactsT :: !(S.Maybe UTCTime) + , _nodeInfoReportT :: !(S.Maybe UTCTime) + } + +makeClassy ''NodeInfo + +instance ToJSON NodeInfo where + toJSON p = object [ ("name" , toJSON (p ^. nodeInfoName)) + , ("deactivated" , toJSON (p ^. nodeInfoDeactivated)) + , ("catalog_timestamp", toJSON (p ^. nodeInfoCatalogT)) + , ("facts_timestamp" , toJSON (p ^. nodeInfoFactsT)) + , ("report_timestamp" , toJSON (p ^. nodeInfoReportT)) + ] + +instance FromJSON NodeInfo where + parseJSON (Object v) = NodeInfo <$> v .: "name" + <*> v .:? "deactivated" .!= False + <*> v .: "catalog_timestamp" + <*> v .: "facts_timestamp" + <*> v .: "report_timestamp" + parseJSON _ = fail "invalide node info" + +-- | Pretty straightforward way to define the various PuppetDB queries +data Query a + = QEqual a Text + | QG a Integer + | QL a Integer + | QGE a Integer + | QLE a Integer + | QMatch Text Text + | QAnd [Query a] + | QOr [Query a] + | QNot (Query a) + | QEmpty + +instance ToJSON a => ToJSON (Query a) where + toJSON (QOr qs) = toJSON ("or" : map toJSON qs) + toJSON (QAnd qs) = toJSON ("and" : map toJSON qs) + toJSON (QNot q) = toJSON [ "not" , toJSON q ] + toJSON (QEqual flds val) = toJSON [ "=", toJSON flds, toJSON val ] + toJSON (QMatch flds val) = toJSON [ "~", toJSON flds, toJSON val ] + toJSON (QL flds val) = toJSON [ "<", toJSON flds, toJSON val ] + 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 + +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 + parseJSON (Array elems) = case toList elems of + ("or":xs) -> QOr <$> mapM parseJSON xs + ("and":xs) -> QAnd <$> mapM parseJSON xs + ["not",x] -> QNot <$> parseJSON x + [ "=", flds, val ] -> QEqual <$> parseJSON flds <*> parseJSON val + [ "~", flds, val ] -> QEqual <$> parseJSON flds <*> parseJSON val + [ ">", flds, val ] -> QG <$> parseJSON flds <*> parseJSON val + [ "<", flds, val ] -> QL <$> parseJSON flds <*> parseJSON val + [">=", flds, val ] -> QGE <$> parseJSON flds <*> parseJSON val + ["<=", flds, val ] -> QLE <$> parseJSON flds <*> parseJSON val + x -> fail ("unknown query" ++ show x) + parseJSON _ = fail "Expected an array" + +-- | Fields for the fact endpoint +data FactField + = FName + | FValue + | FCertname + +instance ToJSON FactField where + toJSON FName = "name" + toJSON FValue = "value" + toJSON FCertname = "certname" + +instance FromJSON FactField where + parseJSON "name" = pure FName + parseJSON "value" = pure FValue + parseJSON "certname" = pure FCertname + parseJSON _ = fail "Can't parse fact field" + +-- | Fields for the node endpoint +data NodeField = NName | NFact Text + +instance ToJSON NodeField where + toJSON NName = "name" + toJSON (NFact t) = toJSON [ "fact", t ] + +instance FromJSON NodeField where + parseJSON (Array xs) = case toList xs of + ["fact", x] -> NFact <$> parseJSON x + _ -> fail "Invalid field syntax" + parseJSON (String "name") = pure NName + parseJSON _ = fail "invalid field" + +-- | Fields for the resource endpoint +data ResourceField + = RTag + | RCertname + | RParameter Text + | RType + | RTitle + | RExported + | RFile + | RLine + +instance ToJSON ResourceField where + toJSON RTag = "tag" + toJSON RCertname = "certname" + toJSON (RParameter t) = toJSON ["parameter", t] + toJSON RType = "type" + toJSON RTitle = "title" + toJSON RExported = "exported" + toJSON RFile = "file" + toJSON RLine = "line" + +instance FromJSON ResourceField where + parseJSON (Array xs) = + case toList xs of + ["parameter", x] -> RParameter <$> parseJSON x + _ -> fail "Invalid field syntax" + parseJSON (String "tag" ) = pure RTag + parseJSON (String "certname") = pure RCertname + parseJSON (String "type" ) = pure RType + parseJSON (String "title" ) = pure RTitle + parseJSON (String "exported") = pure RExported + parseJSON (String "file" ) = pure RFile + parseJSON (String "line" ) = pure RLine + parseJSON _ = fail "invalid field" + +data PuppetDBAPI m = PuppetDBAPI + { pdbInformation :: m Doc + , 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] + } diff --git a/src/PuppetDB/Dummy.hs b/src/PuppetDB/Dummy.hs deleted file mode 100644 --- a/src/PuppetDB/Dummy.hs +++ /dev/null @@ -1,19 +0,0 @@ --- | A dummy implementation of 'PuppetDBAPI', that will return empty --- responses. -module PuppetDB.Dummy where - -import Puppet.Prelude - -import Puppet.Interpreter.Types - -dummyPuppetDB :: Monad m => PuppetDBAPI m -dummyPuppetDB = PuppetDBAPI - (return "dummy") - (const (return ())) - (const (return ())) - (const (return ())) - (const (throwError "not implemented")) - (const (return [] )) - (const (return [] )) - (throwError "not implemented") - (\_ _ -> return [] ) diff --git a/src/PuppetDB/Remote.hs b/src/PuppetDB/Remote.hs --- a/src/PuppetDB/Remote.hs +++ b/src/PuppetDB/Remote.hs @@ -5,15 +5,17 @@ {-# LANGUAGE TypeOperators #-} module PuppetDB.Remote (pdbConnect) where -import Puppet.Prelude +import XPrelude -import Network.HTTP.Client (Manager) +import Network.HTTP.Client (Manager) import Servant.API import Servant.Client -import Puppet.Interpreter.Types -import Puppet.PP +import Facter +import Puppet.Language +import PuppetDB.Core + type PDBAPIv3 = "nodes" :> QueryParam "query" (Query NodeField) :> Get '[JSON] [NodeInfo] :<|> "nodes" :> Capture "resourcename" Text :> "resources" :> QueryParam "query" (Query ResourceField) :> Get '[JSON] [Resource] :<|> "facts" :> QueryParam "query" (Query FactField) :> Get '[JSON] [FactInfo] @@ -25,26 +27,26 @@ api = Proxy -- | Given an URL (ie. @http://localhost:8080@), will return an incomplete 'PuppetDBAPI'. -pdbConnect :: Manager -> BaseUrl -> IO (Either PrettyError (PuppetDBAPI IO)) -pdbConnect mgr url = - return $ Right $ PuppetDBAPI - (return (string $ show url)) - (const (throwError "operation not supported")) - (const (throwError "operation not supported")) - (const (throwError "operation not supported")) - (q1 sgetFacts) - (q1 sgetResources) - (q1 sgetNodes) - (throwError "operation not supported") - (\ndename q -> prettyError $ sgetNodeResources ndename (Just q)) - where - sgetNodes :: Maybe (Query NodeField) -> ClientM [NodeInfo] - sgetNodeResources :: Text -> Maybe (Query ResourceField) -> ClientM [Resource] - sgetFacts :: Maybe (Query FactField) -> ClientM [FactInfo] - sgetResources :: Maybe (Query ResourceField) -> ClientM [Resource] - (sgetNodes :<|> sgetNodeResources :<|> sgetFacts :<|> sgetResources) = client api +pdbConnect :: Manager -> String -> IO (Either PrettyError (PuppetDBAPI IO)) +pdbConnect mgr url = do + url' <- parseBaseUrl url + let env = ClientEnv mgr url' + pure $ Right $ PuppetDBAPI + (return (ppline $ fromString url)) + (const (throwError "operation not supported")) + (const (throwError "operation not supported")) + (const (throwError "operation not supported")) + (\q -> prettyError $ runClientM (sgetFacts (Just q)) env) + (\q -> prettyError $ runClientM (sgetResources (Just q)) env) + (\q -> prettyError $ runClientM (sgetNodes (Just q)) env) + (throwError "operation not supported") + (\node q -> prettyError $ runClientM (sgetNodeResources node (Just q)) env) + where + sgetNodes :: Maybe (Query NodeField) -> ClientM [NodeInfo] + sgetNodeResources :: Text -> Maybe (Query ResourceField) -> ClientM [Resource] + sgetFacts :: Maybe (Query FactField) -> ClientM [FactInfo] + sgetResources :: Maybe (Query ResourceField) -> ClientM [Resource] + (sgetNodes :<|> sgetNodeResources :<|> sgetFacts :<|> sgetResources) = client api - prettyError :: ClientM b -> ExceptT PrettyError IO b - prettyError = ExceptT . fmap (_Left %~ PrettyError . string. show) . flip runClientM (ClientEnv mgr url) - q1 :: (Maybe a -> ClientM b) -> a -> ExceptT PrettyError IO b - q1 f a = prettyError (f (Just a)) + prettyError :: IO (Either ServantError b) -> ExceptT PrettyError IO b + prettyError = ExceptT . fmap (_Left %~ PrettyError . pplines . show) diff --git a/src/PuppetDB/TestDB.hs b/src/PuppetDB/TestDB.hs --- a/src/PuppetDB/TestDB.hs +++ b/src/PuppetDB/TestDB.hs @@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} @@ -10,55 +9,56 @@ , initTestDB ) where -import Puppet.Prelude +import XPrelude import Control.Concurrent.STM -import Data.Aeson.Lens (_Integer) -import qualified Data.CaseInsensitive as CaseInsensitive -import qualified Data.HashMap.Strict as HM -import qualified Data.HashSet as HS -import qualified Data.Maybe.Strict as S -import qualified Data.Text as Text -import qualified Data.Vector as V +import Data.Aeson +import Data.Aeson.Lens (_Integer) +import qualified Data.CaseInsensitive as CaseInsensitive +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as HS +import qualified Data.Maybe.Strict as S +import qualified Data.Text as Text +import qualified Data.Vector as V import Data.Yaml import Text.Megaparsec.Pos -import Puppet.Interpreter.Types -import Puppet.Parser.Types -import Puppet.PP +import Facter +import Puppet.Language +import PuppetDB.Core data DBContent = DBContent - { _dbcontentResources :: Container WireCatalog - , _dbcontentFacts :: Container Facts - , _dbcontentBackingFile :: Maybe FilePath - } + { _dbcontentResources :: Container WireCatalog + , _dbcontentFacts :: Container Facts + , _dbcontentBackingFile :: Maybe FilePath + } makeLensesWith abbreviatedFields ''DBContent type DB = TVar DBContent instance FromJSON DBContent where - parseJSON (Object v) = DBContent <$> v .: "resources" <*> v .: "facts" <*> pure Nothing - parseJSON _ = mempty + parseJSON (Object v) = DBContent <$> v .: "resources" <*> v .: "facts" <*> pure Nothing + parseJSON _ = mempty instance ToJSON DBContent where - toJSON (DBContent r f _) = object [("resources", toJSON r), ("facts", toJSON f)] + toJSON (DBContent r f _) = object [("resources", toJSON r), ("facts", toJSON f)] -- | Initializes the test DB using a file to back its content loadTestDB :: FilePath -> IO (Either PrettyError (PuppetDBAPI IO)) loadTestDB fp = - decodeFileEither fp >>= \case - Left (OtherParseException rr) -> return (Left (PrettyError (string (show rr)))) - Left (InvalidYaml Nothing) -> baseError "Unknown error" - Left (InvalidYaml (Just (YamlException s))) -> if take 21 s == "Yaml file not found: " - then newFile - else 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 _ -> newFile - Right x -> fmap Right (genDBAPI (x & backingFile ?~ fp )) - where - baseError r = return $ Left $ PrettyError $ "Could not parse" <+> string fp <> ":" <+> r - newFile = Right <$> genDBAPI (newDB & backingFile ?~ fp ) + decodeFileEither fp >>= \case + Left (OtherParseException rr) -> return (Left (PrettyError (pplines (show rr)))) + Left (InvalidYaml Nothing) -> baseError "Unknown error" + Left (InvalidYaml (Just (YamlException s))) -> if take 21 s == "Yaml file not found: " + then newFile + else baseError (ppstring s) + Left (InvalidYaml (Just (YamlParseException pb ctx (YamlMark _ l c)))) -> baseError $ red (ppstring pb <+> ppstring ctx) <+> "at line" <+> pretty l <> ", column" <+> pretty c + Left _ -> newFile + Right x -> fmap Right (genDBAPI (x & backingFile ?~ fp )) + where + baseError r = return $ Left $ PrettyError $ "Could not parse" <+> pptext fp <> ":" <+> r + newFile = Right <$> genDBAPI (newDB & backingFile ?~ fp ) -- | Starts a new PuppetDB, without any backing file. initTestDB :: IO (PuppetDBAPI IO) @@ -69,8 +69,8 @@ genDBAPI :: DBContent -> IO (PuppetDBAPI IO) genDBAPI db = do - d <- newTVarIO db - return (PuppetDBAPI (dbapiInfo d) + d <- newTVarIO db + return $! PuppetDBAPI (dbapiInfo d) (replCat d) (replFacts d) (deactivate d) @@ -79,18 +79,20 @@ (getNds d) (commit d) (getResNode d) - ) -data Extracted = EText Text - | ESet (HS.HashSet Text) - | ENil +data Extracted + = EText Text + | ESet (HS.HashSet Text) + | ENil + resolveQuery :: (a -> b -> Extracted) -> Query a -> b -> Bool resolveQuery _ QEmpty = const True -resolveQuery f (QEqual a t) = \v -> case f a v of - EText tt -> CaseInsensitive.mk tt == CaseInsensitive.mk t - ESet ss -> ss ^. contains t - _ -> False +resolveQuery f (QEqual a t) = + \v -> case f a v of + EText tt -> CaseInsensitive.mk tt == CaseInsensitive.mk t + ESet ss -> ss ^. contains t + _ -> False resolveQuery f (QNot q) = not . resolveQuery f q resolveQuery f (QG a i) = ncompare (>) f a i resolveQuery f (QL a i) = ncompare (<) f a i @@ -102,17 +104,18 @@ dbapiInfo :: DB -> IO Doc dbapiInfo db = do - c <- readTVarIO db - case c ^. backingFile of - Nothing -> return "TestDB" - Just v -> return ("TestDB" <+> string v) + c <- readTVarIO db + case c ^. backingFile of + Nothing -> return "TestDB" + Just v -> return ("TestDB" <+> ppstring v) ncompare :: (Integer -> Integer -> Bool) -> (a -> b -> Extracted) -> a -> Integer -> b -> Bool -ncompare operation f a i v = case f a v of - EText tt -> case PString tt ^? _Integer of - Just ii -> operation i ii - _ -> False - _ -> False +ncompare operation f a i v = + case f a v of + EText tt -> case PString tt ^? _Integer of + Just ii -> operation i ii + _ -> False + _ -> False replCat :: DB -> WireCatalog -> ExceptT PrettyError IO () replCat db wc = liftIO $ atomically $ modifyTVar db (resources . at (wc ^. wireCatalogNodename) ?~ wc) diff --git a/src/XPrelude.hs b/src/XPrelude.hs new file mode 100644 --- /dev/null +++ b/src/XPrelude.hs @@ -0,0 +1,7 @@ +module XPrelude + ( module XPrelude.Extra + , module XPrelude.PP + ) where + +import XPrelude.Extra +import XPrelude.PP hiding (width, ()) diff --git a/src/XPrelude/Extra.hs b/src/XPrelude/Extra.hs new file mode 100644 --- /dev/null +++ b/src/XPrelude/Extra.hs @@ -0,0 +1,186 @@ +{-# OPTIONS_HADDOCK ignore-exports #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +-- | General specific prelude for language-puppet +-- | Customization of the Protolude with extra specific utilities. +module XPrelude.Extra ( + module Exports + , String + , Container + , unwrapError + , isEmpty + , dropInitialColons + , textElem + , getDirectoryContents + , takeBaseName + , strictifyEither + , scientific2text + , text2Scientific + , getFiles + , ifromList, ikeys, isingleton, ifromListWith, iunionWith, iinsertWith + -- * Logger + , loggerName + , logDebug + , logInfo + , logInfoStr + , logWarning + , logError + , logDebugStr +) where + +import Protolude as Exports hiding (Down, Infix, Prefix, Selector, + State, StateT, Strict, break, check, + evalState, evalStateT, execState, + execStateT, from, hash, list, + moduleName, runState, runStateT, + sourceColumn, sourceLine, to, uncons, + unsnoc, withState, (%), (<&>), (<.>)) + +import Control.Exception.Lens as Exports (catching) +import Control.Lens as Exports hiding (Strict, argument, noneOf, op) +import Control.Monad as Exports (fail) +import Control.Monad.Trans.Except as Exports (except, throwE, catchE) +import Control.Monad.Trans.Maybe as Exports (runMaybeT) +import Data.Aeson as Exports (FromJSON, ToJSON, fromJSON, toJSON) +import Data.HashMap.Strict as Exports (HashMap) +import Data.HashSet as Exports (HashSet) +import Data.Scientific as Exports (Scientific) +import Data.Set as Exports (Set) +import Data.String as Exports (IsString (..)) +import Data.Tuple.Strict as Exports (Pair (..)) +import Data.Vector as Exports (Vector) +import Text.Regex.PCRE.ByteString.Utils as Exports (Regex) + +import Data.Attoparsec.Text (parseOnly, rational) +import qualified Data.ByteString as BS +import qualified Data.Either.Strict as S +import qualified Data.HashMap.Strict as Map +import qualified Data.HashSet as HS +import qualified Data.List as List +import qualified Data.Scientific as Scientific +import Data.String (String) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified System.Log.Logger as Log +import System.Posix.Directory.ByteString +import XPrelude.PP + +type Container = Map.HashMap Text + +text2Scientific :: Text -> Maybe Scientific +text2Scientific t = + case parseOnly rational t of + Left _ -> Nothing + Right s -> Just s + +scientific2text :: Scientific -> Text +scientific2text n = + Text.pack $ case Scientific.floatingOrInteger n of + Left r -> show (r :: Double) + Right i -> show (i :: Integer) + +strictifyEither :: Either a b -> S.Either a b +strictifyEither (Left x) = S.Left x +strictifyEither (Right x) = S.Right x + +textElem :: Char -> Text -> Bool +textElem c = Text.any (==c) + + +-- | See "System.FilePath.Posix" +takeBaseName :: Text -> Text +takeBaseName fullname = + let afterLastSlash = List.last $ Text.splitOn "/" fullname + splitExtension = List.init $ Text.splitOn "." afterLastSlash + in Text.intercalate "." splitExtension + +-- | Helper for hashmap, in case we want another kind of map. +ifromList :: (Monoid m, At m, Foldable f) => f (Index m, IxValue m) -> m +{-# INLINABLE ifromList #-} +ifromList = foldl' (\curm (k,v) -> curm & at k ?~ v) mempty + +ikeys :: (Eq k, Hashable k) => HashMap k v -> HS.HashSet k +{-# INLINABLE ikeys #-} +ikeys = HS.fromList . Map.keys + +isingleton :: (Monoid b, At b) => Index b -> IxValue b -> b +{-# INLINABLE isingleton #-} +isingleton k v = mempty & at k ?~ v + +ifromListWith :: (Monoid m, At m, Foldable f) => (IxValue m -> IxValue m -> IxValue m) -> f (Index m, IxValue m) -> m +{-# INLINABLE ifromListWith #-} +ifromListWith f = foldl' (\curmap (k,v) -> iinsertWith f k v curmap) mempty + +iinsertWith :: At m => (IxValue m -> IxValue m -> IxValue m) -> Index m -> IxValue m -> m -> m +{-# INLINABLE iinsertWith #-} +iinsertWith f k v m = + m & at k %~ mightreplace + where + mightreplace Nothing = Just v + mightreplace (Just x) = Just (f v x) + +iunionWith :: (Hashable k, Eq k) => (v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v +{-# INLINABLE iunionWith #-} +iunionWith = Map.unionWith + +getFiles :: Text -> Text -> Text -> IO [Text] +getFiles moduledir subdir extension = + fmap concat + $ getDirContents moduledir + >>= mapM ( checkForSubFiles extension . (\x -> moduledir <> "/" <> x <> "/" <> subdir)) + +checkForSubFiles :: Text -> Text -> IO [Text] +checkForSubFiles extension dir = + catch (fmap Right (getDirContents dir)) (\e -> return $ Left (e :: IOException)) >>= \case + Right o -> return ((map (\x -> dir <> "/" <> x) . filter (Text.isSuffixOf extension)) o ) + Left _ -> return [] + +getDirContents :: Text -> IO [Text] +getDirContents x = fmap (filter (not . Text.all (=='.'))) (getDirectoryContents x) + +getDirectoryContents :: Text -> IO [Text] +getDirectoryContents fpath = do + h <- openDirStream (Text.encodeUtf8 fpath) + let readHandle = do + fp <- readDirStream h + if BS.null fp + then return [] + else fmap (Text.decodeUtf8 fp :) readHandle + out <- readHandle + closeDirStream h + pure out + +isEmpty :: (Eq x, Monoid x) => x -> Bool +isEmpty = (== mempty) + +-- | Remove the '::' token from a text if any. +dropInitialColons :: Text -> Text +dropInitialColons t = fromMaybe t (Text.stripPrefix "::" t) + +loggerName :: String +loggerName = "language-puppet" + +logDebug :: Text -> IO () +logDebug = Log.debugM "language-puppet" . toS + +logInfo :: Text -> IO () +logInfo = Log.infoM "language-puppet" . toS + +logInfoStr :: String -> IO () +logInfoStr = Log.infoM "language-puppet" + +logWarning :: Text -> IO () +logWarning = Log.warningM "language-puppet" . toS + +logError :: Text -> IO () +logError = Log.errorM "language-puppet" . toS + +logDebugStr :: String -> IO () +logDebugStr = Log.debugM "language-puppet" + +-- | In case of a Left error, print and exit immediately. +unwrapError :: Doc -> Either PrettyError a -> IO a +unwrapError desc = either exit pure + where + exit = \err -> putDoc (display err) >> exitFailure + display err = red desc <> ":" <+> getError err diff --git a/src/XPrelude/PP.hs b/src/XPrelude/PP.hs new file mode 100644 --- /dev/null +++ b/src/XPrelude/PP.hs @@ -0,0 +1,63 @@ +{-# OPTIONS_HADDOCK ignore-exports #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module XPrelude.PP ( + module Exports + , PrettyError (..) + , prettyToShow + , ppline + , pplines + , pptext + , ppstring +) +where + +import Protolude + +import Data.Scientific +import Data.String +import qualified Data.Text as Text +import Text.PrettyPrint.ANSI.Leijen as Exports hiding (bool, cat, + char, double, empty, + float, group, int, + integer, rational, + string, text, (<$>)) + +import Text.PrettyPrint.ANSI.Leijen (string, text) + +newtype PrettyError = PrettyError + { getError :: Doc + } deriving Show + +instance Monoid PrettyError where + mempty = PrettyError mempty + mappend a b = PrettyError $ align (vsep [getError a, getError b]) + +instance IsString PrettyError where + fromString = PrettyError . string + +instance Pretty PrettyError where + pretty = getError + +instance Pretty Scientific where + pretty = text . show + + +-- | pretty print multiple lines of text. +pplines :: Text -> Doc +pplines = string . Text.unpack + +-- | pretty print a single line of text. +ppline :: Text -> Doc +ppline = text . Text.unpack + +-- | pretty print multiple lines of string. +ppstring :: String -> Doc +ppstring = string + +-- | pretty print one line of string +pptext :: String -> Doc +pptext = text + +prettyToShow :: Doc -> String +prettyToShow d = displayS (renderCompact d) "" diff --git a/tests/DT/Parser.hs b/tests/DT/Parser.hs --- a/tests/DT/Parser.hs +++ b/tests/DT/Parser.hs @@ -2,7 +2,6 @@ import Helpers -import Puppet.Parser import Test.Hspec.Megaparsec import Text.Megaparsec (parse) diff --git a/tests/Function/AssertPrivateSpec.hs b/tests/Function/AssertPrivateSpec.hs --- a/tests/Function/AssertPrivateSpec.hs +++ b/tests/Function/AssertPrivateSpec.hs @@ -3,9 +3,7 @@ import Helpers -import Puppet.Interpreter.Resolve -import Puppet.Interpreter.Utils (initialState) -import Puppet.Interpreter.IO (interpretMonad) +import Puppet.Interpreter (initialState) main :: IO () @@ -18,8 +16,8 @@ -> Either String PValue evalWithScope apFunc callerScope moduleScope = (_Left %~ show) . view _1 . ctxEval . (mapM resolveExpression >=> apFunc) where - ctxEval = runIdentity . interpretMonad (pureReader mempty) startingState - startingState = initialState dummyFacts [("confdir", "/etc/puppet")] & curScope .~ [ContClass moduleScope, ContClass callerScope] + ctxEval = pureEval' mempty state0 + state0 = initialState dummyFacts [("confdir", "/etc/puppet")] & curScope .~ [ContClass moduleScope, ContClass callerScope] spec :: Spec diff --git a/tests/Function/JoinKeysToValuesSpec.hs b/tests/Function/JoinKeysToValuesSpec.hs --- a/tests/Function/JoinKeysToValuesSpec.hs +++ b/tests/Function/JoinKeysToValuesSpec.hs @@ -6,8 +6,7 @@ import qualified Data.Foldable as F import Data.Monoid -import Puppet.Interpreter.Pure -import Puppet.Interpreter.Types +import Puppet.Interpreter import Helpers diff --git a/tests/Function/LookupSpec.hs b/tests/Function/LookupSpec.hs --- a/tests/Function/LookupSpec.hs +++ b/tests/Function/LookupSpec.hs @@ -15,7 +15,6 @@ checkError :: [Expression] -> String -> Expectation checkError = checkExprsError fname - boolDatatype = Terminal (UDataType UDTBoolean) stringDatatype = Terminal (UDataType (UDTString Nothing Nothing)) @@ -24,6 +23,7 @@ it "should fail with no argument" (checkError [] expectedErrMsg) it "should succeed with one argument" (checkSuccess ["hostname"] expectedValue) it "should succeed with 4 arguments" (checkSuccess ["hostname", stringDatatype, "unique", "default"] expectedValue) + it "should fail with an unknown merge strategy" (checkError ["hostname", stringDatatype, "joe", "default"] "Unknown merge strategy") it "should succeed with two arguments, the second on being a datatype" (checkSuccess ["hostname", stringDatatype] expectedValue) it "should fail when the type mismatched" (checkError ["hostname", boolDatatype] "Datatype mismatched") it "should fail with two arguments both strings" (checkError ["hostname", "default"] expectedErrMsg) diff --git a/tests/Helpers.hs b/tests/Helpers.hs --- a/tests/Helpers.hs +++ b/tests/Helpers.hs @@ -12,37 +12,30 @@ , withStdlibFunction ) where +import XPrelude as Exports --- import Control.Lens as Exports hiding (Strict, argument, --- failing, noneOf, op) -import Control.Monad as Exports(fail) +import Control.Monad as Exports (fail) +import qualified Data.HashMap.Strict as HM +import qualified Data.Maybe.Strict as S +import Data.Text as Text +import qualified Data.Vector as Vector +import Test.Hspec as Exports -import Puppet.Interpreter.Pure as Exports -import Puppet.Interpreter.Types as Exports -import Puppet.Parser.Types as Exports -import Puppet.PP as Exports hiding (bool, cat, empty, - text, group) -import Puppet.Prelude as Exports -import Test.Hspec as Exports +import Puppet.Interpreter as Exports +import Puppet.Parser as Exports +import Puppet.Runner as Exports hiding (getCatalog) -import qualified Data.HashMap.Strict as HM -import qualified Data.Maybe.Strict as S -import Data.Text as Text -import qualified Data.Vector as Vector -import Puppet.Interpreter (computeCatalog) -import Puppet.Interpreter.Resolve -import Puppet.Parser -import Puppet.Stdlib - compileCatalog :: MonadError String m => Text -> m (FinalCatalog, EdgeMap, FinalCatalog, [Resource], InterpreterState) compileCatalog input = do - statements <- either (throwError . show) return (runPParser "dummy" input) - let nodename = "node.fqdn" - sttmap = [( (TopNode, nodename), NodeDeclaration (NodeDecl (NodeName nodename) statements S.Nothing (initialPPos "dummy")) ) ] - (res, finalState, _) = pureEval dummyFacts sttmap (computeCatalog nodename) - (catalog,em,exported,defResources) <- either (throwError . show) return res - return (catalog,em,exported,defResources,finalState) + statements <- either (throwError . show) return (runPParser "dummy" input) + let nodename = "node.fqdn" + sttmap = + [((TopNode, nodename), NodeDeclaration (NodeDecl (NodeName nodename) statements S.Nothing (initialPPos "dummy"))) + ] + (res, finalState, _) = pureEval dummyFacts sttmap (computeCatalog nodename) + (catalog, em, exported, defResources) <- either (throwError . show) return res + return (catalog, em, exported, defResources, finalState) getCatalog :: MonadError String m => Text -> m FinalCatalog getCatalog = fmap (view _1) . compileCatalog @@ -57,13 +50,13 @@ getAttribute att res = case res ^? rattributes . ix att of Nothing -> fail ("Unknown attribute: " ++ Text.unpack att) - Just x -> return x + Just x -> return x withStdlibFunction :: Text -> ( ([PValue] -> InterpreterMonad PValue) -> Spec ) -> Spec withStdlibFunction fname testsuite = - case stdlibFunctions ^? ix fname of - Just f -> testsuite f - Nothing -> panic ("Don't know this function: " <> fname) + case stdlibFunctions ^? ix fname of + Just f -> testsuite f + Nothing -> panic ("Don't know this function: " <> fname) checkExprsSuccess :: Text -> [Expression] -> Text -> Expectation checkExprsSuccess fname args res = diff --git a/tests/InterpreterSpec.hs b/tests/InterpreterSpec.hs --- a/tests/InterpreterSpec.hs +++ b/tests/InterpreterSpec.hs @@ -2,25 +2,21 @@ import Helpers -import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM import qualified Data.Text as Text import qualified Data.Vector as V import Text.Megaparsec (eof, parse) -import Puppet.Interpreter -import Puppet.Parser - appendArrowNode :: Text appendArrowNode = "appendArrow" -arrowOperationInput :: ArrowOp -> Text +arrowOperationInput :: Text -> Text arrowOperationInput arr = Text.unlines [ "node " <> appendArrowNode <> " {" , "user { 'jenkins':" , " groups => 'ci'" , "}" , "User <| title == 'jenkins' |> {" - , "groups " <> (prettyToText . pretty) arr <> " 'docker'," + , "groups " <> arr <> " 'docker'," , "uid => 1000}" , "}" ] @@ -42,13 +38,13 @@ let computeWith arr = pureCompute appendArrowNode (arrowOperationInput arr) describe "Resource Collector" $ it "should append the new 'uid' attribute in the user resource" $ - getResAttr (computeWith AssignArrow) ^. at "uid" `shouldBe` Just (PNumber 1000) + getResAttr (computeWith "=>") ^. at "uid" `shouldBe` Just (PNumber 1000) describe "AppendArrow in AttributeDecl" $ it "should add 'docker' to the 'groups' attribute of the user resource" $ - getResAttr (computeWith AppendArrow) ^. at "groups" `shouldBe` Just (PArray $ V.fromList ["ci", "docker"]) + getResAttr (computeWith "+>") ^. at "groups" `shouldBe` Just (PArray $ V.fromList ["ci", "docker"]) describe "AssignArrow in AttributeDecl" $ it "should override the 'groups' attributes from the user resource" $ - getResAttr (computeWith AssignArrow) ^. at "groups" `shouldBe` Just (PArray $ V.fromList ["docker"]) + getResAttr (computeWith "=>") ^. at "groups" `shouldBe` Just (PArray $ V.fromList ["docker"]) classIncludeSpec :: Spec classIncludeSpec = do diff --git a/tests/erb.hs b/tests/erb.hs --- a/tests/erb.hs +++ b/tests/erb.hs @@ -1,8 +1,7 @@ module Main where import System.Environment -import Erb.Parser -import Erb.Ruby +import Erb import Control.Monad (when) checkParse :: FilePath -> IO (Maybe [RubyStatement]) diff --git a/tests/evals.hs b/tests/evals.hs --- a/tests/evals.hs +++ b/tests/evals.hs @@ -1,17 +1,18 @@ +{-# LANGUAGE NoImplicitPrelude #-} module Main where -import qualified Data.Text as T -import Puppet.PP -import Puppet.Parser -import Puppet.Interpreter.Pure -import Puppet.Interpreter.Types -import Puppet.Interpreter.Resolve +import XPrelude -import System.Environment -import Test.Hspec -import Text.Megaparsec (eof, parse) -import Data.Foldable (forM_) +import qualified Data.Text as T +import Data.Foldable (forM_) +import Test.Hspec +import Text.Megaparsec (eof, parse) + +import Puppet.Interpreter +import Puppet.Runner +import Puppet.Parser + pureTests :: [T.Text] pureTests = [ "4 + 2 == 6" , "[1,2][1] == 2" @@ -32,20 +33,20 @@ main :: IO () main = do - let check :: T.Text -> Either String () - check t = case parse (expression <* eof) "dummy" t of - Left rr -> Left (T.unpack t ++ " -> " ++ show rr) - Right e -> case dummyEval (resolveExpression e) of - Right (PBoolean True) -> Right () - Right x -> Left (T.unpack t ++ " -> " ++ show (pretty x)) - Left rr -> Left (T.unpack t ++ " -> " ++ show rr) - runcheck :: String -> IO () - runcheck t = case parse (expression <* eof) "dummy" (T.pack t) of - Left rr -> error ("Can't parse: " ++ show rr) - Right e -> case dummyEval (resolveExpression e) of - Right x -> print (pretty x) - Left rr -> error ("Can't eval: " ++ show rr) - args <- getArgs - if null args - then hspec $ describe "evaluation" $ forM_ pureTests $ \t -> it ("should evaluate " ++ show t) $ either error (const True) (check t) - else mapM_ runcheck args + let check :: T.Text -> Either Text () + check t = case parse (expression <* eof) "dummy" t of + Left rr -> Left (t <> " -> " <> show rr) + Right e -> case dummyEval (resolveExpression e) of + Right (PBoolean True) -> Right () + Right x -> Left (t <> " -> " <> show (pretty x)) + Left rr -> Left (t <> " -> " <> show rr) + runcheck :: String -> IO () + runcheck t = case parse (expression <* eof) "dummy" (T.pack t) of + Left rr -> panic ("Can't parse: " <> show rr) + Right e -> case dummyEval (resolveExpression e) of + Right x -> print (pretty x) + Left rr -> panic ("Can't eval: " <> show rr) + args <- getArgs + if null args + then hspec $ describe "evaluation" $ forM_ pureTests $ \t -> it ("should evaluate " ++ show t) $ either panic (const True) (check t) + else mapM_ runcheck args diff --git a/tests/expr.hs b/tests/expr.hs --- a/tests/expr.hs +++ b/tests/expr.hs @@ -4,8 +4,6 @@ import Data.Tuple.Strict import qualified Data.Vector as V import Puppet.Parser -import Puppet.Parser.PrettyPrinter () -import Puppet.Parser.Types import Text.Megaparsec import Test.Hspec diff --git a/tests/hiera.hs b/tests/hiera.hs --- a/tests/hiera.hs +++ b/tests/hiera.hs @@ -6,11 +6,12 @@ import qualified Data.Either.Strict as S import qualified Data.HashMap.Strict as HM import qualified Data.Vector as Vector -import Hiera.Server import NeatInterpolation import qualified System.IO.Temp as IO import qualified System.Log.Logger as Log import Test.HUnit + +import Hiera.Server main :: IO () main = IO.withSystemTempDirectory "hieratest" $ \tmpfp -> do diff --git a/tests/lexer.hs b/tests/lexer.hs --- a/tests/lexer.hs +++ b/tests/lexer.hs @@ -1,17 +1,17 @@ {-# LANGUAGE LambdaCase #-} module Main where -import Control.Monad -import System.FilePath.Glob -import Puppet.Parser -import System.Environment -import Puppet.Parser.PrettyPrinter -import Text.PrettyPrint.ANSI.Leijen -import Text.Megaparsec (parse, eof, parseErrorPretty) -import System.Posix.Terminal -import System.Posix.Types -import System.IO -import qualified Data.Text.IO as T +import Control.Monad +import qualified Data.Text.IO as T +import System.Environment +import System.FilePath.Glob +import System.IO +import System.Posix.Terminal +import System.Posix.Types +import Text.Megaparsec (eof, parse, parseErrorPretty) +import Text.PrettyPrint.ANSI.Leijen + +import Puppet.Parser allchecks :: IO () allchecks = do diff --git a/tests/puppetdb.hs b/tests/puppetdb.hs --- a/tests/puppetdb.hs +++ b/tests/puppetdb.hs @@ -2,16 +2,13 @@ import Control.Monad import System.IO.Temp -import Data.Monoid +import Data.Semigroup import qualified Data.Text as T import qualified Data.Text.IO as T import Control.Lens import Control.Monad.Trans.Except -import Puppet.Interpreter.Types -import PuppetDB.Common -import PuppetDB.TestDB -import Facter +import PuppetDB checkError :: Show x => String -> Either x a -> IO a checkError _ (Right x) = return x