diff --git a/Erb/Compute.hs b/Erb/Compute.hs --- a/Erb/Compute.hs +++ b/Erb/Compute.hs @@ -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 diff --git a/Hiera/Server.hs b/Hiera/Server.hs --- a/Hiera/Server.hs +++ b/Hiera/Server.hs @@ -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 diff --git a/Puppet/Daemon.hs b/Puppet/Daemon.hs --- a/Puppet/Daemon.hs +++ b/Puppet/Daemon.hs @@ -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 diff --git a/Puppet/Interpreter.hs b/Puppet/Interpreter.hs --- a/Puppet/Interpreter.hs +++ b/Puppet/Interpreter.hs @@ -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 diff --git a/Puppet/Interpreter/Resolve.hs b/Puppet/Interpreter/Resolve.hs --- a/Puppet/Interpreter/Resolve.hs +++ b/Puppet/Interpreter/Resolve.hs @@ -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) diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs --- a/Puppet/Interpreter/Types.hs +++ b/Puppet/Interpreter/Types.hs @@ -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 diff --git a/Puppet/Lens.hs b/Puppet/Lens.hs --- a/Puppet/Lens.hs +++ b/Puppet/Lens.hs @@ -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'. diff --git a/Puppet/NativeTypes/Package.hs b/Puppet/NativeTypes/Package.hs --- a/Puppet/NativeTypes/Package.hs +++ b/Puppet/NativeTypes/Package.hs @@ -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) diff --git a/Puppet/NativeTypes/SshSecure.hs b/Puppet/NativeTypes/SshSecure.hs --- a/Puppet/NativeTypes/SshSecure.hs +++ b/Puppet/NativeTypes/SshSecure.hs @@ -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 diff --git a/Puppet/Parser.hs b/Puppet/Parser.hs --- a/Puppet/Parser.hs +++ b/Puppet/Parser.hs @@ -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 diff --git a/Puppet/Plugins.hs b/Puppet/Plugins.hs --- a/Puppet/Plugins.hs +++ b/Puppet/Plugins.hs @@ -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 () diff --git a/Puppet/Preferences.hs b/Puppet/Preferences.hs --- a/Puppet/Preferences.hs +++ b/Puppet/Preferences.hs @@ -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")) diff --git a/Puppet/Stdlib.hs b/Puppet/Stdlib.hs --- a/Puppet/Stdlib.hs +++ b/Puppet/Stdlib.hs @@ -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 diff --git a/Puppet/Testing.hs b/Puppet/Testing.hs --- a/Puppet/Testing.hs +++ b/Puppet/Testing.hs @@ -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. diff --git a/PuppetDB/TestDB.hs b/PuppetDB/TestDB.hs --- a/PuppetDB/TestDB.hs +++ b/PuppetDB/TestDB.hs @@ -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 diff --git a/Text/Parser/Parsec.hs b/Text/Parser/Parsec.hs deleted file mode 100644 --- a/Text/Parser/Parsec.hs +++ /dev/null @@ -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 --- 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) - diff --git a/language-puppet.cabal b/language-puppet.cabal --- a/language-puppet.cabal +++ b/language-puppet.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: language-puppet -version: 0.10.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 diff --git a/progs/PuppetResources.hs b/progs/PuppetResources.hs --- a/progs/PuppetResources.hs +++ b/progs/PuppetResources.hs @@ -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