module Propellor.Property.DiskImage (
module Propellor.Property.DiskImage.PartSpec,
DiskImage,
imageBuilt,
imageRebuilt,
imageBuiltFrom,
imageExists,
Finalization,
grubBooted,
Grub.BIOS(..),
noFinalization,
) where
import Propellor.Base
import Propellor.Property.DiskImage.PartSpec
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, isInfixOf, sortBy)
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 -> Finalization -> [PartSpec] -> RevertableProperty HasInfo
imageBuilt = imageBuilt' False
imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo
imageRebuilt = imageBuilt' True
imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo
imageBuilt' rebuild img mkchroot tabletype final partspec =
imageBuiltFrom img chrootdir tabletype final partspec
`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
&^ Chroot.noServices
& fst final
& Apt.cacheCleaned
imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty NoInfo
imageBuiltFrom img chrootdir tabletype final partspec = 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, mntopts, parttable) = fitChrootSize tabletype partspec $
map (calcsz mnts) mnts
ensureProperty $
imageExists img (partTableSize parttable)
`before`
partitioned YesReallyDeleteDiskContents 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 = File.notPresent img
partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property NoInfo
partitionsPopulated chrootdir mnts mntopts devs = property desc $ mconcat $ zipWith3 go mnts mntopts devs
where
desc = "partitions populated from " ++ chrootdir
go Nothing _ _ = noChange
go (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket
(liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir mntopt)
(const $ liftIO $ umountLazy tmpdir)
$ \ismounted -> if ismounted
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)
, Protect (Pattern "lost+found")
]) childmnts
fitChrootSize :: TableType -> [PartSpec] -> [PartSize] -> ([Maybe MountPoint], [MountOpts], PartTable)
fitChrootSize tt l basesizes = (mounts, mountopts, parttable)
where
(mounts, mountopts, sizers) = unzip3 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 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
type Finalization = (Property NoInfo, (FilePath -> [LoopDev] -> Property NoInfo))
imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property NoInfo
imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) =
property "disk image finalized" $
withTmpDir "mnt" $ \top ->
go top `finally` liftIO (unmountall top)
where
go top = do
liftIO $ mountall top
liftIO $ writefstab top
liftIO $ allowservices top
ensureProperty $ 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")
noFinalization :: Finalization
noFinalization = (doNothing, \_ _ -> doNothing)
grubBooted :: Grub.BIOS -> Finalization
grubBooted bios = (Grub.installed' bios, boots)
where
boots mnt loopdevs = combineProperties "disk image boots using grub"
[ bindMount "/dev" (inmnt "/dev")
, mounted "proc" "proc" (inmnt "/proc") mempty
, mounted "sysfs" "sys" (inmnt "/sys") mempty
, inchroot "update-initramfs" ["-u"]
`assume` MadeChange
, check haveosprober $ inchroot "chmod" ["-x", osprober]
, inchroot "update-grub" []
`assume` MadeChange
, check haveosprober $ inchroot "chmod" ["+x", osprober]
, inchroot "grub-install" [wholediskloopdev]
`assume` MadeChange
, cmdProperty "sync" []
`assume` NoChange
]
where
inmnt f = mnt ++ f
inchroot cmd ps = cmdProperty "chroot" ([mnt, cmd] ++ ps)
haveosprober = doesFileExist (inmnt osprober)
osprober = "/etc/grub.d/30_os-prober"
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