OSImage.hs

-- |Module to handle Debian OS images, AKA build environments or change roots.
--
-- Author: David Fox <david.fox@linspire.com>
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