summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2015-11-21 13:21:51 -0400
committerJoey Hess2015-11-21 13:21:51 -0400
commitcdcabc4ba35d16c69c6e039d75521dd41aec96a3 (patch)
tree926dcf8d3727983b44d0ff50a49ec20bbd47e89f
parent1366fd272b70c15d8a28bd6fd44fde970cfa05e3 (diff)
parentdd5ffce2b68ac0b4e306682e8511f13974948e39 (diff)
Merge branch 'joeyconfig'
-rw-r--r--debian/changelog9
-rw-r--r--debian/control2
-rw-r--r--propellor.cabal28
-rw-r--r--src/Propellor/Bootstrap.hs1
-rw-r--r--src/Propellor/Property/Chroot.hs20
-rw-r--r--src/Propellor/Property/DebianMirror.hs124
-rw-r--r--src/Propellor/Property/DiskImage.hs13
-rw-r--r--src/Propellor/Types.hs2
-rw-r--r--src/Utility/QuickCheck.hs53
-rw-r--r--src/Utility/Scheduled.hs37
10 files changed, 158 insertions, 131 deletions
diff --git a/debian/changelog b/debian/changelog
index e5bb541b..84c3fc6f 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,7 +1,14 @@
-propellor (2.13.1) UNRELEASED; urgency=medium
+propellor (2.14.0) UNRELEASED; urgency=medium
* Add Propellor.Property.PropellorRepo.hasOriginUrl, an explicit way to
set the git repository url normally implicitly set when using --spin.
+ * Added Chroot.noServices property.
+ * DiskImage creation automatically uses Chroot.noServices.
+ * Removed the (unused) dependency on quickcheck.
+ * DebianMirror: Added a DebianMirror type for configuration (API change)
+ Thanks, Félix Sipma.
+ * DebianMirror: Add RsyncExtra to configuration.
+ Thanks, Félix Sipma.
-- Joey Hess <id@joeyh.name> Wed, 11 Nov 2015 13:37:00 -0400
diff --git a/debian/control b/debian/control
index 1a7909a3..757462d1 100644
--- a/debian/control
+++ b/debian/control
@@ -13,7 +13,6 @@ Build-Depends:
libghc-ansi-terminal-dev,
libghc-ifelse-dev,
libghc-network-dev,
- libghc-quickcheck2-dev,
libghc-mtl-dev,
libghc-transformers-dev,
libghc-exceptions-dev (>= 0.6),
@@ -37,7 +36,6 @@ Depends: ${misc:Depends}, ${shlibs:Depends},
libghc-ansi-terminal-dev,
libghc-ifelse-dev,
libghc-network-dev,
- libghc-quickcheck2-dev,
libghc-mtl-dev,
libghc-transformers-dev,
libghc-exceptions-dev (>= 0.6),
diff --git a/propellor.cabal b/propellor.cabal
index 90871255..45ded769 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -35,37 +35,28 @@ Description:
Executable propellor
Main-Is: wrapper.hs
GHC-Options: -threaded -Wall -fno-warn-tabs
- Hs-Source-Dirs: src
+ Hs-Source-Dirs: src
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
- containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers,
- exceptions (>= 0.6), stm, text
-
- if (! os(windows))
- Build-Depends: unix
+ containers (>= 0.5), network, async, time, mtl, transformers,
+ exceptions (>= 0.6), stm, text, unix
Executable propellor-config
Main-Is: config.hs
GHC-Options: -threaded -Wall -fno-warn-tabs
- Hs-Source-Dirs: src
+ Hs-Source-Dirs: src
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
- containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers,
- exceptions, stm, text
-
- if (! os(windows))
- Build-Depends: unix
+ containers (>= 0.5), network, async, time, mtl, transformers,
+ exceptions (>= 0.6), stm, text, unix
Library
GHC-Options: -Wall -fno-warn-tabs
- Hs-Source-Dirs: src
+ Hs-Source-Dirs: src
Build-Depends: MissingH, directory, filepath, base >= 4.5, base < 5,
IfElse, process, bytestring, hslogger, unix-compat, ansi-terminal,
- containers (>= 0.5), network, async, time, QuickCheck, mtl, transformers,
- exceptions, stm, text
-
- if (! os(windows))
- Build-Depends: unix
+ containers (>= 0.5), network, async, time, mtl, transformers,
+ exceptions (>= 0.6), stm, text, unix
Exposed-Modules:
Propellor
@@ -184,7 +175,6 @@ Library
Utility.ThreadScheduler
Utility.Tmp
Utility.UserInfo
- Utility.QuickCheck
System.Console.Concurrent
System.Console.Concurrent.Internal
System.Process.Concurrent
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)