language-puppet 0.10.3 → 0.10.4
raw patch · 5 files changed
+88/−53 lines, 5 filesdep ~hrubydep ~text
Dependency ranges changed: hruby, text
Files
- Erb/Compute.hs +61/−46
- Puppet/Daemon.hs +10/−1
- Puppet/Interpreter/PrettyPrinter.hs +1/−1
- Puppet/Parser/PrettyPrinter.hs +13/−2
- language-puppet.cabal +3/−3
Erb/Compute.hs view
@@ -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
Puppet/Daemon.hs view
@@ -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
Puppet/Interpreter/PrettyPrinter.hs view
@@ -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))
Puppet/Parser/PrettyPrinter.hs view
@@ -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")
language-puppet.cabal view
@@ -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.*