debian-1.0: Linspire/Debian/Repository.hs
-- |A repository is a the directory heirarchy that is used by the apt
-- packages to retrieve packages. It is set of source packages. It
-- also implies the set of binary packages which were produced along
-- with the source packages. It could also be derived from the deb
-- and deb-src lines contained in a sources.list file, or from the
-- path to a sources.list file.
--
-- Author: David Fox <david.fox@linspire.com>
module Linspire.Debian.Repository
(Repository(Repo),
fromPath, -- FilePath -> Repository
topDir, -- Repository -> FilePath
prepare, -- [Style] -> Bool -> Bool -> FilePath -> IO Repository
-- update, -- [Style] -> Bool -> Repository -> IO Repository
flush, -- Repository -> IO Repository
findLive, -- Repository -> IO [FilePath]
uploadLocal, -- [Style] -> Repository -> FilePath -> IO Repository
uploadAll, -- [Style] -> Bool -> Repository -> Maybe String -> IO Repository
Layout(Pool, Flat),
layout, -- Repository -> IO Layout,
PackageID, -- (Name, Dist, Arch, Version)
Arch(Arch),
parsePackage, -- String -> PackageID
createSkeleton, -- Bool -> FilePath -> Layout -> IO Repository
createDists, -- [String] -> Repository -> IO Repository
scanIncoming, -- [Style] -> Bool -> Repository -> IO [Bool]
removePackage, -- Bool -> Repository -> PackageID -> IO Repository
removeTrumped, -- [Style] -> Bool -> Repository -> IO Repository
removeGarbage, -- [Style] -> Bool -> Repository -> IO Repository
parseChangesFilename, -- String -> (String, String, String, String)
bool) -- bool :: a -> a -> Bool -> a
where
import Control.Exception
import Control.Monad
import Data.List
import Data.Maybe
import qualified Data.Set as Set
import System.Cmd
import System.Directory
import System.Exit
import System.IO
import qualified System.Posix.Files as Posix.Files
import System.Process
import Text.ParserCombinators.Parsec.Error
import Text.Regex
import Linspire.Unix.FilePath
import Linspire.Debian.Control
import Linspire.Debian.Version
import qualified Linspire.Unix.Directory as Unix
import qualified Linspire.Unix.Misc as Unix
import Linspire.Unix.Progress as Progress
data Repository =
Repo
FilePath -- the location of the repository files
Layout -- Flat or Pool, how the repository is laid out
Bool -- Is the repository in a consistent state?
fromPath :: FilePath -> Layout -> Repository
fromPath dir layout = Repo dir layout False
topDir :: Repository -> FilePath
topDir (Repo dir _ _) = dir
prepare :: [Style] -> Bool -> Bool -> FilePath -> Layout -> [String] -> IO Repository
prepare _ dryRun reset dir layout dists = do
repo <- createSkeleton dryRun dir layout >>= createDists dryRun dists
if reset then flush dryRun repo else return repo
flush :: Bool -> Repository -> IO Repository
flush dryRun repo@(Repo dir layout _) =
do
dists <- getDists repo
Unix.removeRecursiveSafely dir -?- (dryRun, "")
createSkeleton dryRun dir layout >>= createDists dryRun dists
-- |Update a repository. This means making sure the Sources.gz and
-- Packages.gz files are up-to-date with respect to the packages in
-- the pool. This only makes sense for a repository where we assume
-- that all the packages are supposed to be in a single dist, i.e. the
-- local repository used to hold the results of the autobuilder.
{-
update :: [Style] -> Bool -> Repository -> IO Repository
update style True repo = flush repo >>= update style False
update _ False repo@(Repo _ _ True) = return repo
update style False (Repo _ Pool False) = error "Unimplemented: update for Pool layout"
update style False (Repo dir Flat False) =
do
-- FIXME: We should see what architectures are present and create
-- a directory for each. Unfortunately, apt-get update fails if
-- the Packages file for its architecture doesn't exist. Maybe we
-- need to change the sources.list when packages show up in the
-- local pool?
createDirectoryIfMissing True (dir ++ "/dists/source")
createDirectoryIfMissing True (dir ++ "/dists/binary-i386")
let scanCmd = ("cd " ++ dir ++ " && " ++
"dpkg-scanpackages dists /dev/null | gzip > dists/binary-i386/Packages.gz && " ++
"dpkg-scansources dists /dev/null | gzip > dists/source/Sources.gz")
systemTask updateStyle scanCmd
return $ Repo dir Flat True
where
updateStyle = addStyles [Start ("updating repository at " ++ dir)] style
-}
uploadAll :: [Style] -> Bool -> Repository -> Maybe String -> IO Repository
uploadAll style dryRun repo host =
do
let dir = topDir repo
files <- getDirectoryContents dir
let changes = map base . concat . groupByNames . catMaybes . map parseChangesFilename . filter (isSuffixOf ".changes") $ files
let upload = map base . catMaybes $ map parseChangesFilename (filter (isSuffixOf ".upload") files)
-- Eliminate any packages already uploaded
let changes' = Set.toList (Set.difference (Set.fromList changes) (Set.fromList upload))
-- Reconstruct the full pathname of the .changes files
let changes'' = map (\ base -> dir ++ "/" ++ base ++ ".changes") changes'
case changes'' of
[] -> ePut "Nothing to upload."
_ -> mapM_ (dupload style dryRun host) changes''
return repo
where
-- newest = map (head . reverse . (sortBy compareVersions))
-- compareVersions (_, a, _, _) (_, b, _, _) = compare (parseDebianVersion a) (parseDebianVersion b)
groupByNames = groupBy equalNames . sortBy compareNames
compareNames (a, _, _, _) (b, _, _, _) = compare a b
equalNames a b = compareNames a b == EQ
-- Reconstruct the .changes or .upload filename without the extension
base :: (String, String, Arch, String) -> String
base (n, v, (Arch a), _) = n ++ "_" ++ v ++ "_" ++ a
-- |Run dupload on a changes file with an optional host (--to)
-- argument.
dupload :: [Style] -> Bool -> Maybe String -> FilePath -> IO TimeDiff
dupload style dryRun host changesFile =
systemTask style' (if dryRun then ("echo " ++ cmd) else cmd)
where
cmd = ("dupload" ++ maybe "" (" --to " ++) host ++ " " ++ changesFile)
style' = setStyles [Start "Uploading", Error "dupload failed", Output Indented] style
-- |Install a package into a local repository.
uploadLocal :: [Style] -> Repository -> FilePath -> IO Repository
uploadLocal style repo changesFile =
do
-- My.ePut ("uploadLocal " ++ show changesFile)
let buildDirParent = parentPath changesFile
-- My.ePut (" dir=" ++ show buildDirParent)
changes <- parseControlFromFile changesFile
case changes of
Right (Control [paragraph]) ->
case fieldValue "Files" paragraph of
Just fileList ->
let paths = map ((buildDirParent ++ "/") ++) (map fifth (parseChangesList fileList)) in
linkFiles style repo (changesFile : paths)
_ -> error "couldn't find either Distribution or Files section in .changes file"
_ -> error "invalid .changes file format"
where fifth (_, _, _, _, x) = x
-- |Move some files into the local repository incoming directory.
linkFiles :: [Style] -> Repository -> [FilePath] -> IO Repository
linkFiles style repo@(Repo dir _ _) paths =
do
mapM install paths
result <- scanIncoming style False repo
if all id result then
return repo else
error "Local upload failed"
where
install path =
do
removeIfExists (dest path)
Posix.Files.createLink path (dest path)
-- Posix.Files.removeLink path
dest path = dir ++ "/incoming/" ++ snd (splitFileName path)
removeIfExists path =
do
exists <- doesFileExist path
if exists then Posix.Files.removeLink path else return ()
-- updateStyle = addStyles [Start "Update local pool - after upload"] style
parseChangesFile :: FilePath -> IO (Either ParseError Control)
parseChangesFile path =
do
ePut ("-> " ++ path)
parseControlFromFile path
parseChangesList :: String -> [(String, String, String, String, FilePath)]
parseChangesList text =
-- md5sum size section priority name
case (text, matchRegexAll re text) of
("", _) -> []
(_, Just (_, _, remaining, [md5sum, size, section, priority, filename])) ->
(md5sum, size, section, priority, filename) : parseChangesList remaining
_ -> error ("Parse error in Files section of changes file: '" ++ text)
where
re = mkRegex ("^[ \t\n]*" ++ g ++w++ g ++w++ g ++w++ g ++w++ g ++ "[ \t\n]*")
g = "(" ++ t ++ ")"
t = "[^ \t\n]+"
w = "[ \t]+"
------------------------ FROM newdist -------------------------
-- Name, Dist, Arch, Version
data PackageID = PackageID String Dist Arch DebianVersion
data Layout = Flat | Pool
newtype Arch = Arch String
newtype Dist = Dist String
instance Show Layout where
show Flat = "Flat"
show Pool = "Pool"
instance Show PackageID where
show (PackageID name (Dist dist) (Arch arch) version) = name ++ "=" ++ show version ++ ", dist=" ++ dist ++ ", arch=" ++ arch
instance Show Arch where
show (Arch arch) = arch
instance Show Dist where
show (Dist arch) = arch
layout :: Repository -> IO Layout
layout repo =
do
exists <- doesDirectoryExist (topDir repo ++ "/pool")
return $ case exists of False -> Flat; True -> Pool
-- |Parse a string in the form <packagename>=<versionnumber>
parsePackage :: String -> Maybe PackageID
parsePackage s =
case splitRegex (mkRegex "[,=]") s of
[dist, arch, name, version] -> Just (PackageID name (Dist dist) (Arch arch) (parseDebianVersion version))
_ -> Nothing
-- |If the repository already exists we must look at it to determine
-- the layout, otherwise use the layout argument.
computeLayout :: FilePath -> Layout -> IO Layout
computeLayout root layout =
do
isPool <- doesDirectoryExist (root ++ "/pool")
isFlat <- doesDirectoryExist root
case (isPool, isFlat) of
(True, _) -> return Pool
(False, True) -> return Flat
(False, False) -> return layout
-- |Create the directories which will hold the repository.
createSkeleton :: Bool -> FilePath -> Layout -> IO Repository
createSkeleton dryRun root layout =
do
layout' <- computeLayout root layout
mapM_ initDir ([("dists", 0o40755),
("incoming", 0o41755),
("removed", 0o40750),
("reject", 0o40750)] ++
case layout' of
Pool -> [("pool", 0o40755),
("installed", 0o40755)]
Flat -> [])
return $ Repo root layout' True
where
initDir (name, mode) =
do
let path = root ++ "/" ++ name
createDirectoryIfMissing True path -?- (dryRun, "")
Posix.Files.setFileMode path mode -?- (dryRun, "")
createDists :: Bool -> [String] -> Repository -> IO Repository
createDists dryRun dists (Repo root layout False) = do
repo' <- createSkeleton dryRun root layout
createDists dryRun dists repo'
createDists dryRun dists repo@(Repo root _ True) = do
mapM_ initDir ((map (\ dist -> ("dists/" ++ dist ++ "/main/source", 0o040755)) dists) ++
(map (\ dist -> ("dists/" ++ dist ++ "/main/binary-i386", 0o040755)) dists))
mapM_ initFile (map (\ dist -> root ++ "/dists/" ++ dist ++ "/main/source/Sources") dists ++
map (\ dist -> root ++ "/dists/" ++ dist ++ "/main/binary-i386/Packages") dists)
return repo
where
initDir (name, mode) =
do
let path = root ++ "/" ++ name
createDirectoryIfMissing True path -?- (dryRun, "")
Posix.Files.setFileMode path mode -?- (dryRun, "")
initFile path =
do
exists <- doesFileExist (path ++ ".gz")
if not (exists || dryRun) then do
writeFile path ""
system ("gzip < " ++ path ++ " > " ++ path ++ ".gz") else
return ExitSuccess
-- |Find the .changes files in the incoming directory and try to
-- process each.
scanIncoming :: [Style] -> Bool -> Repository -> IO [Bool]
scanIncoming style dryRun repo@(Repo root _ _) =
do
changesFiles <- getDirectoryContents (root ++ "/incoming") >>=
return . filter (isSuffixOf ".changes")
let changesPaths = map ((root ++ "/incoming/") ++) changesFiles
changes <- mapM parseChangesFile changesPaths
mapM tryUpload (zip changes changesFiles)
where
tryUpload (Right changes, changesFile) =
try (installPackage style dryRun repo changesFile changes) >>=
either (\ e -> do ePut (" rejected: " ++ changesFile ++ "\n " ++ show e); return False)
(\ _ -> do ePut (" accepted: " ++ changesFile); return True)
tryUpload (Left e, changesFile) =
do
renameFileWithBackup
(root ++ "/incoming/" ++ changesFile)
(root ++ "/reject/" ++ changesFile)
ePut ("Couldn't parse " ++ changesFile ++ ": " ++ show e)
return False
{-
data SubDir = SubDir [String] -- path elements
show0 (SubDir l) = concat (intersperse "/" l)
show1 dir = show0 dir ++ "/"
show2 dir = "/" ++ show0 dir
show3 dir = "/" ++ show0 dir ++ "/"
show4 [] = ""
show4 dir = show1 dir
-}
-- |Install a source package into the repository. This means
-- 1. getting the list of files from the .changes file,
--
-- 2. verifying the file checksums,
--
-- 3. removing any existing version and perhaps other versions which
-- were listed in the remove 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.
installPackage :: [Style] -> Bool -> Repository -> FilePath -> Control -> IO Repository
installPackage style dryRun repo@(Repo root layout True) changesFile (Control [changes]) =
do
-- FIXME - if the upload seems incomplete (missing files, short
-- files) we should leave it here, but if it seems incorrect
-- (bad checksums for files that seem long enough) we should
-- move it to reject.
mapM_ (verifyFile root) uploadFiles
verifyInstall repo root poolDir uploadFiles
-- Build the control file entries for the package
(sourceInfo, binaryInfo) <- buildControl root source poolDir uploadFiles
-- Add our "Build-Info" field
sourceInfo' <-
case sourceInfo of
Control [Paragraph paragraph] ->
return $ Control [Paragraph (paragraph ++
maybe [] (\ s -> [Field ("Build-Info", s)])
(fieldValue "Build-Info" changes))]
_ -> error "Invalid sourceInfo"
-- already exist.
-- Write out the modified control files
writeControl dryRun root source poolDir sourceInfo' binaryInfo
-- Move the files out of incoming
mapM_ (installFile dryRun root poolDir) uploadFiles
let changesDir = case layout of Pool -> root ++ "/installed"; Flat -> root
renameFileWithBackup changesPath (changesDir ++ "/" ++ changesFile) -?- (dryRun, " installing " ++ changesFile)
updatePackageLists style dryRun root dist buildArch sourceInfo' binaryInfo
return repo
where
poolDir = case layout of
Flat -> ""
Pool -> "pool/main/" ++ prefixDir ++ "/" ++ source
prefixDir = if isPrefixOf "lib" source then
take (min 4 (length source)) source else
take (min 1 (length source)) source
uploadFiles = parseChangesList (getField changes "Files")
-- version = parseDebianVersion $ getField changes "Version"
source = getField changes "Source"
dist = Dist $ getField changes "Distribution"
changesPath = root ++ "/incoming/" ++ changesFile
buildArch = case parseChangesFilename changesFile of
Nothing -> error ("Invalid changes filename: " ++ changesFile)
Just (_, _, x, _) -> x
getField para name = maybe (error ("Missing field: " ++ name)) id (fieldValue name para)
installPackage _ _ _ _ (Control _) = error "Invalid changes file"
-- |Make sure that none of the files we are about to install are
-- already in the repository (other than uncollected garbage.)
verifyInstall :: Repository -> FilePath -> FilePath -> [(String, String, String, String, FilePath)] -> IO ()
verifyInstall repo root poolDir uploadFiles =
do
let moves = map (installPaths root poolDir) uploadFiles
-- If none of the files exist we have nothing to worry about.
exists <- mapM doesFileExist (map snd moves)
case exists of
[] -> return ()
_ -> do
-- Now we have to look at all the dists to see if
-- any of these files are present. This is the same
-- operation removeGarbage does.
live <- findLive repo
case Set.toList (Set.intersection (Set.fromList live) (Set.fromList (map snd moves))) of
[] -> return ()
files -> error ("Uploaded files already exist in repository:\n " ++ consperse "\n " files)
-- filename name version arch ext
parseChangesFilename :: String -> Maybe (String, String, Arch, String)
parseChangesFilename name =
case matchRegex (mkRegex "^([^_]*)_(.*)_([^.]*)\\.(changes|upload)$") name of
Just [name, version, arch, ext] -> Just (name, version, Arch arch, ext)
_ -> error ("Invalid .changes file name: " ++ name)
-- text md5sum size name
parseSourcesFileList :: String -> [(String, Int, String)]
parseSourcesFileList text =
catMaybes $ map parseSourcesFiles (lines text)
where
parseSourcesFiles line =
case words line of
[md5sum, size, name] -> Just (md5sum, read size, name)
[] -> Nothing
_ -> error ("Invalid line in Files list: '" ++ line ++ "'")
-- |Remove the version of the package from a dist's package lists.
-- Note that the package's files are not removed, they may still be
-- referenced in other dists.
removePackage :: Bool -> Repository -> PackageID -> IO Repository
removePackage dryRun repo package@(PackageID name dist arch version) =
do
ePut (" Repository.removePackage (" ++ consperse " " [name, show dist, show version] ++ ")")
Control sources <- getSources repo dist
Control packages <- getPackages repo dist arch
case partition testSource sources of
([], _) ->
-- We didn't find a source package, maybe it is a binary package
case partition testBinary packages of
([], _) -> do
ePut (" Package not found: " ++ show package)
return repo
([remove], _) ->
case fieldValue "Source" remove of
Nothing -> do
ePut " Binary package has no 'Source' field"
return repo
Just name -> do
ePut (" Removing binary package version: " ++ show package)
removePackage dryRun repo (PackageID name dist arch version)
(remove, _) -> do
ePut (" Multiple packages found: " ++ consperse "\n\n" (map show remove))
return repo
(remove, keep) -> do
-- We found one or more source packages to remove, rewrite Sources with
-- only the keep packages.
case remove of (_ : _ : _) -> ePut ("WARNING: multiple " ++ show package ++ " found"); _ -> return ()
ePut (" Removing source package version: " ++ show package)
putSources repo dist (Control keep) -?- (dryRun, (""))
case partition testBinaryBySource packages of
([], _) -> do
ePut (" No binary packages found for " ++ show package)
return repo
(remove, keep) -> do
ePut (" Removing binary package versions: " ++ show (catMaybes (map binaryVersion remove)))
putPackages repo dist arch (Control keep) -?- (dryRun, (""))
return repo
where
-- Is this the source package we are looking for?
testSource paragraph =
case (fieldValue "Package" paragraph, fieldValue "Version" paragraph) of
(Just a, Just b) -> a == name && b == show version
_ -> False
-- Is this binary packages part of the source package we are looking for?
testBinaryBySource paragraph =
case (fieldValue "Source" paragraph, fieldValue "Version" paragraph) of
(Just a, Just b) -> a == name && b == show version
_ -> False
-- Is this the binary package we are looking for?
testBinary paragraph =
case (fieldValue "Package" paragraph, fieldValue "Version" paragraph) of
(Just a, Just b) -> a == name && b == show version
_ -> False
{-
removeBinaryP paragraph =
case (fieldValue "Source" paragraph, fieldValue "Version" paragraph) of
(Just a, Just b) -> a == name && b == version
_ -> False
sourceVersion paragraph =
case (fieldValue "Package" paragraph, fieldValue "Version" paragraph) of
(Just a, Just b) -> Just (a, b)
_ -> Nothing
-}
binaryVersion paragraph =
case (fieldValue "Binary" paragraph, fieldValue "Version" paragraph) of
(Just a, Just b) -> Just (a, b)
_ -> Nothing
-- For debugging
nameversion paragraph = (fieldValue "Package" paragraph, fieldValue "Version" paragraph)
-- |Get the contents of the Sources file for a dist
getSources :: Repository -> Dist -> IO Control
getSources repo dist =
do
exists <- doesFileExist (sourcesPath repo dist)
case exists of
False -> return (Control [])
True -> do
let path = sourcesPath repo dist
Control paragraphs <- parseControlFromFile path >>=
either (error ("Error reading " ++ sourcesPath repo dist)) return
return (Control paragraphs)
putSources :: Repository -> Dist -> Control -> IO ()
putSources repo dist control = rewriteFile (sourcesPath repo dist) (show control)
-- |Return the name of the Sources file for a dist
sourcesPath :: Repository -> Dist -> FilePath
sourcesPath (Repo root _ _) dist = root ++ "/dists/" ++ show dist ++ "/main/source/Sources"
getPackages :: Repository -> Dist -> Arch -> IO Control
getPackages repo dist arch =
do
exists <- doesFileExist path
case exists of
False -> return (Control [])
True -> parseControlFromFile path >>=
either (error ("Error reading " ++ path)) return
where
path = (packagesPath repo dist arch)
putPackages :: Repository -> Dist -> Arch -> Control -> IO ()
putPackages repo dist arch control =
do
rewriteFile (packagesPath repo dist arch) (show control)
packagesPath :: Repository -> Dist -> Arch -> FilePath
packagesPath (Repo root _ _) dist arch = root ++ "/dists/" ++ show dist ++ "/main/binary-" ++ show arch ++ "/Packages"
-- |Add a package to the source and binary package lists.
updatePackageLists :: [Style] -> Bool -> FilePath -> Dist -> Arch -> Control -> Control -> IO ()
updatePackageLists style dryRun root dist buildArch sourceInfo binaryInfo =
do
append' sourceStyle (sourcesDir dist) "Sources" (show sourceInfo)
-- Add the packages to the package list for the build architecture
append' binaryStyle (archDir dist buildArch) "Packages" (show binaryInfo)
where
sourcesDir dist = root ++ "/dists/" ++ show dist ++ "/main/source"
archDir dist arch = root ++ "/dists/" ++ show dist ++ "/main/binary-" ++ show arch
-- Append text to a file with a separating newline
-- (This version of append is dying on gzip, claiming that the
-- Sources file is locked, presumably by appendFile. Odd.)
append _ dir name text =
do
createDirectoryIfMissing True dir -?- (dryRun, "") -- ("create directory " ++ dir)
let path = dir ++ "/" ++ name
exists <- doesFileExist path
if exists then
appendFile path ("\n" ++ text) -?- (dryRun, " append package info " ++ path) else
writeFile path text -?- (dryRun, " write package info " ++ path)
Unix.gzip path -?- (dryRun, " gzip package info " ++ path)
-- system ("ls -l " ++ path ++ " " ++ path ++ ".gz 1>&2")
return ()
append' style dir name text = do
createDirectoryIfMissing True dir -?- (dryRun, "") -- ("create directory " ++ dir)
let path = dir ++ "/" ++ name
newtext <- empty path >>= return . bool "\n" "" >>= return . (++ text)
writeFile (path ++ ".new") newtext
let cmd = ("cat " ++ path ++ ".new >> " ++ path ++
" && gzip < " ++ path ++ " > " ++ path ++ ".gz")
systemTask style cmd
removeFile (path ++ ".new")
return ()
empty path = doesFileExist path >>= bool (return True) (readFile path >>= return . (== ""))
sourceStyle = setStyles [Start ("Updating repository " ++ show dist ++ " source indices"),
Error ("Failure updating repository " ++ show dist ++ " source indices")] style
binaryStyle = setStyles [Start ("Updating repository " ++ show dist ++ " binary indices"),
Error ("Failure updating repository " ++ show dist ++ " binary indices")] style
-- |Verify the checksum of a file. (We could verify the size too at
-- some point.)
verifyFile :: FilePath -> (String, String, String, String, FilePath) -> IO ()
verifyFile root (md5sum, _ {- size -}, _, _, name) =
do
let path = root ++ "/incoming/" ++ name
exists <- doesFileExist path
case exists of
False -> error ("Missing file: " ++ path)
True ->
do
sum <- Unix.md5sum path
case sum == md5sum of
True -> return ()
False -> error ("checksum mismatch on " ++ path ++ ":\n expected: " ++ md5sum ++ "\n actual: " ++ sum)
-- |Return the path where a file is to be installed.
installPaths :: FilePath -> FilePath -> (String, String, String, String, FilePath) -> (FilePath, FilePath)
installPaths root dir (_, _, _, _, name) =
(root +/+ "incoming" +/+ name, root +/+ dir +/+ name)
-- |Install one of the files listed in the .changes file into the
-- pool.
installFile :: Bool -> FilePath -> FilePath -> (String, String, String, String, FilePath) -> IO ()
installFile dryRun root dir (_, _, _, _, name) =
do
-- This is used as the Directory attribute
let src = root +/+ "incoming" +/+ name
let dst = root +/+ dir +/+ name
createDirectoryIfMissing True (root +/+ dir) -?- (dryRun, "" {- "create directory " ++ show dir -})
removeFileIf dst -?- (dryRun, "" {- "remove existing file " ++ dst -})
Posix.Files.createLink src dst -?- (dryRun, (" installing " ++ dst) {- "link new name " ++ dst -})
Posix.Files.removeLink src -?- (dryRun, "" {- "unlink old name " ++ src -})
where
removeFileIf path =
doesFileExist path >>=
(\ exists -> if exists then removeFile path else return ())
writeControl :: Bool -> FilePath -> String -> FilePath -> Control -> Control -> IO ()
writeControl dryRun root source dir sourceInfo binaryInfo = do
createDirectoryIfMissing True (root +/+ dir) -?- (dryRun, "") -- "create directory " ++ dir
writeFile (root +/+ dir +/+ source ++ ".package") (show binaryInfo) -?- (dryRun, "") -- "write .package file for " ++ source
writeFile (root +/+ dir +/+ source ++ ".source") (show sourceInfo) -?- (dryRun, "") -- "write .source file for " ++ source
-- |Write the info which belongs in the Packages and Sources files.
buildControl :: FilePath -> String -> FilePath -> [(String, String, String, String, FilePath)] -> IO (Control, Control)
buildControl root source dir files =
do
let debs = filter (isSuffixOf ".deb" . name) files
let dsc = filter (isSuffixOf ".dsc" . name) files
case (dsc, debs) of
([dscTuple], (_ : _)) ->
do
binaryInfo <- mapM doPackage debs >>= return . mergeControls
sourceInfo <- mapM (doSource dscTuple) dsc >>= return . mergeControls
return (sourceInfo, binaryInfo)
([_], _) ->
error "Package contains no debs"
(_, _) ->
error "Package must contain exactly 1 .dsc file"
where
name (_, _, _, _, x) = x
doPackage (md5sum, size, _, _, name) =
do
let debpath = root ++ "/incoming/" ++ name
info <- getControl debpath
case info of
Control [info] ->
do
let newfields = [Field ("Source", " " ++ source),
Field ("Filename", " " ++ dir +/+ name),
Field ("Size", " " ++ size),
Field ("MD5sum", " " ++ md5sum)]
return $ Control [appendFields newfields info]
_ -> error ("Invalid control file in " ++ debpath)
doSource (md5sum, size, _, _, dscName) (_, _, section, priority, name) =
do
let dscpath = root ++ "/incoming/" ++ name
dsc <- parseControlFromFile dscpath >>= either (error ("couldn't parse " ++ dscpath)) return
case dsc of
Control [info] ->
do
let info' = renameField "Source" "Package" info
let info'' = modifyField "Files" (++ "\n " ++ md5sum ++ " " ++ size ++ " " ++ dscName) info'
let info''' = raiseFields (== "Package") info''
let newfields = [Field ("Priority", " " ++ priority),
Field ("Section", " " ++ section),
Field ("Directory", " " ++ dir)]
return $ Control [appendFields newfields info''']
_ -> error ("Invalid .dsc file: " ++ dscpath)
-- |Remove 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.
removeTrumped :: [Style] -> Bool -> Repository -> IO Repository
removeTrumped style dryRun repo =
do
dists <- getDists repo >>= return . map Dist
victims <- mapM (findTrumped style repo) dists >>= return . concat
case victims of
[] -> do
ePut "removeTrumped: nothing to remove"
return repo
_ -> do
ePut "removeTrumped:"
foldM (removePackage dryRun) repo victims
-- |Return a list of packages in a dist which are trumped by some
-- newer version.
findTrumped :: [Style] -> Repository -> Dist -> IO [PackageID]
findTrumped _ (Repo _ _ False) _ = error "Invalid repository"
findTrumped _ (Repo dir _ True) dist =
do
ePut ("findTrumped " ++ show dist)
packages <- return (dir ++ "/dists/" ++ show dist ++ "/main/source/Sources") >>=
parseControlFromFile >>=
return . either (error "control file parse error") id >>=
return . (\ (Control p) -> p) >>=
return . map makePackage
let (groups :: [[PackageID]]) = groupByName packages
mapM_ ePut (catMaybes (map formatGroup groups))
return . concat . (map older) $ groups
where
makePackage p = case (fieldValue "Package" p, fieldValue "Version" p) of
(Just n, Just v) -> (PackageID n dist arch (parseDebianVersion v))
_ -> error ("Invalid Sources paragraph: " ++ show p)
groupByName = groupBy equalNames . sortBy compareNames
equalNames a b = compareNames a b == EQ
compareNames (PackageID a _ _ _) (PackageID b _ _ _) = compare a b
older :: [PackageID] -> [PackageID]
older = tail . reverse . (sortBy compareVersions)
compareVersions (PackageID _ _ _ a) (PackageID _ _ _ b) = compare a b
arch = Arch "i386"
formatGroup [] = Nothing
formatGroup [_] = Nothing
formatGroup (newest@(PackageID _ dist _ _) : other) =
Just ("Trumped by " ++ formatPackage newest ++ " in " ++ show dist ++ ":\n " ++ consperse "\n " (map formatPackage other))
formatPackage (PackageID name _ arch version) = name ++ "=" ++ show version ++ "[" ++ show arch ++ "]"
-- |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.
removeGarbage :: [Style] -> Bool -> Repository -> IO Repository
removeGarbage style dryRun repo@(Repo dir layout True) =
do
ePut ("removeGarbage in " ++ dir ++ " (layout=" ++ show layout ++ ", dryRun=" ++ show dryRun ++ ")")
allFiles1 <- poolFiles repo
allFiles2 <- changesFilePaths repo
let allFiles = allFiles1 ++ allFiles2
-- ePut ("allFiles:\n " ++ consperse "\n " (sort allFiles) ++ "\n")
liveFiles <- findLive repo
-- ePut ("liveFiles:\n " ++ consperse "\n " (sort liveFiles) ++ "\n")
let deadFiles = Set.toList (Set.difference (Set.fromList allFiles) (Set.fromList liveFiles))
ePut ("Removing:\n " ++ consperse "\n " (sort deadFiles) ++ "\n")
mapM_ (moveToRemoved dryRun) deadFiles
return repo
where
poolFiles (Repo dir Flat _) = getDirectoryContents dir >>= filterM (doesFileExist . ((dir ++ "/") ++))
poolFiles (Repo dir Pool _) =
getSubPaths (dir ++ "/pool") >>=
mapM getSubPaths >>= return . concat >>=
mapM getSubPaths >>= return . concat >>=
mapM getSubPaths >>= return . concat
changesFilePaths (Repo dir Pool _) = getDirectoryPaths (dir ++ "/installed")
-- In this case we already got the .changes files from the top directory
changesFilePaths (Repo _ Flat _) = return []
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 True file = do
ePut ("renameFile " ++ file ++ " " ++ dir ++ "/removed/" ++ snd (splitFileName file))
return ()
moveToRemoved False file = do
ePut ("renameFile " ++ file ++ " " ++ dir ++ "/removed/" ++ snd (splitFileName file))
renameFile file (dir ++ "/removed/" ++ snd (splitFileName file))
removeGarbage style dryRun (Repo dir layout False) =
createSkeleton dryRun dir layout >>= removeGarbage style dryRun
findLive :: Repository -> IO [FilePath]
findLive (Repo _ _ False) = error "Invalid operation on unverified repository"
findLive repo@(Repo dir layout True) =
do
dists <- getDists repo >>= return . map Dist
sourcePackages <- mapM packagesOfIndex (map sourceIndexPath dists) >>= return . concat
binaryPackages <- mapM packagesOfIndex (map binaryIndexPath dists) >>= return . concat
let sourceFiles = map ((dir ++ "/") ++) . map (\ (_, _, name) -> name) . concat . map filesOfSourcePackage $ sourcePackages
let binaryFiles = map ((dir ++ "/") ++) . catMaybes $ map (fieldValue "Filename") binaryPackages
let changesFiles = map (changesFilePath layout) $ sourcePackages
let uploadFiles = map ((dir ++ "/") ++) . map uploadFilePath $ sourcePackages
return $ sourceFiles ++ binaryFiles ++ changesFiles ++ uploadFiles
where
sourceIndexPath dist = dir ++ "/dists/" ++ show dist ++ "/main/source/Sources"
binaryIndexPath dist = dir ++ "/dists/" ++ show dist ++ "/main/binary-" ++ show arch ++ "/Packages"
packagesOfIndex :: FilePath -> IO [Paragraph]
packagesOfIndex path =
parseControlFromFile path >>=
return . either (error ("Bad index file: " ++ path)) id >>=
return . (\ (Control p) -> p)
filesOfSourcePackage :: Paragraph -> [(String, Int, String)]
filesOfSourcePackage package =
let dir = sourcePackageDirectory package in
map (\ (a, b, name) -> (a, b, dir ++ name)) (maybe [] parseSourcesFileList (fieldValue "Files" package))
sourcePackageDirectory package =
case fieldValue "Directory" package of
Nothing -> ""
Just "" -> ""
Just s -> s ++ "/"
changesFilePath Flat package = ((dir ++ "/") ++) . changesFileName $ package
changesFilePath Pool package = ((dir ++ "/installed/") ++) . changesFileName $ package
changesFileName package =
consperse "_" [fromJust (fieldValue "Package" package),
fromJust (fieldValue "Version" package),
show arch] ++ ".changes"
uploadFilePath package = ((dir ++ "/") ++) . uploadFileName $ package
uploadFileName package =
consperse "_" [fromJust (fieldValue "Package" package),
fromJust (fieldValue "Version" package),
show arch] ++ ".upload"
arch = Arch "i386"
getDists :: Repository -> IO [String]
getDists (Repo dir _ _) =
getDirectoryContents (dir ++ "/dists") >>= filterM isDist
where
isDist "." = return False
isDist ".." = return False
isDist name = doesFileExist $ dir ++ "/dists/" ++ name ++ "/main/source/Sources.gz"
getControl :: FilePath -> IO Control
getControl path =
do
let cmd = "ar p " ++ path ++ " control.tar.gz | tar xzO ./control"
-- let cmd = "dpkg-deb --info " ++ path ++ " control"
(_, outh, _, handle) <- runInteractiveCommand cmd
control <- parseControlFromHandle cmd outh
exitcode <- waitForProcess handle
case exitcode of
ExitSuccess -> return $ either (error ("Failure reading contol info from " ++ path)) id control
ExitFailure _ -> error ("Failure running " ++ cmd)
-- |Back-up and rewrite a file
rewriteFile :: FilePath -> String -> IO ()
rewriteFile path text =
do
backupFile path
writeFile path text
Unix.gzip path
type DryRunFn = IO () -> (Bool, String) -> IO ()
-- |If this is a dry run (dryRun params is True) do *not* evaluate f,
-- but instead print a message.
(-?-) :: DryRunFn
(-?-) f (dryRun, "") = if dryRun then return () else f
(-?-) f (dryRun, msg) =
do
hPutStrLn stderr msg
if dryRun then return () else f
infixr 9 -?-
renameFileWithBackup :: FilePath -> FilePath -> IO ()
renameFileWithBackup src dst =
do
removeIfExists (dst ++ "~")
renameIfExists dst (dst ++ "~")
System.Directory.renameFile src dst
where
removeIfExists path =
do exists <- doesFileExist path
if exists then removeFile path else return ()
renameIfExists src dst =
do exists <- doesFileExist src
if exists then System.Directory.renameFile src dst else return ()
backupFile :: FilePath -> IO ()
backupFile path =
do
removeIfExists (path ++ "~")
System.Directory.renameFile path (path ++ "~")
where
removeIfExists path =
do exists <- doesFileExist path
if exists then removeFile path else return ()
parentPath :: FilePath -> FilePath
parentPath path = fst (splitFileName path)
ePut :: String -> IO ()
ePut s = hPutStrLn stderr s
bool :: a -> a -> Bool -> a
bool _ t True = t
bool f _ False = f
-- |The mighty consperse function
consperse :: [a] -> [[a]] -> [a]
consperse sep items = concat (intersperse sep items)