From 4ba09ab6844cc3fc3e94856da22190555b697193 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 9 Apr 2017 15:00:33 -0400 Subject: added Propellor.Property.Bootstrap (untested) This commit was sponsored by Jake Vosloo on Patreon. --- src/Propellor/Property/Bootstrap.hs | 95 +++++++++++++++++++++++++++++++++++++ 1 file changed, 95 insertions(+) create mode 100644 src/Propellor/Property/Bootstrap.hs (limited to 'src/Propellor/Property/Bootstrap.hs') diff --git a/src/Propellor/Property/Bootstrap.hs b/src/Propellor/Property/Bootstrap.hs new file mode 100644 index 00000000..6158d967 --- /dev/null +++ b/src/Propellor/Property/Bootstrap.hs @@ -0,0 +1,95 @@ +module Propellor.Property.Bootstrap (RepoSource(..), bootstrappedFrom, clonedFrom) where + +import Propellor.Base +import Propellor.Bootstrap +import Propellor.Property.Chroot + +import Data.List + +-- | 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 $ 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 " ++ originloc) $ do + ifM needclone + ( do + let tmpclone = localdir ++ ".tmpclone" + system <- getOS + assumeChange $ exposeTrueLocaldir $ 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 $ buildShellCommand + [ "cd " ++ localdir + , "git pull" + ] + ) + where + needclone = (inChroot <&&> truelocaldirisempty) + <||> (liftIO (not <$> doesDirectoryExist localdir)) + truelocaldirisempty = exposeTrueLocaldir $ + "test ! -d " ++ localdir ++ "/.git" + originloc = case reposource of + GitRepoUrl s -> s + GitRepoOutsideChroot -> localdir + +-- | Runs the shell command with the true localdir exposed, +-- not the one bind-mounted into a chroot. +exposeTrueLocaldir :: String -> Propellor Bool +exposeTrueLocaldir s = do + s' <- ifM inChroot + ( return $ "unshare -m sh -c " ++ shellEscape + ("umount " ++ localdir ++ " && ( " ++ s ++ ")") + , return s + ) + liftIO $ boolSystem "sh" [ Param "-c", Param s'] + +assumeChange :: Propellor Bool -> Propellor Result +assumeChange a = do + ok <- a + return (cmdResult ok <> MadeChange) + +buildShellCommand :: [String] -> String +buildShellCommand = intercalate "&&" . map (\c -> "(" ++ c ++ ")") -- cgit v1.2.3