module Propellor.Property.DiskImage (
module Propellor.Property.DiskImage.PartSpec,
DiskImage,
imageBuilt,
imageRebuilt,
imageBuiltFrom,
imageExists,
vmdkBuiltFor,
Grub.BIOS(..),
) where
import Propellor.Base
import Propellor.Property.DiskImage.PartSpec
import Propellor.Property.Chroot (Chroot)
import Propellor.Property.Chroot.Util (removeChroot)
import Propellor.Property.Mount
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.Fstab (SwapPartition(..), genFstab)
import Propellor.Property.Partition
import Propellor.Property.Rsync
import Propellor.Types.Info
import Propellor.Types.Bootloader
import Propellor.Container
import Utility.Path
import Utility.FileMode
import Data.List (isPrefixOf, isInfixOf, sortBy, unzip4)
import Data.Function (on)
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 ()] -> RevertableProperty (HasInfo + DebianLike) Linux
imageBuilt = imageBuilt' False
imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
imageRebuilt = imageBuilt' True
imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
imageBuilt' rebuild img mkchroot tabletype partspec =
imageBuiltFrom img chrootdir tabletype final partspec
`requires` Chroot.provisioned chroot
`requires` (cleanrebuild <!> (doNothing :: Property UnixLike))
`describe` desc
where
desc = "built disk image " ++ img
cleanrebuild :: Property Linux
cleanrebuild
| rebuild = property desc $ do
liftIO $ removeChroot chrootdir
return MadeChange
| otherwise = doNothing
chrootdir = img ++ ".chroot"
chroot =
let c = propprivdataonly $ mkchroot chrootdir
in setContainerProps c $ containerProps c
&^ Chroot.noServices
& cachesCleaned
propprivdataonly (Chroot.Chroot d b ip h) =
Chroot.Chroot d b (\c _ -> ip c onlyPrivData) h
final = case fromInfo (containerInfo chroot) of
[GrubInstalled] -> grubBooted
[] -> unbootable "no bootloader is installed"
_ -> unbootable "multiple bootloaders are installed; don't know which to use"
cachesCleaned :: Property UnixLike
cachesCleaned = "cache cleaned" ==> (Apt.cacheCleaned `pickOS` skipit)
where
skipit = doNothing :: Property UnixLike
imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) UnixLike
imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
where
desc = img ++ " built from " ++ chrootdir
mkimg = property' desc $ \w -> 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, mntopts, parttable) = fitChrootSize tabletype partspec $
map (calcsz mnts) mnts
ensureProperty w $
imageExists' img parttable
`before`
kpartx img (mkimg' mnts mntopts parttable)
mkimg' mnts mntopts parttable devs =
partitionsPopulated chrootdir mnts mntopts devs
`before`
imageFinalized final mnts mntopts devs parttable
rmimg = undoRevertableProperty (imageExists' img dummyparttable)
dummyparttable = PartTable tabletype []
partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property DebianLike
partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w ->
mconcat $ zipWith3 (go w) mnts mntopts devs
where
desc = "partitions populated from " ++ chrootdir
go _ Nothing _ _ = noChange
go w (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket
(liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir mntopt)
(const $ liftIO $ umountLazy tmpdir)
$ \ismounted -> if ismounted
then ensureProperty w $
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)
, Protect (Pattern "lost+found")
]) childmnts
fitChrootSize :: TableType -> [PartSpec ()] -> [PartSize] -> ([Maybe MountPoint], [MountOpts], PartTable)
fitChrootSize tt l basesizes = (mounts, mountopts, parttable)
where
(mounts, mountopts, sizers, _) = unzip4 l
parttable = PartTable tt (zipWith id sizers basesizes)
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) -> [Maybe MountPoint] -> Maybe 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)
imageExists :: FilePath -> ByteSize -> Property Linux
imageExists img isz = 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
where
sz = ceiling (fromInteger isz / sectorsize) * ceiling sectorsize
sectorsize = 4096 :: Double
imageExists' :: FilePath -> PartTable -> RevertableProperty DebianLike UnixLike
imageExists' img parttable = (setup <!> cleanup) `describe` desc
where
desc = "disk image exists " ++ img
parttablefile = img ++ ".parttable"
setup = property' desc $ \w -> do
oldparttable <- liftIO $ catchDefaultIO "" $ readFileStrict parttablefile
res <- ensureProperty w $ imageExists img (partTableSize parttable)
if res == NoChange && oldparttable == show parttable
then return NoChange
else if res == FailedChange
then return FailedChange
else do
liftIO $ writeFile parttablefile (show parttable)
ensureProperty w $ partitioned YesReallyDeleteDiskContents img parttable
cleanup = File.notPresent img
`before`
File.notPresent parttablefile
type Finalization = (FilePath -> [LoopDev] -> Property Linux)
imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux
imageFinalized final mnts mntopts devs (PartTable _ parts) =
property' "disk image finalized" $ \w ->
withTmpDir "mnt" $ \top ->
go w top `finally` liftIO (unmountall top)
where
go w top = do
liftIO $ mountall top
liftIO $ writefstab top
liftIO $ allowservices top
ensureProperty w $ final top devs
orderedmntsdevs :: [(Maybe MountPoint, (MountOpts, LoopDev))]
orderedmntsdevs = sortBy (compare `on` fst) $ zip mnts (zip mntopts devs)
swaps = map (SwapPartition . partitionLoopDev . snd) $
filter ((== LinuxSwap) . partFs . fst) $
zip parts devs
mountall top = forM_ orderedmntsdevs $ \(mp, (mopts, loopdev)) -> case mp of
Nothing -> noop
Just p -> do
let mnt = top ++ p
createDirectoryIfMissing True mnt
unlessM (mount "auto" (partitionLoopDev loopdev) mnt mopts) $
error $ "failed mounting " ++ mnt
unmountall top = do
unmountBelow top
umountLazy top
writefstab top = do
let fstab = top ++ "/etc/fstab"
old <- catchDefaultIO [] $ filter (not . unconfigured) . lines
<$> readFileStrict fstab
new <- genFstab (map (top ++) (catMaybes mnts))
swaps (toSysDir top)
writeFile fstab $ unlines $ new ++ old
unconfigured s = "UNCONFIGURED" `isInfixOf` s
allowservices top = nukeFile (top ++ "/usr/sbin/policy-rc.d")
unbootable :: String -> Finalization
unbootable msg = \_ _ -> property desc $ do
warningMessage (desc ++ ": " ++ msg)
return FailedChange
where
desc = "image is not bootable"
grubBooted :: Finalization
grubBooted mnt loopdevs = Grub.bootsMounted mnt wholediskloopdev
`describe` "disk image boots using grub"
where
wholediskloopdev = case loopdevs of
(l:_) -> wholeDiskLoopDev l
[] -> error "No loop devs provided!"
isChild :: FilePath -> Maybe 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
vmdkBuiltFor :: FilePath -> RevertableProperty DebianLike UnixLike
vmdkBuiltFor diskimage = (setup <!> cleanup)
`describe` (vmdkfile ++ " built")
where
vmdkfile = diskimage ++ ".vmdk"
setup = cmdProperty "VBoxManage"
[ "internalcommands", "createrawvmdk"
, "-filename", vmdkfile
, "-rawdisk", diskimage
]
`changesFile` vmdkfile
`onChange` File.mode vmdkfile (combineModes (ownerWriteMode : readModes))
`requires` Apt.installed ["virtualbox"]
`requires` File.notPresent vmdkfile
cleanup = File.notPresent vmdkfile