From 4a9bbd1391b708d72a455cc00f698a80f1fd5fa5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Nov 2014 19:30:51 -0400 Subject: Added support for using debootstrap from propellor. Most of the hard part was making it be able to install debootstrap from source, for use on non-debian-derived systems. --- src/Propellor/Property/Debootstrap.hs | 218 ++++++++++++++++++++++++++++++++++ 1 file changed, 218 insertions(+) create mode 100644 src/Propellor/Property/Debootstrap.hs (limited to 'src/Propellor/Property/Debootstrap.hs') diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs new file mode 100644 index 00000000..8f93fe5b --- /dev/null +++ b/src/Propellor/Property/Debootstrap.hs @@ -0,0 +1,218 @@ +module Propellor.Property.Debootstrap ( + Url, + debootstrapped, + installed, + debootstrapPath, +) where + +import Propellor +import qualified Propellor.Property.Apt as Apt +import Utility.Path +import Utility.SafeCommand +import Utility.FileMode + +import Data.List +import Data.Char +import Control.Exception +import System.Posix.Directory + +type Url = String + +-- | Builds a chroot in the given directory using debootstrap. +-- +-- The System can be any OS and architecture that debootstrap +-- and the kernel support. +debootstrapped :: FilePath -> System -> [CommandParam] -> Property +debootstrapped target system@(System _ arch) extraparams = + check (unpopulated target) prop + `requires` unrevertable installed + where + unpopulated d = null <$> catchDefaultIO [] (dirContents d) + + prop = property ("debootstrapped " ++ target) $ liftIO $ do + createDirectoryIfMissing True target + let suite = case extractSuite system of + Nothing -> error $ "don't know how to debootstrap " ++ show system + Just s -> s + let params = extraparams ++ + [ Param suite + , Param target + , Param $ "--arch=" ++ arch + ] + cmd <- fromMaybe "debootstrap" <$> debootstrapPath + ifM (boolSystem cmd params) + ( do + fixForeignDev target + return MadeChange + , return FailedChange + ) + +extractSuite :: System -> Maybe String +extractSuite (System (Debian s) _) = Just $ Apt.showSuite s +extractSuite (System (Ubuntu r) _) = Just r + +-- | Ensures debootstrap is installed. +-- +-- When necessary, falls back to installing debootstrap from source. +-- Note that installation from source is done by downloading the tarball +-- from a Debian mirror, with no cryptographic verification. +installed :: RevertableProperty +installed = RevertableProperty install remove + where + install = withOS "debootstrap installed" $ \o -> + ifM (liftIO $ isJust <$> debootstrapPath) + ( return NoChange + , ensureProperty (installon o) + ) + + installon (Just (System (Debian _) _)) = aptinstall + installon (Just (System (Ubuntu _) _)) = aptinstall + installon _ = sourceInstall + + remove = withOS "debootstrap removed" $ ensureProperty . removefrom + removefrom (Just (System (Debian _) _)) = aptremove + removefrom (Just (System (Ubuntu _) _)) = aptremove + removefrom _ = sourceRemove + + aptinstall = Apt.installed ["debootstrap"] + aptremove = Apt.removed ["debootstrap"] + +sourceInstall :: Property +sourceInstall = property "debootstrap installed from source" + (liftIO sourceInstall') + +sourceInstall' :: IO Result +sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do + let indexfile = tmpd "index.html" + unlessM (download baseurl indexfile) $ + error $ "Failed to download " ++ baseurl + urls <- reverse . sort -- highest version first + . filter ("debootstrap_" `isInfixOf`) + . filter (".tar." `isInfixOf`) + . extractUrls baseurl <$> + readFileStrictAnyEncoding indexfile + nukeFile indexfile + + tarfile <- case urls of + (tarurl:_) -> do + let f = tmpd takeFileName tarurl + unlessM (download tarurl f) $ + error $ "Failed to download " ++ tarurl + return f + _ -> error $ "Failed to find any debootstrap tarballs listed on " ++ baseurl + + createDirectoryIfMissing True localInstallDir + bracket getWorkingDirectory changeWorkingDirectory $ \_ -> do + changeWorkingDirectory localInstallDir + unlessM (boolSystem "tar" [Param "xf", File tarfile]) $ + error "Failed to extract debootstrap tar file" + nukeFile tarfile + l <- dirContents "." + case l of + (subdir:[]) -> do + changeWorkingDirectory subdir + makeDevicesTarball + makeWrapperScript (localInstallDir subdir) + return MadeChange + _ -> error "debootstrap tar file did not contain exactly one dirctory" + +sourceRemove :: Property +sourceRemove = property "debootstrap not installed from source" $ liftIO $ + ifM (doesDirectoryExist sourceInstallDir) + ( do + removeDirectoryRecursive sourceInstallDir + return MadeChange + , return NoChange + ) + +sourceInstallDir :: FilePath +sourceInstallDir = "/usr/local/propellor/debootstrap" + +wrapperScript :: FilePath +wrapperScript = sourceInstallDir "debootstrap.wrapper" + +-- | Finds debootstrap in PATH, but fall back to looking for the +-- wrapper script that is installed, outside the PATH, when debootstrap +-- is installed from source. +debootstrapPath :: IO (Maybe FilePath) +debootstrapPath = getM searchPath + [ "debootstrap" + , wrapperScript + ] + +makeWrapperScript :: FilePath -> IO () +makeWrapperScript dir = do + createDirectoryIfMissing True (takeDirectory wrapperScript) + writeFile wrapperScript $ unlines + [ "#!/bin/sh" + , "set -e" + , "DEBOOTSTRAP_DIR=" ++ dir + , "export DEBOOTSTRAP_DIR" + , dir "debootstrap" ++ " \"$@\"" + ] + modifyFileMode wrapperScript (addModes $ readModes ++ executeModes) + +-- Work around for http://bugs.debian.org/770217 +makeDevicesTarball :: IO () +makeDevicesTarball = do + -- TODO append to tarball; avoid writing to /dev + writeFile foreignDevFlag "1" + ok <- boolSystem "sh" [Param "-c", Param tarcmd] + nukeFile foreignDevFlag + unless ok $ + error "Failed to tar up /dev to generate devices.tar.gz" + where + tarcmd = "(cd / && tar cf - dev) | gzip > devices.tar.gz" + +fixForeignDev :: FilePath -> IO () +fixForeignDev target = whenM (doesFileExist (target ++ foreignDevFlag)) $ + void $ boolSystem "chroot" + [ File target + , Param "sh" + , Param "-c" + , Param $ intercalate " && " + [ "rm -rf /dev" + , "mkdir /dev" + , "cd /dev" + , "/sbin/MAKEDEV std ptmx fd consoleonly" + ] + ] + +foreignDevFlag :: FilePath +foreignDevFlag = "/dev/.propellor-foreign-dev" + +localInstallDir :: FilePath +localInstallDir = "/usr/local/debootstrap" + +-- This http server directory listing is relied on to be fairly sane, +-- which is one reason why it's using a specific server and not a +-- round-robin address. +baseurl :: Url +baseurl = "http://ftp.debian.org/debian/pool/main/d/debootstrap/" + +download :: Url -> FilePath -> IO Bool +download url dest = anyM id + [ boolSystem "curl" [Param "-o", File dest, Param url] + , boolSystem "wget" [Param "-O", File dest, Param url] + ] + +-- Pretty hackish, but I don't want to pull in a whole html parser +-- or parsec dependency just for this. +-- +-- To simplify parsing, lower case everything. This is ok because +-- the filenames are all lower-case anyway. +extractUrls :: Url -> String -> [Url] +extractUrls base = collect [] . map toLower + where + collect l [] = l + collect l ('h':'r':'e':'f':'=':r) = case r of + ('"':r') -> findend l r' + _ -> findend l r + collect l (_:cs) = collect l cs + + findend l s = + let (u, r) = break (== '"') s + u' = if "http" `isPrefixOf` u + then u + else base u + in collect (u':l) r -- cgit v1.3-2-g0d8e From caeed5492fa3c66668d750a79ea5886248c6bd07 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Nov 2014 20:35:33 -0400 Subject: allow debootstrapped to be reverted --- src/Propellor/Property/Debootstrap.hs | 33 ++++++++++++++++++++++++++++----- 1 file changed, 28 insertions(+), 5 deletions(-) (limited to 'src/Propellor/Property/Debootstrap.hs') diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index 8f93fe5b..876c12cb 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -22,14 +22,24 @@ type Url = String -- -- The System can be any OS and architecture that debootstrap -- and the kernel support. -debootstrapped :: FilePath -> System -> [CommandParam] -> Property -debootstrapped target system@(System _ arch) extraparams = - check (unpopulated target) prop - `requires` unrevertable installed +-- +-- Reverting this property deletes the chroot and all its contents. +-- Anything mounted under the filesystem is first unmounted. +-- +-- Note that reverting this property does not stop any processes +-- currently running in the chroot. +debootstrapped :: FilePath -> System -> [CommandParam] -> RevertableProperty +debootstrapped target system@(System _ arch) extraparams = + RevertableProperty setup teardown where + setup = check (unpopulated target) setupprop + `requires` unrevertable installed + + teardown = check (not <$> unpopulated target) teardownprop + unpopulated d = null <$> catchDefaultIO [] (dirContents d) - prop = property ("debootstrapped " ++ target) $ liftIO $ do + setupprop = property ("debootstrapped " ++ target) $ liftIO $ do createDirectoryIfMissing True target let suite = case extractSuite system of Nothing -> error $ "don't know how to debootstrap " ++ show system @@ -47,6 +57,19 @@ debootstrapped target system@(System _ arch) extraparams = , return FailedChange ) + teardownprop = property ("removed debootstrapped " ++ target) $ liftIO $ do + submnts <- filter (\p -> simplifyPath p /= simplifyPath target) + . filter (dirContains target) + <$> mountPoints + forM_ submnts $ \mnt -> + unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $ do + error $ "failed unmounting " ++ mnt + removeDirectoryRecursive target + return MadeChange + +mountPoints :: IO [FilePath] +mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"] + extractSuite :: System -> Maybe String extractSuite (System (Debian s) _) = Just $ Apt.showSuite s extractSuite (System (Ubuntu r) _) = Just r -- cgit v1.3-2-g0d8e From c186f9f4a858edfe0f2211e71da07715bd2e99b7 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Nov 2014 20:41:35 -0400 Subject: propellor spin --- config-joey.hs | 3 +++ src/Propellor/Property/Debootstrap.hs | 16 ++++++++-------- 2 files changed, 11 insertions(+), 8 deletions(-) (limited to 'src/Propellor/Property/Debootstrap.hs') diff --git a/config-joey.hs b/config-joey.hs index 98dac3e7..fad37b08 100644 --- a/config-joey.hs +++ b/config-joey.hs @@ -24,6 +24,7 @@ import qualified Propellor.Property.Postfix as Postfix import qualified Propellor.Property.Grub as Grub import qualified Propellor.Property.Obnam as Obnam import qualified Propellor.Property.Gpg as Gpg +import qualified Propellor.Property.Debootstrap as Debootstrap import qualified Propellor.Property.HostingProvider.DigitalOcean as DigitalOcean import qualified Propellor.Property.HostingProvider.CloudAtCost as CloudAtCost import qualified Propellor.Property.HostingProvider.Linode as Linode @@ -79,6 +80,8 @@ clam = standardSystem "clam.kitenet.net" Unstable "amd64" & alias "travelling.kitenet.net" ! Ssh.listenPort 80 ! Ssh.listenPort 443 + + & Debootstrap.built "/tmp/chroot" (System (Debian Unstable) "amd64") [] orca :: Host orca = standardSystem "orca.kitenet.net" Unstable "amd64" diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index 876c12cb..70a0dd9c 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -1,8 +1,8 @@ module Propellor.Property.Debootstrap ( Url, - debootstrapped, + built, installed, - debootstrapPath, + programPath, ) where import Propellor @@ -28,8 +28,8 @@ type Url = String -- -- Note that reverting this property does not stop any processes -- currently running in the chroot. -debootstrapped :: FilePath -> System -> [CommandParam] -> RevertableProperty -debootstrapped target system@(System _ arch) extraparams = +built :: FilePath -> System -> [CommandParam] -> RevertableProperty +built target system@(System _ arch) extraparams = RevertableProperty setup teardown where setup = check (unpopulated target) setupprop @@ -49,7 +49,7 @@ debootstrapped target system@(System _ arch) extraparams = , Param target , Param $ "--arch=" ++ arch ] - cmd <- fromMaybe "debootstrap" <$> debootstrapPath + cmd <- fromMaybe "debootstrap" <$> programPath ifM (boolSystem cmd params) ( do fixForeignDev target @@ -83,7 +83,7 @@ installed :: RevertableProperty installed = RevertableProperty install remove where install = withOS "debootstrap installed" $ \o -> - ifM (liftIO $ isJust <$> debootstrapPath) + ifM (liftIO $ isJust <$> programPath) ( return NoChange , ensureProperty (installon o) ) @@ -157,8 +157,8 @@ wrapperScript = sourceInstallDir "debootstrap.wrapper" -- | Finds debootstrap in PATH, but fall back to looking for the -- wrapper script that is installed, outside the PATH, when debootstrap -- is installed from source. -debootstrapPath :: IO (Maybe FilePath) -debootstrapPath = getM searchPath +programPath :: IO (Maybe FilePath) +programPath = getM searchPath [ "debootstrap" , wrapperScript ] -- cgit v1.3-2-g0d8e From 4de7d4295c91b07b1338db2114b9557b5353a978 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Nov 2014 21:03:06 -0400 Subject: propellor spin --- src/Propellor/Property/Debootstrap.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) (limited to 'src/Propellor/Property/Debootstrap.hs') diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index 70a0dd9c..23dabcf6 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -41,9 +41,9 @@ built target system@(System _ arch) extraparams = setupprop = property ("debootstrapped " ++ target) $ liftIO $ do createDirectoryIfMissing True target - let suite = case extractSuite system of - Nothing -> error $ "don't know how to debootstrap " ++ show system - Just s -> s + suite <- case extractSuite system of + Nothing -> errorMessage $ "don't know how to debootstrap " ++ show system + Just s -> pure s let params = extraparams ++ [ Param suite , Param target @@ -63,7 +63,7 @@ built target system@(System _ arch) extraparams = <$> mountPoints forM_ submnts $ \mnt -> unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $ do - error $ "failed unmounting " ++ mnt + errorMessage $ "failed unmounting " ++ mnt removeDirectoryRecursive target return MadeChange @@ -108,7 +108,7 @@ sourceInstall' :: IO Result sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do let indexfile = tmpd "index.html" unlessM (download baseurl indexfile) $ - error $ "Failed to download " ++ baseurl + errorMessage $ "Failed to download " ++ baseurl urls <- reverse . sort -- highest version first . filter ("debootstrap_" `isInfixOf`) . filter (".tar." `isInfixOf`) @@ -120,15 +120,15 @@ sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do (tarurl:_) -> do let f = tmpd takeFileName tarurl unlessM (download tarurl f) $ - error $ "Failed to download " ++ tarurl + errorMessage $ "Failed to download " ++ tarurl return f - _ -> error $ "Failed to find any debootstrap tarballs listed on " ++ baseurl + _ -> errorMessage $ "Failed to find any debootstrap tarballs listed on " ++ baseurl createDirectoryIfMissing True localInstallDir bracket getWorkingDirectory changeWorkingDirectory $ \_ -> do changeWorkingDirectory localInstallDir unlessM (boolSystem "tar" [Param "xf", File tarfile]) $ - error "Failed to extract debootstrap tar file" + errorMessage "Failed to extract debootstrap tar file" nukeFile tarfile l <- dirContents "." case l of @@ -137,7 +137,7 @@ sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do makeDevicesTarball makeWrapperScript (localInstallDir subdir) return MadeChange - _ -> error "debootstrap tar file did not contain exactly one dirctory" + _ -> errorMessage "debootstrap tar file did not contain exactly one dirctory" sourceRemove :: Property sourceRemove = property "debootstrap not installed from source" $ liftIO $ @@ -183,7 +183,7 @@ makeDevicesTarball = do ok <- boolSystem "sh" [Param "-c", Param tarcmd] nukeFile foreignDevFlag unless ok $ - error "Failed to tar up /dev to generate devices.tar.gz" + errorMessage "Failed to tar up /dev to generate devices.tar.gz" where tarcmd = "(cd / && tar cf - dev) | gzip > devices.tar.gz" -- cgit v1.3-2-g0d8e From 205d1925598f986dd4ce679e17e487c089592ff3 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Nov 2014 21:16:18 -0400 Subject: fix param order --- src/Propellor/Property/Debootstrap.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src/Propellor/Property/Debootstrap.hs') diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index 23dabcf6..ed851d97 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -45,9 +45,9 @@ built target system@(System _ arch) extraparams = Nothing -> errorMessage $ "don't know how to debootstrap " ++ show system Just s -> pure s let params = extraparams ++ - [ Param suite + [ Param $ "--arch=" ++ arch + , Param suite , Param target - , Param $ "--arch=" ++ arch ] cmd <- fromMaybe "debootstrap" <$> programPath ifM (boolSystem cmd params) -- cgit v1.3-2-g0d8e From 3343b220a8381fb356926c458e66874bc540abcd Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 19 Nov 2014 21:21:20 -0400 Subject: propellor spin --- src/Propellor/Property/Debootstrap.hs | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) (limited to 'src/Propellor/Property/Debootstrap.hs') diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs index ed851d97..4e7bc740 100644 --- a/src/Propellor/Property/Debootstrap.hs +++ b/src/Propellor/Property/Debootstrap.hs @@ -32,7 +32,7 @@ built :: FilePath -> System -> [CommandParam] -> RevertableProperty built target system@(System _ arch) extraparams = RevertableProperty setup teardown where - setup = check (unpopulated target) setupprop + setup = check (unpopulated target <||> ispartial) setupprop `requires` unrevertable installed teardown = check (not <$> unpopulated target) teardownprop @@ -58,6 +58,10 @@ built target system@(System _ arch) extraparams = ) teardownprop = property ("removed debootstrapped " ++ target) $ liftIO $ do + removetarget + return MadeChange + + removetarget = do submnts <- filter (\p -> simplifyPath p /= simplifyPath target) . filter (dirContains target) <$> mountPoints @@ -65,7 +69,15 @@ built target system@(System _ arch) extraparams = unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $ do errorMessage $ "failed unmounting " ++ mnt removeDirectoryRecursive target - return MadeChange + + -- A failed debootstrap run will leave a debootstrap directory; + -- recover by deleting it and trying again. + ispartial = ifM (doesDirectoryExist (target "debootstrap")) + ( do + removetarget + return True + , return False + ) mountPoints :: IO [FilePath] mountPoints = lines <$> readProcess "findmnt" ["-rn", "--output", "target"] -- cgit v1.3-2-g0d8e