diff --git a/Erb/Compute.hs b/Erb/Compute.hs --- a/Erb/Compute.hs +++ b/Erb/Compute.hs @@ -23,20 +23,18 @@ import Debug.Trace import qualified System.Log.Logger as LOG import qualified Data.Text as T -import Text.Parsec +import Text.Parsec hiding (string) import Text.Parsec.Error import Text.Parsec.Pos import System.Environment import Data.FileCache #ifdef HRUBY -import Foreign hiding (void) -import Foreign.Ruby +import qualified Foreign.Ruby as FR +import Foreign.Ruby.Safe import Control.Lens import Data.Tuple.Strict -type RegisteredGetvariable = RValue -> RValue -> RValue -> RValue -> IO RValue -foreign import ccall "wrapper" mkRegisteredGetvariable :: RegisteredGetvariable -> IO (FunPtr RegisteredGetvariable) #else import System.IO @@ -47,6 +45,10 @@ import qualified Data.Text.Lazy.Builder as T import qualified Data.Foldable as F import qualified Data.Vector as V + +-- we don't have a nice interpreter whithout hruby, but we can keep the +-- function signatures with this hack +type RubyInterpreter = () #endif instance Error ParseError where @@ -56,26 +58,33 @@ type TemplateQuery = (Chan TemplateAnswer, Either T.Text T.Text, T.Text, Container ScopeInformation) type TemplateAnswer = S.Either Doc T.Text -initTemplateDaemon :: Preferences -> MStats -> IO (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text)) -initTemplateDaemon (Preferences _ modpath templatepath _ _ _ _ _ _) mvstats = do +#ifdef HRUBY +showRubyError :: RubyError -> Doc +showRubyError (Stack msg stk) = dullred (string msg) dullyellow (string stk) +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 controlchan <- newChan templatecache <- newFileCache -#ifdef HRUBY -- forkOS is used because ruby doesn't like to change threads -- all initialization is done on the current thread - void $ forkOS $ do - initialize - s <- (getRubyScriptPath "hrubyerb.rb" >>= \p -> rb_load_protect p 0) - unless (s == 0) $ do - msg <- showErrorStack - error ("initTemplateDaemon: " ++ msg) - rubyResolveFunction <- mkRegisteredGetvariable hrresolveVariable - rb_define_global_function "varlookup" rubyResolveFunction 3 - templateDaemon (T.pack modpath) (T.pack templatepath) controlchan mvstats templatecache + let returnError rs = return $ \_ _ _ -> return (S.Left (showRubyError rs)) + getRubyScriptPath "hrubyerb.rb" >>= loadFile intr >>= \case + Left rs -> returnError rs + Right () -> registerGlobalFunction4 intr "varlookup" hrresolveVariable >>= \case + Right () -> do + void $ forkIO $ templateDaemon intr (T.pack modpath) (T.pack templatepath) controlchan mvstats templatecache + return (templateQuery controlchan) + Left rs -> returnError rs #else - forkIO (templateDaemon (T.pack modpath) (T.pack templatepath) controlchan mvstats templatecache) -#endif +initTemplateDaemon :: Preferences -> MStats -> IO (Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text)) +initTemplateDaemon (Preferences _ modpath templatepath _ _ _ _ _ _) mvstats = do + controlchan <- newChan + templatecache <- newFileCache + forkIO (templateDaemon () (T.pack modpath) (T.pack templatepath) controlchan mvstats templatecache) return (templateQuery controlchan) +#endif templateQuery :: Chan TemplateQuery -> Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO (S.Either Doc T.Text) templateQuery qchan filename scope variables = do @@ -83,8 +92,8 @@ writeChan qchan (rchan, filename, scope, variables) readChan rchan -templateDaemon :: T.Text -> T.Text -> Chan TemplateQuery -> MStats -> FileCacheR ParseError [RubyStatement] -> IO () -templateDaemon modpath templatepath qchan mvstats filecache = do +templateDaemon :: RubyInterpreter -> T.Text -> T.Text -> Chan TemplateQuery -> MStats -> FileCacheR ParseError [RubyStatement] -> IO () +templateDaemon intr modpath templatepath qchan mvstats filecache = do (respchan, fileinfo, scope, variables) <- readChan qchan case fileinfo of Right filename -> do @@ -94,15 +103,18 @@ acceptablefiles <- filterM (fileExist . T.unpack) searchpathes if null acceptablefiles then writeChan respchan (S.Left $ "Can't find template file for" <+> ttext filename <+> ", looked in" <+> list (map ttext searchpathes)) - else measure mvstats ("total - " <> filename) (computeTemplate (Right (head acceptablefiles)) scope variables mvstats filecache) >>= writeChan respchan - Left _ -> measure mvstats "total - inline" (computeTemplate fileinfo scope variables mvstats filecache) >>= writeChan respchan - templateDaemon modpath templatepath qchan mvstats filecache + else measure mvstats ("total - " <> filename) (computeTemplate intr (Right (head acceptablefiles)) scope variables mvstats filecache) >>= writeChan respchan + Left _ -> measure mvstats "total - inline" (computeTemplate intr fileinfo scope variables mvstats filecache) >>= writeChan respchan + templateDaemon intr modpath templatepath qchan mvstats filecache -computeTemplate :: Either T.Text T.Text -> T.Text -> Container ScopeInformation -> MStats -> FileCacheR ParseError [RubyStatement] -> IO TemplateAnswer -computeTemplate fileinfo curcontext variables mstats filecache = do +computeTemplate :: RubyInterpreter -> Either T.Text T.Text -> T.Text -> Container ScopeInformation -> MStats -> FileCacheR ParseError [RubyStatement] -> IO TemplateAnswer +computeTemplate intr fileinfo curcontext variables mstats filecache = do let (filename, ufilename) = case fileinfo of Left _ -> ("inline", "inline") Right x -> (x, T.unpack x) + mkSafe a = makeSafe intr a >>= \case + Left rr -> return (S.Left (showRubyError rr)) + Right x -> return x parsed <- case fileinfo of Right _ -> measure mstats ("parsing - " <> filename) $ lazyQuery filecache ufilename $ parseErbFile ufilename Left content -> measure mstats ("parsing - " <> filename) $ return (runParser erbparser () "inline" (T.unpack content)) @@ -111,14 +123,14 @@ let !msg = "template " ++ ufilename ++ " could not be parsed " ++ show err traceEventIO msg LOG.debugM "Erb.Compute" msg - measure mstats ("ruby - " <> filename) $ computeTemplateWRuby fileinfo curcontext variables + measure mstats ("ruby - " <> filename) $ mkSafe $ computeTemplateWRuby fileinfo curcontext variables Right ast -> case rubyEvaluate variables curcontext ast of Right ev -> return (S.Right ev) Left err -> do let !msg = "template " ++ ufilename ++ " evaluation failed " ++ show err traceEventIO msg LOG.debugM "Erb.Compute" msg - measure mstats ("ruby efail - " <> filename) $ computeTemplateWRuby fileinfo curcontext variables + measure mstats ("ruby efail - " <> filename) $ mkSafe $ computeTemplateWRuby fileinfo curcontext variables getRubyScriptPath :: String -> IO String getRubyScriptPath rubybin = do @@ -135,47 +147,50 @@ else rubybin #ifdef HRUBY +-- This must be called from the proper thread. As this is callback, this +-- should be ok. hrresolveVariable :: RValue -> RValue -> RValue -> RValue -> IO RValue -- T.Text -> Container PValue -> RValue -> RValue -> IO RValue hrresolveVariable _ rscp rvariables rtoresolve = do - scope <- extractHaskellValue rscp - variables <- extractHaskellValue rvariables - toresolve <- fromRuby rtoresolve + scope <- FR.extractHaskellValue rscp + variables <- FR.extractHaskellValue rvariables + toresolve <- FR.fromRuby rtoresolve let answer = case toresolve of Just t -> getVariable variables scope t _ -> Left "The variable name is not a string" case answer of - Left _ -> getSymbol "undef" - Right r -> toRuby r + Left _ -> FR.getSymbol "undef" + Right r -> FR.toRuby r computeTemplateWRuby :: Either T.Text T.Text -> T.Text -> Container ScopeInformation -> IO TemplateAnswer -computeTemplateWRuby fileinfo curcontext variables = freezeGC $ eitherDocIO $ do - rscp <- embedHaskellValue curcontext - rvariables <- embedHaskellValue variables +computeTemplateWRuby fileinfo curcontext variables = FR.freezeGC $ eitherDocIO $ do + rscp <- FR.embedHaskellValue curcontext + rvariables <- FR.embedHaskellValue variables let varlist = variables ^. ix curcontext . scopeVariables + -- must be called from a "makeSafe" thingie let withBinding f = do - erbBinding <- safeMethodCall "ErbBinding" "new" [rscp,rvariables] + erbBinding <- FR.safeMethodCall "ErbBinding" "new" [rscp,rvariables] case erbBinding of Left x -> return (Left x) Right v -> do - forM_ (itoList varlist) $ \(varname, (varval :!: _ :!: _)) -> toRuby varval >>= rb_iv_set v (T.unpack varname) + forM_ (itoList varlist) $ \(varname, (varval :!: _ :!: _)) -> FR.toRuby varval >>= FR.rb_iv_set v (T.unpack varname) f v o <- case fileinfo of Right fname -> do - rfname <- toRuby fname - withBinding $ \v -> safeMethodCall "Controller" "runFromFile" [rfname,v] - Left content -> withBinding $ \v -> toRuby content >>= safeMethodCall "Controller" "runFromContent" . (:[v]) - freeHaskellValue rvariables - freeHaskellValue rscp + 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 rvariables + FR.freeHaskellValue rscp case o of Left (rr, _) -> let fname = case fileinfo of Right f -> T.unpack f Left _ -> "inline_template" in return (S.Left (dullred (text rr) <+> "in" <+> dullgreen (text fname))) - Right r -> fromRuby r >>= \case - Just result -> return (S.Right result) - Nothing -> return (S.Left "Could not deserialiaze ruby output") + Right r -> FR.fromRuby r >>= \case + Just result -> return (S.Right result) + Nothing -> return (S.Left "Could not deserialiaze ruby output") #else saveTmpContent :: T.Text -> IO FilePath diff --git a/Puppet/Daemon.hs b/Puppet/Daemon.hs --- a/Puppet/Daemon.hs +++ b/Puppet/Daemon.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase, CPP #-} module Puppet.Daemon (initDaemon, logDebug, logInfo, logWarning, logError) where import Puppet.Parser @@ -29,6 +29,10 @@ import Data.Tuple.Strict import Control.Exception +#ifdef HRUBY +import Foreign.Ruby.Safe +#endif + loggerName :: String loggerName = "Puppet.Daemon" @@ -90,7 +94,12 @@ parserStats <- newStats catalogStats <- newStats getStatements <- initParserDaemon prefs parserStats +#ifdef HRUBY + intr <- startRubyInterpreter + getTemplate <- initTemplateDaemon intr prefs templateStats +#else getTemplate <- initTemplateDaemon prefs templateStats +#endif hquery <- case prefs ^. hieraPath of Just p -> startHiera p >>= \case Left _ -> return dummyHiera diff --git a/Puppet/Interpreter/PrettyPrinter.hs b/Puppet/Interpreter/PrettyPrinter.hs --- a/Puppet/Interpreter/PrettyPrinter.hs +++ b/Puppet/Interpreter/PrettyPrinter.hs @@ -34,7 +34,7 @@ instance Pretty PValue where pretty (PBoolean True) = dullmagenta $ text "true" pretty (PBoolean False) = dullmagenta $ text "false" - pretty (PString s) = dullcyan (text (show s)) + pretty (PString s) = dullcyan (ttext (stringEscape s)) pretty PUndef = dullmagenta (text "undef") pretty (PResourceReference t n) = capitalize t <> brackets (text (T.unpack n)) pretty (PArray v) = list (map pretty (V.toList v)) diff --git a/Puppet/Parser/PrettyPrinter.hs b/Puppet/Parser/PrettyPrinter.hs --- a/Puppet/Parser/PrettyPrinter.hs +++ b/Puppet/Parser/PrettyPrinter.hs @@ -21,6 +21,17 @@ where showC (a :!: b) = pretty a <+> text "=>" <+> pretty b +-- Extremely hacky escaping system +stringEscape :: T.Text -> T.Text +stringEscape = T.concatMap escapeChar + where + escapeChar '"' = "\\\"" + escapeChar '\n' = "\\n" + escapeChar '\t' = "\\t" + escapeChar '\r' = "\\r" + escapeChar x = T.singleton x +{-# INLINE stringEscape #-} + instance Pretty Expression where pretty (Equal a b) = parens (pretty a <+> text "==" <+> pretty b) pretty (Different a b) = parens (pretty a <+> text "!=" <+> pretty b) @@ -71,10 +82,10 @@ instance Pretty UValue where pretty (UBoolean True) = dullmagenta $ text "true" pretty (UBoolean False) = dullmagenta $ text "false" - pretty (UString s) = dullcyan (text (show s)) + pretty (UString s) = char '"' <> dullcyan (ttext (stringEscape s)) <> char '"' pretty (UInterpolable v) = char '"' <> hcat (map specific (V.toList v)) <> char '"' where - specific (UString s) = dullcyan (text (tail (init (show s)))) + specific (UString s) = dullcyan (ttext (stringEscape s)) specific (UVariableReference vr) = dullblue (text "${" <> text (T.unpack vr) <> char '}') specific x = bold (red (pretty x)) pretty UUndef = dullmagenta (text "undef") 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.3 +version: 0.10.4 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/ @@ -73,7 +73,7 @@ , Puppet.Interpreter.RubyRandom extensions: OverloadedStrings, BangPatterns if flag(hruby) - Build-depends: hruby >= 0.1.1 && <0.2 + Build-depends: hruby >= 0.1.3 && <0.2 CPP-Options: -DHRUBY ghc-options: -Wall -funbox-strict-fields @@ -84,7 +84,7 @@ , strict-base-types >= 0.2 , hashable == 1.2.* , unordered-containers == 0.2.* - , text == 0.11.* + , text >= 0.11 && < 1.1 , vector == 0.10.* , parsec == 3.1.* , mtl == 2.1.*