From a6790167e9ee14d818a88e3f8164cfd7608ec2d5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 23 Oct 2015 13:06:38 -0400 Subject: propellor spin --- src/Propellor/Property/DiskImage.hs | 2 +- src/Propellor/Property/Rsync.hs | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 97880cf4..c8b9ffa1 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -160,7 +160,7 @@ partitionsPopulated chrootdir mnts devs = property desc $ mconcat $ zipWith go m [ Include (Pattern m) , Exclude (filesUnder m) -- Preserve any lost+found directory that mkfs made - , Exclude (Pattern "lost+found") + , Protect (Pattern "lost+found") ]) childmnts -- | Ensures that a disk image file of the specified size exists. diff --git a/src/Propellor/Property/Rsync.hs b/src/Propellor/Property/Rsync.hs index 894b8cc7..cae3c877 100644 --- a/src/Propellor/Property/Rsync.hs +++ b/src/Propellor/Property/Rsync.hs @@ -22,10 +22,12 @@ syncDir = syncDirFiltered [] data Filter = Include Pattern | Exclude Pattern + | Protect Pattern instance RsyncParam Filter where toRsync (Include (Pattern p)) = "--include=" ++ p toRsync (Exclude (Pattern p)) = "--exclude=" ++ p + toRsync (Protect (Pattern p)) = "--filter=P " ++ p -- | A pattern to match against files that rsync is going to transfer. -- -- cgit v1.2.3 From acb7ad7a925b8597af42158d52544aebf89abb0e Mon Sep 17 00:00:00 2001 From: Per Olofsson Date: Fri, 23 Oct 2015 15:54:39 +0200 Subject: Add File.basedOn Signed-off-by: Per Olofsson --- src/Propellor/Property/File.hs | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'src') diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs index 7e421cb7..3476bad0 100644 --- a/src/Propellor/Property/File.hs +++ b/src/Propellor/Property/File.hs @@ -70,6 +70,13 @@ f `lacksLine` l = fileProperty (f ++ " remove: " ++ l) (filter (/= l)) f lacksLines :: FilePath -> [Line] -> Property NoInfo f `lacksLines` ls = fileProperty (f ++ " remove: " ++ show [ls]) (filter (`notElem` ls)) f +-- | Replaces the content of a file with the transformed content of another file +basedOn :: FilePath -> (FilePath, [Line] -> [Line]) -> Property NoInfo +f `basedOn` (f', a) = property desc $ go =<< (liftIO $ readFile f') + where + desc = "replace " ++ f + go tmpl = ensureProperty $ fileProperty desc (\_ -> a $ lines $ tmpl) f + -- | Removes a file. Does not remove symlinks or non-plain-files. notPresent :: FilePath -> Property NoInfo notPresent f = check (doesFileExist f) $ property (f ++ " not present") $ -- cgit v1.2.3 From 1f62b0d3a3d247f16f875f02e5bc89c7b7dc9ace Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 23 Oct 2015 14:18:19 -0400 Subject: Changed how the operating system is provided to Chroot (API change). * Where before debootstrapped and bootstrapped took a System parameter, the os property should now be added to the Chroot. * Follow-on change to Systemd.container, which now takes a System parameter. Two motivations for this change: 1. When using ChrootTarball, there may be no particular System that makes sense for the contents of the tarball, so don't force the user to specify one. 2. When creating a chroot for a disk image with the same properties as an existing Host, using hostProperties host to get them, this allows inheriting the os property from the host, and doesn't require it to be redundantly passed to Chroot.debootstrapped. --- config-joey.hs | 14 ++--- debian/changelog | 4 ++ src/Propellor/Property/Chroot.hs | 68 +++++++++++----------- .../Property/SiteSpecific/GitAnnexBuilder.hs | 8 +-- src/Propellor/Property/Systemd.hs | 18 +++--- 5 files changed, 59 insertions(+), 53 deletions(-) (limited to 'src') diff --git a/config-joey.hs b/config-joey.hs index fce4f7a1..8d6c9f33 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -88,7 +88,8 @@ darkstar = host "darkstar.kitenet.net" , swapPartition (MegaBytes 256) ] where - c d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d + c d = Chroot.debootstrapped mempty d + & os (System (Debian Unstable) "amd64") & Apt.installed ["linux-image-amd64"] & User "root" `User.hasInsecurePassword` "root" @@ -494,14 +495,13 @@ standardSystemUnhardened hn suite arch motd = host hn -- This is my standard container setup, Featuring automatic upgrades. standardContainer :: Systemd.MachineName -> DebianSuite -> Architecture -> Systemd.Container -standardContainer name suite arch = Systemd.container name chroot - & os system - & Apt.stdSourcesList `onChange` Apt.upgrade - & Apt.unattendedUpgrades - & Apt.cacheCleaned +standardContainer name suite arch = + Systemd.container name system (Chroot.debootstrapped mempty) + & Apt.stdSourcesList `onChange` Apt.upgrade + & Apt.unattendedUpgrades + & Apt.cacheCleaned where system = System (Debian suite) arch - chroot = Chroot.debootstrapped system mempty standardStableContainer :: Systemd.MachineName -> Systemd.Container standardStableContainer name = standardContainer name (Stable "jessie") "amd64" diff --git a/debian/changelog b/debian/changelog index 4fbf7157..ada4b1a1 100644 --- a/debian/changelog +++ b/debian/changelog @@ -7,6 +7,10 @@ propellor (2.11.1) UNRELEASED; urgency=medium current mounts. * HostName: Improve domain extraction code. * Add File.basedOn. Thanks, Per Olofsson. + * Changed how the operating system is provided to Chroot (API change). + Where before debootstrapped and bootstrapped took a System parameter, + the os property should now be added to the Chroot. + * Follow-on change to Systemd.container, which now takes a System parameter. -- Joey Hess Thu, 22 Oct 2015 20:24:18 -0400 diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 2b5391fa..f32a9117 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -34,25 +34,26 @@ import System.Posix.Directory -- | Specification of a chroot. Normally you'll use `debootstrapped` or -- `bootstrapped` to construct a Chroot value. data Chroot where - Chroot :: ChrootBootstrapper b => FilePath -> System -> b -> Host -> Chroot + Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot -chrootSystem :: Chroot -> System -chrootSystem (Chroot _ system _ _) = system +chrootSystem :: Chroot -> Maybe System +chrootSystem (Chroot _ _ h) = fromInfoVal (getInfo (hostInfo h)) instance Show Chroot where - show (Chroot loc system _ _) = "Chroot " ++ loc ++ " " ++ show system + show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c) instance PropAccum Chroot where - (Chroot l s c h) `addProp` p = Chroot l s c (h & p) - (Chroot l s c h) `addPropFront` p = Chroot l s c (h `addPropFront` p) - getProperties (Chroot _ _ _ h) = hostProperties h + (Chroot l c h) `addProp` p = Chroot l c (h & p) + (Chroot l c h) `addPropFront` p = Chroot l c (h `addPropFront` p) + getProperties (Chroot _ _ h) = hostProperties h -- | Class of things that can do initial bootstrapping of an operating -- System in a chroot. class ChrootBootstrapper b where -- | Do initial bootstrapping of an operating system in a chroot. - -- If the operating System is not supported, return Nothing. - buildchroot :: b -> System -> FilePath -> Maybe (Property HasInfo) + -- If the operating System is not supported, return + -- Left error message. + buildchroot :: b -> Maybe System -> FilePath -> Either String (Property HasInfo) -- | Use this to bootstrap a chroot by extracting a tarball. -- @@ -63,7 +64,7 @@ class ChrootBootstrapper b where data ChrootTarball = ChrootTarball FilePath instance ChrootBootstrapper ChrootTarball where - buildchroot (ChrootTarball tb) _ loc = Just $ extractTarball loc tb + buildchroot (ChrootTarball tb) _ loc = Right $ extractTarball loc tb extractTarball :: FilePath -> FilePath -> Property HasInfo extractTarball target src = toProp . @@ -83,27 +84,28 @@ data Debootstrapped = Debootstrapped Debootstrap.DebootstrapConfig instance ChrootBootstrapper Debootstrapped where buildchroot (Debootstrapped cf) system loc = case system of - (System (Debian _) _) -> Just debootstrap - (System (Ubuntu _) _) -> Just debootstrap + (Just s@(System (Debian _) _)) -> Right $ debootstrap s + (Just s@(System (Ubuntu _) _)) -> Right $ debootstrap s + Nothing -> Left "Cannot debootstrap; `os` property not specified" where - debootstrap = Debootstrap.built loc system cf + debootstrap s = Debootstrap.built loc s cf -- | Defines a Chroot at the given location, built with debootstrap. -- --- Properties can be added to configure the Chroot. +-- Properties can be added to configure the Chroot. At a minimum, +-- add the `os` property to specify the operating system to bootstrap. -- --- > debootstrapped (System (Debian Unstable) "amd64") Debootstrap.BuildD "/srv/chroot/ghc-dev" +-- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev" +-- > & os (System (Debian Unstable) "amd64") -- > & Apt.installed ["ghc", "haskell-platform"] -- > & ... -debootstrapped :: System -> Debootstrap.DebootstrapConfig -> FilePath -> Chroot -debootstrapped system conf = bootstrapped system (Debootstrapped conf) +debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot +debootstrapped conf = bootstrapped (Debootstrapped conf) -- | Defines a Chroot at the given location, bootstrapped with the -- specified ChrootBootstrapper. -bootstrapped :: ChrootBootstrapper b => System -> b -> FilePath -> Chroot -bootstrapped system bootstrapper location = - Chroot location system bootstrapper h - & os system +bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Chroot +bootstrapped bootstrapper location = Chroot location bootstrapper h where h = Host location [] mempty @@ -117,7 +119,7 @@ provisioned :: Chroot -> RevertableProperty provisioned c = provisioned' (propagateChrootInfo c) c False provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty -provisioned' propigator c@(Chroot loc system bootstrapper _) systemdonly = +provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly = (propigator $ propertyList (chrootDesc c "exists") [setup]) (propertyList (chrootDesc c "removed") [teardown]) @@ -125,18 +127,18 @@ provisioned' propigator c@(Chroot loc system bootstrapper _) systemdonly = setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly `requires` toProp built - built = case buildchroot bootstrapper system loc of - Just p -> p - Nothing -> cantbuild + built = case buildchroot bootstrapper (chrootSystem c) loc of + Right p -> p + Left e -> cantbuild e - cantbuild = infoProperty (chrootDesc c "built") (error $ "cannot bootstrap " ++ show system ++ " using supplied ChrootBootstrapper") mempty [] + cantbuild e = infoProperty (chrootDesc c "built") (error e) mempty [] teardown = check (not <$> unpopulated loc) $ property ("removed " ++ loc) $ makeChange (removeChroot loc) propagateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo -propagateChrootInfo c@(Chroot location _ _ _) p = propagateContainer location c p' +propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c p' where p' = infoProperty (propertyDesc p) @@ -145,12 +147,12 @@ propagateChrootInfo c@(Chroot location _ _ _) p = propagateContainer location c (propertyChildren p) chrootInfo :: Chroot -> Info -chrootInfo (Chroot loc _ _ h) = mempty `addInfo` +chrootInfo (Chroot loc _ h) = mempty `addInfo` mempty { _chroots = M.singleton loc h } -- | Propellor is run inside the chroot to provision it. propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property NoInfo -propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do +propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do let d = localdir shimdir c let me = localdir "propellor" shim <- liftIO $ ifM (doesDirectoryExist d) @@ -189,7 +191,7 @@ propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c " return r toChain :: HostName -> Chroot -> Bool -> IO CmdLine -toChain parenthost (Chroot loc _ _ _) systemdonly = do +toChain parenthost (Chroot loc _ _) systemdonly = do onconsole <- isConsole <$> mkMessageHandle return $ ChrootChain parenthost loc systemdonly onconsole @@ -214,7 +216,7 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) = chain _ _ = errorMessage "bad chain command" inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ()) -inChrootProcess keepprocmounted (Chroot loc _ _ _) cmd = do +inChrootProcess keepprocmounted (Chroot loc _ _) cmd = do mountproc return (proc "chroot" (loc:cmd), cleanup) where @@ -234,10 +236,10 @@ provisioningLock :: FilePath -> FilePath provisioningLock containerloc = "chroot" mungeloc containerloc ++ ".lock" shimdir :: Chroot -> FilePath -shimdir (Chroot loc _ _ _) = "chroot" mungeloc loc ++ ".shim" +shimdir (Chroot loc _ _) = "chroot" mungeloc loc ++ ".shim" mungeloc :: FilePath -> String mungeloc = replace "/" "_" chrootDesc :: Chroot -> String -> String -chrootDesc (Chroot loc _ _ _) desc = "chroot " ++ loc ++ " " ++ desc +chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs index a10e5877..3f7cbad1 100644 --- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -99,13 +99,12 @@ cabalDeps = flagFile go cabalupdated autoBuilderContainer :: (System -> Flavor -> Property HasInfo) -> System -> Flavor -> Times -> TimeOut -> Systemd.Container autoBuilderContainer mkprop osver@(System _ arch) flavor crontime timeout = - Systemd.container name bootstrap + Systemd.container name osver (Chroot.debootstrapped mempty) & mkprop osver flavor & buildDepsApt & autobuilder arch crontime timeout where name = arch ++ fromMaybe "" flavor ++ "-git-annex-builder" - bootstrap = Chroot.debootstrapped osver mempty type Flavor = Maybe String @@ -144,8 +143,7 @@ androidContainer -> Property i -> FilePath -> Systemd.Container -androidContainer name setupgitannexdir gitannexdir = Systemd.container name bootstrap - & os osver +androidContainer name setupgitannexdir gitannexdir = Systemd.container name osver bootstrap & Apt.stdSourcesList & User.accountFor (User builduser) & File.dirExists gitbuilderdir @@ -161,4 +159,4 @@ androidContainer name setupgitannexdir gitannexdir = Systemd.container name boot [ "cd " ++ gitannexdir ++ " && ./standalone/android/buildchroot-inchroot" ] osver = System (Debian (Stable "jessie")) "i386" - bootstrap = Chroot.debootstrapped osver mempty + bootstrap = Chroot.debootstrapped mempty diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs index d5373e15..700bc350 100644 --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -174,21 +174,22 @@ machined = go `describe` "machined installed" Apt.installed ["systemd-container"] _ -> noChange --- | Defines a container with a given machine name. +-- | Defines a container with a given machine name, and operating system, +-- and how to create its chroot if not already present. -- -- Properties can be added to configure the Container. -- --- > container "webserver" (Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty) +-- > container "webserver" (System (Debian Unstable) "amd64") (Chroot.debootstrapped mempty) -- > & Apt.installedRunning "apache2" -- > & ... -container :: MachineName -> (FilePath -> Chroot.Chroot) -> Container -container name mkchroot = Container name c h +container :: MachineName -> System -> (FilePath -> Chroot.Chroot) -> Container +container name system mkchroot = Container name c h & os system & resolvConfed & linkJournal where c = mkchroot (containerDir name) - system = Chroot.chrootSystem c + & os system h = Host name [] mempty -- | Runs a container using systemd-nspawn. @@ -206,7 +207,7 @@ container name mkchroot = Container name c h -- Reverting this property stops the container, removes the systemd unit, -- and deletes the chroot and all its contents. nspawned :: Container -> RevertableProperty -nspawned c@(Container name (Chroot.Chroot loc system builder _) h) = +nspawned c@(Container name (Chroot.Chroot loc builder _) h) = p `describe` ("nspawned " ++ name) where p = enterScript c @@ -226,7 +227,7 @@ nspawned c@(Container name (Chroot.Chroot loc system builder _) h) = doNothing - chroot = Chroot.Chroot loc system builder h + chroot = Chroot.Chroot loc builder h -- | Sets up the service file for the container, and then starts -- it running. @@ -382,7 +383,8 @@ instance Publishable (Proto, Bound Port) where -- > `requires` Systemd.running Systemd.networkd -- > -- > webserver :: Systemd.container --- > webserver = Systemd.container "webserver" (Chroot.debootstrapped (System (Debian Testing) "amd64") mempty) +-- > webserver = Systemd.container "webserver" (Chroot.debootstrapped mempty) +-- > & os (System (Debian Testing) "amd64") -- > & Systemd.privateNetwork -- > & Systemd.running Systemd.networkd -- > & Systemd.publish (Port 80 ->- Port 8080) -- cgit v1.2.3 From c9e408af6ddb296d60c6eeb6cdb3210262dd7cde Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 23 Oct 2015 14:33:10 -0400 Subject: refactor --- propellor.cabal | 1 + src/Propellor/Property/DiskImage.hs | 140 ++++++++------------------- src/Propellor/Property/DiskImage/PartSpec.hs | 65 +++++++++++++ 3 files changed, 105 insertions(+), 101 deletions(-) create mode 100644 src/Propellor/Property/DiskImage/PartSpec.hs (limited to 'src') diff --git a/propellor.cabal b/propellor.cabal index 9853b604..8a466a28 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -84,6 +84,7 @@ Library Propellor.Property.DebianMirror Propellor.Property.Debootstrap Propellor.Property.DiskImage + Propellor.Property.DiskImage.PartSpec Propellor.Property.Dns Propellor.Property.DnsSec Propellor.Property.Docker diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index c8b9ffa1..979a3e6a 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -5,28 +5,14 @@ -- TODO avoid starting services while populating chroot and running final module Propellor.Property.DiskImage ( + -- * Partition specification + module Propellor.Property.DiskImage.PartSpec, -- * Properties DiskImage, imageBuilt, imageRebuilt, imageBuiltFrom, imageExists, - -- * Partitioning - Partition, - PartSize(..), - Fs(..), - PartSpec, - MountPoint, - swapPartition, - partition, - mountedAt, - addFreeSpace, - setSize, - PartFlag(..), - setFlag, - TableType(..), - extended, - adjustp, -- * Finalization Finalization, grubBooted, @@ -35,6 +21,7 @@ module Propellor.Property.DiskImage ( ) 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 @@ -163,23 +150,13 @@ partitionsPopulated chrootdir mnts devs = property desc $ mconcat $ zipWith go m , Protect (Pattern "lost+found") ]) childmnts --- | Ensures that a disk image file of the specified size exists. --- --- If the file doesn't exist, or is too small, creates a new one, full of 0's. --- --- If the file is too large, truncates it down to the specified size. -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 +-- The constructor for each Partition is passed the size of the files +-- from the chroot that will be put in that partition. +fitChrootSize :: TableType -> [PartSpec] -> [PartSize] -> ([Maybe MountPoint], PartTable) +fitChrootSize tt l basesizes = (mounts, parttable) + where + (mounts, sizers) = unzip l + parttable = PartTable tt (zipWith id sizers basesizes) -- | Generates a map of the sizes of the contents of -- every directory in a filesystem tree. @@ -210,22 +187,6 @@ getMountSz szm l (Just mntpt) = where childsz = mconcat $ mapMaybe (getMountSz szm l) (filter (isChild mntpt) l) -isChild :: FilePath -> Maybe MountPoint -> Bool -isChild mntpt (Just d) - | d `equalFilePath` mntpt = False - | otherwise = mntpt `dirContains` d -isChild _ Nothing = False - --- | From a location in a chroot (eg, /tmp/chroot/usr) to --- the corresponding location inside (eg, /usr). -toSysDir :: FilePath -> FilePath -> FilePath -toSysDir chrootdir d = case makeRelative chrootdir d of - "." -> "/" - sysdir -> "/" ++ sysdir - -defSz :: PartSize -defSz = MegaBytes 128 - -- Add 2% for filesystem overhead. Rationalle for picking 2%: -- A filesystem with 1% overhead might just sneak by as acceptable. -- Double that just in case. Add an additional 3 mb to deal with @@ -234,60 +195,24 @@ defSz = MegaBytes 128 fudge :: PartSize -> PartSize fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200) --- | Specifies a mount point and a constructor for a Partition. --- --- The size that is eventually provided is the amount of space needed to --- hold the files that appear in the directory where the partition is to be --- mounted. Plus a fudge factor, since filesystems have some space --- overhead. --- --- (Partitions that are not to be mounted (ie, LinuxSwap), or that have --- no corresponding directory in the chroot will have 128 MegaBytes --- provided as a default size.) -type PartSpec = (Maybe MountPoint, PartSize -> Partition) --- | Specifies a swap partition of a given size. -swapPartition :: PartSize -> PartSpec -swapPartition sz = (Nothing, const (mkPartition LinuxSwap sz)) - --- | Specifies a partition with a given filesystem. +-- | Ensures that a disk image file of the specified size exists. +-- +-- If the file doesn't exist, or is too small, creates a new one, full of 0's. -- --- The partition is not mounted anywhere by default; use the combinators --- below to configure it. -partition :: Fs -> PartSpec -partition fs = (Nothing, mkPartition fs) - --- | Specifies where to mount a partition. -mountedAt :: PartSpec -> FilePath -> PartSpec -mountedAt (_, p) mp = (Just mp, p) - --- | Adds additional free space to the partition. -addFreeSpace :: PartSpec -> PartSize -> PartSpec -addFreeSpace (mp, p) freesz = (mp, \sz -> p (sz <> freesz)) - --- | Forced a partition to be a specific size, instead of scaling to the --- size needed for the files in the chroot. -setSize :: PartSpec -> PartSize -> PartSpec -setSize (mp, p) sz = (mp, const (p sz)) - --- | Sets a flag on the partition. -setFlag :: PartSpec -> PartFlag -> PartSpec -setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p } - --- | Makes a MSDOS partition be Extended, rather than Primary. -extended :: PartSpec -> PartSpec -extended s = adjustp s $ \p -> p { partType = Extended } - -adjustp :: PartSpec -> (Partition -> Partition) -> PartSpec -adjustp (mp, p) f = (mp, f . p) - --- | The constructor for each Partition is passed the size of the files --- from the chroot that will be put in that partition. -fitChrootSize :: TableType -> [PartSpec] -> [PartSize] -> ([Maybe MountPoint], PartTable) -fitChrootSize tt l basesizes = (mounts, parttable) - where - (mounts, sizers) = unzip l - parttable = PartTable tt (zipWith id sizers basesizes) +-- If the file is too large, truncates it down to the specified size. +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 -- | A pair of properties. The first property is satisfied within the -- chroot, and is typically used to download the boot loader. @@ -382,3 +307,16 @@ grubBooted bios = (Grub.installed' bios, boots) 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 + +-- | From a location in a chroot (eg, /tmp/chroot/usr) to +-- the corresponding location inside (eg, /usr). +toSysDir :: FilePath -> FilePath -> FilePath +toSysDir chrootdir d = case makeRelative chrootdir d of + "." -> "/" + sysdir -> "/" ++ sysdir diff --git a/src/Propellor/Property/DiskImage/PartSpec.hs b/src/Propellor/Property/DiskImage/PartSpec.hs new file mode 100644 index 00000000..1bd4fb01 --- /dev/null +++ b/src/Propellor/Property/DiskImage/PartSpec.hs @@ -0,0 +1,65 @@ +-- | Disk image partition specification and combinators. + +module Propellor.Property.DiskImage.PartSpec ( + module Propellor.Property.DiskImage.PartSpec, + Partition, + PartSize(..), + PartFlag(..), + TableType(..), + Fs(..), + MountPoint, +) where + +import Propellor.Base +import Propellor.Property.Parted +import Propellor.Property.Mount + +-- | Specifies a mount point and a constructor for a Partition. +-- +-- The size that is eventually provided is the amount of space needed to +-- hold the files that appear in the directory where the partition is to be +-- mounted. Plus a fudge factor, since filesystems have some space +-- overhead. +-- +-- (Partitions that are not to be mounted (ie, LinuxSwap), or that have +-- no corresponding directory in the chroot will have 128 MegaBytes +-- provided as a default size.) +type PartSpec = (Maybe MountPoint, PartSize -> Partition) + +defSz :: PartSize +defSz = MegaBytes 128 + +-- | Specifies a swap partition of a given size. +swapPartition :: PartSize -> PartSpec +swapPartition sz = (Nothing, const (mkPartition LinuxSwap sz)) + +-- | Specifies a partition with a given filesystem. +-- +-- The partition is not mounted anywhere by default; use the combinators +-- below to configure it. +partition :: Fs -> PartSpec +partition fs = (Nothing, mkPartition fs) + +-- | Specifies where to mount a partition. +mountedAt :: PartSpec -> FilePath -> PartSpec +mountedAt (_, p) mp = (Just mp, p) + +-- | Adds additional free space to the partition. +addFreeSpace :: PartSpec -> PartSize -> PartSpec +addFreeSpace (mp, p) freesz = (mp, \sz -> p (sz <> freesz)) + +-- | Forced a partition to be a specific size, instead of scaling to the +-- size needed for the files in the chroot. +setSize :: PartSpec -> PartSize -> PartSpec +setSize (mp, p) sz = (mp, const (p sz)) + +-- | Sets a flag on the partition. +setFlag :: PartSpec -> PartFlag -> PartSpec +setFlag s f = adjustp s $ \p -> p { partFlags = (f, True):partFlags p } + +-- | Makes a MSDOS partition be Extended, rather than Primary. +extended :: PartSpec -> PartSpec +extended s = adjustp s $ \p -> p { partType = Extended } + +adjustp :: PartSpec -> (Partition -> Partition) -> PartSpec +adjustp (mp, p) f = (mp, f . p) -- cgit v1.2.3 From e9fdfd5de1546f880d3bc8868a235a68f5f01e54 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 23 Oct 2015 15:14:00 -0400 Subject: allow specifying filesystem mount options --- src/Propellor/Property/Chroot.hs | 2 +- src/Propellor/Property/DiskImage.hs | 52 ++++++++++++---------------- src/Propellor/Property/DiskImage/PartSpec.hs | 40 ++++++++++++++------- src/Propellor/Property/Mount.hs | 48 +++++++++++++++++++------ src/Propellor/Property/OS.hs | 6 ++-- 5 files changed, 92 insertions(+), 56 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index f32a9117..ecac1115 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -223,7 +223,7 @@ inChrootProcess keepprocmounted (Chroot loc _ _) cmd = do -- /proc needs to be mounted in the chroot for the linker to use -- /proc/self/exe which is necessary for some commands to work mountproc = unlessM (elem procloc <$> mountPointsBelow loc) $ - void $ mount "proc" "proc" procloc + void $ mount "proc" "proc" procloc mempty procloc = loc "proc" diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 979a3e6a..90d0bcc6 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -62,6 +62,7 @@ type DiskImage = FilePath -- > `setFlag` BootFlag -- > , partition EXT4 `mountedAt` "/" -- > `addFreeSpace` MegaBytes 100 +-- > `mountOpt` errorReadonly -- > , swapPartition (MegaBytes 256) -- > ] -- @@ -110,28 +111,28 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg rmimg <$> liftIO (dirSizes chrootdir) let calcsz mnts = maybe defSz fudge . getMountSz szm mnts -- tie the knot! - let (mnts, parttable) = fitChrootSize tabletype partspec $ + 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 parttable) - mkimg' mnts parttable devs = - partitionsPopulated chrootdir mnts devs + kpartx img (mkimg' mnts mntopts parttable) + mkimg' mnts mntopts parttable devs = + partitionsPopulated chrootdir mnts mntopts devs `before` - imageFinalized final mnts devs parttable + imageFinalized final mnts mntopts devs parttable rmimg = File.notPresent img -partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [LoopDev] -> Property NoInfo -partitionsPopulated chrootdir mnts devs = property desc $ mconcat $ zipWith go mnts devs +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) loopdev = withTmpDir "mnt" $ \tmpdir -> bracket - (liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir) + 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 $ @@ -152,10 +153,10 @@ partitionsPopulated chrootdir mnts devs = property desc $ mconcat $ zipWith go m -- The constructor for each Partition is passed the size of the files -- from the chroot that will be put in that partition. -fitChrootSize :: TableType -> [PartSpec] -> [PartSize] -> ([Maybe MountPoint], PartTable) -fitChrootSize tt l basesizes = (mounts, parttable) +fitChrootSize :: TableType -> [PartSpec] -> [PartSize] -> ([Maybe MountPoint], [MountOpts], PartTable) +fitChrootSize tt l basesizes = (mounts, mountopts, parttable) where - (mounts, sizers) = unzip l + (mounts, mountopts, sizers) = unzip3 l parttable = PartTable tt (zipWith id sizers basesizes) -- | Generates a map of the sizes of the contents of @@ -187,15 +188,6 @@ getMountSz szm l (Just mntpt) = where childsz = mconcat $ mapMaybe (getMountSz szm l) (filter (isChild mntpt) l) --- Add 2% for filesystem overhead. Rationalle for picking 2%: --- A filesystem with 1% overhead might just sneak by as acceptable. --- Double that just in case. Add an additional 3 mb to deal with --- non-scaling overhead of filesystems (eg, superblocks). --- Add an additional 200 mb for temp files, journals, etc. -fudge :: PartSize -> PartSize -fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200) - - -- | Ensures that a disk image file of the specified size exists. -- -- If the file doesn't exist, or is too small, creates a new one, full of 0's. @@ -226,8 +218,8 @@ imageExists img sz = property ("disk image exists" ++ img) $ liftIO $ do -- in the partition tree. type Finalization = (Property NoInfo, (FilePath -> [LoopDev] -> Property NoInfo)) -imageFinalized :: Finalization -> [Maybe MountPoint] -> [LoopDev] -> PartTable -> Property NoInfo -imageFinalized (_, final) mnts devs (PartTable _ parts) = +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) @@ -239,19 +231,19 @@ imageFinalized (_, final) mnts devs (PartTable _ parts) = -- Ordered lexographically by mount point, so / comes before /usr -- comes before /usr/local - orderedmntsdevs :: [(Maybe MountPoint, LoopDev)] - orderedmntsdevs = sortBy (compare `on` fst) $ zip mnts 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, loopdev) -> case mp of + 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) $ + unlessM (mount "auto" (partitionLoopDev loopdev) mnt mopts) $ error $ "failed mounting " ++ mnt unmountall top = do @@ -278,8 +270,8 @@ grubBooted bios = (Grub.installed' bios, boots) boots mnt loopdevs = combineProperties "disk image boots using grub" -- bind mount host /dev so grub can access the loop devices [ bindMount "/dev" (inmnt "/dev") - , mounted "proc" "proc" (inmnt "/proc") - , mounted "sysfs" "sys" (inmnt "/sys") + , mounted "proc" "proc" (inmnt "/proc") mempty + , mounted "sysfs" "sys" (inmnt "/sys") mempty -- update the initramfs so it gets the uuid of the root partition , inchroot "update-initramfs" ["-u"] -- work around for http://bugs.debian.org/802717 diff --git a/src/Propellor/Property/DiskImage/PartSpec.hs b/src/Propellor/Property/DiskImage/PartSpec.hs index 1bd4fb01..4b05df03 100644 --- a/src/Propellor/Property/DiskImage/PartSpec.hs +++ b/src/Propellor/Property/DiskImage/PartSpec.hs @@ -14,44 +14,60 @@ import Propellor.Base import Propellor.Property.Parted import Propellor.Property.Mount --- | Specifies a mount point and a constructor for a Partition. +-- | Specifies a mount point, mount options, and a constructor for a Partition. -- -- The size that is eventually provided is the amount of space needed to -- hold the files that appear in the directory where the partition is to be -- mounted. Plus a fudge factor, since filesystems have some space -- overhead. --- --- (Partitions that are not to be mounted (ie, LinuxSwap), or that have --- no corresponding directory in the chroot will have 128 MegaBytes --- provided as a default size.) -type PartSpec = (Maybe MountPoint, PartSize -> Partition) +type PartSpec = (Maybe MountPoint, MountOpts, PartSize -> Partition) +-- | Partitions that are not to be mounted (ie, LinuxSwap), or that have +-- no corresponding directory in the chroot will have 128 MegaBytes +-- provided as a default size. defSz :: PartSize defSz = MegaBytes 128 +-- | Add 2% for filesystem overhead. Rationalle for picking 2%: +-- A filesystem with 1% overhead might just sneak by as acceptable. +-- Double that just in case. Add an additional 3 mb to deal with +-- non-scaling overhead of filesystems (eg, superblocks). +-- Add an additional 200 mb for temp files, journals, etc. +fudge :: PartSize -> PartSize +fudge (MegaBytes n) = MegaBytes (n + n `div` 100 * 2 + 3 + 200) + -- | Specifies a swap partition of a given size. swapPartition :: PartSize -> PartSpec -swapPartition sz = (Nothing, const (mkPartition LinuxSwap sz)) +swapPartition sz = (Nothing, mempty, const (mkPartition LinuxSwap sz)) -- | Specifies a partition with a given filesystem. -- -- The partition is not mounted anywhere by default; use the combinators -- below to configure it. partition :: Fs -> PartSpec -partition fs = (Nothing, mkPartition fs) +partition fs = (Nothing, mempty, mkPartition fs) -- | Specifies where to mount a partition. mountedAt :: PartSpec -> FilePath -> PartSpec -mountedAt (_, p) mp = (Just mp, p) +mountedAt (_, o, p) mp = (Just mp, o, p) + +-- | Specifies a mount option, such as "noexec" +mountOpt :: ToMountOpts o => PartSpec -> o -> PartSpec +mountOpt (mp, o, p) o' = (mp, o <> toMountOpts o', p) + +-- | Mount option to make a partition be remounted readonly when there's an +-- error accessing it. +errorReadonly :: MountOpts +errorReadonly = toMountOpts "errors=remount-ro" -- | Adds additional free space to the partition. addFreeSpace :: PartSpec -> PartSize -> PartSpec -addFreeSpace (mp, p) freesz = (mp, \sz -> p (sz <> freesz)) +addFreeSpace (mp, o, p) freesz = (mp, o, \sz -> p (sz <> freesz)) -- | Forced a partition to be a specific size, instead of scaling to the -- size needed for the files in the chroot. setSize :: PartSpec -> PartSize -> PartSpec -setSize (mp, p) sz = (mp, const (p sz)) +setSize (mp, o, p) sz = (mp, o, const (p sz)) -- | Sets a flag on the partition. setFlag :: PartSpec -> PartFlag -> PartSpec @@ -62,4 +78,4 @@ extended :: PartSpec -> PartSpec extended s = adjustp s $ \p -> p { partType = Extended } adjustp :: PartSpec -> (Partition -> Partition) -> PartSpec -adjustp (mp, p) f = (mp, f . p) +adjustp (mp, o, p) f = (mp, o, f . p) diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs index a08f9e3b..3f13388b 100644 --- a/src/Propellor/Property/Mount.hs +++ b/src/Propellor/Property/Mount.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeSynonymInstances, FlexibleInstances #-} + module Propellor.Property.Mount where import Propellor.Base @@ -8,16 +10,36 @@ import Data.Char import Data.List import Utility.Table -type FsType = String -- ^ type of filesystem to mount ("auto" to autodetect) +-- | type of filesystem to mount ("auto" to autodetect) +type FsType = String +-- | A device or other thing to be mounted. type Source = String +-- | A mount point for a filesystem. type MountPoint = FilePath +-- | Filesystem mount options. Eg, "errors=remount-ro" +newtype MountOpts = MountOpts [String] + deriving Monoid + +class ToMountOpts a where + toMountOpts :: a -> MountOpts + +instance ToMountOpts MountOpts where + toMountOpts = id + +instance ToMountOpts String where + toMountOpts s = MountOpts [s] + +formatMountOpts :: MountOpts -> String +formatMountOpts (MountOpts []) = "defaults" +formatMountOpts (MountOpts l) = intercalate "," l + -- | Mounts a device. -mounted :: FsType -> Source -> MountPoint -> Property NoInfo -mounted fs src mnt = property (mnt ++ " mounted") $ - toResult <$> liftIO (mount fs src mnt) +mounted :: FsType -> Source -> MountPoint -> MountOpts -> Property NoInfo +mounted fs src mnt opts = property (mnt ++ " mounted") $ + toResult <$> liftIO (mount fs src mnt opts) -- | Bind mounts the first directory so its contents also appear -- in the second directory. @@ -25,8 +47,13 @@ bindMount :: FilePath -> FilePath -> Property NoInfo bindMount src dest = cmdProperty "mount" ["--bind", src, dest] `describe` ("bind mounted " ++ src ++ " to " ++ dest) -mount :: FsType -> Source -> MountPoint -> IO Bool -mount fs src mnt = boolSystem "mount" [Param "-t", Param fs, Param src, Param mnt] +mount :: FsType -> Source -> MountPoint -> MountOpts -> IO Bool +mount fs src mnt opts = boolSystem "mount" $ + [ Param "-t", Param fs + , Param "-o", Param (formatMountOpts opts) + , Param src + , Param mnt + ] newtype SwapPartition = SwapPartition FilePath @@ -64,7 +91,7 @@ genFstab mnts swaps mnttransform = do ] , pure (mnttransform mnt) , fromMaybe "auto" <$> getFsType mnt - , fromMaybe "defaults" <$> getFsOptions mnt + , formatMountOpts <$> getFsMountOpts mnt , pure "0" , pure (if mnt == "/" then "1" else "2") ] @@ -75,7 +102,7 @@ genFstab mnts swaps mnttransform = do ] , pure "none" , pure "swap" - , pure "defaults" + , pure (formatMountOpts mempty) , pure "0" , pure "0" ] @@ -115,8 +142,9 @@ getFsType :: MountPoint -> IO (Maybe FsType) getFsType = findmntField "fstype" -- | Mount options for the filesystem mounted at a given location. -getFsOptions :: MountPoint -> IO (Maybe String) -getFsOptions = findmntField "fs-options" +getFsMountOpts :: MountPoint -> IO MountOpts +getFsMountOpts p = maybe mempty toMountOpts + <$> findmntField "fs-options" p type UUID = String diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs index e176e33d..1f22888c 100644 --- a/src/Propellor/Property/OS.hs +++ b/src/Propellor/Property/OS.hs @@ -123,16 +123,16 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ -- Remount /dev, so that block devices etc are -- available for other properties to use. - unlessM (mount devfstype devfstype "/dev") $ do + unlessM (mount devfstype devfstype "/dev" mempty) $ do warningMessage $ "failed mounting /dev using " ++ devfstype ++ "; falling back to MAKEDEV generic" void $ boolSystem "sh" [Param "-c", Param "cd /dev && /sbin/MAKEDEV generic"] -- Mount /sys too, needed by eg, grub-mkconfig. - unlessM (mount "sysfs" "sysfs" "/sys") $ + unlessM (mount "sysfs" "sysfs" "/sys" mempty) $ warningMessage "failed mounting /sys" -- And /dev/pts, used by apt. - unlessM (mount "devpts" "devpts" "/dev/pts") $ + unlessM (mount "devpts" "devpts" "/dev/pts" mempty) $ warningMessage "failed mounting /dev/pts" return MadeChange -- cgit v1.2.3