242 lines
7.2 KiB
Haskell
242 lines
7.2 KiB
Haskell
module Propellor.Property.Debootstrap (
|
|
Url,
|
|
built,
|
|
installed,
|
|
programPath,
|
|
) 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.
|
|
--
|
|
-- 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.
|
|
built :: FilePath -> System -> [CommandParam] -> RevertableProperty
|
|
built 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)
|
|
|
|
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
|
|
let params = extraparams ++
|
|
[ Param suite
|
|
, Param target
|
|
, Param $ "--arch=" ++ arch
|
|
]
|
|
cmd <- fromMaybe "debootstrap" <$> programPath
|
|
ifM (boolSystem cmd params)
|
|
( do
|
|
fixForeignDev target
|
|
return MadeChange
|
|
, 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
|
|
|
|
-- | 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 <$> programPath)
|
|
( 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.
|
|
programPath :: IO (Maybe FilePath)
|
|
programPath = 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
|