summaryrefslogtreecommitdiff
path: root/src/Propellor
diff options
context:
space:
mode:
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)
generated by cgit v1.3-2-g0d8e (git 2.53.0) at 2026-06-14 03:35:54 +0000