diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Propellor/Bootstrap.hs | 1 | ||||
| -rw-r--r-- | src/Propellor/Property/Chroot.hs | 20 | ||||
| -rw-r--r-- | src/Propellor/Property/DebianMirror.hs | 124 | ||||
| -rw-r--r-- | src/Propellor/Property/DiskImage.hs | 13 | ||||
| -rw-r--r-- | src/Propellor/Types.hs | 2 | ||||
| -rw-r--r-- | src/Utility/QuickCheck.hs | 53 | ||||
| -rw-r--r-- | src/Utility/Scheduled.hs | 37 |
7 files changed, 141 insertions, 109 deletions
diff --git a/src/Propellor/Bootstrap.hs b/src/Propellor/Bootstrap.hs index 21772b34..f2f5af55 100644 --- a/src/Propellor/Bootstrap.hs +++ b/src/Propellor/Bootstrap.hs @@ -77,7 +77,6 @@ depsCommand = "( " ++ intercalate " ; " (concat [osinstall, cabalinstall]) ++ " , "libghc-ansi-terminal-dev" , "libghc-ifelse-dev" , "libghc-network-dev" - , "libghc-quickcheck2-dev" , "libghc-mtl-dev" , "libghc-transformers-dev" , "libghc-exceptions-dev" diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 8d1a2388..30c11ed3 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -8,6 +8,7 @@ module Propellor.Property.Chroot ( ChrootBootstrapper(..), Debootstrapped(..), ChrootTarball(..), + noServices, inChroot, -- * Internal use provisioned', @@ -27,6 +28,7 @@ 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 +import Utility.FileMode import qualified Data.Map as M import Data.List.Utils @@ -247,6 +249,24 @@ mungeloc = replace "/" "_" chrootDesc :: Chroot -> String -> String chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc +-- | Adding this property to a chroot prevents daemons and other services +-- from being started, which is often something you want to prevent when +-- building a chroot. +-- +-- This is accomplished by installing a </usr/sbin/policy-rc.d> script +-- that does not let any daemons be started by packages that use +-- invoke-rc.d. Reverting the property removes the script. +noServices :: RevertableProperty NoInfo +noServices = setup <!> teardown + where + f = "/usr/sbin/policy-rc.d" + script = [ "#!/bin/sh", "exit 101" ] + setup = combineProperties "no services started" + [ File.hasContent f script + , File.mode f (combineModes (readModes ++ executeModes)) + ] + teardown = File.notPresent f + -- | Check if propellor is currently running within a chroot. -- -- This allows properties to check and avoid performing actions that diff --git a/src/Propellor/Property/DebianMirror.hs b/src/Propellor/Property/DebianMirror.hs index 6f1ff7b2..468cca32 100644 --- a/src/Propellor/Property/DebianMirror.hs +++ b/src/Propellor/Property/DebianMirror.hs @@ -1,10 +1,22 @@ -- | Maintainer: Félix Sipma <felix+propellor@gueux.org> module Propellor.Property.DebianMirror - ( DebianPriority(..) + ( DebianPriority (..) , showPriority , mirror - , mirrorCdn + , RsyncExtra (..) + , Method (..) + , DebianMirror + , debianMirrorHostName + , debianMirrorSuites + , debianMirrorArchitectures + , debianMirrorSections + , debianMirrorSourceBool + , debianMirrorPriorities + , debianMirrorMethod + , debianMirrorKeyring + , debianMirrorRsyncExtra + , mkDebianMirror ) where import Propellor.Base @@ -27,8 +39,88 @@ showPriority Standard = "standard" showPriority Optional = "optional" showPriority Extra = "extra" -mirror :: Apt.Url -> FilePath -> [DebianSuite] -> [Architecture] -> [Apt.Section] -> Bool -> [DebianPriority] -> Cron.Times -> Property NoInfo -mirror url dir suites archs sections source priorities crontimes = propertyList +data RsyncExtra = Doc | Indices | Tools | Trace + deriving (Show, Eq) + +showRsyncExtra :: RsyncExtra -> String +showRsyncExtra Doc = "doc" +showRsyncExtra Indices = "indices" +showRsyncExtra Tools = "tools" +showRsyncExtra Trace = "trace" + +data Method = Ftp | Http | Https | Rsync | MirrorFile + +showMethod :: Method -> String +showMethod Ftp = "ftp" +showMethod Http = "http" +showMethod Https = "https" +showMethod Rsync = "rsync" +showMethod MirrorFile = "file" + +-- | To get a new DebianMirror and set options, use: +-- +-- > mkDebianMirror mymirrordir mycrontimes +-- > . debianMirrorHostName "otherhostname" +-- > . debianMirrorSourceBool True + +data DebianMirror = DebianMirror + { _debianMirrorHostName :: HostName + , _debianMirrorDir :: FilePath + , _debianMirrorSuites :: [DebianSuite] + , _debianMirrorArchitectures :: [Architecture] + , _debianMirrorSections :: [Apt.Section] + , _debianMirrorSourceBool :: Bool + , _debianMirrorPriorities :: [DebianPriority] + , _debianMirrorMethod :: Method + , _debianMirrorKeyring :: FilePath + , _debianMirrorRsyncExtra :: [RsyncExtra] + , _debianMirrorCronTimes :: Cron.Times + } + +mkDebianMirror :: FilePath -> Cron.Times -> DebianMirror +mkDebianMirror dir crontimes = DebianMirror + { _debianMirrorHostName = "httpredir.debian.org" + , _debianMirrorDir = dir + , _debianMirrorSuites = [] + , _debianMirrorArchitectures = [] + , _debianMirrorSections = [] + , _debianMirrorSourceBool = False + , _debianMirrorPriorities = [] + , _debianMirrorMethod = Http + , _debianMirrorKeyring = "/usr/share/keyrings/debian-archive-keyring.gpg" + , _debianMirrorRsyncExtra = [Trace] + , _debianMirrorCronTimes = crontimes + } + +debianMirrorHostName :: HostName -> DebianMirror -> DebianMirror +debianMirrorHostName hn m = m { _debianMirrorHostName = hn } + +debianMirrorSuites :: [DebianSuite] -> DebianMirror -> DebianMirror +debianMirrorSuites s m = m { _debianMirrorSuites = s } + +debianMirrorArchitectures :: [Architecture] -> DebianMirror -> DebianMirror +debianMirrorArchitectures a m = m { _debianMirrorArchitectures = a } + +debianMirrorSections :: [Apt.Section] -> DebianMirror -> DebianMirror +debianMirrorSections s m = m { _debianMirrorSections = s } + +debianMirrorSourceBool :: Bool -> DebianMirror -> DebianMirror +debianMirrorSourceBool s m = m { _debianMirrorSourceBool = s } + +debianMirrorPriorities :: [DebianPriority] -> DebianMirror -> DebianMirror +debianMirrorPriorities p m = m { _debianMirrorPriorities = p } + +debianMirrorMethod :: Method -> DebianMirror -> DebianMirror +debianMirrorMethod me m = m { _debianMirrorMethod = me } + +debianMirrorKeyring :: FilePath -> DebianMirror -> DebianMirror +debianMirrorKeyring k m = m { _debianMirrorKeyring = k } + +debianMirrorRsyncExtra :: [RsyncExtra] -> DebianMirror -> DebianMirror +debianMirrorRsyncExtra r m = m { _debianMirrorRsyncExtra = r } + +mirror :: DebianMirror -> Property NoInfo +mirror mirror' = propertyList ("Debian mirror " ++ dir) [ Apt.installed ["debmirror"] , User.accountFor (User "debmirror") @@ -36,28 +128,30 @@ mirror url dir suites archs sections source priorities crontimes = propertyList , File.ownerGroup dir (User "debmirror") (Group "debmirror") , check (not . and <$> mapM suitemirrored suites) $ cmdProperty "debmirror" args `describe` "debmirror setup" - , Cron.niceJob ("debmirror_" ++ dir) crontimes (User "debmirror") "/" $ + , Cron.niceJob ("debmirror_" ++ dir) (_debianMirrorCronTimes mirror') (User "debmirror") "/" $ unwords ("/usr/bin/debmirror" : args) ] where + dir = _debianMirrorDir mirror' + suites = _debianMirrorSuites mirror' suitemirrored suite = doesDirectoryExist $ dir </> "dists" </> Apt.showSuite suite architecturearg = intercalate "," suitearg = intercalate "," $ map Apt.showSuite suites priorityRegex pp = "(" ++ intercalate "|" (map showPriority pp) ++ ")" + rsyncextraarg [] = "none" + rsyncextraarg res = intercalate "," $ map showRsyncExtra res args = [ "--dist" , suitearg - , "--arch", architecturearg archs - , "--section", intercalate "," sections - , "--limit-priority", "\"" ++ priorityRegex priorities ++ "\"" + , "--arch", architecturearg $ _debianMirrorArchitectures mirror' + , "--section", intercalate "," $ _debianMirrorSections mirror' + , "--limit-priority", "\"" ++ priorityRegex (_debianMirrorPriorities mirror') ++ "\"" ] ++ - (if source then [] else ["--nosource"]) + (if _debianMirrorSourceBool mirror' then [] else ["--nosource"]) ++ - [ "--host", url - , "--method", "http" - , "--keyring", "/usr/share/keyrings/debian-archive-keyring.gpg" + [ "--host", _debianMirrorHostName mirror' + , "--method", showMethod $ _debianMirrorMethod mirror' + , "--rsync-extra", rsyncextraarg $ _debianMirrorRsyncExtra mirror' + , "--keyring", _debianMirrorKeyring mirror' , dir ] - -mirrorCdn :: FilePath -> [DebianSuite] -> [Architecture] -> [Apt.Section] -> Bool -> [DebianPriority] -> Cron.Times -> Property NoInfo -mirrorCdn = mirror "http://httpredir.debian.org/debian" diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 5b8619ba..4878c365 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -1,8 +1,6 @@ -- | Disk image generation. -- -- This module is designed to be imported unqualified. --- --- TODO avoid starting services while populating chroot and running final module Propellor.Property.DiskImage ( -- * Partition specification @@ -69,6 +67,11 @@ type DiskImage = FilePath -- Note that the disk image file is reused if it already exists, -- to avoid expensive IO to generate a new one. And, it's updated in-place, -- so its contents are undefined during the build process. +-- +-- Note that the `Chroot.noServices` property is automatically added to the +-- chroot while the disk image is being built, which should prevent any +-- daemons that are included from being started on the system that is +-- building the disk image. imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty HasInfo imageBuilt = imageBuilt' False @@ -93,6 +96,9 @@ imageBuilt' rebuild img mkchroot tabletype final partspec = | otherwise = doNothing chrootdir = img ++ ".chroot" chroot = mkchroot chrootdir + -- Before ensuring any other properties of the chroot, avoid + -- starting services. Reverted by imageFinalized. + &^ Chroot.noServices -- First stage finalization. & fst final -- Avoid wasting disk image space on the apt cache @@ -227,6 +233,7 @@ imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) = go top = do liftIO $ mountall top liftIO $ writefstab top + liftIO $ allowservices top ensureProperty $ final top devs -- Ordered lexographically by mount point, so / comes before /usr @@ -260,6 +267,8 @@ imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) = -- Eg "UNCONFIGURED FSTAB FOR BASE SYSTEM" unconfigured s = "UNCONFIGURED" `isInfixOf` s + allowservices top = nukeFile (top ++ "/usr/sbin/policy-rc.d") + noFinalization :: Finalization noFinalization = (doNothing, \_ _ -> doNothing) diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index fa24786c..3d2fbf14 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -23,7 +23,7 @@ module Propellor.Types , propertyDesc , propertyChildren , RevertableProperty(..) - , (<!>) + , MkRevertableProperty(..) , IsProp(..) , Combines(..) , CombinedType diff --git a/src/Utility/QuickCheck.hs b/src/Utility/QuickCheck.hs deleted file mode 100644 index cd408ddc..00000000 --- a/src/Utility/QuickCheck.hs +++ /dev/null @@ -1,53 +0,0 @@ -{- QuickCheck with additional instances - - - - Copyright 2012-2014 Joey Hess <id@joeyh.name> - - - - License: BSD-2-clause - -} - -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE TypeSynonymInstances #-} - -module Utility.QuickCheck - ( module X - , module Utility.QuickCheck - ) where - -import Test.QuickCheck as X -import Data.Time.Clock.POSIX -import System.Posix.Types -import qualified Data.Map as M -import qualified Data.Set as S -import Control.Applicative -import Prelude - -instance (Arbitrary k, Arbitrary v, Eq k, Ord k) => Arbitrary (M.Map k v) where - arbitrary = M.fromList <$> arbitrary - -instance (Arbitrary v, Eq v, Ord v) => Arbitrary (S.Set v) where - arbitrary = S.fromList <$> arbitrary - -{- Times before the epoch are excluded. -} -instance Arbitrary POSIXTime where - arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral - -instance Arbitrary EpochTime where - arbitrary = fromInteger <$> nonNegative arbitrarySizedIntegral - -{- Pids are never negative, or 0. -} -instance Arbitrary ProcessID where - arbitrary = arbitrarySizedBoundedIntegral `suchThat` (> 0) - -{- Inodes are never negative. -} -instance Arbitrary FileID where - arbitrary = nonNegative arbitrarySizedIntegral - -{- File sizes are never negative. -} -instance Arbitrary FileOffset where - arbitrary = nonNegative arbitrarySizedIntegral - -nonNegative :: (Num a, Ord a) => Gen a -> Gen a -nonNegative g = g `suchThat` (>= 0) - -positive :: (Num a, Ord a) => Gen a -> Gen a -positive g = g `suchThat` (> 0) diff --git a/src/Utility/Scheduled.hs b/src/Utility/Scheduled.hs index 5e813d4a..ead8f771 100644 --- a/src/Utility/Scheduled.hs +++ b/src/Utility/Scheduled.hs @@ -23,12 +23,10 @@ module Utility.Scheduled ( toRecurrance, toSchedule, parseSchedule, - prop_schedule_roundtrips, prop_past_sane, ) where import Utility.Data -import Utility.QuickCheck import Utility.PartialPrelude import Utility.Misc @@ -337,41 +335,6 @@ parseSchedule s = do recurrance = unwords rws scheduledtime = unwords tws -instance Arbitrary Schedule where - arbitrary = Schedule <$> arbitrary <*> arbitrary - -instance Arbitrary ScheduledTime where - arbitrary = oneof - [ pure AnyTime - , SpecificTime - <$> choose (0, 23) - <*> choose (1, 59) - ] - -instance Arbitrary Recurrance where - arbitrary = oneof - [ pure Daily - , Weekly <$> arbday - , Monthly <$> arbday - , Yearly <$> arbday - , Divisible - <$> positive arbitrary - <*> oneof -- no nested Divisibles - [ pure Daily - , Weekly <$> arbday - , Monthly <$> arbday - , Yearly <$> arbday - ] - ] - where - arbday = oneof - [ Just <$> nonNegative arbitrary - , pure Nothing - ] - -prop_schedule_roundtrips :: Schedule -> Bool -prop_schedule_roundtrips s = toSchedule (fromSchedule s) == Just s - prop_past_sane :: Bool prop_past_sane = and [ all (checksout oneMonthPast) (mplus1 ++ yplus1) |