Debootstrap.hs

{-# LANGUAGE TypeFamilies #-}

module Propellor.Property.Debootstrap (
	Url,
	DebootstrapConfig(..),
	built,
	built',
	extractSuite,
	installed,
	sourceInstall,
) where

import Propellor.Base
import qualified Propellor.Property.Apt as Apt
import Propellor.Property.Chroot.Util
import Propellor.Property.Qemu
import Utility.Path
import Utility.FileMode

import Data.List
import Data.Char
import qualified Data.Semigroup as Sem
import System.Posix.Directory
import System.Posix.Files

type Url = String

-- | A data type for debootstrap configuration.
-- mempty is a default debootstrapped system.
data DebootstrapConfig
	= DefaultConfig
	| MinBase
	| BuilddD
	| DebootstrapParam String
	| UseEmulation
	| DebootstrapConfig :+ DebootstrapConfig
	deriving (Show)

instance Sem.Semigroup DebootstrapConfig where
	(<>) = (:+)

instance Monoid DebootstrapConfig where
	mempty  = DefaultConfig
	mappend = (Sem.<>)

toParams :: DebootstrapConfig -> [CommandParam]
toParams DefaultConfig = []
toParams MinBase = [Param "--variant=minbase"]
toParams BuilddD = [Param "--variant=buildd"]
toParams (DebootstrapParam p) = [Param p]
toParams UseEmulation = []
toParams (c1 :+ c2) = toParams c1 <> toParams c2

useEmulation :: DebootstrapConfig -> Bool
useEmulation UseEmulation = True
useEmulation (a :+ b) = useEmulation a || useEmulation b
useEmulation _ = False

-- | Builds a chroot in the given directory using debootstrap.
--
-- The System can be any OS and architecture that debootstrap
-- and the kernel support.
--
-- When the System is architecture that the kernel does not support,
-- it can still be bootstrapped using emulation. This is determined
-- by checking `supportsArch`, or can be configured with `UseEmulation`.
--
-- When emulation is used, the chroot will have an additional binary 
-- installed in it. To get a completelty clean chroot (eg for producing a
-- bootable disk image), use the `removeHostEmulationBinary` property.
built :: FilePath -> System -> DebootstrapConfig -> Property Linux
built target system@(System _ targetarch) config =
	withOS ("debootstrapped " ++ target) go
  where
	go w (Just hostos)
		| supportsArch hostos targetarch && not (useEmulation config) =
			ensureProperty w $
				built' (setupRevertableProperty installed)
					target system config
	go w _ = ensureProperty w $ do
		let p = setupRevertableProperty foreignBinariesEmulated
			`before` setupRevertableProperty installed
		built' p target system (config :+ UseEmulation)

-- | Like `built`,  but uses the provided Property to install debootstrap.
built' :: Property Linux -> FilePath -> System -> DebootstrapConfig -> Property Linux
built' installprop target system@(System _ arch) config = 
	go `before` oldpermfix
  where
	go = check (isUnpopulated target <||> ispartial) setupprop
		`requires` installprop

	setupprop :: Property Linux
	setupprop = property ("debootstrapped " ++ target) $ liftIO $ do
		createDirectoryIfMissing True target
		suite <- case extractSuite system of
			Nothing -> errorMessage $ "don't know how to debootstrap " ++ show system
			Just s -> pure s
		let params = toParams config ++
			[ Param $ "--arch=" ++ architectureToDebianArchString arch
			, Param suite
			, Param target
			]
		cmd <- if useEmulation config
			then pure "qemu-debootstrap"
			else fromMaybe "debootstrap" <$> programPath
		de <- standardPathEnv
		ifM (boolSystemEnv cmd params (Just de))
			( return MadeChange
			, return FailedChange
			)

	-- A failed debootstrap run will leave a debootstrap directory;
	-- recover by deleting it and trying again.
	ispartial = ifM (doesDirectoryExist (target </> "debootstrap"))
		( do
			removeChroot target
			return True
		, return False
		)
	
	-- May want to remove this after some appropriate length of time,
	-- as it's a workaround for chroots set up with too tight
	-- permissions.
	oldpermfix :: Property Linux
	oldpermfix = property ("fixed old chroot file mode") $ do
		liftIO $ modifyFileMode target $
			addModes [otherReadMode, otherExecuteMode]
		return NoChange

extractSuite :: System -> Maybe String
extractSuite (System (Debian _ s) _) = Just $ Apt.showSuite s
extractSuite (System (Buntish r) _) = Just r
extractSuite (System (ArchLinux) _) = Nothing
extractSuite (System (FreeBSD _) _) = Nothing

-- | 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 Linux Linux
installed = install <!> remove
  where
	install = check (isNothing <$> programPath) $
		(aptinstall `pickOS` sourceInstall)
			`describe` "debootstrap installed"

	remove = (aptremove `pickOS` sourceRemove)
		`describe` "debootstrap removed"

	aptinstall = Apt.installed ["debootstrap"]
	aptremove = Apt.removed ["debootstrap"]

sourceInstall :: Property Linux
sourceInstall = go
	`requires` perlInstalled
	`requires` arInstalled
  where
	go :: Property Linux
	go = property "debootstrap installed from source" (liftIO sourceInstall')

perlInstalled :: Property Linux
perlInstalled = check (not <$> inPath "perl") $ property "perl installed" $
	liftIO $ toResult . isJust <$> firstM id
		[ yumInstall "perl"
		]

arInstalled :: Property Linux
arInstalled = check (not <$> inPath "ar") $ property "ar installed" $
	liftIO $ toResult . isJust <$> firstM id
		[ yumInstall "binutils"
		]

yumInstall :: String -> IO Bool
yumInstall p = boolSystem "yum" [Param "-y", Param "install", Param p]

sourceInstall' :: IO Result
sourceInstall' = withTmpDir "debootstrap" $ \tmpd -> do
	let indexfile = tmpd </> "index.html"
	unlessM (download baseurl indexfile) $
		errorMessage $ "Failed to download " ++ baseurl
	urls <- sortBy (flip compare) -- highest version first
		. filter ("debootstrap_" `isInfixOf`)
		. filter (".tar." `isInfixOf`)
		. extractUrls baseurl <$>
		readFileStrict indexfile
	nukeFile indexfile

	tarfile <- case urls of
		(tarurl:_) -> do
			let f = tmpd </> takeFileName tarurl
			unlessM (download tarurl f) $
				errorMessage $ "Failed to download " ++ tarurl
			return f
		_ -> 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]) $
			errorMessage "Failed to extract debootstrap tar file"
		nukeFile tarfile
		l <- dirContents "."
		case l of
			(subdir:[]) -> do
				changeWorkingDirectory subdir
				makeWrapperScript (localInstallDir </> subdir)
				return MadeChange
			_ -> errorMessage "debootstrap tar file did not contain exactly one directory"

sourceRemove :: Property Linux
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)

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