{-# 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 --create-release " ++ releaseName' dist ++ "\n" ++ " (3) A new alias needs to be created in the repository (typically 'unstable', 'testing', or 'stable'.)\n" ++ " newdist --root --create-alias " ++ 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 --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)