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
data OSImage
= OS { osGlobalCacheDir :: FilePath
, osRoot :: EnvRoot
, osBaseDistro :: SliceList
, osReleaseName :: ReleaseName
, osArch :: Arch
, osLocalRepoMaster :: Maybe LocalRepository
, 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
aptBaseSliceList = osBaseDistro
aptSourcePackages = osSourcePackages
aptBinaryPackages = osBinaryPackages
aptReleaseName = osReleaseName
instance AptBuildCache OSImage where
aptSliceList = osFullDistro
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 }] }
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
prepareEnv :: CIO m
=> FilePath
-> EnvRoot
-> NamedSliceList
-> Maybe LocalRepository
-> Bool
-> SourcesChangedAction
-> [String]
-> [String]
-> [String]
-> AptIOT m OSImage
prepareEnv cacheDir root distro repo flush _ifSourcesChanged extraEssential omitEssential extra =
do arch <- liftIO buildArchOfRoot
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
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
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
(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
[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"
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 ++ "'")
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}
syncEnv :: CIO m => OSImage -> OSImage -> m OSImage
syncEnv src dst =
mkdir >>= liftIO . umount >>= sync >>= 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) ++ "'")
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)]
neuterFile :: OSImage -> (FilePath, Bool) -> IO ()
neuterFile os (file, mustExist) =
do
exists <- doesFileExist (outsidePath fullPath)
if exists then
neuterExistantFile else
if mustExist then
error ("Can't neuter nonexistant file: " ++ outsidePath fullPath) else
return ()
where
neuterExistantFile =
do
sameFile <- sameInode (outsidePath fullPath) (outsidePath binTrue)
if sameFile then
return () else
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
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
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
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))
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
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
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)