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
|
module Propellor.Property.Bootstrap (RepoSource(..), bootstrappedFrom, clonedFrom) where
import Propellor.Base
import Propellor.Bootstrap
import Propellor.Property.Chroot
import Data.List
import System.Posix.Directory
-- | Where a propellor repository should be bootstrapped from.
data RepoSource
= GitRepoUrl String
| GitRepoOutsideChroot
-- | Bootstraps a propellor installation into
-- /usr/local/propellor/
--
-- Normally, propellor is already bootstrapped when it runs, so this
-- property is not useful. However, this can be useful inside a
-- chroot used to build a disk image, to make the disk image
-- have propellor installed.
--
-- The git repository is cloned (or pulled to update if it already exists).
--
-- All build dependencies are installed, using distribution packages
-- or falling back to using cabal.
bootstrappedFrom :: RepoSource -> Property Linux
bootstrappedFrom reposource = go `requires` clonedFrom reposource
where
go :: Property Linux
go = property "Propellor bootstrapped" $ do
system <- getOS
assumeChange $ exposeTrueLocaldir $ const $
runShellCommand $ buildShellCommand
[ "cd " ++ localdir
, bootstrapPropellorCommand system
]
-- | Clones the propellor repeository into /usr/local/propellor/
--
-- GitRepoOutsideChroot can be used when this is used in a chroot.
-- In that case, it clones the /usr/local/propellor/ from outside the
-- chroot into the same path inside the chroot.
--
-- If the propellor repo has already been cloned, pulls to get it
-- up-to-date.
clonedFrom :: RepoSource -> Property Linux
clonedFrom reposource = property ("Propellor repo cloned from " ++ sourcedesc) $ do
ifM needclone
( do
let tmpclone = localdir ++ ".tmpclone"
system <- getOS
assumeChange $ exposeTrueLocaldir $ \sysdir -> do
let originloc = case reposource of
GitRepoUrl s -> s
GitRepoOutsideChroot -> sysdir
runShellCommand $ buildShellCommand
[ installGitCommand system
, "rm -rf " ++ tmpclone
, "git clone " ++ shellEscape originloc ++ " " ++ tmpclone
, "mkdir -p " ++ localdir
-- This is done rather than deleting
-- the old localdir, because if it is bound
-- mounted from outside the chroot, deleting
-- it after unmounting in unshare will remove
-- the bind mount outside the unshare.
, "(cd " ++ tmpclone ++ " && tar c .) | (cd " ++ localdir ++ " && tar x)"
, "rm -rf " ++ tmpclone
]
, assumeChange $ exposeTrueLocaldir $ const $
runShellCommand $ buildShellCommand
[ "cd " ++ localdir
, "git pull"
]
)
where
needclone = (inChroot <&&> truelocaldirisempty)
<||> (liftIO (not <$> doesDirectoryExist localdir))
truelocaldirisempty = exposeTrueLocaldir $ const $
runShellCommand ("test ! -d " ++ localdir ++ "/.git")
sourcedesc = case reposource of
GitRepoUrl s -> s
GitRepoOutsideChroot -> localdir
-- | Runs an action with the true localdir exposed,
-- not the one bind-mounted into a chroot. The action is passed the
-- path containing the contents of the localdir outside the chroot.
--
-- In a chroot, this is accomplished by temporily bind mounting the localdir
-- to a temp directory, to preserve access to the original bind mount. Then
-- we unmount the localdir to expose the true localdir. Finally, to cleanup,
-- the temp directory is bind mounted back to the localdir.
exposeTrueLocaldir :: (FilePath -> IO a) -> Propellor a
exposeTrueLocaldir a = ifM inChroot
( liftIO $ withTmpDirIn (takeDirectory localdir) "propellor.tmp" $ \tmpdir ->
bracket_
(movebindmount localdir tmpdir)
(movebindmount tmpdir localdir)
(a tmpdir)
, liftIO $ a localdir
)
where
movebindmount from to = do
run "mount" [Param "--bind", File from, File to]
-- Have to lazy unmount, because the propellor process
-- is running in the localdir that it's unmounting..
run "umount" [Param "-l", File from]
-- We were in the old localdir; move to the new one after
-- flipping the bind mounts. Otherwise, commands that try
-- to access the cwd will fail because it got umounted out
-- from under.
changeWorkingDirectory "/"
changeWorkingDirectory localdir
run cmd ps = unlessM (boolSystem cmd ps) $
error $ "exposeTrueLocaldir failed to run " ++ show (cmd, ps)
assumeChange :: Propellor Bool -> Propellor Result
assumeChange a = do
ok <- a
return (cmdResult ok <> MadeChange)
buildShellCommand :: [String] -> String
buildShellCommand = intercalate "&&" . map (\c -> "(" ++ c ++ ")")
runShellCommand :: String -> IO Bool
runShellCommand s = liftIO $ boolSystem "sh" [ Param "-c", Param s]
|
