From e98b82c5dc68ae4c02a16945f78c0f1c78444bbd Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 17 Nov 2015 15:05:02 -0400 Subject: export for haddock --- src/Propellor/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src') 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 -- cgit v1.2.3 From d796284d8bb483a89bf3d65d198a890a62090d96 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 17 Nov 2015 15:06:35 -0400 Subject: Added Chroot.noServices property. --- debian/changelog | 1 + src/Propellor/Property/Chroot.hs | 18 ++++++++++++++++++ 2 files changed, 19 insertions(+) (limited to 'src') diff --git a/debian/changelog b/debian/changelog index 043848c5..b27ab8b2 100644 --- a/debian/changelog +++ b/debian/changelog @@ -2,6 +2,7 @@ propellor (2.13.1) 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. -- Joey Hess Wed, 11 Nov 2015 13:37:00 -0400 diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 8d1a2388..a763a56b 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,22 @@ 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 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 = File.mode f (combineModes (readModes ++ executeModes)) + `requires` File.hasContent f script + teardown = File.notPresent f + -- | Check if propellor is currently running within a chroot. -- -- This allows properties to check and avoid performing actions that -- cgit v1.2.3 From b75db5ae653b7b87859e582528df9b03aa5366f1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 17 Nov 2015 15:22:29 -0400 Subject: DiskImage creation automatically uses Chroot.noServices. --- debian/changelog | 1 + src/Propellor/Property/Chroot.hs | 6 ++++-- src/Propellor/Property/DiskImage.hs | 13 +++++++++++-- 3 files changed, 16 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/debian/changelog b/debian/changelog index b27ab8b2..320aff96 100644 --- a/debian/changelog +++ b/debian/changelog @@ -3,6 +3,7 @@ propellor (2.13.1) 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. -- Joey Hess Wed, 11 Nov 2015 13:37:00 -0400 diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index a763a56b..30c11ed3 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -261,8 +261,10 @@ noServices = setup teardown where f = "/usr/sbin/policy-rc.d" script = [ "#!/bin/sh", "exit 101" ] - setup = File.mode f (combineModes (readModes ++ executeModes)) - `requires` File.hasContent f script + 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. 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) -- cgit v1.2.3 From 9ad0f07358df3d87a5d05e9f44131da79cfe266e Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 17 Nov 2015 15:51:12 -0400 Subject: Removed the (unused) dependency on quickcheck. --- debian/changelog | 1 + debian/control | 2 -- propellor.cabal | 7 +++--- src/Propellor/Bootstrap.hs | 1 - src/Utility/QuickCheck.hs | 53 ---------------------------------------------- src/Utility/Scheduled.hs | 37 -------------------------------- 6 files changed, 4 insertions(+), 97 deletions(-) delete mode 100644 src/Utility/QuickCheck.hs (limited to 'src') diff --git a/debian/changelog b/debian/changelog index 320aff96..a117e1d3 100644 --- a/debian/changelog +++ b/debian/changelog @@ -4,6 +4,7 @@ propellor (2.13.1) UNRELEASED; urgency=medium 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. -- Joey Hess 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 ee3a4f70..0a27acb2 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -38,7 +38,7 @@ Executable propellor 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, + containers (>= 0.5), network, async, time, mtl, transformers, exceptions (>= 0.6), stm, text, unix Executable propellor-config @@ -47,7 +47,7 @@ Executable propellor-config 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, + containers (>= 0.5), network, async, time, mtl, transformers, exceptions (>= 0.6), stm, text, unix Library @@ -55,7 +55,7 @@ Library 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, + containers (>= 0.5), network, async, time, mtl, transformers, exceptions (>= 0.6), stm, text, unix Exposed-Modules: @@ -175,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/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 - - - - 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) -- cgit v1.2.3 From 1d38d3d3a17ac0c89d172291e879b91f32f2d9e1 Mon Sep 17 00:00:00 2001 From: Félix Sipma Date: Fri, 20 Nov 2015 15:15:39 +0100 Subject: DebianMirror: debmirror --host argument should be a hostname, not an url (cherry picked from commit f0e374b4a43db750868f1ca4ccc465cee5691748) --- src/Propellor/Property/DebianMirror.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/DebianMirror.hs b/src/Propellor/Property/DebianMirror.hs index 6f1ff7b2..bdcade96 100644 --- a/src/Propellor/Property/DebianMirror.hs +++ b/src/Propellor/Property/DebianMirror.hs @@ -27,8 +27,8 @@ 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 +mirror :: HostName -> FilePath -> [DebianSuite] -> [Architecture] -> [Apt.Section] -> Bool -> [DebianPriority] -> Cron.Times -> Property NoInfo +mirror hn dir suites archs sections source priorities crontimes = propertyList ("Debian mirror " ++ dir) [ Apt.installed ["debmirror"] , User.accountFor (User "debmirror") @@ -53,11 +53,11 @@ mirror url dir suites archs sections source priorities crontimes = propertyList ++ (if source then [] else ["--nosource"]) ++ - [ "--host", url + [ "--host", hn , "--method", "http" , "--keyring", "/usr/share/keyrings/debian-archive-keyring.gpg" , dir ] mirrorCdn :: FilePath -> [DebianSuite] -> [Architecture] -> [Apt.Section] -> Bool -> [DebianPriority] -> Cron.Times -> Property NoInfo -mirrorCdn = mirror "http://httpredir.debian.org/debian" +mirrorCdn = mirror "httpredir.debian.org" -- cgit v1.2.3 From 12c0dccd1952ed115f576a1d5616394ec981c13c Mon Sep 17 00:00:00 2001 From: Félix Sipma Date: Fri, 20 Nov 2015 15:18:15 +0100 Subject: DebianMirror: add a [RsyncExtra] argument (cherry picked from commit baff70140cbf3f6113439335b96f3016f261a6a0) --- src/Propellor/Property/DebianMirror.hs | 18 +++++++++++++++--- 1 file changed, 15 insertions(+), 3 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/DebianMirror.hs b/src/Propellor/Property/DebianMirror.hs index bdcade96..9c80050b 100644 --- a/src/Propellor/Property/DebianMirror.hs +++ b/src/Propellor/Property/DebianMirror.hs @@ -27,8 +27,17 @@ showPriority Standard = "standard" showPriority Optional = "optional" showPriority Extra = "extra" -mirror :: HostName -> FilePath -> [DebianSuite] -> [Architecture] -> [Apt.Section] -> Bool -> [DebianPriority] -> Cron.Times -> Property NoInfo -mirror hn 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" + +mirror :: HostName -> FilePath -> [DebianSuite] -> [Architecture] -> [Apt.Section] -> Bool -> [DebianPriority] -> [RsyncExtra] -> Cron.Times -> Property NoInfo +mirror hn dir suites archs sections source priorities rsyncextras crontimes = propertyList ("Debian mirror " ++ dir) [ Apt.installed ["debmirror"] , User.accountFor (User "debmirror") @@ -44,6 +53,8 @@ mirror hn dir suites archs sections source priorities crontimes = propertyList 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 @@ -55,9 +66,10 @@ mirror hn dir suites archs sections source priorities crontimes = propertyList ++ [ "--host", hn , "--method", "http" + , "--rsync-extra", rsyncextraarg rsyncextras , "--keyring", "/usr/share/keyrings/debian-archive-keyring.gpg" , dir ] -mirrorCdn :: FilePath -> [DebianSuite] -> [Architecture] -> [Apt.Section] -> Bool -> [DebianPriority] -> Cron.Times -> Property NoInfo +mirrorCdn :: FilePath -> [DebianSuite] -> [Architecture] -> [Apt.Section] -> Bool -> [DebianPriority] -> [RsyncExtra] -> Cron.Times -> Property NoInfo mirrorCdn = mirror "httpredir.debian.org" -- cgit v1.2.3 From f68b34e166083f150b6122efcfd1d1e78cd26eeb Mon Sep 17 00:00:00 2001 From: Félix Sipma Date: Fri, 20 Nov 2015 17:53:08 +0100 Subject: DebianMirror: add DebianMirror type (cherry picked from commit 82d949506dbadabff7d62de85a2f601b9d5755cc) --- src/Propellor/Property/DebianMirror.hs | 108 ++++++++++++++++++++++++++++----- 1 file changed, 92 insertions(+), 16 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/DebianMirror.hs b/src/Propellor/Property/DebianMirror.hs index 9c80050b..61546424 100644 --- a/src/Propellor/Property/DebianMirror.hs +++ b/src/Propellor/Property/DebianMirror.hs @@ -1,10 +1,22 @@ -- | Maintainer: Félix Sipma module Propellor.Property.DebianMirror - ( DebianPriority(..) + ( DebianPriority (..) , showPriority , mirror - , mirrorCdn + , RsyncExtra (..) + , Method (..) + , DebianMirror + , setDebianMirrorHostName + , setDebianMirrorSuites + , setDebianMirrorArchitectures + , setDebianMirrorSections + , setDebianMirrorSourceBool + , setDebianMirrorPriorities + , setDebianMirrorMethod + , setDebianMirrorKeyring + , setDebianMirrorRsyncExtra + , mkDebianMirror ) where import Propellor.Base @@ -36,8 +48,73 @@ showRsyncExtra Indices = "indices" showRsyncExtra Tools = "tools" showRsyncExtra Trace = "trace" -mirror :: HostName -> FilePath -> [DebianSuite] -> [Architecture] -> [Apt.Section] -> Bool -> [DebianPriority] -> [RsyncExtra] -> Cron.Times -> Property NoInfo -mirror hn dir suites archs sections source priorities rsyncextras crontimes = propertyList +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" + +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 + } + +setDebianMirrorHostName :: HostName -> DebianMirror -> DebianMirror +setDebianMirrorHostName hn m = m { debianMirrorHostName = hn } + +setDebianMirrorSuites :: [DebianSuite] -> DebianMirror -> DebianMirror +setDebianMirrorSuites s m = m { debianMirrorSuites = s } + +setDebianMirrorArchitectures :: [Architecture] -> DebianMirror -> DebianMirror +setDebianMirrorArchitectures a m = m { debianMirrorArchitectures = a } + +setDebianMirrorSections :: [Apt.Section] -> DebianMirror -> DebianMirror +setDebianMirrorSections s m = m { debianMirrorSections = s } + +setDebianMirrorSourceBool :: Bool -> DebianMirror -> DebianMirror +setDebianMirrorSourceBool s m = m { debianMirrorSourceBool = s } + +setDebianMirrorPriorities :: [DebianPriority] -> DebianMirror -> DebianMirror +setDebianMirrorPriorities p m = m { debianMirrorPriorities = p } + +setDebianMirrorMethod :: Method -> DebianMirror -> DebianMirror +setDebianMirrorMethod me m = m { debianMirrorMethod = me } + +setDebianMirrorKeyring :: FilePath -> DebianMirror -> DebianMirror +setDebianMirrorKeyring k m = m { debianMirrorKeyring = k } + +setDebianMirrorRsyncExtra :: [RsyncExtra] -> DebianMirror -> DebianMirror +setDebianMirrorRsyncExtra r m = m { debianMirrorRsyncExtra = r } + +mirror :: DebianMirror -> Property NoInfo +mirror mirror' = propertyList ("Debian mirror " ++ dir) [ Apt.installed ["debmirror"] , User.accountFor (User "debmirror") @@ -45,10 +122,12 @@ mirror hn dir suites archs sections source priorities rsyncextras crontimes = pr , 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 @@ -57,19 +136,16 @@ mirror hn dir suites archs sections source priorities rsyncextras crontimes = pr 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", hn - , "--method", "http" - , "--rsync-extra", rsyncextraarg rsyncextras - , "--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] -> [RsyncExtra] -> Cron.Times -> Property NoInfo -mirrorCdn = mirror "httpredir.debian.org" -- cgit v1.2.3 From f038460bfe1447fdbeaaa311fc42ccf4dee2b994 Mon Sep 17 00:00:00 2001 From: Félix Sipma Date: Sat, 21 Nov 2015 11:29:34 +0100 Subject: DebianMirror: use a lensy approach to set values of a DebianMirror (cherry picked from commit 359e449157f831bbd22a212d618b6762a58b47de) --- src/Propellor/Property/DebianMirror.hs | 126 +++++++++++++++++---------------- 1 file changed, 66 insertions(+), 60 deletions(-) (limited to 'src') diff --git a/src/Propellor/Property/DebianMirror.hs b/src/Propellor/Property/DebianMirror.hs index 61546424..468cca32 100644 --- a/src/Propellor/Property/DebianMirror.hs +++ b/src/Propellor/Property/DebianMirror.hs @@ -7,15 +7,15 @@ module Propellor.Property.DebianMirror , RsyncExtra (..) , Method (..) , DebianMirror - , setDebianMirrorHostName - , setDebianMirrorSuites - , setDebianMirrorArchitectures - , setDebianMirrorSections - , setDebianMirrorSourceBool - , setDebianMirrorPriorities - , setDebianMirrorMethod - , setDebianMirrorKeyring - , setDebianMirrorRsyncExtra + , debianMirrorHostName + , debianMirrorSuites + , debianMirrorArchitectures + , debianMirrorSections + , debianMirrorSourceBool + , debianMirrorPriorities + , debianMirrorMethod + , debianMirrorKeyring + , debianMirrorRsyncExtra , mkDebianMirror ) where @@ -57,61 +57,67 @@ 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 + { _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 = "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 } -setDebianMirrorHostName :: HostName -> DebianMirror -> DebianMirror -setDebianMirrorHostName hn m = m { debianMirrorHostName = hn } +debianMirrorHostName :: HostName -> DebianMirror -> DebianMirror +debianMirrorHostName hn m = m { _debianMirrorHostName = hn } -setDebianMirrorSuites :: [DebianSuite] -> DebianMirror -> DebianMirror -setDebianMirrorSuites s m = m { debianMirrorSuites = s } +debianMirrorSuites :: [DebianSuite] -> DebianMirror -> DebianMirror +debianMirrorSuites s m = m { _debianMirrorSuites = s } -setDebianMirrorArchitectures :: [Architecture] -> DebianMirror -> DebianMirror -setDebianMirrorArchitectures a m = m { debianMirrorArchitectures = a } +debianMirrorArchitectures :: [Architecture] -> DebianMirror -> DebianMirror +debianMirrorArchitectures a m = m { _debianMirrorArchitectures = a } -setDebianMirrorSections :: [Apt.Section] -> DebianMirror -> DebianMirror -setDebianMirrorSections s m = m { debianMirrorSections = s } +debianMirrorSections :: [Apt.Section] -> DebianMirror -> DebianMirror +debianMirrorSections s m = m { _debianMirrorSections = s } -setDebianMirrorSourceBool :: Bool -> DebianMirror -> DebianMirror -setDebianMirrorSourceBool s m = m { debianMirrorSourceBool = s } +debianMirrorSourceBool :: Bool -> DebianMirror -> DebianMirror +debianMirrorSourceBool s m = m { _debianMirrorSourceBool = s } -setDebianMirrorPriorities :: [DebianPriority] -> DebianMirror -> DebianMirror -setDebianMirrorPriorities p m = m { debianMirrorPriorities = p } +debianMirrorPriorities :: [DebianPriority] -> DebianMirror -> DebianMirror +debianMirrorPriorities p m = m { _debianMirrorPriorities = p } -setDebianMirrorMethod :: Method -> DebianMirror -> DebianMirror -setDebianMirrorMethod me m = m { debianMirrorMethod = me } +debianMirrorMethod :: Method -> DebianMirror -> DebianMirror +debianMirrorMethod me m = m { _debianMirrorMethod = me } -setDebianMirrorKeyring :: FilePath -> DebianMirror -> DebianMirror -setDebianMirrorKeyring k m = m { debianMirrorKeyring = k } +debianMirrorKeyring :: FilePath -> DebianMirror -> DebianMirror +debianMirrorKeyring k m = m { _debianMirrorKeyring = k } -setDebianMirrorRsyncExtra :: [RsyncExtra] -> DebianMirror -> DebianMirror -setDebianMirrorRsyncExtra r m = m { debianMirrorRsyncExtra = r } +debianMirrorRsyncExtra :: [RsyncExtra] -> DebianMirror -> DebianMirror +debianMirrorRsyncExtra r m = m { _debianMirrorRsyncExtra = r } mirror :: DebianMirror -> Property NoInfo mirror mirror' = propertyList @@ -122,12 +128,12 @@ mirror mirror' = propertyList , File.ownerGroup dir (User "debmirror") (Group "debmirror") , check (not . and <$> mapM suitemirrored suites) $ cmdProperty "debmirror" args `describe` "debmirror setup" - , Cron.niceJob ("debmirror_" ++ dir) (debianMirrorCronTimes mirror') (User "debmirror") "/" $ + , Cron.niceJob ("debmirror_" ++ dir) (_debianMirrorCronTimes mirror') (User "debmirror") "/" $ unwords ("/usr/bin/debmirror" : args) ] where - dir = debianMirrorDir mirror' - suites = debianMirrorSuites mirror' + dir = _debianMirrorDir mirror' + suites = _debianMirrorSuites mirror' suitemirrored suite = doesDirectoryExist $ dir "dists" Apt.showSuite suite architecturearg = intercalate "," suitearg = intercalate "," $ map Apt.showSuite suites @@ -136,16 +142,16 @@ mirror mirror' = propertyList rsyncextraarg res = intercalate "," $ map showRsyncExtra res args = [ "--dist" , suitearg - , "--arch", architecturearg (debianMirrorArchitectures mirror') - , "--section", intercalate "," (debianMirrorSections mirror') - , "--limit-priority", "\"" ++ priorityRegex (debianMirrorPriorities mirror') ++ "\"" + , "--arch", architecturearg $ _debianMirrorArchitectures mirror' + , "--section", intercalate "," $ _debianMirrorSections mirror' + , "--limit-priority", "\"" ++ priorityRegex (_debianMirrorPriorities mirror') ++ "\"" ] ++ - (if (debianMirrorSourceBool mirror') then [] else ["--nosource"]) + (if _debianMirrorSourceBool mirror' then [] else ["--nosource"]) ++ - [ "--host", debianMirrorHostName mirror' - , "--method", showMethod $ debianMirrorMethod mirror' - , "--rsync-extra", rsyncextraarg $ debianMirrorRsyncExtra mirror' - , "--keyring", debianMirrorKeyring mirror' + [ "--host", _debianMirrorHostName mirror' + , "--method", showMethod $ _debianMirrorMethod mirror' + , "--rsync-extra", rsyncextraarg $ _debianMirrorRsyncExtra mirror' + , "--keyring", _debianMirrorKeyring mirror' , dir ] -- cgit v1.2.3