module Puppet.Interpreter.Types where
import Puppet.DSL.Types hiding (Value)
import Puppet.Utils
import qualified PuppetDB.Query as PDB
import qualified Scripting.Lua as Lua
import Text.Parsec.Pos
import Control.Monad.State
import Control.Monad.Error
import qualified Data.Map as Map
import qualified Data.Set as Set
import GHC.Exts
import Data.Aeson
import qualified Data.HashMap.Strict as HM
import Control.Applicative
import qualified Data.Text as T
import Data.Attoparsec.Number
import qualified Text.Parsec.Pos as TPP
import qualified Data.Vector as V
import Control.Arrow ( (***) )
import Data.Maybe (fromMaybe)
type PuppetTypeName = T.Text
type PuppetTypeValidate = RResource -> Either String RResource
data PuppetTypeMethods = PuppetTypeMethods {
puppetvalidate :: PuppetTypeValidate,
puppetfields :: Set.Set T.Text
}
type Catalog =[CResource]
type Facts = Map.Map T.Text ResolvedValue
data LinkType = RNotify | RRequire | RBefore | RSubscribe deriving(Show, Ord, Eq)
type LinkInfo = (LinkType, RelUpdateType, SourcePos, [[ScopeName]])
data ResolvedValue
= ResolvedString !T.Text
| ResolvedRegexp !T.Text
| ResolvedInt !Integer
| ResolvedDouble !Double
| ResolvedBool !Bool
| ResolvedRReference !T.Text !ResolvedValue
| ResolvedArray ![ResolvedValue]
| ResolvedHash ![(T.Text, ResolvedValue)]
| ResolvedUndefined
deriving(Show, Eq, Ord)
instance IsString ResolvedValue where
fromString = ResolvedString . fromString
instance ToJSON ResolvedValue where
toJSON (ResolvedString s) = String s
toJSON (ResolvedRegexp r) = String r
toJSON (ResolvedInt i) = Number (I i)
toJSON (ResolvedDouble d) = Number (D d)
toJSON (ResolvedBool b) = Bool b
toJSON (ResolvedRReference _ _) = Null
toJSON (ResolvedArray rr) = toJSON rr
toJSON (ResolvedHash hh) = object (map (uncurry (.=)) hh)
toJSON (ResolvedUndefined) = Null
parseResourceReference :: T.Text -> Maybe ResolvedValue
parseResourceReference instr = case T.splitOn "[" instr of
[restype, renamee] -> if T.last renamee == ']'
then Just (ResolvedRReference (T.toLower restype) (ResolvedString (T.init renamee)))
else Nothing
_ -> Nothing
instance FromJSON ResolvedValue where
parseJSON Null = return ResolvedUndefined
parseJSON (Number x) = return $ case x of
(I n) -> ResolvedInt n
(D d) -> ResolvedDouble d
parseJSON (String s) = case parseResourceReference s of
Just x -> return x
Nothing -> return $ ResolvedString s
parseJSON (Array a) = fmap ResolvedArray (mapM parseJSON (V.toList a))
parseJSON (Object o) = fmap ResolvedHash (mapM (\(a,b) -> do {
b' <- parseJSON b ;
return (a,b') }
) (HM.toList o))
parseJSON (Bool b) = return $ ResolvedBool b
type GeneralValue = Either Expression ResolvedValue
type GeneralString = Either Expression T.Text
data CResource = CResource {
crid :: !Int,
crname :: !GeneralString,
crtype :: !T.Text,
crparams :: !(Map.Map GeneralString GeneralValue),
crvirtuality :: !Virtuality,
crscope :: ![[ScopeName]],
pos :: !SourcePos
} deriving(Show)
instance FromJSON CResource where
parseJSON (Object o) = do
utitle <- o .: "title"
params <- o .: "parameters"
sourcefile <- o .: "sourcefile"
sourceline <- o .: "sourceline"
certname <- o .: "certname"
scope <- o .:? "scope"
let _ = params :: HM.HashMap T.Text ResolvedValue
parameters = Map.fromList $ map (Right *** Right) $ ("EXPORTEDSOURCE", ResolvedString certname) : HM.toList params :: Map.Map GeneralString GeneralValue
position = TPP.newPos (T.unpack sourcefile ++ "(host: " ++ T.unpack certname ++ ")") sourceline 1
mscope = fromMaybe [["json"]] scope
CResource <$> pure 0
<*> pure (Right utitle)
<*> fmap T.toLower (o .: "type")
<*> pure parameters
<*> pure Normal
<*> pure mscope
<*> pure position
parseJSON _ = mzero
json2puppet :: (FromJSON a) => Value -> Either String a
json2puppet x = case fromJSON x of
Error s -> Left s
Success a -> Right a
type ResIdentifier = (T.Text, T.Text)
type Relation = (LinkType, ResIdentifier)
data RResource = RResource {
rrid :: !Int,
rrname :: !T.Text,
rrtype :: !T.Text,
rrparams :: !(Map.Map T.Text ResolvedValue),
rrelations :: ![Relation],
rrscope :: ![[ScopeName]],
rrpos :: !SourcePos
} deriving(Show, Ord, Eq)
rr2json :: T.Text -> RResource -> Value
rr2json hostname rr =
let sourcefile = sourceName (rrpos rr)
sourceline = sourceLine (rrpos rr)
in object [ "title" .= rrname rr
, "sourcefile" .= sourcefile
, "sourceline" .= sourceline
, "type" .= capitalizeResType (rrtype rr)
, "certname" .= hostname
, "scope" .= rrscope rr
, "parameters" .= rrparams rr
]
type FinalCatalog = Map.Map ResIdentifier RResource
type ScopeName = T.Text
data RelUpdateType = UNormal | UOverride | UDefault | UPlus deriving (Show, Ord, Eq)
data ResDefaults = RDefaults T.Text (Map.Map GeneralString GeneralValue) SourcePos
| ROverride T.Text GeneralString (Map.Map GeneralString GeneralValue) SourcePos
deriving (Show, Ord, Eq)
data ScopeState = ScopeState {
curScope :: ![[ScopeName]],
curVariables :: !(Map.Map T.Text (GeneralValue, SourcePos)),
curClasses :: !(Map.Map T.Text SourcePos),
curDefaults :: !(Map.Map [ScopeName] [ResDefaults]),
curResId :: !Int,
curPos :: !SourcePos,
nestedtoplevels :: !(Map.Map (TopLevelType, T.Text) Statement),
getStatementsFunction :: TopLevelType -> T.Text -> IO (Either String Statement),
getWarnings :: ![T.Text],
curCollect :: ![(CResource -> CatalogMonad Bool, Map.Map GeneralString GeneralValue, Maybe PDB.Query)],
unresolvedRels :: ![([(LinkType, GeneralValue, GeneralValue)], (T.Text, GeneralString), RelUpdateType, SourcePos, [[ScopeName]])],
computeTemplateFunction :: Either T.Text T.Text -> T.Text -> Map.Map T.Text GeneralValue -> IO (Either String T.Text),
puppetDBFunction :: T.Text -> PDB.Query -> IO (Either String Value),
luaState :: Maybe Lua.LuaState,
userFunctions :: !(Set.Set T.Text),
nativeTypes :: !(Map.Map PuppetTypeName PuppetTypeMethods),
definedResources :: !(Map.Map ResIdentifier SourcePos),
currentDependencyStack :: [ResIdentifier]
}
type CatalogMonad = ErrorT T.Text (StateT ScopeState IO)
instance Error T.Text where
noMsg = ""
strMsg = T.pack
type EdgeMap = Map.Map (ResIdentifier, ResIdentifier) LinkInfo
generalizeValueE :: Expression -> GeneralValue
generalizeValueE = Left
generalizeValueR :: ResolvedValue -> GeneralValue
generalizeValueR = Right
generalizeStringE :: Expression -> GeneralString
generalizeStringE = Left
generalizeStringS :: T.Text -> GeneralString
generalizeStringS = Right
metaparameters :: Set.Set T.Text
metaparameters = Set.fromList ["tag","stage","name","title","alias","audit","check","loglevel","noop","schedule", "EXPORTEDSOURCE", "require", "before", "register", "notify"] :: Set.Set T.Text
getPos = liftM curPos get
modifyScope f sc = sc { curScope = f $ curScope sc }
modifyDeps f sc = sc { currentDependencyStack = f $ currentDependencyStack sc }
modifyVariables f sc = sc { curVariables = f $ curVariables sc }
modifyClasses f sc = sc { curClasses = f $ curClasses sc }
incrementResId sc = sc { curResId = curResId sc + 1 }
setStatePos npos sc = sc { curPos = npos }
pushWarning t sc = sc { getWarnings = getWarnings sc ++ [t] }
pushCollect r sc = sc { curCollect = r : curCollect sc }
pushUnresRel r sc = sc { unresolvedRels = r : unresolvedRels sc }
addDefinedResource r p = modify (\st -> st { definedResources = Map.insert r p (definedResources st) } )
saveVariables vars = modify (\st -> st { curVariables = vars })
showScope :: [[ScopeName]] -> T.Text
showScope = tshow . reverse . concatMap (take 1)
throwPosError :: T.Text -> CatalogMonad a
throwPosError msg = do
p <- getPos
st <- fmap (map T.pack) (liftIO currentCallStack)
throwError (msg <> " at " <> tshow p <> "\n\t" <> T.intercalate "\n\t" st)
addAlias :: T.Text -> RResource -> Either String RResource
addAlias value res = case Map.lookup "alias" (rrparams res) of
Nothing -> Right $! insertparam res "alias" (ResolvedArray [ResolvedString value])
Just a@(ResolvedString _) -> Right $! insertparam res "alias" (ResolvedArray [a,ResolvedString value])
Just (ResolvedArray ar) -> Right $! insertparam res "alias" (ResolvedArray (ResolvedString value : ar))
Just x -> Left ("Aliases should be strings or arrays of strings, not " ++ show x)
insertparam :: RResource -> T.Text -> ResolvedValue -> RResource
insertparam res param value = res { rrparams = Map.insert param value (rrparams res) }