{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
module BDCS.Export.TmpFiles(
TmpFileEntry(..),
TmpFileType(..),
parseConfString,
setupFilesystem)
where
import Control.Conditional(ifM)
import Data.List(sort)
import qualified Data.Text as T
import System.Directory(createDirectoryIfMissing, doesPathExist, removePathForcibly)
import System.FilePath((</>), dropDrive, takeFileName)
import System.Posix.Files(createSymbolicLink, setFileMode, setOwnerAndGroup)
import System.Posix.Types(CMode(..), CUid(..), CGid(..))
import Text.Parsec
import Text.ParserCombinators.Parsec.Char(CharParser)
import Text.ParserCombinators.Parsec.Number(number)
import Text.Printf(printf)
data TmpFileType = NewDirectory
| NewSymlink
| ReplaceSymlink
| NewFile
| TruncateFile
| ModifyDirectory
| Unsupported
deriving(Ord, Eq, Show)
getTmpFileType :: String -> TmpFileType
getTmpFileType "f" = NewFile
getTmpFileType "F" = TruncateFile
getTmpFileType "d" = NewDirectory
getTmpFileType "e" = ModifyDirectory
getTmpFileType "L" = NewSymlink
getTmpFileType "L+"= ReplaceSymlink
getTmpFileType _ = Unsupported
allowedTypes :: String
allowedTypes = "fFwdDevqQpLcbCxXrRzZtThHaA+!"
data TmpFileEntry = TmpFileEntry {
tfeType :: TmpFileType,
tfePath :: FilePath,
tfeMode :: Maybe Integer,
tfeUid :: Maybe T.Text,
tfeGid :: Maybe T.Text,
tfeAge :: Maybe T.Text,
tfeArg :: Maybe T.Text
} deriving(Eq, Show)
instance Ord TmpFileEntry where
a `compare` b = let cmp = tfeType a `compare` tfeType b
in if cmp == EQ then tfePath a `compare` tfePath b else cmp
eol :: Parsec String () Char
eol = char '\n'
octal :: Integral i => CharParser st i
octal = many1 (oneOf "Oo0") >> number 8 octDigit
skipSpaces :: Parsec String () ()
skipSpaces = skipMany (oneOf " \t")
getTextField :: Parsec String () T.Text
getTextField = T.pack <$> many (noneOf " ")
parseMaybeDash :: Stream s m Char => ParsecT s u m a -> ParsecT s u m (Maybe a)
parseMaybeDash f = (Nothing <$ char '-') <|> (return <$> f)
parseType :: Parsec String () TmpFileType
parseType = getTmpFileType <$> many1 (oneOf allowedTypes)
parsePath :: Parsec String () FilePath
parsePath = many1 (noneOf " ")
parseMode :: Parsec String () (Maybe Integer)
parseMode = parseMaybeDash octal
parseId :: Parsec String () (Maybe T.Text)
parseId = parseMaybeDash getTextField
parseAge :: Parsec String () (Maybe T.Text)
parseAge = parseMaybeDash getAgeField
where
getAgeField = T.pack <$> many1 (oneOf "0123456789sminhdwu-")
parseArg :: Parsec String () T.Text
parseArg = T.pack <$> many1 (noneOf "\n")
parseConfLine :: Parsec String () TmpFileEntry
parseConfLine = do
t <- parseType
skipSpaces
p <- parsePath
skipSpaces
m <- parseMode
skipSpaces
uid <- parseId
skipSpaces
gid <- parseId
skipSpaces
age <- parseAge
skipSpaces
arg <- optionMaybe $ try parseArg
_ <- eol
return TmpFileEntry{tfeType=t, tfePath=p, tfeMode=m, tfeUid=uid, tfeGid=gid, tfeAge=age, tfeArg=arg}
parseConfString :: String -> Either ParseError [TmpFileEntry]
parseConfString = parse (many1 parseConfLine) "(tmpFiles.d)"
owner :: Maybe T.Text -> CUid
owner uid = case uid of
Nothing -> CUid 0
Just _ -> CUid 0
group :: Maybe T.Text -> CGid
group gid = case gid of
Nothing -> CGid 0
Just _ -> CGid 0
writeNewFile :: FilePath -> TmpFileEntry -> IO ()
writeNewFile outPath TmpFileEntry{..} = do
writeFile file content
setFileMode file mode
setOwnerAndGroup file (owner tfeUid) (group tfeGid)
where
file = outPath </> dropDrive tfePath
content = case tfeArg of
Nothing -> ""
Just c -> T.unpack c
mode = case tfeMode of
Nothing -> CMode 0o644
Just m -> CMode $ fromIntegral m
applyEntry :: FilePath -> TmpFileEntry -> IO ()
applyEntry outPath TmpFileEntry{tfeType=NewDirectory, ..} = do
createDirectoryIfMissing True dir
setFileMode dir mode
setOwnerAndGroup dir (owner tfeUid) (group tfeGid)
where
dir = outPath </> dropDrive tfePath
mode = case tfeMode of
Nothing -> CMode 0o755
Just m -> CMode $ fromIntegral m
applyEntry outPath entry@TmpFileEntry{tfeType=NewFile, ..} =
ifM (doesPathExist file)
(printf "NewFile: %s already exists, skipping it." file)
(writeNewFile outPath entry)
where
file = outPath </> dropDrive tfePath
applyEntry outPath entry@TmpFileEntry{tfeType=TruncateFile, ..} = writeNewFile outPath entry
applyEntry outPath TmpFileEntry{tfeType=ModifyDirectory, ..} =
ifM (doesPathExist dir)
modify
(printf "ModifyDirectory: %s doesn't exist, skipping it." dir)
where
dir = outPath </> dropDrive tfePath
mode = case tfeMode of
Nothing -> CMode 0o755
Just m -> CMode $ fromIntegral m
modify = do
setFileMode dir mode
setOwnerAndGroup dir (owner tfeUid) (group tfeGid)
applyEntry outPath TmpFileEntry{tfeType=NewSymlink, ..} =
ifM (doesPathExist source)
(printf "NewSymlink: %s exists, skipping." source)
(createSymbolicLink target source)
where
source = outPath </> dropDrive tfePath
target = case tfeArg of
Nothing -> "/usr/share/factory" </> takeFileName tfePath
Just arg -> T.unpack arg
applyEntry outPath TmpFileEntry{tfeType=ReplaceSymlink, ..} = do
removePathForcibly source
createSymbolicLink target source
where
source = outPath </> dropDrive tfePath
target = case tfeArg of
Nothing -> "/usr/share/factory" </> takeFileName tfePath
Just arg -> T.unpack arg
applyEntry _ TmpFileEntry{tfeType=Unsupported, ..} = undefined
setupFilesystem :: FilePath -> FilePath -> IO ()
setupFilesystem outPath tmpFileConf = do
createDirectoryIfMissing True outPath
tmpfiles <- parseConfString <$> readFile tmpFileConf
case tmpfiles of
Right entries -> mapM_ (applyEntry outPath) $ sort entries
Left err -> print err