summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Chroot.hs
blob: aecf33ec68b41da7c146c622c24be5498296fff2 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
{-# LANGUAGE FlexibleContexts #-}

module Propellor.Property.Chroot (
	Chroot(..),
	BuilderConf(..),
	debootstrapped,
	provisioned,
	-- * Internal use
	provisioned',
	propigateChrootInfo,
	propellChroot,
	chain,
) where

import Propellor
import Propellor.Types.CmdLine
import Propellor.Types.Chroot
import Propellor.Types.Info
import Propellor.Property.Chroot.Util
import qualified Propellor.Property.Debootstrap as Debootstrap
import qualified Propellor.Property.Systemd.Core as Systemd
import qualified Propellor.Shim as Shim
import Propellor.Property.Mount

import qualified Data.Map as M
import Data.List.Utils
import System.Posix.Directory

data Chroot = Chroot FilePath System BuilderConf Host
	deriving (Show)

data BuilderConf
	= UsingDeboostrap Debootstrap.DebootstrapConfig
	deriving (Show)

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

-- | Defines a Chroot at the given location, built with debootstrap.
--
-- Properties can be added to configure the Chroot.
--
-- > debootstrapped (System (Debian Unstable) "amd64") Debootstrap.BuildD "/srv/chroot/ghc-dev"
-- >    & Apt.installed ["ghc", "haskell-platform"]
-- >	& ...
debootstrapped :: System -> Debootstrap.DebootstrapConfig -> FilePath -> Chroot
debootstrapped system conf location = case system of
	(System (Debian _) _) -> mk
	(System (Ubuntu _) _) -> mk
  where
	h = Host location [] mempty
	mk = Chroot location system (UsingDeboostrap conf) h
		& os system

-- | Ensures that the chroot exists and is provisioned according to its
-- properties.
--
-- 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
provisioned c = provisioned' (propigateChrootInfo c) c False

provisioned' :: (Property HasInfo -> Property HasInfo) -> Chroot -> Bool -> RevertableProperty
provisioned' propigator c@(Chroot loc system builderconf _) systemdonly =
	(propigator $ go "exists" setup)
		<!>
	(go "removed" teardown)
  where
	go desc a = propertyList (chrootDesc c desc) [a]

	setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly
		`requires` toProp built
	
	built = case (system, builderconf) of
		((System (Debian _) _), UsingDeboostrap cf) -> debootstrap cf
		((System (Ubuntu _) _), UsingDeboostrap cf) -> debootstrap cf

	debootstrap = Debootstrap.built loc system

	teardown = toProp (revert built)

propigateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo
propigateChrootInfo c@(Chroot location _ _ _) p = propigateContainer location c p'
  where
	p' = infoProperty
		(propertyDesc p)
		(propertySatisfy p)
		(propertyInfo p <> chrootInfo c)
		(propertyChildren p)

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 c@(Chroot loc _ _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do
	let d = localdir </> shimdir c
	let me = localdir </> "propellor"
	shim <- liftIO $ ifM (doesDirectoryExist d)
		( pure (Shim.file me d)
		, Shim.setup me Nothing d
		)
	ifM (liftIO $ bindmount shim)
		( chainprovision shim
		, return FailedChange
		)
  where
	bindmount shim = ifM (doesFileExist (loc ++ shim))
		( return True
		, do
			let mntpnt = loc ++ localdir
			createDirectoryIfMissing True mntpnt
			boolSystem "mount"
				[ Param "--bind"
				, File localdir, File mntpnt
				]
		)

	chainprovision shim = do
		parenthost <- asks hostName
		cmd <- liftIO $ toChain parenthost c systemdonly
		pe <- liftIO standardPathEnv
		(p, cleanup) <- liftIO $ mkproc
			[ shim
			, "--continue"
			, show cmd
			]
		let p' = p { env = Just pe }
		r <- liftIO $ withHandle StdoutHandle createProcessSuccess p'
			processChainOutput
		liftIO cleanup
		return r

toChain :: HostName -> Chroot -> Bool -> IO CmdLine
toChain parenthost (Chroot loc _ _ _) systemdonly = do
	onconsole <- isConsole <$> mkMessageHandle
	return $ ChrootChain parenthost loc systemdonly onconsole

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
			Nothing -> errorMessage ("cannot find chroot " ++ loc ++ " on host " ++ hn)
			Just h -> go h
  where
	go h = do
		changeWorkingDirectory localdir
		when onconsole forceConsole
		onlyProcess (provisioningLock loc) $ do
			r <- runPropellor h $ ensureProperties $
				if systemdonly
					then [Systemd.installed]
					else map ignoreInfo $
						hostProperties h
			putStrLn $ "\n" ++ show r
chain _ _ = errorMessage "bad chain command"

inChrootProcess :: Bool -> Chroot -> [String] -> IO (CreateProcess, IO ())
inChrootProcess keepprocmounted (Chroot loc _ _ _) cmd = do
	mountproc
	return (proc "chroot" (loc:cmd), cleanup)
  where
	-- /proc needs to be mounted in the chroot for the linker to use
	-- /proc/self/exe which is necessary for some commands to work
	mountproc = unlessM (elem procloc <$> mountPointsBelow loc) $
		void $ mount "proc" "proc" procloc
	
	procloc = loc </> "proc"

	cleanup
		| keepprocmounted = noop
		| otherwise = whenM (elem procloc <$> mountPointsBelow loc) $
			umountLazy procloc

provisioningLock :: FilePath -> FilePath
provisioningLock containerloc = "chroot" </> mungeloc containerloc ++ ".lock"

shimdir :: Chroot -> FilePath
shimdir (Chroot loc _ _ _) = "chroot" </> mungeloc loc ++ ".shim"

mungeloc :: FilePath -> String
mungeloc = replace "/" "_"

chrootDesc :: Chroot -> String -> String
chrootDesc (Chroot loc _ _ _) desc = "chroot " ++ loc ++ " " ++ desc