diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,10 @@ +#v1.3 (2016/07/11) + +This release is about dependencies versions upgrades. + +## Removed features +* External Lua plugins are not a thing anymore + #v1.2 (2016/05/31) ## New features diff --git a/Puppet/Daemon.hs b/Puppet/Daemon.hs --- a/Puppet/Daemon.hs +++ b/Puppet/Daemon.hs @@ -16,7 +16,6 @@ import Control.Lens hiding (Strict) import qualified Data.Either.Strict as S import Data.FileCache as FileCache -import qualified Data.HashMap.Strict as HM import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Tuple.Strict @@ -40,7 +39,6 @@ import Puppet.OptionalTests import Puppet.Parser import Puppet.Parser.Types -import Puppet.Plugins import Puppet.PP import Puppet.Preferences import Puppet.Stats @@ -83,12 +81,10 @@ > ssh -L 8080:localhost:8080 puppet.host -} initDaemon :: Preferences IO -> IO Daemon -initDaemon pref0 = do - setupLogger (pref0 ^. prefLogLevel) +initDaemon pref = do + setupLogger (pref ^. prefLogLevel) logDebug "initDaemon" traceEventIO "initDaemon" - luacontainer <- initLuaMaster (T.pack (pref0 ^. prefPuppetPaths.modulesPath)) - let pref = pref0 & prefExtFuncs %~ HM.union luacontainer hquery <- case pref ^. prefHieraPath of Just p -> either error id <$> startHiera p Nothing -> return dummyHiera diff --git a/Puppet/Interpreter.hs b/Puppet/Interpreter.hs --- a/Puppet/Interpreter.hs +++ b/Puppet/Interpreter.hs @@ -53,12 +53,12 @@ 'InterpreterState' and might not be up to date. There are only useful for coverage testing (checking dependencies for instance). -} -interpretCatalog :: (Functor m, Monad m) - => InterpreterReader m -- ^ The whole environment required for computing catalog. - -> NodeName - -> Facts - -> Container Text -- ^ Server settings - -> m (Pair (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) [Pair Priority Doc]) +interpretCatalog :: Monad m + => InterpreterReader m -- ^ The whole environment required for computing catalog. + -> NodeName + -> Facts + -> Container Text -- ^ Server settings + -> m (Pair (S.Either PrettyError (FinalCatalog, EdgeMap, FinalCatalog, [Resource])) [Pair Priority Doc]) interpretCatalog interpretReader node facts settings = do (output, _, warnings) <- interpretMonad interpretReader (initialState facts settings) (computeCatalog node) return (strictifyEither output :!: warnings) diff --git a/Puppet/Interpreter/IO.hs b/Puppet/Interpreter/IO.hs --- a/Puppet/Interpreter/IO.hs +++ b/Puppet/Interpreter/IO.hs @@ -10,7 +10,6 @@ , interpretMonad ) where -import Control.Concurrent.MVar import Control.Exception import Control.Lens import Control.Monad.Operational @@ -22,40 +21,35 @@ import qualified Data.Text.IO as T import Debug.Trace (traceEventIO) import GHC.Stack -import qualified Scripting.Lua as Lua import Puppet.Interpreter.PrettyPrinter () import Puppet.Interpreter.Types -import Puppet.Plugins () import Puppet.PP -defaultImpureMethods :: (Functor m, MonadIO m) => IoMethods m +defaultImpureMethods :: MonadIO m => IoMethods m defaultImpureMethods = IoMethods (liftIO currentCallStack) - (liftIO . file) - (liftIO . traceEventIO) - (\c fname args -> liftIO (runlua c fname args)) + (liftIO . file) + (liftIO . traceEventIO) where file [] = return $ Left "" file (x:xs) = (Right <$> T.readFile (T.unpack x)) `catch` (\SomeException{} -> file xs) - runlua c fname args = liftIO $ withMVar c $ \lstt -> - catch (Right <$> Lua.callfunc lstt (T.unpack fname) args) (\e -> return $ Left $ show (e :: SomeException)) -- | The operational interpreter function -interpretMonad :: (Functor m, Monad m) - => InterpreterReader m - -> InterpreterState - -> InterpreterMonad a - -> m (Either PrettyError a, InterpreterState, InterpreterWriter) +interpretMonad :: Monad m + => InterpreterReader m + -> InterpreterState + -> InterpreterMonad a + -> m (Either PrettyError a, InterpreterState, InterpreterWriter) interpretMonad r s0 instr = let (!p, !s1) = runState (viewT instr) s0 in eval r s1 p -- The internal (not exposed) eval function -eval :: (Functor m, Monad m) - => InterpreterReader m - -> InterpreterState - -> ProgramViewT InterpreterInstr (State InterpreterState) a - -> m (Either PrettyError a, InterpreterState, InterpreterWriter) +eval :: Monad m + => InterpreterReader m + -> InterpreterState + -> ProgramViewT InterpreterInstr (State InterpreterState) a + -> m (Either PrettyError a, InterpreterState, InterpreterWriter) eval _ s (Return x) = return (Right x, s, mempty) eval r s (a :>>= k) = let runInstr = interpretMonad r s . k -- run one instruction @@ -102,6 +96,3 @@ TraceEvent e -> (r ^. readerIoMethods . ioTraceEvent) e >>= runInstr IsIgnoredModule m -> runInstr (r ^. readerIgnoredModules . contains m) IsExternalModule m -> runInstr (r ^. readerExternalModules . contains m) - CallLua c fname args -> (r ^. readerIoMethods . ioCallLua) c fname args >>= \case - Right x -> runInstr x - Left rr -> thpe (PrettyError (string rr)) diff --git a/Puppet/Interpreter/PrettyPrinter.hs b/Puppet/Interpreter/PrettyPrinter.hs --- a/Puppet/Interpreter/PrettyPrinter.hs +++ b/Puppet/Interpreter/PrettyPrinter.hs @@ -139,7 +139,6 @@ Left content -> pretty (PString content) Right filena -> ttext filena pretty (ExternalFunction fn args) = pf (ttext fn) (map pretty args) - pretty (CallLua _ f args) = pf (ttext f) (map pretty args) pretty GetNodeName = pf "GetNodeName" [] pretty (HieraQuery _ q _) = pf "HieraQuery" [ttext q] pretty GetCurrentCallStack = pf "GetCurrentCallStack" [] diff --git a/Puppet/Interpreter/Pure.hs b/Puppet/Interpreter/Pure.hs --- a/Puppet/Interpreter/Pure.hs +++ b/Puppet/Interpreter/Pure.hs @@ -27,7 +27,7 @@ -- | Worst name ever, this is a set of pure stub for the 'ImpureMethods' -- type. impurePure :: IoMethods Identity -impurePure = IoMethods (return []) (const (return (Left "Can't read file"))) (\_ -> return ()) (\_ _ _ -> return (Left "Can't call lua")) +impurePure = IoMethods (return []) (const (return (Left "Can't read file"))) (\_ -> return ()) -- | A pure 'InterpreterReader', that can only evaluate a subset of the -- templates, and that can include only the supplied top level statements. diff --git a/Puppet/Interpreter/Types.hs b/Puppet/Interpreter/Types.hs --- a/Puppet/Interpreter/Types.hs +++ b/Puppet/Interpreter/Types.hs @@ -79,7 +79,6 @@ , showPos ) where -import Control.Concurrent.MVar (MVar) import Control.Exception import Control.Lens hiding (Strict) import Control.Monad.Except @@ -106,7 +105,6 @@ import Foreign.Ruby.Helpers import GHC.Generics hiding (to) import GHC.Stack -import qualified Scripting.Lua as Lua import qualified System.Log.Logger as LOG import Text.Megaparsec.Pos import Web.HttpApiData (ToHttpApiData(..)) @@ -283,7 +281,6 @@ { _ioGetCurrentCallStack :: m [String] , _ioReadFile :: [Text] -> m (Either String T.Text) , _ioTraceEvent :: String -> m () - , _ioCallLua :: MVar Lua.LuaState -> Text -> [PValue] -> m (Either String PValue) } data InterpreterInstr a where @@ -320,9 +317,6 @@ ReadFile :: [Text] -> InterpreterInstr T.Text -- Tracing events TraceEvent :: String -> InterpreterInstr () - -- Calling Lua - CallLua :: MVar Lua.LuaState -> Text -> [PValue] -> InterpreterInstr PValue - -- | The main monad type InterpreterMonad = ProgramT InterpreterInstr (State InterpreterState) diff --git a/Puppet/Interpreter/Utils.hs b/Puppet/Interpreter/Utils.hs --- a/Puppet/Interpreter/Utils.hs +++ b/Puppet/Interpreter/Utils.hs @@ -133,13 +133,13 @@ -- Logging -- -warn :: (Monad m, MonadWriter InterpreterWriter m) => Doc -> m () +warn :: MonadWriter InterpreterWriter m => Doc -> m () warn d = tell [LOG.WARNING :!: d] -debug :: (Monad m, MonadWriter InterpreterWriter m) => Doc -> m () +debug :: MonadWriter InterpreterWriter m => Doc -> m () debug d = tell [LOG.DEBUG :!: d] -logWriter :: (Monad m, MonadWriter InterpreterWriter m) => LOG.Priority -> Doc -> m () +logWriter :: MonadWriter InterpreterWriter m => LOG.Priority -> Doc -> m () logWriter prio d = tell [prio :!: d] -- General -- diff --git a/Puppet/Plugins.hs b/Puppet/Plugins.hs deleted file mode 100644 --- a/Puppet/Plugins.hs +++ /dev/null @@ -1,165 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{-| This module is used for user plugins. It exports three functions that should -be easy to use: 'initLua', 'puppetFunc' and 'closeLua'. Right now it is used by -the "Puppet.Daemon" by initializing and destroying the Lua context for each -catalog computation. Obviously such plugins will be implemented in Lua. - -Users plugins are right now limited to custom functions. The user must put them -at the exact same place as their Ruby counterparts, except the extension must be -lua instead of rb. In the file, a function called by the same name that takes a -single argument must be defined. This argument will be an array made of all the -functions arguments. If the file doesn't parse, it will be silently ignored. - -Here are the things that must be kept in mind: - -* Lua doesn't have integers. All numbers are double. - -* All Lua associative arrays that are returned must have a "simple" type for all -the keys, as it will be converted to a string. Numbers will be directly -converted and other types will produce strange results. (currently this doesn't work at all, all associative arrays will be turned into lists, ignoring the keys) - -* This currently only works for functions that must return a value. They will -have no access to the manifests data. - --} -module Puppet.Plugins (initLua, initLuaMaster, puppetFunc, closeLua, getFiles) where - -import Puppet.PP -import qualified Scripting.Lua as Lua -import Control.Exception -import qualified Data.HashMap.Strict as HM -import System.IO -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.IO as T -import qualified Data.Vector as V -import Control.Concurrent -import Control.Monad.Except -import Control.Monad.Operational (singleton) -import Data.Scientific -import qualified Data.ByteString as BS -import Control.Lens -import Debug.Trace - -import Puppet.Interpreter.Types -import Puppet.Utils - -instance Lua.StackValue PValue - where - push l (PString s) = Lua.push l (T.encodeUtf8 s) - push l (PBoolean b) = Lua.push l b - push l (PResourceReference rr _) = Lua.push l (T.encodeUtf8 rr) - push l (PArray arr) = Lua.push l (V.toList arr) - push l (PHash m) = do - Lua.newtable l - forM_ (HM.toList m) $ \(k,v) -> do - Lua.push l (T.encodeUtf8 k) - Lua.push l v - Lua.settable l (-3) - push l (PUndef) = Lua.push l ("undefined" :: BS.ByteString) - push l (PNumber b) = Lua.push l (fromRational (toRational b) :: Double) - - peek l n = Lua.ltype l n >>= \case - Lua.TBOOLEAN -> fmap (fmap PBoolean) (Lua.peek l n) - Lua.TSTRING -> do - cnt <- Lua.peek l n - case fmap T.decodeUtf8' cnt of - Just (Right t) -> return (Just $ PString t) - _ -> return Nothing - Lua.TNUMBER -> fmap (fmap (PNumber . fromFloatDigits)) (Lua.peek l n :: IO (Maybe Double)) - Lua.TNIL -> return (Just PUndef) - Lua.TNONE -> return (Just PUndef) - Lua.TTABLE -> do - let go tidx m = do - isnext <- Lua.next l tidx - if isnext - then do - mk <- Lua.peek l (-2) - mv <- Lua.peek l (-1) - traceShow (mk, mv) $ return () - Lua.pop l 1 - case HM.insert <$> (mk >>= preview _Right . T.decodeUtf8') <*> mv <*> pure m of - Just m' -> go tidx m' - Nothing -> return Nothing - else return $ Just $ PHash m - ln <- Lua.objlen l n - if ln > 0 - then fmap (PArray . V.fromList) <$> Lua.tolist l n - else do - tidx <- if n >= 0 - then return n - else fmap (\top -> top + n + 1) (Lua.gettop l) - Lua.pushnil l - go tidx mempty - - _ -> return Nothing - - valuetype _ = Lua.TUSERDATA - -getDirContents :: T.Text -> IO [T.Text] -getDirContents x = fmap (filter (not . T.all (=='.'))) (getDirectoryContents x) - --- find files in subdirectories -checkForSubFiles :: T.Text -> T.Text -> IO [T.Text] -checkForSubFiles extension dir = - catch (fmap Right (getDirContents dir)) (\e -> return $ Left (e :: IOException)) >>= \case - Right o -> return ((map (\x -> dir <> "/" <> x) . filter (T.isSuffixOf extension)) o ) - Left _ -> return [] - --- Find files in the module directory that are in a module subdirectory and --- finish with a specific extension -getFiles :: T.Text -> T.Text -> T.Text -> IO [T.Text] -getFiles moduledir subdir extension = fmap concat $ - getDirContents moduledir - >>= mapM ( checkForSubFiles extension . (\x -> moduledir <> "/" <> x <> "/" <> subdir)) - -getLuaFiles :: T.Text -> IO [T.Text] -getLuaFiles moduledir = getFiles moduledir "lib/puppet/parser/luafunctions" ".lua" - -loadLuaFile :: Lua.LuaState -> T.Text -> IO [T.Text] -loadLuaFile l file = - Lua.loadfile l (T.unpack file) >>= \case - 0 -> Lua.call l 0 0 >> return [takeBaseName file] - _ -> do - T.hPutStrLn stderr ("Could not load file " <> file) - return [] -{-| Runs a puppet function in the 'CatalogMonad' monad. It takes a state, -function name and list of arguments. It returns a valid Puppet value. --} -puppetFunc :: (MonadThrowPos m, MonadIO m, MonadError Doc m, Monad m) => Lua.LuaState -> T.Text -> [PValue] -> m PValue -puppetFunc l fn args = - liftIO ( catch (fmap Right (Lua.callfunc l (T.unpack fn) args)) (\e -> return $ Left $ show (e :: SomeException)) ) >>= \case - Right x -> return x - Left y -> throwPosError (string y) - --- | Initializes the Lua state. The argument is the modules directory. Each --- subdirectory will be traversed for functions. --- The default location is @\/lib\/puppet\/parser\/functions@. -initLua :: T.Text -> IO (Lua.LuaState, [T.Text]) -initLua moduledir = do - funcfiles <- getLuaFiles moduledir - l <- Lua.newstate - Lua.openlibs l - luafuncs <- 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 = singleton (CallLua c fname args) - {- - 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 () -closeLua = Lua.close diff --git a/Puppet/Preferences.hs b/Puppet/Preferences.hs --- a/Puppet/Preferences.hs +++ b/Puppet/Preferences.hs @@ -26,7 +26,6 @@ import Puppet.Interpreter.Types import Puppet.NativeTypes import Puppet.NativeTypes.Helpers -import Puppet.Plugins import Puppet.Stdlib import Puppet.Paths import qualified Puppet.Puppetlabs as Puppetlabs diff --git a/Puppet/Utils.hs b/Puppet/Utils.hs --- a/Puppet/Utils.hs +++ b/Puppet/Utils.hs @@ -10,6 +10,7 @@ , loadYamlFile , scientific2text , text2Scientific + , getFiles , ifromList, ikeys, isingleton, ifromListWith, iunionWith, iinsertWith -- * re-export , module Data.Monoid @@ -27,6 +28,7 @@ import System.Posix.Directory.ByteString import qualified Data.Either.Strict as S import Data.Scientific +import Control.Exception import Control.Lens import Data.Aeson.Lens import qualified Data.Yaml as Y @@ -138,3 +140,17 @@ iunionWith :: (Hashable k, Eq k) => (v -> v -> v) -> HM.HashMap k v -> HM.HashMap k v -> HM.HashMap k v {-# INLINABLE iunionWith #-} iunionWith = HM.unionWith + +getFiles :: T.Text -> T.Text -> T.Text -> IO [T.Text] +getFiles moduledir subdir extension = fmap concat $ + getDirContents moduledir + >>= mapM ( checkForSubFiles extension . (\x -> moduledir <> "/" <> x <> "/" <> subdir)) + +checkForSubFiles :: T.Text -> T.Text -> IO [T.Text] +checkForSubFiles extension dir = + catch (fmap Right (getDirContents dir)) (\e -> return $ Left (e :: IOException)) >>= \case + Right o -> return ((map (\x -> dir <> "/" <> x) . filter (T.isSuffixOf extension)) o ) + Left _ -> return [] + +getDirContents :: T.Text -> IO [T.Text] +getDirContents x = fmap (filter (not . T.all (=='.'))) (getDirectoryContents x) diff --git a/PuppetDB/Remote.hs b/PuppetDB/Remote.hs --- a/PuppetDB/Remote.hs +++ b/PuppetDB/Remote.hs @@ -1,22 +1,20 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} module PuppetDB.Remote (pdbConnect) where -import Puppet.PP +import Control.Lens +import Control.Monad.Except +import Data.Proxy +import Data.Text (Text) +import Network.HTTP.Client (Manager) +import Servant.API +import Servant.Client -import Puppet.Interpreter.Types -import Network.HTTP.Client (Manager) -import Data.Text (Text) -import Control.Monad.Except -import Control.Monad.Trans.Except -import Control.Lens -import Servant.API -import Servant.Client -import Data.Aeson -import Data.Proxy +import Puppet.Interpreter.Types +import Puppet.PP type PDBAPIv3 = "nodes" :> QueryParam "query" (Query NodeField) :> Get '[JSON] [NodeInfo] :<|> "nodes" :> Capture "resourcename" Text :> "resources" :> QueryParam "query" (Query ResourceField) :> Get '[JSON] [Resource] @@ -50,5 +48,5 @@ prettyError :: ExceptT ServantError IO b -> ExceptT PrettyError IO b prettyError = mapExceptT (fmap (_Left %~ PrettyError . string. show)) - q1 :: FromJSON b => (Maybe a -> Manager -> BaseUrl -> ClientM b) -> a -> ExceptT PrettyError IO b + q1 :: (Maybe a -> Manager -> BaseUrl -> ClientM b) -> a -> ExceptT PrettyError IO b q1 f a = prettyError (f (Just a) mgr url) diff --git a/README.adoc b/README.adoc --- a/README.adoc +++ b/README.adoc @@ -1,7 +1,8 @@ = Language-puppet -image:https://travis-ci.org/bartavelle/language-puppet.svg?branch=master["Build Status", link="https://travis-ci.org/bartavelle/language-puppet"] image:https://img.shields.io/hackage/v/language-puppet.svg[link="http://hackage.haskell.org/package/language-puppet"] +image:https://www.stackage.org/package/language-puppet/badge/nightly[link="https://www.stackage.org/nightly/package/language-puppet"] +image:https://travis-ci.org/bartavelle/language-puppet.svg?branch=master["Build Status", link="https://travis-ci.org/bartavelle/language-puppet"] A library to work with Puppet manifests, test them and eventually replace everything ruby. @@ -18,7 +19,7 @@ stack install ``` -There are also http://lpuppet.banquise.net/download/[binary packages available] and https://registry.hub.docker.com/u/pierrer/puppetresources[a docker images]. +https://hub.docker.com/r/pierrer/language-puppet/[A docker image] is available. == Puppetresources @@ -162,4 +163,3 @@ * the deprecated `import` function is not supported (see https://github.com/bartavelle/language-puppet/issues/82[issue #82]) custom ruby functions:: -Currently the only way to support your custom ruby functions is to rewrite them in Lua. 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: 1.2 +version: 1.3 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/ @@ -79,7 +79,6 @@ , Puppet.NativeTypes.ZoneRecord , Puppet.Parser.Utils , Puppet.Paths - , Puppet.Plugins extensions: OverloadedStrings, BangPatterns ghc-options: -Wall -funbox-strict-fields -j1 -- ghc-prof-options: -auto-all -caf-all @@ -99,10 +98,9 @@ , formatting , hashable == 1.2.* , http-api-data == 0.2.* - , http-client == 0.4.* + , http-client >= 0.5 && < 0.6 , hruby >= 0.3.2 && < 0.4 , hslogger == 1.2.* - , hslua >= 0.4.1 && < 0.5 , hspec , lens >= 4.12 && < 5 , lens-aeson >= 1.0 @@ -117,8 +115,8 @@ , regex-pcre-builtin >= 0.94.4 , scientific >= 0.2 && < 0.4 , semigroups - , servant == 0.7.* - , servant-client == 0.7.* + , servant == 0.8.* + , servant-client == 0.8.* , split == 0.2.* , stm == 2.4.* , strict-base-types >= 0.3