-- | Install packages to and delete packages from a local repository.
{-# LANGUAGE BangPatterns, FlexibleContexts, FlexibleInstances, OverloadedStrings, PackageImports, ScopedTypeVariables, TemplateHaskell, TupleSections, UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-}
module Debian.Repo.State.Package
    ( MonadInstall
    , evalInstall
    , scanIncoming
    , installPackages
    , deleteTrumped
    , deleteBinaryOrphans
    , deleteGarbage
    , deleteSourcePackages
    -- * Install result
    , InstallResult(..)
    , resultToProblems
    , explainError
    , explainErrors
    , showErrors
    , releaseKey
    ) where

import Control.Applicative ((<$>))
import Control.Exception (SomeException)
import Control.Exception as E (ErrorCall(ErrorCall), SomeException(..), try)
import Control.Monad (filterM, foldM, when)
import Control.Monad.State (StateT, runStateT, MonadState(get, put))
import Control.Monad.Trans (liftIO, MonadIO, lift)
import qualified Data.ByteString.Lazy.Char8 as L (ByteString, fromChunks, readFile)
import Data.Digest.Pure.MD5 (md5)
import Data.Either (partitionEithers, lefts, rights)
import Data.Lens.Lazy (getL, modL)
import Data.Lens.Template (makeLenses)
import Data.List as List (filter, groupBy, intercalate, intersperse, isSuffixOf, map, partition, sortBy)
import Data.Map as Map (fromList, lookup)
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import Data.Monoid ((<>), mconcat)
import Data.Set as Set (difference, empty, fold, fromList, insert, map, member, null, Set, size, toAscList, toList, union, unions, singleton)
import Data.Text as T (pack, Text, unpack)
import qualified Data.Text as T (concat)
import Data.Text.Encoding (encodeUtf8)
import Debian.Apt.Index (Compression(..), controlFromIndex)
import Debian.Arch (Arch(..), prettyArch)
import Debian.Changes (ChangedFileSpec(..), ChangesFile(..), changesFileName)
import Debian.Control (ControlFunctions(stripWS), formatControl, formatParagraph, Paragraph')
import qualified Debian.Control.Text as B (appendFields, Control, Control'(Control), ControlFunctions(lookupP), ControlFunctions(parseControlFromHandle), Field, Field'(Field), fieldValue, modifyField, Paragraph, raiseFields, renameField)
import qualified Debian.Control.Text as S (Control'(Control), ControlFunctions(parseControlFromFile))
import Debian.Pretty (PP(..), ppPrint, ppDisplay)
import Debian.Relation (BinPkgName, PkgName)
import qualified Debian.Relation.Text as B (ParseRelations(..), Relations)
import Debian.Release (parseSection', ReleaseName, releaseName', Section(..), sectionName, sectionName', SubSection(section))
import Debian.Repo.Changes (changeName, changePath, findChangesFiles)
import Debian.Repo.EnvPath (EnvPath, outsidePath)
import Debian.Repo.Internal.Repos (MonadRepos(..), ReleaseKey, releaseByKey, putRelease)
import Debian.Repo.LocalRepository (Layout(..), LocalRepository, poolDir', repoLayout, repoReleaseInfoLocal, repoRoot)
import Debian.Repo.PackageID (makeBinaryPackageID, makeSourcePackageID, PackageID(packageName, packageVersion), prettyPackageID)
import Debian.Repo.PackageIndex (binaryIndexes, BinaryPackage(packageID, packageInfo), BinaryPackage(BinaryPackage, pConflicts, pDepends, pPreDepends, pProvides, pReplaces), PackageIndex(..), packageIndexes, packageIndexPath, SourceControl(..), SourceFileSpec(SourceFileSpec, sourceFileName), sourceIndexes, SourcePackage(sourcePackageID), SourcePackage(SourcePackage, sourceControl, sourceDirectory, sourcePackageFiles, sourceParagraph))
import Debian.Repo.Prelude (nub')
import Debian.Repo.Prelude.Files (writeAndZipFileWithBackup)
import Debian.Repo.Prelude.Misc (listDiff)
import Debian.Repo.Prelude.GPGSign (PGPKey)
import Debian.Repo.Prelude.Verbosity (ePutStrLn, qPutStr, qPutStrLn)
import Debian.Repo.Repo (Repo, repoArchList, repoKey, repoKeyURI)
import Debian.Repo.Release (Release(releaseAliases, releaseComponents, releaseName, releaseArchitectures))
import Debian.Repo.State.Release (findReleases, prepareRelease, writeRelease, signRepo)
import Debian.URI (fileFromURIStrict)
import Debian.Version (DebianVersion, parseDebianVersion, prettyDebianVersion)
import Debian.Version.Text ()
import Network.URI (URI(uriPath))
import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getDirectoryContents, removeFile, renameFile)
import System.Exit (ExitCode(..))
import System.FilePath ((</>), splitFileName)
import System.IO ()
import qualified System.Posix.Files as F (createLink, fileSize, getFileStatus)
import System.Posix.Types (FileOffset)
import System.Process (runInteractiveCommand, waitForProcess)
import Text.Regex (matchRegex, mkRegex, splitRegex)
import Text.PrettyPrint.HughesPJClass (Pretty(pPrint), text, hcat)

-- | A monad for installing or deleting a repository's packages
class MonadRepos m => MonadInstall m where
    getInstall :: m InstallState
    putInstall :: InstallState -> m ()

data InstallState
    = InstallState
      { _repository :: LocalRepository
      , _live :: Maybe (Set Text)
      -- ^ All the files that are part of this repository - debs,
      -- original tarballs, index files, etc.
      , _releases :: [Release]
      -- ^ All the releases in this repository.
      , _modified :: Set ReleaseKey
      -- ^ Releases which have been modified and need to be rewritten and signed
      }

instance MonadRepos m => MonadInstall (StateT InstallState m) where
    getInstall = get
    putInstall = put

instance MonadRepos m => MonadRepos (StateT InstallState m) where
    getRepos = lift getRepos
    putRepos = lift . putRepos

$(makeLenses [''InstallState])

runInstall :: MonadRepos m => StateT InstallState m a -> LocalRepository -> Maybe PGPKey -> m (a, InstallState)
runInstall task repo keyname = do
  releases <- findReleases repo
  (r, st) <- runStateT task (InstallState repo Nothing releases empty)
  mapM_ (\ key -> releaseByKey key >>= \ rel -> liftIO (writeRelease repo rel >>= signRepo keyname repo)) (Set.toList (getL modified st))
  return (r, st)

evalInstall :: MonadRepos m => StateT InstallState m a -> LocalRepository -> Maybe PGPKey -> m a
evalInstall task repo keyname = fst <$> runInstall task repo keyname

modifyInstall :: MonadInstall m => (InstallState -> InstallState) -> m ()
modifyInstall f = getInstall >>= putInstall . 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
    -- ^ A file in the incoming directory is shorter than its entry
    -- in the .changes file indicates - maybe it is still uploading?
    | LongFile FilePath FileOffset FileOffset
    -- ^ A file in the incoming directory is longer than its entry
    -- in the .changes file indicates.  Maybe it is left over from a
    -- previous failed upload, or a concurrent upload from somewhere
    -- else.  (That should not be permitted to happen, the .changes
    -- file should be a lock for uploads of that package/version.)
    | MissingFromIncoming FilePath
    -- ^ A file listed in the .changes file is missing from incoming.
    | MissingFromPool FilePath
    -- ^ A file listed in an index file is not in the pool
    | BadChecksum FilePath String String
    -- ^ A file which is listed in the .changes file exists in incoming
    -- and is the right length but its checksum is wrong.
    | InvalidControlInfo FilePath String
    -- ^ Badly formatted control file
    | DuplicatePackage Duplicate
    -- ^ A package in incoming has the same ID as a package already in the index
    | OtherProblem String
    deriving (Eq)

data Duplicate
    = Duplicate {release :: Release, index :: PackageIndex, newPackage :: BinaryPackage, oldPackage :: BinaryPackage} deriving (Eq, Show)

instance Show Problem where
    show (NoSuchRelease rel) = "NoSuchRelease  " ++ releaseName' rel
    show (NoSuchSection rel sect) = "NoSuchSection " ++ releaseName' rel ++ " " ++ show (List.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 (MissingFromIncoming path) = "MissingFromIncoming " ++ path
    show (MissingFromPool path) = "MissingFromPool " ++ path
    show (BadChecksum path a b) = "BadChecksum " ++ path ++ " " ++ show a ++ " " ++ show b
    show (DuplicatePackage (Duplicate rel idx old _new)) = "DuplicatePackage in " ++ show rel ++ ":" ++ show idx ++ ": " ++ show (packageID old)
    show (InvalidControlInfo path a) = "InvalidControlInfo " ++ path ++ " " ++ show a
    show (OtherProblem s) = "OtherProblem " ++ show s

releaseKey :: MonadInstall m => Release -> m ReleaseKey
releaseKey release = do
  repo <- getL repository <$> getInstall
  putRelease repo release

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 = intercalate "\n" . List.map explainError . concatMap resultToProblems

-- | Return the list of issues that provoked a result - the Ok result
-- becomes the empty list, a Failed or Rejected result becomes a
-- non-empty list.
resultToProblems :: InstallResult -> [Problem]
resultToProblems Ok = []
resultToProblems (Failed x) = x
resultToProblems (Rejected x) = x

explainErrors :: [InstallResult] -> [String]
explainErrors = List.map explainError . concatMap resultToProblems

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 ", " (List.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 (List.map (\ component -> "\n  newdist --root <root> --create-section " ++ releaseName' dist ++ "," ++ sectionName' component) components))
explainError (ShortFile path a b) =
    ("\nThe file " ++ path ++ "\n" ++
     "is shorter than it should be (expected: " ++ show a ++ ", actual: " ++ show b ++ ".)  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

plural :: String -> [a] -> String
plural "do" [_] = "does"
plural "do" _ = "do"

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

plural _ _ = ""

-- | Find all the .changes files in the incoming directory and try to
-- process each to install the package into a local repository.
scanIncoming :: (MonadInstall m, MonadRepos m) => Bool -> Maybe PGPKey -> LocalRepository -> m [(ChangesFile, InstallResult)]
scanIncoming createSections keyname repo = do
  qPutStrLn ("Uploading packages to " ++ outsidePath (repoRoot repo) </> "incoming")
  changes <- liftIO (findChangesFiles (outsidePath (repoRoot repo) </> "incoming"))
  case changes of
    [] -> qPutStrLn "Nothing to install."
    _ -> qPutStrLn ("To install:\n  " ++ (intercalate "\n  " . List.map ppDisplay $ changes))
  results <- installPackages createSections keyname repo changes
  case results of
    [] -> return ()
    _ -> qPutStrLn ("Upload results:\n  " ++ (intercalate "\n  " . List.map (uncurry showResult) $ (zip changes results)))
  return (zip changes results)
    where
      showResult changes result =
          changesFileName changes ++ ": " ++
          case result of
            Ok -> "Ok"
            Failed lst -> "Failed -\n      " ++ (intercalate "\n      " $ List.map show lst)
            Rejected lst -> "Rejected -\n      " ++ (intercalate "\n      " $ List.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 :: MonadRepos m =>
                   Bool			-- ^ ok to create new releases and sections
                -> Maybe PGPKey		-- ^ key to sign repository with
                -> LocalRepository	-- ^ destination repository
                -> [ChangesFile]	-- ^ Packages to be installed
                -> m [InstallResult]	-- ^ Outcome of each source package
installPackages createSections keyname repo changeFileList =
    evalInstall
      (do results' <- foldM (installFiles createSections) [] changeFileList
          results'' <- updateIndexes (reverse results')
          when (elem Ok results'')
               (do mapM_ (uncurry (finish (repoRoot repo) (maybe Flat id (repoLayout repo)))) (zip changeFileList results'')
                   let releaseNames = nub' (List.map changeRelease changeFileList)
                   releases' <- catMaybes <$> mapM findRelease' releaseNames
                   mapM_ (\ rel -> liftIO $ writeRelease repo rel >>= signRepo keyname repo) releases')
          return results'')
      repo
      keyname
    where
      -- 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 :: MonadInstall m => [InstallResult] -> m [InstallResult]
      updateIndexes results =
          do (pairLists :: [Either InstallResult [((Release, PackageIndex), B.Paragraph)]]) <-
                 mapM (uncurry buildInfo) (zip changeFileList results)
             let sortedByIndex = sortBy compareIndex (concat (rights pairLists))
             let groupedByIndex = undistribute (groupBy (\ a b -> compareIndex a b == EQ) sortedByIndex)
             result <- addPackagesToIndexes groupedByIndex
             case result of
               Ok -> return $ List.map (either id (const Ok)) pairLists
               problem -> return $ List.map (const problem) results
          where
            compareIndex :: ((Release, PackageIndex), B.Paragraph) -> ((Release, PackageIndex), B.Paragraph) -> Ordering
            compareIndex (a, _) (b, _) = compare a b

-- Build the control information to be added to the package indexes.
buildInfo :: MonadInstall m => ChangesFile -> InstallResult -> m (Either InstallResult [((Release, PackageIndex), B.Paragraph)])
buildInfo changes Ok =
          do mrel <- findRelease' (changeRelease changes)
             case mrel of
               Just release ->
                   do (info :: [Either InstallResult B.Paragraph]) <- mapM (fileInfo changes) indexFiles
                      case lefts info of
                        [] ->
                            let (pairs :: [(Set (Release, PackageIndex), Either InstallResult B.Paragraph)]) = zip (indexLists release) info in
                            let (pairs' :: [(Set (Release, PackageIndex), B.Paragraph)]) =
                                    catMaybes $ List.map (\ (a, b) -> either (const Nothing) (\ b' -> Just (a, b')) b) pairs in
                            let (pairs'' :: [((Release, PackageIndex), B.Paragraph)]) = concat (List.map distribute pairs') in
                            return (Right pairs'')
                        results -> return (Left (mergeResults results))
               Nothing -> return . Left . Failed $ [NoSuchRelease (changeRelease changes)]
          where
            indexLists :: Release -> [Set (Release, PackageIndex)]
            indexLists release = List.map (indexes release) indexFiles
            indexes :: Release -> ChangedFileSpec -> Set (Release, PackageIndex)
            indexes release file = Set.map (\ arch -> (release, PackageIndex (section . changedFileSection $ file) arch)) (archSet 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 = List.map (PackageIndex release (section . changedFileSection $ file)) (archList release changes 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 :: MonadInstall m => EnvPath -> Layout -> ChangesFile -> InstallResult -> m ()
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))
                      (List.map changedFileName (changeFiles changes))
             liftIO $ moveFile (outsidePath root </> "incoming" </> changeName changes) (outsidePath root </> "reject" </> changeName changes)
finish _ _ changes (Failed _) =
          do qPutStrLn $ "  Finish Failed " ++ changesFileName changes
             return ()

installChangesFile :: MonadInstall m => EnvPath -> Layout -> ChangesFile -> m ()
installChangesFile root layout changes =
          liftIO (moveFile (changePath changes) dst)
          where dst = case layout of
                        Flat -> outsidePath root </> changeName changes
                        Pool -> outsidePath root </> "installed" </> changeName changes

incoming :: MonadInstall m => m FilePath
incoming = do
  root <- repoRoot . getL repository <$> getInstall
  return $ outsidePath root </> "incoming" {- </> changedFileName file -}

reject :: MonadInstall m => ChangedFileSpec -> m FilePath
reject file = do
  root <- repoRoot . getL repository <$> getInstall
  return $ outsidePath root </> "reject" </> changedFileName file

-- | Get information about one of the (.deb or .dsc) files listed in a .changes file.
fileInfo :: MonadInstall m => ChangesFile -> ChangedFileSpec -> m (Either InstallResult B.Paragraph)
fileInfo changes file = do
  repo <- getL repository <$> getInstall
  getControl >>= addFields repo
                where
                  getControl :: MonadInstall m => m (Either InstallResult B.Paragraph)
                  getControl =
                      do -- path <- incoming file
                         dir <- incoming
                         control <-
                             case isSuffixOf ".deb" . changedFileName $ file of
                               -- Extract the control information from a .deb
                               True -> getDebControl
                               -- This is the .dsc file, parse it
                               False -> liftIO $ S.parseControlFromFile (dir </> changedFileName file) >>= return . either (Left . show) Right
                         case control of
                           -- The control file should contain one paragraph
                           Right (S.Control [info]) -> return (Right info)
                           Left message -> return . Left . Rejected $ [InvalidControlInfo (dir </> changedFileName file) message]
                           Right (S.Control _) -> return . Left . Rejected $ [InvalidControlInfo (dir </> changedFileName file) "Expected one paragraph"]
                  addFields :: MonadInstall m => LocalRepository -> (Either InstallResult B.Paragraph) -> m (Either InstallResult B.Paragraph)
                  addFields _ (Left result) = return $ Left result
                  addFields repo (Right info) =
                      case isSuffixOf ".deb" . changedFileName $ file of
                        True -> addDebFields repo changes file info
                        False -> addSourceFields repo changes file info
                  -- | Extract the control file from a binary .deb.
                  getDebControl :: MonadInstall m => m (Either String B.Control)
                  getDebControl =
                      do dir <- incoming
                         let cmd = "ar p " ++ dir </> changedFileName file ++ " 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

findRelease' :: MonadInstall m => ReleaseName -> m (Maybe Release)
findRelease' name = do
    rels <- getL releases <$> getInstall
    return $ findRelease rels name

findRelease :: [Release] -> ReleaseName -> Maybe Release
findRelease releases name =
    case filter (\ release -> elem name (releaseName release : releaseAliases release)) releases of
      [] -> Nothing
      [x] -> Just x
      _ -> error $ "Internal error 16 - multiple releases named " ++ releaseName' name

markReleaseModified :: MonadInstall m => ReleaseKey -> m ()
markReleaseModified = modifyInstall . modL modified . Set.insert

-- | 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 :: MonadInstall m => Bool -> [InstallResult] -> ChangesFile -> m [InstallResult]
installFiles createSections results changes = do
  mrel <- findOrCreateRelease (changeRelease changes)
  maybe (return (Failed [NoSuchRelease (changeRelease changes)] : results)) (installFiles' createSections changes results) mrel
    where
      findOrCreateRelease :: MonadInstall m => ReleaseName -> m (Maybe Release)
      findOrCreateRelease name = do
        rels <- getL releases <$> getInstall
        case createSections of
            False -> return (findRelease rels name)
            True -> do let release = findRelease rels name
                       repo <- (getL repository <$> getInstall)
                       case release of
                         Nothing ->
                             do newRelease <- prepareRelease repo name [] [parseSection' "main"] (repoArchList repo)
                                modifyInstall (modL releases (newRelease :))
                                return (Just newRelease)
                         Just release -> return (Just release)

installFiles' :: MonadInstall m => Bool -> ChangesFile -> [InstallResult] -> Release -> m [InstallResult]
installFiles' createSections changes results release =
                let sections = nub' . List.map (section . changedFileSection) . changeFiles $ changes in
                case (createSections, listDiff sections (releaseComponents release)) of
                  (_, []) -> installFiles'' changes results
                  (True, missing) ->
                      do qPutStrLn ("Creating missing sections: " ++ intercalate " " (List.map sectionName' missing))
                         repo <- getL repository <$> getInstall
                         release' <- prepareRelease repo (releaseName release) [] missing (releaseArchitectures release)
                         installFiles'' changes results
                  (False, missing) ->
                      return (Failed [NoSuchSection (releaseName release) missing] : results)

installFiles'' :: MonadInstall m => ChangesFile -> [InstallResult] -> m [InstallResult]
installFiles'' changes results = do
  repo <- getL repository <$> getInstall
  result <- mapM (installFile changes) (changeFiles changes) >>= return . mergeResults
  when (result == Ok) (modifyInstall (modL live (Just . Set.union (paths repo) . fromMaybe empty)))
  return $ result : results
    where
      paths repo = Set.fromList $ List.map (T.pack . ((outsidePath (repoRoot repo)) </>) . poolDir' repo changes) (changeFiles changes)

-- | Move one file into the repository
installFile :: MonadInstall m => ChangesFile -> ChangedFileSpec -> m InstallResult
installFile changes file = do
  repo <- getL repository <$> getInstall
  live' <- getL live <$> getInstall
  let root = repoRoot repo
  let dir = outsidePath root </> poolDir' repo changes file
  let src = outsidePath root </> "incoming" </> changedFileName file
  let dst = dir </> changedFileName file
  installed <- liftIO $ doesFileExist dst
  available <- liftIO $ doesFileExist src
  let indexed = maybe False (Set.member (T.pack dst)) live' -- Is the file already part of the repository?
  case (available, indexed, installed) of
    (False, _, _) -> do                        -- Perhaps this file is about to be uploaded
      return (Failed [MissingFromIncoming src])
    (True, False, False) -> do         -- This just needs to be installed
      liftIO (createDirectoryIfMissing True dir)
      liftIO (F.createLink src dst)
      return Ok
    (True, False, True) -> do          -- A garbage file is already present
      qPutStrLn ("  Replacing unlisted file: " ++ dst)
      liftIO (removeFile dst)
      liftIO (F.createLink src dst)
      return Ok
    (True, True, False) -> do
      -- The repository is damaged - the file is listed in the index
      -- but it does not exist at that location.
      return (Failed [MissingFromPool dst])
    (True, True, True) -> do           -- Further inspection is required
      installedSize <- liftIO $ F.getFileStatus dst >>= return . F.fileSize
      installedMD5sum <- liftIO $ L.readFile dst >>= return . show . md5
      let status =
              case (compare (changedFileSize file) installedSize, compare (changedFileMD5sum file) installedMD5sum) of
                -- Somehow the correct file is already installed - so be it.
                (EQ, EQ) -> Ok
                -- The wrong file of the right length is installed
                (EQ, _) -> Rejected [BadChecksum dst (changedFileMD5sum file) installedMD5sum]
                -- File may be in the process of being uploaded
                (LT, _) -> Failed [ShortFile dst (changedFileSize file) installedSize]
                -- This must be the wrong file
                (GT, _) -> Rejected [LongFile dst (changedFileSize file) installedSize]
      return status

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

distribute :: (Set a, b) -> [(a, b)]
distribute (iset, p) = List.map (\ i -> (i, p)) (toList iset)

undistribute :: [[(a, b)]] -> [(a, [b])]
-- undistribute pairss = Map.toList (Map.fromListWith (++) (map (\ (a, b) -> (a, [b])) (concat pairss)))
undistribute [] = []
undistribute ([] : tail) = undistribute tail
undistribute (((index, info) : items) : tail) =
    (index, info : List.map snd items) : undistribute tail

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


addSourceFields :: MonadInstall m => LocalRepository -> ChangesFile -> ChangedFileSpec -> B.Paragraph -> m (Either InstallResult B.Paragraph)
addSourceFields repo changes file info =
    return . Right . append . raise . modify . rename $ info
    where
      rename = B.renameField (T.pack "Source") (T.pack "Package")
      modify = B.modifyField (T.pack "Files") (\ b -> (T.pack (T.unpack b ++ "\n " ++ filesLine file))) .
               B.modifyField (T.pack "Checksums-Sha1") (\ b -> (T.pack (T.unpack b ++ "\n " ++ sha1Line file))) .
               B.modifyField (T.pack "Checksums-Sha256") (\ b -> (T.pack (T.unpack b ++ "\n " ++ sha256Line file)))
      raise = B.raiseFields (== (T.pack "Package"))
      append = B.appendFields $
               [B.Field (T.pack "Priority", T.pack (" " ++ changedFilePriority file)),
                B.Field (T.pack "Section", T.pack  (" " ++ (sectionName (changedFileSection file)))),
                B.Field (T.pack "Directory", T.pack (" " ++ poolDir' repo changes file))] ++
               maybe [] (\ s -> [B.Field (T.pack "Build-Info", " " <> s)]) (B.fieldValue "Build-Info" (changeInfo changes))
      filesLine file = changedFileMD5sum file ++ " "  ++ show (changedFileSize file) ++ " " ++ changedFileName file
      sha1Line file = changedFileSHA1sum file ++ " "  ++ show (changedFileSize file) ++ " " ++ changedFileName file
      sha256Line file = changedFileSHA256sum file ++ " "  ++ show (changedFileSize file) ++ " " ++ changedFileName file
{-
    let info' = B.renameField (T.pack "Source") (T.pack "Package") info in
    let info'' = B.modifyField (T.pack "Files") (\ b -> (T.pack (B.unpack b ++ "\n " ++ changedFileMD5sum file ++ " "  ++
                                                                 show (changedFileSize file) ++ " " ++
                                                                 changedFileName file))) info' in
    let info''' = B.raiseFields (== (T.pack "Package")) info'' in
    let newfields = [B.Field (T.pack "Priority", T.pack (" " ++ changedFilePriority file)),
                     B.Field (T.pack "Section", T.pack  (" " ++ (sectionName (changedFileSection file)))),
                     B.Field (T.pack "Directory", T.pack (" " ++ poolDir' release changes file))] ++
                    maybe [] (\ s -> [B.Field (T.pack "Build-Info", T.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 :: MonadInstall m => [((Release, PackageIndex), [B.Paragraph])] -> m InstallResult
addPackagesToIndexes pairs =
    do repo <- getL repository <$> getInstall
       oldPackageLists <- mapM (uncurry getPackages_) indexKeys
       case partitionEithers oldPackageLists of
         -- No errors
         ([], oldPackageLists') ->
             do -- if none of the new packages are already in the index, add them
                let newPackageLists = List.map (\ ((release, index), info) -> List.map (toBinaryPackage_ release index) info) pairs
                    dupes :: [Duplicate]
                    dupes = concat (List.map (\ ((rel, idx), old, new) -> findDupes rel idx old new) (zip3 indexKeys oldPackageLists' newPackageLists))
                case dupes of
                  [] -> do mapM_ (updateIndex repo) (zip3 indexKeys oldPackageLists' newPackageLists)
                           return Ok
                  dupes -> return $ Failed (List.map DuplicatePackage dupes)
         (bad, _) -> return $ Failed (List.map (OtherProblem . show) bad)
    where
      findDupes :: Release -> PackageIndex -> [BinaryPackage] -> [BinaryPackage] -> [Duplicate]
      findDupes rel idx oldList newList =
          -- Assuming here that each package in oldList has a unique packageID
          let oldMap = Map.fromList (zip (List.map packageID oldList) oldList) in
          mapMaybe (\ new -> fmap (Duplicate rel idx new) (Map.lookup (packageID new) oldMap)) newList
          -- (\ (oldList, newList) -> filter (\ new -> any (== (packageID new)) (List.map packageID oldList)) newList)
      updateIndex repo ((release, index), oldPackages, newPackages) = liftIO $ putPackages_ repo release index (oldPackages ++ newPackages)
      indexKeys = List.map fst pairs
      indexMemberFn :: [BinaryPackage] -> BinaryPackage -> Bool
      indexMemberFn packages package = any (== (packageID package)) (List.map packageID packages)

-- 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 :: MonadInstall m => m (Set Text)
findLive = do
    repo <- getL repository <$> getInstall
    case repoLayout repo of
      Nothing -> return Set.empty	-- Repository is empty
      Just layout ->
          do !releases <- findReleases repo
             !sourcePackages <- mapM releaseSourcePackages_ releases >>= return . Set.unions
             !binaryPackages <- mapM releaseBinaryPackages_ releases >>= return . Set.unions
             let sourceFiles = Set.map (T.pack (outsidePath (repoRoot repo) ++ "/") <>) . Set.map T.pack . Set.fold Set.union Set.empty . Set.map sourceFilePaths_ $ sourcePackages
             let binaryFiles = Set.map (T.pack (outsidePath (repoRoot repo) ++ "/") <>) . Set.fold (\ mt s -> maybe s (`Set.insert` s) mt) Set.empty $ Set.map (B.fieldValue "Filename" . packageInfo) binaryPackages
             let changesFiles = Set.map T.pack . Set.fold Set.union Set.empty $ Set.map (Set.fromList . changesFilePaths (repoRoot repo) layout releases) sourcePackages
             let uploadFiles = Set.map T.pack . Set.fold Set.union Set.empty . Set.map (uploadFilePaths (repoRoot repo) releases) $ sourcePackages
             return $ Set.unions [sourceFiles, binaryFiles, changesFiles, uploadFiles]
    where
      changesFilePaths root Flat releases package =
          List.map ((outsidePath root ++ "/") ++) . changesFileNames releases $ package
      changesFilePaths root Pool releases package =
          List.map ((outsidePath root ++ "/installed/") ++) . changesFileNames releases $ package
      changesFileNames releases package =
          List.map (\ arch -> intercalate "_" [ppDisplay (packageName . sourcePackageID $ package),
                                               show (prettyDebianVersion . packageVersion . sourcePackageID $ package),
                                               show (prettyArch arch)] ++ ".changes") (toList (architectures releases))
      uploadFilePaths root releases package = Set.map ((outsidePath root ++ "/") ++) . uploadFileNames releases $ package
      uploadFileNames releases package =
          Set.map (\ arch -> intercalate "_" [ppDisplay (packageName . sourcePackageID $ package),
                                              show (prettyDebianVersion . packageVersion . sourcePackageID $ package),
                                              show (prettyArch arch)] ++ ".upload") (architectures releases)
      architectures releases = unions . List.map releaseArchitectures $ releases

instance (Pretty (PP r), Repo r) => Pretty (PP (r, Release, PackageIndex)) where
    pPrint (PP (repo, r, i)) = text $
        intercalate "/" [ppDisplay repo,
                         "dist",
		         (releaseName' . releaseName $ r),
		         ppDisplay (packageIndexComponent i),
                         show (prettyArch (packageIndexArch i))]

instance Pretty (PP (Release, PackageIndex)) where
    pPrint (PP (r, i)) = text $
        intercalate "/" [(releaseName' . releaseName $ r),
		         ppDisplay (packageIndexComponent i),
                         show (prettyArch (packageIndexArch i))]

instance (Pretty (PP r), Repo r) => Pretty (PP (r, Release)) where
    pPrint (PP (repo, r)) = hcat [ppPrint repo, text " ", ppPrint r]

instance Pretty (PP Release) where
    pPrint (PP r) = text $ intercalate " " (releaseName' (releaseName r) : List.map ppDisplay (releaseComponents r))

instance Pretty (PP (Release, PackageIndex, PackageID BinPkgName)) where
    pPrint (PP (r, i, b)) = text $
        intercalate "/" [(releaseName' . releaseName $ r),
		         ppDisplay (packageIndexComponent i),
                         show (prettyArch (packageIndexArch i)),
                         ppDisplay b]

instance PkgName name => Pretty (PP (PackageID name)) where
    pPrint (PP p) = prettyPackageID p -- packageName p ++ "=" ++ show (prettyDebianVersion (packageVersion p))

instance Pretty (PP BinaryPackage) where
    pPrint (PP p) = ppPrint (packageID p)

-- |Delete any packages from a dist which are trumped by newer
-- packages.  These packages are not technically garbage because they
-- can still be installed by explicitly giving their version number to
-- apt, but it is not really a good idea to use them.
deleteTrumped :: MonadInstall m => Bool -> Maybe PGPKey -> [Release] -> m [Release]
deleteTrumped _ _ [] = error "deleteTrumped called with empty release list"
deleteTrumped dry keyname releases =
    mapM findTrumped releases >>=
    return . partitionEithers >>=
    \ (bad, good) ->
        case bad of
          [] -> return (concat good) >>=
                ifEmpty (qPutStr "deleteTrumped: nothing to delete") >>=
                deleteSourcePackages dry keyname . (List.map (\ (r, i, p) -> (r, i, packageID p)))
          _ -> error $ "Error reading package lists"
    where
      ifEmpty :: MonadIO m => m () -> [a] -> m [a]
      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 :: MonadInstall m => Release -> m (Either String [(Release, PackageIndex, BinaryPackage)])
findTrumped release =
    do
      mapM doIndex (sourceIndexes release) >>= return . merge
    where
      doIndex index = getPackages_ release index >>= return . either Left (Right . (List.map (\ b -> (release, index, b))))

-- |Delete any packages from a dist which are trumped by newer
-- packages.  These packages are not technically garbage because they
-- can still be installed by explicitly giving their version number to
-- apt, but it is not really a good idea to use them.
deleteBinaryOrphans :: MonadInstall m => Bool -> Maybe PGPKey -> [Release] -> m ()
deleteBinaryOrphans _ _ [] = error "deleteBinaryOrphans called with empty release list"
deleteBinaryOrphans dry keyname releases =
    do -- All the source packages in the repository
       ((exns1, sourcePackages) :: ([[SomeException]], [[[(Release, PackageIndex, SourcePackage)]]])) <- unzip <$> mapM (\ release -> partitionEithers <$> mapM (sourcePackagesOfIndex' release) (sourceIndexes release)) releases
       -- All the binary packages in the repository
       ((exns2, binaryPackages) :: ([[SomeException]], [[[(Release, PackageIndex, BinaryPackage)]]])) <- unzip <$> mapM (\ release -> partitionEithers <$> mapM (getPackages' release) (binaryIndexes release)) releases
       case (concat exns1, concat exns2, concat (concat sourcePackages), concat (concat binaryPackages)) of
         ([], [], sps, bps) ->
             do let bps' = Set.fromList (List.map (\ (r, i, b) -> (r, i, packageID b)) bps)
                qPutStrLn ("Number of source packages: " ++ show (length sps))
                qPutStrLn ("Number of binary packages: " ++ show (size bps'))
                let -- The binary packages which are associated with
                    -- some source package.  These need to have their
                    -- architecture set from the release architecture
                    -- list and the source package architecture
                    goodBps :: Set (Release, PackageIndex, PackageID BinPkgName)
                    goodBps =
                        Set.fromList (concatMap f sps)
                        where
                          f (r, i, p) = concatMap (g r i) (sourcePackageBinaryIDs_ p)
                          g r i p' = List.map (h r i p') (toList (releaseArchitectures r))
                          h r i p' a = (r, i {packageIndexArch = a}, p')
{-
                        Set.fromList (concatMap (\ (r, i, p) -> Set.fromList (concatMap (\ bid -> map (\ a -> (r, i {packageindexArch = a}, bid)) (releaseArchitectures r)) (sourcePackageBinaryIDs p)) in

                        Set.fromList (concatMap (\ (r, i, p) -> List.map (\ (a, p') -> (r, (i {packageIndexArch = a}), p')) (concatMap (\ a -> (a, sourcePackageBinaryIDs p)) (releaseArchitectures r))) sps)
-}
                    badBps :: Set (Release, PackageIndex, PackageID BinPkgName)
                    badBps = Set.difference bps' goodBps
                qPutStrLn ("deleteBinaryOrphans - keeping " ++ show (Set.size goodBps) ++ " packages.")
                qPutStrLn ("deleteBinaryOrphans - discarding " ++ show (Set.size badBps) ++ " packages.")
                deleteBinaryPackages dry keyname badBps
         (exns1', exns2', _, _) -> error $ "Failure(s) loading package indexes:\n " ++ intercalate "\n " (List.map show (exns1' ++ exns2'))
    where
      -- p :: (Release, PackageIndex, PackageID BinPkgName) -> Bool
      -- p (_, _, pid) = isInfixOf "fay" (unBinPkgName . packageName $ pid)
      getPackages' release index = either Left (Right . List.map (\ p -> (release, index, p))) <$> getPackages_ release index
      sourcePackagesOfIndex' release index = either Left (Right . List.map (\ p -> (release, index, p))) <$> sourcePackagesOfIndex_ release index
{-
         (Right sourcePackages', Right binaryPackages') ->
             do 
    mapM (findBinaryOrphans repo) releases >>=
    return . partitionEithers >>=
    \ (bad, good) ->
        case bad of
          [] -> return (concat good) >>=
                ifEmpty (qPutStr "deleteBinaryOrphans: nothing to delete") >>=
                deleteBinaryPackages dry keyname repo . (List.map (\ (r, i, p) -> (r, i, packageID p)))
          _ -> error $ "Error reading package lists"
    where
      ifEmpty :: IO () -> [a] -> IO [a]
      ifEmpty action [] = do action; return []
      ifEmpty _ x = return x
-}

-- | Return a list of binary packages in a release which have no
-- corresponding source package.  This never ought to happen, but due
-- to a broken newdist it did.
{-
findBinaryOrphans :: LocalRepository -> Release -> IO (Either String [(Release, PackageIndex, BinaryPackage)])
findBinaryOrphans repo release =
    mapM (doIndex (sourceIndexList release)) (binaryIndexList release) >>= return . merge
    where
      doIndex sourceIndexes binaryIndex =
          getPackages (repoKey repo) release binaryIndex >>=
          return . either Left (Right . (List.map (\ b -> (release, binaryIndex, b))))
-}

merge :: [Either SomeException [(Release, PackageIndex, BinaryPackage)]] -> Either String [(Release, PackageIndex, BinaryPackage)]
merge packages =
    case partitionEithers packages of
      ([], packages') -> Right . concat . List.map tail . List.map newestFirst . groupByName . concat $ packages'
      (bad, _) -> Left $ "Error(s) reading source indexes: " ++ intercalate ", " (List.map show bad)
    where
      groupByName :: [(Release, PackageIndex, BinaryPackage)] -> [[(Release, PackageIndex, BinaryPackage)]]
      groupByName = groupBy equalNames . sortBy compareNames
      equalNames (_, _, a') (_, _, b') = packageName (packageID a') == packageName (packageID b')
      compareNames (_, _, a') (_, _, b') = compare (packageName (packageID a')) (packageName (packageID b'))
      newestFirst = sortBy (flip compareVersions)
      compareVersions (_, _, a') (_, _, b') = compare (packageVersion (packageID a')) (packageVersion (packageID b'))

-- | 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 :: MonadInstall m => m ()
deleteGarbage = do
  layout <- (repoLayout . getL repository) <$> getInstall
  root <- (repoRoot . getL repository) <$> getInstall
  case layout of
      Just layout ->
          do
            qPutStrLn ("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
            -- ePutStr ("liveFiles:\n  " ++ intercalate "\n  " (sort liveFiles) ++ "\n")
            let deadFiles = Set.difference (Set.map T.pack (Set.fromList allFiles)) liveFiles
            qPutStrLn ("Removing:\n  " ++ intercalate "\n  " (Set.toAscList (Set.map T.unpack deadFiles)) ++ "\n")
            mapM_ (liftIO . moveToRemoved root . T.unpack) (Set.toList deadFiles)
      _ -> error "Cannot remove files from an empty repository"
    where
      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 . List.filter (isSuffixOf ".changes")
      getSubPaths path =
          do
            isDir <- doesDirectoryExist path
            case isDir of
              False -> return [path]
              True -> getDirectoryPaths path
      getDirectoryPaths dir = getDirectoryContents dir >>= return . List.filter filterDots >>= return . List.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))

-- | Delete specific source packages and their associated binary packages.
deleteSourcePackages :: MonadInstall m => Bool -> Maybe PGPKey -> [(Release, PackageIndex, PackageID BinPkgName)] -> m [Release]
deleteSourcePackages _ _ [] = return []
deleteSourcePackages dry keyname packages =
    do qPutStrLn ("deleteSourcePackages:\n " ++ intercalate "\n " (List.map (ppDisplay . (\ (_, _, x) -> x)) packages))
       releases <- (Set.fromList . repoReleaseInfoLocal . getL repository) <$> getInstall
       mapM doIndex (Set.toList (allIndexes releases))
    where
      doIndex (release, index) = getEntries release index >>= put release index . List.partition (victim release index)
      put :: MonadInstall m => Release -> PackageIndex -> ([BinaryPackage], [BinaryPackage]) -> m Release
      put release index ([], _) = do
        qPutStrLn ("deleteSourcePackages - nothing to remove from " ++ show index)
        return release
      put release index (junk, keep) = do
        qPutStrLn ("deleteSourcePackages  - Removing packages from " ++ ppDisplay (release, index) ++ ":\n  " ++ intercalate "\n " (List.map (ppDisplay . packageID) junk))
        putIndex' keyname release index keep
      allIndexes releases = Set.fold Set.union Set.empty (Set.map (\ r -> Set.fromList (List.map (r,) (packageIndexes r))) releases) -- concatMap allIndexes (Set.toList indexes)
      -- (indexes, invalid) = Set.partition (\ (_, i) -> packageIndexArch i == Source) (Set.fromList (List.map (\ (r, i, _) -> (r, i)) (repoReleaseInfoLocal repo)))
      -- (source, invalid) = Set.partition (\ (r, i, b) -> packageIndexArch i == Source) (Set.fromList packages)
      -- (indexes, invalid) = Set.partition (\ index -> packageIndexArch index == Source) (Set.fromList (List.map fst packages))
      -- allIndexes (release, sourceIndex) = packageIndexList release

      -- Compute the id of the source package this entry is from, and see if
      -- it is one of the packages we are deleting.
      victim :: Release -> PackageIndex -> BinaryPackage -> Bool
      victim release index binaryPackage = Set.member (sourceIdent (release, index, binaryPackage)) (Set.fromList packages)
      getEntries :: MonadInstall m => Release -> PackageIndex -> m [BinaryPackage]
      getEntries release index = getPackages_ release index >>= return . either (error . show) id
      putIndex' :: MonadInstall m => Maybe PGPKey -> Release -> PackageIndex -> [BinaryPackage] -> m Release
      putIndex' keyname release index entries = do
        -- markReleaseModified
        repo <- getL repository <$> getInstall
        case dry of
          True -> ePutStrLn ("dry run: not changing " ++ show index)
          False -> liftIO $ putIndex (repoRoot repo) release index entries >> writeRelease repo release >>= signRepo keyname repo
        return release
      putIndex :: EnvPath -> Release -> PackageIndex -> [BinaryPackage] -> IO (Either [String] ())
      putIndex root release index packages =
                let text = formatControl (B.Control (List.map packageInfo packages)) in
                liftIO $ writeAndZipFileWithBackup (outsidePath root </> packageIndexPath release index) (L.fromChunks [encodeUtf8 (mconcat text)])

-- | Delete specific source packages and their associated binary packages.
deleteBinaryPackages :: MonadInstall m => Bool -> Maybe PGPKey -> Set (Release, PackageIndex, PackageID BinPkgName) -> m ()
deleteBinaryPackages _ _ s | Set.null s = return ()
deleteBinaryPackages dry keyname blacklist = do
  repo <- getL repository <$> getInstall
  mapM_ doIndex (Set.toList (allIndexes repo))
    where
      doIndex (release, index) = getEntries release index >>= put release index . List.partition (victim release index)
      put :: MonadInstall m => Release -> PackageIndex -> ([BinaryPackage], [BinaryPackage]) -> m Release
      put release index ([], _) =
          qPutStrLn ("deleteBinaryPackages - nothing to remove from " ++ show index) >>
          return release
      put release index (junk, keep) =
          qPutStrLn ("deleteBinaryPackages - removing " ++ show (length junk) ++ " packages from " ++ ppDisplay (release, index) ++ ", leaving " ++ show (length keep) {- ++ ":\n " ++ intercalate "\n " (List.map (show . F.pretty . packageID) junk) -}) >>
          putIndex' keyname release index keep
      allIndexes repo = Set.fold Set.union Set.empty (Set.map (\ r -> Set.fromList (List.map (r,) (packageIndexes r))) (Set.fromList (repoReleaseInfoLocal repo)))

      -- (invalid, indexes) = Set.partition (\ (_, i) -> packageIndexArch i == Source) (Set.fromList (List.map (\ (r, i, _) -> (r, i)) (toList packages)))
      -- (source, invalid) = Set.partition (\ (r, i, b) -> packageIndexArch i == Source) (Set.fromList packages)
      -- (indexes, invalid) = Set.partition (\ index -> packageIndexArch index == Source) (Set.fromList (List.map fst packages))
      -- allIndexes (release, sourceIndex) = packageIndexList release

      -- Compute the id of the source package this entry is from, and see if
      -- it is one of the packages we are deleting.
      victim :: Release -> PackageIndex -> BinaryPackage -> Bool
      victim release index binaryPackage = Set.member (release, index, packageID binaryPackage) blacklist

      getEntries :: MonadInstall m => Release -> PackageIndex -> m [BinaryPackage]
      getEntries release index = getPackages_ release index >>= return . either (error . show) id
      putIndex' :: MonadInstall m => Maybe PGPKey -> Release -> PackageIndex -> [BinaryPackage] -> m Release
      putIndex' keyname release index entries =
          do repo <- getL repository <$> getInstall
             case dry of
               True -> ePutStrLn ("dry run: not changing " ++ show index)
               False -> liftIO $ putIndex (repoRoot repo) release index entries >> writeRelease repo release >>= signRepo keyname repo
             return release
      putIndex :: EnvPath -> Release -> PackageIndex -> [BinaryPackage] -> IO (Either [String] ())
      putIndex root release index packages =
                let text = formatControl (B.Control (List.map packageInfo packages)) in
                liftIO $ writeAndZipFileWithBackup (outsidePath root </> packageIndexPath release index) (L.fromChunks [encodeUtf8 (mconcat text)])

sourceIdent :: (Release, PackageIndex, BinaryPackage) -> (Release, PackageIndex, PackageID BinPkgName)
sourceIdent (release, index, entry) =
    case packageIndexArch index of
      Source -> (release, index, packageID entry)
      _ -> (release, (index {packageIndexArch = Source}), binaryPackageSourceID_ index entry)

{-
uriToString' :: URI -> String
uriToString' uri = uriToString id uri ""
-}

sourceFilePaths_ :: SourcePackage -> Set FilePath
sourceFilePaths_ package =
    Set.map ((sourceDirectory package) </>) . Set.map sourceFileName . Set.fromList . sourcePackageFiles $ package

toSourcePackage_ :: PackageIndex -> B.Paragraph -> SourcePackage
toSourcePackage_ index package =
    case (B.fieldValue "Directory" package,
          B.fieldValue "Files" package,
          B.fieldValue "Package" package,
          maybe Nothing (Just . parseDebianVersion . T.unpack) (B.fieldValue "Version" package)) of
      (Just directory, Just files, Just name, Just version) ->
          case (parseSourcesFileList files, parseSourceParagraph package) of
            (Right files', Right para) ->
                SourcePackage
                { sourcePackageID = makeSourcePackageID (T.unpack name) version
                , sourceParagraph = package
                , sourceControl = para
                , sourceDirectory = T.unpack directory
                , sourcePackageFiles = files' }
            (Left messages, _) -> error $ "Invalid file list: " ++ show messages
            (_, Left messages) -> error $ "Error in source paragraph\n package=" ++ show package ++ "\n  index=" ++ show index ++ "\n  messages:\n   " ++ intercalate "\n   " messages
      x -> error $ "Missing info in source package control information in " ++ show index ++ " -> " ++ show x ++ " :\n" ++ T.unpack (formatParagraph package)
    where
      -- Parse the list of files in a paragraph of a Sources index.
      parseSourcesFileList :: T.Text -> Either [String] [SourceFileSpec]
      parseSourcesFileList text =
          merge . catMaybes . List.map parseSourcesFiles . lines . T.unpack $ text
      parseSourcesFiles line =
          case words line of
            [md5sum, size, name] -> Just (Right (SourceFileSpec md5sum (read size) name))
            [] -> Nothing
            _ -> Just (Left ("Invalid line in Files list: '" ++ show line ++ "'"))
      merge x = case partition (either (const True) (const False)) x of
                  (a, []) -> Left . catMaybes . List.map (either Just (const Nothing )) $ a
                  (_, a) -> Right . catMaybes . List.map (either (const Nothing) Just) $ a

parseSourceParagraph :: B.Paragraph -> Either [String] SourceControl
parseSourceParagraph p =
    -- Look up the required fields
    case (B.fieldValue "Package" p,
          B.fieldValue "Maintainer" p) of
      (Just source', Just maintainer') ->
          -- The optional fields can be parsed as pure values
          Right (SourceControl
                  { source = source'
                  , maintainer = maintainer'
                  , uploaders = maybe [] (: []) $ B.fieldValue "Uploaders" p
                  , packageSection = fmap stripWS $ B.fieldValue "Section" p
                  , packagePriority = fmap stripWS $ B.fieldValue "Priority" p
                  , buildDepends = maybe [] (: []) $ B.fieldValue "Build-Depends" p
                  , buildDependsIndep = maybe [] (: []) $ B.fieldValue "Build-Depends-Indep" p
                  , buildConflicts = maybe [] (: []) $ B.fieldValue "Build-Conflicts" p
                  , buildConflictsIndep = maybe [] (: []) $ B.fieldValue "Build-Conflicts-Indep" p
                  , standardsVersion = fmap stripWS $ B.fieldValue "Standards-Version" p
                  , homepage = fmap stripWS $ B.fieldValue "Homepage" p })
      _x -> Left ["parseSourceParagraph - One or more required fields (Package, Maintainer, Standards-Version) missing: " ++ show p]

toBinaryPackage_ :: Release -> PackageIndex -> B.Paragraph -> BinaryPackage
toBinaryPackage_ release index p =
    case (B.fieldValue "Package" p, B.fieldValue "Version" p) of
      (Just name, Just version) ->
          BinaryPackage
          { packageID =
                makeBinaryPackageID (T.unpack name) (parseDebianVersion (T.unpack version))
          , packageInfo = p
          , pDepends = tryParseRel $ B.lookupP "Depends" p
          , pPreDepends = tryParseRel $ B.lookupP "Pre-Depends" p
          , pConflicts = tryParseRel $ B.lookupP "Conflicts" p
          , pReplaces =  tryParseRel $ B.lookupP "Replaces" p
          , pProvides =  tryParseRel $ B.lookupP "Provides" p
          }
      _ -> error ("Invalid data in source index:\n " ++ packageIndexPath release index)

tryParseRel :: Maybe B.Field -> B.Relations
tryParseRel (Just (B.Field (_, relStr))) = either (error . show) id (B.parseRelations relStr)
tryParseRel _ = []

-- | Parse the /Source/ field of a binary package's control
-- information, this may specify a version number for the source
-- package if it differs from the version number of the binary
-- package.
binaryPackageSourceID_ :: PackageIndex -> BinaryPackage -> PackageID BinPkgName
binaryPackageSourceID_ (PackageIndex _component _) package =
    case maybe Nothing (matchRegex re . T.unpack) (B.fieldValue "Source" (packageInfo package)) of
      Just [name, _, ""] -> makeBinaryPackageID name (packageVersion pid)
      Just [name, _, version] -> makeBinaryPackageID name (parseDebianVersion version)
      _ -> error "Missing Source attribute in binary package info"
    where
      -- sourceIndex = PackageIndex component Source
      pid = packageID package
      re = mkRegex "^[ ]*([^ (]*)[ ]*(\\([ ]*([^ )]*)\\))?[ ]*$"

sourcePackageBinaryIDs_ :: SourcePackage -> [PackageID BinPkgName]
sourcePackageBinaryIDs_ package =
    case (B.fieldValue "Version" info, B.fieldValue "Binary" info) of
      (Just version, Just names) -> List.map (binaryID (parseDebianVersion (T.unpack version))) $ splitRegex (mkRegex "[ ,]+") (T.unpack names)
      _ -> error ("Source package info has no 'Binary' field:\n" ++ (T.unpack . formatParagraph $ info))
    where
      -- Note that this version number may be wrong - we need to
      -- look at the Source field of the binary package info.
      binaryID version name = makeBinaryPackageID name version
      -- binaryIndex = sourceIndex { packageIndexArch = arch }
      info = sourceParagraph package

-- | Get the contents of a package index
getPackages_ :: MonadInstall m => Release -> PackageIndex -> m (Either SomeException [BinaryPackage])
getPackages_ release index = do
  repo <- getL repository <$> getInstall
  let uri = repoKeyURI . repoKey $ repo
      uri' = uri {uriPath = uriPath uri </> packageIndexPath release index}
  liftIO $ fileFromURIStrict uri' >>= readControl uri' . either (Left . SomeException) Right
    where
      readControl :: URI -> Either SomeException L.ByteString -> IO (Either SomeException [BinaryPackage])
      readControl _ (Left e) = return (Left e)
      readControl uri' (Right s) =
          try (case controlFromIndex Uncompressed (show uri') s of
                 Left e -> return $ Left (SomeException (ErrorCall (show uri' ++ ": " ++ show e)))
                 Right (B.Control control) -> return (Right $ List.map (toBinaryPackage_ release index) control)) >>=
          return . either (\ (e :: SomeException) -> Left . SomeException . ErrorCall . ((show uri' ++ ":") ++) . show $ e) id

-- | Get the contents of a package index
binaryPackagesOfIndex_ :: MonadInstall m => Release -> PackageIndex -> m (Either SomeException [BinaryPackage])
binaryPackagesOfIndex_ release index =
    case packageIndexArch index of
      Source -> return (Right [])
      _ -> getPackages_ release index -- >>= return . either Left (Right . List.map (toBinaryPackage index . packageInfo))

-- | Get the contents of a package index
sourcePackagesOfIndex_ :: MonadInstall m => Release -> PackageIndex -> m (Either SomeException [SourcePackage])
sourcePackagesOfIndex_ release index =
    case packageIndexArch index of
      Source -> getPackages_ release index >>= return . either Left (Right . List.map (toSourcePackage_ index . packageInfo))
      _ -> return (Right [])

{-
indexCacheFile :: (AptCache a) => a -> RepoKey -> Release -> PackageIndex -> FilePath
indexCacheFile apt repo release index =
    case (aptArch apt, packageIndexArch index) of
      (Binary _ _, Source) -> indexPrefix repo release index ++ "_source_Sources"
      (Binary _ _, arch@(Binary _ _)) -> indexPrefix repo release index ++ "_binary-" ++ show (prettyArch arch) ++ "_Packages"
      (x, _) -> error "Invalid build architecture: " ++ show x

indexPrefix :: RepoKey -> Release -> PackageIndex -> FilePath
indexPrefix repo release index =
    (escapeURIString (/= '@') ("/var/lib/apt/lists/" ++ uriText +?+ "dists_") ++
     releaseName' distro ++ "_" ++ (sectionName' $ section))
    where
      section = packageIndexComponent index
      uri = repoKeyURI repo
      distro = releaseName $ release
      scheme = uriScheme uri
      auth = uriAuthority uri
      path = uriPath uri
      userpass = maybe "" uriUserInfo auth
      reg = maybeOfString $ maybe "" uriRegName auth
      port = maybe "" uriPort auth
      (user, pass) = break (== ':') userpass
      user' = maybeOfString user
      pass' = maybeOfString pass
      uriText = prefix scheme user' pass' reg port path
      -- If user is given and password is not, the user name is
      -- added to the file name.  Otherwise it is not.  Really.
      prefix "http:" (Just user) Nothing (Just host) port path =
          user ++ host ++ port ++ escape path
      prefix "http:" _ _ (Just host) port path =
          host ++ port ++ escape path
      prefix "ftp:" _ _ (Just host) _ path =
          host ++ escape path
      prefix "file:" Nothing Nothing Nothing "" path =
          escape path
      prefix "ssh:" (Just user) Nothing (Just host) port path =
          user ++ host ++ port ++ escape path
      prefix "ssh" _ _ (Just host) port path =
          host ++ port ++ escape path
      prefix _ _ _ _ _ _ = error ("invalid repo URI: " ++ (uriToString' . repoKeyURI $ repo))
      maybeOfString "" = Nothing
      maybeOfString s = Just s
      escape s = intercalate "_" (wordsBy (== '/') s)
      wordsBy :: Eq a => (a -> Bool) -> [a] -> [[a]]
      wordsBy p s =
          case (break p s) of
            (s, []) -> [s]
            (h, t) -> h : wordsBy p (drop 1 t)

(+?+) :: String -> String -> String
(+?+) a ('_' : b) = a +?+ b
(+?+) "" b = b
(+?+) a b =
    case last a of
      '_' -> (init a) +?+ b
      _ -> a ++ "_" ++ b
-}

-- | Return a list of all source packages.
releaseSourcePackages_ :: MonadInstall m => Release -> m (Set SourcePackage)
releaseSourcePackages_ release =
    mapM (sourcePackagesOfIndex_ release) (sourceIndexes release) >>= return . test
    where
      test :: [Either SomeException [SourcePackage]] -> Set SourcePackage
      test xs = case partitionEithers xs of
                  ([], ok) -> Set.unions (List.map Set.fromList ok)
                  (bad, _) -> error $ intercalate ", " (List.map show bad)

-- | Return a list of all the binary packages for all supported architectures.
releaseBinaryPackages_ :: MonadInstall m => Release -> m (Set BinaryPackage)
releaseBinaryPackages_ release =
    mapM (binaryPackagesOfIndex_ release) (binaryIndexes release) >>= return . test
    where
      test xs = case partitionEithers xs of
                  ([], ok) -> Set.unions (List.map Set.fromList ok)
                  (bad, _) -> error $ intercalate ", " (List.map show bad)

-- | Write a set of packages into a package index.
putPackages_ :: LocalRepository -> Release -> PackageIndex ->  [BinaryPackage] -> IO ()
putPackages_ repo release index packages =
    writeAndZipFileWithBackup (outsidePath (repoRoot repo) </> packageIndexPath release index) (L.fromChunks [encodeUtf8 text]) >>= either (fail . intercalate "\n") return
    where
      text = T.concat (intersperse (T.pack "\n") . List.map formatParagraph . List.map packageInfo $ packages)

{-
readParagraphs :: FilePath -> IO [B.Paragraph]
readParagraphs path =
    do --IO.hPutStrLn IO.stderr ("OSImage.paragraphsFromFile " ++ path)			-- Debugging output
       h <- IO.openBinaryFile path IO.ReadMode
       B.Control paragraphs <- B.parseControlFromHandle path h >>= return . (either (error . show) id)
       IO.hClose h
       --IO.hPutStrLn IO.stderr ("OSImage.paragraphsFromFile " ++ path ++ " done.")	-- Debugging output
       return paragraphs
-}