debian-3.23: Debian/Repo/OSImage.hs
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)