-- MCM - Machine Configuration Manager; manages the contents of files and directories
-- Copyright (c) 2013-2018 Anthony Doggett <mcm@interfaces.org.uk>
--
-- Licence:
--     This program is free software: you can redistribute it and/or modify
--     it under the terms of the GNU General Public License as published by
--     the Free Software Foundation, either version 3 of the License, or
--     (at your option) any later version.
--
--     This program is distributed in the hope that it will be useful,
--     but WITHOUT ANY WARRANTY; without even the implied warranty of
--     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--     GNU General Public License for more details.
--
--     You should have received a copy of the GNU General Public License
--     along with this program.  If not, see <http://www.gnu.org/licenses/>.
module Main (main)
where

import Action (Action, displayActions, runActions)
import FileCorrector(ChangesSummary(..), correctAll, CompFun, diffCompare, simpleCompare, Path, theRootDir, emptyPermissions, PathType(..), addPath, mergePaths)
import Parser (mcmParsePackagePath)
import ParserTypes (PackagePath(..), Group, DefName(..), packagePath)
import InterpretState (initState, SearchPath(..), Args(..), State, getCache, setCache)
import Interpret (run, fullyLoadSectionFromHandle)
import PathToMCM (pathToMcm)
import Paths_mcm (version)

import Control.Monad(when, unless, foldM)
import Data.List (foldl')
import qualified Data.Map as Map
import qualified Data.Text.Lazy as T
import Data.Version (showVersion)
import Network.HostName (getHostName)
import System.Environment (getArgs)
import System.Console.GetOpt
import System.Directory (getCurrentDirectory, doesDirectoryExist)
import System.Exit (exitSuccess, exitFailure, exitWith, ExitCode(..))
import System.FilePath (normalise, dropTrailingPathSeparator, combine)
import System.IO.PlafCompat (nullFileName)
import System.Posix.User (getAllUserEntries, getAllGroupEntries)
import System.IO (stdin, stdout, hFlush)
import System.IO.Unsafe (unsafeInterleaveIO)

usage :: String
usage = unlines ["Usage: mcm [OPTION..] [STARTINGPOINT..] [OPTION..]"
                ,"Configure the specified files and directories"
                ,"(both file/directory contents and permissions)."
                ,"Changes to be made (if any) are displayed before they are enacted."
                ,""
                ,"STARTINGPOINT\tstarting point (default = \"Go.<lowercase_hostname>\")."
                ,"FIXTYPE\t\tno|prompt|ifnew|yes|promptunlessonlyadditions"
                ]

main :: IO ()
main = do
    progargs <- getArgs
    let (actions, nonOpts, msgs) = getOpt Permute options progargs
    unless (null msgs) $ error $ concat msgs ++ usageInfo usage options
    opts <- foldl' (>>=) (return defaultOptions) actions
    hostname <- unsafeInterleaveIO getHostName
    let go = PackagePath [T.pack "Go"]
    let lhostname = T.toLower . T.pack $ hostname
    let startingpoints@((pp0, _):_) = reverse $
            case parseNonOpts (go, DefName lhostname) [] nonOpts of
                [] -> [(go, DefName lhostname)]
                xs -> xs
    let Options {optRoot = root
                ,optConfigPath = configpath
                ,optEnactChanges = enactchanges
                ,optLeftoverChecker = leftoverchecker
                ,optLoadInitialConfig = loadinitialconfig
                ,optComparisonFunction = compfun
                ,optCorrectFunction = correctfun
                ,optCompileToFunction = compilefun
                ,optCollatePaths = collatePaths
                ,optDisplayOGWarnings = displayOGwarnings
                } = opts
    sp <- configpath
    us <- getAllUserEntries
    gs <- getAllGroupEntries
    s0 <- loadinitialconfig pp0 $ initState us gs sp root
    let correctDisplayEnact p = do
        (csummary, as) <- correctfun compfun p
        displayActions as
        enactchanges csummary as
    (_, combinedPath, enactResults) <- foldM (\(c, cumulativePaths, enactResults) (pp, d) -> do
        when (length startingpoints > 1) $
            putStrLn $ "== " ++ show pp ++ "." ++ show d ++ " =="
        ((errors, ogwarnings, path, leftoverFragments), s1) <-
            run (setCache s0 c) (pp, d, Args Map.empty)
        displayOGwarnings ogwarnings
        mapM_ print errors
        leftoverchecker leftoverFragments
        let path' = compilefun pp d path
        unless (null errors) exitFailure
        er <- if collatePaths then return AsExpected else correctDisplayEnact path'
        return (getCache s1, cumulativePaths `mergePaths` path', er:enactResults)
        ) (getCache s0, theRootDir, []) startingpoints
    er <- if collatePaths then correctDisplayEnact combinedPath else return AsExpected
    unless (all (== AsExpected) (er:enactResults)) $ exitWith $ ExitFailure 3

parseNonOpts :: (PackagePath, DefName) -> [(PackagePath, DefName)] -> [String] -> [(PackagePath, DefName)]
parseNonOpts _ ys [] = ys
parseNonOpts _ _ ("":_) = error "'' is an invalid starting point"
parseNonOpts defaults@(go, lhostname) ys (x:xs) =
    let parsepp p = case mcmParsePackagePath (T.pack p) of
                        Right a -> a
                        Left _ -> error $ "Bad package name: " ++ show p
        y = case break (== '.') (reverse x) of
                (_, []) -> error $ "ERROR: Starting point '"++ x ++ "' is not of the format PACKAGE.DEFINE"
                ([], ".") -> (go, lhostname)
                (revdefine, ".") -> (go, (DefName . T.pack . reverse) revdefine)
                ([], '.':revpackage) -> (parsepp (reverse revpackage), lhostname)
                (revdefine, '.':revpackage) -> (parsepp (reverse revpackage), (DefName . T.pack . reverse) revdefine)
                _ -> error $ "ERROR: Impossible starting point: " ++ show x

    in
        parseNonOpts defaults (y:ys) xs

data EnactResult = AsExpected | UserCancelled
    deriving (Show, Eq)

data Options = Options
    {optRoot :: String
    ,optConfigPath :: IO SearchPath
    ,optEnactChanges :: ChangesSummary -> [Action] -> IO EnactResult
    ,optLeftoverChecker :: [(PackagePath, Group)] -> IO ()
    ,optLoadInitialConfig :: PackagePath -> State -> IO State
    ,optComparisonFunction :: CompFun
    ,optCorrectFunction :: CompFun -> Path -> IO (ChangesSummary, [Action])
    ,optCompileToFunction :: PackagePath -> DefName -> Path -> Path
    ,optCollatePaths :: Bool
    ,optDisplayOGWarnings :: [String] -> IO ()
    }

defaultOptions :: Options
defaultOptions = Options
    {optRoot = "./build"
    ,optConfigPath = do {d <- getCurrentDirectory; return $ SearchPath [d]}
    ,optEnactChanges = const prompt
    ,optLeftoverChecker = warnIfAny
    ,optLoadInitialConfig = \_ s0 -> return s0
    ,optComparisonFunction = simpleCompare
    ,optCorrectFunction = correctAll
    ,optCompileToFunction = \_ _ p -> p
    ,optCollatePaths = False
    ,optDisplayOGWarnings = mapM_ putStrLn
    }

options :: [OptDescr (Options -> IO Options)]
options = [Option "V" ["version"] (NoArg displayVersion)         "show version and exit"
          ,Option "P" ["config-path"]   (ReqArg setPath "PATH")   "colon-separated list of directories holding configs (default = \".\")"
          ,Option "r" ["root"] (ReqArg setRoot "DIRECTORY") "path to manage (default = \"./build\")"
          ,Option [] ["error-on-leftover-fragments"]    (NoArg errorOnLeftoverFragments) "complain if there are fragments without corresponding files"
          ,Option "f" ["fix"]    (ReqArg chooseFix "FIXTYPE") "whether to enact the changes (default=\"prompt\")"
          ,Option "d" ["diff"]    (NoArg useDiff) "display differences (requires 'diff')"
          ,Option [] ["parse-only"] (NoArg parseOnly) "parse configuration only"
          ,Option "c" ["compile-to"] (ReqArg compileTo "DIRECTORY") "compile to a single MCM file"
          ,Option [] ["stdin"] (NoArg readStdin) "read (initial) config from stdin"
          ,Option "h" ["help"] (NoArg justHelp) "show this help and exit"
          ]

setRoot :: FilePath -> Options -> IO Options
setRoot r opt = return opt {optRoot = r}

readStdin ::  Options -> IO Options
readStdin opt = return opt {optLoadInitialConfig = fullyLoadSectionFromHandle "<stdin>" stdin}

useDiff :: Options -> IO Options
useDiff opt = return opt {optComparisonFunction = diffCompare}

parseOnly :: Options -> IO Options
parseOnly opt = return opt {optCorrectFunction = \_ p -> writeToNull p
                           ,optDisplayOGWarnings = \_ -> return ()
                           }
    where
        writeToNull path = do
            writeFile nullFileName (pathToMcm "ParseOnly" "parseonly" path "")
            return (SomeItemsChangedOrRemoved, [])

compileTo :: FilePath -> Options -> IO Options
compileTo fp opt = return opt {optCompileToFunction = p2m
                              ,optCollatePaths = True
                              ,optDisplayOGWarnings = \_ -> return ()
                              }
    where
        p2m (PackagePath pp) d@(DefName d') path =
            let content = T.pack $ pathToMcm (show pp') (show d) path ""
                pp' = PackagePath $ appendD pp
                appendD [] = []
                appendD [x] = [x `T.append` T.cons '_' d']
                appendD (x:xs) = x : appendD xs
                filename = combine fp' (packagePath pp')
                fp' = dropTrailingPathSeparator $ normalise fp
                compiledPath = addPath theRootDir filename (File content) emptyPermissions "(compiled)"
                in case compiledPath of
                    Left s -> error s
                    Right p -> p

setPath :: String -> Options -> IO Options
setPath p opt = return opt {optConfigPath = return $ SearchPath (extractPath p)}

-- Change ".:/etc/mcm" to [".", "/etc/mcm"]
extractPath :: String -> [FilePath]
extractPath "" = []
extractPath p = let (l, p') = break (== ':') p
                in  l : case p' of
                                []      -> []
                                (_:p'') -> extractPath p''

doFix :: [Action] -> IO EnactResult
doFix [] = return AsExpected
doFix as = do
    putStrLn "Enacting..."
    runActions as
    return AsExpected

chooseFix :: String -> Options -> IO Options
chooseFix "no" opt = return opt {optEnactChanges = \_ _ -> return AsExpected}
chooseFix "yes" opt = return opt {optEnactChanges = const doFix}
chooseFix "ifnew" opt = return opt {optEnactChanges = \_ as -> do
    exists <- doesDirectoryExist (optRoot opt)
    if exists
        then exitWith $ ExitFailure 2
        else doFix as
    }
chooseFix "prompt" opt = return opt {optEnactChanges = const prompt}
chooseFix "promptunlessonlyadditions" opt = return opt {optEnactChanges = promptunlessonlyadditions}
chooseFix f _ = error ("Unrecognised fix method: " ++ f ++"\n" ++ usageInfo usage options)

prompt ::  [Action] -> IO EnactResult
prompt [] = return AsExpected
prompt as = do
    putStrLn "Enact changes? (Y/N)"
    hFlush stdout
    r <- getLine
    if r `elem` ["Y", "y"]
        then doFix as
        else putStrLn "Not correcting." >> return UserCancelled

promptunlessonlyadditions :: ChangesSummary -> [Action] -> IO EnactResult
promptunlessonlyadditions OnlyNewItems = doFix
promptunlessonlyadditions SomeItemsChangedOrRemoved = prompt

errorOnLeftoverFragments :: Options -> IO Options
errorOnLeftoverFragments opt = return opt {optLeftoverChecker = errorIfAny}

warnIfAny :: [(PackagePath, Group)] -> IO ()
warnIfAny [] = return ()
warnIfAny fs = do
    putStr "Warning: "
    ifany fs

errorIfAny :: [(PackagePath, Group)] -> IO ()
errorIfAny [] = return ()
errorIfAny fs = do
    putStr "Error: "
    ifany fs
    exitFailure

ifany :: [(PackagePath, Group)] -> IO ()
ifany fs = do
    putStrLn "Leftover fragments:"
    mapM_ print fs

displayVersion :: Options -> IO Options
displayVersion _ = do
    putStrLn $ "mcm " ++ showVersion version
    exitSuccess

justHelp ::  Options -> IO Options
justHelp _ = do
    putStrLn $ usageInfo usage options
    exitSuccess