mcm-0.6.8.1: FileCorrector.hs

-- 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 FileCorrector (ChangesSummary(..), correctAll, CompFun, diffCompare, simpleCompare, Path, PathType(..), theRootDir, addPath, walk, Permissions(..), emptyPermissions, DirType(..), OwnerP(..), GroupP(..), ownerAsString, groupAsString, mergePaths, Source)
where

import Control.Exception (catchJust)
import Data.Char(isSpace)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.IO as TextIO
import Numeric(showOct)
import System.Directory (getDirectoryContents, removeFile, removeDirectory)
import qualified System.Directory as SD
import System.Exit(ExitCode(ExitSuccess))
import System.FilePath (joinPath, normalise, splitFileName, makeRelative, splitDirectories, dropTrailingPathSeparator, takeFileName, combine)
import System.IO.HVFS.Utils (recursiveRemove, SystemFS(..))
import System.IO.Error (isDoesNotExistErrorType, ioeGetErrorType)
import System.Posix.Directory (createDirectory)
import System.Posix.Files (fileExist, isDirectory, setFileMode, removeLink, getSymbolicLinkStatus, isSymbolicLink, readSymbolicLink, createSymbolicLink, setOwnerAndGroup, setSymbolicLinkOwnerAndGroup, fileMode, fileOwner, fileGroup, getFileStatus, accessModes, intersectFileModes)
import System.Posix.Types (FileMode, UserID, GroupID)
import System.Process (readProcessWithExitCode)

import Action

data ChangesSummary = SomeItemsChangedOrRemoved | OnlyNewItems
    deriving Show

data FT = FileT | DirT | SymlinkT
    deriving (Show, Eq)

data WrongFT = FileWT | SymlinkWT | EmptyDirWT | NonEmptyDirWT
    deriving (Show, Eq)

data AlsoWrongPermissions = PermissionsWrongToo | PermissionsRight
    deriving (Show, Eq)

-- Intermediate Status of files found (all but for permissions checked)
data IStatus = IMissing -- File/Dir is not there at all
             | IWrongType WrongFT -- File when should be Dir, etc.
             | IWrongContents (Maybe String) -- Files: Might as well not be there...
             | IExtraFiles [(FilePath, WrongFT)] -- Full Dirs: some extra files
             | ILooksOk
    deriving (Show, Eq)

-- Final Status of files found
data FStatus = FMissing -- File/Dir is not there at all
             | FWrongType WrongFT -- File when should be Dir, etc.
             | FWrongContents (Maybe String) -- Files: Might as well not be there...
             | FExtraFiles [(FilePath, WrongFT)] AlsoWrongPermissions -- Full Dirs: some extra files
             | FWrongPermissions -- Content ok, permissions need correcting
             | FPerfect
    deriving (Show, Eq)

data DirType = Full     -- Fully managed dir (delete unmanaged files/dirs)
             | Partial     -- Partially managed dir (do not delete unmanaged files/dirs)
             | Implicit    -- Implicitly created
    deriving (Show, Eq)

data PathType = Dir DirType
              | File T.Text
              | Symlink FilePath
              | Absent
    deriving (Show, Eq)

kind2ft :: PathType -> FT
kind2ft (Dir _) = DirT
kind2ft (File _) = FileT
kind2ft (Symlink _) = SymlinkT
kind2ft Absent = error "Absent has no ft"

-- FileMode, UserName, GroupName
newtype OwnerP = OwnerP (T.Text, UserID)
    deriving (Show, Eq)
newtype GroupP = GroupP (T.Text, GroupID)
    deriving (Show, Eq)
data Permissions = Perm (Maybe FileMode) (Maybe OwnerP) (Maybe GroupP)
    deriving (Show, Eq)

emptyPermissions :: Permissions
emptyPermissions = Perm Nothing Nothing Nothing

ownerAsString :: OwnerP -> String
ownerAsString (OwnerP (o, _)) = T.unpack o

groupAsString :: GroupP -> String
groupAsString (GroupP (g, _)) = T.unpack g

type Source = String

implicitSource :: Source
implicitSource = "(implicit)"

-- A tree of paths.  Each FilePath contains the full path
-- ToDo: shouldn't the Map.Map be part of the Dir PathType?
data Path = Path FilePath PathType (Map.Map FilePath Path) Permissions Source
    deriving (Show, Eq)

theRootDir :: Path
theRootDir = Path "" (Dir Implicit) Map.empty emptyPermissions implicitSource

type CompFun = T.Text -> FilePath -> IO IStatus

walk :: Path -> [(FilePath, PathType, Permissions)]
walk (Path "" _ ps _ _) = concatMap walk (Map.elems ps)
walk (Path path kind ps perm _) = x:xs
    where
        x  = (path, kind, perm)
        xs = concatMap walk (Map.elems ps)

addPath :: Path -> FilePath -> PathType -> Permissions -> Source -> Either String Path
addPath p f = addPath' p normalisedFilePath
    where
        normalisedFilePath = normalise (dropTrailingPathSeparator f)

addPath' :: Path -> FilePath -> PathType -> Permissions -> Source -> Either String Path
addPath' (Path path kind ps perm source) newPath newType newPermissions newS =
    if path == newPath then
        if kind == Dir Implicit then
            if newType `elem` [Dir Full, Dir Partial] then
                -- Replace old implicit directory
                Right $ Path path newType ps newPermissions newS
            else
                Left $ "Path " ++ newPath ++ " is already implicitly a directory from " ++ show source
        else
            Left $ "Path " ++ newPath ++ " already exists from " ++ show source ++ " and the new definition from " ++ show newS ++ " conflicts."
    else
        let (dir, _) = splitFileName newPath
            dir' = if dir == "./" then "" else dropTrailingPathSeparator dir
        in
            if dir' == path then
                -- Add item into this path,
                -- complaining if already exists and is different
                case Map.lookup newPath ps of
                    Nothing -> let iP = Path newPath newType Map.empty newPermissions newS
                               in Right $ Path path kind (Map.insert newPath iP ps) perm source
                    Just p -> case addPath' p newPath newType newPermissions newS of
                        Left e -> Left e
                        Right pp -> Right $ Path path kind (Map.insert newPath pp ps) perm source
            else
                -- recurse, adding result as a new/replacement path
                let remainingdirs = makeRelative path dir'
                    nextdir = head $ splitDirectories remainingdirs
                    newentryPath = joinPath [path, nextdir]
                    defaultNewEntry = Path newentryPath (Dir Implicit) Map.empty emptyPermissions newS
                    lookedupNewEntry = Map.findWithDefault defaultNewEntry newentryPath ps
                in case addPath' lookedupNewEntry newPath newType newPermissions newS of
                    Left e -> Left e
                    Right p -> Right $ Path path kind (Map.insert newentryPath p ps) perm source

-- As yet only for the merging of very simple, compileTo-generated paths
mergePaths :: Path -> Path -> Path
mergePaths (Path apath akind aps aperm asource) (Path bpath bkind bps bperm _) =
    if or [apath /= bpath, akind /= bkind, aperm /= bperm]
        then error "Internal Error: Path construction/traversal mistake"
        else let mergedps = Map.unionWith mergePaths aps bps
             in Path apath akind mergedps aperm asource

calculateStatus :: CompFun -> Path -> IO FStatus
calculateStatus compfun (Path path kind paths perm _) = do
    s <- case kind of
        Dir t -> calcDirStatus t path paths
        File s -> calcFileStatus compfun s path
        Symlink fp -> calcSymlinkStatus fp path
        Absent -> calcAbsentStatus path
    checkPermissions kind path perm s

checkPermissions :: PathType -> FilePath -> Permissions -> IStatus -> IO FStatus
checkPermissions kind path perm (IExtraFiles fs) = do
    wrong <- permissionsAreWrong kind path perm
    return $ FExtraFiles fs $ if wrong then PermissionsWrongToo else PermissionsRight
checkPermissions kind path perm ILooksOk = do
    wrong <- permissionsAreWrong kind path perm
    return $ if wrong then FWrongPermissions else FPerfect
checkPermissions _ _ _ IMissing = return FMissing
checkPermissions _ _ _ (IWrongType wft) = return $ FWrongType wft
checkPermissions _ _ _ (IWrongContents ms) = return $ FWrongContents ms

permissionsAreWrong :: PathType -> FilePath -> Permissions -> IO Bool
permissionsAreWrong _ _ (Perm Nothing Nothing Nothing) = return False
permissionsAreWrong kind path (Perm m u g) = do
    let getStatusCmd = case kind of
                        (Symlink _) -> getSymbolicLinkStatus
                        _ -> getFileStatus
    fstatus <- getStatusCmd path
    let wrong = or [case m of
                        (Just m') -> m' /= intersectFileModes accessModes (fileMode fstatus)
                        _ -> False
                   ,case u of
                        (Just (OwnerP(_, u'))) -> u' /= fileOwner fstatus
                        _ -> False
                   ,case g of
                        (Just (GroupP(_, g'))) -> g' /= fileGroup fstatus
                        _ -> False
                   ]
    return wrong

calcDirStatus :: DirType -> FilePath -> Map.Map FilePath Path -> IO IStatus
calcDirStatus  _ "" _ = return ILooksOk
calcDirStatus  t path paths = do
    e <- fileExist path
    if e
        then do
            fs <- getSymbolicLinkStatus path
            if isSymbolicLink fs
                then return $ IWrongType SymlinkWT
                else if isDirectory fs
                    then
                        case t of
                            Full -> checkContents path paths
                            _ -> return ILooksOk
                    else return $ IWrongType FileWT
        else return IMissing

listDirectory :: FilePath -> IO [FilePath]
listDirectory fp = do
    fs <- getDirectoryContents fp
    return $ filter (\f -> f `notElem` [".", ".."]) fs

-- Return ILooksOk if path contains no files other than path.
-- Otherwise return ExtraFiles.
checkContents :: FilePath -> Map.Map FilePath Path -> IO IStatus
checkContents path paths = do
    files <- listDirectory path
    let wanted = Set.map (takeFileName.dropTrailingPathSeparator) (Map.keysSet paths)
        actual = Set.fromList files
        extras = Set.toList $ Set.difference actual wanted
        extrasWithPath = map (combine path) extras
    if null extras
        then return ILooksOk
        else do
            withFTs <- mapM appendFileType extrasWithPath
            return $ IExtraFiles withFTs

-- Is the given directory empty? helper during calculating WrongFT
isDirEmpty :: FilePath -> IO WrongFT
isDirEmpty path = do
    ls <- listDirectory path
    return $ if [] == ls then EmptyDirWT else NonEmptyDirWT

appendFileType :: FilePath -> IO (FilePath, WrongFT)
appendFileType path = do
    fs <- getSymbolicLinkStatus path
    t <- if isSymbolicLink fs
            then return SymlinkWT
            else if isDirectory fs
                    then isDirEmpty path
                    else return FileWT
    return (path, t)

calcFileStatus :: CompFun -> T.Text -> FilePath -> IO IStatus
calcFileStatus compfun contents path = do
    e <- fileExist path
    if e
        then do
            fs <- getSymbolicLinkStatus path
            if isSymbolicLink fs
                then return $ IWrongType SymlinkWT
                else if isDirectory fs
                    then IWrongType <$> isDirEmpty path
                    else compfun contents path
        else return IMissing

simpleCompare :: CompFun
simpleCompare contents path = do
    let contents' = appendNewlineIfMissing contents
    current <- TextIO.readFile path
    return $ if current == contents' then ILooksOk else IWrongContents Nothing

diffCompare :: CompFun
diffCompare contents path = do
    let contents' = appendNewlineIfMissing contents
    (exitCode, stderr, stdout)
        <- readProcessWithExitCode "diff" [path, "-"] $ T.unpack contents'
    return $ if exitCode == ExitSuccess
                then ILooksOk
                else IWrongContents (Just $ stderr++stdout)

calcSymlinkStatus :: FilePath -> FilePath -> IO IStatus
calcSymlinkStatus dest source = do
    e <- fileExist source   -- NB. Works on the _target_ of symbolic links
    if e
        then do
            fs <- getSymbolicLinkStatus source
            if isSymbolicLink fs
                then do
                    l <- readSymbolicLink source
                    return $ if l == dest
                                then ILooksOk
                                else IWrongContents (Just $ "Symlink is currently " ++ l)
                else if isDirectory fs
                        then IWrongType <$> isDirEmpty source
                        else return $ IWrongType FileWT
        else do
            isslink <- catchJust (\ex -> if isDoesNotExistErrorType (ioeGetErrorType ex) then Just () else Nothing)
                             (do
                                fs <- getSymbolicLinkStatus source
                                return $ isSymbolicLink fs)
                             (\_ -> return False)
            if isslink
                then do
                    l <- readSymbolicLink source
                    return $ if l == dest
                                then ILooksOk
                                else IWrongContents (Just $ "Symlink is currently " ++ l)
                else
                    return IMissing

calcAbsentStatus :: FilePath -> IO IStatus
calcAbsentStatus path = do
    e <- fileExist path
    if e
        then do
            fs <- getSymbolicLinkStatus path
            if isSymbolicLink fs
                then return $ IWrongType SymlinkWT
                else if isDirectory fs
                        then IWrongType <$> isDirEmpty path
                        else return $ IWrongType FileWT
        else
            return ILooksOk

correctOne :: Path -> FStatus -> [Action]
correctOne _ FPerfect = []
correctOne (Path path kind _ perm _) s@FWrongPermissions = correctPermissions s kind path perm
correctOne (Path path Absent _ _ _) s = correctAbsent s path
correctOne p@(Path path _ _ _ _) s@(FWrongType _) = correctAbsent s path ++ correctOne p FMissing
correctOne (Path path kind _ perm _) s = k ++ cor
    where cor = correctPermissions s kind path perm'
          (perm', k) = case kind of
                Dir _ -> correctDir s path perm
                File c -> correctFile s c path perm
                Symlink fp -> correctSymlink s fp path perm
                Absent -> (emptyPermissions, correctAbsent s path)

correctPermissions :: FStatus -> PathType -> FilePath -> Permissions -> [Action]
correctPermissions FPerfect _ _ _ = []
correctPermissions _ kind path (Perm m u g) = correctM m ++ correctUG u g
    where
        correctM Nothing = []
        correctM (Just m') = [Action ("chmod " ++ showOct m' []
                                      ++ " " ++ path)
                                     (setFileMode path m')]
        correctUG Nothing Nothing = []
        correctUG _ _ =
            let text = case (u, g) of
                        (Nothing, Nothing) -> ""
                        (Nothing, Just s) -> "chgrp " ++ groupAsString s ++ " " ++ path
                        (Just s, Nothing) -> "chown " ++ ownerAsString s ++ " " ++ path
                        (Just a, Just b) -> "chown " ++ ownerAsString a ++ ":" ++ groupAsString b ++ " " ++ path
                ft = kind2ft kind
            in
                [Action text (repairOwnerAndGroup ft path u g)]

repairOwnerAndGroup :: FT -> FilePath -> Maybe OwnerP -> Maybe GroupP -> IO ()
repairOwnerAndGroup ft p u g = ogrepair p u' g'
    where
        u' = case u of
                Nothing -> -1
                Just (OwnerP(_, uid)) -> uid
        g' = case g of
                Nothing -> -1
                Just (GroupP(_, gid)) -> gid
        ogrepair = case ft of
                    SymlinkT -> setSymbolicLinkOwnerAndGroup
                    _ -> setOwnerAndGroup

joinWithSpace :: String -> String -> String
joinWithSpace "" b = b
joinWithSpace a "" = a
joinWithSpace a b = a ++ " " ++ b

toModeOwnerGroup :: FT -> FilePath -> Permissions -> String -> (String, IO ())
toModeOwnerGroup _ path (Perm Nothing Nothing Nothing) extraargs = (joinWithSpace extraargs path, return ())
toModeOwnerGroup kind path (Perm m u g) extraargs = (mt ++ ugt ++ joinWithSpace extraargs path, do {mio; ugio})
    where
        (mt, mio) = case m of
                    Nothing -> ("", return ())
                    Just m' -> ("--mode " ++ showOct m' [] ++ " ", setFileMode path m')
        ugio = repairOwnerAndGroup kind path u g
        ugt = case (u, g) of
                    (Nothing, Nothing) -> ""
                    (Nothing, Just s) -> "--group " ++ groupAsString s ++ " "
                    (Just s, Nothing) -> "--owner " ++ ownerAsString s ++ " "
                    (Just a, Just b) -> "--owner " ++ ownerAsString a ++ " --group " ++ groupAsString b ++ " "

correctAbsent :: FStatus -> FilePath -> [Action]
correctAbsent (FWrongType SymlinkWT) path = [Action ("rm "++path) (removeLink path)]
correctAbsent (FWrongType FileWT) path = [Action ("rm "++path) (removeFile path)]
correctAbsent (FWrongType EmptyDirWT) path = [Action ("rmdir "++path) (removeDirectory path)]
correctAbsent (FWrongType NonEmptyDirWT) path = [Action ("rm -r "++path) (recursiveRemove SystemFS path)]
correctAbsent FMissing _ = [] -- Occurs when parent directories do not exist
correctAbsent s path = error $ "Unexpected correctAbsent state: " ++ show s ++ " (occurred for path " ++ path ++ ")"

-- NB. For security reasons we create the directory with the correct owner
correctDir :: FStatus -> FilePath -> Permissions -> (Permissions, [Action])
correctDir FMissing p perm@(Perm m _ _) =
    let (mogText, mogIO) = toModeOwnerGroup DirT p perm ""
        mkdir = case m of
                    Nothing -> SD.createDirectory p
                    Just mode -> createDirectory p mode
    in (emptyPermissions, [Action ("mkdir " ++ mogText) (do {mkdir; mogIO})])
correctDir (FExtraFiles fs wrongp) _ perm = (perm', concatMap (\(p, ft) -> correctAbsent (FWrongType ft) p) fs)
    where
        perm' = case wrongp of
            PermissionsRight -> emptyPermissions
            PermissionsWrongToo -> perm
correctDir _ _ _ = error "Unexpected correctDir state"

correctFile :: FStatus -> T.Text -> FilePath -> Permissions -> (Permissions, [Action])
correctFile (FWrongContents w) c p perm =
    let (mogText, mogIO) = toModeOwnerGroup FileT p perm ""
        c' = appendNewlineIfMissing c
    in (emptyPermissions, correctAbsent (FWrongType FileWT) p
                          ++ showWrong w
                          ++ [Action ("install "++mogText) (do {TextIO.writeFile p c'; mogIO})])
correctFile FMissing c p perm =
    let (mogText, mogIO) = toModeOwnerGroup FileT p perm ""
        c' = appendNewlineIfMissing c
    in (emptyPermissions, [Action ("install " ++ mogText) (do {TextIO.writeFile p c'; mogIO})])
correctFile _ _ _ _ = error "Unexpected correctFile state"

correctSymlink :: FStatus -> FilePath -> FilePath -> Permissions -> (Permissions, [Action])
correctSymlink (FWrongContents w) fp p perm =
    let (perm', fixmissing) = correctSymlink FMissing fp p perm
    in (perm', correctAbsent (FWrongType SymlinkWT) p ++ showWrong w ++ fixmissing)
correctSymlink FMissing fp p perm =
    let (mogText, mogIO) = toModeOwnerGroup FileT p perm ("-s " ++ fp)
    in (emptyPermissions, [Action ("ln " ++ mogText) (do {createSymbolicLink fp p; mogIO})])
correctSymlink _ _ _ _ = error "Unexpected correctSymlink state"

showWrong :: Maybe String -> [Action]
showWrong Nothing = []
showWrong (Just s) = [Action (trim s) (return ())]

trim :: String -> String
trim = f . f
   where f = reverse . dropWhile isSpace

statusAndCorrect :: CompFun -> Path -> IO (FStatus, [Action])
statusAndCorrect compfun p = do
    s <- calculateStatus compfun p
    return (s, correctOne p s)

correctAll :: CompFun -> Path -> IO (ChangesSummary, [Action])
correctAll compfun p@(Path _ _ paths _ _) = do
    (s, a) <- statusAndCorrect compfun p
    let corrector = case s of
                    FPerfect -> correctAll
                    FWrongPermissions -> correctAll
                    FExtraFiles _ _ -> correctAll
                    _ -> \_ pp -> return (OnlyNewItems, correctTheMissingRest pp)
        csummary = case s of
                    FMissing -> OnlyNewItems
                    FPerfect -> OnlyNewItems
                    _ -> SomeItemsChangedOrRemoved
        calcCSummary :: ChangesSummary -> ChangesSummary -> ChangesSummary
        calcCSummary SomeItemsChangedOrRemoved _ = SomeItemsChangedOrRemoved
        calcCSummary _ SomeItemsChangedOrRemoved = SomeItemsChangedOrRemoved
        calcCSummary OnlyNewItems OnlyNewItems = OnlyNewItems
    children <- mapM (corrector compfun) $ Map.elems paths
    return (foldr1 calcCSummary (csummary:map fst children), concat (a:map snd children))

correctTheMissingRest :: Path -> [Action]
correctTheMissingRest p@(Path _ _ paths _ _) =
    let a = correctOne p FMissing
        children = map correctTheMissingRest $ Map.elems paths
    in
        concat (a:children)

appendNewlineIfMissing :: T.Text  -> T.Text
appendNewlineIfMissing x | T.null x = x
appendNewlineIfMissing x | T.last x == '\n' = x
appendNewlineIfMissing x = T.snoc x '\n'