summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Chroot.hs
blob: 874d7750f09d6cfe7be88b0a8e6d0fd3c5ea2b55 (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
module Propellor.Property.Chroot (
	Chroot(..),
	chroot,
	provisioned,
	chain,
) where

import Propellor
import qualified Propellor.Property.Debootstrap as Debootstrap
import qualified Propellor.Shim as Shim
import Utility.SafeCommand

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

data Chroot = Chroot FilePath System Host

instance Hostlike Chroot where
	(Chroot l s h) & p = Chroot l s (h & p)
	(Chroot l s h) &^ p = Chroot l s (h &^ p)
	getHost (Chroot _ _ h) = h

-- | Defines a Chroot at the given location, containing the specified
-- System. Properties can be added to configure the Chroot.
--
-- > chroot "/srv/chroot/ghc-dev" (System (Debian Unstable) "amd64")
-- >    & Apt.installed ["build-essential", "ghc", "haskell-platform"]
-- >	& ...
chroot :: FilePath -> System -> Chroot
chroot location system = Chroot location system (Host location [] mempty)

-- | Ensures that the chroot exists and is provisioned according to its
-- properties.
--
-- Reverting this property removes the chroot. Note that it does not ensure
-- that any processes that might be running inside the chroot are stopped.
provisioned :: Chroot -> RevertableProperty
provisioned c@(Chroot loc system _) = RevertableProperty
	(propigateChrootInfo c (go "exists" setup))
	(go "removed" teardown)
  where
	go desc a = property (chrootDesc c desc) $ ensureProperties [a]

	setup = provisionChroot c `requires` toProp built
	
	built = case system of
		(System (Debian _) _) -> debootstrap
		(System (Ubuntu _) _) -> debootstrap

	debootstrap = Debootstrap.built loc system []

	teardown = toProp (revert built)

propigateChrootInfo :: Chroot -> Property -> Property
propigateChrootInfo c p = propigateInfo c p (<> chrootInfo c)

chrootInfo :: Chroot -> Info
chrootInfo (Chroot loc _ h) =
	mempty { _chrootinfo = mempty { _chroots = M.singleton loc h } }

-- | Propellor is run inside the chroot to provision it.
--
-- Strange and wonderful tricks let the host's /usr/local/propellor
-- be used inside the chroot, without needing to install anything.
provisionChroot :: Chroot -> Property
provisionChroot c@(Chroot loc _ _) = 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 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
		let p = inChrootProcess c
			[ shim
			, "--continue"
			, show cmd
			]
		liftIO $ withHandle StdoutHandle createProcessSuccess p
			processChainOutput

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

chain :: [Host] -> HostName -> FilePath -> Bool -> IO ()
chain hostlist hn loc onconsole = case findHostNoAlias hostlist hn of
	Nothing -> errorMessage ("cannot find host " ++ hn)
	Just parenthost -> case M.lookup loc (_chroots $ _chrootinfo $ 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 $ hostProperties h
			putStrLn $ "\n" ++ show r

inChrootProcess :: Chroot -> [String] -> CreateProcess
inChrootProcess (Chroot loc _ _) cmd = proc "chroot" (loc:cmd)

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