language-puppet 0.10.6 → 0.11.0
raw patch · 18 files changed
+214/−259 lines, 18 filesdep +scientificdep −lens-aesondep ~aesondep ~attoparsecdep ~filecache
Dependencies added: scientific
Dependencies removed: lens-aeson
Dependency ranges changed: aeson, attoparsec, filecache, hruby, lens, parsers, text
Files
- Erb/Compute.hs +1/−1
- Hiera/Server.hs +1/−1
- Puppet/Daemon.hs +34/−75
- Puppet/Interpreter.hs +6/−3
- Puppet/Interpreter/Resolve.hs +5/−5
- Puppet/Interpreter/Types.hs +12/−6
- Puppet/Lens.hs +20/−55
- Puppet/NativeTypes/Package.hs +1/−1
- Puppet/NativeTypes/SshSecure.hs +1/−1
- Puppet/Parser.hs +100/−30
- Puppet/Plugins.hs +14/−1
- Puppet/Preferences.hs +1/−3
- Puppet/Stdlib.hs +2/−4
- Puppet/Testing.hs +1/−1
- PuppetDB/TestDB.hs +1/−1
- Text/Parser/Parsec.hs +0/−56
- language-puppet.cabal +11/−12
- progs/PuppetResources.hs +3/−3
Erb/Compute.hs view
@@ -64,7 +64,7 @@ showRubyError (WithOutput str _) = dullred (string str) initTemplateDaemon :: RubyInterpreter -> Preferences -> MStats -> IO (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text))-initTemplateDaemon intr (Preferences _ modpath templatepath _ _ _ _ _ _) mvstats = do+initTemplateDaemon intr (Preferences _ modpath templatepath _ _ _ _) mvstats = do controlchan <- newChan templatecache <- newFileCache -- forkOS is used because ruby doesn't like to change threads
Hiera/Server.hs view
@@ -22,7 +22,7 @@ import Control.Applicative import Control.Lens-import Control.Lens.Aeson+import Data.Aeson.Lens import Puppet.Lens import System.FilePath.Lens (directory) import Control.Exception
Puppet/Daemon.hs view
@@ -14,7 +14,6 @@ import Erb.Compute import Puppet.PP-import Text.Parsec import Data.FileCache import qualified System.Log.Logger as LOG import qualified Data.Text as T@@ -23,8 +22,6 @@ import qualified Data.HashMap.Strict as HM import Debug.Trace import Control.Lens-import Control.Monad-import Control.Concurrent import qualified Data.Either.Strict as S import Data.Tuple.Strict import Control.Exception@@ -52,16 +49,12 @@ functions that can be used in order to query the daemon for statistics, following the format in "Puppet.Stats". -It will internaly initialize several threads that communicate with channels. It-should scale well, althrough it hasn't really been tested yet. It should cache-the ASL of every .pp file, and could use a bit of memory. As a comparison, it+It will internaly initialize a thread for the LUA interpreter, and a thread for the Ruby one.+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 is recommended to ask for as many parser and interpreter threads as there are-CPUs.- It can optionnaly talk with PuppetDB, by setting an URL in the 'Prefs' data structure. The recommended way to set it to http://localhost:8080 and set a SSH tunnel :@@ -73,8 +66,6 @@ * It might be buggy when top level statements that are not class\/define\/nodes are altered, or when files loaded with require are changed. -* Exported resources are supported through the PuppetDB interface.- * The catalog is not computed exactly the same way Puppet does. Take a look at "Puppet.Interpreter.Catalog" for a list of differences. @@ -82,18 +73,18 @@ * There might be race conditions because file status are checked before they are opened. This means the program might end with an exception when the file-is not existent. This will need fixing.+is nonexistent. This will need fixing. -} initDaemon :: Preferences -> IO DaemonMethods initDaemon prefs = do logDebug "initDaemon" traceEventIO "initDaemon"- controlChan <- newChan templateStats <- newStats parserStats <- newStats catalogStats <- newStats- getStatements <- initParserDaemon prefs parserStats+ pfilecache <- newFileCache+ let getStatements = parseFunction prefs pfilecache parserStats #ifdef HRUBY intr <- startRubyInterpreter getTemplate <- initTemplateDaemon intr prefs templateStats@@ -105,57 +96,38 @@ Left _ -> return dummyHiera Right x -> return x Nothing -> return dummyHiera- let runMaster = do- (luastate, luafunctions) <- initLua (T.pack (prefs ^. modulesPath))- let luacontainer = HM.fromList [ (fname, puppetFunc luastate fname) | fname <- luafunctions ]- myprefs = prefs & prefExtFuncs %~ HM.union luacontainer- master myprefs controlChan getStatements getTemplate catalogStats hquery- replicateM_ (prefs ^. compilePoolSize) (forkIO runMaster)- return (DaemonMethods (gCatalog controlChan) parserStats catalogStats templateStats)--gCatalog :: Chan DaemonQuery -> T.Text -> Facts -> IO (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog))-gCatalog q ndename fcts = do- t <- newEmptyMVar- writeChan q (DaemonQuery ndename fcts t)- readMVar t--data DaemonQuery = DaemonQuery- { _qNodeName :: T.Text- , _qFacts :: Facts- , _qQ :: MVar DaemonResponse- }--type DaemonResponse = S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog)+ luacontainer <- initLuaMaster (T.pack (prefs ^. modulesPath))+ let myprefs = prefs & prefExtFuncs %~ HM.union luacontainer+ return (DaemonMethods (gCatalog myprefs getStatements getTemplate catalogStats hquery) parserStats catalogStats templateStats) -master :: Preferences- -> Chan DaemonQuery- -> ( TopLevelType -> T.Text -> IO (S.Either Doc Statement) )- -> (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text))- -> MStats- -> HieraQueryFunc- -> IO ()-master prefs controlQ getStatements getTemplate stats hquery = forever $ do- (DaemonQuery ndename facts q) <- readChan controlQ+gCatalog :: Preferences+ -> ( TopLevelType -> T.Text -> IO (S.Either Doc Statement) )+ -> (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text))+ -> MStats+ -> HieraQueryFunc+ -> T.Text+ -> Facts+ -> IO (S.Either Doc (FinalCatalog, EdgeMap, FinalCatalog))+gCatalog prefs getStatements getTemplate stats hquery ndename facts = do logDebug ("Received query for node " <> ndename) traceEventIO ("Received query for node " <> T.unpack ndename) (stmts :!: warnings) <- measure stats ndename $ getCatalog getStatements getTemplate (prefs ^. prefPDB) ndename facts (prefs ^. natTypes) (prefs ^. prefExtFuncs) hquery mapM_ (\(p :!: m) -> LOG.logM loggerName p (displayS (renderCompact m) "")) warnings traceEventIO ("getCatalog finished for " <> T.unpack ndename)- putMVar q stmts--initParserDaemon :: Preferences -> MStats -> IO ( TopLevelType -> T.Text -> IO (S.Either Doc Statement) )-initParserDaemon prefs mstats = do- let nbthreads = prefs ^. parsePoolSize- logDebug ("initParserDaemon - " <> tshow nbthreads <> " threads")- controlChan <- newChan- filecache <- newFileCache- replicateM_ nbthreads (forkIO (pmaster prefs controlChan filecache mstats))- return $ \tt tn -> do- c <- newEmptyMVar- writeChan controlChan (ParserQuery tt tn c)- readMVar c+ return stmts -data ParserMessage = ParserQuery !TopLevelType !T.Text !(MVar (S.Either Doc Statement))+parseFunction :: Preferences -> FileCache (V.Vector Statement) -> MStats -> TopLevelType -> T.Text -> IO (S.Either Doc Statement)+parseFunction prefs filecache stats topleveltype toplevelname =+ case compileFileList prefs topleveltype toplevelname of+ S.Left rr -> return (S.Left rr)+ S.Right fname -> do+ let sfname = T.unpack fname+ handleFailure :: SomeException -> IO (S.Either String (V.Vector Statement))+ handleFailure e = return (S.Left (show e))+ x <- measure stats fname (query filecache sfname (parseFile sfname `catch` handleFailure))+ case x of+ S.Right stmts -> filterStatements topleveltype toplevelname stmts+ S.Left rr -> return (S.Left (red (text rr))) -- TODO this is wrong, see -- http://docs.puppetlabs.com/puppet/3/reference/lang_namespaces.html#behavior@@ -171,22 +143,9 @@ parseFile :: FilePath -> IO (S.Either String (V.Vector Statement)) parseFile fname = do+ traceEventIO ("Start parsing " ++ fname) cnt <- T.readFile fname- runParserT puppetParser () fname cnt >>= \case- Right r -> return (S.Right r)- Left rr -> return (S.Left (show rr))+ runMyParser puppetParser fname cnt >>= \case+ Right r -> traceEventIO ("Stopped parsing " ++ fname) >> return (S.Right r)+ Left rr -> traceEventIO ("Stopped parsing " ++ fname ++ " (failure: " ++ show rr ++ ")") >> return (S.Left (show rr)) -pmaster :: Preferences -> Chan ParserMessage -> FileCache (V.Vector Statement) -> MStats -> IO ()-pmaster prefs controlqueue filecache stats = forever $ do- (ParserQuery topleveltype toplevelname responseQ) <- readChan controlqueue- case compileFileList prefs topleveltype toplevelname of- S.Left rr -> putMVar responseQ (S.Left rr)- S.Right fname -> do- let sfname = T.unpack fname- handleFailure :: SomeException -> IO (S.Either String (V.Vector Statement))- handleFailure e = return (S.Left (show e))- colorError (S.Right x) = S.Right x- colorError (S.Left rr) = S.Left (red (text rr))- fmap colorError ( measure stats fname (query filecache sfname (parseFile sfname `catch` handleFailure)) ) >>= \case- S.Left rr -> putMVar responseQ (S.Left rr)- S.Right stmts -> filterStatements topleveltype toplevelname stmts >>= putMVar responseQ
Puppet/Interpreter.hs view
@@ -28,6 +28,7 @@ import qualified Data.Tree as T import Data.Foldable (toList,foldl',Foldable,foldlM) import Data.Traversable (mapM,forM)+import Debug.Trace (traceEventIO) -- helpers vmapM :: (Monad m, Foldable t) => (a -> m b) -> t a -> m [b]@@ -235,7 +236,7 @@ -- check that all resources are defined, and build graph let checkResDef :: (RIdentifier, [LinkInformation]) -> InterpreterMonad (RIdentifier, RIdentifier, [RIdentifier]) checkResDef (ri, lifs) = do- let checkExists r msg = unless (defs ^. contains r) (throwPosError msg)+ let checkExists r msg = unless (defs & has (ix r)) (throwPosError msg) errmsg = "Unknown resource" <+> pretty ri <+> "used in the following relationships:" <+> vcat prels prels = [ pretty (li ^. linksrc) <+> "->" <+> pretty (li ^. linkdst) <+> showPPos (li ^. linkPos) | li <- lifs ] checkExists ri errmsg@@ -419,7 +420,7 @@ curcont <- getCurContainer scp <- getScopeName p <- use curPos- scopeDefined <- use (scopes . contains scp)+ scopeDefined <- has (ix scp) `fmap` 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)@@ -501,7 +502,7 @@ curcaller <- case secontext of SEParent l -> return (PString $ T.takeWhile (/=':') l) _ -> resolveVariable "module_name"- scopeAlreadyDefined <- use (scopes . contains scopename)+ scopeAlreadyDefined <- has (ix scopename) `fmap` use scopes let isImported = case cont of ContImported _ -> True _ -> False@@ -569,6 +570,8 @@ -> InterpreterMonad [Resource] loadClass rclassname loadedfrom params cincludetype = do let classname = dropInitialColons rclassname+ ndn <- view thisNodename+ liftIO (traceEventIO ('[' : T.unpack ndn ++ "] loadClass " ++ T.unpack classname)) p <- use curPos -- check if the class has already been loaded -- http://docs.puppetlabs.com/puppet/3/reference/lang_classes.html#using-resource-like-declarations
Puppet/Interpreter/Resolve.hs view
@@ -51,7 +51,7 @@ import Control.Monad.Error import Data.Tuple.Strict as S import Control.Lens-import Control.Lens.Aeson hiding (key)+import Data.Aeson.Lens hiding (key) import Data.Attoparsec.Number import Data.Attoparsec.Text import qualified Data.Either.Strict as S@@ -143,7 +143,7 @@ -- | A simple helper that checks if a given type is native or a define. isNativeType :: T.Text -> InterpreterMonad Bool-isNativeType t = view (nativeTypes . contains t)+isNativeType t = has (ix t) `fmap` view nativeTypes -- | A pure function for resolving variables. getVariable :: Container ScopeInformation -- ^ The whole scope data.@@ -365,16 +365,16 @@ undefEmptyString x = x resolveFunction' :: T.Text -> [PValue] -> InterpreterMonad PValue-resolveFunction' "defined" [PResourceReference rt rn] = fmap PBoolean (use (definedResources . contains (RIdentifier rt rn)))+resolveFunction' "defined" [PResourceReference rt rn] = fmap (PBoolean . has (ix (RIdentifier rt rn))) (use definedResources) resolveFunction' "defined" [ut] = do t <- resolvePValueString ut -- case 1, netsted thingie nestedStuff <- use nestedDeclarations- if (nestedStuff ^. contains (TopDefine, t)) || (nestedStuff ^. contains (TopClass, t))+ if (has (ix (TopDefine, t)) nestedStuff) || (has (ix (TopClass, t)) nestedStuff) then return (PBoolean True) else do -- case 2, loadeded class lc <- use loadedClasses- if lc ^. contains t+ if has (ix t) lc then return (PBoolean True) else fmap PBoolean (isNativeType t) resolveFunction' "defined" x = throwPosError ("defined(): expects a single resource reference, type or class name, and not" <+> pretty x)
Puppet/Interpreter/Types.hs view
@@ -19,7 +19,7 @@ import Control.Monad.Writer hiding ((<>)) import Control.Monad.Error import Control.Lens-import Control.Lens.Aeson+import Data.Aeson.Lens import Data.String (IsString(..)) import qualified Data.Either.Strict as S import qualified Data.Maybe.Strict as S@@ -36,6 +36,7 @@ import Data.Maybe (fromMaybe) import Data.Attoparsec.Number import Data.Attoparsec.Text (parseOnly,number)+import Data.Scientific #ifdef HRUBY import Foreign.Ruby@@ -656,12 +657,17 @@ instance AsNumber PValue where _Number = prism num2PValue toNumber where- num2PValue :: Number -> PValue- num2PValue (I x) = PString (T.pack (show x))- num2PValue (D x) = PString (T.pack (show x))- toNumber :: PValue -> Either PValue Number+ num2PValue :: Scientific -> PValue+ num2PValue s =+ let e = base10Exponent s+ c = coefficient s+ in PString $ T.pack $ if e >= 0+ then show (c * 10 ^ e)+ else show ( (fromInteger c / 10 ^ negate e) :: Double)+ toNumber :: PValue -> Either PValue Scientific toNumber p@(PString x) = case parseOnly number x of- Right y -> Right y+ Right (I n) -> Right (fromInteger n)+ Right (D n) -> Right (fromRational (toRational n)) _ -> Left p toNumber p = Left p
Puppet/Lens.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts, TemplateHaskell #-} module Puppet.Lens ( -- * Pure resolution prisms _PResolveExpression@@ -8,19 +8,29 @@ , _PBoolean , _PString , _PResourceReference+ , _PUndef , _PArray -- * Parsing prism , _PParse -- * Lenses and Prisms for 'Statement's- , _VariableAssignment- , _NodeDeclaration- , _DefineDeclaration+ , _ResourceDeclaration+ , _DefaultDeclaration+ , _ResourceOverride+ , _ConditionalStatement , _ClassDeclaration+ , _DefineDeclaration+ , _Node+ , _VariableAssignment+ , _MainFunctionCall+ , _SHFunctionCall+ , _ResourceCollection+ , _Dependency+ , _TopContainer , _Statements ) where import Control.Lens-import Control.Lens.Aeson+import Data.Aeson.Lens import Control.Applicative import Puppet.PP (displayNocolor)@@ -33,14 +43,15 @@ import qualified Data.Vector as V import qualified Data.HashMap.Strict as HM import qualified Data.Text as T-import qualified Data.Maybe.Strict as S import Data.Tuple.Strict hiding (uncurry)-import Text.Parsec.Prim (runParserT)-import Text.PrettyPrint.ANSI.Leijen (renderPretty,displayS,SimpleDoc(..)) import System.IO.Unsafe import Data.Bits import Text.Parser.Combinators (eof) +-- Prisms+makePrisms ''PValue+makePrisms ''Statement+ -- | Incomplete _PResolveExpression :: Prism' Expression PValue _PResolveExpression = prism reinject extract@@ -113,61 +124,15 @@ toU (PArray r) = UArray (fmap (PValue . toU) r) toU (PHash h) = UHash (V.fromList $ map (\(k,v) -> (PValue (UString k) :!: PValue (toU v))) $ HM.toList h) -_PHash :: Prism' PValue (Container PValue)-_PHash = prism PHash $ \c -> case c of; PHash x -> Right x; _ -> Left c-_PBoolean :: Prism' PValue Bool-_PBoolean = prism PBoolean $ \c -> case c of; PBoolean x -> Right x; _ -> Left c-_PString :: Prism' PValue T.Text-_PString = prism PString $ \c -> case c of; PString x -> Right x; _ -> Left c-_PResourceReference :: Prism' PValue (T.Text, T.Text)-_PResourceReference = prism (uncurry PResourceReference) $ \c -> case c of; PResourceReference t n -> Right (t,n); _ -> Left c-_PArray :: Prism' PValue (V.Vector PValue)-_PArray = prism PArray $ \c -> case c of; PArray x -> Right x; _ -> Left c- -- | Warning, this uses 'unsafePerformIO' to parse (parsing Regexps -- requires IO). _PParse :: Prism' T.Text (V.Vector Statement) _PParse = prism dspl prs where- prs i = case unsafePerformIO (runParserT (puppetParser <* eof) () "dummy" i) of+ prs i = case unsafePerformIO (runMyParser (puppetParser <* eof) "dummy" i) of Left _ -> Left i Right x -> Right x dspl = T.pack . displayNocolor . ppStatements--_VariableAssignment :: Prism' Statement (T.Text,Expression,PPosition)-_VariableAssignment = prism rebuild extract- where- extract (VariableAssignment t e p) = Right (t,e,p)- extract x = Left x- rebuild (t,e,p) = VariableAssignment t e p--_NodeDeclaration :: Prism' Statement (NodeDesc, V.Vector Statement, S.Maybe NodeDesc, PPosition)-_NodeDeclaration = prism rebuild extract- where- extract (Node nd s nd' p) = Right (nd, s, nd', p)- extract x = Left x- rebuild (nd, s, nd', p) = Node nd s nd' p--_DefineDeclaration :: Prism' Statement (T.Text, V.Vector (Pair T.Text (S.Maybe Expression)), V.Vector Statement, PPosition)-_DefineDeclaration = prism rebuild extract- where- extract (DefineDeclaration n args stmts p) = Right (n, args, stmts, p)- extract x = Left x- rebuild (n, args, stmts, p) = DefineDeclaration n args stmts p--_ClassDeclaration :: Prism' Statement (T.Text, V.Vector (Pair T.Text (S.Maybe Expression)), S.Maybe T.Text, V.Vector Statement, PPosition)-_ClassDeclaration = prism rebuild extract- where- extract (ClassDeclaration n args inh stmts p) = Right (n, args, inh, stmts, p)- extract x = Left x- rebuild (n, args, inh, stmts, p) = ClassDeclaration n args inh stmts p--_TopContainer :: Prism' Statement (V.Vector Statement, Statement)-_TopContainer = prism rebuild extract- where- extract (TopContainer spur s) = Right (spur, s)- extract x = Left x- rebuild (spur, s) = TopContainer spur s -- | Extracts the statements from 'ClassDeclaration', 'DefineDeclaration', -- 'Node' and the spurious statements of 'TopContainer'.
Puppet/NativeTypes/Package.hs view
@@ -91,7 +91,7 @@ then Right (s, r) else Left ("Feature" <+> text (show f) <+> "is required for the current configuration") checkParam :: T.Text -> PackagingFeatures -> (HS.HashSet PackagingFeatures, Resource) -> Either Doc (HS.HashSet PackagingFeatures, Resource)- checkParam pn f (s,r) = if r ^. rattributes . containsAt pn+ checkParam pn f (s,r) = if has (ix pn) (r ^. rattributes) then checkFeature s r f else Right (s,r) checkAdminFile :: (HS.HashSet PackagingFeatures, Resource) -> Either Doc (HS.HashSet PackagingFeatures, Resource)
Puppet/NativeTypes/SshSecure.hs view
@@ -25,7 +25,7 @@ ] userOrTarget :: PuppetTypeValidate-userOrTarget res = case (res ^. rattributes . containsAt "user", res ^. rattributes . containsAt "target") of+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
Puppet/Parser.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE LambdaCase #-}-module Puppet.Parser (puppetParser,expression) where+module Puppet.Parser (puppetParser,expression,runMyParser) where import qualified Data.Text as T import qualified Data.Vector as V@@ -12,7 +12,7 @@ import Control.Monad import Control.Monad.IO.Class import Control.Applicative-import Control.Lens+import Control.Lens hiding (noneOf) import Puppet.Parser.Types @@ -20,14 +20,79 @@ import Text.Parser.Token hiding (stringLiteral') import Text.Parser.Combinators import Text.Parser.Char+import Text.Parsec.Pos (SourcePos,SourceName) import Text.Parser.LookAhead-import Text.Parser.Parsec () import Text.Parser.Token.Highlight-import Text.Parsec.Prim (getPosition, ParsecT)+import Text.Parsec.Error (ParseError) import Text.Parsec.Text ()+import qualified Text.Parsec.Prim as PP+import qualified Text.Parsec.Char as PP+import Text.Parsec.Text () -type Parser = ParsecT T.Text () IO+import Unsafe.Coerce +newtype Parser a = Parser { unParser :: PP.ParsecT T.Text () IO a }++getPosition :: Parser SourcePos+getPosition = Parser PP.getPosition++runMyParser :: Parser a -> SourceName -> T.Text -> IO (Either ParseError a)+runMyParser (Parser p) = PP.runPT p ()++type OP = PP.ParsecT T.Text () IO++instance Functor Parser where+ fmap = unsafeCoerce (fmap :: (a -> b) -> OP a -> OP b)++instance Monad Parser where+ return = unsafeCoerce (return :: a -> OP a)+ fail = unsafeCoerce (fail :: String -> OP ())+ (>>=) = unsafeCoerce ((>>=) :: OP a -> (a -> OP b) -> OP b)++instance Parsing Parser where+ try = unsafeCoerce (PP.try :: OP a -> OP a)+ (<?>) = unsafeCoerce ((<?>) :: OP a -> String -> OP a)+ skipMany = unsafeCoerce (PP.skipMany :: OP a -> OP ())+ skipSome = unsafeCoerce (skipSome :: OP a -> OP ())+ unexpected = unsafeCoerce (PP.unexpected :: String -> OP ())+ eof = unsafeCoerce (eof :: OP ())+ notFollowedBy = Parser . notFollowedBy . unParser++instance LookAheadParsing Parser where+ lookAhead = unsafeCoerce (PP.lookAhead :: OP a -> OP a)++instance CharParsing Parser where+ satisfy = unsafeCoerce (PP.satisfy :: (Char -> Bool) -> OP Char)+ char = unsafeCoerce (PP.char :: Char -> OP Char)+ notChar = Parser . notChar+ anyChar = unsafeCoerce (PP.anyChar :: OP Char)+ string = unsafeCoerce (PP.string :: String -> OP String)++instance Applicative Parser where+ pure = unsafeCoerce (pure :: a -> OP a)+ (<*>) = unsafeCoerce ((<*>) :: OP (a -> b) -> OP a -> OP b)+ (*>) = unsafeCoerce ((*>) :: OP a -> OP b -> OP b)+ (<*) = unsafeCoerce ((<*) :: OP a -> OP b -> OP a)++instance Alternative Parser where+ empty = unsafeCoerce (empty :: OP a)+ (<|>) = unsafeCoerce ((<|>) :: OP a -> OP a -> OP a)+ some = unsafeCoerce (some :: OP a -> OP [a])+ many = unsafeCoerce (many :: OP a -> OP [a])++instance MonadIO Parser where+ liftIO = unsafeCoerce (liftIO :: IO a -> OP a)++instance TokenParsing Parser where+ someSpace = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment)+ where+ simpleSpace = skipSome (satisfy isSpace)+ oneLineComment = char '#' >> void (manyTill anyChar newline)+ multiLineComment = try (string "/*") >> inComment+ inComment = void (try (string "*/"))+ <|> (skipSome (noneOf "*/") >> inComment)+ <|> (oneOf "*/" >> inComment)+ stringLiteral' :: Parser T.Text stringLiteral' = char '\'' *> interior <* symbolic '\'' where@@ -192,14 +257,14 @@ -- this is a hack. Contrary to what the documentation says, -- a "bareword" can perfectly be a qualified name : -- include foo::bar- let argsc sep e = (fmap (PValue . UString) (qualif1 className) <|> e <?> "Function argument") `sep` comma+ let argsc sep e = (fmap (PValue . UString) (qualif1 className) <|> e <?> "Function argument A") `sep` comma terminalF = terminalG (fail "function hack")- expressionF = buildExpressionParser expressionTable (token terminalF) <?> "function expression"+ expressionF = unsafeCoerce (buildExpressionParser expressionTable (unsafeCoerce (token terminalF)) <?> "function expression") withparens = parens (argsc sepEndBy expression) withoutparens = argsc sepEndBy1 expressionF args <- withparens <|> if nonparens- then withoutparens <?> "Function arguments"- else fail "Function arguments"+ then withoutparens <?> "Function arguments B"+ else fail "Function arguments C" return (fname, V.fromList args) functionCall :: Parser UValue@@ -243,7 +308,7 @@ expression :: Parser Expression expression = condExpression- <|> buildExpressionParser expressionTable (token terminal)+ <|> unsafeCoerce (buildExpressionParser expressionTable (unsafeCoerce (token terminal))) <?> "expression" where condExpression = do@@ -263,34 +328,39 @@ expressionTable :: [[Operator T.Text () IO Expression]] expressionTable = [ -- [ Infix ( operator "?" >> return ConditionalValue ) AssocLeft ]- [ Prefix ( operator "-" >> return Negate ) ]- , [ Prefix ( operator "!" >> return Not ) ]- , [ Infix ( operator "." >> return FunctionApplication ) AssocLeft ]- , [ Infix ( reserved "in" >> return Contains ) AssocLeft ]- , [ Infix ( operator "/" >> return Division ) AssocLeft- , Infix ( operator "*" >> return Multiplication ) AssocLeft+ [ Prefix ( operator' "-" >> return Negate ) ]+ , [ Prefix ( operator' "!" >> return Not ) ]+ , [ Infix ( operator' "." >> return FunctionApplication ) AssocLeft ]+ , [ Infix ( reserved' "in" >> return Contains ) AssocLeft ]+ , [ Infix ( operator' "/" >> return Division ) AssocLeft+ , Infix ( operator' "*" >> return Multiplication ) AssocLeft ]- , [ Infix ( operator "+" >> return Addition ) AssocLeft- , Infix ( operator "-" >> return Substraction ) AssocLeft+ , [ Infix ( operator' "+" >> return Addition ) AssocLeft+ , Infix ( operator' "-" >> return Substraction ) AssocLeft ]- , [ Infix ( operator "<<" >> return LeftShift ) AssocLeft- , Infix ( operator ">>" >> return RightShift ) AssocLeft+ , [ Infix ( operator' "<<" >> return LeftShift ) AssocLeft+ , Infix ( operator' ">>" >> return RightShift ) AssocLeft ]- , [ Infix ( operator "==" >> return Equal ) AssocLeft- , Infix ( operator "!=" >> return Different ) AssocLeft+ , [ Infix ( operator' "==" >> return Equal ) AssocLeft+ , Infix ( operator' "!=" >> return Different ) AssocLeft ]- , [ Infix ( operator ">=" >> return MoreEqualThan ) AssocLeft- , Infix ( operator "<=" >> return LessEqualThan ) AssocLeft- , Infix ( operator ">" >> return MoreThan ) AssocLeft- , Infix ( operator "<" >> return LessThan ) AssocLeft+ , [ Infix ( operator' ">=" >> return MoreEqualThan ) AssocLeft+ , Infix ( operator' "<=" >> return LessEqualThan ) AssocLeft+ , Infix ( operator' ">" >> return MoreThan ) AssocLeft+ , Infix ( operator' "<" >> return LessThan ) AssocLeft ]- , [ Infix ( reserved "and" >> return And ) AssocLeft- , Infix ( reserved "or" >> return Or ) AssocLeft+ , [ Infix ( reserved' "and" >> return And ) AssocLeft+ , Infix ( reserved' "or" >> return Or ) AssocLeft ]- , [ Infix ( operator "=~" >> return RegexMatch ) AssocLeft- , Infix ( operator "!~" >> return NotRegexMatch ) AssocLeft+ , [ Infix ( operator' "=~" >> return RegexMatch ) AssocLeft+ , Infix ( operator' "!~" >> return NotRegexMatch ) AssocLeft ] ]+ where+ operator' :: String -> OP String+ operator' = unsafeCoerce operator+ reserved' :: String -> OP String+ reserved' = unsafeCoerce reserved stringExpression :: Parser Expression stringExpression = fmap (PValue . UInterpolable) interpolableString <|> (reserved "undef" *> return (PValue UUndef)) <|> fmap (PValue . UBoolean) puppetBool <|> variableOrHash <|> fmap (PValue . UString) literalValue
Puppet/Plugins.hs view
@@ -24,7 +24,7 @@ have no access to the manifests data. -}-module Puppet.Plugins (initLua, puppetFunc, closeLua, getFiles) where+module Puppet.Plugins (initLua, initLuaMaster, puppetFunc, closeLua, getFiles) where import Puppet.PP import qualified Scripting.Lua as Lua@@ -37,6 +37,7 @@ import qualified Data.Text.IO as T import qualified Data.Vector as V import Control.Monad.IO.Class+import Control.Concurrent import Puppet.Interpreter.Types import Puppet.Utils@@ -108,6 +109,18 @@ Lua.openlibs l luafuncs <- fmap concat $ mapM (loadLuaFile l) funcfiles return (l , luafuncs)++initLuaMaster :: T.Text -> IO (HM.HashMap T.Text ([PValue] -> InterpreterMonad PValue))+initLuaMaster moduledir = do+ (luastate, luafunctions) <- initLua moduledir+ c <- newMVar luastate+ let callf fname args = do+ r <- liftIO $ withMVar c $ \stt ->+ catch (fmap Right (Lua.callfunc stt (T.unpack fname) args)) (\e -> return $ Left $ show (e :: SomeException))+ case r of+ Right x -> return x+ Left rr -> throwPosError (string rr)+ return $ HM.fromList [(fname, callf fname) | fname <- luafunctions] -- | Obviously releases the Lua state. closeLua :: Lua.LuaState -> IO ()
Puppet/Preferences.hs view
@@ -17,8 +17,6 @@ { _manifestPath :: FilePath -- ^ The path to the manifests. , _modulesPath :: FilePath -- ^ The path to the modules. , _templatesPath :: FilePath -- ^ The path to the template.- , _compilePoolSize :: Int -- ^ Size of the compiler pool.- , _parsePoolSize :: Int -- ^ Size of the parser pool. , _prefPDB :: PuppetDBAPI , _natTypes :: Container PuppetTypeMethods -- ^ The list of native types. , _prefExtFuncs :: Container ( [PValue] -> InterpreterMonad PValue )@@ -35,4 +33,4 @@ templatedir = basedir <> "/templates" typenames <- fmap (map takeBaseName) (getFiles (T.pack modulesdir) "lib/puppet/type" ".rb") let loadedTypes = HM.fromList (map defaulttype typenames)- return $ Preferences manifestdir modulesdir templatedir 8 4 dummyPuppetDB (baseNativeTypes `HM.union` loadedTypes) (stdlibFunctions) (Just (basedir <> "/hiera.yaml"))+ return $ Preferences manifestdir modulesdir templatedir dummyPuppetDB (baseNativeTypes `HM.union` loadedTypes) (stdlibFunctions) (Just (basedir <> "/hiera.yaml"))
Puppet/Stdlib.hs view
@@ -7,7 +7,7 @@ import Puppet.Interpreter.Types import Control.Lens-import Control.Lens.Aeson+import Data.Aeson.Lens import Puppet.Lens import Data.Char import Data.Monoid@@ -18,7 +18,6 @@ import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import qualified Data.Text.Encoding as T-import Data.Attoparsec.Number import qualified Data.ByteString.Base16 as B16 -- | Contains the implementation of the StdLib functions.@@ -84,8 +83,7 @@ puppetAbs :: PValue -> InterpreterMonad PValue puppetAbs y = case y ^? _Number of- Just (I x) -> return $ _Integer # abs x- Just (D x) -> return $ _Double # abs x+ Just x -> return $ _Number # abs x Nothing -> throwPosError ("abs(): Expects a number, not" <+> pretty y) any2array :: [PValue] -> InterpreterMonad PValue
Puppet/Testing.hs view
@@ -114,7 +114,7 @@ testingDaemon pdb pdir allFacts = do LOG.updateGlobalLogger "Puppet.Daemon" (LOG.setLevel LOG.WARNING) prefs <- genPreferences pdir- q <- initDaemon (prefs { _compilePoolSize = 8, _parsePoolSize = 2, _prefPDB = pdb })+ q <- initDaemon (prefs { _prefPDB = pdb }) return (\nodname -> allFacts nodname >>= _dGetCatalog q nodname) -- | A default testing daemon.
PuppetDB/TestDB.hs view
@@ -7,7 +7,7 @@ import qualified Data.Either.Strict as S import qualified Data.Vector as V import Control.Lens-import Control.Lens.Aeson+import Data.Aeson.Lens import Control.Exception import Control.Concurrent.STM import Data.Monoid
− Text/Parser/Parsec.hs
@@ -1,56 +0,0 @@-{-# LANGUAGE UndecidableInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--------------------------------------------------------------------------------- |--- Module : Text.Parser.Parsec--- Copyright : (C) 2012-2013 Edward Kmett,--- License : BSD-style (see the file LICENSE)------ Maintainer : Edward Kmett <ekmett@gmail.com>--- Stability : experimental--- Portability : MPTCs, undecidable instances------ This module provides instances that permit @parsec@ parsers to use--- the combinators from the @parsers@ library.------------------------------------------------------------------------------module Text.Parser.Parsec () where--import Text.Parsec.Char-import Text.Parsec.Combinator-import Text.Parsec.Prim-import qualified Text.Parser.Char as P-import qualified Text.Parser.Combinators as P-import qualified Text.Parser.LookAhead as P-import qualified Text.Parser.Token as P-import Data.Char-import Control.Monad--instance (Stream s m t, Show t) => P.Parsing (ParsecT s u m) where- try = try- (<?>) = (<?>)- skipMany = skipMany- skipSome = skipMany1- unexpected = unexpected- eof = eof- notFollowedBy = notFollowedBy--instance (Stream s m t, Show t) => P.LookAheadParsing (ParsecT s u m) where- lookAhead = lookAhead--instance Stream s m Char => P.CharParsing (ParsecT s u m) where- satisfy = satisfy- char = char- notChar c = satisfy (/= c)- anyChar = anyChar- string = string--instance Stream s m Char => P.TokenParsing (ParsecT s u m) where- someSpace = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment)- where- simpleSpace = P.skipSome (satisfy isSpace)- oneLineComment = char '#' >> void (manyTill anyChar newline)- multiLineComment = try (string "/*") >> inComment- inComment = void (try (string "*/"))- <|> (P.skipSome (noneOf "*/") >> inComment)- <|> (oneOf "*/" >> inComment)-
language-puppet.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet-version: 0.10.6+version: 0.11.0 synopsis: Tools to parse and evaluate the Puppet DSL. description: This is a set of tools that is supposed to fill all your Puppet needs : syntax checks, catalog compilation, PuppetDB queries, simulationg of complex interactions between nodes, Puppet master replacement, and more ! homepage: http://lpuppet.banquise.net/@@ -51,8 +51,7 @@ , PuppetDB.Common , Hiera.Server , Puppet.Lens- other-modules: Text.Parser.Parsec- , Puppet.Utils+ other-modules: Puppet.Utils , Puppet.NativeTypes.File , Paths_language_puppet , Erb.Parser@@ -74,7 +73,7 @@ , Puppet.Interpreter.RubyRandom extensions: OverloadedStrings, BangPatterns if flag(hruby)- Build-depends: hruby >= 0.1.3 && <0.2+ Build-depends: hruby >= 0.2 && <0.3 CPP-Options: -DHRUBY ghc-options: -Wall -funbox-strict-fields@@ -85,28 +84,28 @@ , strict-base-types >= 0.2 , hashable == 1.2.* , unordered-containers == 0.2.*- , text >= 0.11 && < 1.1+ , text >= 0.11 , vector == 0.10.* , parsec == 3.1.* , mtl == 2.1.*- , lens >= 3.9 && < 4- , parsers >= 0.9 && < 0.10+ , lens >= 4 && < 5+ , parsers >= 0.10 && < 0.11 , ansi-wl-pprint == 0.6.* , unix == 2.6.*- , aeson == 0.6.*+ , aeson == 0.7.* , luautils >= 0.1.3 && < 0.1.4 , hslua >= 0.3.10 && < 0.4 , transformers == 0.3.* , hslogger == 1.2.* , time == 1.4.*- , filecache >= 0.2.2 && < 0.3+ , filecache >= 0.2.3 && < 0.3 , regex-pcre-builtin >= 0.94.4 , pcre-utils >= 0.1.0.1 && < 0.2 , process == 1.1.* , iconv == 0.4.* , http-types == 0.8.* , http-conduit >= 1.9 && <1.10- , attoparsec == 0.10.*+ , attoparsec == 0.11.* , case-insensitive == 1.1.* , cryptohash >= 0.10 && < 0.12 , base16-bytestring == 0.1.*@@ -114,9 +113,9 @@ , stm == 2.4.* , hspec >= 1.7.0 && <1.8.0 , yaml >= 0.8.0 && <0.9- , lens-aeson >= 0.1.2 && <0.2 , stateWriter == 0.2.* , split == 0.2.*+ , scientific == 0.2.* Test-Suite test-lexer hs-source-dirs: tests@@ -153,7 +152,7 @@ executable puppetresources hs-source-dirs: progs extensions: BangPatterns, OverloadedStrings- ghc-options: -Wall -rtsopts -threaded -eventlog+ ghc-options: -Wall -rtsopts -threaded -with-rtsopts "-A2M" ghc-prof-options: -auto-all -caf-all -fprof-auto build-depends: language-puppet,base,text,parsec,vector,ansi-wl-pprint,bytestring,mtl,hslogger,Diff,unordered-containers,strict-base-types,optparse-applicative,regex-pcre-builtin,lens,aeson,yaml,parallel-io main-is: PuppetResources.hs
progs/PuppetResources.hs view
@@ -163,7 +163,7 @@ return f parseFile :: FilePath -> IO (Either P.ParseError (V.Vector Statement))-parseFile fp = T.readFile fp >>= P.runParserT puppetParser () fp+parseFile fp = T.readFile fp >>= runMyParser puppetParser fp printContent :: T.Text -> FinalCatalog -> IO () printContent filename catalog =@@ -206,7 +206,7 @@ -- step 2 : replace all references with the resource title in case -- of aliases - yes this sucks knownEdge :: PuppetEdge -> Bool- knownEdge (PuppetEdge s d _) = (aliasMap ^. contains s) && (aliasMap ^. contains d)+ 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@@ -214,7 +214,7 @@ correctEdge :: PuppetEdge -> PuppetEdge correctEdge (PuppetEdge s d x) = PuppetEdge (correct s) (correct d) x correctResource :: Resource -> Resource- correctResource r = r & rrelations %~ HM.fromList . filter (\(x,_) -> aliasMap ^. contains x) . map (_1 %~ correct) . HM.toList+ correctResource r = r & rrelations %~ HM.fromList . filter (\(x,_) -> aliasMap & has (ix x)) . map (_1 %~ correct) . HM.toList in (wResources .~ correctResources) . (wEdges .~ correctEdges) $ w