summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2015-10-23 01:27:51 -0400
committerJoey Hess2015-10-23 01:27:51 -0400
commiteca865628c2cae8996854d596dfee0dea4ef17c2 (patch)
treed30425bf0630173bc17be40c5ca8283b2a3897f6 /src
parentbf25cb287bcec0b85f64c90a88a4556291efe74a (diff)
parent1a55d09b5452f07508d4624b632e9a54782dbee8 (diff)
Merge branch 'joeyconfig'
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Property/Chroot.hs28
-rw-r--r--src/Propellor/Property/DiskImage.hs122
-rw-r--r--src/Propellor/Property/Grub.hs19
-rw-r--r--src/Propellor/Property/Mount.hs10
-rw-r--r--src/Propellor/Property/Parted.hs2
-rw-r--r--src/Propellor/Property/Partition.hs42
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs2
-rw-r--r--src/Propellor/Property/Ssh.hs1
-rw-r--r--src/Propellor/Property/User.hs19
9 files changed, 194 insertions, 51 deletions
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 7ec2010c..d17edae7 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -4,6 +4,7 @@ module Propellor.Property.Chroot (
Chroot(..),
ChrootBootstrapper(..),
Debootstrapped(..),
+ ChrootTarball(..),
debootstrapped,
bootstrapped,
provisioned,
@@ -22,6 +23,7 @@ import Propellor.Types.Info
import Propellor.Property.Chroot.Util
import qualified Propellor.Property.Debootstrap as Debootstrap
import qualified Propellor.Property.Systemd.Core as Systemd
+import qualified Propellor.Property.File as File
import qualified Propellor.Shim as Shim
import Propellor.Property.Mount
@@ -52,7 +54,31 @@ class ChrootBootstrapper b where
-- If the operating System is not supported, return Nothing.
buildchroot :: b -> System -> FilePath -> Maybe (Property HasInfo)
--- | Use to bootstrap a chroot with debootstrap.
+-- | Use this to bootstrap a chroot by extracting a tarball.
+--
+-- The tarball is expected to contain a root directory (no top-level
+-- directory, also known as a "tarbomb").
+-- It may be optionally compressed with any format `tar` knows how to
+-- detect automatically.
+data ChrootTarball = ChrootTarball FilePath
+
+instance ChrootBootstrapper ChrootTarball where
+ buildchroot (ChrootTarball tb) _ loc = Just $ extractTarball loc tb
+
+extractTarball :: FilePath -> FilePath -> Property HasInfo
+extractTarball target src = toProp .
+ check (unpopulated target) $
+ cmdProperty "tar" params
+ `requires` File.dirExists target
+ where
+ params =
+ [ "-C"
+ , target
+ , "-xf"
+ , src
+ ]
+
+-- | Use this to bootstrap a chroot with debootstrap.
data Debootstrapped = Debootstrapped Debootstrap.DebootstrapConfig
instance ChrootBootstrapper Debootstrapped where
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index 8d503e28..1e3a5407 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -2,8 +2,6 @@
--
-- This module is designed to be imported unqualified.
--
--- TODO run final
---
-- TODO avoid starting services while populating chroot and running final
module Propellor.Property.DiskImage (
@@ -49,7 +47,8 @@ import Propellor.Property.Partition
import Propellor.Property.Rsync
import Utility.Path
-import Data.List (isPrefixOf)
+import Data.List (isPrefixOf, sortBy)
+import Data.Function (on)
import qualified Data.Map.Strict as M
import qualified Data.ByteString.Lazy as L
import System.Posix.Files
@@ -70,25 +69,26 @@ type DiskImage = FilePath
-- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d
-- > & Apt.installed ["linux-image-amd64"]
-- > & ...
--- > in imageBuilt "/srv/images/foo.img" chroot MSDOS
+-- > in imageBuilt "/srv/images/foo.img" chroot
+-- > MSDOS (grubBooted PC)
-- > [ partition EXT2 `mountedAt` "/boot"
-- > `setFlag` BootFlag
-- > , partition EXT4 `mountedAt` "/"
-- > `addFreeSpace` MegaBytes 100
-- > , swapPartition (MegaBytes 256)
--- > ] (grubBooted PC)
-imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty
+-- > ]
+imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty
imageBuilt = imageBuilt' False
-- | Like 'built', but the chroot is deleted and rebuilt from scratch each
-- time. This is more expensive, but useful to ensure reproducible results
-- when the properties of the chroot have been changed.
-imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> [PartSpec] -> Finalization -> RevertableProperty
+imageRebuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> 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)
+imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty
+imageBuilt' rebuild img mkchroot tabletype final partspec =
+ imageBuiltFrom img chrootdir tabletype final partspec
`requires` Chroot.provisioned chroot
`requires` (cleanrebuild <!> doNothing)
`describe` desc
@@ -107,10 +107,8 @@ imageBuilt' rebuild img mkchroot tabletype partspec final =
& Apt.cacheCleaned
-- | Builds a disk image from the contents of a chroot.
---
--- The passed property is run inside the mounted disk image.
-imageBuiltFrom :: DiskImage -> FilePath -> TableType -> [PartSpec] -> Property NoInfo -> RevertableProperty
-imageBuiltFrom img chrootdir tabletype partspec final = mkimg <!> rmimg
+imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty
+imageBuiltFrom img chrootdir tabletype final partspec = mkimg <!> rmimg
where
desc = img ++ " built from " ++ chrootdir
mkimg = property desc $ do
@@ -121,25 +119,30 @@ imageBuiltFrom img chrootdir tabletype partspec final = mkimg <!> rmimg
<$> liftIO (dirSizes chrootdir)
let calcsz mnts = maybe defSz fudge . getMountSz szm mnts
-- tie the knot!
- let (mnts, t) = fitChrootSize tabletype partspec (map (calcsz mnts) 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)
+ kpartx img (mkimg' mnts)
+ mkimg' mnts devs =
+ partitionsPopulated chrootdir mnts devs
+ `before`
+ imageFinalized final mnts devs
rmimg = File.notPresent img
-partitionsPopulated :: FilePath -> [MountPoint] -> [FilePath] -> Property NoInfo
+partitionsPopulated :: FilePath -> [MountPoint] -> [LoopDev] -> 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)
+ go (Just mnt) loopdev = withTmpDir "mnt" $ \tmpdir -> bracket
+ (liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir)
(const $ liftIO $ umountLazy tmpdir)
- $ \mounted -> if mounted
+ $ \ismounted -> if ismounted
then ensureProperty $
syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir
else return FailedChange
@@ -284,15 +287,76 @@ fitChrootSize tt l basesizes = (mounts, parttable)
-- | A pair of properties. The first property is satisfied within the
-- chroot, and is typically used to download the boot loader.
--- The second property is satisfied chrooted into the resulting
--- disk image, and will typically take care of installing the boot loader
--- to the disk image.
-type Finalization = (Property NoInfo, Property NoInfo)
+--
+-- The second property is run after the disk image is created,
+-- with its populated partition tree mounted in the provided
+-- location from the provided loop devices. This will typically
+-- take care of installing the boot loader to the image.
+--
+-- It's ok if the second property leaves additional things mounted
+-- in the partition tree.
+type Finalization = (Property NoInfo, (FilePath -> [LoopDev] -> Property NoInfo))
+
+imageFinalized :: Finalization -> [MountPoint] -> [LoopDev] -> Property NoInfo
+imageFinalized (_, final) mnts devs = property "disk image finalized" $
+ withTmpDir "mnt" $ \top ->
+ go top `finally` liftIO (unmountall top)
+ where
+ go mnt = do
+ liftIO $ mountall mnt
+ ensureProperty $ final mnt devs
+
+ -- Ordered lexographically by mount point, so / comes before /usr
+ -- comes before /usr/local
+ orderedmntsdevs :: [(MountPoint, LoopDev)]
+ orderedmntsdevs = sortBy (compare `on` fst) $ zip mnts devs
+
+ mountall top = forM_ orderedmntsdevs $ \(mp, loopdev) -> case mp of
+ Nothing -> noop
+ Just p -> do
+ let mnt = top ++ p
+ createDirectoryIfMissing True mnt
+ unlessM (mount "auto" (partitionLoopDev loopdev) mnt) $
+ error $ "failed mounting " ++ mnt
+
+ unmountall top = do
+ unmountBelow top
+ umountLazy top
+
+noFinalization :: Finalization
+noFinalization = (doNothing, \_ _ -> doNothing)
-- | Makes grub be the boot loader of the disk image.
--- TODO not implemented
grubBooted :: Grub.BIOS -> Finalization
-grubBooted bios = (Grub.installed bios, undefined)
-
-noFinalization :: Finalization
-noFinalization = (doNothing, doNothing)
+grubBooted bios = (Grub.installed' bios, boots)
+ where
+ 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")
+ -- work around for http://bugs.debian.org/802717
+ , check haveosprober $ inchroot "chmod" ["-x", osprober]
+ , inchroot "update-grub" []
+ , check haveosprober $ inchroot "chmod" ["+x", osprober]
+ , inchroot "grub-install" [wholediskloopdev]
+ -- sync all buffered changes out to the disk image
+ -- may not be necessary, but seemed needed sometimes
+ -- when using the disk image right away.
+ , cmdProperty "sync" []
+ ]
+ where
+ -- cannot use </> since the filepath is absolute
+ inmnt f = mnt ++ f
+
+ inchroot cmd ps = cmdProperty "chroot" ([mnt, cmd] ++ ps)
+
+ haveosprober = doesFileExist (inmnt osprober)
+ osprober = "/etc/grub.d/30_os-prober"
+
+ -- It doesn't matter which loopdev we use; all
+ -- come from the same disk image, and it's the loop dev
+ -- for the whole disk image we seek.
+ wholediskloopdev = case loopdevs of
+ (l:_) -> wholeDiskLoopDev l
+ [] -> error "No loop devs provided!"
diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs
index 6b763d08..ea54295b 100644
--- a/src/Propellor/Property/Grub.hs
+++ b/src/Propellor/Property/Grub.hs
@@ -18,14 +18,19 @@ data BIOS = PC | EFI64 | EFI32 | Coreboot | Xen
-- | Installs the grub package. This does not make grub be used as the
-- bootloader.
--
--- This includes running update-grub, so that the grub boot menu is
--- created. It will be automatically updated when kernel packages are
--- installed.
+-- This includes running update-grub.
installed :: BIOS -> Property NoInfo
-installed bios =
- Apt.installed [pkg] `describe` "grub package installed"
- `before`
- cmdProperty "update-grub" []
+installed bios = installed' bios `before` mkConfig
+
+-- Run update-grub, to generate the grub boot menu. It will be
+-- automatically updated when kernel packages are
+-- -- installed.
+mkConfig :: Property NoInfo
+mkConfig = cmdProperty "update-grub" []
+
+-- | Installs grub; does not run update-grub.
+installed' :: BIOS -> Property NoInfo
+installed' bios = Apt.installed [pkg] `describe` "grub package installed"
where
pkg = case bios of
PC -> "grub-pc"
diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs
index 30d057f5..09016011 100644
--- a/src/Propellor/Property/Mount.hs
+++ b/src/Propellor/Property/Mount.hs
@@ -36,5 +36,15 @@ unmountBelow d = do
forM_ submnts umountLazy
-- | Mounts a device.
+mounted :: FsType -> Source -> FilePath -> Property NoInfo
+mounted fs src mnt = property (mnt ++ " mounted") $
+ toResult <$> liftIO (mount fs src mnt)
+
+-- | Bind mounts the first directory so its contents also appear
+-- in the second directory.
+bindMount :: FilePath -> FilePath -> Property NoInfo
+bindMount src dest = cmdProperty "mount" ["--bind", src, dest]
+ `describe` ("bind mounted " ++ src ++ " to " ++ dest)
+
mount :: FsType -> Source -> FilePath -> IO Bool
mount fs src mnt = boolSystem "mount" [Param "-t", Param fs, Param src, Param mnt]
diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs
index 7bd38a65..834b6c7d 100644
--- a/src/Propellor/Property/Parted.hs
+++ b/src/Propellor/Property/Parted.hs
@@ -160,7 +160,7 @@ partitioned eep disk (PartTable tabletype parts) = property desc $ do
[ parted eep disk partedparams
, if isdev
then formatl (map (\n -> disk ++ show n) [1 :: Int ..])
- else Partition.kpartx disk formatl
+ else Partition.kpartx disk (formatl . map Partition.partitionLoopDev)
]
where
desc = disk ++ " partitioned"
diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs
index 56bc1575..fd3c7930 100644
--- a/src/Propellor/Property/Partition.hs
+++ b/src/Propellor/Property/Partition.hs
@@ -4,6 +4,10 @@ module Propellor.Property.Partition where
import Propellor.Base
import qualified Propellor.Property.Apt as Apt
+import Utility.Applicative
+
+import System.Posix.Files
+import Data.List
-- | Filesystems etc that can be used for a partition.
data Fs = EXT2 | EXT3 | EXT4 | BTRFS | REISERFS | XFS | FAT | VFAT | NTFS | LinuxSwap
@@ -41,20 +45,44 @@ formatted' opts YesReallyFormatPartition fs dev =
-- Be quiet.
q l = "-q":l
+data LoopDev = LoopDev
+ { partitionLoopDev :: FilePath -- ^ device for a loop partition
+ , wholeDiskLoopDev :: FilePath -- ^ corresponding device for the whole loop disk
+ } deriving (Show)
+
+isLoopDev :: LoopDev -> IO Bool
+isLoopDev l = isLoopDev' (partitionLoopDev l) <&&> isLoopDev' (wholeDiskLoopDev l)
+
+isLoopDev' :: FilePath -> IO Bool
+isLoopDev' f
+ | "loop" `isInfixOf` f = catchBoolIO $
+ isBlockDevice <$> getFileStatus f
+ | otherwise = return False
+
-- | Uses the kpartx utility to create device maps for partitions contained
--- within a disk image file. The resulting devices are passed to the
+-- within a disk image file. The resulting loop devices are passed to the
-- property, which can operate on them. Always cleans up after itself,
-- by removing the device maps after the property is run.
-kpartx :: FilePath -> ([FilePath] -> Property NoInfo) -> Property NoInfo
+kpartx :: FilePath -> ([LoopDev] -> Property NoInfo) -> Property NoInfo
kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"]
where
go = property (propertyDesc (mkprop [])) $ do
cleanup -- idempotency
- s <- liftIO $ readProcess "kpartx" ["-avs", diskimage]
- r <- ensureProperty (mkprop (devlist s))
+ loopdevs <- liftIO $ kpartxParse
+ <$> readProcess "kpartx" ["-avs", diskimage]
+ bad <- liftIO $ filterM (not <$$> isLoopDev) loopdevs
+ unless (null bad) $
+ error $ "kpartx output seems to include non-loop-devices (possible parse failure): " ++ show bad
+ r <- ensureProperty (mkprop loopdevs)
cleanup
return r
- devlist = mapMaybe (finddev . words) . lines
- finddev ("add":"map":s:_) = Just ("/dev/mapper/" ++ s)
- finddev _ = Nothing
cleanup = void $ liftIO $ boolSystem "kpartx" [Param "-d", File diskimage]
+
+kpartxParse :: String -> [LoopDev]
+kpartxParse = mapMaybe (finddev . words) . lines
+ where
+ finddev ("add":"map":ld:_:_:_:_:wd:_) = Just $ LoopDev
+ { partitionLoopDev = "/dev/mapper/" ++ ld
+ , wholeDiskLoopDev = wd
+ }
+ finddev _ = Nothing
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index e8d8aef3..70d5884f 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -15,6 +15,7 @@ import qualified Propellor.Property.User as User
import qualified Propellor.Property.Obnam as Obnam
import qualified Propellor.Property.Apache as Apache
import qualified Propellor.Property.Postfix as Postfix
+import qualified Propellor.Property.Systemd as Systemd
import Utility.FileMode
import Data.List
@@ -346,6 +347,7 @@ gitAnnexDistributor = combineProperties "git-annex distributor, including rsync
`onChange` Service.restarted "rsync"
& "/etc/default/rsync" `File.containsLine` "RSYNC_ENABLE=true"
`onChange` Service.running "rsync"
+ & Systemd.enabled "rsync"
& endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild"
& endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/x86_64-apple-yosemite"
& endpoint "/srv/web/downloads.kitenet.net/git-annex/autobuild/windows"
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index 5ba069e3..60121336 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -4,6 +4,7 @@ module Propellor.Property.Ssh (
installed,
restarted,
PubKeyText,
+ SshKeyType(..),
-- * Daemon configuration
sshdConfig,
ConfigKeyword,
diff --git a/src/Propellor/Property/User.hs b/src/Propellor/Property/User.hs
index c3314738..78e606ac 100644
--- a/src/Propellor/Property/User.hs
+++ b/src/Propellor/Property/User.hs
@@ -58,14 +58,21 @@ hasPassword' (User u) context = go `requires` shadowConfig True
setPassword :: (((PrivDataField, PrivData) -> Propellor Result) -> Propellor Result) -> Propellor Result
setPassword getpassword = getpassword $ go
where
- go (Password user, password) = set user (privDataVal password) []
- go (CryptPassword user, hash) = set user (privDataVal hash) ["--encrypted"]
+ go (Password user, password) = chpasswd (User user) (privDataVal password) []
+ go (CryptPassword user, hash) = chpasswd (User user) (privDataVal hash) ["--encrypted"]
go (f, _) = error $ "Unexpected type of privdata: " ++ show f
- set user v ps = makeChange $ withHandle StdinHandle createProcessSuccess
- (proc "chpasswd" ps) $ \h -> do
- hPutStrLn h $ user ++ ":" ++ v
- hClose h
+-- | Makes a user's password be the passed String. Highly insecure:
+-- The password is right there in your config file for anyone to see!
+hasInsecurePassword :: User -> String -> Property NoInfo
+hasInsecurePassword u@(User n) p = property (n ++ " has insecure password") $
+ chpasswd u p []
+
+chpasswd :: User -> String -> [String] -> Propellor Result
+chpasswd (User user) v ps = makeChange $ withHandle StdinHandle createProcessSuccess
+ (proc "chpasswd" ps) $ \h -> do
+ hPutStrLn h $ user ++ ":" ++ v
+ hClose h
lockedPassword :: User -> Property NoInfo
lockedPassword user@(User u) = check (not <$> isLockedPassword user) $ cmdProperty "passwd"