From 3218e344d117701066ced6c13927318ea2938ad4 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 26 Mar 2016 14:28:38 -0400 Subject: more porting --- src/Propellor/Property/DebianMirror.hs | 20 +++++++++---------- src/Propellor/Property/Dns.hs | 35 ++++++++++++++++++---------------- src/Propellor/Property/DnsSec.hs | 12 +++++++----- src/Propellor/Property/Fail2Ban.hs | 8 ++++---- src/Propellor/Property/File.hs | 10 +++++----- src/Propellor/Property/Firewall.hs | 4 ++-- src/Propellor/Property/FreeBSD/Pkg.hs | 17 ++++++++++------- src/Propellor/Property/Git.hs | 23 +++++++++++----------- src/Propellor/Property/Grub.hs | 32 +++++++++++++++---------------- src/Propellor/Property/Network.hs | 1 - src/Propellor/Property/Parted.hs | 17 ++++++++--------- src/Propellor/Property/Partition.hs | 11 ++++++----- src/Propellor/Property/Rsync.hs | 6 +++--- 13 files changed, 101 insertions(+), 95 deletions(-) diff --git a/src/Propellor/Property/DebianMirror.hs b/src/Propellor/Property/DebianMirror.hs index eea7b96f..b86d8e0b 100644 --- a/src/Propellor/Property/DebianMirror.hs +++ b/src/Propellor/Property/DebianMirror.hs @@ -119,19 +119,17 @@ 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") - , File.dirExists dir - , File.ownerGroup dir (User "debmirror") (Group "debmirror") - , check (not . and <$> mapM suitemirrored suites) +mirror :: DebianMirror -> Property DebianLike +mirror mirror' = propertyList ("Debian mirror " ++ dir) $ props + & Apt.installed ["debmirror"] + & User.accountFor (User "debmirror") + & File.dirExists dir + & 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") "/" $ - unwords ("/usr/bin/debmirror" : args) - ] + & Cron.niceJob ("debmirror_" ++ dir) (_debianMirrorCronTimes mirror') (User "debmirror") "/" + (unwords ("/usr/bin/debmirror" : args)) where dir = _debianMirrorDir mirror' suites = _debianMirrorSuites mirror' diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs index adc12930..a660a016 100644 --- a/src/Propellor/Property/Dns.hs +++ b/src/Propellor/Property/Dns.hs @@ -60,7 +60,7 @@ import Data.List -- -- In either case, the secondary dns server Host should have an ipv4 and/or -- ipv6 property defined. -primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty HasInfo +primary :: [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty (HasInfo + DebianLike) DebianLike primary hosts domain soa rs = setup cleanup where setup = setupPrimary zonefile id hosts domain soa rs @@ -70,7 +70,7 @@ primary hosts domain soa rs = setup cleanup zonefile = "/etc/bind/propellor/db." ++ domain -setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property HasInfo +setupPrimary :: FilePath -> (FilePath -> FilePath) -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> Property (HasInfo + DebianLike) setupPrimary zonefile mknamedconffile hosts domain soa rs = withwarnings baseprop `requires` servingZones @@ -80,9 +80,10 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs = indomain = M.elems $ M.filterWithKey (\hn _ -> inDomain domain $ AbsDomain $ hn) hostmap (partialzone, zonewarnings) = genZone indomain hostmap domain soa - baseprop = infoProperty ("dns primary for " ++ domain) satisfy - (mempty `addInfo` addNamedConf conf) [] - satisfy = do + baseprop = primaryprop + `addInfoProperty` (toInfo (addNamedConf conf)) + primaryprop :: Property DebianLike + primaryprop = property ("dns primary for " ++ domain) $ do sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap) let zone = partialzone { zHosts = zHosts partialzone ++ rs ++ sshfps } @@ -120,11 +121,13 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs = in z /= oldzone || oldserial < sSerial (zSOA zone) -cleanupPrimary :: FilePath -> Domain -> Property NoInfo +cleanupPrimary :: FilePath -> Domain -> Property DebianLike cleanupPrimary zonefile domain = check (doesFileExist zonefile) $ - property ("removed dns primary for " ++ domain) - (makeChange $ removeZoneFile zonefile) - `requires` namedConfWritten + go `requires` namedConfWritten + where + desc = "removed dns primary for " ++ domain + go :: Property DebianLike + go = property desc (makeChange $ removeZoneFile zonefile) -- | Primary dns server for a domain, secured with DNSSEC. -- @@ -152,7 +155,7 @@ cleanupPrimary zonefile domain = check (doesFileExist zonefile) $ -- This is different from the serial number used by 'primary', so if you -- want to later disable DNSSEC you will need to adjust the serial number -- passed to mkSOA to ensure it is larger. -signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty HasInfo +signedPrimary :: Recurrance -> [Host] -> Domain -> SOA -> [(BindDomain, Record)] -> RevertableProperty (HasInfo + DebianLike) DebianLike signedPrimary recurrance hosts domain soa rs = setup cleanup where setup = combineProperties ("dns primary for " ++ domain ++ " (signed)") @@ -184,12 +187,12 @@ signedPrimary recurrance hosts domain soa rs = setup cleanup -- -- Note that if a host is declared to be a primary and a secondary dns -- server for the same domain, the primary server config always wins. -secondary :: [Host] -> Domain -> RevertableProperty HasInfo +secondary :: [Host] -> Domain -> RevertableProperty (HasInfo + DebianLike) DebianLike secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts domain -- | This variant is useful if the primary server does not have its DNS -- configured via propellor. -secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty HasInfo +secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty (HasInfo + DebianLike) DebianLike secondaryFor masters hosts domain = setup cleanup where setup = pureInfoProperty desc (addNamedConf conf) @@ -218,15 +221,15 @@ otherServers wantedtype hosts domain = -- | Rewrites the whole named.conf.local file to serve the zones -- configured by `primary` and `secondary`, and ensures that bind9 is -- running. -servingZones :: Property NoInfo +servingZones :: Property DebianLike servingZones = namedConfWritten `onChange` Service.reloaded "bind9" `requires` Apt.serviceInstalledRunning "bind9" -namedConfWritten :: Property NoInfo -namedConfWritten = property "named.conf configured" $ do +namedConfWritten :: Property DebianLike +namedConfWritten = property' "named.conf configured" $ \w -> do zs <- getNamedConf - ensureProperty $ + ensureProperty w $ hasContent namedConfFile $ concatMap confStanza $ M.elems zs diff --git a/src/Propellor/Property/DnsSec.hs b/src/Propellor/Property/DnsSec.hs index 1ba459e6..aa58dc60 100644 --- a/src/Propellor/Property/DnsSec.hs +++ b/src/Propellor/Property/DnsSec.hs @@ -7,13 +7,13 @@ import qualified Propellor.Property.File as File -- -- signedPrimary uses this, so this property does not normally need to be -- used directly. -keysInstalled :: Domain -> RevertableProperty HasInfo +keysInstalled :: Domain -> RevertableProperty (HasInfo + UnixLike) UnixLike keysInstalled domain = setup cleanup where - setup = propertyList "DNSSEC keys installed" $ + setup = propertyList "DNSSEC keys installed" $ toProps $ map installkey keys - cleanup = propertyList "DNSSEC keys removed" $ + cleanup = propertyList "DNSSEC keys removed" $ toProps $ map (File.notPresent . keyFn domain) keys installkey k = writer (keysrc k) (keyFn domain k) (Context domain) @@ -37,12 +37,14 @@ keysInstalled domain = setup cleanup -- -- signedPrimary uses this, so this property does not normally need to be -- used directly. -zoneSigned :: Domain -> FilePath -> RevertableProperty HasInfo +zoneSigned :: Domain -> FilePath -> RevertableProperty (HasInfo + UnixLike) UnixLike zoneSigned domain zonefile = setup cleanup where + setup :: Property (HasInfo + UnixLike) setup = check needupdate (forceZoneSigned domain zonefile) `requires` keysInstalled domain + cleanup :: Property UnixLike cleanup = File.notPresent (signedZoneFile zonefile) `before` File.notPresent dssetfile `before` revert (keysInstalled domain) @@ -63,7 +65,7 @@ zoneSigned domain zonefile = setup cleanup t2 <- getModificationTime f return (t2 >= t1) -forceZoneSigned :: Domain -> FilePath -> Property NoInfo +forceZoneSigned :: Domain -> FilePath -> Property UnixLike forceZoneSigned domain zonefile = property ("zone signed for " ++ domain) $ liftIO $ do salt <- take 16 <$> saltSha1 let p = proc "dnssec-signzone" diff --git a/src/Propellor/Property/Fail2Ban.hs b/src/Propellor/Property/Fail2Ban.hs index 716d376f..9f147943 100644 --- a/src/Propellor/Property/Fail2Ban.hs +++ b/src/Propellor/Property/Fail2Ban.hs @@ -5,24 +5,24 @@ import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service import Propellor.Property.ConfFile -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.serviceInstalledRunning "fail2ban" -reloaded :: Property NoInfo +reloaded :: Property DebianLike reloaded = Service.reloaded "fail2ban" type Jail = String -- | By default, fail2ban only enables the ssh jail, but many others -- are available to be enabled, for example "postfix-sasl" -jailEnabled :: Jail -> Property NoInfo +jailEnabled :: Jail -> Property DebianLike jailEnabled name = jailConfigured name "enabled" "true" `onChange` reloaded -- | Configures a jail. For example: -- -- > jailConfigured "sshd" "port" "2222" -jailConfigured :: Jail -> IniKey -> String -> Property NoInfo +jailConfigured :: Jail -> IniKey -> String -> Property UnixLike jailConfigured name key value = jailConfFile name `containsIniSetting` (name, key, value) diff --git a/src/Propellor/Property/File.hs b/src/Propellor/Property/File.hs index 2a74b5ed..e072fcaa 100644 --- a/src/Propellor/Property/File.hs +++ b/src/Propellor/Property/File.hs @@ -25,25 +25,25 @@ f `hasContentProtected` newcontent = fileProperty' writeFileProtected -- -- The file's permissions are preserved if the file already existed. -- Otherwise, they're set to 600. -hasPrivContent :: IsContext c => FilePath -> c -> Property HasInfo +hasPrivContent :: IsContext c => FilePath -> c -> Property (HasInfo + UnixLike) hasPrivContent f = hasPrivContentFrom (PrivDataSourceFile (PrivFile f) f) f -- | Like hasPrivContent, but allows specifying a source -- for PrivData, rather than using PrivDataSourceFile . -hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo +hasPrivContentFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property (HasInfo + UnixLike) hasPrivContentFrom = hasPrivContent' writeFileProtected -- | Leaves the file at its default or current mode, -- allowing "private" data to be read. -- -- Use with caution! -hasPrivContentExposed :: IsContext c => FilePath -> c -> Property HasInfo +hasPrivContentExposed :: IsContext c => FilePath -> c -> Property (HasInfo + UnixLike) hasPrivContentExposed f = hasPrivContentExposedFrom (PrivDataSourceFile (PrivFile f) f) f -hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property HasInfo +hasPrivContentExposedFrom :: (IsContext c, IsPrivDataSource s) => s -> FilePath -> c -> Property (HasInfo + UnixLike) hasPrivContentExposedFrom = hasPrivContent' writeFile -hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (FilePath -> String -> IO ()) -> s -> FilePath -> c -> Property HasInfo +hasPrivContent' :: (IsContext c, IsPrivDataSource s) => (FilePath -> String -> IO ()) -> s -> FilePath -> c -> Property (HasInfo + UnixLike) hasPrivContent' writer source f context = withPrivData source context $ \getcontent -> property' desc $ \o -> getcontent $ \privcontent -> diff --git a/src/Propellor/Property/Firewall.hs b/src/Propellor/Property/Firewall.hs index fa1f95d4..ce0befcd 100644 --- a/src/Propellor/Property/Firewall.hs +++ b/src/Propellor/Property/Firewall.hs @@ -26,10 +26,10 @@ import Propellor.Base import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Network as Network -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["iptables"] -rule :: Chain -> Table -> Target -> Rules -> Property NoInfo +rule :: Chain -> Table -> Target -> Rules -> Property Linux rule c tb tg rs = property ("firewall rule: " <> show r) addIpTable where r = Rule c tb tg rs diff --git a/src/Propellor/Property/FreeBSD/Pkg.hs b/src/Propellor/Property/FreeBSD/Pkg.hs index 6bbd2570..6c775b94 100644 --- a/src/Propellor/Property/FreeBSD/Pkg.hs +++ b/src/Propellor/Property/FreeBSD/Pkg.hs @@ -22,8 +22,8 @@ runPkg cmd args = in lines <$> readProcess p a -pkgCmdProperty :: String -> [String] -> UncheckedProperty NoInfo -pkgCmdProperty cmd args = +pkgCmdProperty :: String -> [String] -> UncheckedProperty FreeBSD +pkgCmdProperty cmd args = tightenTargets $ let (p, a) = pkgCommand cmd args in @@ -44,13 +44,14 @@ instance IsInfo PkgUpdate where pkgUpdated :: PkgUpdate -> Bool pkgUpdated (PkgUpdate _) = True -update :: Property HasInfo +update :: Property (HasInfo + FreeBSD) update = let upd = pkgCmd "update" [] go = ifM (pkgUpdated <$> askInfo) ((noChange), (liftIO upd >> return MadeChange)) in - infoProperty "pkg update has run" go (addInfo mempty (PkgUpdate "")) [] + (property "pkg update has run" go :: Property FreeBSD) + `addInfoProperty` (toInfo (PkgUpdate "")) newtype PkgUpgrade = PkgUpgrade String deriving (Typeable, Monoid, Show) @@ -60,17 +61,19 @@ instance IsInfo PkgUpgrade where pkgUpgraded :: PkgUpgrade -> Bool pkgUpgraded (PkgUpgrade _) = True -upgrade :: Property HasInfo +upgrade :: Property (HasInfo + FreeBSD) upgrade = let upd = pkgCmd "upgrade" [] go = ifM (pkgUpgraded <$> askInfo) ((noChange), (liftIO upd >> return MadeChange)) in - infoProperty "pkg upgrade has run" go (addInfo mempty (PkgUpgrade "")) [] `requires` update + (property "pkg upgrade has run" go :: Property FreeBSD) + `addInfoProperty` (toInfo (PkgUpdate "")) + `requires` update type Package = String -installed :: Package -> Property NoInfo +installed :: Package -> Property FreeBSD installed pkg = check (isInstallable pkg) $ pkgCmdProperty "install" [pkg] isInstallable :: Package -> IO Bool diff --git a/src/Propellor/Property/Git.hs b/src/Propellor/Property/Git.hs index a5ef5ab1..5d7c8b4d 100644 --- a/src/Propellor/Property/Git.hs +++ b/src/Propellor/Property/Git.hs @@ -11,7 +11,7 @@ import Data.List -- using git-daemon, run from inetd. -- -- Note that reverting this property does not remove or stop inetd. -daemonRunning :: FilePath -> RevertableProperty NoInfo +daemonRunning :: FilePath -> RevertableProperty DebianLike DebianLike daemonRunning exportdir = setup unsetup where setup = containsLine conf (mkl "tcp4") @@ -47,7 +47,7 @@ daemonRunning exportdir = setup unsetup , exportdir ] -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["git"] type RepoUrl = String @@ -61,8 +61,8 @@ type Branch = String -- it will be recursively deleted first. -- -- A branch can be specified, to check out. -cloned :: User -> RepoUrl -> FilePath -> Maybe Branch -> Property NoInfo -cloned owner url dir mbranch = check originurl (property desc checkout) +cloned :: User -> RepoUrl -> FilePath -> Maybe Branch -> Property DebianLike +cloned owner url dir mbranch = check originurl go `requires` installed where desc = "git cloned " ++ url ++ " to " ++ dir @@ -74,12 +74,13 @@ cloned owner url dir mbranch = check originurl (property desc checkout) return (v /= Just url) , return True ) - checkout = do + go :: Property DebianLike + go = property' desc $ \w -> do liftIO $ do whenM (doesDirectoryExist dir) $ removeDirectoryRecursive dir createDirectoryIfMissing True (takeDirectory dir) - ensureProperty $ userScriptProperty owner (catMaybes checkoutcmds) + ensureProperty w $ userScriptProperty owner (catMaybes checkoutcmds) `assume` MadeChange checkoutcmds = -- The catchMaybeIO (readProcess "git" ["rev-parse", "--re data GitShared = Shared Group | SharedAll | NotShared -bareRepo :: FilePath -> User -> GitShared -> Property NoInfo -bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $ +bareRepo :: FilePath -> User -> GitShared -> Property UnixLike +bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " ++ repo) $ toProps $ dirExists repo : case gitshared of NotShared -> [ ownerGroup repo user (userGroup user) @@ -121,7 +122,7 @@ bareRepo repo user gitshared = check (isRepo repo) $ propertyList ("git repo: " isRepo repo' = isNothing <$> catchMaybeIO (readProcess "git" ["rev-parse", "--resolve-git-dir", repo']) -- | Set a key value pair in a git repo's configuration. -repoConfigured :: FilePath -> (String, String) -> Property NoInfo +repoConfigured :: FilePath -> (String, String) -> Property UnixLike repo `repoConfigured` (key, value) = check (not <$> alreadyconfigured) $ userScriptProperty (User "root") [ "cd " ++ repo @@ -141,7 +142,7 @@ getRepoConfig repo key = catchDefaultIO [] $ lines <$> readProcess "git" ["-C", repo, "config", key] -- | Whether a repo accepts non-fast-forward pushes. -repoAcceptsNonFFs :: FilePath -> RevertableProperty NoInfo +repoAcceptsNonFFs :: FilePath -> RevertableProperty UnixLike UnixLike repoAcceptsNonFFs repo = accepts refuses where accepts = repoConfigured repo ("receive.denyNonFastForwards", "false") @@ -152,7 +153,7 @@ repoAcceptsNonFFs repo = accepts refuses -- | Sets a bare repository's default branch, which will be checked out -- when cloning it. -bareRepoDefaultBranch :: FilePath -> String -> Property NoInfo +bareRepoDefaultBranch :: FilePath -> String -> Property UnixLike bareRepoDefaultBranch repo branch = userScriptProperty (User "root") [ "cd " ++ repo diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs index 1b7f2a0a..09255587 100644 --- a/src/Propellor/Property/Grub.hs +++ b/src/Propellor/Property/Grub.hs @@ -19,17 +19,17 @@ data BIOS = PC | EFI64 | EFI32 | Coreboot | Xen -- bootloader. -- -- This includes running update-grub. -installed :: BIOS -> Property NoInfo +installed :: BIOS -> Property DebianLike installed bios = installed' bios `onChange` 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" [] +mkConfig :: Property DebianLike +mkConfig = tightenTargets $ cmdProperty "update-grub" [] `assume` MadeChange -- | Installs grub; does not run update-grub. -installed' :: BIOS -> Property NoInfo +installed' :: BIOS -> Property DebianLike installed' bios = Apt.installed [pkg] `describe` "grub package installed" where pkg = case bios of @@ -48,8 +48,8 @@ installed' bios = Apt.installed [pkg] `describe` "grub package installed" -- on the device; it always does the work to reinstall it. It's a good idea -- to arrange for this property to only run once, by eg making it be run -- onChange after OS.cleanInstallOnce. -boots :: OSDevice -> Property NoInfo -boots dev = cmdProperty "grub-install" [dev] +boots :: OSDevice -> Property Linux +boots dev = tightenTargets $ cmdProperty "grub-install" [dev] `assume` MadeChange `describe` ("grub boots " ++ dev) @@ -61,10 +61,10 @@ boots dev = cmdProperty "grub-install" [dev] -- -- The rootdev should be in the form "hd0", while the bootdev is in the form -- "xen/xvda". -chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property NoInfo -chainPVGrub rootdev bootdev timeout = combineProperties desc - [ File.dirExists "/boot/grub" - , "/boot/grub/menu.lst" `File.hasContent` +chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property DebianLike +chainPVGrub rootdev bootdev timeout = combineProperties desc $ props + & File.dirExists "/boot/grub" + & "/boot/grub/menu.lst" `File.hasContent` [ "default 1" , "timeout " ++ show timeout , "" @@ -73,12 +73,12 @@ chainPVGrub rootdev bootdev timeout = combineProperties desc , "kernel /boot/xen-shim" , "boot" ] - , "/boot/load.cf" `File.hasContent` + & "/boot/load.cf" `File.hasContent` [ "configfile (" ++ bootdev ++ ")/boot/grub/grub.cfg" ] - , installed Xen - , flip flagFile "/boot/xen-shim" $ scriptProperty ["grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"] - `assume` MadeChange - `describe` "/boot-xen-shim" - ] + & installed Xen + & flip flagFile "/boot/xen-shim" xenshim where desc = "chain PV-grub" + xenshim = scriptProperty ["grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"] + `assume` MadeChange + `describe` "/boot-xen-shim" diff --git a/src/Propellor/Property/Network.hs b/src/Propellor/Property/Network.hs index 46f5cef3..9ed9e591 100644 --- a/src/Propellor/Property/Network.hs +++ b/src/Propellor/Property/Network.hs @@ -2,7 +2,6 @@ module Propellor.Property.Network where import Propellor.Base import Propellor.Property.File -import Propellor.Types.MetaTypes import Data.Char diff --git a/src/Propellor/Property/Parted.hs b/src/Propellor/Property/Parted.hs index 5d6afa9c..bc8a256d 100644 --- a/src/Propellor/Property/Parted.hs +++ b/src/Propellor/Property/Parted.hs @@ -153,18 +153,17 @@ data Eep = YesReallyDeleteDiskContents -- The FilePath can be a block device (eg, \/dev\/sda), or a disk image file. -- -- This deletes any existing partitions in the disk! Use with EXTREME caution! -partitioned :: Eep -> FilePath -> PartTable -> Property NoInfo -partitioned eep disk (PartTable tabletype parts) = property desc $ do +partitioned :: Eep -> FilePath -> PartTable -> Property DebianLike +partitioned eep disk (PartTable tabletype parts) = property' desc $ \w -> do isdev <- liftIO $ isBlockDevice <$> getFileStatus disk - ensureProperty $ combineProperties desc - [ parted eep disk partedparams - , if isdev + ensureProperty w $ combineProperties desc $ props + & parted eep disk partedparams + & if isdev then formatl (map (\n -> disk ++ show n) [1 :: Int ..]) else Partition.kpartx disk (formatl . map Partition.partitionLoopDev) - ] where desc = disk ++ " partitioned" - formatl devs = combineProperties desc (map format (zip parts devs)) + formatl devs = combineProperties desc (toProps $ map format (zip parts devs)) partedparams = concat $ mklabel : mkparts (1 :: Integer) mempty parts [] format (p, dev) = Partition.formatted' (partMkFsOpts p) Partition.YesReallyFormatPartition (partFs p) dev @@ -193,12 +192,12 @@ partitioned eep disk (PartTable tabletype parts) = property desc $ do -- -- Parted is run in script mode, so it will never prompt for input. -- It is asked to use cylinder alignment for the disk. -parted :: Eep -> FilePath -> [String] -> Property NoInfo +parted :: Eep -> FilePath -> [String] -> Property DebianLike parted YesReallyDeleteDiskContents disk ps = p `requires` installed where p = cmdProperty "parted" ("--script":"--align":"cylinder":disk:ps) `assume` MadeChange -- | Gets parted installed. -installed :: Property NoInfo +installed :: Property DebianLike installed = Apt.installed ["parted"] diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs index b2f50339..5aff4ba4 100644 --- a/src/Propellor/Property/Partition.hs +++ b/src/Propellor/Property/Partition.hs @@ -16,7 +16,7 @@ data Fs = EXT2 | EXT3 | EXT4 | BTRFS | REISERFS | XFS | FAT | VFAT | NTFS | Linu data Eep = YesReallyFormatPartition -- | Formats a partition. -formatted :: Eep -> Fs -> FilePath -> Property NoInfo +formatted :: Eep -> Fs -> FilePath -> Property DebianLike formatted = formatted' [] -- | Options passed to a mkfs.* command when making a filesystem. @@ -24,7 +24,7 @@ formatted = formatted' [] -- Eg, ["-m0"] type MkfsOpts = [String] -formatted' :: MkfsOpts -> Eep -> Fs -> FilePath -> Property NoInfo +formatted' :: MkfsOpts -> Eep -> Fs -> FilePath -> Property DebianLike formatted' opts YesReallyFormatPartition fs dev = cmdProperty cmd opts' `assume` MadeChange `requires` Apt.installed [pkg] @@ -64,17 +64,18 @@ isLoopDev' f -- 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 -> ([LoopDev] -> Property NoInfo) -> Property NoInfo +kpartx :: FilePath -> ([LoopDev] -> Property DebianLike) -> Property DebianLike kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"] where - go = property (propertyDesc (mkprop [])) $ do + go :: Property DebianLike + go = property' (propertyDesc (mkprop [])) $ \w -> do cleanup -- idempotency 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) + r <- ensureProperty w (mkprop loopdevs) cleanup return r cleanup = void $ liftIO $ boolSystem "kpartx" [Param "-d", File diskimage] diff --git a/src/Propellor/Property/Rsync.hs b/src/Propellor/Property/Rsync.hs index 0c77df58..b40396de 100644 --- a/src/Propellor/Property/Rsync.hs +++ b/src/Propellor/Property/Rsync.hs @@ -16,7 +16,7 @@ filesUnder d = Pattern (d ++ "/*") -- | Ensures that the Dest directory exists and has identical contents as -- the Src directory. -syncDir :: Src -> Dest -> Property NoInfo +syncDir :: Src -> Dest -> Property DebianLike syncDir = syncDirFiltered [] data Filter @@ -43,7 +43,7 @@ newtype Pattern = Pattern String -- Rsync checks each name to be transferred against its list of Filter -- rules, and the first matching one is acted on. If no matching rule -- is found, the file is processed. -syncDirFiltered :: [Filter] -> Src -> Dest -> Property NoInfo +syncDirFiltered :: [Filter] -> Src -> Dest -> Property DebianLike syncDirFiltered filters src dest = rsync $ [ "-av" -- Add trailing '/' to get rsync to sync the Dest directory, @@ -56,7 +56,7 @@ syncDirFiltered filters src dest = rsync $ , "--quiet" ] ++ map toRsync filters -rsync :: [String] -> Property NoInfo +rsync :: [String] -> Property DebianLike rsync ps = cmdProperty "rsync" ps `assume` MadeChange `requires` Apt.installed ["rsync"] -- cgit v1.2.3