diff options
author | Yorhel <git@yorhel.nl> | 2018-01-08 21:28:24 +0100 |
---|---|---|
committer | Yorhel <git@yorhel.nl> | 2018-01-08 21:28:24 +0100 |
commit | eb683aa0df23aae925cfa045e808f27749bfb747 (patch) | |
tree | bf66b27d167b142bf611bfb586c1719e68abc3ca | |
parent | d6c6a50fc197840ef32043083ccaf78940273390 (diff) |
Mostly untested first attempt at preprocessing
-rw-r--r-- | Main.hs | 110 | ||||
-rw-r--r-- | nginx-confgen.cabal | 9 | ||||
-rw-r--r-- | test.conf | 13 |
3 files changed, 111 insertions, 21 deletions
@@ -1,26 +1,31 @@ +{-# LANGUAGE TupleSections #-} module Main where -import Control.Applicative (empty) -import Control.Monad (void) -import Data.Void -import Data.Char (isSpace) -import Data.List (intercalate) -import Text.Megaparsec -import Text.Megaparsec.Char +import Control.Applicative (empty) +import Control.Monad (void,foldM) +import Data.Char (isSpace) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as M +import Data.List (intercalate) +import Data.Void +import Text.Megaparsec +import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L +-- Config file AST + type Conf = [Directive] data Directive = Directive String [Arg] (Maybe Conf) - | BlockRef String + | BlockRef String -- extension deriving Show data Arg = ArgString [ArgComponent] - | ArgArray String - | ArgBlock String + | ArgArray String -- extension + | ArgBlock String -- extension deriving Show data ArgComponent @@ -101,8 +106,9 @@ parser = between ws eof $ many stmt + fmt :: Conf -> String -fmt content = intercalate "\n" $ concatMap dir content +fmt conf = intercalate "\n" $ concatMap dir conf where indent = map (" "++) escape q = concatMap (\c -> if c == q then ['\\', c] else [c]) @@ -135,8 +141,88 @@ fmt content = intercalate "\n" $ concatMap dir content + +data PState = PState + { stVars :: HashMap String [ArgComponent] + , stMacros :: HashMap String ([Arg], Conf) + , stArgs :: HashMap String [ArgComponent] -- shadows stVars + -- Max 1, but Prelude's 'lookup' isn't generic to work on Maybe, so this'll do + , stArray :: [(String, [Arg])] + , stBlock :: [(String, Conf)] + } + +-- TODO: Add source locations to these errors +data Error + = MacroNoName + | MacroNoBlock String + | UnknownBlockRef String + | BlockArg String + | UnknownArray String + +instance Show Error where + show MacroNoName = "Macro directive missing or invalid name argument, syntax is \"macro name ..args.. { }\"" + show (MacroNoBlock n) = "Macro '"++n++"' has no block argument, syntax is \"macro name ..args.. { }\"" + show (UnknownBlockRef n) = "Reference to unknown block variable '&"++n++"'" + show (BlockArg n) = "Block variable '&"++n++"' may not be used as argument to a directive" + show (UnknownArray n) = "Reference to unknown variable '&'"++n++"'" + + +proc :: Conf -> Either Error Conf +proc globalconf = pconf (PState mempty mempty mempty mempty mempty) globalconf + where + -- Kind of like concatMap with error handling and internal state + proc' :: (PState -> a -> Either Error (PState, [a])) -> PState -> [a] -> Either Error [a] + proc' f st a = snd <$> foldM p (st, []) a + where p (st', a') i = (fmap . fmap) (a'++) (f st' i) + + pconf = proc' stmt -- Process a Conf + pargs = proc' interp -- Process [Arg] + + interp :: PState -> Arg -> Either Error (PState, [Arg]) + interp st a = (st,) <$> case a of + ArgBlock n -> Left (BlockArg n) + ArgArray n -> + case lookup n (stArray st) of + Nothing -> Left (UnknownArray n) + Just l -> Right l -- No interpolation necessary I think, should have been processed at call site + ArgString l -> Right $ (:[]) $ ArgString $ concatMap f l + where + f (Variable n) = + case (M.lookup n (stArgs st), M.lookup n (stVars st)) of + (Just v, _) -> v + (_, Just v) -> v + _ -> [Variable n] -- Unknown variables are assumed to be run-time variables, so are passed through + f v = [v] + + -- directives + stmt :: PState -> Directive -> Either Error (PState, [Directive]) + + stmt st (BlockRef n) = + case lookup n (stBlock st) of + Nothing -> Left (UnknownBlockRef n) + Just b -> Right (st, b) -- All further processing on b should already have been done at call site + + stmt st (Directive "macro" a b) = + case (a,b) of + (ArgString [Literal n]:_ , Nothing) -> Left (MacroNoBlock n) + (ArgString [Literal n]:a', Just b') -> Right (st { stMacros = M.insert n (a', b') (stMacros st) }, []) -- TODO: variable & macro substitution in b' + (_ , _ ) -> Left MacroNoName + + stmt st (Directive name a b) = + case M.lookup name (stMacros st) of + Nothing -> do + a' <- pargs st a + b' <- mapM (pconf st) b + Right (st, [Directive name a' b']) + Just _ -> fail "Unimplemented" -- TODO + + + + main :: IO () main = interact $ \s -> case parse parser "-" s of Left e -> parseErrorPretty e - Right r -> fmt r ++ "\n" + Right r -> case proc r of + Left e -> show e ++ "\n" + Right r' -> fmt r' ++ "\n" diff --git a/nginx-confgen.cabal b/nginx-confgen.cabal index f9bebbf..d36d317 100644 --- a/nginx-confgen.cabal +++ b/nginx-confgen.cabal @@ -18,12 +18,5 @@ executable nginx-confgen main-is: Main.hs default-language: Haskell2010 build-depends: base - , bytestring - --, containers - --, directory - --, filepath , megaparsec - --, mtl - --, optparse-applicative - --, pcre-light - , text + , unordered-containers @@ -7,18 +7,29 @@ events { } +pre_set $name 1; # Set a variable + +pre_if something { + pre_set $var 2; + # Not visible outside of this pre_if block... hmmmm. +} + # Macro <name> <arg1> <arg2> .. <contents> # Arguments can be a: # $var -> scalar argument # @var -> array argument, can only be passed to other directives # &var -> block argument, must be the last argument, if present macro server_https $name @alias &block { + # $name here shadows the global $name + + set $something 2; + # Anything can go inside the macro contents server { listen 0.0.0.0:80 tls; server_name $name @alias; cert_something "/etc/nginx/certs/$name.crt"; - █ # expands to the block argument + █ # expands to the block argument, inside this block, $name is the global name again and $something is not available } } |