module Propellor.Property.DiskImage (
DiskImage,
imageBuilt,
imageRebuilt,
imageBuiltFrom,
imageExists,
Partition,
PartSize(..),
Fs(..),
PartSpec,
MountPoint,
swapPartition,
partition,
mountedAt,
addFreeSpace,
setSize,
PartFlag(..),
setFlag,
TableType(..),
extended,
adjustp,
Finalization,
grubBooted,
Grub.BIOS(..),
noFinalization,
) where
import Propellor
import Propellor.Property.Chroot (Chroot)
import Propellor.Property.Chroot.Util (removeChroot)
import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Property.Grub as Grub
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import Propellor.Property.Parted
import Propellor.Property.Mount
import Propellor.Property.Partition
import Propellor.Property.Rsync
import Utility.Path
import Data.List (isPrefixOf)
import qualified Data.Map.Strict as M
import qualified Data.ByteString.Lazy as L
import System.Posix.Files
type DiskImage = FilePath
imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty
imageBuilt = imageBuilt' False
imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty
imageRebuilt = imageBuilt' True
imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty
imageBuilt' rebuild img mkchroot tabletype partspec final =
imageBuiltFrom img chrootdir tabletype partspec (snd final)
`requires` Chroot.provisioned chroot
`requires` (cleanrebuild <!> doNothing)
`describe` desc
where
desc = "built disk image " ++ img
cleanrebuild
| rebuild = property desc $ do
liftIO $ removeChroot chrootdir
return MadeChange
| otherwise = doNothing
chrootdir = img ++ ".chroot"
chroot = mkchroot chrootdir
& fst final
& Apt.cacheCleaned
imageBuiltFrom :: DiskImage -> FilePath -> TableType -> [PartSpec] -> Property NoInfo -> RevertableProperty
imageBuiltFrom img chrootdir tabletype partspec final = mkimg <!> rmimg
where
desc = img ++ " built from " ++ chrootdir
mkimg = property desc $ do
liftIO $ unmountBelow chrootdir
szm <- M.mapKeys (toSysDir chrootdir) . M.map toPartSize
<$> liftIO (dirSizes chrootdir)
let calcsz mnts = maybe defSz fudge . getMountSz szm mnts
let (mnts, t) = fitChrootSize tabletype partspec (map (calcsz mnts) mnts)
ensureProperty $
imageExists img (partTableSize t)
`before`
partitioned YesReallyDeleteDiskContents img t
`before`
kpartx img (partitionsPopulated chrootdir mnts)
rmimg = File.notPresent img
partitionsPopulated :: FilePath -> [MountPoint] -> [FilePath] -> Property NoInfo
partitionsPopulated chrootdir mnts devs = property desc $ mconcat $ zipWith go mnts devs
where
desc = "partitions populated from " ++ chrootdir
go Nothing _ = noChange
go (Just mnt) dev = withTmpDir "mnt" $ \tmpdir -> bracket
(liftIO $ mount "auto" dev tmpdir)
(const $ liftIO $ umountLazy tmpdir)
$ \mounted -> if mounted
then ensureProperty $
syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir
else return FailedChange
filtersfor mnt =
let childmnts = map (drop (length (dropTrailingPathSeparator mnt))) $
filter (\m -> m /= mnt && addTrailingPathSeparator mnt `isPrefixOf` m)
(catMaybes mnts)
in concatMap (\m ->
[ Include (Pattern m)
, Exclude (filesUnder m)
]) childmnts
imageExists :: FilePath -> ByteSize -> Property NoInfo
imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do
ms <- catchMaybeIO $ getFileStatus img
case ms of
Just s
| toInteger (fileSize s) == toInteger sz -> return NoChange
| toInteger (fileSize s) > toInteger sz -> do
setFileSize img (fromInteger sz)
return MadeChange
_ -> do
L.writeFile img (L.replicate (fromIntegral sz) 0)
return MadeChange
dirSizes :: FilePath -> IO (M.Map FilePath Integer)
dirSizes top = go M.empty top [top]
where
go m _ [] = return m
go m dir (i:is) = flip catchIO (\_ioerr -> go m dir is) $ do
s <- getSymbolicLinkStatus i
let sz = fromIntegral (fileSize s)
if isDirectory s
then do
subm <- go M.empty i =<< dirContents i
let sz' = M.foldr' (+) sz
(M.filterWithKey (const . subdirof i) subm)
go (M.insertWith (+) i sz' (M.union m subm)) dir is
else go (M.insertWith (+) dir sz m) dir is
subdirof parent i = not (i `equalFilePath` parent) && takeDirectory i `equalFilePath` parent
getMountSz :: (M.Map FilePath PartSize) -> [MountPoint] -> MountPoint -> Maybe PartSize
getMountSz _ _ Nothing = Nothing
getMountSz szm l (Just mntpt) =
fmap (`reducePartSize` childsz) (M.lookup mntpt szm)
where
childsz = mconcat $ mapMaybe (getMountSz szm l) (filter (isChild mntpt) l)
isChild :: FilePath -> MountPoint -> Bool
isChild mntpt (Just d)
| d `equalFilePath` mntpt = False
| otherwise = mntpt `dirContains` d
isChild _ Nothing = False
toSysDir :: FilePath -> FilePath -> FilePath
toSysDir chrootdir d = case makeRelative chrootdir d of
"." -> "/"
sysdir -> "/" ++ sysdir
type MountPoint = Maybe FilePath
defSz :: PartSize
defSz = MegaBytes 128
fudge :: PartSize -> PartSize
fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3)
type PartSpec = (MountPoint, PartSize -> Partition)
swapPartition :: PartSize -> PartSpec
swapPartition sz = (Nothing, const (mkPartition LinuxSwap sz))
partition :: Fs -> PartSpec
partition fs = (Nothing, mkPartition fs)
mountedAt :: PartSpec -> FilePath -> PartSpec
mountedAt (_, p) mp = (Just mp, p)
addFreeSpace :: PartSpec -> PartSize -> PartSpec
addFreeSpace (mp, p) freesz = (mp, \sz -> p (sz <> freesz))
setSize :: PartSpec -> PartSize -> PartSpec
setSize (mp, p) sz = (mp, const (p sz))
setFlag :: PartSpec -> PartFlag -> PartSpec
setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p }
extended :: PartSpec -> PartSpec
extended s = adjustp s $ \p -> p { partType = Extended }
adjustp :: PartSpec -> (Partition -> Partition) -> PartSpec
adjustp (mp, p) f = (mp, f . p)
fitChrootSize :: TableType -> [PartSpec] -> [PartSize] -> ([MountPoint], PartTable)
fitChrootSize tt l basesizes = (mounts, parttable)
where
(mounts, sizers) = unzip l
parttable = PartTable tt (zipWith id sizers basesizes)
type Finalization = (Property NoInfo, Property NoInfo)
grubBooted :: Grub.BIOS -> Finalization
grubBooted bios = (Grub.installed bios, undefined)
noFinalization :: Finalization
noFinalization = (doNothing, doNothing)