summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2015-10-23 15:43:06 -0400
committerJoey Hess2015-10-23 15:43:06 -0400
commit42ed4b5e68ec84106850c07904ee6124a7805742 (patch)
tree9e49ef3e9a8d02d1951e07d1c31119e5eb7d5844 /src
parent3f17dd7cbef4ec6bbccc368e07be964dc7f9570b (diff)
parent3aee86abac10f1ad9d4b51c024f5f3c02cdbfc68 (diff)
Merge branch 'joeyconfig'
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Property/Chroot.hs70
-rw-r--r--src/Propellor/Property/DiskImage.hs186
-rw-r--r--src/Propellor/Property/DiskImage/PartSpec.hs81
-rw-r--r--src/Propellor/Property/File.hs7
-rw-r--r--src/Propellor/Property/Mount.hs48
-rw-r--r--src/Propellor/Property/OS.hs6
-rw-r--r--src/Propellor/Property/Rsync.hs2
-rw-r--r--src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs8
-rw-r--r--src/Propellor/Property/Systemd.hs18
9 files changed, 238 insertions, 188 deletions
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 2b5391fa..ecac1115 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,14 +216,14 @@ 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
-- /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"
@@ -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/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 97880cf4..90d0bcc6 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
@@ -75,6 +62,7 @@ type DiskImage = FilePath
-- > `setFlag` BootFlag
-- > , partition EXT4 `mountedAt` "/"
-- > `addFreeSpace` MegaBytes 100
+-- > `mountOpt` errorReadonly
-- > , swapPartition (MegaBytes 256)
-- > ]
--
@@ -123,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 $
@@ -160,26 +148,16 @@ 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.
---
--- 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], [MountOpts], PartTable)
+fitChrootSize tt l basesizes = (mounts, mountopts, parttable)
+ where
+ (mounts, mountopts, sizers) = unzip3 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,84 +188,23 @@ 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
--- 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 mount point and a constructor for a Partition.
+-- | Ensures that a disk image file of the specified size exists.
--
--- 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.
+-- 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.
@@ -301,8 +218,8 @@ fitChrootSize tt l basesizes = (mounts, parttable)
-- 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)
@@ -314,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
@@ -353,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
@@ -382,3 +299,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..4b05df03
--- /dev/null
+++ b/src/Propellor/Property/DiskImage/PartSpec.hs
@@ -0,0 +1,81 @@
+-- | 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, 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.
+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, 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, mempty, mkPartition fs)
+
+-- | Specifies where to mount a partition.
+mountedAt :: PartSpec -> FilePath -> PartSpec
+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, 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, o, p) sz = (mp, o, 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, o, p) f = (mp, o, f . p)
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") $
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
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.
--
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)