mcm-0.6.4.10: mcm.hs
-- MCM - Machine Configuration Manager; manages the contents of files and directories
-- Copyright (c) 2013-2016 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