{-# LANGUAGE NamedFieldPuns #-}
module Puppet.Runner.Erb (
initTemplateDaemon
, rubyEvaluate
) where
import XPrelude
import Data.Aeson.Lens (_Number)
import qualified Data.Either.Strict as S
import qualified Data.FileCache as Cache
import qualified Data.List as List
import qualified Data.List.Split as List
import qualified Data.Text as Text
import Data.Tuple.Strict (Pair (..))
import qualified Data.Vector as Vector
import Debug.Trace
import Foreign.Ruby
import qualified Foreign.Ruby.Bindings as FR
import qualified Foreign.Ruby.Helpers as FR
import GHC.Conc (labelThread)
import Paths_language_puppet (getDataFileName)
import System.Environment (getExecutablePath)
import System.FilePath
import System.Posix.Files
import Text.Parsec hiding (string)
import Text.Parsec.Error
import Text.Parsec.Pos
import Erb
import Puppet.Interpreter.Helpers
import Puppet.Interpreter.IO
import Puppet.Interpreter.Resolve
import Puppet.Interpreter.Types
import Puppet.Runner.Erb.Evaluate
import Puppet.Runner.Preferences
import Puppet.Runner.Stats
instance IsString TemplateParseError where
fromString s = TemplateParseError $ newErrorMessage (Message s) (initialPos mempty)
newtype TemplateParseError = TemplateParseError { tgetError :: ParseError }
type TemplateQuery = (Chan TemplateAnswer, TemplateSource, InterpreterState, InterpreterReader IO)
type TemplateAnswer = S.Either PrettyError Text
showRubyError :: RubyError -> PrettyError
showRubyError (Stack msg stk) = PrettyError $ dullred (ppstring msg) <> softline <> dullyellow (ppstring stk)
showRubyError (WithOutput str _) = PrettyError $ dullred (ppstring str)
showRubyError (OtherError rr) = PrettyError (dullred (pptext rr))
initTemplateDaemon :: RubyInterpreter
-> Preferences IO
-> MStats
-> IO (TemplateSource -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError Text))
initTemplateDaemon rubyintp prefs mvstats = do
controlchan <- newChan
templatecache <- Cache.newFileCache
let returnError rs = return $ \_ _ _ -> pure (S.Left (showRubyError rs))
x <- runExceptT $ do
liftIO (getRubyScriptPath "hrubyerb.rb") >>= ExceptT . loadFile rubyintp
ExceptT (registerGlobalFunction4 rubyintp "varlookup" hrresolveVariable)
ExceptT (registerGlobalFunction5 rubyintp "callextfunc" hrcallfunction)
liftIO $ void $ forkIO $ templateDaemon rubyintp
(prefs ^. prefPuppetPaths.modulesPath)
(prefs ^. prefPuppetPaths.templatesPath)
controlchan
mvstats
templatecache
pure $! templateQuery controlchan
either returnError pure x
templateQuery :: Chan TemplateQuery -> TemplateSource -> InterpreterState -> InterpreterReader IO -> IO (S.Either PrettyError Text)
templateQuery qchan filename intpstate intpreader = do
rchan <- newChan
writeChan qchan (rchan, filename, intpstate, intpreader)
readChan rchan
templateDaemon :: RubyInterpreter -> FilePath -> FilePath -> Chan TemplateQuery -> MStats -> Cache.FileCacheR TemplateParseError [RubyStatement] -> IO ()
templateDaemon rubyintp modpath templatepath qchan mvstats filecache = do
let nameThread :: String -> IO ()
nameThread n = myThreadId >>= flip labelThread n
nameThread "RubyTemplateDaemon"
(respchan, fileinfo, intpstate, intpreader) <- readChan qchan
case fileinfo of
Filename filename -> do
let prts = List.splitOn "/" filename
searchpathes | length prts > 1 = [ modpath </> List.head prts </> "templates" </> List.intercalate "/" (List.tail prts)
, templatepath </> filename
]
| otherwise = [templatepath </> filename]
acceptablefiles <- filterM fileExist searchpathes
if null acceptablefiles
then writeChan respchan (S.Left $ PrettyError $ "Can't find template file for" <+> pptext filename <+> ", looked in" <+> list (map pptext searchpathes))
else measure mvstats (toS filename) (computeTemplate rubyintp (Filename (List.head acceptablefiles)) intpstate intpreader mvstats filecache) >>= writeChan respchan
Inline _ -> measure mvstats "inline" (computeTemplate rubyintp fileinfo intpstate intpreader mvstats filecache) >>= writeChan respchan
templateDaemon rubyintp modpath templatepath qchan mvstats filecache
computeTemplate :: RubyInterpreter -> TemplateSource -> InterpreterState -> InterpreterReader IO -> MStats -> Cache.FileCacheR TemplateParseError [RubyStatement] -> IO TemplateAnswer
computeTemplate rubyintp srcinfo intpstate intpreader mstats filecache = do
let (curcontext, fvariables) =
case extractScope intpstate of
Nothing -> (mempty, mempty)
Just (c,v) -> (c,v)
template_src = templateSrc srcinfo
mkSafe a = makeSafe rubyintp a >>= \case
Left err -> return (S.Left (showRubyError err))
Right x -> return x
encapsulateError = _Left %~ TemplateParseError
variables = fvariables & traverse . scopeVariables . traverse . _1 . _1 %~ toStr
toStr (PNumber n) = PString (scientific2text n)
toStr x = x
traceEventIO ("START template " <> template_src)
parsed <- case srcinfo of
Filename _ -> measure mstats ("parsing - " <> toS template_src) $ Cache.lazyQuery filecache template_src $ fmap encapsulateError (parseErbFile template_src)
Inline s -> measure mstats ("parsing - " <> toS template_src) $ pure $ encapsulateError (runParser erbparser () "inline" (toS s))
o <- case parsed of
Left err -> do
let !msg = "Template could not be parsed " <> show (tgetError err)
logInfoStr msg
measure mstats ("ruby - " <> toS template_src) $ mkSafe $ computeTemplateWRuby srcinfo curcontext variables intpstate intpreader
Right ast -> case rubyEvaluate variables curcontext ast of
Right ev -> pure (S.Right ev)
Left err -> do
let !msg = "At " <> showPPos'(intpstate^.curPos) <> " the evaluation of template '" <> template_src <> "' failed. " <> show err
logErrorStr msg
measure mstats ("ruby efail - " <> toS template_src) $ mkSafe $ computeTemplateWRuby srcinfo curcontext variables intpstate intpreader
traceEventIO ("STOP template " <> template_src)
pure o
getRubyScriptPath :: String -> IO String
getRubyScriptPath rubybin = do
let checkpath :: FilePath -> IO FilePath -> IO FilePath
checkpath fp nxt =
ifM (fileExist fp)
(pure fp)
nxt
withExecutablePath = do
path <- fmap takeDirectory getExecutablePath
let fullpath = path </> rubybin
checkpath fullpath $ checkpath ("/usr/local/bin/" <> rubybin) (pure rubybin)
cabalPath <- getDataFileName $ "ruby/" ++ rubybin :: IO FilePath
checkpath cabalPath withExecutablePath
hrresolveVariable :: RValue -> RValue -> RValue -> RValue -> IO RValue
hrresolveVariable _ rscp rvariables rtoresolve = do
scope <- FR.extractHaskellValue rscp
variables <- FR.extractHaskellValue rvariables
toresolve <- FR.fromRuby rtoresolve
let answer = case toresolve of
Right "~g~e~t_h~a~s~h~" ->
let getvars ctx = (variables ^. ix ctx . scopeVariables) & traverse %~ view (_1 . _1)
vars = getvars "::" <> getvars scope
in Right (PHash vars)
Right t -> getVariable variables scope t
Left err -> Left ("The variable name is not a string" <+> pptext err)
case answer of
Left _ -> getSymbol "undef"
Right r -> FR.toRuby r
hrcallfunction :: RValue -> RValue -> RValue -> RValue -> RValue -> IO RValue
hrcallfunction _ rfname rargs rstt rrdr = do
efname <- FR.fromRuby rfname
eargs <- FR.fromRuby rargs
rdr <- FR.extractHaskellValue rrdr
stt <- FR.extractHaskellValue rstt
let rubyerr :: String -> IO RValue
rubyerr err = fmap (either snd identity) (FR.toRuby (Text.pack err) >>= FR.safeMethodCall "MyError" "new" . (:[]))
case (,) <$> efname <*> eargs of
Right (fname, varray) | fname `elem` ["template", "inline_template"] -> do
logWarning $ "Can't parse a call to the external ruby function '" <> fname <> "' n an erb file.\n\tIt is not possible to call it from a Ruby function. It would stall (yes it sucks ...).\n\tChoosing to output \"undef\" !"
getSymbol "undef"
| otherwise -> do
let args = case varray of
[PArray vargs] -> Vector.toList vargs
_ -> varray
(x,_,_) <- interpretMonad rdr stt (resolveFunction' fname args)
case x of
Right o -> case o ^? _Number of
Just n -> FR.toRuby n
Nothing -> FR.toRuby o
Left err -> rubyerr (show err)
Left err -> rubyerr err
computeTemplateWRuby :: TemplateSource -> Text -> Container ScopeInformation -> InterpreterState -> InterpreterReader IO -> IO TemplateAnswer
computeTemplateWRuby fileinfo curcontext variables stt rdr = FR.freezeGC $ eitherDocIO $ do
rscp <- FR.embedHaskellValue curcontext
rvariables <- FR.embedHaskellValue variables
rstt <- FR.embedHaskellValue stt
rrdr <- FR.embedHaskellValue rdr
let varlist = variables ^. ix curcontext . scopeVariables
contentinfo <- case fileinfo of
Filename fname -> FR.toRuby (Text.pack fname)
Inline _ -> FR.toRuby ("-" :: Text)
let withBinding f =
FR.safeMethodCall "ErbBinding" "new" [rscp,rvariables,rstt,rrdr,contentinfo] >>= \case
Left x -> pure (Left x)
Right v -> do
forM_ (itoList varlist) $ \(varname, varval :!: _ :!: _) -> FR.toRuby varval >>= FR.rb_iv_set v (toS varname)
f v
o <- case fileinfo of
Filename fname -> do
rfname <- FR.toRuby (Text.pack fname)
withBinding $ \v -> FR.safeMethodCall "Controller" "runFromFile" [rfname,v]
Inline content -> withBinding $ \v -> FR.toRuby content >>= FR.safeMethodCall "Controller" "runFromContent" . (:[v])
FR.freeHaskellValue rrdr
FR.freeHaskellValue rstt
FR.freeHaskellValue rvariables
FR.freeHaskellValue rscp
case o of
Left (err, _) ->
pure (S.Left $ PrettyError (dullred (pptext err) <+> "in" <+> dullgreen (pptext (templateSrc fileinfo))))
Right r -> FR.fromRuby r >>= \case
Right result -> pure (S.Right result)
Left err -> pure (S.Left $ PrettyError ("Could not deserialiaze ruby output" <+> pptext err))
eitherDocIO :: IO (S.Either PrettyError a) -> IO (S.Either PrettyError a)
eitherDocIO computation =
(computation >>= check) `catch` (\e -> pure $ S.Left $ PrettyError $ dullred $ ppline $ show (e :: SomeException))
where
check (S.Left r) = pure (S.Left r)
check (S.Right x) = pure (S.Right x)
templateSrc :: TemplateSource -> String
templateSrc = \case
Inline _ -> "inline_template"
Filename n -> n