module Puppet.DSL.Parser (
parse,
mparser,
exprparser
) where
import Puppet.DSL.Types
import Puppet.Utils
import Data.Char
import qualified Text.Parsec as TP
import Text.Parsec hiding (string)
import Text.Parsec.Text
import qualified Text.Parsec.Token as P
import Text.Parsec.Expr
import qualified Data.Map as Map
import Puppet.NativeTypes
import Control.Monad (when)
import qualified Data.Text as T
def = P.LanguageDef
{ P.commentStart = "/*"
, P.commentEnd = "*/"
, P.commentLine = "#"
, P.nestedComments = True
, P.identStart = letter
, P.identLetter = alphaNum <|> char '_'
, P.reservedNames = ["if", "else", "case", "elsif", "default", "import", "define", "class", "node", "inherits", "true", "false", "undef"]
, P.reservedOpNames= ["=>","=","+","-","/","*","+>","->","~>","!"]
, P.caseSensitive = True
, P.opStart = oneOf ":!#$%&*+./<=>?@\\^|-~"
, P.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~"
}
lexer = P.makeTokenParser def
parens = P.parens lexer
symbol = fmap T.pack . P.symbol lexer
reservedOp = P.reservedOp lexer
reserved = P.reserved lexer
whiteSpace = P.whiteSpace lexer
naturalOrFloat = P.naturalOrFloat lexer
string = fmap T.pack . TP.string
lowerFirstChar :: T.Text -> T.Text
lowerFirstChar "" = ""
lowerFirstChar x = T.cons (toLower (T.head x)) (T.tail x)
exprparser = buildExpressionParser table term <?> "expression"
table = [
[ Infix ( reservedOp "?" >> return ConditionalValue ) AssocLeft ]
, [ Prefix ( symbol "-" >> return NegOperation ) ]
, [ Prefix ( symbol "!" >> return NotOperation ) ]
, [ Infix ( reserved "in" >> return IsElementOperation ) AssocLeft ]
, [ Infix ( reservedOp "/" >> return DivOperation ) AssocLeft
, Infix ( reservedOp "*" >> return MultiplyOperation ) AssocLeft ]
, [ Infix ( reservedOp "+" >> return PlusOperation ) AssocLeft
, Infix ( reservedOp "-" >> return MinusOperation ) AssocLeft ]
, [ Infix ( reservedOp "<<" >> return ShiftLeftOperation ) AssocLeft
, Infix ( reservedOp ">>" >> return ShiftRightOperation ) AssocLeft ]
, [ Infix ( reservedOp "==" >> return EqualOperation ) AssocLeft
, Infix ( reservedOp "!=" >> return DifferentOperation ) AssocLeft ]
, [ Infix ( reservedOp ">" >> return AboveOperation ) AssocLeft
, Infix ( reservedOp ">=" >> return AboveEqualOperation ) AssocLeft
, Infix ( reservedOp "<=" >> return UnderEqualOperation ) AssocLeft
, Infix ( reservedOp "<" >> return UnderOperation ) AssocLeft ]
, [ Infix ( reserved "and" >> return AndOperation ) AssocLeft
, Infix ( reserved "or" >> return OrOperation ) AssocLeft ]
, [ Infix ( reservedOp "=~" >> return RegexpOperation ) AssocLeft
, Infix ( reservedOp "!~" >> return NotRegexpOperation ) AssocLeft ]
]
term = parens exprparser
<|> puppetInterpolableString
<|> puppetUndefined
<|> puppetRegexpExpr
<|> puppetVariableOrHashLookup
<|> puppetNumeric
<|> puppetArray
<|> puppetHash
<|> puppetBool
<|> try puppetResourceReference
<|> try puppetFunctionCall
<|> puppetLiteralValue
<?> "Expression terminal"
puppetBool = fmap (Value . PuppetBool) ((reserved "true" >> return True) <|> (reserved "false" >> return False))
hashRef = do { symbol "["
; e <- exprparser
; symbol "]"
; return e
}
puppetVariableOrHashLookup = do
v <- puppetVariable
whiteSpace
hashlist <- many hashRef
when (v == "string") $ unexpected "You are not allowed to name variables $string."
case hashlist of
[] -> return $ Value (VariableReference v)
_ -> return $ makeLookupOperation v hashlist
makeLookupOperation :: T.Text -> [Expression] -> Expression
makeLookupOperation _ [] = error "Error in makeLookupOperation: empty list"
makeLookupOperation name exprs = foldl LookupOperation (LookupOperation (Value (VariableReference name)) (head exprs)) (tail exprs)
identstring :: Parser T.Text
identstring = fmap T.pack $ many1 (alphaNum <|> char '_')
identifier :: Parser T.Text
identifier = do {
x <- identstring
; whiteSpace
; return x
}
puppetResourceReference = do { rtype <- puppetQualifiedReference
; symbol "["
; rnames <- exprparser `sepBy` symbol ","
; symbol "]"
; if length rnames == 1
then return $ Value (ResourceReference rtype (head rnames))
else return $ Value $ PuppetArray $ map (Value . ResourceReference rtype) rnames
}
puppetResourceOverride = do { pos <- getPosition
; rtype <- puppetQualifiedReference
; symbol "["
; rname <- exprparser `sepBy` symbol ","
; symbol "]"
; symbol "{"
; e <- puppetAssignment `sepEndBy` symbol ","
; symbol "}"
; return (map (\n -> ResourceOverride rtype n e pos) rname)
}
puppetInclude = do { pos <- getPosition
; try $ reserved "include"
; vs <- exprparser `sepBy` (symbol ",")
; return $ map (\v -> Include v pos) vs
}
puppetRequire = do { pos <- getPosition
; try $ reserved "require"
; v <- puppetLiteral `sepBy` (symbol ",")
; return $ map (\x -> Require x pos) v
}
puppetQualifiedName = do { optional (string "::")
; firstletter <- lower
; parts <- identstring `sepBy` (try $ string "::")
; whiteSpace
; return $ T.cons firstletter (T.intercalate "::" parts)
}
puppetQualifiedReference = do { optional (string "::")
; firstletter <- upper <?> "Uppercase letter for a reference"
; parts <- identstring `sepBy` (string "::")
; whiteSpace
; return $ T.cons (toLower firstletter) (T.intercalate "::" $ map lowerFirstChar parts)
}
puppetFunctionCall = do { funcname <- identifier
; symbol "("
; e <- exprparser `sepEndBy` (symbol ",")
; symbol ")"
; return $ Value (FunctionCall funcname e)
}
puppetArrayRaw = do { symbol "["
; e <- exprparser `sepEndBy` (symbol ",")
; symbol "]"
; return e
}
puppetArray = do { e <- puppetArrayRaw
; return $ Value (PuppetArray e)
}
puppetHash = do { symbol "{"
; e <- puppetAssignment `sepEndBy` (symbol ",")
; symbol "}"
; return $ Value (PuppetHash (Parameters e))
}
puppetAssignment = do { n <- exprparser
; symbol "=>"
; v <- exprparser
; return $ (n, v)
}
nodeDeclaration = do { pos <- getPosition
; try $ reserved "node"
; whiteSpace
; n <- puppetRegexp <|> puppetLiteral
; symbol "{"
; e <- many stmtparser
; symbol "}"
; return [ Node n (concat e) pos ]
}
puppetVariable :: Parser T.Text
puppetVariable = do
char '$'
choice
[ do { char '{' ; o <- many1 $ noneOf "}" ; char '}' ; return (T.pack o) }
, do { s <- option "" (string "::") ; o <- identstring `sepBy` (try $ string "::") ; return (s <> (T.intercalate "::" o)) }
]
variableAssignment = do
pos <- getPosition
varname <- puppetVariable
whiteSpace
symbol "="
e <- exprparser
when (varname == "string") $ unexpected "You are not allowed to name variables $string."
return [VariableAssignment varname e pos]
puppetLiteral :: Parser T.Text
puppetLiteral = doubleQuotedString
<|> singleQuotedString
<|> puppetQualifiedName
<|> identifier
puppetLiteralValue = do { v <- puppetLiteral
; return (Value (Literal v))
}
puppetRegexp :: Parser T.Text
puppetRegexp = do { char '/'
; v <- many ( do { char '\\' ; x <- anyChar; return ['\\', x] } <|> many1 (noneOf "/\\") )
; symbol "/"
; return $ T.pack $ concat v
}
puppetRegexpExpr = puppetRegexp >>= return . Value . PuppetRegexp
singleQuotedString = do { char '\''
; v <- many ( do { char '\\' ; x <- anyChar; if x=='\'' then return "'" else return ['\\',x] } <|> many1 (noneOf "'\\") )
; char '\''
; whiteSpace
; return $ T.pack $ concat v
}
doubleQuotedString = do { char '"'
; v <- option "" doubleQuotedStringContent
; char '"'
; whiteSpace
; return v
}
puppetInterpolableString = do { char '"'
; v <- many (
try ( do { x <- puppetVariable
; when (x == "string") $ unexpected "You are not allowed to name variables $string."
; return $ VariableReference x
} )
<|> do { x <- doubleQuotedStringContent
; return $ Literal x
}
<|> do { char '$'
; return $ Literal "$"
}
<?> "Interpolable string content"
)
; char '"'
; whiteSpace
; return $ Value (Interpolable v)
}
doubleQuotedStringContent = do { x <- many1 (do { char '\\' ; x <- anyChar; return [stringEscape x] } <|> many1 (noneOf "\"\\$") )
; return $ T.pack $ concat x
}
stringEscape 'n' = '\n'
stringEscape 't' = '\t'
stringEscape 'r' = '\r'
stringEscape '"' = '"'
stringEscape '\\' = '\\'
stringEscape '$' = '$'
stringEscape x = error $ "unknown escape pattern \\" ++ [x]
puppetUndefined = do
try $ string "undef"
whiteSpace
return $ Value $ Undefined
puppetNumeric = do { v <- naturalOrFloat
; return (case v of
Left x -> (Value . Integer) x
Right x -> (Value . Double) x
)
}
puppetResourceGroup = do
(virtcount, v) <- try ( do {
virtcount <- many (char '@')
; v <- puppetQualifiedName
; symbol "{"
; return (virtcount, v)
} )
x <- (resourceArrayDeclaration <|> resourceDeclaration) `sepEndBy` (symbol ";" <|> symbol ",")
symbol "}"
case virtcount of
"" -> return $ map (\(rname, rvalues, pos) -> (Resource v rname rvalues Normal pos)) (concat x)
"@" -> return $ map (\(rname, rvalues, pos) -> (Resource v rname rvalues Virtual pos)) (concat x)
"@@" -> return $ map (\(rname, rvalues, pos) -> (Resource v rname rvalues Exported pos)) (concat x)
_ -> unexpected "Too many @'s"
puppetResourceCollection = do { pos <- getPosition
; rtype <- puppetQualifiedReference
; chev <- many1 (char '<')
; symbol "|"
; e <- option BTrue exprparser
; symbol "|"
; many1 (char '>')
; whiteSpace
; overrides <- option [] (do { symbol "{"
; ne <- puppetAssignment `sepEndBy` (symbol ",")
; symbol "}"
; return ne
})
; case chev of
"<" -> return [ VirtualResourceCollection rtype e overrides pos ]
"<<" -> return [ ResourceCollection rtype e overrides pos ]
_ -> error $ "Invalid resource collection syntax at " ++ (show pos)
}
resourceArrayDeclaration = do { pos <- getPosition
; v <- puppetArrayRaw
; symbol ":"
; x <- puppetAssignment `sepEndBy` symbol ","
; return $ map (\nm -> (nm, x, pos)) v
}
resourceDeclaration = do { pos <- getPosition
; v <- (puppetVariableOrHashLookup <|> puppetInterpolableString <|> puppetLiteralValue )
; whiteSpace
; symbol ":"
; x <- puppetAssignment `sepEndBy` symbol ","
; return [(v, x, pos)]
}
puppetResourceDefaults = do { pos <- getPosition
; rtype <- puppetQualifiedReference
; symbol "{"
; e <- puppetAssignment `sepEndBy` symbol ","
; symbol "}"
; return [ResourceDefault rtype e pos]
}
puppetClassParameter = do { varname <- puppetVariable
; whiteSpace
; defaultvalue <- optionMaybe ( do { symbol "="
; e <- exprparser
; return e
} )
; when (varname == "string") $ unexpected "You are not allowed to name variables $string."
; return (varname, defaultvalue)
}
puppetClassParameters = do { symbol "("
; pmt <- puppetClassParameter `sepBy` symbol ","
; symbol ")"
; return pmt
}
puppetClassDefinition = do { pos <- getPosition
; try $ reserved "class"
; cname <- puppetQualifiedName
; params <- option [] puppetClassParameters
; cparent <- optionMaybe ( do { string "inherits"; whiteSpace ; p <- puppetQualifiedName; return p } )
; symbol "{"
; st <- many stmtparser
; symbol "}"
; return [ClassDeclaration cname cparent params (concat st) pos]
}
puppetDefine = do
pos <- getPosition
try $ reserved "define"
cname <- puppetQualifiedName
params <- option [] puppetClassParameters
symbol "{"
st <- many stmtparser
symbol "}"
case Map.lookup cname baseNativeTypes of
Just _ -> unexpected "Can't use a native type name for a define."
Nothing -> return [DefineDeclaration cname params (concat st) pos]
puppetIfStyleCondition = do { cond <- exprparser <?> "Conditional expression"
; symbol "{"
; e <- many stmtparser
; symbol "}"
; return (cond, concat e)
}
puppetElseIfCondition = do { reservedOp "elsif"
; whiteSpace
; out <- puppetIfStyleCondition
; return out
}
puppetElseCondition = do { reservedOp "else"
; whiteSpace
; symbol "{"
; e <- many stmtparser
; symbol "}"
; return $ concat e
}
puppetIfCondition = do { pos <- getPosition
; reserved "if"
; whiteSpace
; maincond <- puppetIfStyleCondition
; others <- option [] (many puppetElseIfCondition)
; elsec <- option [] puppetElseCondition
; return [ConditionalStatement ([maincond] ++ others ++ [(BTrue, elsec)]) pos]
}
puppetCase = do {
compares <- exprparser `sepBy` symbol ","
; symbol ":"
; symbol "{"
; st <- many stmtparser
; symbol "}"
; return ( compares, concat st )
}
puppetRegexpCase = do {
expression <- puppetRegexp
; symbol ":"
; symbol "{"
; st <- many stmtparser
; symbol "}"
; return ( [Value (PuppetRegexp expression)], concat st )
}
defaultCase = do {
string "default"
; symbol ":"
; symbol "{"
; st <- many stmtparser
; symbol "}"
; return ( [BTrue], concat st )
}
condsToExpression :: Expression -> ([Expression], [Statement]) -> [(Expression, [Statement])]
condsToExpression e (exprs, stmts) = map (\x -> condToExpression e (x, stmts)) exprs
condToExpression :: Expression -> (Expression, [Statement]) -> (Expression, [Statement])
condToExpression _ (BTrue, stmts) = (BTrue, stmts)
condToExpression e (Value (PuppetRegexp regexp), stmts) = (RegexpOperation e (Value (PuppetRegexp regexp)), stmts)
condToExpression e (cnd, stmts) = (EqualOperation e cnd, stmts)
puppetCaseCondition = do { pos <- getPosition
; reservedOp "case"
; whiteSpace
; expr1 <- exprparser
; symbol "{"
; condlist <- many1 (puppetRegexpCase <|> try defaultCase <|> puppetCase)
; symbol "}"
; return $ [ConditionalStatement (concat (map (\x -> condsToExpression expr1 x) condlist)) pos]
}
puppetMainFunctionCall = do { pos <- getPosition
; name <- identifier
; whiteSpace
; hasParens <- optionMaybe $ symbol "("
; refs <- exprparser `sepEndBy` symbol ","
; case hasParens of
Just _ -> symbol ")"
_ -> return ""
; return [MainFunctionCall name refs pos]
}
puppetChains = do { pos <- getPosition
; refs <- try (puppetResourceReference `sepBy1` symbol "->")
; let refToPair (Value (ResourceReference rtype name)) = (rtype, name)
refToPair x = error $ "Could not run refToPair on " ++ show x
; let pairs = map refToPair refs
; let refpairs | null pairs = []
| otherwise = zip pairs (tail pairs)
; return $ map (\((n1,v1),(n2,v2)) -> DependenceChain (n1,v1) (n2,v2) pos) refpairs
}
puppetImport = do { pos <- getPosition
; try $ reserved "import"
; pattern <- puppetLiteral
; return [Import pattern pos]
}
stmtparser = variableAssignment
<|> puppetInclude
<|> puppetRequire
<|> puppetImport
<|> nodeDeclaration
<|> puppetDefine
<|> puppetIfCondition
<|> puppetCaseCondition
<|> puppetResourceGroup
<|> try (puppetResourceDefaults)
<|> try (puppetResourceOverride)
<|> try (puppetResourceCollection)
<|> puppetClassDefinition
<|> puppetChains
<|> puppetMainFunctionCall
<?> "Statement"
mparser :: Parser [Statement]
mparser = do {
whiteSpace
; result <- many stmtparser
; eof
; return $ concat result
}