module Debian.Repo.OSImage ( OSImage(..) , prepareEnv , updateEnv , syncPool , chrootEnv , syncEnv , neuterEnv , restoreEnv , removeEnv , buildEssential ) where import Control.Monad.Trans import Control.Exception import Control.Monad import qualified Data.ByteString.Lazy.Char8 as L import Data.List import Data.Maybe import Debian.Extra.CIO (vMessage) import Debian.Repo.Cache import Debian.Repo.IO import Debian.Repo.Package import Debian.Relation import Debian.Repo.Slice import Debian.Repo.SourcesList import Debian.Repo.Types import Debian.Shell (timeTask, vOutput, runTaskAndTest, SimpleTask(..)) import Extra.CIO (CIO, vPutStr, vPutStrBl, vBOL, ePutStr) import Extra.Files (replaceFile) import Extra.List (isSublistOf) import Extra.Misc (sameInode, sameMd5sum) import Extra.SSH (sshCopy) import System.FilePath import System.Unix.Directory import System.Unix.Mount import System.Unix.Process import System.Cmd import System.Directory import qualified System.IO as IO import System.Posix.Files import System.Time import Text.Regex -- |This type represents an OS image located at osRoot built from a -- particular osBaseDistro using a particular osArch. If an -- osLocalRepo 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 { osGlobalCacheDir :: FilePath , osRoot :: EnvRoot , osBaseDistro :: SliceList , osReleaseName :: ReleaseName , osArch :: Arch -- | The associated local repository, where packages we -- build inside this image are first uploaded to. , osLocalRepoMaster :: Maybe LocalRepository -- |A copy of osLocalRepo which is inside the changeroot --, osLocalRepoCopy :: Maybe LocalRepo -- | Update and return a copy of the local repository -- which is inside the changeroot. , osSourcePackages :: [SourcePackage] , osBinaryPackages :: [BinaryPackage] } instance Show OSImage where show os = intercalate " " ["OS {", rootPath (osRoot os), relName (osReleaseName os), archName (osArch os), show (osLocalRepoMaster os)] instance Ord OSImage where compare a b = case compare (osRoot a) (osRoot b) of EQ -> case compare (osBaseDistro a) (osBaseDistro b) of EQ -> compare (osArch a) (osArch b) x -> x x -> x instance Eq OSImage where a == b = compare a b == EQ instance AptCache OSImage where globalCacheDir = osGlobalCacheDir rootDir = osRoot aptArch = osArch -- aptSliceList = osFullDistro aptBaseSliceList = osBaseDistro aptSourcePackages = osSourcePackages aptBinaryPackages = osBinaryPackages aptReleaseName = osReleaseName instance AptBuildCache OSImage where aptSliceList = osFullDistro -- |The sources.list is the list associated with the distro name, plus -- the local sources where we deposit newly built packages. osFullDistro :: OSImage -> SliceList osFullDistro os = SliceList { slices = slices (osBaseDistro os) ++ slices (localSources os) } localSources :: OSImage -> SliceList localSources os = case osLocalRepoMaster os of Nothing -> SliceList { slices = [] } Just repo -> let repo' = repoCD (EnvPath (envRoot (repoRoot repo)) "/work/localpool") repo in let name = relName (osReleaseName os) in let src = DebSource Deb (repoURI repo') (Right (parseReleaseName name, [parseSection' "main"])) bin = DebSource DebSrc (repoURI repo') (Right (parseReleaseName name, [parseSection' "main"])) in SliceList { slices = [Slice { sliceRepo = LocalRepo repo', sliceSource = src }, Slice { sliceRepo = LocalRepo repo', sliceSource = bin }] } -- |Change the root directory of a repository. FIXME: This should -- also sync the repository to ensure consistency. repoCD :: EnvPath -> LocalRepository -> LocalRepository repoCD path repo = repo { repoRoot = path } getSourcePackages :: CIO m => OSImage -> AptIOT m [SourcePackage] getSourcePackages os = mapM (sourcePackagesOfIndex' os) indexes >>= return . concat where indexes = concat . map (sliceIndexes os) . slices . sourceSlices . aptSliceList $ os getBinaryPackages :: CIO m => OSImage -> AptIOT m [BinaryPackage] getBinaryPackages os = mapM (binaryPackagesOfIndex' os) indexes >>= return . concat where indexes = concat . map (sliceIndexes os) . slices . binarySlices . aptSliceList $ os -- |Create or update an OS image in which packages can be built. prepareEnv :: CIO m => FilePath -> EnvRoot -- ^ The location where image is to be built -> NamedSliceList -- ^ The sources.list -> Maybe LocalRepository -- ^ The associated local repository, where newly -- built packages are stored. This repository is -- periodically copied into the build environment -- so apt can access the packages in it. -> Bool -- ^ If true, remove and rebuild the image -> SourcesChangedAction -- ^ What to do if called with a sources.list that -- differs from the previous call (unimplemented) -> [String] -- ^ Extra packages to treat as essential -> [String] -- ^ Packages to consider non-essential even if marked essential -> [String] -- ^ Extra packages to install during the build -> AptIOT m OSImage prepareEnv cacheDir root distro repo flush _ifSourcesChanged extraEssential omitEssential extra = do arch <- liftIO buildArchOfRoot --vPutStrLn 0 $ "prepareEnv repo: " ++ show repo let os = OS { osGlobalCacheDir = cacheDir , osRoot = root , osBaseDistro = sliceList distro , osReleaseName = ReleaseName . sliceName . sliceListName $ distro , osArch = arch , osLocalRepoMaster = repo , osSourcePackages = [] , osBinaryPackages = [] } update os >>= recreate arch os >>= lift . syncPool where update _ | flush = return $ Left "--flush option given" update os = updateEnv os recreate _ _ (Right os) = return os recreate arch os (Left reason) = do lift (vPutStrBl 0 $ "Removing and recreating build environment at " ++ rootPath root ++ ": " ++ reason) lift (vPutStrBl 2 ("removeRecursiveSafely " ++ rootPath root)) liftIO (removeRecursiveSafely (rootPath root)) lift (vPutStrBl 2 ("createDirectoryIfMissing True " ++ show (distDir os))) liftIO (createDirectoryIfMissing True (distDir os)) lift (vPutStrBl 3 ("writeFile " ++ show (sourcesPath os) ++ " " ++ show (show . osBaseDistro $ os))) liftIO (replaceFile (sourcesPath os) (show . osBaseDistro $ os)) buildEnv cacheDir root distro arch repo extraEssential omitEssential extra >>= lift . neuterEnv >>= lift . syncPool -- |Prepare a minimal \/dev directory 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 :: CIO m => FilePath -> EnvRoot -> NamedSliceList -> Arch -> Maybe LocalRepository -> [String] -> [String] -> [String] -> AptIOT m OSImage buildEnv cacheDir root distro arch repo extraEssential omitEssential extra = do -- 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. (output, result) <- liftIO (lazyCommand cmd L.empty) >>= lift . vMessage 0 ("Creating clean build environment (" ++ sliceName (sliceListName distro) ++ ")") >>= lift . vMessage 1 ("# " ++ cmd) >>= lift . vOutput 1 >>= return . collectStderr . mergeToStderr case result of -- It is fatal if we can't build the environment [Result ExitSuccess] -> do lift (ePutStr "done.\n") let os = OS { osGlobalCacheDir = cacheDir , osRoot = root , osBaseDistro = sliceList distro , osReleaseName = ReleaseName . sliceName . sliceListName $ distro , osArch = arch , osLocalRepoMaster = repo , osSourcePackages = [] , osBinaryPackages = [] } let sourcesPath = rootPath root ++ "/etc/apt/sources.list" -- Rewrite the sources.list with the local pool added. liftIO $ replaceFile sourcesPath (show . aptSliceList $ os) updateEnv os >>= either (error . show) return failure -> (lift . ePutStr . L.unpack $ output) >> error ("Could not create build environment:\n " ++ cmd ++ " -> " ++ show failure) where cmd = ("unset LANG; build-env --allow-missing-indexes --immediate-configure-false " ++ " -o " ++ rootPath root ++ " -s " ++ cacheSourcesPath cacheDir (ReleaseName (sliceName (sliceListName distro))) ++ " --with '" ++ intercalate " " extra ++ "'" ++ " --with-essential '" ++ intercalate " " extraEssential ++ "'" ++ " --omit-essential '" ++ intercalate " " omitEssential ++ "'") -- |Try to update an existing build environment: run apt-get update -- and dist-upgrade. updateEnv :: CIO m => OSImage -> AptIOT m (Either String OSImage) updateEnv os = do verified <- verifySources os case verified of Left x -> return $ Left x Right _ -> do liftIO $ prepareDevs (rootPath root) os' <- lift $ syncPool os liftIO $ sshCopy (rootPath root) source <- getSourcePackages os' binary <- getBinaryPackages os' return . Right $ os' {osSourcePackages = source, osBinaryPackages = binary} where verifySources :: CIO m => OSImage -> AptIOT m (Either String OSImage) verifySources os = do let correct = aptSliceList os sourcesPath = rootPath root ++ "/etc/apt/sources.list" text <- liftIO (try $ readFile sourcesPath) installed <- case text of Left _ -> return Nothing Right s -> verifySourcesList (Just root) (parseSourcesList s) >>= return . Just case installed of Nothing -> return $ Left ("No sources.list for " ++ relName (osReleaseName os) ++ " at " ++ sourcesPath) Just installed | installed /= correct -> return $ Left ("Sources for " ++ relName (osReleaseName os) ++ " in " ++ sourcesPath ++ " don't match computed configuration.\n\ncomputed:\n" ++ show correct ++ "\ninstalled:\n" ++ show installed) _ -> return $ Right os root = osRoot os chrootEnv :: OSImage -> EnvRoot -> OSImage chrootEnv os dst = os {osRoot=dst} -- 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 :: CIO m => OSImage -> OSImage -> m OSImage syncEnv src dst = mkdir >>= liftIO . umount >>= sync >>= either (error . show) (const (return dst)) {- either (return . Left . show) (const (liftIO doUmounts)) >>= either (return . Left) (const . syncStyle . runCommand 1 $ cmd) >>= either (error . show) (const (return dst)) -} where mkdir = liftIO (try (createDirectoryIfMissing True (rootPath (osRoot dst) ++ "/work"))) umount (Left message) = return . Left . show $ message umount (Right _) = do srcResult <- umountBelow (rootPath (osRoot src)) dstResult <- umountBelow (rootPath (osRoot dst)) case filter (\ (_, (_, _, code)) -> code /= ExitSuccess) (srcResult ++ dstResult) of [] -> return (Right ()) failed -> return . Left $ "umount failure(s): " ++ show failed sync (Left message) = return (Left message) sync (Right _) = runTaskAndTest (SimpleTask 1 cmd) >>= vMessage 0 ("Copying clean build environment: " ++ rootPath (osRoot src) ++ " -> " ++ rootPath (osRoot dst)) cmd = ("rsync -aHxSpDt '--exclude=/work/build/**' --delete '" ++ rootPath (osRoot src) ++ "/' '" ++ rootPath (osRoot dst) ++ "'") {- syncStyle = setStyle (setStart (Just ("Copying clean build environment: " ++ rootPath (osRoot src) ++ " -> " ++ rootPath (osRoot dst))) . setError (Just "Could not sync with clean build environment")) -} -- |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 :: CIO m => OSImage -> m OSImage neuterEnv os = do vBOL 0 >> vPutStr 0 ("Neutering OS image (" ++ stripDist (rootPath root) ++ ")...") result <- liftIO $ try $ mapM_ (neuterFile os) neuterFiles either (\ e -> error $ "Failed to neuter environment " ++ rootPath root ++ ": " ++ show e) (\ _ -> return os) result where root = osRoot os neuterFiles :: [(FilePath, Bool)] neuterFiles = [("/sbin/start-stop-daemon", True), ("/usr/sbin/invoke-rc.d", True), ("/sbin/init",False), ("/usr/sbin/policy-rc.d", False)] -- neuter_file from build-env.ml neuterFile :: OSImage -> (FilePath, Bool) -> IO () neuterFile os (file, mustExist) = do -- putStrBl ("Neutering file " ++ file) exists <- doesFileExist (outsidePath fullPath) if exists then neuterExistantFile else if mustExist then error ("Can't neuter nonexistant file: " ++ outsidePath fullPath) else return () -- putStrBl "File doesn't exist, nothing to do" where neuterExistantFile = do sameFile <- sameInode (outsidePath fullPath) (outsidePath binTrue) if sameFile then return () else -- putStrBl "File already neutered" neuterUnneuteredFile neuterUnneuteredFile = do hasReal <- doesFileExist (outsidePath fullPath ++ ".real") if hasReal then neuterFileWithRealVersion else neuterFileWithoutRealVersion createLink (outsidePath binTrue) (outsidePath fullPath) neuterFileWithRealVersion = do sameCksum <- sameMd5sum (outsidePath fullPath) (outsidePath fullPath ++ ".real") if sameCksum then removeFile (outsidePath fullPath) else error (file ++ " and " ++ file ++ ".real differ (in " ++ rootPath root ++ ")") neuterFileWithoutRealVersion = renameFile (outsidePath fullPath) (outsidePath fullPath ++ ".real") fullPath = EnvPath root file binTrue = EnvPath root "/bin/true" root = osRoot os -- |Reverse the neuterEnv operation. restoreEnv :: OSImage -> IO OSImage restoreEnv os = do IO.hPutStr IO.stderr "De-neutering OS image..." result <- try $ mapM_ (restoreFile os) neuterFiles either (\ e -> error $ "damaged environment " ++ rootPath root ++ ": " ++ show e ++ "\n please remove it.") (\ _ -> return os) result where root = osRoot os -- check_and_restore from build-env.ml restoreFile :: OSImage -> (FilePath, Bool) -> IO () restoreFile os (file, mustExist) = do exists <- doesFileExist (outsidePath fullPath) if exists then restoreExistantFile else if mustExist then error ("Can't restore nonexistant file: " ++ outsidePath fullPath) else return () where restoreExistantFile = do isTrue <- sameInode (outsidePath fullPath) (outsidePath binTrue) hasReal <- doesFileExist (outsidePath fullPath ++ ".real") case (isTrue, hasReal) of (True, True) -> do removeFile (outsidePath fullPath) renameFile (outsidePath fullPath ++ ".real") (outsidePath 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" root = osRoot os ----------------------------------- -- |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 False = do essential <- readFile (rootPath root ++ "/usr/share/build-essential/essential-packages-list") >>= return . lines >>= return . dropWhile (/= "") >>= return . tail >>= return . filter (/= "sysvinit") >>= return . parseRelations . (intercalate ", ") >>= return . (either (error "parse error in /usr/share/build-essential/essential-packages-list") id) let re = mkRegex "^[^ \t]" relationText <- readFile (rootPath 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: " ++ intercalate ", " relationText) let buildEssential = parseRelations (intercalate ", " relationText) let buildEssential' = either (\ l -> error ("parse error in /usr/share/build-essential/list:\n" ++ show l)) id buildEssential return (essential ++ buildEssential') where root = osRoot os -- |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 = do IO.hPutStr IO.stderr "Removing build environment..." removeRecursiveSafely (rootPath root) IO.hPutStrLn IO.stderr "done." where root = osRoot os -- |Use rsync to synchronize the pool of locally built packages from -- outside the build environment to the location inside the environment -- where apt can see and install the packages. syncPool :: CIO m => OSImage -> m OSImage syncPool os = case osLocalRepoMaster os of Nothing -> return os Just repo -> liftIO (try (createDirectoryIfMissing True (rootPath root ++ "/work"))) >>= either (return . Left . show) (const (rsync repo)) >>= either (return . Left) (const (updateLists os)) >>= either (error . show) (const (return os)) where rsync repo = liftIO (lazyCommand (cmd repo) L.empty) >>= vOutput 0 >>= vMessage 1 ("Syncing local pool from " ++ outsidePath (repoRoot repo) ++ " -> " ++ rootPath root) >>= checkResult (\ n -> return (Left $ "*** FAILURE syncing local pool: " ++ cmd repo ++ " -> " ++ show n)) (return (Right ())) cmd repo = "rsync -aHxSpDt --delete '" ++ outsidePath (repoRoot repo) ++ "/' '" ++ rootPath root ++ "/work/localpool'" root = osRoot os updateLists :: CIO m => OSImage -> m (Either String TimeDiff) updateLists os = do vMessage 1 ("Updating OSImage " ++ stripDist (rootPath root) ++ " ") () vMessage 2 ("# " ++ cmd) () ((_out, err, code), elapsed) <- liftIO . timeTask $ lazyCommand cmd L.empty >>= return . collectOutputUnpacked return $ case code of [ExitSuccess] -> Right elapsed result -> Left $ "*** FAILURE: Could not update environment: " ++ cmd ++ " -> " ++ show result ++ "\n" ++ err where cmd = ("echo $PATH 1>&2 && /usr/sbin/chroot " ++ rootPath root ++ " bash -c 'unset LANG; apt-get update && apt-get -y --force-yes dist-upgrade'") root = osRoot os stripDist :: FilePath -> FilePath stripDist path = maybe path (\ n -> drop (n + 7) path) (isSublistOf "/dists/" path)