-- |Module to handle Debian OS images, AKA build environments or change roots. -- -- Author: David Fox module Linspire.Debian.OSImage (OSImage, -- (export abstract to assure consistency) EnvRoot(EnvRoot), -- * Creation prepareEnv, -- [Style] -> EnvRoot -> DistroCache -> Maybe Repository -> Bool -> Bool -> IO OSImage syncEnv, -- [Style] -> OSImage -> OSImage -> IO TimeDiff chrootEnv, -- OSImage -> EnvRoot -> OSImage -- * Modification updateEnv, -- [Style] -> OSImage -> IO OSImage neuterEnv, -- [Style] -> OSImage -> IO OSImage restoreEnv, -- OSImage -> IO OSImage -- * Queries osRoot, -- OSImage -> EnvRoot osDistro, osSources, -- OSImage -> [DebSource] osArch, -- OSImage -> String osLocalRepository, -- OSImage -> Maybe Repository getSourceInfo, -- [Style] -> OSImage -> [PkgName] -> IO Control getBinaryInfo, -- [Style] -> OSImage -> [PkgName] -> IO Control getAvailable, -- [Style] -> OSImage -> [String] -> IO [Paragraph] buildEssential, -- OSImage -> Bool -> IO Relations buildArch, -- EnvRoot -> IO String -- * Removal removeEnv, -- OSImage -> IO () -- * Helper chrootPool -- DistroCache -> [DebSource] ) where import Control.Exception import Data.List import qualified Data.Map as Map import System.Cmd import System.Directory import System.Exit import System.IO import System.Posix.Files import System.Process import Text.Regex import Linspire.Unix.Directory as Unix import Linspire.Unix.FilePath import Linspire.Debian.Control import Linspire.Debian.DistroCache as DistroCache import Linspire.Debian.Relation import Linspire.Debian.Repository as Repository import Linspire.Debian.SourcesList import Linspire.Debian.Version import Linspire.Unix.Misc import Linspire.Unix.Progress as Progress -- |This type represents an OS image located at root built from a -- particular distro using a particular architecture. If a Repository -- argument is given, that repository will be copied into the -- environment and kept in sync, and lines will be added to -- sources.list to point to it. data OSImage = OS EnvRoot DistroCache Architecture (Maybe Repository) type Architecture = String -- |The root directory of an OS image. data EnvRoot = EnvRoot FilePath instance Show EnvRoot where show (EnvRoot path) = path -- |A directory inside of an OS image. data EnvPath = EnvPath EnvRoot FilePath instance Show EnvPath where show (EnvPath root path) = show root ++ path -- |Create or update an image. FIXME: Make sure there is no -- ".incomplete" flag next to the directory prepareEnv :: [Style] -> EnvRoot -> DistroCache -> Maybe Repository -> Bool -> Bool -> IO OSImage prepareEnv style root distro repo flush pgp = do exists <- doesFileExist (show root ++ "/etc/apt/sources.list") case flush || not exists of True -> do Unix.removeRecursiveSafely (show root) buildEnv failStyle root distro repo pgp >>= neuterEnv failStyle >>= syncPool style False -> do let os = OS root distro "i386" repo try (updateEnv style os) >>= -- At one point I removed and re-created the -- environment if anything went wrong trying to update -- it. This is often the wrong thing to do, since it -- might be caused by a glitch in networking. either (\ e -> error (updateError root e)) return where failStyle = Progress.removeStyle (Start "") style updateError root e = ("OSImage.updateEnv failed: " ++ show e ++ "\n (You may need to remove " ++ show root ++ ")") prepareDevs :: FilePath -> IO () prepareDevs root = do mapM_ prepareDev ([(root ++ "/dev/null", "c", 1, 3), (root ++ "/dev/zero", "c", 1, 5), (root ++ "/dev/full", "c", 1, 7), (root ++ "/dev/console", "c", 5, 1), (root ++ "/dev/random", "c", 1, 8), (root ++ "/dev/urandom", "c", 1, 9)] ++ (map (\ n -> (root ++ "/dev/loop" ++ show n, "b", 7, n)) [0..7]) ++ (map (\ n -> (root ++ "/dev/loop/" ++ show n, "b", 7, n)) [0..7])) where prepareDev (path, typ, major, minor) = do createDirectoryIfMissing True (fst (splitFileName path)) let cmd = "mknod " ++ path ++ " " ++ typ ++ " " ++ show major ++ " " ++ show minor exists <- doesFileExist path if not exists then system cmd else return ExitSuccess -- Create a new clean build environment in root.clean -- FIXME: create an ".incomplete" flag and remove it when build-env succeeds buildEnv :: [Style] -> EnvRoot -> DistroCache -> Maybe Repository -> Bool -> IO OSImage buildEnv style root distro repo pgp = do let extra = ["makedev", "build-essential"] ++ (if pgp then ["pgp"] else []) -- We can't create the environment if the sources.list has any -- file:// URIs because they can't yet be visible inside the -- environment. So we grep them out, create the environment, and -- then add them back in. systemTask buildStyle ("build-env -o " ++ show root ++ " -s " ++ DistroCache.sourcesPath distro ++ " with '" ++ consperse " " extra ++ "'") let os = OS root distro "i386" repo let sourceListText = osSources os -- ePut ("writeFile2 " ++ (show root ++ "/etc/apt/sources.list") ++ "\n" ++ (formatSources sourceListText)) writeFile (show root ++ "/etc/apt/sources.list") (consperse "\n" (map show sourceListText) ++ "\n") updateEnv style os where buildStyle = setStyles [Start ("Creating clean build environment (" ++ DistroCache.dist distro ++ ")"), Error "Could not create build environment."] style -- |Update an existing build environment - run apt-get update -- and dist-upgrade. updateEnv :: [Style] -> OSImage -> IO OSImage updateEnv style os@(OS root _ _ _) = do verifySources os prepareDevs (show root) syncPool style os syncSSH return os where verifySources os = do let correct = osSources os let sourcesPath = show root ++ "/etc/apt/sources.list" installed <- readFile sourcesPath >>= return . parseSourcesList if correct /= installed then do ePut ("Sources in " ++ sourcesPath ++ " don't match configuration for " ++ (show . dist . osDistro) os ++ ":\n\n" ++ consperse "\n" (map show correct)) error ("Sources.list mismatch for " ++ (show . dist . osDistro) os) else return () syncSSH = systemTask syncSSHStyle ("rsync -aHxSpDt --delete ~/.ssh/ " ++ show root ++ "/root/.ssh && " ++ "chown -R root.root " ++ show root ++ "/root/.ssh") syncSSHStyle = addStyles [Start "Copying SSH parameters", Error "Could copy SSH parameters", Output Dots] style -- These are the sources.list lines for the local pool when viewed -- from inside the changeroot. chrootPool :: DistroCache -> [DebSource] chrootPool distro = DistroCache.localPool distro "/work/localpool" chrootEnv :: OSImage -> EnvRoot -> OSImage chrootEnv (OS _ a b c) dst = (OS dst a b c) -- Sync the environment from the clean copy. All this does besides -- performing the proper rsync command is to make sure the destination -- directory exists, otherwise rsync will fail. Not sure why the 'work' -- subdir is appended. There must have been a reason at one point. syncEnv :: [Style] -> OSImage -> OSImage -> IO OSImage syncEnv style src dst = do createDirectoryIfMissing True (show (osRoot dst) ++ "/work") systemTask (setStyles [Start "Copying clean build environment", Error "Could not sync with clean build environment"] style) ("rsync -aHxSpDt --delete '" ++ show (osRoot src) ++ "/' '" ++ show (osRoot dst) ++ "'") return dst -- |To "neuter" an executable is to replace it with a hard link to -- \/bin\/true in such a way that the operation can be reversed. This -- is done in order to make it safe to install files into it when it -- isn't "live". If this operation fails it is assumed that the -- image is damaged, so it is removed. neuterEnv :: [Style] -> OSImage -> IO OSImage neuterEnv style os@(OS root _ _ _) = do msg style ("Neutering OS image (" ++ stripDist (show root) ++ ")...") result <- try $ mapM_ (neuterFile os) neuterFiles either (\ e -> error $ "Failed to neuter environment " ++ show root ++ ": " ++ show e) (\ _ -> return os) result neuterFiles :: [(FilePath, Bool)] neuterFiles = [("/sbin/start-stop-daemon", True), ("/usr/sbin/invoke-rc.d", True), ("/sbin/init",True), ("/usr/sbin/policy-rc.d", False)] -- neuter_file from build-env.ml neuterFile :: OSImage -> (FilePath, Bool) -> IO () neuterFile (OS root _ _ _) (file, mustExist) = do -- putStrLn ("Neutering file " ++ file) exists <- doesFileExist (show fullPath) if exists then neuterExistantFile else if mustExist then error ("Can't neuter nonexistant file: " ++ show fullPath) else return () -- putStrLn "File doesn't exist, nothing to do" where neuterExistantFile = do sameFile <- sameInode (show fullPath) (show binTrue) if sameFile then return () else -- putStrLn "File already neutered" neuterUnneuteredFile neuterUnneuteredFile = do hasReal <- doesFileExist (show fullPath ++ ".real") if hasReal then neuterFileWithRealVersion else neuterFileWithoutRealVersion createLink (show binTrue) (show fullPath) neuterFileWithRealVersion = do sameCksum <- sameMd5sum (show fullPath) (show fullPath ++ ".real") if sameCksum then removeFile (show fullPath) else error (file ++ " and " ++ file ++ ".real differ (in " ++ show root ++ ")") neuterFileWithoutRealVersion = renameFile (show fullPath) (show fullPath ++ ".real") fullPath = EnvPath root file binTrue = EnvPath root "/bin/true" -- |Reverse the neuterEnv operation. restoreEnv :: OSImage -> IO OSImage restoreEnv os@(OS root _ _ _) = do hPutStr stderr "De-neutering OS image..." result <- try $ mapM_ (restoreFile os) neuterFiles either (\ e -> error $ "damaged environment " ++ show root ++ ": " ++ show e ++ "\n please remove it.") (\ _ -> return os) result -- check_and_restore from build-env.ml restoreFile :: OSImage -> (FilePath, Bool) -> IO () restoreFile (OS root _ _ _) (file, mustExist) = do exists <- doesFileExist (show fullPath) if exists then restoreExistantFile else if mustExist then error ("Can't restore nonexistant file: " ++ show fullPath) else return () where restoreExistantFile = do isTrue <- sameInode (show fullPath) (show binTrue) hasReal <- doesFileExist (show fullPath ++ ".real") case (isTrue, hasReal) of (True, True) -> do removeFile (show fullPath) renameFile (show fullPath ++ ".real") (show fullPath) (False, _) -> error "Can't restore file not linked to /bin/true" (_, False) -> error "Can't restore file with no .real version" fullPath = EnvPath root file binTrue = EnvPath root "/bin/true" ----------------------------------- osRoot :: OSImage -> EnvRoot osRoot (OS root _ _ _) = root osDistro :: OSImage -> DistroCache osDistro (OS _ distro _ _) = distro osSources :: OSImage -> [DebSource] osSources (OS _ distro _ repo) = DistroCache.sources distro ++ maybe [] (\ _ -> chrootPool distro) repo osDist :: OSImage -> String osDist (OS _ distro _ _) = DistroCache.dist distro -- FIXME: Compute this with dpkg-architecture and save this in the OSImage osArch :: OSImage -> String osArch (OS _ _ arch _) = arch osLocalRepository :: OSImage -> Maybe Repository osLocalRepository (OS _ _ _ repo) = repo -- |Debian Status file (not currently used) {- type StatusMap = Map.Map String (Maybe Paragraph) getStatusFile :: OSImage -> IO StatusMap getStatusFile (OS root _ _ _ _) = parseControlFromFile (show root ++ "/var/lib/dpkg/status") >>= return . either (error . show) id >>= return . statusMake statusFind :: String -> StatusMap -> Maybe Paragraph statusFind name map = Map.findWithDefault Nothing name map statusMake :: Control -> StatusMap statusMake (Control control) = Map.fromList (map makepair control) where makepair paragraph = case lookupP "Package" paragraph of Just (Field (_, name)) -> (stripWS name, Just paragraph) _ -> error "A status file entry has no Package field" -} -- |Function to get information about source packages using apt-cache showsrc. getSourceInfo :: [Style] -> OSImage -> [PkgName] -> IO Control getSourceInfo style root packages = runAptCache (addStyles [Start ("getSourceInfo " ++ consperse " " packages ++ " in " ++ osDist root)] style) root "showsrc" packages -- |Function to get information about binary packages using apt-cache show. getBinaryInfo :: [Style] -> OSImage -> [PkgName] -> IO Control getBinaryInfo style root packages = runAptCache (addStyles [Start "getBinaryInfo"] style) root "show" packages -- We get different files in \/var\/lib\/apt\/lists depending on whether we run -- apt-get update in or out of the changeroot. Depending on that we need to -- use a different sources.list to query the cache. -- FIXME: it would be nice to not use temporary files here, but -- waitForProcess hangs below. -- FIXME: Uniquify the list of packages runAptCache :: [Style] -> OSImage -> String -> [PkgName] -> IO Control -- |apt-cache will fail if called with no package names runAptCache _ _ _ [] = return (Control []) runAptCache style os command packages = do let opts = aptOpts os let cmd = consperse " " ("apt-cache" : opts : command : packages) -- FIXME: don't use a temporary file here, but waitForProcess is hanging {- (_, outh, _, handle) <- runInteractiveCommand cmd control <- parseControlFromHandle ("getPackageInfo " ++ command) outh exitcode <- waitForProcess handle return $ either (error "Parse error in apt-cache output") id control -} let tmp = "/tmp/output" systemTask runStyle (cmd ++ " > " ++ tmp) control <- parseControlFromFile tmp -- If this file is not removed here, its contents may be -- replaced by a subsequent call before the parseControlFromFile -- is executed. Seriously! removeFile tmp return $ either (error "Parse error in apt-cache output") id control where runStyle = addStyles [Start ("Running apt-cache " ++ command ++ {- " " ++ show packages ++ -} " in " ++ osDist os)] style getAvailable :: [Style] -> OSImage -> [String] -> IO [Paragraph] getAvailable style os names = do Control available <- getSourceInfo style os names return $ sortBy cmp available where cmp p1 p2 = compare v2 v1 -- Flip args to get newest first where v1 = maybe Nothing (Just . parseDebianVersion) (fieldValue "Version" p1) v2 = maybe Nothing (Just . parseDebianVersion) (fieldValue "Version" p2) aptOpts :: OSImage -> String aptOpts (OS root _ _ _) = (" -o=Dir::State::status=" ++ show root ++ "/var/lib/dpkg/status" ++ " -o=Dir::State::Lists=" ++ show root ++ "/var/lib/apt/lists" ++ " -o=Dir::Cache::Archives=" ++ show root ++ "/var/cache/apt/archives" ++ " -o=Dir::Etc::SourceList=" ++ show root ++ "/etc/apt/sources.list") -- |Build the dependency relations for the build essential packages. -- For this to work the build-essential package must be installed in -- the OSImage. buildEssential :: OSImage -> Bool -> IO Relations buildEssential _ True = return [] buildEssential (OS root _ _ _) False = do essential <- readFile (show root ++ "/usr/share/build-essential/essential-packages-list") >>= return . lines >>= return . dropWhile (/= "") >>= return . tail >>= return . parseRelations . (consperse ", ") >>= return . (either (error "parse error in /usr/share/build-essential/essential-packages-list") id) let re = mkRegex "^[^ \t]" relationText <- readFile (show root ++ "/usr/share/build-essential/list") >>= return . lines >>= return . dropWhile (/= "BEGIN LIST OF PACKAGES") >>= return . tail >>= return . takeWhile (/= "END LIST OF PACKAGES") >>= return . filter ((/= Nothing) . (matchRegex re)) -- ePut ("buildEssentialText: " ++ consperse ", " relationText) let buildEssential = parseRelations (consperse ", " relationText) let buildEssential' = either (\ l -> error ("parse error in /usr/share/build-essential/list:\n" ++ show l)) id buildEssential return (essential ++ buildEssential') buildArch :: OSImage -> IO String buildArch (OS root _ _ _) = processOutput ("export LOGNAME=root; chroot " ++ show root ++ " dpkg-architecture") >>= return . lines . fst >>= return . map (mapSnd (drop 1) . break (== '=')) >>= return . Map.fromList >>= Map.lookup "DEB_BUILD_ARCH" processOutput :: String -> IO (String, ExitCode) processOutput command = do (_, outh, _, handle) <- runInteractiveCommand command output <- hGetContents outh exitCode <- waitForProcess handle return (output, exitCode) -- |Remove an image. The removeRecursiveSafely function is used to -- ensure that any file systems mounted inside the image are unmounted -- instead of destroyed. removeEnv :: OSImage -> IO () removeEnv (OS root _ _ _) = do hPutStr stderr "Removing build environment..." Unix.removeRecursiveSafely (show root) hPutStrLn stderr "done." {- -- mapM_ (createDirectoryIfMissing True . (++ "/dists") . show) copies -- syncCopies style repo -} syncPool :: [Style] -> OSImage -> IO OSImage syncPool _ os@(OS _ _ _ Nothing) = return os syncPool style os@(OS root _ _ (Just repo)) = do createDirectoryIfMissing True (show root ++ "/work") systemTask syncStyle ("rsync -aHxSpDt --delete '" ++ topDir repo ++ "/' '" ++ show root ++ "/work/localpool'") updateLists style os return os where syncStyle = setStyles [Start ("Syncing local pool from " ++ topDir repo ++ " -> " ++ show root), Error "Failure syncing local pool"] style updateLists :: [Style] -> OSImage -> IO TimeDiff updateLists style (OS root _ _ _) = systemTask updateStyle ("chroot " ++ show root ++ " bash -c 'unset LANG; apt-get update && apt-get -y dist-upgrade'") where updateStyle = addStyles [Start ("Updating environment (" ++ stripDist (show root) ++ ")"), Error "Could not update environment", Output Dots] style sameInode :: FilePath -> FilePath -> IO Bool sameInode a b = do aStatus <- getFileStatus a bStatus <- getFileStatus b return (deviceID aStatus == deviceID bStatus && fileID aStatus == fileID bStatus) sameMd5sum :: FilePath -> FilePath -> IO Bool sameMd5sum a b = do asum <- md5sum a bsum <- md5sum b return (asum == bsum) -- |The mighty consperse function consperse :: [a] -> [[a]] -> [a] consperse sep items = concat (intersperse sep items) mapSnd :: (b -> c) -> (a, b) -> (a, c) mapSnd f (a, b) = (a, f b) ePut :: String -> IO () ePut s = hPutStrLn stderr s