{-# LANGUAGE TupleSections #-}
module Main where

import           Control.Applicative (empty)
import           Control.Exception.Base (throwIO,Exception)
import           Control.Monad (when,void,foldM,join,filterM)
import qualified Data.Array as A
import           Data.Char (isSpace)
import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as M
import           Data.Maybe (isJust)
import           Data.Semigroup ((<>))
import           Data.Void
import           Options.Applicative hiding (Parser,  ParseError)
import           System.Directory
import           System.FilePath
import           System.IO (hPutStrLn,stderr)
import           System.IO.Error (tryIOError)
import           System.Process
import           Text.Megaparsec hiding (option,hidden)
import           Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import qualified Text.Regex.TDFA as R


-- Config file AST

type Conf = [Directive]

data Directive
  = Directive String [Arg] (Maybe Conf)
  | BlockRef String -- extension
  deriving Show

data Arg
  = ArgString String -- Retains any quoting and escape sequences
  | ArgArray String -- extension
  | ArgBlock String -- extension
  deriving Show



type Parser = Parsec Void String

-- Name of a directive or variable.
-- I've no clue what the actual nginx parsing rules are.
identifier :: Parser String
identifier = (:)
  <$> letterChar
  <*> many (alphaNumChar <|> char '_')

isIdentifier :: String -> Bool
isIdentifier n = isJust $ parseMaybe identifier n

parser :: Parser Conf
parser = between ws eof $ many stmt
  where
  -- Whitespace and comments
  ws :: Parser ()
  ws = L.space (void spaceChar) (L.skipLineComment "#") empty
  lexeme :: Parser a -> Parser a
  lexeme = L.lexeme ws
  symbol :: String -> Parser ()
  symbol s = void $ L.symbol ws s

  blockvar, arrayvar :: Parser String
  blockvar = lexeme (char '&' >> identifier)
  arrayvar = lexeme (char '@' >> identifier)

  arg :: Parser Arg
  arg = ArgArray  <$> arrayvar
    <|> ArgBlock  <$> blockvar
    <|> ArgString <$> lexeme fstr
    <?> "argument"
    where
    -- My understanding from reading ngx_conf_file.c: Single/double quoted and
    -- unquoted strings all work the same way. Backslash escapes everything,
    -- space is not allowed in unquoted strings. Variable interpolation is
    -- allowed in all cases, but whether they are resolved depends on the
    -- directive.  (Which means that "${v}" and "$v" are not equivalent if the
    -- directive does not resolve variables)
    fstr = qstr '"'
       <|> qstr '\''
       <|> join <$> (some (lit (\c -> not (isSpace c) && c /= '{' && c /= ';')))

    qstr c = between (char c) (char c) $ do
      s <- join <$> many (lit (/=c))
      return (c:s ++ [c])

    lit :: (Char -> Bool) -> Parser String
    lit f = (char '\\' >> anyChar >>= \c -> return $ '\\':[c])
        <|> some (satisfy (\c -> f c && c /= '\\'))

  stmt :: Parser Directive
  stmt = blockref <|> directive <?> "directive"
    where
    block :: Parser [Directive]
    block =
      let close = symbol "}" >> (optional $ symbol ";")
      in between (symbol "{") close $ many stmt

    directive = Directive
      -- A "proper" directive would start with an identifier, but some modules
      -- (e.g. http_core's 'types' directive) have special syntax. So let's
      -- just allow any unquoted string that doesn't interfere with the rest of
      -- the syntax.
      <$> lexeme (some $ satisfy $ \c -> not (isSpace c) && c /= '\\' && c /= '$' && c /= '{' && c /= '}' && c /= ';')
      <*> many arg
      <*> (   Just    <$> block
          <|> Nothing <$  symbol ";")

    blockref = BlockRef <$> blockvar <* symbol ";"


-- Utilify function to selectively unescape some escape sequences
unescape' :: (Char -> Bool) -> String -> String
unescape' h ('\\':c:xs) = if h c then c : unescape' h xs else '\\' : c : unescape' h xs
unescape' h (x:xs) = x : unescape' h xs
unescape' _ [] = []

-- Turns a string argument from the AST into a fully unescaped Haskell string.
-- (Yes, argument strings ought to have their own type to make it clear when
-- we're dealing with quoted argument strings or with plain Haskell strings,
-- but this stringly-typed hack will do for now)
unescape :: String -> String
unescape s = unescape' (const True) $ case s of
  '"' :xs -> init xs
  '\'':xs -> init xs
  xs      -> xs



fmt :: Conf -> String
fmt conf = concatMap (++"\n") $ concatMap dir conf
  where
  indent = map ("    "++)

  dir :: Directive -> [String]
  dir (Directive n a b) =
    let (suffix, b') = block b
    in [n ++ fmtArgs a ++ suffix] ++ b'
  dir (BlockRef n) = ['&' : n ++ ";"]

  block :: Maybe [Directive] -> (String, [String])
  block Nothing = (";", [])
  block (Just l) = (" {", (indent $ concatMap dir l) ++ ["}"]);

fmtArgs :: [Arg] -> String
fmtArgs = concatMap ((' ':).arg)
  where
  arg (ArgString s) = s
  arg (ArgArray n) = '@' : n
  arg (ArgBlock n) = '&' : n




-- TODO: Add source locations to these errors
data Error
  = MacroNoName
  | MacroNoBlock String
  | UnknownBlockRef String
  | BlockArg String
  | UnknownArray String
  | MacroDefBlock String String
  | MacroDefArray String String
  | MacroDefVar String
  | MacroNotEnoughArgs String
  | MacroTooManyArgs String
  | MacroNoNeedsBlock String
  | MacroNeedsBlock String
  | IncludeArg
  | IncludeNotFound String
  | IncludeParse (ParseError (Token String) Void)
  | IncludeRecurse
  | SetArg
  | ExecArg
  | WarnArg
  | IfNeedsBlock
  | IfUnknown
  | IfInvalidArg
  | InvalidRegex 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++"'"
  show (MacroDefBlock n a) = "Block argument '&"++a++"' must be the last in macro definition of '"++n++"'"
  show (MacroDefArray n a) = "Array argument '@"++a++"' must be last or before block argument in macro definition of '"++n++"'"
  show (MacroDefVar n) = "Arguments to macro definition of '"++n++"' can only contain variables"
  show (MacroNotEnoughArgs n) = "Not enough arguments given to macro '"++n++"'"
  show (MacroTooManyArgs n) = "Too many arguments given to macro '"++n++"'"
  show (MacroNoNeedsBlock n) = "Macro '"++n++"' does not accept a block argument"
  show (MacroNeedsBlock n) = "Macro '"++n++"' requires a block argument, but none given"
  show IncludeArg = "Invalid argument(s) to 'pre_include'"
  show (IncludeNotFound f) = "Can't find include file '"++f++"'"
  show (IncludeParse e) = parseErrorPretty e
  show IncludeRecurse = "Recursion depth exceeded with 'pre_include'"
  show SetArg = "Invalid argument(s) to 'pre_set'"
  show ExecArg = "Invalid argument(s) to 'pre_exec'"
  show WarnArg = "Invalid argument(s) to 'pre_warn'"
  show IfNeedsBlock = "'pre_if' directive requires a block argument"
  show IfUnknown = "Unknown argument or operator in 'pre_if' directive"
  show IfInvalidArg = "Invalid &block or @array argument to 'pre_if'"
  show (InvalidRegex s) = "Invalid regular expression in pre_if: '"++s++"'"

instance Exception Error




data Macro = Macro
  { mName   :: String
  , mState  :: PState -- the state in which this macro was defined
  , mScalar :: [String]
  , mArray  :: Maybe String
  , mBlock  :: Maybe String
  , mCode   :: Conf
  }


macroDef :: PState -> String -> [Arg] -> Conf -> IO PState
macroDef st name arg code = do
  when (not $ isIdentifier name) $ throwIO MacroNoName
  case reverse arg of
    (ArgBlock b):(ArgArray a):xs -> m xs (Just a) (Just b)
    (ArgBlock b):xs              -> m xs Nothing  (Just b)
    (ArgArray a):xs              -> m xs (Just a) Nothing
    xs                           -> m xs Nothing  Nothing
  where
  f (ArgBlock v)        = throwIO (MacroDefBlock name v)
  f (ArgArray v)        = throwIO (MacroDefArray name v)
  f (ArgString ('$':v)) = if isIdentifier v then return v else throwIO (MacroDefVar name)
  f _                   = throwIO (MacroDefVar name)
  m rscalars a block = do
    scalars <- mapM f $ reverse rscalars
    let macro = Macro name st scalars a block code
    return (st { stMacros = M.insert name macro (stMacros st) })


macroExpand :: Macro -> [Arg] -> Maybe Conf -> IO [Directive]
macroExpand m iargs iblock = do
  (args, leftover) <- genargs mempty (mScalar m) iargs
  arr <- case (leftover, mArray m) of
    (a,  Just b)  -> return [(b, a)]
    ([], Nothing) -> return []
    _             -> throwIO (MacroTooManyArgs (mName m))
  block <- case (iblock, mBlock m) of
    (Just a,  Just b)  -> return [(b, a)]
    (Nothing, Nothing) -> return []
    (Just _,  Nothing) -> throwIO (MacroNoNeedsBlock (mName m))
    (Nothing, Just _)  -> throwIO (MacroNeedsBlock (mName m))
  let nst = (mState m) { stArgs = args, stArray = arr, stBlock = block }
  procConf' nst (mCode m)
  where
  genargs :: HashMap String String -> [String] -> [Arg] -> IO (HashMap String String, [Arg])
  -- All arguments are ArgString, enforced by 'interp'
  genargs vars (n:ns) (ArgString a:as) = genargs (M.insert n a vars) ns as
  genargs vars [] as = return (vars, as)
  genargs _ _ _ = throwIO (MacroNotEnoughArgs (mName m))




-- [Arg] should not have been interpolated yet, otherwise rmParen may remove
-- parenthesis from variables.
-- Conf should also not have been interpolated
ifExpand :: PState -> [Arg] -> Conf -> IO Conf
ifExpand st arg conf = do
  args <- mapM validateArg arg
  (st', ok) <- case args of

    -- Single argument, test if true/false
    [v] -> do
      v' <- interpArg v
      return $ (st, v' /= "" && v' /= "0")

    -- Equality/inequality
    [a, "=" , b] -> (st,) <$> ((==) <$> interpArg a <*> interpArg b)
    [a, "!=", b] -> (st,) <$> ((/=) <$> interpArg a <*> interpArg b)

    -- Regex
    [a, "~"  , b] ->                     regex a b True
    [a, "~*" , b] ->                     regex a b False
    [a, "!~" , b] -> (fmap . fmap) not $ regex a b True
    [a, "!~*", b] -> (fmap . fmap) not $ regex a b False

    ---- File tests
    [ "-f", a] -> (st,) <$> (         interpArg a >>= doesFileExist)
    ["!-f", a] -> (st,) <$> (not <$> (interpArg a >>= doesFileExist))
    [ "-d", a] -> (st,) <$> (         interpArg a >>= doesDirectoryExist)
    ["!-d", a] -> (st,) <$> (not <$> (interpArg a >>= doesDirectoryExist))
    [ "-e", a] -> (st,) <$> (         interpArg a >>= doesPathExist)
    ["!-e", a] -> (st,) <$> (not <$> (interpArg a >>= doesPathExist))
    [ "-x", a] -> (st,) <$> (         interpArg a >>= doesExecutableExist)
    ["!-x", a] -> (st,) <$> (not <$> (interpArg a >>= doesExecutableExist))

    -- Dunno
    _ -> throwIO IfUnknown

  if ok
    then procConf' st' conf
    else return []

  where
  -- All arguments must be fully evaluated ArgStrings
  validateArg :: Arg -> IO String
  validateArg (ArgString l) = return l
  validateArg _             = throwIO IfInvalidArg

  -- Performs variable substitution and flattens the result
  -- TODO: Throw error if a variable could not be substituted.
  interpArg :: String -> IO String
  interpArg a = do
    [ArgString a'] <- procArg st [ArgString a]
    return $ unescape a'

  -- System.Directory is missing this check
  doesExecutableExist :: FilePath -> IO Bool
  doesExecutableExist p = either (const False) executable <$> tryIOError (getPermissions p)

  -- Regex matching
  regex :: String -> String -> Bool -> IO (PState, Bool)
  regex a' b' caseSen = do
    a <- interpArg a'
    b <- interpArg b'
    -- 'Either String' does not implement fail, but 'Maybe' does. Go figure.
    reg <- case R.makeRegexOptsM (R.defaultCompOpt { R.caseSensitive = caseSen }) R.defaultExecOpt b of
      Nothing -> throwIO (InvalidRegex b)
      Just r -> return r
    case R.matchOnceText reg a of
      Nothing -> return (st, False)
      Just (_, res, _) ->
        let nargs = foldr (\(n,(s,_)) i -> M.insert (show n) s i)
                          (stArgs st)
                          (A.assocs res)
            st' = st { stArgs = nargs }
        in return (st', True)




includeExpand :: PState -> Int -> String -> IO (PState, [Directive])
includeExpand st n fn = do
  fns <- filterM doesFileExist $ map (</>fn) $ stIncDir st
  f <- case fns of
    [] -> throwIO (IncludeNotFound fn)
    f:_ -> return f
  contents <- readFile f
  ast <- case parse parser fn contents of
    Left e  -> throwIO (IncludeParse e)
    Right r -> return r
  (nst, conf) <- procConf (st { stIncludes = n-1 }) ast
  return (nst { stIncludes = n+1 }, conf)



data PState = PState
  { stIncDir   :: [String]
  , stVars     :: HashMap String String
  , stMacros   :: HashMap String Macro
  , stArgs     :: HashMap String String -- 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)]
  , stIncludes :: Int
  }


procArg :: PState -> [Arg] -> IO [Arg]
procArg st gargs = join <$> mapM interp gargs
  where
  interp a = case a of
    ArgBlock n -> throwIO (BlockArg n)
    ArgArray n ->
      case lookup n (stArray st) of
        Nothing -> throwIO (UnknownArray n)
        Just l -> return l -- No interpolation necessary I think, should have been processed at call site
    ArgString l -> return [ArgString $ interps l]

  -- Interpolated variables will be converted to the quoting style of the containing string.
  -- E.g.
  --   a = "abc{";  b = "x\yz";  c = "$something"
  --   $a       -> abc\{
  --   $a$b;    -> abc\{xyz
  --   "$a$b";  -> "abc{xyz"
  --   $c$a     -> $somethingabc\{   <- Or should this be ${something}abc\{? Current solution is simpler, but not sure what the expected behavior is here.

  doubleEsc = (=='"')
  singleEsc = (=='\'')
  plainEsc c = c == '{' || c == ';' || isSpace c

  escFunc ('"' :_) = doubleEsc
  escFunc ('\'':_) = singleEsc
  escFunc _        = plainEsc

  quote :: (Char -> Bool) -> String -> String
  quote f = concatMap (\c -> if f c then ['\\', c] else [c])

  -- Note that the config parser already ensures that quoted strings have an
  -- end quote, so the use of 'init' here is safe.
  unquote s = case s of
    '"' :xs -> unescape' doubleEsc (init xs)
    '\'':xs -> unescape' singleEsc (init xs)
    xs      -> unescape' plainEsc xs

  interps :: String -> String
  interps s = case parse (rep (escFunc s)) s s of
      Left e -> error ("Variable interpolation failed to parse: " ++ parseErrorPretty e)
      Right s' -> join s'
    where
    scalarname = identifier <|> some digitChar
    scalarvar = char '$'
      >>  between (char '{') (char '}') scalarname
      <|> scalarname
    var f = scalarvar >>= \n ->
      case (M.lookup n (stArgs st), M.lookup n (stVars st)) of
        (Just v, _) -> return $ quote f $ unquote v
        (_, Just v) -> return $ quote f $ unquote v
        _           -> fail "unknown variable"
    rep f = many (string "\\$" <|> try (var f) <|> ((:[]) <$> anyChar))




procConf' :: PState -> [Directive] -> IO [Directive]
procConf' st c = snd <$> procConf st c

procConf :: PState -> [Directive] -> IO (PState, [Directive])
procConf gst gconf = foldM p (gst, []) gconf
  where
  p (st, a) i = (fmap . fmap) (a++) (stmt st i)

  stmt :: PState -> Directive -> IO (PState, [Directive])

  stmt st (BlockRef n) =
    case lookup n (stBlock st) of
      Nothing -> throwIO (UnknownBlockRef n)
      Just b -> return (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 n:_ , Nothing) -> throwIO (MacroNoBlock n)
      (ArgString n:a', Just b') -> (,[]) <$> macroDef st n a' b'
      (_             , _      ) -> throwIO MacroNoName

  stmt st (Directive "pre_include" a b) =
    case (stIncludes st, a, b) of
      (0, _, _) -> throwIO IncludeRecurse
      (i, [ArgString n], Nothing) -> includeExpand st i $ unescape n
      _ -> throwIO IncludeArg

  stmt st (Directive "pre_set" a b) =
    case (a, b) of
      (ArgString ('$':n):arg:[], Nothing) -> do
        [ArgString arg'] <- procArg st [arg]
        return (st { stVars = M.insert n arg' (stVars st) }, [])
      _ -> throwIO SetArg

  stmt st (Directive "pre_warn" a b) =
    (st, []) <$ case (a, b) of
      (arg, Nothing) -> do
        msg <- fmtArgs <$> procArg st arg
        hPutStrLn stderr ("[warn]" ++ msg)
      _ -> throwIO WarnArg

  stmt st (Directive "pre_exec" a b) =
    case (a, b) of
      (ArgString ('$':n):arg:[], Nothing) -> do
        -- TODO: Throw error if a variable could not be substituted? That would
        -- demand that all shell variables are escaped properly, which in turn
        -- may prevent some surprises.
        [ArgString cmd] <- procArg st [arg]
        -- This will throw an IOError on failure, which is good enough
        ret <- readCreateProcess (shell $ unescape cmd) ""
        -- Remove final newline
        let ret' = if not (null ret) && last ret == '\n' then init ret else ret
        return (st { stVars = M.insert n ret' (stVars st) }, [])
      _ -> throwIO ExecArg

  stmt st (Directive "pre_if" a b) =
    (st,) <$> case b of
      Nothing -> throwIO IfNeedsBlock
      Just b' -> ifExpand st a b'

  stmt st (Directive name a b) = (st,) <$> do
    a' <- procArg st a
    b' <- mapM (procConf' st) b
    case M.lookup name (stMacros st) of
      Just macro -> macroExpand macro a' b'
      Nothing    -> return [Directive name a' b']





data Options = Options
  { optVersion :: Bool
  , optInput   :: String
  , optOutput  :: String
  , optInclude :: [String]
  }

main :: IO ()
main = do
  o <- execParser opts
  if optVersion o
    -- I could use cabal's Paths_* module here to get the version from the
    -- cabal file, but unfortunately that also puts all my build paths in the
    -- generated binary.
    then putStrLn "nginx-confgen 1.1"
    else prog o

  where
  opts = info (optparse <**> helper) fullDesc
  optparse = Options
    <$> switch    (short 'V' <> long "version" <> hidden <> help "Show program version")
    <*> strOption (short 'i' <> metavar "FILE" <> value "-" <> showDefault <> help "Input file")
    <*> strOption (short 'o' <> metavar "FILE" <> value "-" <> showDefault <> help "Output file")
    <*> many (strOption (short 'I' <> metavar "DIR" <> help "Add search path for pre_include directives"))

  prog o = do
    let inc = if null (optInclude o) then ["."] else optInclude o

    input <- if optInput o == "-"
      then getContents
      else readFile (optInput o)

    case parse parser (optInput o) input of
      Left e -> hPutStrLn stderr $ parseErrorPretty e
      Right r -> do
        output <- fmt <$> procConf' (PState inc mempty mempty mempty mempty mempty 15) r
        if optOutput o == "-"
          then putStr output
          else writeFile (optOutput o) output
