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 <||> ispartial) setupprop
		`requires` toProp installed
	
	teardown = check (not <$> unpopulated target) teardownprop
	
	unpopulated d = null <$> catchDefaultIO [] (dirContents d)

	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 = extraparams ++
			[ Param $ "--arch=" ++ arch
			, Param suite
			, Param target
			]
		cmd <- fromMaybe "debootstrap" <$> programPath
		ifM (boolSystem cmd params)
			( do
				fixForeignDev target
				return MadeChange
			, return FailedChange
			)

	teardownprop = property ("removed debootstrapped " ++ target) $ liftIO $ do
		removetarget
		return MadeChange

	removetarget = do
		submnts <- filter (\p -> simplifyPath p /= simplifyPath target)
			. filter (dirContains target)
			<$> mountPoints
		forM_ submnts $ \mnt ->
			unlessM (boolSystem "umount" [ Param "-l", Param mnt ]) $ do
				errorMessage $ "failed unmounting " ++ mnt
		removeDirectoryRecursive target

	-- 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"]

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) $
		errorMessage $ "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) $
				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
				makeDevicesTarball
				makeWrapperScript (localInstallDir </> subdir)
				return MadeChange
			_ -> errorMessage "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 $
		errorMessage "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