summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Chroot.hs
diff options
context:
space:
mode:
authorJoey Hess2016-03-28 05:53:38 -0400
committerJoey Hess2016-03-28 05:55:48 -0400
commita1655d24bbb1db9caccdf93eae8110d746389ae2 (patch)
tree66b6890d852c19daec2306920fecf9108e055273 /src/Propellor/Property/Chroot.hs
parentebf30061d8f8a251330070e69c2710fe4a8fd9da (diff)
type safe targets for properties
* Property types have been improved to indicate what systems they target. This prevents using eg, Property FreeBSD on a Debian system. Transition guide for this sweeping API change: - Change "host name & foo & bar" to "host name $ props & foo & bar" - Similarly, `propertyList` and `combineProperties` need `props` to be used to combine together properties; they no longer accept lists of properties. (If you have such a list, use `toProps`.) - And similarly, Chroot, Docker, and Systemd container need `props` to be used to combine together the properies used inside them. - The `os` property is removed. Instead use `osDebian`, `osBuntish`, or `osFreeBSD`. These tell the type checker the target OS of a host. - Change "Property NoInfo" to "Property UnixLike" - Change "Property HasInfo" to "Property (HasInfo + UnixLike)" - Change "RevertableProperty NoInfo" to "RevertableProperty UnixLike UnixLike" - Change "RevertableProperty HasInfo" to "RevertableProperty (HasInfo + UnixLike) UnixLike" - GHC needs {-# LANGUAGE TypeOperators #-} to use these fancy types. This is enabled by default for all modules in propellor.cabal. But if you are using propellor as a library, you may need to enable it manually. - If you know a property only works on a particular OS, like Debian or FreeBSD, use that instead of "UnixLike". For example: "Property Debian" - It's also possible make a property support a set of OS's, for example: "Property (Debian + FreeBSD)" - Removed `infoProperty` and `simpleProperty` constructors, instead use `property` to construct a Property. - Due to the polymorphic type returned by `property`, additional type signatures tend to be needed when using it. For example, this will fail to type check, because the type checker cannot guess what type you intend the intermediate property "go" to have: foo :: Property UnixLike foo = go `requires` bar where go = property "foo" (return NoChange) To fix, specify the type of go: go :: Property UnixLike - `ensureProperty` now needs to be passed a witness to the type of the property it's used in. change this: foo = property desc $ ... ensureProperty bar to this: foo = property' desc $ \w -> ... ensureProperty w bar - General purpose properties like cmdProperty have type "Property UnixLike". When using that to run a command only available on Debian, you can tighten the type to only the OS that your more specific property works on. For example: upgraded :: Property Debian upgraded = tightenTargets (cmdProperty "apt-get" ["upgrade"]) - Several utility functions have been renamed: getInfo to fromInfo propertyInfo to getInfo propertyDesc to getDesc propertyChildren to getChildren * The new `pickOS` property combinator can be used to combine different properties, supporting different OS's, into one Property that chooses which to use based on the Host's OS. * Re-enabled -O0 in propellor.cabal to reign in ghc's memory use handling these complex new types. * Added dependency on concurrent-output; removed embedded copy.
Diffstat (limited to 'src/Propellor/Property/Chroot.hs')
-rw-r--r--src/Propellor/Property/Chroot.hs99
1 files changed, 51 insertions, 48 deletions
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 378836e8..09047ce5 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -19,9 +19,11 @@ module Propellor.Property.Chroot (
) where
import Propellor.Base
+import Propellor.Container
import Propellor.Types.CmdLine
import Propellor.Types.Chroot
import Propellor.Types.Info
+import Propellor.Types.Core
import Propellor.Property.Chroot.Util
import qualified Propellor.Property.Debootstrap as Debootstrap
import qualified Propellor.Property.Systemd.Core as Systemd
@@ -40,24 +42,24 @@ import System.Console.Concurrent
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)
+
chrootSystem :: Chroot -> Maybe System
-chrootSystem (Chroot _ _ h) = fromInfoVal (getInfo (hostInfo h))
+chrootSystem = fromInfoVal . fromInfo . containerInfo
instance Show Chroot where
show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c)
-instance PropAccum Chroot where
- (Chroot l c h) `addProp` p = Chroot l c (h & p)
- (Chroot l c h) `addPropFront` p = Chroot l c (h `addPropFront` p)
- getProperties (Chroot _ _ h) = hostProperties h
-
-- | Class of things that can do initial bootstrapping of an operating
-- System in a chroot.
class ChrootBootstrapper b 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 HasInfo)
+ buildchroot :: b -> Maybe System -> FilePath -> Either String (Property Linux)
-- | Use this to bootstrap a chroot by extracting a tarball.
--
@@ -68,14 +70,14 @@ class ChrootBootstrapper b where
data ChrootTarball = ChrootTarball FilePath
instance ChrootBootstrapper ChrootTarball where
- buildchroot (ChrootTarball tb) _ loc = Right $ extractTarball loc tb
-
-extractTarball :: FilePath -> FilePath -> Property HasInfo
-extractTarball target src = toProp .
- check (unpopulated target) $
- cmdProperty "tar" params
- `assume` MadeChange
- `requires` File.dirExists target
+ buildchroot (ChrootTarball tb) _ loc = Right $
+ tightenTargets $ extractTarball loc tb
+
+extractTarball :: FilePath -> FilePath -> Property UnixLike
+extractTarball target src = check (unpopulated target) $
+ cmdProperty "tar" params
+ `assume` MadeChange
+ `requires` File.dirExists target
where
params =
[ "-C"
@@ -92,28 +94,27 @@ instance ChrootBootstrapper Debootstrapped where
(Just s@(System (Debian _) _)) -> Right $ debootstrap s
(Just s@(System (Buntish _) _)) -> Right $ debootstrap s
(Just (System (FreeBSD _) _)) -> Left "FreeBSD not supported by debootstrap."
- Nothing -> Left "Cannot debootstrap; `os` property not specified"
+ Nothing -> Left "Cannot debootstrap; OS not specified"
where
debootstrap s = Debootstrap.built loc s cf
-- | Defines a Chroot at the given location, built with debootstrap.
--
-- Properties can be added to configure the Chroot. At a minimum,
--- add the `os` property to specify the operating system to bootstrap.
+-- add a property such as `osDebian` to specify the operating system
+-- to bootstrap.
--
--- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev"
--- > & os (System (Debian Unstable) "amd64")
+-- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev" $ props
+-- > & osDebian Unstable "amd64"
-- > & Apt.installed ["ghc", "haskell-platform"]
-- > & ...
-debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot
+debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Props metatypes -> Chroot
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
- where
- h = Host location [] mempty
+bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Props metatypes -> Chroot
+bootstrapped bootstrapper location ps = Chroot location bootstrapper (host location ps)
-- | Ensures that the chroot exists and is provisioned according to its
-- properties.
@@ -121,43 +122,44 @@ bootstrapped bootstrapper location = Chroot location bootstrapper h
-- 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
+provisioned :: Chroot -> RevertableProperty (HasInfo + Linux) Linux
provisioned c = provisioned' (propagateChrootInfo c) c False
-provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty HasInfo
+provisioned'
+ :: (Property Linux -> Property (HasInfo + Linux))
+ -> Chroot
+ -> Bool
+ -> RevertableProperty (HasInfo + Linux) Linux
provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly =
- (propigator $ propertyList (chrootDesc c "exists") [setup])
+ (propigator $ setup `describe` chrootDesc c "exists")
<!>
- (propertyList (chrootDesc c "removed") [teardown])
+ (teardown `describe` chrootDesc c "removed")
where
+ setup :: Property Linux
setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly
- `requires` toProp built
+ `requires` built
built = case buildchroot bootstrapper (chrootSystem c) loc of
Right p -> p
Left e -> cantbuild e
- cantbuild e = infoProperty (chrootDesc c "built") (error e) mempty []
+ cantbuild e = property (chrootDesc c "built") (error e)
+ teardown :: Property Linux
teardown = check (not <$> unpopulated loc) $
property ("removed " ++ loc) $
makeChange (removeChroot loc)
-propagateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo
-propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c p'
- where
- p' = infoProperty
- (propertyDesc p)
- (propertySatisfy p)
- (propertyInfo p <> chrootInfo c)
- (propertyChildren p)
+propagateChrootInfo :: Chroot -> Property Linux -> Property (HasInfo + Linux)
+propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c $
+ p `setInfoProperty` chrootInfo c
chrootInfo :: Chroot -> 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 NoInfo
+propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property UnixLike
propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do
let d = localdir </> shimdir c
let me = localdir </> "propellor"
@@ -205,7 +207,7 @@ chain :: [Host] -> CmdLine -> IO ()
chain hostlist (ChrootChain hn loc systemdonly onconsole) =
case findHostNoAlias hostlist hn of
Nothing -> errorMessage ("cannot find host " ++ hn)
- Just parenthost -> case M.lookup loc (_chroots $ getInfo $ hostInfo parenthost) of
+ Just parenthost -> case M.lookup loc (_chroots $ fromInfo $ hostInfo parenthost) of
Nothing -> errorMessage ("cannot find chroot " ++ loc ++ " on host " ++ hn)
Just h -> go h
where
@@ -213,11 +215,10 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) =
changeWorkingDirectory localdir
when onconsole forceConsole
onlyProcess (provisioningLock loc) $ do
- r <- runPropellor (setInChroot h) $ ensureProperties $
+ r <- runPropellor (setInChroot h) $ ensureChildProperties $
if systemdonly
- then [Systemd.installed]
- else map ignoreInfo $
- hostProperties h
+ then [toChildProperty Systemd.installed]
+ else hostProperties h
flushConcurrentOutput
putStrLn $ "\n" ++ show r
chain _ _ = errorMessage "bad chain command"
@@ -255,15 +256,17 @@ 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 </usr/sbin/policy-rc.d> script
--- that does not let any daemons be started by packages that use
+-- On Debian, this is accomplished by installing a </usr/sbin/policy-rc.d>
+-- script that does not let any daemons be started by packages that use
-- invoke-rc.d. Reverting the property removes the script.
-noServices :: RevertableProperty NoInfo
+--
+-- 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" ]
- setup = combineProperties "no services started"
+ setup = combineProperties "no services started" $ toProps
[ File.hasContent f script
, File.mode f (combineModes (readModes ++ executeModes))
]