{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}
-- |Insert packages into a release, remove packages from a release.
module Debian.Repo.Insert
    ( scanIncoming
    , InstallResult(..)
    , deleteTrumped
    , deleteGarbage
    , deleteSourcePackages
    , resultToProblems
    , showErrors
    , explainError
    ) where

import Control.Exception (Exception(..))
import Control.Monad
import Control.Monad.Trans
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import Data.List (group, sort, intercalate, sortBy, groupBy, isSuffixOf, partition)
import Data.Maybe (catMaybes)
import qualified Data.Set as Set
import Debian.Control
import qualified Debian.Control.ByteString as B
import qualified Debian.Control.String as S
import Debian.Repo.Changes
import Debian.Repo.IO
import qualified Debian.Repo.Package as DRP
import Debian.Repo.PackageIndex
import Debian.Repo.Release
import Debian.Repo.Repository
import Debian.Repo.Types
import Debian.Version
import Extra.GPGSign (PGPKey)
import Extra.Either (partitionEithers, rights)
import Extra.Files (writeAndZipFileWithBackup)
import Extra.Misc (listDiff)
import Extra.CIO (CIO, vPutStr, vPutStrBl)
import System.FilePath(splitFileName, (</>))
import qualified System.Unix.Misc as Unix
import System.Unix.Process
import System.Directory
import System.IO
import qualified System.Posix.Files as F
import System.Posix.Types (FileOffset)
import System.Process
import qualified Text.Format as F

data InstallResult 
    = Ok
    | Failed [Problem]		-- Package can not currently be installed
    | Rejected [Problem]	-- Package can not ever be installed
    deriving (Show, Eq)

data Problem
    = NoSuchRelease ReleaseName
    | NoSuchSection ReleaseName [Section]
    | ShortFile FilePath FileOffset FileOffset
    | LongFile FilePath FileOffset FileOffset
    | MissingFile FilePath
    | BadChecksum FilePath String String
    | OtherProblem Exception
    deriving (Eq)

instance Show Problem where
    show (NoSuchRelease rel) = "NoSuchRelease  " ++ releaseName' rel
    show (NoSuchSection rel sect) = "NoSuchSection " ++ releaseName' rel ++ " " ++ show (map sectionName' sect)
    show (ShortFile path a b) = "ShortFile " ++ path ++ " " ++ show a ++ " " ++ show b
    show (LongFile path a b) = "LongFile " ++ path ++ " " ++ show a ++ " " ++ show b
    show (MissingFile path) = "MissingFile " ++ path
    show (BadChecksum path a b) = "BadChecksum " ++ path ++ " " ++ show a ++ " " ++ show b
    show (OtherProblem s) = "OtherProblem " ++ show s

nub :: (Ord a) => [a] -> [a]
nub = map head . group . sort

mergeResults :: [InstallResult] -> InstallResult
mergeResults results =
    doMerge Ok results
    where
      doMerge x [] = x
      doMerge x (Ok : more) = doMerge x more
      doMerge (Rejected p1) (Rejected p2 : more) = doMerge (Rejected (p1 ++ p2)) more
      doMerge (Rejected p1) (Failed p2 : more) = doMerge (Rejected (p1 ++ p2)) more
      doMerge (Failed p1) (Rejected p2 : more) = doMerge (Rejected (p1 ++ p2)) more
      doMerge (Failed p1) (Failed p2 : more) = doMerge (Failed (p1 ++ p2)) more
      doMerge Ok (x : more) = doMerge x more

showErrors :: [InstallResult] -> String
showErrors errors = intercalate "\n" (map explainError (concat . map resultToProblems $ errors))

resultToProblems :: InstallResult -> [Problem]
resultToProblems Ok = []
resultToProblems (Failed x) = x
resultToProblems (Rejected x) = x

isError :: InstallResult -> Bool
isError Ok = False
isError _ = True

plural "do" [_] = "does"
plural "do" _ = "do"

plural "s" [_] = ""
plural "s" _ = "s"

plural _ _ = ""


explainError :: Problem -> String
explainError (NoSuchRelease dist) =
    ("\nThe distribution in the .changes file (" ++ releaseName' dist ++ ") does not exist.  There\n" ++
     "are three common reasons this might happen:\n" ++
     " (1) The value in the latest debian/changelog entry is wrong\n" ++
     " (2) A new release needs to be created in the repository.\n" ++
     "       newdist --root <root> --create-release " ++ releaseName' dist ++ "\n" ++
     " (3) A new alias needs to be created in the repository (typically 'unstable', 'testing', or 'stable'.)\n" ++
     "       newdist --root <root> --create-alias <existing release> " ++ releaseName' dist ++ "\n")
explainError (NoSuchSection dist components) =
    ("\nThe component" ++ plural "s" components ++ " " ++ intercalate ", " (map sectionName' components) ++
     " in release " ++ releaseName' dist ++ " " ++
     plural "do" components ++ " not exist.\n" ++
     "either the 'Section' value in debian/control was wrong or the section needs to be created:" ++
     concat (map (\ component -> "\n  newdist --root <root> --create-section " ++ releaseName' dist ++ "," ++ sectionName' component) components))
explainError (ShortFile path _ _) =
    ("\nThe file " ++ path ++ "\n" ++
     "is shorter than it should be.  This usually\n" ++
     "happens while the package is still being uploaded to the repository.")
explainError (LongFile path _ _) =
    ("\nThe file " ++ path ++
     "\nis longer than it should be.  This can happen when the --force-build\n" ++
     "option is used.  In this case the --flush-pool option should help.")
explainError (BadChecksum path _ _) =
    ("\nThe checksum of the file " ++ path ++ "\n" ++
     "is different from the value in the .changes file.\n" ++
     "This can happen when the --force-build option is used.  In this case the\n" ++
     "--flush-pool option should help.  It may also mean a hardware failure.")
explainError other = show other

-- | Find the .changes files in the incoming directory and try to 
-- process each.
scanIncoming :: CIO m => Bool -> Maybe PGPKey -> LocalRepository -> AptIOT m ([ChangesFile], [(ChangesFile, InstallResult)])
scanIncoming createSections keyname repo@(LocalRepository root _ _) =
    do releases <- findReleases repo
       changes <- liftIO (findChangesFiles (outsidePath root </> "incoming"))
       case changes of
         [] -> lift $ vPutStrBl 0 "Nothing to install."
         _ -> lift $ vPutStrBl 1 ("Changes:\n  " ++ (intercalate "\n  " . map show $ changes))
       results <- installPackages createSections keyname repo releases changes
       case results of
         [] -> return ()
         _ -> lift (vPutStrBl 0 ("Upload results:\n  " ++
                                 (intercalate "\n  " . map (uncurry showResult) $ (zip changes results))))
       let (bad, good) = partition (isError . snd) (zip changes results)
       return (map fst good, bad)
    where
      showResult changes result =
          changesFileName changes ++ ": " ++
          case result of
            Ok -> "Ok"
            Failed lst -> "Failed -\n      " ++ (intercalate "\n      " $ map show lst)
            Rejected lst -> "Rejected -\n      " ++ (intercalate "\n      " $ map show lst)

-- | Install several packages into a repository.  This means
-- 1. getting the list of files from the .changes file,
-- 2. verifying the file checksums,
-- 3. deleting any existing version and perhaps other versions which
--    were listed in the delete list,
-- 4. updating the Packages and Sources files, and
-- 5. moving the files from the incoming directory to the proper
--    place in the package pool.
installPackages :: CIO m
                => Bool				-- ^ ok to create new releases and sections
                -> Maybe PGPKey		-- ^ key to sign repository with
                -> LocalRepository		-- ^ target repository
                -> [Release]			-- ^ Releases in target repository
                -> [ChangesFile]		-- ^ Package to be installed
                -> AptIOT m [InstallResult]	-- ^ Outcome of each source package
installPackages createSections keyname repo@(LocalRepository root layout _) releases changeFileList =
    do live <- findLive repo >>= return . Set.fromList
       (_, releases', results) <- foldM (installFiles root) (live, releases, []) changeFileList
       let results' = reverse results
       results'' <- lift $ updateIndexes root releases' results'
       -- The install is done, now we will try to clean up incoming.
       case elem Ok results'' of
         False ->
             return results''
         True ->
             mapM_ (lift . uncurry (finish root (maybe Flat id layout))) (zip changeFileList results'') >>
             mapM_ (lift . signRelease keyname) (catMaybes . map (findRelease releases) . nub . sort . map changeRelease $ changeFileList) >>
             return results''
    where
      -- Hard link the files of each package into the repository pool,
      -- but don't unlink the files in incoming in case of subsequent
      -- failure.
      installFiles :: CIO m => EnvPath -> (Set.Set FilePath, [Release], [InstallResult]) -> ChangesFile -> AptIOT m (Set.Set FilePath, [Release], [InstallResult])
      installFiles root (live, releases, results) changes =
          findOrCreateRelease releases (changeRelease changes) >>=
          maybe (return (live, releases, Failed [NoSuchRelease (changeRelease changes)] : results)) installFiles'
          where
            installFiles' release =
                let sections = nub . sort . map (section . changedFileSection) . changeFiles $ changes in
                case (createSections, listDiff sections (releaseComponents release)) of
                  (_, []) -> installFiles'' release
                  (True, missing) ->
                      do lift $ vPutStrBl 0 ("Creating missing sections: " ++ intercalate " " (map sectionName' missing))
                         release' <- case releaseRepo release of
                                       LocalRepo repo -> prepareRelease repo (releaseName release) [] missing (releaseArchitectures release)
                                       x -> error $ "Expected local release: " ++ show x
                         installFiles'' release'
                  (False, missing) ->
                      return (live, releases, Failed [NoSuchSection (releaseName release) missing] : results)
            installFiles'' release' =
                do let releases' = release' : filter ((/= releaseName release') . releaseName) releases
                   result <- mapM (installFile root release') (changeFiles changes) >>= return . mergeResults
                   let live' =
                           case result of
                             -- Add the successfully installed files to the live file set
                             Ok -> foldr Set.insert live (map (((outsidePath root) </>) . poolDir' release' changes) (changeFiles changes))
                             _ -> live
                   return (live', releases', result : results)
{-
                   release' <-
                       case (createSections, listDiff sections (releaseComponents release)) of
                         (_, []) -> return release
                         (True, missing) ->
                             vPutStrBl 0 ("Creating missing sections: " ++ show missing) >>
                             prepareRelease (releaseRepo release) (releaseName release) [] missing (releaseArchitectures release)
                         (False, missing) ->
                             error $ "Missing sections: " ++ show missing
                   let releases' = release' : filter ((/= releaseName release') . releaseName) releases
                   result <- mapM (installFile root release') (changeFiles changes) >>= return . mergeResults
                   let live' =
                           case result of
                             -- Add the successfully installed files to the live file set
                             Ok -> foldr Set.insert live (map (((show root) </>) . poolDir' release changes) (changeFiles changes))
                             _ -> live
                   return (live', releases', result : results)
-}
            installFile root release file =
                do let dir = outsidePath root </> poolDir' release changes file
                   let src = outsidePath root </> "incoming" </> changedFileName file
                   let dst = dir </> changedFileName file
                   installed <- liftIO $ doesFileExist dst
                   available <- liftIO $ doesFileExist src
                   let indexed = Set.member dst live
                   case (available, indexed, installed) of
                     (False, _, _) ->			-- Perhaps this file is about to be uploaded
                         return (Failed [MissingFile src])
                     (True, False, False) ->		-- This just needs to be installed 
			 liftIO (createDirectoryIfMissing True dir) >>
                         liftIO (F.createLink src dst) >>
                         return Ok
                     (True, False, True) ->		-- A garbage file is already present
                         lift (vPutStrBl 1 ("  Replacing unlisted file: " ++ dst)) >>
			 liftIO (removeFile dst) >>
                         liftIO (F.createLink src dst) >>
                         return Ok
                     (True, True, False) ->		-- Apparantly the repository is damaged.
                         return (Failed [OtherProblem $ (ErrorCall $ "Missing from repository: " ++ dst)])
                     (True, True, True) ->		-- Further inspection is required
                         do installedSize <- liftIO $ F.getFileStatus dst >>= return . F.fileSize
                            installedMD5sum <- liftIO $ Unix.md5sum dst
                            case () of
                              _ | changedFileSize file < installedSize ->
	                            -- File may be in the process of being uploaded
                                    return (Failed [ShortFile dst (changedFileSize file) installedSize])
                              _ | changedFileSize file > installedSize ->
                                    -- We could skip this size test and just do the checksum test,
                                    -- but a file that is too long indicates a different type of
                                    -- failure than a file with a checksum mismatch.
                                    return (Rejected [LongFile dst (changedFileSize file) installedSize])
                              _ | changedFileMD5sum file /= installedMD5sum ->
                                    return (Rejected [BadChecksum dst (changedFileMD5sum file) installedMD5sum])
                              _ -> return Ok	-- The correct file is already installed - so be it.
          
      -- Update all the index files affected by the successful
      -- installs.  This is a time consuming operation, so we want to
      -- do this all at once, rather than one package at a time
      updateIndexes :: CIO m => EnvPath -> [Release] -> [InstallResult] -> m [InstallResult]
      updateIndexes root releases results =
          do vPutStrBl 1 "updateIndexes"
             (pairLists :: [Either InstallResult [(PackageIndexLocal, B.Paragraph)]]) <-
                 mapM (uncurry $ buildInfo root releases) (zip changeFileList results)
             let sortedByIndex = sortBy compareIndex (concat (keepRight pairLists))
             let groupedByIndex = undistribute (groupBy (\ a b -> compareIndex a b == EQ) sortedByIndex)
             result <- addPackagesToIndexes groupedByIndex
             case result of
               Ok -> return $ map (either id (const Ok)) pairLists
               problem -> return $ map (const problem) results 
          where
            compareIndex :: (PackageIndexLocal, B.Paragraph) -> (PackageIndexLocal, B.Paragraph) -> Ordering
            compareIndex (a, _) (b, _) = compare a b
      -- Build the control information to be added to the package indexes.
      buildInfo :: CIO m => EnvPath -> [Release] -> ChangesFile -> InstallResult -> m (Either InstallResult [(PackageIndexLocal, B.Paragraph)])
      buildInfo root releases changes Ok =
          do vPutStrBl 1 $ "  buildInfo " ++ changesFileName changes
             case findRelease releases (changeRelease changes) of
               Just release ->
                   do (info :: [Either InstallResult B.Paragraph]) <- mapM (fileInfo root release) indexFiles
                      case keepLeft info of
                        [] ->
                            let (pairs :: [([PackageIndexLocal], Either InstallResult B.Paragraph)]) = zip (indexLists release) info in
                            let (pairs' :: [([PackageIndexLocal], B.Paragraph)]) =
                                    catMaybes $ map (\ (a, b) -> either (const Nothing) (\ b' -> Just (a, b')) b) pairs in
                            let (pairs'' :: [(PackageIndexLocal, B.Paragraph)]) = concat (map distribute pairs') in
                            return (Right pairs'')
                        results -> return (Left (mergeResults results))
               Nothing -> return . Left . Failed $ [NoSuchRelease (changeRelease changes)]
          where
            indexLists :: Release -> [[PackageIndexLocal]]
            indexLists release = map (indexes release) indexFiles
            indexes :: Release  -> ChangedFileSpec -> [PackageIndexLocal]
            indexes release file = map (PackageIndex release (section . changedFileSection $ file)) (archList release changes file)
            indexFiles = dsc ++ debs
            (debs :: [ChangedFileSpec]) = filter f files
                where (f :: ChangedFileSpec -> Bool) = (isSuffixOf ".deb" . changedFileName)
                      (files :: [ChangedFileSpec]) = (changeFiles changes)
            dsc = filter (isSuffixOf ".dsc" . changedFileName) (changeFiles changes)
            -- (debs, nonDebs) = partition (isSuffixOf ".deb" . changedFileName) (changeFiles changes)
            -- (indepDebs, archDebs) = partition (isSuffixOf "_all.deb" . changedFileName) debs
            -- (dsc, other) = partition (isSuffixOf ".dsc" . changedFileName) nonDebs
            --fileIndex release file = map (PackageIndex release (section . changedFileSection $ file)) (archList release changes file)
            fileInfo :: CIO m => EnvPath -> Release -> ChangedFileSpec -> m (Either InstallResult B.Paragraph)
            fileInfo root release file =
                getControl >>= return . addFields
                where
                  getControl :: CIO m => m (Either InstallResult B.Paragraph)
                  getControl =
                      do control <-
                             case isSuffixOf ".deb" . changedFileName $ file of
                               True -> getDebControl path
                               False -> liftIO $ S.parseControlFromFile path >>= return . either (Left . show) Right
                         case control of
                           Left message -> return . Left . Rejected $ [OtherProblem (ErrorCall message)]
                           Right (S.Control [info]) -> return (Right info)
                           Right (S.Control _) -> return . Left . Rejected $ [OtherProblem (ErrorCall "Invalid control file")]
                  addFields :: (Either InstallResult B.Paragraph) -> (Either InstallResult B.Paragraph)
                  addFields (Left result) = Left result
                  addFields (Right info) =
                      case isSuffixOf ".deb" . changedFileName $ file of
                        True -> addDebFields release changes file info
                        False -> addSourceFields release changes file info
                  -- | Extract the control file from a binary .deb.
                  getDebControl :: CIO m => FilePath -> m (Either String B.Control)
                  getDebControl path =
                      do let cmd = "ar p " ++ path ++ " control.tar.gz | tar xzO ./control"
                         (_, outh, _, handle) <- liftIO $ runInteractiveCommand cmd
                         control <- liftIO $ B.parseControlFromHandle cmd outh >>= return . either (Left . show) Right
                         exitcode <- liftIO $ waitForProcess handle
                         case exitcode of
                           ExitSuccess -> return control
                           ExitFailure n -> return . Left $ "Failure: " ++ cmd ++ " -> " ++ show n
                  path = outsidePath root ++ "/incoming/" ++ changedFileName file
      buildInfo _ _ _ notOk = return . Left $ notOk
      -- For a successful install this unlinks the files from INCOMING and
      -- moves the .changes file into INSTALLED.  For a failure it moves
      -- all the files to REJECT.
      finish root layout changes Ok =
          do --vPutStrBl 1 stderr $ "  finish Ok " ++ changesFileName changes
             mapM (liftIO . removeFile . ((outsidePath root ++ "/incoming/") ++) . changedFileName) (changeFiles changes)
             installChangesFile root layout changes
      finish root _ changes (Rejected _) =
          do --vPutStrBl 1 stderr $ "  finish Rejected " ++ changesFileName changes
             mapM (\ name -> liftIO (moveFile (outsidePath root ++ "/incoming/" ++ name) (outsidePath root ++ "/reject/" ++ name)))
                      (map changedFileName (changeFiles changes))
             liftIO (moveFile (outsidePath root ++ "/incoming/" ++ Debian.Repo.Changes.name changes)
                                (outsidePath root ++ "/reject/" ++ Debian.Repo.Changes.name changes))
      finish _ _ changes (Failed _) =
          do vPutStrBl 1 $ "  Finish Failed " ++ changesFileName changes
             return ()
      installChangesFile :: CIO m => EnvPath -> Layout -> ChangesFile -> m ()
      installChangesFile root layout changes =
          liftIO (moveFile (Debian.Repo.Changes.path changes) dst)
          where dst = case layout of
                        Flat -> outsidePath root </> Debian.Repo.Changes.name changes
                        Pool -> outsidePath root ++ "/installed/" ++ Debian.Repo.Changes.name changes
      findOrCreateRelease :: CIO m => [Release] -> ReleaseName -> AptIOT m (Maybe Release)
      findOrCreateRelease releases name =
          case createSections of
            False -> return (findRelease releases name)
            True -> do let release = findRelease releases name
                       case release of
                         Nothing ->
                             do newRelease <- prepareRelease repo name [] [parseSection' "main"] (repoArchList repo)
                                return (Just newRelease)
                         Just release -> return (Just release)
      findRelease :: [Release] -> ReleaseName -> Maybe Release
      findRelease releases name = 
          case filter (\ release -> elem name (releaseName release : releaseInfoAliases (releaseInfo release))) releases of
            [] -> Nothing
            [x] -> Just x
            _ -> error $ "Internal error 16 - multiple releases named " ++ releaseName' name

archList :: Release -> ChangesFile -> ChangedFileSpec -> [Arch]
archList release changes file =
    case () of
      _ | isSuffixOf "_all.deb" name -> releaseArchitectures release
      _ | isSuffixOf ".deb" name -> [changeArch changes]
      _ | isSuffixOf ".udeb" name -> []
      _ -> [Source]
    where name = changedFileName file

distribute :: ([a], b) -> [(a, b)]
distribute (ilist, p) = map (\ i -> (i, p)) ilist

undistribute :: [[(a, b)]] -> [(a, [b])]
undistribute [] = []
undistribute ([] : tail) = undistribute tail
undistribute (((index, info) : items) : tail) =
    (index, info : map snd items) : undistribute tail

keepRight :: [Either a b] -> [b]
keepRight xs = catMaybes $ map (either (const Nothing) Just) xs

keepLeft :: [Either a b] -> [a]
keepLeft xs = catMaybes $ map (either Just (const Nothing)) xs

addDebFields :: Release -> ChangesFile -> ChangedFileSpec -> B.Paragraph -> (Either InstallResult B.Paragraph)
addDebFields release changes file info =
    let (binaryVersion :: DebianVersion) =
            maybe (error $ "Missing 'Version' field") (parseDebianVersion . B.unpack) (B.fieldValue "Version" info) in
    let (newfields :: [B.Field]) =
            [B.Field (B.pack "Source", B.pack (" " ++ source ++ versionSuffix binaryVersion)),
             B.Field (B.pack "Filename", B.pack (" " ++ poolDir' release changes file </> changedFileName file)),
             B.Field (B.pack "Size", B.pack (" " ++ show (changedFileSize file))),
             B.Field (B.pack "MD5sum", B.pack (" " ++ changedFileMD5sum file))] in
    Right $ B.appendFields newfields info
    where
      versionSuffix :: DebianVersion -> String
      versionSuffix binaryVersion = if binaryVersion /= sourceVersion then " (" ++ show sourceVersion ++ ")" else ""
      source = maybe (error "Missing 'Source' field in .changes file") id (B.fieldValue "Source" (changeInfo changes))
      sourceVersion = changeVersion changes


addSourceFields :: Release -> ChangesFile -> ChangedFileSpec -> B.Paragraph -> (Either InstallResult B.Paragraph)
addSourceFields release changes file info =
    let info' = B.renameField (B.pack "Source") (B.pack "Package") info in
    let info'' = B.modifyField (B.pack "Files") (\ b -> (B.pack (B.unpack b ++ "\n " ++ changedFileMD5sum file ++ " "  ++ 
                                                                 show (changedFileSize file) ++ " " ++
                                                                 changedFileName file))) info' in
    let info''' = B.raiseFields (== (B.pack "Package")) info'' in
    let newfields = [B.Field (B.pack "Priority", B.pack (" " ++ changedFilePriority file)),
                     B.Field (B.pack "Section", B.pack  (" " ++ (sectionName (changedFileSection file)))),
                     B.Field (B.pack "Directory", B.pack (" " ++ poolDir' release changes file))] ++
                    maybe [] (\ s -> [B.Field (B.pack "Build-Info", B.pack (" " ++ s))])
                              (B.fieldValue "Build-Info" (changeInfo changes)) in
    Right $ B.appendFields newfields info'''    

moveFile :: FilePath -> FilePath -> IO ()
moveFile src dst =
    do --vPutStrBl 1 stderr ("moveFile " ++ src ++ " " ++ dst)
       doesFileExist dst >>= (flip when) (removeFile dst)
       F.createLink src dst
       removeFile src

-- |Add control information to several package indexes, making sure
-- that that no duplicate package ids are inserted.
addPackagesToIndexes :: CIO m => [(PackageIndexLocal, [B.Paragraph])] -> m InstallResult
addPackagesToIndexes pairs =
    do oldPackageLists <- mapM DRP.getPackages (map fst pairs)
       case partitionEithers oldPackageLists of
         ([], _) -> 
             do let (oldPackageLists' :: [[BinaryPackageLocal]]) = rights oldPackageLists
                let (indexMemberFns :: [BinaryPackageLocal -> Bool]) = map indexMemberFn oldPackageLists'
                -- if none of the new packages are already in the index, add them
                case concat (map (uncurry filter) (zip indexMemberFns newPackageLists)) of
                  [] -> do mapM (liftIO . updateIndex) (zip3 indexes oldPackageLists' newPackageLists)
                           return Ok
                  dupes -> return $ Failed [OtherProblem (ErrorCall ("Duplicate packages: " ++ intercalate " " (map show dupes)))]
         (bad, _) -> return $ Failed (map OtherProblem bad)
{-
    do (oldPackageLists :: [[BinaryPackageLocal]]) <- mapM getPackages (map fst pairs) >>= return . rights
       -- package membership predicates
       let (indexMemberFns :: [BinaryPackageLocal -> Bool]) = map indexMemberFn oldPackageLists
       -- if none of the new packages are already in the index, add them
       case concat (map (uncurry filter) (zip indexMemberFns newPackageLists)) of
         [] -> do mapM (liftIO . updateIndex) (zip3 indexes oldPackageLists newPackageLists)
                  return Ok
         dupes -> return $ Failed [OtherProblem ("Duplicate packages: " ++ (intercalate " " (map show dupes)))]
-}
    where
      updateIndex (index, oldPackages, newPackages) = DRP.putPackages index (oldPackages ++ newPackages)
      indexes = map fst pairs
      indexMemberFn :: [BinaryPackageLocal] -> BinaryPackageLocal -> Bool
      indexMemberFn packages =
          let set = Set.fromList . map packageID $ packages
          in
            \package -> Set.member (packageID package) set
      newPackageLists = map (\ (index, info) -> map (DRP.toBinaryPackage index) info) pairs

-- | Delete any packages from a dist which are trumped by newer
-- packages.  These packages are not garbage because they can still be
-- installed by explicitly giving their version number to apt.
deleteTrumped :: CIO m => Maybe PGPKey -> [Release] -> m [Release]
deleteTrumped _ [] = error "deleteTrumped called with empty release list"
deleteTrumped keyname releases =
    case nub . map releaseRepo $ releases of
      [_] ->
          mapM findTrumped releases >>=
          return . partitionEithers >>=
          \ (bad, good) -> 
              case bad of 
                [] -> return (concat good) >>=
                      ifEmpty (vPutStr 0 "deleteTrumped: nothing to delete") >>=
                      deleteSourcePackages keyname
                _ -> error $ "Error reading package lists"
      [] -> error "internal error"
      repos -> error ("Multiple repositories passed to deleteTrumped:\n  " ++
                      (intercalate "\n  " $ map show repos) ++ "\n")
    where
      ifEmpty action [] = do action; return []
      ifEmpty _ x = return x

-- | Return a list of packages in a release which are trumped by some
-- newer version.
findTrumped :: CIO m => Release -> m (Either String [PackageIDLocal])
findTrumped release =
    do
      --ePutStr ("findTrumped " ++ show release)
      packages <- mapM DRP.getPackages (sourceIndexList release)
      case partitionEithers packages of
        ([], packages') ->
            do let groups = map newestFirst . groupByName . map packageID . concat $ packages'
               mapM_ (vPutStrBl 0) (catMaybes . map formatGroup $ groups)
               return . Right . concat . map tail $ groups
        (bad, _) -> return (Left $ "Error reading source indexes: " ++ intercalate ", " (map show bad))
    where
      groupByName = groupBy equalNames . sortBy compareNames
      equalNames a b = packageName a == packageName b
      compareNames a b = compare (packageName a) (packageName b)
      newestFirst = sortBy (flip compareVersions)
      compareVersions a b = compare (packageVersion a) (packageVersion b)
      formatGroup [] = Nothing
      formatGroup [_] = Nothing
      formatGroup (newest : other) =
          Just ("Trumped by " ++ F.format newest ++ " in " ++ F.format (packageIndex newest) ++ ":\n " ++
                intercalate "\n " (map F.format other))

-- | Collect files that no longer appear in any package index and move
-- them to the removed directory.  The .changes files are treated
-- specially: they don't appear in any index files, but the package
-- they belong to can be constructed from their name.
deleteGarbage :: CIO m => LocalRepository -> AptIOT m LocalRepository
deleteGarbage repo =
    case repoLayout repo of
      Just layout ->
          do
            lift (vPutStrBl 0 ("deleteGarbage in " ++ outsidePath root ++ " (layout=" ++ show layout ++ ")"))
            allFiles1 <- liftIO $ poolFiles root layout
            allFiles2 <- liftIO $ changesFileList root layout
            let allFiles = allFiles1 ++ allFiles2
            -- ePutStr ("allFiles:\n  " ++ intercalate "\n  " (sort allFiles) ++ "\n")
            liveFiles <- findLive repo
            -- ePutStr ("liveFiles:\n  " ++ intercalate "\n  " (sort liveFiles) ++ "\n")
            let deadFiles = Set.toList (Set.difference (Set.fromList allFiles) (Set.fromList liveFiles))
            lift (vPutStrBl 0 ("Removing:\n  " ++ intercalate "\n  " (sort deadFiles) ++ "\n"))
            mapM_ (liftIO . moveToRemoved root) deadFiles
            return repo
      _ -> error "Cannot remove files from an empty repository"
    where
      root = repoRoot repo
      poolFiles root Flat = getDirectoryContents (outsidePath root) >>=
                            filterM (doesFileExist . ((outsidePath root ++ "/") ++))
      poolFiles root Pool = 
          getSubPaths (outsidePath root ++ "/pool") >>=
          mapM getSubPaths >>= return . concat >>=
          mapM getSubPaths >>= return . concat >>=
          mapM getSubPaths >>= return . concat
      changesFileList root Pool = getDirectoryPaths (outsidePath root ++ "/installed")
      -- In this case we already got the .changes files from the top directory
      changesFileList root Flat = getDirectoryPaths (outsidePath root) >>= return . filter (isSuffixOf ".changes")
      getSubPaths path = 
          do
            isDir <- doesDirectoryExist path
            case isDir of
              False -> return [path]
              True -> getDirectoryPaths path
      getDirectoryPaths dir = getDirectoryContents dir >>= return . filter filterDots >>= return . map ((dir ++ "/") ++)
      filterDots "." = False
      filterDots ".." = False
      filterDots _ = True
      -- upload files only appear when we dupload from a flat repository to another.
      moveToRemoved root file =
          renameFile file (outsidePath root ++ "/removed/" ++ snd (splitFileName file))

-- Repository Accessors and Inquiries

-- | Return a list of all the files in a release which are
-- 'live', in the sense that they appear in some index files.
findLive :: CIO m => LocalRepository -> AptIOT m [FilePath]
findLive (LocalRepository _ Nothing _) = return []	-- Repository is empty
findLive repo@(LocalRepository root (Just layout) _) =
    do releases <- findReleases repo
       sourcePackages <- mapM (lift . DRP.releaseSourcePackages) releases >>= return . map (either (error . show) id) >>= return . concat
       binaryPackages <- mapM (lift . DRP.releaseBinaryPackages) releases >>= return . map (either (error . show) id) >>= return . concat
       let sourceFiles = map ((outsidePath root ++ "/") ++) . concat . map DRP.sourceFilePaths $ sourcePackages
       let binaryFiles =
               map ((outsidePath root ++ "/") ++) . map B.unpack . catMaybes $ map (B.fieldValue "Filename" . packageInfo) binaryPackages
       let changesFiles = concat . map (changesFilePaths root layout releases) $ sourcePackages
       let uploadFiles = concat . map (uploadFilePaths root releases) $ sourcePackages
       return $ sourceFiles ++ binaryFiles ++ changesFiles ++ uploadFiles
    where
      changesFilePaths root Flat releases package =
          map ((outsidePath root ++ "/") ++) . changesFileNames releases $ package
      changesFilePaths root Pool releases package =
          map ((outsidePath root ++ "/installed/") ++) . changesFileNames releases $ package
      changesFileNames releases package = 
          map (\ arch -> intercalate "_" [packageName . sourcePackageID $ package,
                                          show . packageVersion . sourcePackageID $ package,
                                          archName arch] ++ ".changes") (nub (concat (architectures releases)))
      uploadFilePaths root releases package = map ((outsidePath root ++ "/") ++) . uploadFileNames releases $ package
      uploadFileNames releases package =
          map (\ arch -> intercalate "_" [packageName . sourcePackageID $ package,
                                          show . packageVersion . sourcePackageID $ package,
                                          archName arch] ++ ".upload") (nub (concat (architectures releases)))
      architectures releases = map head . group . sort . map releaseArchitectures $ releases

-- | Although the PackageID type could refer to source or binary
-- packages, we only export the function to remove source packages.
-- This is in order to avoid leaving around references to removed
-- binary packages in the source index.
deleteSourcePackages :: CIO m => Maybe PGPKey -> [PackageIDLocal] -> m [Release]
deleteSourcePackages keyname packages =
    mapM (deleteSourcePackagesFromIndex keyname) (map indexPair indexGroups)
    where
      indexGroups = group (sortBy compareIndex packages)
      compareIndex a b = compare (packageIndex a) (packageIndex b)
      indexPair group@(package : _) = (packageIndex package, group)
      indexPair [] = error "internal error"

deleteSourcePackagesFromIndex :: CIO m => Maybe PGPKey -> (PackageIndexLocal, [PackageIDLocal]) -> m Release
deleteSourcePackagesFromIndex keyname (index, packages) =
    case (packageIndexArch index, packageIndexRelease index) of
      (_, release@(Release {releaseRepo = LocalRepo repo})) ->
          do -- ePutStr (" Repository.deleteSourcePackageFromIndex (" ++ show packages ++ ")")
             (remove, keep) <- DRP.getPackages index >>= return . either (error . show) id >>= return . partition (testSource . packageID)
             case (remove, keep) of
               ([], _) ->
                   do vPutStrBl 0 ("Packages not found:\n " ++ intercalate "\n " (map F.format packages))
                      vPutStrBl 2 ("Available in " ++ F.format index ++ ":\n " ++ intercalate "\n " (map F.format keep))
                      return release
               (remove, keep) ->
                   -- We found one or more source packages to remove
                   do vPutStrBl 0 ("Removing source packages from " ++ F.format index ++ ": " ++ intercalate " " (map (F.format . packageID) remove))
                      mapM_ (deleteBinaryPackages root) binaryIndexes
                      putIndex root index keep
                      signRelease keyname release
                      return release
          where
            --release = packageIndexRelease index
            --repo = releaseRepo release
            root = repoRoot repo
            binaryIndexes = filter (\ index -> packageIndexArch index /= Source) (packageIndexList release)
            deleteBinaryPackages root binaryIndex =
                do binaryPackages <- DRP.getPackages binaryIndex >>= return . either (error . show) id
                   case partition testBinary binaryPackages of
                     ([], _) -> return $ Right ()
                     (remove, keep) -> 
                         do vPutStrBl 0 ("Removing binary packages from " ++ F.format binaryIndex ++ ": " ++ intercalate " " (map (F.format . packageID) remove))
                            putIndex root binaryIndex keep
            -- Is this one of the source packages we are looking for?
            testSource package = elem ((packageName package), (packageVersion package)) versions
            testBinary = testSource . DRP.binaryPackageSourceID
            putIndex :: CIO m => EnvPath -> PackageIndexLocal -> [BinaryPackageLocal] -> m (Either [String] ())
            putIndex root index packages =
                let text = L.fromChunks (formatControl (B.Control (map packageInfo packages))) in
                liftIO $ writeAndZipFileWithBackup (outsidePath root </> packageIndexPath index) text
            -- This is not correct - we need to get the correct version numbers from the binary index file
            -- binaryPackages = map (PackageID (PackageIndex release component arch)) versions
            versions = zip (map packageName packages) (map packageVersion packages)
            --archList = releaseArchitectures release
            --component = packageIndexComponent index
      (Binary _, _) -> error $ "Not a source index: " ++ show index
      (_, release) -> error $ "Not a local release: " ++ show release

instance F.Format PackageID where
    format p = packageName p ++ "=" ++ show (packageVersion p)

instance F.Format PackageIndex where
    format i = 
        intercalate "/" [F.format (releaseRepo . packageIndexRelease $ i),
                         "dist",
		         (releaseName' . releaseInfoName . releaseInfo . packageIndexRelease $ i),
		         F.format (packageIndexComponent i),
                         F.format (packageIndexArch i)]

instance F.Format Release where
    format r = F.format (releaseRepo r) ++ " " ++ F.format (releaseInfo r)

instance F.Format Repository where
    format (LocalRepo r) = outsidePath (repoRoot r)
    format (VerifiedRepo s _) = s
    format (UnverifiedRepo s) = s

instance F.Format ReleaseInfo where
    format r = intercalate " " (releaseName' (releaseInfoName r) : map F.format (releaseInfoComponents r))

instance F.Format Section where
    format (Section s) = s

instance F.Format Arch where
    format x@(Binary _) = "binary-" ++ archName x
    format x = archName x

instance F.Format BinaryPackage where
    format p = F.format (packageID p)