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 Debian.Repo.AptImage 
    ( prepareAptEnv
    , updateAptEnv
    , aptGetSource
    ) where

import		 Debian.Shell
import		 Debian.Repo.Cache
import		 Debian.Repo.Changes
import		 Debian.Repo.Package
import		 Debian.Repo.IO
import		 Debian.Repo.Slice
import		 Debian.Repo.SourceTree
import		 Debian.Repo.Types
import		 Debian.Relation
import		 Debian.Version

import		 Control.Exception
import		 Control.Monad.State (get, put)
import		 Control.Monad.Trans
import		 Extra.CIO
import		 Data.List
import		 Data.Maybe
import		 Extra.Files
import		 Extra.List
import		 System.Unix.Directory
import		 System.Unix.Process
import		 System.Cmd
import		 System.Directory

instance Show AptImage where
    show apt = "AptImage " ++ relName (aptImageReleaseName apt)

instance AptCache AptImage where
    globalCacheDir = aptGlobalCacheDir
    rootDir = aptImageRoot
    aptArch = aptImageArch
    aptBaseSliceList = aptImageSliceList
    aptSourcePackages = aptImageSourcePackages
    aptBinaryPackages = aptImageBinaryPackages
    aptReleaseName = aptImageReleaseName

instance Ord AptImage where
    compare a b = compare (aptImageReleaseName a) (aptImageReleaseName b)

instance Eq AptImage where
    a == b = compare a b == EQ

prepareAptEnv :: CIO m
	      => FilePath		-- Put environment in a subdirectory of this
              -> SourcesChangedAction	-- What to do if environment already exists and sources.list is different
              -> NamedSliceList		-- The sources.list
              -> AptIOT m AptImage		-- The resulting environment
prepareAptEnv cacheDir sourcesChangedAction sources =
    get >>= return . lookupAptImage (sliceListName sources) >>=
    maybe (prepareAptEnv' cacheDir sourcesChangedAction sources) return

-- |Create a skeletal enviroment sufficient to run apt-get.
{-# NOINLINE prepareAptEnv' #-}
prepareAptEnv' :: CIO m => FilePath -> SourcesChangedAction -> NamedSliceList -> AptIOT m AptImage
prepareAptEnv' cacheDir sourcesChangedAction sources =
    do let root = rootPath (cacheRootDir cacheDir (ReleaseName (sliceName (sliceListName sources))))
       --vPutStrLn 2 $ "prepareAptEnv " ++ sliceName (sliceListName sources)
       io $ createDirectoryIfMissing True (root ++ "/var/lib/apt/lists/partial")
       io $ createDirectoryIfMissing True (root ++ "/var/lib/apt/lists/partial")
       io $ createDirectoryIfMissing True (root ++ "/var/cache/apt/archives/partial")
       io $ createDirectoryIfMissing True (root ++ "/var/lib/dpkg")
       io $ createDirectoryIfMissing True (root ++ "/etc/apt")
       io $ writeFileIfMissing True (root ++ "/var/lib/dpkg/status") ""
       io $ writeFileIfMissing True (root ++ "/var/lib/dpkg/diversions") ""
       -- We need to create the local pool before updating so the
       -- sources.list will be valid.
       let sourceListText = show (sliceList sources)
       -- ePut ("writeFile " ++ (root ++ "/etc/apt/sources.list") ++ "\n" ++ sourceListText)
       io $ replaceFile (root ++ "/etc/apt/sources.list") sourceListText
       arch <- io $ buildArchOfRoot
       let os = AptImage { aptGlobalCacheDir = cacheDir
                         , aptImageRoot = EnvRoot root
                         , aptImageArch = arch
                         , aptImageReleaseName = ReleaseName . sliceName . sliceListName $ sources
                         , aptImageSliceList = sliceList sources
                         , aptImageSourcePackages = []
                         , aptImageBinaryPackages = [] }
       os' <- updateCacheSources sourcesChangedAction os >>= updateAptEnv
       get >>= put . insertAptImage (sliceListName sources) os'
       return os'

-- |Run apt-get update and then retrieve all the packages referenced
-- by the sources.list.  The source packages are sorted so that
-- packages with the same name are together with the newest first.
{-# NOINLINE updateAptEnv #-}
updateAptEnv :: CIO m => AptImage -> AptIOT m AptImage
updateAptEnv os =
    do
      io $ system ("apt-get" ++ aptOpts os ++ " update >/dev/null 2>&1")
      -- Make the loading of the package indexes lazy.
      sourcePackages <- getSourcePackages os >>= return . sortBy cmp
      binaryPackages <- getBinaryPackages os
      return $ os { aptImageSourcePackages = sourcePackages
                  , aptImageBinaryPackages = binaryPackages }
    where
      cmp p1 p2 =
          compare v2 v1		-- Flip args to get newest first
          where
            v1 = packageVersion . sourcePackageID $ p1
            v2 = packageVersion . sourcePackageID $ p2

getSourcePackages :: CIO m => AptImage -> AptIOT m [SourcePackage]
getSourcePackages os = 
    mapM (sourcePackagesOfIndex' os) indexes >>= return . concat
    where
      indexes = concat . map (sliceIndexes os) . slices . sourceSlices . aptImageSliceList $ os

getBinaryPackages :: CIO m => AptImage -> AptIOT m [BinaryPackage]
getBinaryPackages os = 
    mapM (binaryPackagesOfIndex' os) indexes >>= return . concat
    where
      indexes = concat . map (sliceIndexes os) . slices . binarySlices . aptImageSliceList $ os

-- |Retrieve a source package via apt-get.
aptGetSource :: (AptCache t, CIO m)
             => EnvPath			-- Where to put the source
             -> t			-- Where to apt-get from
             -> PkgName			-- The name of the package
             -> Maybe DebianVersion	-- The desired version, if Nothing get newest
             -> m DebianBuildTree	-- The resulting source tree
aptGetSource dir os package version =
    do liftIO $ createDirectoryIfMissing True (outsidePath dir)
       ready <- findDebianBuildTrees dir
       let newest = listToMaybe . map (packageVersion . sourcePackageID) . filter ((== package) . packageName . sourcePackageID) . aptSourcePackages $ os
       let version' = maybe newest Just version
       case (version', ready) of
         (Nothing, _) ->
             error ("No available versions of " ++ package ++ " in " ++ rootPath (rootDir os))
         (Just requested, [tree])
             | requested == (logVersion . entry $ tree) ->
                 return tree
         (Just requested, []) ->
             do runAptGet os dir "source" [(package, Just requested)]
                trees <- findDebianBuildTrees dir
                case trees of
                  [tree] -> return tree
                  _ -> error "apt-get source failed"
         (Just requested, _) ->
             do -- One or more incorrect versions are available, remove them
                liftIO $ removeRecursiveSafely (outsidePath dir)
                vBOL 0
                vEPutStr 0 $ "Retrieving APT source for " ++ package
                runAptGet os dir "source" [(package, Just requested)]
                trees <- findDebianBuildTrees dir
                case trees of
                  [tree] -> return tree
                  _ -> error "apt-get source failed"
{-
    where
      _availableStyle = setStyle (setStart (Just ("Finding available versions of " ++ package ++ " in APT pool")))
      aptGetStyle = setStyle (setStart (Just ("Retrieving APT source for " ++ package)))
-}

runAptGet :: (AptCache t, CIO m) => t -> EnvPath -> String -> [(PkgName, Maybe DebianVersion)] -> m (Either String [Output])
runAptGet os dir command packages =
    mkdir >>= aptget
    where
      mkdir = liftIO . try . createDirectoryIfMissing True . outsidePath $ dir
      aptget (Left e) = return . Left . show $ e
      aptget (Right _) = runTaskAndTest (SimpleTask 0 cmd)          
      cmd = (consperse " " ("cd" : outsidePath dir : "&&" : "apt-get" : aptOpts os : command : map formatPackage packages))
      formatPackage (name, Nothing) = name
      formatPackage (name, Just version) = name ++ "=" ++ show version

aptOpts :: AptCache t => t -> String
aptOpts os =
    (" -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")
    where root = rootPath . rootDir $ os