summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2014-11-19 19:30:51 -0400
committerJoey Hess2014-11-19 19:30:56 -0400
commit4a9bbd1391b708d72a455cc00f698a80f1fd5fa5 (patch)
treed2d2bc76804b78f5a937ac31b34d8f4151c12745
parent08242e29f6878cbf514bdf68a4a7276d514a6aba (diff)
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.
-rw-r--r--debian/changelog3
-rw-r--r--propellor.cabal1
-rw-r--r--src/Propellor/Property.hs4
-rw-r--r--src/Propellor/Property/Debootstrap.hs218
4 files changed, 225 insertions, 1 deletions
diff --git a/debian/changelog b/debian/changelog
index 63adc6fe..0f4a06af 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -15,8 +15,9 @@ propellor (1.0.0) UNRELEASED; urgency=medium
* Avoid outputting color setting sequences when not run on a terminal.
* Run remote propellor --spin with a controlling terminal.
* Docker code simplified by using `docker exec`; needs docker 1.2.0.
+ * Added support for using debootstrap from propellor.
- -- Joey Hess <joeyh@debian.org> Mon, 10 Nov 2014 11:15:27 -0400
+ -- Joey Hess <id@joeyh.name> Mon, 10 Nov 2014 11:15:27 -0400
propellor (0.9.2) unstable; urgency=medium
diff --git a/propellor.cabal b/propellor.cabal
index 9a1df40b..161e4779 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -75,6 +75,7 @@ Library
Propellor.Property.Cmd
Propellor.Property.Hostname
Propellor.Property.Cron
+ Propellor.Property.Debootstrap
Propellor.Property.Dns
Propellor.Property.Docker
Propellor.Property.File
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 9545979c..7000b2a3 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -131,6 +131,10 @@ boolProperty desc a = property desc $ ifM (liftIO a)
revert :: RevertableProperty -> RevertableProperty
revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
+-- | Turns a revertable property into a regular property.
+unrevertable :: RevertableProperty -> Property
+unrevertable (RevertableProperty p1 _p2) = p1
+
-- | Starts accumulating the properties of a Host.
--
-- > host "example.com"
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