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]
| Rejected [Problem]
deriving (Show, Eq)
data Problem
= NoSuchRelease ReleaseName
| NoSuchSection ReleaseName [Section]
| ShortFile FilePath FileOffset FileOffset
| LongFile FilePath FileOffset FileOffset
| MissingFile FilePath
| BadChecksum FilePath String String
| OtherProblem Exception
deriving (Eq)
instance Show Problem where
show (NoSuchRelease rel) = "NoSuchRelease " ++ releaseName' rel
show (NoSuchSection rel sect) = "NoSuchSection " ++ releaseName' rel ++ " " ++ show (map sectionName' sect)
show (ShortFile path a b) = "ShortFile " ++ path ++ " " ++ show a ++ " " ++ show b
show (LongFile path a b) = "LongFile " ++ path ++ " " ++ show a ++ " " ++ show b
show (MissingFile path) = "MissingFile " ++ path
show (BadChecksum path a b) = "BadChecksum " ++ path ++ " " ++ show a ++ " " ++ show b
show (OtherProblem s) = "OtherProblem " ++ show s
nub :: (Ord a) => [a] -> [a]
nub = map head . group . sort
mergeResults :: [InstallResult] -> InstallResult
mergeResults results =
doMerge Ok results
where
doMerge x [] = x
doMerge x (Ok : more) = doMerge x more
doMerge (Rejected p1) (Rejected p2 : more) = doMerge (Rejected (p1 ++ p2)) more
doMerge (Rejected p1) (Failed p2 : more) = doMerge (Rejected (p1 ++ p2)) more
doMerge (Failed p1) (Rejected p2 : more) = doMerge (Rejected (p1 ++ p2)) more
doMerge (Failed p1) (Failed p2 : more) = doMerge (Failed (p1 ++ p2)) more
doMerge Ok (x : more) = doMerge x more
showErrors :: [InstallResult] -> String
showErrors errors = intercalate "\n" (map explainError (concat . map resultToProblems $ errors))
resultToProblems :: InstallResult -> [Problem]
resultToProblems Ok = []
resultToProblems (Failed x) = x
resultToProblems (Rejected x) = x
isError :: InstallResult -> Bool
isError Ok = False
isError _ = True
plural "do" [_] = "does"
plural "do" _ = "do"
plural "s" [_] = ""
plural "s" _ = "s"
plural _ _ = ""
explainError :: Problem -> String
explainError (NoSuchRelease dist) =
("\nThe distribution in the .changes file (" ++ releaseName' dist ++ ") does not exist. There\n" ++
"are three common reasons this might happen:\n" ++
" (1) The value in the latest debian/changelog entry is wrong\n" ++
" (2) A new release needs to be created in the repository.\n" ++
" newdist --root <root> --create-release " ++ releaseName' dist ++ "\n" ++
" (3) A new alias needs to be created in the repository (typically 'unstable', 'testing', or 'stable'.)\n" ++
" newdist --root <root> --create-alias <existing release> " ++ releaseName' dist ++ "\n")
explainError (NoSuchSection dist components) =
("\nThe component" ++ plural "s" components ++ " " ++ intercalate ", " (map sectionName' components) ++
" in release " ++ releaseName' dist ++ " " ++
plural "do" components ++ " not exist.\n" ++
"either the 'Section' value in debian/control was wrong or the section needs to be created:" ++
concat (map (\ component -> "\n newdist --root <root> --create-section " ++ releaseName' dist ++ "," ++ sectionName' component) components))
explainError (ShortFile path _ _) =
("\nThe file " ++ path ++ "\n" ++
"is shorter than it should be. This usually\n" ++
"happens while the package is still being uploaded to the repository.")
explainError (LongFile path _ _) =
("\nThe file " ++ path ++
"\nis longer than it should be. This can happen when the --force-build\n" ++
"option is used. In this case the --flush-pool option should help.")
explainError (BadChecksum path _ _) =
("\nThe checksum of the file " ++ path ++ "\n" ++
"is different from the value in the .changes file.\n" ++
"This can happen when the --force-build option is used. In this case the\n" ++
"--flush-pool option should help. It may also mean a hardware failure.")
explainError other = show other
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)
installPackages :: CIO m
=> Bool
-> Maybe PGPKey
-> LocalRepository
-> [Release]
-> [ChangesFile]
-> AptIOT m [InstallResult]
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'
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
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
Ok -> foldr Set.insert live (map (((outsidePath 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, _, _) ->
return (Failed [MissingFile src])
(True, False, False) ->
liftIO (createDirectoryIfMissing True dir) >>
liftIO (F.createLink src dst) >>
return Ok
(True, False, True) ->
lift (vPutStrBl 1 (" Replacing unlisted file: " ++ dst)) >>
liftIO (removeFile dst) >>
liftIO (F.createLink src dst) >>
return Ok
(True, True, False) ->
return (Failed [OtherProblem $ (ErrorCall $ "Missing from repository: " ++ dst)])
(True, True, True) ->
do installedSize <- liftIO $ F.getFileStatus dst >>= return . F.fileSize
installedMD5sum <- liftIO $ Unix.md5sum dst
case () of
_ | changedFileSize file < installedSize ->
return (Failed [ShortFile dst (changedFileSize file) installedSize])
_ | changedFileSize file > installedSize ->
return (Rejected [LongFile dst (changedFileSize file) installedSize])
_ | changedFileMD5sum file /= installedMD5sum ->
return (Rejected [BadChecksum dst (changedFileMD5sum file) installedMD5sum])
_ -> return Ok
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
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)
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
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
finish root layout changes Ok =
do
mapM (liftIO . removeFile . ((outsidePath root ++ "/incoming/") ++) . changedFileName) (changeFiles changes)
installChangesFile root layout changes
finish root _ changes (Rejected _) =
do
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
doesFileExist dst >>= (flip when) (removeFile dst)
F.createLink src dst
removeFile src
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'
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)
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
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
findTrumped :: CIO m => Release -> m (Either String [PackageIDLocal])
findTrumped release =
do
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))
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
liveFiles <- findLive repo
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")
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
moveToRemoved root file =
renameFile file (outsidePath root ++ "/removed/" ++ snd (splitFileName file))
findLive :: CIO m => LocalRepository -> AptIOT m [FilePath]
findLive (LocalRepository _ Nothing _) = return []
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
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
(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) ->
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
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
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
versions = zip (map packageName packages) (map packageVersion packages)
(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)