AptImage.hs

-- |The AptImage object represents a partial OS image which is capable
-- of running apt-get, and thus obtaining repository info and source
-- code packages.
module Linspire.Debian.AptImage 
    (AptImage,
     prepareAptEnv,	-- [Style] -> FilePath -> Maybe Repository -> SourcesList -> IO AptImage
     updateAptEnv,	-- [Style] -> AptImage -> IO AptImage
     aptGetSource,	-- [Style] -> FilePath -> AptImage -> PkgName -> Maybe DebianVersion -> IO SourceTree
     getAvailable)	-- [Style] -> OSImage -> [String] -> IO [Paragraph]
    where

import Data.List
import Data.Maybe
import System.Directory
import System.IO

import Linspire.Unix.FilePath
import Linspire.Unix.Directory
import Linspire.Unix.Misc
import Linspire.Unix.Progress as Progress
import qualified Linspire.Debian.ChangeLog as ChangeLog
import Linspire.Debian.Control
import Linspire.Debian.Version
import Linspire.Debian.Relation
import Linspire.Debian.SourcesList as SourcesList
import Linspire.Debian.SourceTree as SourceTree

data AptImage = Apt FilePath [DebSource]

-- |Create a skeletal enviroment sufficient to run apt-get.
prepareAptEnv ::  [Style] -> FilePath -> [DebSource] -> IO AptImage
prepareAptEnv style root sources =
    do
      let os = Apt root sources
      createDirectoryIfMissing True (root ++ "/var/lib/apt/lists/partial")
      createDirectoryIfMissing True (root ++ "/var/lib/apt/lists/partial")
      createDirectoryIfMissing True (root ++ "/var/cache/apt/archives/partial")
      createDirectoryIfMissing True (root ++ "/var/lib/dpkg")
      createDirectoryIfMissing True (root ++ "/etc/apt")
      writeFileIfMissing True (root ++ "/var/lib/dpkg/status") ""
      -- We need to create the local pool before updating so the
      -- sources.list will be valid.
      let sourceListText = consperse "\n" (map show sources) ++ "\n"
      -- ePut ("writeFile " ++ (root ++ "/etc/apt/sources.list") ++ "\n" ++ sourceListText)
      writeFile (root ++ "/etc/apt/sources.list") sourceListText
      updateAptEnv style os

updateAptEnv :: [Style] -> AptImage -> IO AptImage
updateAptEnv style os@(Apt root _) =
    do
      systemTask updateStyle ("apt-get" ++ aptOpts os ++ " update")
      return os
    where
      updateStyle = addStyles [Start ("Updating apt-get environment (" ++ root ++ ")"),
                               Error "Failure preparing apt-get environment"] style

-- |Retrieve a source package via apt-get.
aptGetSource :: [Style] -> FilePath -> AptImage -> PkgName -> Maybe DebianVersion -> IO SourceTree
aptGetSource style dir root package version =
    do
      ready <- SourceTree.findTrees dir >>= mapM latestChange >>= return . map ChangeLog.version
      newest <- getAvailable availableStyle root [package] >>=
                return . listToMaybe . map parseDebianVersion . catMaybes . map (fieldValue "Version")
      let version' = maybe newest Just version
      case (version', ready) of
        (Nothing, _) -> error ("No available versions of " ++ package)
        (Just requested, [available]) | requested == available -> SourceTree.findTree dir
        (Just requested, []) ->
            do
              runAptGet aptGetStyle root dir "source" [(package, Just requested)]
              trees <- SourceTree.findTrees dir
              case trees of
                [tree] -> return tree
                _ -> error "apt-get source failed"
        (Just requested, _) ->
            do
              -- One or more incorrect versions are available, remove them
              removeRecursiveSafely dir
              runAptGet aptGetStyle root dir "source" [(package, Just requested)]
              trees <- SourceTree.findTrees dir
              case trees of
                [tree] -> return tree
                _ -> error "apt-get source failed"
    where
      availableStyle = setStyles [Start ("Finding available versions of " ++ package ++ " in APT pool")] style
      aptGetStyle = setStyles [Start ("Retrieving APT source for " ++ package)] style


runAptGet :: [Style] -> AptImage -> FilePath -> String -> [(PkgName, Maybe DebianVersion)] -> IO TimeDiff
runAptGet style root dir command packages =
    do
      createDirectoryIfMissing True dir
      systemTask aptGetStyle (consperse " " ("cd" : dir : "&&" : "apt-get" : aptOpts root : command : map formatPackage packages))
    where
      formatPackage (name, Nothing) = name
      formatPackage (name, Just version) = name ++ "=" ++ show version
      aptGetStyle = setStyles [Error "apt-get failed"] style

getAvailable :: [Style] -> AptImage -> [String] -> IO [Paragraph]
getAvailable style root names =
    do
      Control available <- getSourceInfo style root 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)

-- |Function to get information about source packages using apt-cache showsrc.
getSourceInfo :: [Style] -> AptImage -> [PkgName] -> IO Control
getSourceInfo style os@(Apt root _) packages =
    runAptCache (addStyles [Start ("getSourceInfo " ++ consperse " " packages ++ " in " ++ root)] style) os "showsrc" packages

-- |Function to get information about binary packages using apt-cache show.
getBinaryInfo :: [Style] -> AptImage -> [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] -> AptImage -> String -> [PkgName] -> IO Control
-- |apt-cache will fail if called with no package names
runAptCache _ _ _ [] = return (Control [])
runAptCache style os@(Apt root _) 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 " ++ root)] style

{-
aptSourcesList :: AptImage -> [DebSource]
aptSourcesList (Apt _ sources) = sources
    -- DistroCache.sources distro ++ maybe [] (DistroCache.localPool distro . topDir) repo
-}

aptOpts :: AptImage -> String
aptOpts (Apt root _) =
    (" -o=Dir::State::status=" ++ root ++ "/var/lib/dpkg/status" ++
     " -o=Dir::State::Lists=" ++ root ++ "/var/lib/apt/lists" ++
     " -o=Dir::Cache::Archives=" ++ root ++ "/var/cache/apt/archives" ++
     " -o=Dir::Etc::SourceList=" ++ root ++ "/etc/apt/sources.list")

{-
aptDist :: AptImage -> String
aptDist (Apt _ sources) = DistroCache.dist distro
-}

writeFileIfMissing :: Bool -> FilePath -> String -> IO ()
writeFileIfMissing mkdirs path text =
    do
      exists <- doesFileExist path
      case exists of
        False ->
            do
              if mkdirs then
                  createDirectoryIfMissing True (parentPath path) else
                  return ()
              writeFile path text
        True ->
            return ()

parentPath :: FilePath -> FilePath
parentPath path = fst (splitFileName path)

-- |The mighty consperse function
consperse :: [a] -> [[a]] -> [a]
consperse sep items = concat (intersperse sep items)

ePut :: String -> IO ()
ePut s = hPutStrLn stderr s