-- |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 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 = 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)