summaryrefslogtreecommitdiff
path: root/src/Propellor
diff options
context:
space:
mode:
authorJoey Hess2015-10-23 14:18:19 -0400
committerJoey Hess2015-10-23 14:18:19 -0400
commit1f62b0d3a3d247f16f875f02e5bc89c7b7dc9ace (patch)
tree4523439165bb45f6a555b9dc3b20dd0b154aadb9 /src/Propellor
parentfc7c8513d90e36875b25746c62e35369a9a98850 (diff)
Changed how the operating system is provided to Chroot (API change).
* Where before debootstrapped and bootstrapped took a System parameter, the os property should now be added to the Chroot. * Follow-on change to Systemd.container, which now takes a System parameter. Two motivations for this change: 1. When using ChrootTarball, there may be no particular System that makes sense for the contents of the tarball, so don't force the user to specify one. 2. When creating a chroot for a disk image with the same properties as an existing Host, using hostProperties host to get them, this allows inheriting the os property from the host, and doesn't require it to be redundantly passed to Chroot.debootstrapped.
Diffstat (limited to 'src/Propellor')
-rw-r--r--src/Propellor/Property/Chroot.hs68
-rw-r--r--src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs8
-rw-r--r--src/Propellor/Property/Systemd.hs18
3 files changed, 48 insertions, 46 deletions
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 2b5391fa..f32a9117 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -34,25 +34,26 @@ import System.Posix.Directory
-- | Specification of a chroot. Normally you'll use `debootstrapped` or
-- `bootstrapped` to construct a Chroot value.
data Chroot where
- Chroot :: ChrootBootstrapper b => FilePath -> System -> b -> Host -> Chroot
+ Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot
-chrootSystem :: Chroot -> System
-chrootSystem (Chroot _ system _ _) = system
+chrootSystem :: Chroot -> Maybe System
+chrootSystem (Chroot _ _ h) = fromInfoVal (getInfo (hostInfo h))
instance Show Chroot where
- show (Chroot loc system _ _) = "Chroot " ++ loc ++ " " ++ show system
+ show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c)
instance PropAccum Chroot where
- (Chroot l s c h) `addProp` p = Chroot l s c (h & p)
- (Chroot l s c h) `addPropFront` p = Chroot l s c (h `addPropFront` p)
- getProperties (Chroot _ _ _ h) = hostProperties h
+ (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 Nothing.
- buildchroot :: b -> System -> FilePath -> Maybe (Property HasInfo)
+ -- If the operating System is not supported, return
+ -- Left error message.
+ buildchroot :: b -> Maybe System -> FilePath -> Either String (Property HasInfo)
-- | Use this to bootstrap a chroot by extracting a tarball.
--
@@ -63,7 +64,7 @@ class ChrootBootstrapper b where
data ChrootTarball = ChrootTarball FilePath
instance ChrootBootstrapper ChrootTarball where
- buildchroot (ChrootTarball tb) _ loc = Just $ extractTarball loc tb
+ buildchroot (ChrootTarball tb) _ loc = Right $ extractTarball loc tb
extractTarball :: FilePath -> FilePath -> Property HasInfo
extractTarball target src = toProp .
@@ -83,27 +84,28 @@ data Debootstrapped = Debootstrapped Debootstrap.DebootstrapConfig
instance ChrootBootstrapper Debootstrapped where
buildchroot (Debootstrapped cf) system loc = case system of
- (System (Debian _) _) -> Just debootstrap
- (System (Ubuntu _) _) -> Just debootstrap
+ (Just s@(System (Debian _) _)) -> Right $ debootstrap s
+ (Just s@(System (Ubuntu _) _)) -> Right $ debootstrap s
+ Nothing -> Left "Cannot debootstrap; `os` property not specified"
where
- debootstrap = Debootstrap.built loc system cf
+ 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.
+-- Properties can be added to configure the Chroot. At a minimum,
+-- add the `os` property to specify the operating system to bootstrap.
--
--- > debootstrapped (System (Debian Unstable) "amd64") Debootstrap.BuildD "/srv/chroot/ghc-dev"
+-- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev"
+-- > & os (System (Debian Unstable) "amd64")
-- > & Apt.installed ["ghc", "haskell-platform"]
-- > & ...
-debootstrapped :: System -> Debootstrap.DebootstrapConfig -> FilePath -> Chroot
-debootstrapped system conf = bootstrapped system (Debootstrapped conf)
+debootstrapped :: Debootstrap.DebootstrapConfig -> FilePath -> Chroot
+debootstrapped conf = bootstrapped (Debootstrapped conf)
-- | Defines a Chroot at the given location, bootstrapped with the
-- specified ChrootBootstrapper.
-bootstrapped :: ChrootBootstrapper b => System -> b -> FilePath -> Chroot
-bootstrapped system bootstrapper location =
- Chroot location system bootstrapper h
- & os system
+bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Chroot
+bootstrapped bootstrapper location = Chroot location bootstrapper h
where
h = Host location [] mempty
@@ -117,7 +119,7 @@ provisioned :: Chroot -> RevertableProperty
provisioned c = provisioned' (propagateChrootInfo c) c False
provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty
-provisioned' propigator c@(Chroot loc system bootstrapper _) systemdonly =
+provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly =
(propigator $ propertyList (chrootDesc c "exists") [setup])
<!>
(propertyList (chrootDesc c "removed") [teardown])
@@ -125,18 +127,18 @@ provisioned' propigator c@(Chroot loc system bootstrapper _) systemdonly =
setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly
`requires` toProp built
- built = case buildchroot bootstrapper system loc of
- Just p -> p
- Nothing -> cantbuild
+ built = case buildchroot bootstrapper (chrootSystem c) loc of
+ Right p -> p
+ Left e -> cantbuild e
- cantbuild = infoProperty (chrootDesc c "built") (error $ "cannot bootstrap " ++ show system ++ " using supplied ChrootBootstrapper") mempty []
+ cantbuild e = infoProperty (chrootDesc c "built") (error e) mempty []
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'
+propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c p'
where
p' = infoProperty
(propertyDesc p)
@@ -145,12 +147,12 @@ propagateChrootInfo c@(Chroot location _ _ _) p = propagateContainer location c
(propertyChildren p)
chrootInfo :: Chroot -> Info
-chrootInfo (Chroot loc _ _ h) = mempty `addInfo`
+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 c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do
+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)
@@ -189,7 +191,7 @@ propellChroot c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "
return r
toChain :: HostName -> Chroot -> Bool -> IO CmdLine
-toChain parenthost (Chroot loc _ _ _) systemdonly = do
+toChain parenthost (Chroot loc _ _) systemdonly = do
onconsole <- isConsole <$> mkMessageHandle
return $ ChrootChain parenthost loc systemdonly onconsole
@@ -214,7 +216,7 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) =
chain _ _ = errorMessage "bad chain command"
inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ())
-inChrootProcess keepprocmounted (Chroot loc _ _ _) cmd = do
+inChrootProcess keepprocmounted (Chroot loc _ _) cmd = do
mountproc
return (proc "chroot" (loc:cmd), cleanup)
where
@@ -234,10 +236,10 @@ provisioningLock :: FilePath -> FilePath
provisioningLock containerloc = "chroot" </> mungeloc containerloc ++ ".lock"
shimdir :: Chroot -> FilePath
-shimdir (Chroot loc _ _ _) = "chroot" </> mungeloc loc ++ ".shim"
+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 loc _ _) desc = "chroot " ++ loc ++ " " ++ desc
diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
index a10e5877..3f7cbad1 100644
--- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
+++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs
@@ -99,13 +99,12 @@ cabalDeps = flagFile go cabalupdated
autoBuilderContainer :: (System -> Flavor -> Property HasInfo) -> System -> Flavor -> Times -> TimeOut -> Systemd.Container
autoBuilderContainer mkprop osver@(System _ arch) flavor crontime timeout =
- Systemd.container name bootstrap
+ Systemd.container name osver (Chroot.debootstrapped mempty)
& mkprop osver flavor
& buildDepsApt
& autobuilder arch crontime timeout
where
name = arch ++ fromMaybe "" flavor ++ "-git-annex-builder"
- bootstrap = Chroot.debootstrapped osver mempty
type Flavor = Maybe String
@@ -144,8 +143,7 @@ androidContainer
-> Property i
-> FilePath
-> Systemd.Container
-androidContainer name setupgitannexdir gitannexdir = Systemd.container name bootstrap
- & os osver
+androidContainer name setupgitannexdir gitannexdir = Systemd.container name osver bootstrap
& Apt.stdSourcesList
& User.accountFor (User builduser)
& File.dirExists gitbuilderdir
@@ -161,4 +159,4 @@ androidContainer name setupgitannexdir gitannexdir = Systemd.container name boot
[ "cd " ++ gitannexdir ++ " && ./standalone/android/buildchroot-inchroot"
]
osver = System (Debian (Stable "jessie")) "i386"
- bootstrap = Chroot.debootstrapped osver mempty
+ bootstrap = Chroot.debootstrapped mempty
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index d5373e15..700bc350 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -174,21 +174,22 @@ machined = go `describe` "machined installed"
Apt.installed ["systemd-container"]
_ -> noChange
--- | Defines a container with a given machine name.
+-- | Defines a container with a given machine name, and operating system,
+-- and how to create its chroot if not already present.
--
-- Properties can be added to configure the Container.
--
--- > container "webserver" (Chroot.debootstrapped (System (Debian Unstable) "amd64") mempty)
+-- > container "webserver" (System (Debian Unstable) "amd64") (Chroot.debootstrapped mempty)
-- > & Apt.installedRunning "apache2"
-- > & ...
-container :: MachineName -> (FilePath -> Chroot.Chroot) -> Container
-container name mkchroot = Container name c h
+container :: MachineName -> System -> (FilePath -> Chroot.Chroot) -> Container
+container name system mkchroot = Container name c h
& os system
& resolvConfed
& linkJournal
where
c = mkchroot (containerDir name)
- system = Chroot.chrootSystem c
+ & os system
h = Host name [] mempty
-- | Runs a container using systemd-nspawn.
@@ -206,7 +207,7 @@ container name mkchroot = Container name c h
-- Reverting this property stops the container, removes the systemd unit,
-- and deletes the chroot and all its contents.
nspawned :: Container -> RevertableProperty
-nspawned c@(Container name (Chroot.Chroot loc system builder _) h) =
+nspawned c@(Container name (Chroot.Chroot loc builder _) h) =
p `describe` ("nspawned " ++ name)
where
p = enterScript c
@@ -226,7 +227,7 @@ nspawned c@(Container name (Chroot.Chroot loc system builder _) h) =
<!>
doNothing
- chroot = Chroot.Chroot loc system builder h
+ chroot = Chroot.Chroot loc builder h
-- | Sets up the service file for the container, and then starts
-- it running.
@@ -382,7 +383,8 @@ instance Publishable (Proto, Bound Port) where
-- > `requires` Systemd.running Systemd.networkd
-- >
-- > webserver :: Systemd.container
--- > webserver = Systemd.container "webserver" (Chroot.debootstrapped (System (Debian Testing) "amd64") mempty)
+-- > webserver = Systemd.container "webserver" (Chroot.debootstrapped mempty)
+-- > & os (System (Debian Testing) "amd64")
-- > & Systemd.privateNetwork
-- > & Systemd.running Systemd.networkd
-- > & Systemd.publish (Port 80 ->- Port 8080)