From b39f330ce63ef3d16dc0455dc7a7638c54e2885f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 22 Oct 2015 02:00:21 -0400 Subject: re-export SshKeyType --- src/Propellor/Property/Ssh.hs | 1 + 1 file changed, 1 insertion(+) (limited to 'src') 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, -- cgit v1.2.3 From f651e3cad11a9834bebf3e7c3fde85ef559f8f48 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 22 Oct 2015 13:10:34 -0400 Subject: seems the rsync systemd service ships disabled by default So many hoops to run a daemon.. --- src/Propellor/Property/SiteSpecific/JoeySites.hs | 2 ++ 1 file changed, 2 insertions(+) (limited to 'src') 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" -- cgit v1.2.3 From cc8fbeda82774f6c9a223a87187408496fcd0d2b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 22 Oct 2015 14:10:52 -0400 Subject: avoid grub install failure in chroot --- config-joey.hs | 2 +- src/Propellor/Property/DiskImage.hs | 7 ++++++- src/Propellor/Property/Grub.hs | 19 ++++++++++++------- 3 files changed, 19 insertions(+), 9 deletions(-) (limited to 'src') diff --git a/config-joey.hs b/config-joey.hs index 3fcf2289..815fe798 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -85,7 +85,7 @@ darkstar = host "darkstar.kitenet.net" [ partition EXT2 `mountedAt` "/boot" `setFlag` BootFlag , partition EXT4 `mountedAt` "/" `addFreeSpace` MegaBytes 100 -- , swapPartition (MegaBytes 256) - ] (grubBooted PC) -- (grubBooted PC) + ] (grubBooted PC) where c d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d & Apt.installed ["linux-image-amd64"] diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 8d503e28..3c2b2200 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -292,7 +292,12 @@ type Finalization = (Property NoInfo, Property NoInfo) -- | Makes grub be the boot loader of the disk image. -- TODO not implemented grubBooted :: Grub.BIOS -> Finalization -grubBooted bios = (Grub.installed bios, undefined) +grubBooted bios = (inchroot, inimg) + where + -- Need to set up device.map manually before running update-grub. + inchroot = Grub.installed' bios + + inimg = undefined noFinalization :: Finalization noFinalization = (doNothing, doNothing) 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" -- cgit v1.2.3 From 6399d6d2722320346877071866414e450701fbf9 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 22 Oct 2015 16:23:24 -0400 Subject: propellor spin --- src/Propellor/Property/DiskImage.hs | 6 +++--- src/Propellor/Property/Parted.hs | 2 +- src/Propellor/Property/Partition.hs | 23 +++++++++++++++++------ 3 files changed, 21 insertions(+), 10 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 3c2b2200..8b74f478 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -130,14 +130,14 @@ imageBuiltFrom img chrootdir tabletype partspec final = mkimg rmimg kpartx img (partitionsPopulated chrootdir mnts) 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 then ensureProperty $ 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..fa381d5d 100644 --- a/src/Propellor/Property/Partition.hs +++ b/src/Propellor/Property/Partition.hs @@ -41,20 +41,31 @@ 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) + -- | 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)) + r <- ensureProperty (mkprop (kpartxParse s)) 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 -- cgit v1.2.3 From 9c1630d3c17b495ce97dfff5bd4a94c98c5b46db Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 22 Oct 2015 18:59:16 -0400 Subject: belt-and-suspenders check of kpartx output --- src/Propellor/Property/Partition.hs | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs index fa381d5d..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 @@ -46,6 +50,15 @@ data LoopDev = LoopDev , 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 loop devices are passed to the -- property, which can operate on them. Always cleans up after itself, @@ -55,8 +68,12 @@ 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 (kpartxParse 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 cleanup = void $ liftIO $ boolSystem "kpartx" [Param "-d", File diskimage] -- cgit v1.2.3 From 9f09b6236d33d68850f8d99d1ea482c47b47ae84 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 22 Oct 2015 20:13:47 -0400 Subject: disk image finalization may work --- src/Propellor/Property/DiskImage.hs | 101 ++++++++++++++++++++++++++++-------- src/Propellor/Property/Mount.hs | 4 ++ 2 files changed, 82 insertions(+), 23 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 8b74f478..4715ba08 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 @@ -88,7 +87,7 @@ 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) + imageBuiltFrom img chrootdir tabletype partspec final `requires` Chroot.provisioned chroot `requires` (cleanrebuild doNothing) `describe` desc @@ -107,9 +106,7 @@ 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 :: DiskImage -> FilePath -> TableType -> [PartSpec] -> Finalization -> RevertableProperty imageBuiltFrom img chrootdir tabletype partspec final = mkimg rmimg where desc = img ++ " built from " ++ chrootdir @@ -121,13 +118,18 @@ 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] -> [LoopDev] -> Property NoInfo @@ -139,7 +141,7 @@ partitionsPopulated chrootdir mnts devs = property desc $ mconcat $ zipWith go m 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,20 +286,73 @@ 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 = (inchroot, inimg) +grubBooted bios = (Grub.installed' bios, boots) where - -- Need to set up device.map manually before running update-grub. - inchroot = Grub.installed' bios - - inimg = undefined - -noFinalization :: Finalization -noFinalization = (doNothing, doNothing) + boots mnt loopdevs = combineProperties "disk image boots using grub" + -- bind mount host /dev so grub can access the loop devices + [ mounted "bind" "/dev" (mnt <> "dev") + , mounted "proc" "proc" (mnt <> "proc") + , mounted "sysfs" "sys" (mnt <> "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 + inchroot cmd ps = cmdProperty "chroot" ([mnt, cmd] ++ ps) + + haveosprober = doesFileExist (mnt ++ 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/Mount.hs b/src/Propellor/Property/Mount.hs index 30d057f5..25984afa 100644 --- a/src/Propellor/Property/Mount.hs +++ b/src/Propellor/Property/Mount.hs @@ -36,5 +36,9 @@ 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) + mount :: FsType -> Source -> FilePath -> IO Bool mount fs src mnt = boolSystem "mount" [Param "-t", Param fs, Param src, Param mnt] -- cgit v1.2.3 From 69d1021c0c12bae52cbea2cc64399be4e4b3532f Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 22 Oct 2015 20:18:11 -0400 Subject: propellor spin --- src/Propellor/Property/DiskImage.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 4715ba08..cb38cef3 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -331,9 +331,9 @@ 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 - [ mounted "bind" "/dev" (mnt <> "dev") - , mounted "proc" "proc" (mnt <> "proc") - , mounted "sysfs" "sys" (mnt <> "sys") + [ mounted "bind" "/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" [] @@ -345,9 +345,12 @@ grubBooted bios = (Grub.installed' bios, boots) , cmdProperty "sync" [] ] where + -- cannot use since the filepath is absolute + inmnt f = mnt ++ f + inchroot cmd ps = cmdProperty "chroot" ([mnt, cmd] ++ ps) - haveosprober = doesFileExist (mnt ++ osprober) + haveosprober = doesFileExist (inmnt osprober) osprober = "/etc/grub.d/30_os-prober" -- It doesn't matter which loopdev we use; all -- cgit v1.2.3 From c84005cbbf432a8296ee44fec83227b15ce18d38 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 22 Oct 2015 20:22:52 -0400 Subject: propellor spin --- src/Propellor/Property/DiskImage.hs | 2 +- src/Propellor/Property/Mount.hs | 6 ++++++ 2 files changed, 7 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index cb38cef3..dcd522a3 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -331,7 +331,7 @@ 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 - [ mounted "bind" "/dev" (inmnt "/dev") + [ bindMount "/dev" (inmnt "/dev") , mounted "proc" "proc" (inmnt "/proc") , mounted "sysfs" "sys" (inmnt "/sys") -- work around for http://bugs.debian.org/802717 diff --git a/src/Propellor/Property/Mount.hs b/src/Propellor/Property/Mount.hs index 25984afa..09016011 100644 --- a/src/Propellor/Property/Mount.hs +++ b/src/Propellor/Property/Mount.hs @@ -40,5 +40,11 @@ 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] -- cgit v1.2.3 From 5db5d8418e27e187502e0807c3cbb7554dbbbcd1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 22 Oct 2015 20:52:11 -0400 Subject: propellor spin --- config-joey.hs | 11 +++++------ src/Propellor/Property/DiskImage.hs | 19 ++++++++++--------- 2 files changed, 15 insertions(+), 15 deletions(-) (limited to 'src') diff --git a/config-joey.hs b/config-joey.hs index cc1a9687..21d7194f 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -81,13 +81,12 @@ darkstar = host "darkstar.kitenet.net" & JoeySites.postfixClientRelay (Context "darkstar.kitenet.net") & JoeySites.dkimMilter - & imageBuilt "/tmp/img" c MSDOS - [ - -- partition EXT2 `mountedAt` "/boot" `setFlag` BootFlag - partition EXT4 `mountedAt` "/" `addFreeSpace` MegaBytes 100 + & imageBuilt "/tmp/img" c MSDOS (grubBooted PC) + [ partition EXT4 `mountedAt` "/" + `addFreeSpace` MegaBytes 100 `setFlag` BootFlag - -- , swapPartition (MegaBytes 256) - ] (grubBooted PC) + , swapPartition (MegaBytes 256) + ] where c d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d & Apt.installed ["linux-image-amd64"] diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index dcd522a3..1e3a5407 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -69,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 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 @@ -106,8 +107,8 @@ imageBuilt' rebuild img mkchroot tabletype partspec final = & Apt.cacheCleaned -- | Builds a disk image from the contents of a chroot. -imageBuiltFrom :: DiskImage -> FilePath -> TableType -> [PartSpec] -> Finalization -> 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 -- cgit v1.2.3 From 54125139a306209995f9e145998514bc6a9233ab Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 22 Oct 2015 21:13:05 -0400 Subject: hasInsecurePassword --- src/Propellor/Property/User.hs | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) (limited to 'src') 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" -- cgit v1.2.3 From 62aaba85c7ff40d44fa2101b05e6577dee7d0184 Mon Sep 17 00:00:00 2001 From: Ben Boeckel Date: Tue, 20 Oct 2015 23:52:27 -0400 Subject: chroot: add a ChrootTarball chroot type This extracts a minimal tarball into a target directory. (cherry picked from commit 33ac6c1c4bb2581d6f5a27254e52956e5a257326) --- src/Propellor/Property/Chroot.hs | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) (limited to 'src') diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 7ec2010c..a0bbad35 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -22,6 +22,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,6 +53,29 @@ class ChrootBootstrapper b where -- If the operating System is not supported, return Nothing. buildchroot :: b -> System -> FilePath -> Maybe (Property HasInfo) +-- | Use to extract a tarball with a filesystem image. +-- +-- The filesystem image is expected to be 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 to bootstrap a chroot with debootstrap. data Debootstrapped = Debootstrapped Debootstrap.DebootstrapConfig -- cgit v1.2.3 From 1a55d09b5452f07508d4624b632e9a54782dbee8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 23 Oct 2015 01:27:22 -0400 Subject: export ChrootTarball and improve docs --- src/Propellor/Property/Chroot.hs | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index a0bbad35..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, @@ -53,11 +54,12 @@ class ChrootBootstrapper b where -- If the operating System is not supported, return Nothing. buildchroot :: b -> System -> FilePath -> Maybe (Property HasInfo) --- | Use to extract a tarball with a filesystem image. +-- | Use this to bootstrap a chroot by extracting a tarball. -- --- The filesystem image is expected to be 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. +-- 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 @@ -76,7 +78,7 @@ extractTarball target src = toProp . , src ] --- | Use to bootstrap a chroot with debootstrap. +-- | Use this to bootstrap a chroot with debootstrap. data Debootstrapped = Debootstrapped Debootstrap.DebootstrapConfig instance ChrootBootstrapper Debootstrapped where -- cgit v1.2.3