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/Grub.hs | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) (limited to 'src/Propellor/Property/Grub.hs') 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" -- cgit v1.3-2-g0d8e From 0b0ea182ab3301ade8b87b1be1cdecc3464cd1da Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 27 Mar 2016 16:10:43 -0400 Subject: ported DiskImage Unfortunately, DiskImage needs to add properties to the Chroot it's presented with, and the metatypes are not included in the Chroot, so it can't guarantee that the properties it's adding match the OS in the Chroot. I partially worked around this by making the properties that DiskImage adds check the OS, so they don't assume Debian. It would be nicer to parameterize the Chroot type with the metatypes of the inner OS. I worked for several hours on a patch along those lines, but it doesn't quite compile. Failed at the final hurdle :/ The patch is below for later.. --- src/Propellor/Property/Chroot.hs 2016-03-27 16:06:44.285464820 -0400 +++ /home/joey/Chroot.hs 2016-03-27 15:32:29.073416143 -0400 @@ -1,9 +1,9 @@ -{-# LANGUAGE FlexibleContexts, GADTs, DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts, GADTs, DeriveDataTypeable, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, DataKinds #-} module Propellor.Property.Chroot ( debootstrapped, bootstrapped, - provisioned, + --provisioned, Chroot(..), ChrootBootstrapper(..), Debootstrapped(..), @@ -11,7 +11,7 @@ noServices, inChroot, -- * Internal use - provisioned', + --provisioned', propagateChrootInfo, propellChroot, chain, @@ -20,6 +20,7 @@ import Propellor.Base import Propellor.Container +import Propellor.Types.MetaTypes import Propellor.Types.CmdLine import Propellor.Types.Chroot import Propellor.Types.Info @@ -38,27 +39,29 @@ -- | Specification of a chroot. Normally you'll use `debootstrapped` or -- `bootstrapped` to construct a Chroot value. -data Chroot where - Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot - -instance IsContainer Chroot where - containerProperties (Chroot _ _ h) = containerProperties h - containerInfo (Chroot _ _ h) = containerInfo h - setContainerProperties (Chroot loc b h) ps = Chroot loc b (setContainerProperties h ps) +-- +-- The inner and outer type variables are the metatypes of the inside of +-- the chroot and the system it runs in. +data Chroot inner outer where + Chroot :: ChrootBootstrapper b inner outer => FilePath -> b -> Host -> (inner, outer) -> Chroot inner outer + +instance IsContainer (Chroot inner outer) where + containerProperties (Chroot _ _ h _) = containerProperties h + containerInfo (Chroot _ _ h _) = containerInfo h -chrootSystem :: Chroot -> Maybe System +chrootSystem :: Chroot inner outer -> Maybe System chrootSystem = fromInfoVal . fromInfo . containerInfo -instance Show Chroot where - show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c) +instance Show (Chroot inner outer) where + show c@(Chroot loc _ _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c) -- | Class of things that can do initial bootstrapping of an operating -- System in a chroot. -class ChrootBootstrapper b where +class ChrootBootstrapper b inner outer where -- | Do initial bootstrapping of an operating system in a chroot. -- If the operating System is not supported, return -- Left error message. - buildchroot :: b -> Maybe System -> FilePath -> Either String (Property Linux) + buildchroot :: b -> Maybe System -> FilePath -> Either String (Property outer) -- | Use this to bootstrap a chroot by extracting a tarball. -- @@ -68,9 +71,8 @@ -- detect automatically. data ChrootTarball = ChrootTarball FilePath -instance ChrootBootstrapper ChrootTarball where - buildchroot (ChrootTarball tb) _ loc = Right $ - tightenTargets $ extractTarball loc tb +instance ChrootBootstrapper ChrootTarball UnixLike UnixLike where + buildchroot (ChrootTarball tb) _ loc = Right $ extractTarball loc tb extractTarball :: FilePath -> FilePath -> Property UnixLike extractTarball target src = check (unpopulated target) $ @@ -88,7 +90,7 @@ -- | Use this to bootstrap a chroot with debootstrap. data Debootstrapped = Debootstrapped Debootstrap.DebootstrapConfig -instance ChrootBootstrapper Debootstrapped where +instance ChrootBootstrapper Debootstrapped DebianLike Linux where buildchroot (Debootstrapped cf) system loc = case system of (Just s@(System (Debian _) _)) -> Right $ debootstrap s (Just s@(System (Buntish _) _)) -> Right $ debootstrap s @@ -107,13 +109,22 @@ -- > & osDebian Unstable "amd64" -- > & Apt.installed ["ghc", "haskell-platform"] -- > & ... -debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot +-- debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot DebianLike +debootstrapped + :: (SingI inner, SingI outer, ChrootBootstrapper Debootstrapped (MetaTypes inner) (MetaTypes outer)) + => Debootstrap.DebootstrapConfig + -> FilePath + -> Chroot (MetaTypes inner) (MetaTypes outer) debootstrapped conf = bootstrapped (Debootstrapped conf) -- | Defines a Chroot at the given location, bootstrapped with the -- specified ChrootBootstrapper. -bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Chroot -bootstrapped bootstrapper location = Chroot location bootstrapper h +bootstrapped + :: (SingI inner, SingI outer, ChrootBootstrapper b (MetaTypes inner) (MetaTypes outer)) + => b + -> FilePath + -> Chroot (MetaTypes inner) (MetaTypes outer) +bootstrapped bootstrapper location = Chroot location bootstrapper h (sing, sing) where h = Host location [] mempty @@ -123,45 +134,79 @@ -- Reverting this property removes the chroot. Anything mounted inside it -- is first unmounted. Note that it does not ensure that any processes -- that might be running inside the chroot are stopped. -provisioned :: Chroot -> RevertableProperty (HasInfo + Linux) Linux +-- provisioned :: SingI outer => Chroot inner outer -> RevertableProperty (HasInfo + MetaTypes outer) Linux +provisioned + :: + ( SingI outer + , SingI metatypes + , Combines (Property (MetaTypes outer)) (Property (MetaTypes outer)) + , (HasInfo + outer) ~ MetaTypes metatypes + , CombinedType (Property (MetaTypes outer)) (Property (MetaTypes outer)) ~ Property outer + , IncludesInfo (MetaTypes metatypes) ~ 'True) + => Chroot inner outer -> RevertableProperty (HasInfo + outer) Linux provisioned c = provisioned' (propagateChrootInfo c) c False provisioned' - :: (Property Linux -> Property (HasInfo + Linux)) - -> Chroot + :: + ( Combines (Property (MetaTypes outer)) (Property (MetaTypes outer)) + , CombinedType (Property (MetaTypes outer)) (Property (MetaTypes outer)) ~ Property outer + , SingI outer + ) + => (Property outer -> Property (HasInfo + outer)) + -> Chroot inner outer -> Bool - -> RevertableProperty (HasInfo + Linux) Linux -provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly = - (propigator $ setup `describe` chrootDesc c "exists") + -> RevertableProperty (HasInfo + outer) Linux +provisioned' propigator c systemdonly = + (propigator $ setup c systemdonly `describe` chrootDesc c "exists") - (teardown `describe` chrootDesc c "removed") - where - setup :: Property Linux - setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly - `requires` built - - built = case buildchroot bootstrapper (chrootSystem c) loc of - Right p -> p - Left e -> cantbuild e - - cantbuild e = property (chrootDesc c "built") (error e) - - teardown :: Property Linux - teardown = check (not <$> unpopulated loc) $ - property ("removed " ++ loc) $ - makeChange (removeChroot loc) - -propagateChrootInfo :: Chroot -> Property Linux -> Property (HasInfo + Linux) -propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c $ - p `addInfoProperty` chrootInfo c + (teardown c `describe` chrootDesc c "removed") -chrootInfo :: Chroot -> Info -chrootInfo (Chroot loc _ h) = mempty `addInfo` +-- chroot removal code is currently linux specific.. +teardown :: Chroot inner outer -> Property Linux +teardown (Chroot loc _ _ _) = check (not <$> unpopulated loc) $ + property ("removed " ++ loc) $ + makeChange (removeChroot loc) + +setup + :: + ( SingI outer + , Combines (Property (MetaTypes outer)) (Property (MetaTypes outer)) + ) + => Chroot inner outer + -> Bool + -> CombinedType (Property (MetaTypes outer)) (Property (MetaTypes outer)) +setup c systemdonly = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly + `requires` built c + +built :: (SingI outer, ChrootBootstrapper b inner outer) => Chroot inner outer -> Property (MetaTypes outer) +built c@(Chroot loc bootstrapper _ _) = + case buildchroot bootstrapper (chrootSystem c) loc of + Right p -> error "FOO" -- p + Left e -> error "FOO" -- cantbuild c e + +cantbuild :: Chroot inner outer -> String -> Property UnixLike +cantbuild c e = property (chrootDesc c "built") (error e) + +propagateChrootInfo + :: + ( SingI metatypes + , (HasInfo + outer) ~ MetaTypes metatypes + , IncludesInfo (MetaTypes metatypes) ~ 'True + ) + => Chroot inner outer + -> Property outer + -> Property (MetaTypes metatypes) +propagateChrootInfo c@(Chroot location _ _ _) p = + propagateContainer location c $ + p `addInfoProperty` chrootInfo c + +chrootInfo :: Chroot inner outer -> Info +chrootInfo (Chroot loc _ h _) = mempty `addInfo` mempty { _chroots = M.singleton loc h } -- | Propellor is run inside the chroot to provision it. -propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property UnixLike -propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do +propellChroot :: SingI outer => Chroot inner outer -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property (MetaTypes outer) +propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do let d = localdir shimdir c let me = localdir "propellor" shim <- liftIO $ ifM (doesDirectoryExist d) @@ -199,8 +244,8 @@ liftIO cleanup return r -toChain :: HostName -> Chroot -> Bool -> IO CmdLine -toChain parenthost (Chroot loc _ _) systemdonly = do +toChain :: HostName -> Chroot inner outer -> Bool -> IO CmdLine +toChain parenthost (Chroot loc _ _ _) systemdonly = do onconsole <- isConsole <$> getMessageHandle return $ ChrootChain parenthost loc systemdonly onconsole @@ -224,8 +269,8 @@ putStrLn $ "\n" ++ show r chain _ _ = errorMessage "bad chain command" -inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ()) -inChrootProcess keepprocmounted (Chroot loc _ _) cmd = do +inChrootProcess :: Bool -> Chroot inner outer -> [String] -> IO (CreateProcess, IO ()) +inChrootProcess keepprocmounted (Chroot loc _ _ _) cmd = do mountproc return (proc "chroot" (loc:cmd), cleanup) where @@ -244,26 +289,24 @@ provisioningLock :: FilePath -> FilePath provisioningLock containerloc = "chroot" mungeloc containerloc ++ ".lock" -shimdir :: Chroot -> FilePath -shimdir (Chroot loc _ _) = "chroot" mungeloc loc ++ ".shim" +shimdir :: Chroot inner outer -> FilePath +shimdir (Chroot loc _ _ _) = "chroot" mungeloc loc ++ ".shim" mungeloc :: FilePath -> String mungeloc = replace "/" "_" -chrootDesc :: Chroot -> String -> String -chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc +chrootDesc :: Chroot inner outer -> String -> String +chrootDesc (Chroot loc _ _ _) desc = "chroot " ++ loc ++ " " ++ desc --- src/Propellor/Container.hs | 18 ++++++++- src/Propellor/PropAccum.hs | 12 ------ src/Propellor/Property.hs | 2 +- src/Propellor/Property/Chroot.hs | 11 +++-- src/Propellor/Property/Conductor.hs | 7 ++-- src/Propellor/Property/DiskImage.hs | 81 ++++++++++++++++++++++--------------- src/Propellor/Property/Grub.hs | 11 +++-- src/Propellor/Property/Ssh.hs | 2 +- src/Propellor/Types/MetaTypes.hs | 2 +- 9 files changed, 87 insertions(+), 59 deletions(-) (limited to 'src/Propellor/Property/Grub.hs') diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs index 832faf9c..4cd46ae5 100644 --- a/src/Propellor/Container.hs +++ b/src/Propellor/Container.hs @@ -6,14 +6,28 @@ import Propellor.Types import Propellor.Types.MetaTypes import Propellor.Types.Info import Propellor.PrivData +import Propellor.PropAccum class IsContainer c where containerProperties :: c -> [ChildProperty] containerInfo :: c -> Info + setContainerProperties :: c -> [ChildProperty] -> c instance IsContainer Host where - containerProperties = hostProperties - containerInfo = hostInfo + containerProperties = hostProperties + containerInfo = hostInfo + setContainerProperties h ps = host (hostName h) (Props ps) + +-- | Note that the metatype of a container's properties is not retained, +-- so this defaults to UnixLike. So, using this with setContainerProps can +-- add properties to a container that conflict with properties already in it. +-- Use caution when using this; only add properties that do not have +-- restricted targets. +containerProps :: IsContainer c => c -> Props UnixLike +containerProps = Props . containerProperties + +setContainerProps :: IsContainer c => c -> Props metatypes -> c +setContainerProps c (Props ps) = setContainerProperties c ps -- | Adjust the provided Property, adding to its -- propertyChidren the properties of the provided container. diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs index 1212ef7a..856f2e8e 100644 --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -12,8 +12,6 @@ module Propellor.PropAccum , (&) , (&^) , (!) - , hostProps - , modifyHostProps ) where import Propellor.Types @@ -32,16 +30,6 @@ import Prelude host :: HostName -> Props metatypes -> Host host hn (Props ps) = Host hn ps (mconcat (map getInfoRecursive ps)) --- | Note that the metatype of a Host's properties is not retained, --- so this defaults to UnixLike. So, using this with modifyHostProps can --- add properties to a Host that conflict with properties already in it. --- Use caution when using this. -hostProps :: Host -> Props UnixLike -hostProps = Props . hostProperties - -modifyHostProps :: Host -> Props metatypes -> Host -modifyHostProps h ps = host (hostName h) ps - -- | Props is a combination of a list of properties, with their combined -- metatypes. data Props metatypes = Props [ChildProperty] diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 9fa29888..70583edc 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -308,7 +308,7 @@ makeChange a = liftIO a >> return MadeChange noChange :: Propellor Result noChange = return NoChange -doNothing :: Property UnixLike +doNothing :: SingI t => Property (MetaTypes t) doNothing = property "noop property" noChange -- | Registers an action that should be run at the very end, after diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index ddadc763..b29da7f9 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -44,6 +44,7 @@ data Chroot where instance IsContainer Chroot where containerProperties (Chroot _ _ h) = containerProperties h containerInfo (Chroot _ _ h) = containerInfo h + setContainerProperties (Chroot loc b h) ps = Chroot loc b (setContainerProperties h ps) chrootSystem :: Chroot -> Maybe System chrootSystem = fromInfoVal . fromInfo . containerInfo @@ -256,11 +257,13 @@ chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc -- 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 +-- On Debian, 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 DebianLike DebianLike -noServices = tightenTargets setup tightenTargets teardown +-- +-- This property has no effect on non-Debian systems. +noServices :: RevertableProperty UnixLike UnixLike +noServices = setup teardown where f = "/usr/sbin/policy-rc.d" script = [ "#!/bin/sh", "exit 101" ] diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs index 005fc804..ab747acc 100644 --- a/src/Propellor/Property/Conductor.hs +++ b/src/Propellor/Property/Conductor.hs @@ -74,6 +74,7 @@ module Propellor.Property.Conductor ( ) where import Propellor.Base +import Propellor.Container import Propellor.Spin (spin') import Propellor.PrivData.Paths import Propellor.Types.Info @@ -219,7 +220,7 @@ orchestrate hs = map go hs os = extractOrchestras hs removeold h = foldl removeold' h (oldconductorsof h) - removeold' h oldconductor = modifyHostProps h $ hostProps h + removeold' h oldconductor = setContainerProps h $ containerProps h ! conductedBy oldconductor oldconductors = zip hs (map (fromInfo . hostInfo) hs) @@ -234,7 +235,7 @@ orchestrate' h (Conducted _) = h orchestrate' h (Conductor c l) | sameHost h c = cont $ addConductorPrivData h (concatMap allHosts l) | any (sameHost h) (map topHost l) = cont $ - modifyHostProps h $ hostProps h + setContainerProps h $ containerProps h & conductedBy c | otherwise = cont h where @@ -268,7 +269,7 @@ conductorFor h = go -- Reverts conductorFor. notConductorFor :: Host -> Property (HasInfo + UnixLike) -notConductorFor h = doNothing +notConductorFor h = (doNothing :: Property UnixLike) `addInfoProperty` (toInfo (NotConductorFor [h])) `describe` desc `requires` undoRevertableProperty (conductorKnownHost h) diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 48df7fab..8c027b05 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -2,6 +2,8 @@ -- -- This module is designed to be imported unqualified. +{-# LANGUAGE TypeFamilies #-} + module Propellor.Property.DiskImage ( -- * Partition specification module Propellor.Property.DiskImage.PartSpec, @@ -30,6 +32,7 @@ import Propellor.Property.Parted import Propellor.Property.Mount import Propellor.Property.Partition import Propellor.Property.Rsync +import Propellor.Container import Utility.Path import Data.List (isPrefixOf, isInfixOf, sortBy) @@ -51,7 +54,8 @@ type DiskImage = FilePath -- -- > import Propellor.Property.DiskImage -- --- > let chroot d = Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty d +-- > let chroot d = Chroot.debootstrapped mempty d +-- > & osDebian Unstable "amd64" -- > & Apt.installed ["linux-image-amd64"] -- > & User.hasPassword (User "root") -- > & User.accountFor (User "demo") @@ -89,31 +93,44 @@ imageBuilt' :: Bool -> DiskImage -> (FilePath -> Chroot) -> TableType -> Finaliz imageBuilt' rebuild img mkchroot tabletype final partspec = imageBuiltFrom img chrootdir tabletype final partspec `requires` Chroot.provisioned chroot - `requires` (cleanrebuild doNothing) + `requires` (cleanrebuild (doNothing :: Property UnixLike)) `describe` desc where desc = "built disk image " ++ img + cleanrebuild :: Property Linux cleanrebuild | rebuild = property desc $ do liftIO $ removeChroot chrootdir return MadeChange | 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 - & Apt.cacheCleaned + chroot = + let c = mkchroot chrootdir + in setContainerProps c $ containerProps c + -- Before ensuring any other properties of the chroot, + -- avoid starting services. Reverted by imageFinalized. + &^ Chroot.noServices + -- First stage finalization. + & fst final + & cachesCleaned + +-- | This property is automatically added to the chroot when building a +-- disk image. It cleans any caches of information that can be omitted; +-- eg the apt cache on Debian. +cachesCleaned :: Property UnixLike +cachesCleaned = withOS "cache cleaned" $ \w o -> + let aptclean = ensureProperty w Apt.cacheCleaned + in case o of + (Just (System (Debian _) _)) -> aptclean + (Just (System (Buntish _) _)) -> aptclean + _ -> noChange -- | Builds a disk image from the contents of a chroot. -imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty Linux Linux +imageBuiltFrom :: DiskImage -> FilePath -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + Linux) UnixLike imageBuiltFrom img chrootdir tabletype final partspec = mkimg rmimg where desc = img ++ " built from " ++ chrootdir - mkimg = property desc $ do + mkimg = property' desc $ \w -> do -- unmount helper filesystems such as proc from the chroot -- before getting sizes liftIO $ unmountBelow chrootdir @@ -123,7 +140,7 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg rmimg -- tie the knot! let (mnts, mntopts, parttable) = fitChrootSize tabletype partspec $ map (calcsz mnts) mnts - ensureProperty $ + ensureProperty w $ imageExists img (partTableSize parttable) `before` partitioned YesReallyDeleteDiskContents img parttable @@ -136,16 +153,17 @@ imageBuiltFrom img chrootdir tabletype final partspec = mkimg rmimg rmimg = File.notPresent img partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property Linux -partitionsPopulated chrootdir mnts mntopts devs = property desc $ mconcat $ zipWith3 go mnts mntopts devs +partitionsPopulated chrootdir mnts mntopts devs = property' desc $ \w -> + mconcat $ zipWith3 (go w) mnts mntopts devs where desc = "partitions populated from " ++ chrootdir - go Nothing _ _ = noChange - go (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket + go _ Nothing _ _ = noChange + go w (Just mnt) mntopt loopdev = withTmpDir "mnt" $ \tmpdir -> bracket (liftIO $ mount "auto" (partitionLoopDev loopdev) tmpdir mntopt) (const $ liftIO $ umountLazy tmpdir) $ \ismounted -> if ismounted - then ensureProperty $ + then ensureProperty w $ syncDirFiltered (filtersfor mnt) (chrootdir ++ mnt) tmpdir else return FailedChange @@ -230,15 +248,15 @@ type Finalization = (Property Linux, (FilePath -> [LoopDev] -> Property Linux)) imageFinalized :: Finalization -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux imageFinalized (_, final) mnts mntopts devs (PartTable _ parts) = - property "disk image finalized" $ + property' "disk image finalized" $ \w -> withTmpDir "mnt" $ \top -> - go top `finally` liftIO (unmountall top) + go w top `finally` liftIO (unmountall top) where - go top = do + go w top = do liftIO $ mountall top liftIO $ writefstab top liftIO $ allowservices top - ensureProperty $ final top devs + ensureProperty w $ final top devs -- Ordered lexographically by mount point, so / comes before /usr -- comes before /usr/local @@ -280,27 +298,26 @@ noFinalization = (doNothing, \_ _ -> doNothing) grubBooted :: Grub.BIOS -> Finalization grubBooted bios = (Grub.installed' bios, boots) where - boots mnt loopdevs = combineProperties "disk image boots using grub" + boots mnt loopdevs = combineProperties "disk image boots using grub" $ props -- bind mount host /dev so grub can access the loop devices - [ bindMount "/dev" (inmnt "/dev") - , mounted "proc" "proc" (inmnt "/proc") mempty - , mounted "sysfs" "sys" (inmnt "/sys") mempty + & bindMount "/dev" (inmnt "/dev") + & mounted "proc" "proc" (inmnt "/proc") mempty + & mounted "sysfs" "sys" (inmnt "/sys") mempty -- update the initramfs so it gets the uuid of the root partition - , inchroot "update-initramfs" ["-u"] + & inchroot "update-initramfs" ["-u"] `assume` MadeChange -- work around for http://bugs.debian.org/802717 - , check haveosprober $ inchroot "chmod" ["-x", osprober] - , inchroot "update-grub" [] + & check haveosprober (inchroot "chmod" ["-x", osprober]) + & inchroot "update-grub" [] `assume` MadeChange - , check haveosprober $ inchroot "chmod" ["+x", osprober] - , inchroot "grub-install" [wholediskloopdev] + & check haveosprober (inchroot "chmod" ["+x", osprober]) + & inchroot "grub-install" [wholediskloopdev] `assume` MadeChange -- 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" [] + & cmdProperty "sync" [] `assume` NoChange - ] where -- cannot use since the filepath is absolute inmnt f = mnt ++ f diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs index 09255587..b8dc5f9e 100644 --- a/src/Propellor/Property/Grub.hs +++ b/src/Propellor/Property/Grub.hs @@ -29,10 +29,15 @@ mkConfig = tightenTargets $ cmdProperty "update-grub" [] `assume` MadeChange -- | Installs grub; does not run update-grub. -installed' :: BIOS -> Property DebianLike -installed' bios = Apt.installed [pkg] `describe` "grub package installed" +installed' :: BIOS -> Property Linux +installed' bios = withOS "grub package installed" $ \w o -> + let apt = ensureProperty w (Apt.installed [debpkg]) + in case o of + (Just (System (Debian _) _)) -> apt + (Just (System (Buntish _) _)) -> apt + _ -> unsupportedOS where - pkg = case bios of + debpkg = case bios of PC -> "grub-pc" EFI64 -> "grub-efi-amd64" EFI32 -> "grub-efi-ia32" diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs index 05409593..7048de3b 100644 --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -173,7 +173,7 @@ hostKeys ctx l = go `before` cleanup removestale b = map (tightenTargets . File.notPresent . flip keyFile b) staletypes cleanup :: Property DebianLike cleanup - | null staletypes || null l = tightenTargets doNothing + | null staletypes || null l = doNothing | otherwise = combineProperties ("any other ssh host keys removed " ++ typelist staletypes) (toProps $ removestale True ++ removestale False) diff --git a/src/Propellor/Types/MetaTypes.hs b/src/Propellor/Types/MetaTypes.hs index ce2b1411..3e89e28d 100644 --- a/src/Propellor/Types/MetaTypes.hs +++ b/src/Propellor/Types/MetaTypes.hs @@ -36,7 +36,7 @@ type UnixLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish, 'Targe -- | Any linux system type Linux = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ] -- | Debian and derivatives. -type DebianLike = Debian + Buntish +type DebianLike = MetaTypes '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish ] type Debian = MetaTypes '[ 'Targeting 'OSDebian ] type Buntish = MetaTypes '[ 'Targeting 'OSBuntish ] type FreeBSD = MetaTypes '[ 'Targeting 'OSFreeBSD ] -- cgit v1.3-2-g0d8e From 67a1bb6d9915a0c36b71d984cf0ef4c89dd59607 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 28 Mar 2016 03:54:28 -0400 Subject: propellor spin --- src/Propellor/Property/Grub.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) (limited to 'src/Propellor/Property/Grub.hs') diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs index b8dc5f9e..85d098ed 100644 --- a/src/Propellor/Property/Grub.hs +++ b/src/Propellor/Property/Grub.hs @@ -30,13 +30,11 @@ mkConfig = tightenTargets $ cmdProperty "update-grub" [] -- | Installs grub; does not run update-grub. installed' :: BIOS -> Property Linux -installed' bios = withOS "grub package installed" $ \w o -> - let apt = ensureProperty w (Apt.installed [debpkg]) - in case o of - (Just (System (Debian _) _)) -> apt - (Just (System (Buntish _) _)) -> apt - _ -> unsupportedOS +installed' bios = (aptinstall `pickOS` aptinstall) + `describe` "grub package installed" where + aptinstall :: Property DebianLike + aptinstall = Apt.installed [debpkg] debpkg = case bios of PC -> "grub-pc" EFI64 -> "grub-efi-amd64" -- cgit v1.3-2-g0d8e From 5f41492d8afe6ac6ee3cc280c3e2f252bcc91817 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 28 Mar 2016 04:46:21 -0400 Subject: propellor spin --- src/Propellor/Property.hs | 18 ++++++++---------- src/Propellor/Property/Apt.hs | 6 +++--- src/Propellor/Property/Debootstrap.hs | 19 +++++-------------- src/Propellor/Property/Grub.hs | 2 +- src/Propellor/Property/OS.hs | 2 +- src/Propellor/Property/Ssh.hs | 2 +- 6 files changed, 19 insertions(+), 30 deletions(-) (limited to 'src/Propellor/Property/Grub.hs') diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 7878912b..55c39ee2 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -28,6 +28,7 @@ module Propellor.Property ( , pickOS , withOS , unsupportedOS + , unsupportedOS' , makeChange , noChange , doNothing @@ -292,7 +293,7 @@ pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b] then getSatisfy a else if matching o b then getSatisfy b - else unsupportedOS + else unsupportedOS' matching Nothing _ = False matching (Just o) p = Targeting (systemToTargetOS o) @@ -307,7 +308,7 @@ pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b] -- > myproperty = withOS "foo installed" $ \w o -> case o of -- > (Just (System (Debian (Stable release)) arch)) -> ensureProperty w ... -- > (Just (System (Debian suite) arch)) -> ensureProperty w ... --- > _ -> unsupportedOS +-- > _ -> unsupportedOS' -- -- Note that the operating system specifics may not be declared for all hosts, -- which is where Nothing comes in. @@ -324,21 +325,18 @@ withOS desc a = property desc $ a dummyoutermetatypes =<< getOS dummyoutermetatypes :: OuterMetaTypesWitness ('[]) dummyoutermetatypes = OuterMetaTypesWitness sing -class UnsupportedOS a where - unsupportedOS :: a +-- | A property that always fails with an unsupported OS error. +unsupportedOS :: Property UnixLike +unsupportedOS = property "unsupportedOS" unsupportedOS' -- | Throws an error, for use in `withOS` when a property is lacking -- support for an OS. -instance UnsupportedOS (Propellor a) where - unsupportedOS = go =<< getOS +unsupportedOS' :: Propellor Result +unsupportedOS' = go =<< getOS where go Nothing = error "Unknown host OS is not supported by this property." go (Just o) = error $ "This property is not implemented for " ++ show o --- | A property that always fails with an unsupported OS error. -instance UnsupportedOS (Property UnixLike) where - unsupportedOS = property "unsupportedOS" unsupportedOS - -- | Undoes the effect of a RevertableProperty. revert :: RevertableProperty setup undo -> RevertableProperty undo setup revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs index 2199d950..1a15f72c 100644 --- a/src/Propellor/Property/Apt.hs +++ b/src/Propellor/Property/Apt.hs @@ -84,7 +84,7 @@ stdSourcesList :: Property Debian stdSourcesList = withOS "standard sources.list" $ \w o -> case o of (Just (System (Debian suite) _)) -> ensureProperty w $ stdSourcesListFor suite - _ -> unsupportedOS + _ -> unsupportedOS' stdSourcesListFor :: DebianSuite -> Property Debian stdSourcesListFor suite = stdSourcesList' suite [] @@ -160,11 +160,11 @@ installed' params ps = robustly $ check (isInstallable ps) go installedBackport :: [Package] -> Property Debian installedBackport ps = withOS desc $ \w o -> case o of (Just (System (Debian suite) _)) -> case backportSuite suite of - Nothing -> unsupportedOS + Nothing -> unsupportedOS' Just bs -> ensureProperty w $ runApt (["install", "-t", bs, "-y"] ++ ps) `changesFile` dpkgStatus - _ -> unsupportedOS + _ -> unsupportedOS' where desc = unwords ("apt installed backport":ps) diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index fd5f6c96..e0c56966 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -101,21 +101,12 @@ extractSuite (System (FreeBSD _) _) = Nothing installed :: RevertableProperty Linux Linux installed = install remove where - install = withOS "debootstrap installed" $ \w o -> - ifM (liftIO $ isJust <$> programPath) - ( return NoChange - , ensureProperty w (installon o) - ) - - installon (Just (System (Debian _) _)) = aptinstall - installon (Just (System (Buntish _) _)) = aptinstall - installon _ = sourceInstall + install = check (isJust <$> programPath) $ + (aptinstall `pickOS` sourceInstall) + `describe` "debootstrap installed" - remove = withOS "debootstrap removed" $ \w o -> - ensureProperty w (removefrom o) - removefrom (Just (System (Debian _) _)) = aptremove - removefrom (Just (System (Buntish _) _)) = aptremove - removefrom _ = sourceRemove + remove = (aptremove `pickOS` sourceRemove) + `describe` "debootstrap removed" aptinstall = Apt.installed ["debootstrap"] aptremove = Apt.removed ["debootstrap"] diff --git a/src/Propellor/Property/Grub.hs b/src/Propellor/Property/Grub.hs index 85d098ed..a03fc5a0 100644 --- a/src/Propellor/Property/Grub.hs +++ b/src/Propellor/Property/Grub.hs @@ -30,7 +30,7 @@ mkConfig = tightenTargets $ cmdProperty "update-grub" [] -- | Installs grub; does not run update-grub. installed' :: BIOS -> Property Linux -installed' bios = (aptinstall `pickOS` aptinstall) +installed' bios = (aptinstall `pickOS` unsupportedOS) `describe` "grub package installed" where aptinstall :: Property DebianLike diff --git a/src/Propellor/Property/OS.hs b/src/Propellor/Property/OS.hs index 72753248..7d0a10ca 100644 --- a/src/Propellor/Property/OS.hs +++ b/src/Propellor/Property/OS.hs @@ -89,7 +89,7 @@ cleanInstallOnce confirmation = check (not <$> doesFileExist flagfile) $ debootstrap d (Just u@(System (Buntish _) _)) -> ensureProperty w $ debootstrap u - _ -> unsupportedOS + _ -> unsupportedOS' debootstrap :: System -> Property Linux debootstrap targetos = diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs index 7048de3b..369999b7 100644 --- a/src/Propellor/Property/Ssh.hs +++ b/src/Propellor/Property/Ssh.hs @@ -53,7 +53,7 @@ installed = withOS "ssh installed" $ \w o -> in case o of (Just (System (Debian _) _)) -> aptinstall (Just (System (Buntish _) _)) -> aptinstall - _ -> unsupportedOS + _ -> unsupportedOS' restarted :: Property DebianLike restarted = Service.restarted "ssh" -- cgit v1.3-2-g0d8e