diff --git a/Debian/Apt/Dependencies.hs b/Debian/Apt/Dependencies.hs --- a/Debian/Apt/Dependencies.hs +++ b/Debian/Apt/Dependencies.hs @@ -21,7 +21,7 @@ import qualified Data.ByteString.Char8 as C import Debian.Control.ByteString -import Debian.Control.PrettyPrint +--import Debian.Control.PrettyPrint import Debian.Relation.ByteString import Debian.Apt.Package import Debian.Version @@ -125,7 +125,7 @@ -- |JAS: deal with 'Provides' (can a package provide more than one package?) conflict' :: (String, DebianVersion) -> Relation -> Bool -conflict' (pName, pVersion) rel@(Rel pkgName mVersionReq _) = +conflict' (pName, pVersion) (Rel pkgName mVersionReq _) = (pName == pkgName) && (checkVersionReq mVersionReq (Just pVersion)) @@ -203,7 +203,7 @@ -- earliestInconsistency :: CSP a -> State a -> Maybe ((String, DebianVersion), (String, DebianVersion)) earliestInconsistency _ (_,[]) = Nothing -earliestInconsistency _ (_,[p]) = Nothing +earliestInconsistency _ (_,[_p]) = Nothing earliestInconsistency csp (_,(p:ps)) = case find ((conflict csp) p) (reverse ps) of Nothing -> Nothing diff --git a/Debian/Apt/Index.hs b/Debian/Apt/Index.hs --- a/Debian/Apt/Index.hs +++ b/Debian/Apt/Index.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveDataTypeable #-} module Debian.Apt.Index ( update - , Fetcher(..) + , Fetcher , CheckSums(..) , Compression(..) , FileTuple @@ -204,6 +204,7 @@ M.insertWith -} +{- groupIndexes' :: String ->[FileTuple] -> [(FilePath, [(FileTuple, Compression)])] groupIndexes' iType indexFiles = M.toList (foldr (insertType iType) M.empty indexFiles) @@ -213,6 +214,7 @@ Nothing -> m (Just (un, compression)) -> M.insertWith (\x y -> sortBy (compare `on` snd) (x ++ y)) un [(t, compression)] m +-} -- |The release file contains the checksums for the uncompressed -- package indexes, even if the uncompressed package indexes are not @@ -233,21 +235,25 @@ where isType iType (fp, _) = iType `isSuffixOf` fp +{- findIndexes' :: FilePath -> String -> [FileTuple] -> IO [(FileTuple, Compression)] findIndexes' distDir iType controlFiles = let m = groupIndexes' iType controlFiles in do m' <- mapM (filterExists distDir) m return $ map (head . snd) (filter (not . null . snd) m') +-} -- insertType :: String -> (CheckSums, Integer, FilePath) -> M.Map FilePath ((CheckSums, Integer, FilePath), Compression) -> M.Map FilePath ((CheckSums, Integer, FilePath), Compression) +{- uncompressedName' :: String -> FilePath -> Maybe (FilePath, Compression) uncompressedName' iType fp | isSuffixOf iType fp = Just (fp, Uncompressed) | isSuffixOf (iType ++".gz") fp = Just (reverse . (drop 3) . reverse $ fp, GZ) | isSuffixOf (iType ++".bz2") fp = Just (reverse . (drop 4) . reverse $ fp, BZ2) | otherwise = Nothing +-} uncompressedName :: FilePath -> (FilePath, Compression) uncompressedName fp diff --git a/Debian/Apt/Methods.hs b/Debian/Apt/Methods.hs --- a/Debian/Apt/Methods.hs +++ b/Debian/Apt/Methods.hs @@ -260,7 +260,7 @@ waitForProcess handle recv :: MethodHandle -> IO [String] -recv (pIn, pOut, pErr, pHandle) = +recv (_pIn, pOut, _pErr, _pHandle) = do -- hPutStrLn stderr "recv:" readTillEmptyLine pOut @@ -399,21 +399,21 @@ -- required, no credentials will be supplied and the download should -- abort. emptyFetchCallbacks = - FetchCallbacks { logCB = \m -> return () - , statusCB = \uri m -> return () - , uriStartCB = \uri size lastModified resumePoint -> return () - , uriDoneCB = \uri size lastModified resumePoint filename hashes imsHit -> return () - , uriFailureCB = \uri message -> return () - , generalFailureCB = \m -> return () - , authorizationRequiredCB = \site -> return Nothing - , mediaFailureCB = \media drive -> return () - , debugCB = \m -> return () + FetchCallbacks { logCB = \ _m -> return () + , statusCB = \ _uri _m -> return () + , uriStartCB = \ _uri _size _lastModified _resumePoint -> return () + , uriDoneCB = \ _uri _size _lastModified _resumePoint _filename _hashes _imsHit -> return () + , uriFailureCB = \ _uri _message -> return () + , generalFailureCB = \ _m -> return () + , authorizationRequiredCB = \ _site -> return Nothing + , mediaFailureCB = \ _media _drive -> return () + , debugCB = \ _m -> return () } cliFetchCallbacks = emptyFetchCallbacks { statusCB = \uri m -> putStrLn $ uriToString' uri ++ " : " ++ m - , uriStartCB = \uri size lastModified resumePoint -> putStrLn $ uriToString' uri ++ " started. " ++ show lastModified - , uriDoneCB = \uri size lastModified resumePoint filename hashes imsHit -> putStrLn $ uriToString' uri ++ (if imsHit then " cached." else " downloaded.") + , uriStartCB = \ uri _size lastModified _resumePoint -> putStrLn $ uriToString' uri ++ " started. " ++ show lastModified + , uriDoneCB = \uri _size _lastModified _resumePoint _filename _hashes imsHit -> putStrLn $ uriToString' uri ++ (if imsHit then " cached." else " downloaded.") , uriFailureCB = \uri message -> hPutStrLn stderr $ "URI Failure: " ++ uriToString' uri ++ " : " ++ message , generalFailureCB = \message -> hPutStrLn stderr $ "General Failure: " ++ message , authorizationRequiredCB = \site -> @@ -473,9 +473,10 @@ then getFileStatus fp >>= return . Just . epochTimeToUTCTime . modificationTime else return Nothing - +{- groupOn :: (Ord b) => (a -> b) -> [a] -> [[a]] groupOn f = groupBy ((==) `on` f) . sortBy (compare `on` f) +-} on :: (a -> a -> b) -> (c -> a) -> c -> c -> b on f g x y = f (g x) (g y) diff --git a/Debian/Apt/Package.hs b/Debian/Apt/Package.hs --- a/Debian/Apt/Package.hs +++ b/Debian/Apt/Package.hs @@ -40,14 +40,14 @@ -- |'lookupPackageByRel' returns all the packages that satisfy the specified relation -- TODO: Add architecture check lookupPackageByRel :: PackageNameMap a -> (a -> (String, DebianVersion)) -> Relation -> [a] -lookupPackageByRel pm packageVersionF (Rel pkgName mVerReq mArch) = +lookupPackageByRel pm packageVersionF (Rel pkgName mVerReq _mArch) = case Map.lookup pkgName pm of Nothing -> [] Just packages -> filter filterVer packages where filterVer p = case mVerReq of Nothing -> True - Just verReq -> + Just _verReq -> let (pName, pVersion) = packageVersionF p in if pName /= pkgName then False -- package is a virtual package, hence we can not do a version req diff --git a/Debian/GenBuildDeps.hs b/Debian/GenBuildDeps.hs --- a/Debian/GenBuildDeps.hs +++ b/Debian/GenBuildDeps.hs @@ -13,12 +13,11 @@ , BuildableInfo(..) , buildable , compareSource -{- + -- * Obsolete? , orderSource , genDeps , failPackage , getSourceOrder --} ) where import Control.Monad (filterM) @@ -118,8 +117,7 @@ ([], _) -> CycleInfo {depPairs = map ofEdge (cycleEdges hasDep)} -- We have some buildable packages, return them along with -- the list of packages each one directly blocks - (allReady@(oneReady : moreReady), blocked) -> - let (deps, other) = partition (\ x -> elem x (reachable isDep oneReady)) blocked in + (allReady, blocked) -> BuildableInfo { readyTriples = map (makeTriple blocked allReady) allReady, allBlocked = map ofVertex blocked } @@ -128,7 +126,7 @@ let otherReady = filter (/= thisReady) ready (directlyBlocked, otherBlocked) = partition (\ x -> elem x (reachable isDep thisReady)) blocked in (ofVertex thisReady, map ofVertex directlyBlocked, map ofVertex (otherReady ++ otherBlocked)) - allDeps x = (ofVertex x, map ofVertex (filter (/= x) (reachable hasDep x))) + --allDeps x = (ofVertex x, map ofVertex (filter (/= x) (reachable hasDep x))) isDep = buildG (0, length packages - 1) edges' edges' = map (\ (a, b) -> (b, a)) edges hasDep = buildG (0, length packages - 1) edges @@ -189,9 +187,9 @@ (Set.fromList (closure (transposeG g))))) where closure g = concat (map (\ v -> (map (\ u -> (v, u)) (reachable g v))) (vertices g)) - self (a, b) = a == b - distrib = concat . map (\ (n, ms) -> map (\ m -> (n, m)) ms) - swap (a, b) = (b, a) + --self (a, b) = a == b + --distrib = concat . map (\ (n, ms) -> map (\ m -> (n, m)) ms) + --swap (a, b) = (b, a) -- | Remove any packages which can't be built given that a package has failed. failPackage :: Eq a => (a -> a -> Ordering) -> a -> [a] -> ([a], [a]) diff --git a/Debian/Repo/AptImage.hs b/Debian/Repo/AptImage.hs --- a/Debian/Repo/AptImage.hs +++ b/Debian/Repo/AptImage.hs @@ -122,13 +122,13 @@ -- |Retrieve a source package via apt-get. aptGetSource :: (AptCache t, CIO m) - => EnvPath -- Where to put the source + => FilePath -- Where to put the source -> t -- Where to apt-get from -> PkgName -- The name of the package -> Maybe DebianVersion -- The desired version, if Nothing get newest -> m DebianBuildTree -- The resulting source tree aptGetSource dir os package version = - do liftIO $ createDirectoryIfMissing True (outsidePath dir) + do liftIO $ createDirectoryIfMissing True dir ready <- findDebianBuildTrees dir let newest = listToMaybe . map (packageVersion . sourcePackageID) . filter ((== package) . packageName . sourcePackageID) . aptSourcePackages $ os let version' = maybe newest Just version @@ -146,7 +146,7 @@ _ -> error "apt-get source failed" (Just requested, _) -> do -- One or more incorrect versions are available, remove them - liftIO $ removeRecursiveSafely (outsidePath dir) + liftIO $ removeRecursiveSafely dir vBOL 0 vEPutStr 0 $ "Retrieving APT source for " ++ package runAptGet os dir "source" [(package, Just requested)] @@ -160,14 +160,14 @@ aptGetStyle = setStyle (setStart (Just ("Retrieving APT source for " ++ package))) -} -runAptGet :: (AptCache t, CIO m) => t -> EnvPath -> String -> [(PkgName, Maybe DebianVersion)] -> m (Either String [Output]) +runAptGet :: (AptCache t, CIO m) => t -> FilePath -> String -> [(PkgName, Maybe DebianVersion)] -> m (Either String [Output]) runAptGet os dir command packages = mkdir >>= aptget where - mkdir = liftIO . try . createDirectoryIfMissing True . outsidePath $ dir + mkdir = liftIO . try . createDirectoryIfMissing True $ dir aptget (Left e) = return . Left . show $ e aptget (Right _) = runTaskAndTest (SimpleTask 0 cmd) - cmd = (consperse " " ("cd" : outsidePath dir : "&&" : "apt-get" : aptOpts os : command : map formatPackage packages)) + cmd = (consperse " " ("cd" : dir : "&&" : "apt-get" : aptOpts os : command : map formatPackage packages)) formatPackage (name, Nothing) = name formatPackage (name, Just version) = name ++ "=" ++ show version diff --git a/Debian/Repo/Insert.hs b/Debian/Repo/Insert.hs --- a/Debian/Repo/Insert.hs +++ b/Debian/Repo/Insert.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} -- |Insert packages into a release, remove packages from a release. module Debian.Repo.Insert ( scanIncoming diff --git a/Debian/Repo/OSImage.hs b/Debian/Repo/OSImage.hs --- a/Debian/Repo/OSImage.hs +++ b/Debian/Repo/OSImage.hs @@ -475,7 +475,7 @@ updateLists os = do vMessage 1 ("Updating OSImage " ++ stripDist (rootPath root) ++ " ") () vMessage 2 ("# " ++ cmd) () - ((out, err, code), elapsed) <- liftIO . timeTask $ lazyCommand cmd L.empty >>= return . collectOutputUnpacked + ((_out, err, code), elapsed) <- liftIO . timeTask $ lazyCommand cmd L.empty >>= return . collectOutputUnpacked return $ case code of [ExitSuccess] -> Right elapsed result -> Left $ "*** FAILURE: Could not update environment: " ++ cmd ++ " -> " ++ show result ++ "\n" ++ err diff --git a/Debian/Repo/Package.hs b/Debian/Repo/Package.hs --- a/Debian/Repo/Package.hs +++ b/Debian/Repo/Package.hs @@ -26,7 +26,7 @@ import qualified Debian.Control.ByteString as B import qualified Debian.Relation.ByteString as B import Debian.Repo.IO -import Debian.Shell +--import Debian.Shell import Debian.Repo.Types import Debian.URI import Debian.Version @@ -40,12 +40,12 @@ import Data.Maybe import qualified Extra.Either as EE import qualified Extra.Files as EF -import Extra.CIO (CIO(..), vEPutStrBl) -import System.Directory +import Extra.CIO (CIO(..)) +--import System.Directory import System.FilePath(()) import System.IO.Unsafe import System.Posix -import System.Unix.Process +--import System.Unix.Process import Text.Regex sourceFilePaths :: SourcePackage -> [FilePath] diff --git a/Debian/Repo/Release.hs b/Debian/Repo/Release.hs --- a/Debian/Repo/Release.hs +++ b/Debian/Repo/Release.hs @@ -93,7 +93,7 @@ case failed of [] -> return () files -> vPutStrBl 0 ("Unable to sign:\n " ++ intercalate "\n " files) -signRelease keyname release = error $ "Attempt to sign non-local repository" +signRelease _keyname _release = error $ "Attempt to sign non-local repository" -- |Write out the @Release@ files that describe a 'Release'. writeRelease :: CIO m => Release -> m [FilePath] @@ -149,7 +149,7 @@ map ((packageIndexDir index) ) ["Packages", "Packages.gz", "Packages.bz2", "Packages.diff/Index", "Release"] formatFileInfo fw sum size name = intercalate " " $ ["",sum, pad ' ' fw $ show size, name] fieldWidth = ceiling . (logBase 10) . fromIntegral . maximum -writeRelease release = error $ "Attempt to write release files to non-local repository" +writeRelease _release = error $ "Attempt to write release files to non-local repository" md5sum f = do output <- System.Unix.Process.processOutput "/usr/bin/md5sum" [f] diff --git a/Debian/Repo/Repository.hs b/Debian/Repo/Repository.hs --- a/Debian/Repo/Repository.hs +++ b/Debian/Repo/Repository.hs @@ -32,7 +32,7 @@ import Extra.Either import Extra.Files import Extra.List -import Extra.Net +--import Extra.Net import Extra.SSH import Extra.CIO import System.FilePath diff --git a/Debian/Repo/Slice.hs b/Debian/Repo/Slice.hs --- a/Debian/Repo/Slice.hs +++ b/Debian/Repo/Slice.hs @@ -21,18 +21,18 @@ import Data.List import Data.Maybe import Debian.Control -import Debian.Extra.CIO (vMessage) +--import Debian.Extra.CIO (vMessage) import Debian.Repo.IO import Debian.Repo.LocalRepository import Debian.Repo.Repository -import Debian.Shell +--import Debian.Shell import Debian.Repo.SourcesList import Debian.Repo.Types import Debian.URI -import Extra.Net (webServerDirectoryContents) +--import Extra.Net (webServerDirectoryContents) import Extra.CIO (CIO, vPutStrBl) -import System.Unix.Process -import System.Directory +--import System.Unix.Process +--import System.Directory import Text.Regex sourceSlices :: SliceList -> SliceList diff --git a/Debian/Repo/SourceTree.hs b/Debian/Repo/SourceTree.hs --- a/Debian/Repo/SourceTree.hs +++ b/Debian/Repo/SourceTree.hs @@ -37,6 +37,7 @@ import Debian.Shell import qualified Debian.Version as V import Extra.Files (replaceFile, getSubDirectories) +import Extra.List (dropPrefix) import Extra.CIO (CIO, setStyle, addPrefixes) import System.Directory import System.Environment @@ -46,12 +47,12 @@ -- |Any directory containing source code. class Show t => SourceTreeC t where - topdir :: t -> EnvPath -- ^The top directory of the source tree + topdir :: t -> FilePath -- ^The top directory of the source tree -- |A Debian source tree, which has a debian subdirectory containing -- at least a control file and a changelog. class (Show t, SourceTreeC t) => DebianSourceTreeC t where - debdir :: t -> EnvPath -- ^The directory containing the debian subdirectory + debdir :: t -> FilePath -- ^The directory containing the debian subdirectory control :: t -> Control -- ^The contents of debian\/control entry :: t -> ChangeLogEntry -- ^The latest entry from debian\/changelog @@ -62,7 +63,7 @@ -- |Any directory containing source code. data SourceTree = - SourceTree {dir' :: EnvPath} deriving Show + SourceTree {dir' :: FilePath} deriving Show -- |A Debian source tree, which has a debian subdirectory containing -- at least a control file and a changelog. @@ -74,7 +75,7 @@ -- |A Debian source tree plus a parent directory, which is where the -- binary and source deb packages appear after a build. data DebianBuildTree = - DebianBuildTree {topdir' :: EnvPath, + DebianBuildTree {topdir' :: FilePath, subdir' :: String, debTree' :: DebianSourceTree} deriving Show @@ -93,7 +94,7 @@ topdir = topdir' instance DebianSourceTreeC DebianBuildTree where - debdir t = (topdir' t) { envPath = envPath (topdir' t) ++ "/" ++ subdir' t } + debdir t = topdir' t ++ "/" ++ subdir' t control = control' . debTree' entry = entry' . debTree' @@ -105,18 +106,18 @@ findChanges :: DebianBuildTree -> IO (Either String ChangesFile) findChanges tree = do let dir = topdir tree - result <- findChangesFiles (outsidePath dir) + result <- findChangesFiles dir case result of [cf] -> return (Right cf) - [] -> return (Left ("Couldn't find .changes file in " ++ outsidePath dir)) - lst -> return (Left ("Multiple .changes files in " ++ outsidePath dir ++ ": " ++ show lst)) + [] -> return (Left ("Couldn't find .changes file in " ++ dir)) + lst -> return (Left ("Multiple .changes files in " ++ dir ++ ": " ++ show lst)) -- |Rewrite the changelog with an added entry. addLogEntry :: DebianSourceTreeC t => ChangeLogEntry -> t -> IO () addLogEntry entry debtree = readFile changelogPath >>= replaceFile changelogPath . ((show entry) ++) where - changelogPath = (outsidePath . debdir $ debtree) ++ "/debian/changelog" + changelogPath = (debdir debtree) ++ "/debian/changelog" -- |There are three possible results of a build: an upload consisting -- of only the architecture independent debs (Indep), one including @@ -141,10 +142,10 @@ ++ (case status of Indep -> " -B "; _ -> "") ++ (if noSecretKey then " -us -uc" else "") ++ (if noClean then " -nc" else "") - let fullcmd = ("chroot " ++ rootPath root ++ + let fullcmd = ("chroot " ++ root ++ " bash -c \"unset LANG; export LOGNAME=root; " ++ concat (map (\ x -> "export " ++ x ++ "; ") setEnv) ++ - "cd '" ++ path ++ "' && " ++ + "cd '" ++ fromJust (dropPrefix root path) ++ "' && " ++ "chmod ugo+x debian/rules && " ++ -- Try to build twice, some packages do configuration the first -- time 'so that it is NEVER run during an automated build.' :-/ @@ -156,31 +157,31 @@ timeTask . checkResult (\ n -> return (Left ("*** FAILURE: " ++ fullcmd ++ " -> " ++ show n))) (return (Right ())) >>= \ (result, elapsed) -> return (either Left (const (Right elapsed)) result) where - path = envPath . debdir $ buildTree - root = rootDir buildOS + path = debdir buildTree + root = rootPath (rootDir buildOS) -- |Make a copy of a source tree in a directory. -copySourceTree :: (SourceTreeC t, CIO m) => t -> EnvPath -> m (Either String SourceTree) +copySourceTree :: (SourceTreeC t, CIO m) => t -> FilePath -> m (Either String SourceTree) copySourceTree tree dest = - liftIO (try (createDirectoryIfMissing True (outsidePath dest))) >>= + liftIO (try (createDirectoryIfMissing True dest)) >>= either (return . Left . show) (const (runTaskAndTest (SimpleTask 0 command))) >>= return . either Left (const . Right . SourceTree $ dest) --copyStyle $ systemTaskDR ("rsync -aHxSpDt --delete '" ++ outsidePath (topdir tree) ++ "/' '" ++ outsidePath dest ++ "'") --return $ SourceTree dest where - command = "rsync -aHxSpDt --delete '" ++ outsidePath (topdir tree) ++ "/' '" ++ outsidePath dest ++ "'" + command = "rsync -aHxSpDt --delete '" ++ topdir tree ++ "/' '" ++ dest ++ "'" {- copyStyle = setStyle (setStart (Just ("Copying source tree (" ++ outsidePath dest ++ ")")) . setError (Just ("Could not copy source tree from " ++ outsidePath (topdir tree) ++ " to " ++ outsidePath dest))) -} -copyDebianSourceTree :: (DebianSourceTreeC t, CIO m) => t -> EnvPath -> m (Either String DebianSourceTree) +copyDebianSourceTree :: (DebianSourceTreeC t, CIO m) => t -> FilePath -> m (Either String DebianSourceTree) copyDebianSourceTree src dest = copySourceTree src dest >>= return . either Left (\ copy -> Right (DebianSourceTree copy (control src) (entry src))) -copyDebianBuildTree :: (DebianBuildTreeC t, CIO m) => t -> EnvPath -> m (Either String DebianBuildTree) +copyDebianBuildTree :: (DebianBuildTreeC t, CIO m) => t -> FilePath -> m (Either String DebianBuildTree) copyDebianBuildTree src dest = copySource >>= copyTarball >>= makeTree where @@ -194,7 +195,7 @@ makeTree (Left message) = return (Left message) makeTree (Right copy) = return $ Right (DebianBuildTree (dir' copy) (subdir src) - (DebianSourceTree { tree' = SourceTree { dir' = dest { envPath = envPath dest ++ "/" ++ subdir src } } + (DebianSourceTree { tree' = SourceTree { dir' = dest ++ "/" ++ subdir src } , control' = (control src) , entry' = (entry src) })) {- @@ -210,28 +211,28 @@ , entry' = (entry src) }) where -} - cmd = ("cp -p " ++ origPath ++ " " ++ outsidePath dest ++ "/") - origPath = outsidePath (topdir src) ++ "/" ++ orig + cmd = ("cp -p " ++ origPath ++ " " ++ dest ++ "/") + origPath = topdir src ++ "/" ++ orig orig = name ++ "_" ++ version ++ ".orig.tar.gz" name = logPackage . entry $ src version = V.version . logVersion . entry $ src -findSourceTree :: CIO m => EnvPath -> m (Either String SourceTree) +findSourceTree :: CIO m => FilePath -> m (Either String SourceTree) findSourceTree path = - do exists <- liftIO $ doesDirectoryExist (outsidePath path) + do exists <- liftIO $ doesDirectoryExist path case exists of - False -> return . Left $ "No such directory: " ++ outsidePath path + False -> return . Left $ "No such directory: " ++ path True -> return . Right . SourceTree $ path -findDebianSourceTree :: CIO m => EnvPath -> m (Either String DebianSourceTree) +findDebianSourceTree :: CIO m => FilePath -> m (Either String DebianSourceTree) findDebianSourceTree path = do --vPutStrLn 2 stderr $ "findDebianSourceTree " ++ show path findSourceTree path >>= either (return . Left) findDebianSource where findDebianSource :: CIO m => SourceTree -> m (Either String DebianSourceTree) findDebianSource tree@(SourceTree path) = - do let controlPath = outsidePath path ++ "/debian/control" - changelogPath = outsidePath path ++ "/debian/changelog" + do let controlPath = path ++ "/debian/control" + changelogPath = path ++ "/debian/changelog" control <- liftIO (try . readFile $ controlPath) >>= return . either (Left . (("Could not read control file: " ++ controlPath ++ ": ") ++) . show) @@ -250,7 +251,7 @@ -- returns the newest one according to the version numbers. If there -- are none, or there are trees with different package names, Nothing -- is returned. -findOneDebianBuildTree :: CIO m => EnvPath -> m (Maybe DebianBuildTree) +findOneDebianBuildTree :: CIO m => FilePath -> m (Maybe DebianBuildTree) findOneDebianBuildTree path = do trees <- findDebianBuildTrees path case nubBy eqNames trees of @@ -261,23 +262,23 @@ cmpVers tree1 tree2 = compare (logVersion . entry $ tree1) (logVersion . entry $ tree2) -- |Find the DebianBuildTree in a particular subdirectory. -findDebianBuildTree :: CIO m => EnvPath -> String -> m (Either String DebianBuildTree) +findDebianBuildTree :: CIO m => FilePath -> String -> m (Either String DebianBuildTree) findDebianBuildTree path name = - findDebianSourceTree (appendPath ("/" ++ name) path) >>= return . either Left (Right . DebianBuildTree path name) + findDebianSourceTree (path ++ "/" ++ name) >>= return . either Left (Right . DebianBuildTree path name) -- |Find all the debian source trees in a directory. -findDebianSourceTrees :: CIO m => EnvPath -> m [(String, DebianSourceTree)] +findDebianSourceTrees :: CIO m => FilePath -> m [(String, DebianSourceTree)] findDebianSourceTrees path = - do dirs <- liftIO (try (getSubDirectories (outsidePath path))) >>= return . either (const []) id - trees <- mapM (\ dir -> findDebianSourceTree (appendPath ("/" ++ dir) path)) dirs + do dirs <- liftIO (try (getSubDirectories path)) >>= return . either (const []) id + trees <- mapM (\ dir -> findDebianSourceTree (path ++ "/" ++ dir)) dirs return $ catRightSeconds $ zip dirs trees -- |Find all the debian source trees in a directory. -findDebianBuildTrees :: CIO m => EnvPath -> m [DebianBuildTree] +findDebianBuildTrees :: CIO m => FilePath -> m [DebianBuildTree] findDebianBuildTrees path = - do dirs <- (liftIO $ try (getSubDirectories (outsidePath path))) >>= return . either (const []) id - trees <- mapM (\ dir -> findDebianSourceTree (appendPath ("/" ++ dir) path)) dirs + do dirs <- (liftIO $ try (getSubDirectories path)) >>= return . either (const []) id + trees <- mapM (\ dir -> findDebianSourceTree (path ++ "/" ++ dir)) dirs let trees' = catRightSeconds $ zip dirs trees return $ map (\ (subdir, tree) -> DebianBuildTree path subdir tree) trees' @@ -288,16 +289,20 @@ -- |Construct the directory name that dpkg-buildpackage expects to find the -- source code in for this package: -. +{- debDir :: DebianSourceTree -> String debDir (DebianSourceTree _ _ entry) = logPackage entry ++ "-" ++ show (logVersion entry) +-} -- |Find the .changes file which is generated by a successful run of -- dpkg-buildpackage. +{- findBuildChanges :: DebianBuildTree -> IO (Either String ChangesFile) findBuildChanges tree = do let dir = topdir tree - result <- findChangesFiles (outsidePath dir) + result <- findChangesFiles dir case result of [cf] -> return (Right cf) - [] -> return (Left ("Couldn't find .changes file in " ++ outsidePath dir)) - lst -> return (Left ("Multiple .changes files in " ++ outsidePath dir ++ ": " ++ show lst)) + [] -> return (Left ("Couldn't find .changes file in " ++ dir)) + lst -> return (Left ("Multiple .changes files in " ++ dir ++ ": " ++ show lst)) +-} diff --git a/Debian/Repo/Types.hs b/Debian/Repo/Types.hs --- a/Debian/Repo/Types.hs +++ b/Debian/Repo/Types.hs @@ -67,7 +67,7 @@ import Network.URI import System.FilePath (()) import System.Posix.Types -import System.Unix.Process +--import System.Unix.Process -- |The root directory of an OS image. data EnvRoot = EnvRoot { rootPath :: FilePath } deriving (Ord, Eq, Read, Show) diff --git a/Debian/Report.hs b/Debian/Report.hs --- a/Debian/Report.hs +++ b/Debian/Report.hs @@ -1,6 +1,6 @@ module Debian.Report where -import Debian.Apt.Index (Fetcher(..), Compression(..), update, controlFromIndex') +import Debian.Apt.Index (Fetcher, Compression(..), update, controlFromIndex') import Debian.Control.ByteString import Debian.Repo.Types import Debian.Version diff --git a/Debian/URI.hs b/Debian/URI.hs --- a/Debian/URI.hs +++ b/Debian/URI.hs @@ -7,7 +7,7 @@ ) where import Control.Exception (Exception(..), try) -import Control.Monad.Trans (MonadIO) +--import Control.Monad.Trans (MonadIO) import qualified Data.ByteString.Lazy.Char8 as L import Extra.Net (webServerDirectoryContents) import Network.URI @@ -42,7 +42,8 @@ cmdOutput :: String -> IO (Either Exception L.ByteString) cmdOutput cmd = - do (out, err, code) <- lazyCommand cmd L.empty >>= return . collectOutput + do (out, _err, code) <- lazyCommand cmd L.empty >>= return . collectOutput case code of - [ExitSuccess] -> return (Right out) - [ExitFailure _] -> return . Left . ErrorCall $ "Failure: " ++ show cmd + (ExitSuccess : _) -> return (Right out) + (ExitFailure _ : _) -> return . Left . ErrorCall $ "Failure: " ++ show cmd + [] -> return . Left . ErrorCall $ "Failure: no exit code" diff --git a/Debian/Version/Common.hs b/Debian/Version/Common.hs --- a/Debian/Version/Common.hs +++ b/Debian/Version/Common.hs @@ -90,12 +90,14 @@ -- can currently happen. Are there any invalid version strings? -- Perhaps ones with underscore, or something? +{- showNN :: NonNumeric -> String showNN (NonNumeric s n) = s ++ showN n showN :: Found Numeric -> String showN (Found (Numeric n nn)) = show n ++ maybe "" showNN nn showN (Simulated _) = "" +-} parseDV :: CharParser () (Found Int, NonNumeric, Found NonNumeric) parseDV = @@ -129,12 +131,14 @@ <|> return (Simulated (Numeric 0 Nothing)) +{- compareTest :: String -> String -> Ordering compareTest str1 str2 = let v1 = either (error . show) id $ parse parseDV str1 str1 v2 = either (error . show) id $ parse parseDV str2 str2 in compare v1 v2 +-} -- |Split a DebianVersion into its three components: epoch, version, -- revision. It is not safe to use the parsed version number for diff --git a/Distribution/Package/Debian.hs b/Distribution/Package/Debian.hs --- a/Distribution/Package/Debian.hs +++ b/Distribution/Package/Debian.hs @@ -24,7 +24,7 @@ import Data.List import qualified Data.Map as Map import Data.Maybe -import Data.Version (Version(..), showVersion) +import Data.Version (showVersion) import Debian.Control import qualified Debian.Relation as D import qualified Debian.Repo as D @@ -39,32 +39,31 @@ import System.Posix.Files (setFileCreationMask) import System.Unix.Process import System.Environment -import Text.ParserCombinators.ReadP +--import Text.ParserCombinators.ReadP import Distribution.Text (display) import Distribution.Simple.Compiler (CompilerFlavor(..), compilerFlavor, Compiler(..)) -import Distribution.Simple.Configure (localBuildInfoFile) +--import Distribution.Simple.Configure (localBuildInfoFile) import Distribution.System (buildOS, buildArch) import Distribution.License (License(..)) import Distribution.Package (Package(..), PackageIdentifier(..), PackageName(..), Dependency(..)) import Distribution.Simple.Program (defaultProgramConfiguration) -import Distribution.Simple.Configure (configCompiler, configure, maybeGetPersistBuildConfig) -import Distribution.Simple.InstallDirs (InstallDirs(..), InstallDirTemplates(..), toPathTemplate) +import Distribution.Simple.Configure (configCompiler, maybeGetPersistBuildConfig) +import Distribution.Simple.InstallDirs (InstallDirs(..), InstallDirTemplates, toPathTemplate) import Distribution.Simple.Register (writeInstalledConfig) -import Distribution.Simple.Setup (defaultRegisterFlags) +--import Distribution.Simple.Setup (defaultRegisterFlags) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) -import Distribution.Simple.PackageIndex (PackageIndex(..), fromList) +import Distribution.Simple.PackageIndex (fromList) import Distribution.Simple.Utils (die, setupMessage) import Distribution.PackageDescription (GenericPackageDescription(..), PackageDescription(..), - emptyHookedBuildInfo, allBuildInfo, buildTools, pkgconfigDepends, - exeName, BuildType(..)) + exeName) import Distribution.PackageDescription.Configuration (finalizePackageDescription) import Distribution.ParseUtils (parseQuoted) import Distribution.Verbosity (Verbosity) import Distribution.Version (VersionRange(..)) -import Distribution.Simple.Setup (ConfigFlags (..), toFlag, defaultConfigFlags, defaultDistPref) +import Distribution.Simple.Setup (defaultDistPref) import Distribution.Package.Debian.Setup (Flags(..), DebAction(..), DebType(..)) import Distribution.Package.Debian.Bundled import qualified Distribution.Compat.ReadP as ReadP @@ -131,7 +130,7 @@ do (compiler, pkgDesc) <- simplePackageDescription genPkgDesc flags let verbose = rpmVerbosity flags createDirectoryIfMissing True (debOutputDir flags) - lbi <- localBuildInfo pkgDesc flags + --lbi <- localBuildInfo pkgDesc flags debVersions <- buildDebVersionMap cabalPackages <- libPaths compiler debVersions >>= return . Map.fromList . map (\ p -> (cabalName p, p)) bracket (setFileCreationMask 0o022) setFileCreationMask $ \ _ -> do @@ -198,7 +197,7 @@ -> Map.Map String PackageInfo -- ^The list of installed cabal packages -> DebType -- ^The type of deb we want to write substvars for -> IO () -substvars pkgDesc compiler debVersions control cabalPackages debType = +substvars pkgDesc _compiler _debVersions control cabalPackages debType = case (missingBuildDeps, path) of -- There should already be a .substvars file produced by dh_haskell_prep, -- keep the relations listed there. They will contain something like this: @@ -214,7 +213,7 @@ hPutStrLn stderr (if new /= old then ("cabal-debian - Updated " ++ show path' ++ ":\n " ++ old ++ "\n ->\n " ++ new) else ("cabal-debian - No updates found for " ++ show path')) - maybe (return ()) (\ x -> replaceFile path' new) name + maybe (return ()) (\ _x -> replaceFile path' new) name ([], Nothing) -> return () (missing, _) -> die $ "These debian packages need to be added to the build dependency list so the required cabal packages are available:\n " ++ intercalate "\n " (map fst missing) where @@ -244,20 +243,20 @@ -- which are build dependencies devDeps :: D.Relations devDeps = - catMaybes (map (\ dep@(Dependency (PackageName name) _) -> + catMaybes (map (\ (Dependency (PackageName name) _) -> case Map.lookup name cabalPackages :: Maybe PackageInfo of Just package -> maybe Nothing (\ (s, v) -> Just [D.Rel s (Just (D.GRE v)) Nothing]) (devDeb package) Nothing -> Nothing) cabalDeps) profDeps :: D.Relations profDeps = maybe [] (\ name -> [[D.Rel name Nothing Nothing]]) devDebName ++ - catMaybes (map (\ dep@(Dependency (PackageName name) _) -> + catMaybes (map (\ (Dependency (PackageName name) _) -> case Map.lookup name cabalPackages :: Maybe PackageInfo of Just package -> maybe Nothing (\ (s, v) -> Just [D.Rel s (Just (D.GRE v)) Nothing]) (profDeb package) Nothing -> Nothing) cabalDeps) docDeps :: D.Relations docDeps = - catMaybes (map (\ dep@(Dependency (PackageName name) _) -> + catMaybes (map (\ (Dependency (PackageName name) _) -> case Map.lookup name cabalPackages :: Maybe PackageInfo of Just package -> maybe Nothing (\ (s, v) -> Just [D.Rel s (Just (D.GRE v)) Nothing]) (docDeb package) Nothing -> Nothing) cabalDeps) @@ -267,13 +266,13 @@ buildDepNames = concat (map (map (\ (D.Rel s _ _) -> s)) buildDeps) buildDeps :: D.Relations buildDeps = (either (error . show) id . D.parseRelations $ bd) ++ (either (error . show) id . D.parseRelations $ bdi) - sourceName = maybe (error "Invalid control file") (\ (Field (_, s)) -> stripWS s) (lookupP "Source" (head (unControl control))) + --sourceName = maybe (error "Invalid control file") (\ (Field (_, s)) -> stripWS s) (lookupP "Source" (head (unControl control))) devDebName = listToMaybe (filter (isSuffixOf "-dev") debNames) profDebName = listToMaybe (filter (isSuffixOf "-prof") debNames) docDebName = listToMaybe (filter (isSuffixOf "-doc") debNames) debNames = map (\ (Field (_, s)) -> stripWS s) (catMaybes (map (lookupP "Package") (tail (unControl control)))) - bd = maybe "" (\ (Field (a, b)) -> stripWS b) . lookupP "Build-Depends" . head . unControl $ control - bdi = maybe "" (\ (Field (a, b)) -> stripWS b) . lookupP "Build-Depends-Indep" . head . unControl $ control + bd = maybe "" (\ (Field (_a, b)) -> stripWS b) . lookupP "Build-Depends" . head . unControl $ control + bdi = maybe "" (\ (Field (_a, b)) -> stripWS b) . lookupP "Build-Depends-Indep" . head . unControl $ control -- |Write a file which we might still be reading from in -- order to compute the text argument. @@ -316,20 +315,20 @@ , docDeb = maybe Nothing (\ x -> Just (x, debVersions ! x)) doc })) parseNameVersion s = case (break (== '-') (reverse s)) of - (a, "") -> Nothing + (_a, "") -> Nothing (a, b) -> Just (reverse (tail b), reverse a) -- |Given a path, return the name of the package that owns it. debOfFile :: FilePath -> IO (Maybe String) debOfFile s = - do (out, err, code) <- lazyCommand cmd L.empty >>= return . collectOutputUnpacked + do (out, _err, code) <- lazyCommand cmd L.empty >>= return . collectOutputUnpacked case code of [ExitSuccess] -> return (takePackageName out) _ -> return Nothing where cmd = "cd /var/lib/dpkg/info && grep '" ++ s ++ "' *.list" -- We already know here that suff actually is a suffix of s - dropSuffix suff s = take (length s - length suff) s + --dropSuffix suff s = take (length s - length suff) s takePackageName :: String -> Maybe String takePackageName s = @@ -337,9 +336,10 @@ where f name ('.':'l':'i':'s':'t':':':_) = Just (reverse name) f name (x : xs) = f (x : name) xs - f name [] = Nothing + f _ [] = Nothing -- Determine the documentation package name. Look for .haddock +{- devToDoc :: Compiler -> String -> IO (Maybe String) devToDoc compiler name | compilerFlavor compiler == GHC = @@ -364,9 +364,10 @@ dropPrefix pref s = case isPrefixOf pref s of True -> Just (drop (length pref) s) False -> Nothing +-} -cond ifF ifT False = ifF -cond ifF ifT True = ifT +cond ifF _ifT False = ifF +cond _ifF ifT True = ifT debianize force pkgDesc flags compiler tgtPfx = mapM_ removeIfExists ["debian/control", "debian/changelog"] >> @@ -382,7 +383,7 @@ -> Compiler -- ^compiler details -> FilePath -- ^directory in which to create files -> IO () -updateDebianization force pkgDesc flags compiler tgtPfx = +updateDebianization _force pkgDesc flags compiler tgtPfx = do createDirectoryIfMissing True "debian" date <- getCurrentLocalRFC822Time copyright <- try (readFile (licenseFile pkgDesc)) >>= @@ -446,6 +447,7 @@ ["# How to install an extra file into the documentation package", "#binary-fixup/libghc6-" ++ libName ++ "-doc::", "#\techo \"Some informative text\" > debian/libghc6-" ++ libName ++ "-doc/usr/share/doc/libghc6-" ++ libName ++ "-doc/AnExtraDocFile"] +{- devrules = case (library pkgDesc, executables pkgDesc) of (_, []) -> [] @@ -462,6 +464,7 @@ [["binary-fixup/" ++ (debianProfilingPackageName libName) ++ "::"] ++ map (\ exec -> "\trm debian/" ++ (debianProfilingPackageName libName) ++ "/usr/lib/haskell-packages/ghc6/bin/" ++ exeName exec) (executables pkgDesc)] +-} libName = unPackageName . pkgName . package $ pkgDesc list :: b -> ([a] -> b) -> [a] -> b @@ -469,14 +472,15 @@ controlUpdate :: FilePath -> Flags -> Compiler -> String -> PackageDescription -> IO () controlUpdate path flags compiler debianMaintainer pkgDesc = + builtIns compiler >>= \bundled -> try (readFile path) >>= - either (\ _ -> writeFile path (show newCtl)) (\ s -> writeFile (path ++ ".new") $! show (merge newCtl (oldCtl s))) + either (\ _ -> writeFile path (show (newCtl bundled))) (\ s -> writeFile (path ++ ".new") $! show (merge (newCtl bundled) (oldCtl s))) where - newCtl = control flags compiler debianMaintainer pkgDesc + newCtl bundled = control flags bundled compiler debianMaintainer pkgDesc oldCtl s = either (const (Control [])) id (parseControl "debian/control" s) merge (Control new) (Control old) = case (new, old) of - (newSource : new', []) -> Control new + (_newSource : _new', []) -> Control new (newSource : new', oldSource : old') -> Control (mergeParagraphs newSource oldSource : mergeOther new' old') -- Merge a list of binary package paragraphs @@ -529,8 +533,8 @@ depPackageNames xs = nub (map depPackageName xs) depPackageName (D.Rel x _ _) = x -control :: Flags -> Compiler -> String -> PackageDescription -> Control -control flags compiler debianMaintainer pkgDesc = +control :: Flags -> [Bundled] -> Compiler -> String -> PackageDescription -> Control +control flags bundled compiler debianMaintainer pkgDesc = Control {unControl = ([sourceSpec] ++ develLibrarySpecs ++ @@ -538,7 +542,7 @@ docLibrarySpecs ++ map executableSpec (executables pkgDesc))} where - buildDepsIndep = "" + --buildDepsIndep = "" sourceSpec = Paragraph ([Field ("Source", " " ++ debianSourcePackageName pkgDesc), @@ -574,10 +578,10 @@ "-doc" -> docPrefix (unPackageName . pkgName . package $ pkgDesc) _ -> error $ "Unknown suffix: " ++ suffix libraryDependencies :: String -> D.Relations - libraryDependencies "-dev" = concat . map (debianDependencies compiler develDependencies) . allBuildDepends $ pkgDesc + libraryDependencies "-dev" = concat . map (debianDependencies bundled compiler develDependencies) . allBuildDepends $ pkgDesc libraryDependencies "-prof" = [[D.Rel (debianDevelPackageName (unPackageName . pkgName . package $ pkgDesc)) Nothing Nothing]] ++ - (concat . map (debianDependencies compiler profilingDependencies) . allBuildDepends $ pkgDesc) - libraryDependencies "-doc" = [D.Rel "ghc6-doc" Nothing Nothing] : (concat . map (debianDependencies compiler docDependencies) . allBuildDepends $ pkgDesc) + (concat . map (debianDependencies bundled compiler profilingDependencies) . allBuildDepends $ pkgDesc) + libraryDependencies "-doc" = [D.Rel "ghc6-doc" Nothing Nothing] : (concat . map (debianDependencies bundled compiler docDependencies) . allBuildDepends $ pkgDesc) libraryDependencies suffix = error $ "Unexpected library package name suffix: " ++ show suffix -- The haskell-cdbs package contains the hlibrary.mk file with -- the rules for building haskell packages. @@ -589,7 +593,7 @@ [D.Rel "ghc6-doc" Nothing Nothing], [D.Rel "haddock" Nothing Nothing]] ++ (if debLibProf flags then [[D.Rel "ghc6-prof" Nothing Nothing]] else []) ++ - (concat . map (debianDependencies compiler buildDependencies) . allBuildDepends $ pkgDesc) + (concat . map (debianDependencies bundled compiler buildDependencies) . allBuildDepends $ pkgDesc) debianDescription = (synopsis pkgDesc) ++ case description pkgDesc of @@ -623,9 +627,9 @@ -- library is required as a build dependency we need the profiling -- version, which pulls in the regular version, and we need the -- documentation so the cross references can be resolved. -debianDependencies :: Compiler -> (Compiler -> Dependency -> D.Relations) -> Dependency -> D.Relations -debianDependencies compiler toDebRels dep | isBundled compiler dep = [] -debianDependencies compiler toDebRels dep = toDebRels compiler dep +debianDependencies :: [Bundled] -> Compiler -> (Compiler -> Dependency -> D.Relations) -> Dependency -> D.Relations +debianDependencies bundled compiler toDebRels dep | isBundled bundled compiler dep = [] +debianDependencies _ compiler toDebRels dep = toDebRels compiler dep changelogUpdate :: FilePath -> String -> PackageDescription -> String -> IO () changelogUpdate path debianMaintainer pkgDesc date = @@ -655,7 +659,7 @@ debianDevelPackageName :: String -> String debianDevelPackageName x = "libghc6-" ++ map toLower x ++ "-dev" -debianDevelPackageName' (Dependency (PackageName name) _) = debianDevelPackageName name +--debianDevelPackageName' (Dependency (PackageName name) _) = debianDevelPackageName name -- debianPackageName prefix name suffix = prefix ++ (map toLower name) ++ suffix diff --git a/Distribution/Package/Debian/Bundled.hs b/Distribution/Package/Debian/Bundled.hs --- a/Distribution/Package/Debian/Bundled.hs +++ b/Distribution/Package/Debian/Bundled.hs @@ -14,44 +14,133 @@ module Distribution.Package.Debian.Bundled ( - bundledWith + Bundled + , bundledWith , isBundled , isLibrary , docPrefix + , builtIns ) where -import Data.List (find) +import qualified Data.ByteString.Char8 as B +import Data.Function (on) +import Data.List (find,isPrefixOf,sortBy) +import Data.Maybe (maybeToList) import Data.Version (Version(..)) -import Distribution.Simple.Compiler (Compiler(..), CompilerId(..), CompilerFlavor(..), compilerFlavor) +import Debian.Control(Control'(Control), fieldValue, parseControlFromFile) +import Debian.Relation.ByteString() +import Debian.Relation(Relation(Rel),parseRelations) +import Distribution.InstalledPackageInfo(InstalledPackageInfo, libraryDirs, package) +import Distribution.Simple.Compiler (Compiler(..), CompilerId(..), CompilerFlavor(..), PackageDB(GlobalPackageDB), compilerFlavor) +import Distribution.Simple.Configure (getInstalledPackages) +-- import Distribution.Simple.GHC (getInstalledPackages) +import Distribution.Simple.PackageIndex (PackageIndex, SearchResult(None, Unambiguous, Ambiguous), allPackages, searchByName) +import Distribution.Simple.Program (configureAllKnownPrograms, defaultProgramConfiguration) import Distribution.Package (PackageIdentifier(..), PackageName(..), Dependency(..)) +import Distribution.Verbosity(normal) import Distribution.Version (withinRange) +import Text.ParserCombinators.Parsec(ParseError) +import Text.Regex.Posix ((=~)) -- | List the packages bundled with this version of the given -- compiler. If the answer is not known, return the empty list. -bundledWith :: Compiler -> Maybe [PackageIdentifier] -bundledWith c = +bundledWith :: [(CompilerFlavor, Version, [PackageIdentifier])] -> Compiler -> Maybe [PackageIdentifier] +bundledWith builtIns c = let cv = (compilerFlavor c, (\ (CompilerId _ v) -> v) $ compilerId c) in thd `fmap` find (\(n,v,_) -> (n,v) == cv) builtIns where thd (_,_,x) = x -- | Determine whether a specific version of a Haskell package is -- bundled with into this particular version of the given compiler. -isBundled :: Compiler -> Dependency -> Bool -isBundled c (Dependency pkg version) = maybe False checkVersion $ do +isBundled :: [(CompilerFlavor, Version, [PackageIdentifier])] -> Compiler -> Dependency -> Bool +isBundled builtIns c (Dependency pkg version) = let cv = (compilerFlavor c, (\ (CompilerId _ v) -> v) (compilerId c)) - (_, _, cb) <- find (\(n, k, _) -> (n,k) == cv) builtIns - pkgVersion `fmap` find ((== pkg) . pkgName) cb + in + case find (\(n, k, _) -> (n,k) == cv) builtIns of + Nothing -> False + (Just (_, _, cb)) -> + any checkVersion $ pkgVersion `fmap` filter ((== pkg) . pkgName) cb where checkVersion = flip withinRange version -builtIns :: [(CompilerFlavor, Version, [PackageIdentifier])] -builtIns = [ - (GHC, Version [6,8,3] [], ghc683BuiltIns) - , (GHC, Version [6,8,2] [], ghc682BuiltIns) - , (GHC, Version [6,8,1] [], ghc681BuiltIns) - , (GHC, Version [6,6,1] [], ghc661BuiltIns) - , (GHC, Version [6,6] [], ghc66BuiltIns) - ] +type Bundled = (CompilerFlavor, Version, [PackageIdentifier]) +builtIns :: Compiler -> IO [Bundled] +builtIns compiler = + do ghc6 <- fmap maybeToList $ ghc6BuiltIns compiler + return $ ghc6 ++ [ (GHC, Version [6,8,3] [], ghc683BuiltIns) + , (GHC, Version [6,8,2] [], ghc682BuiltIns) + , (GHC, Version [6,8,1] [], ghc681BuiltIns) + , (GHC, Version [6,6,1] [], ghc661BuiltIns) + , (GHC, Version [6,6] [], ghc66BuiltIns) + ] +ghc6BuiltIns :: Compiler -> IO (Maybe (CompilerFlavor, Version, [PackageIdentifier])) +ghc6BuiltIns compiler@(Compiler (CompilerId GHC compilerVersion) _) = + do mInstalledPackages <- getInstalledPackageIndex compiler + case mInstalledPackages of + Nothing -> error "Could not find the installed package database." + (Just installedPackages) -> + do ghc6Files <- fmap lines $ readFile "/var/lib/dpkg/info/ghc6.list" + let ghcProvides = filter (\package -> any (\dir -> elem dir ghc6Files) (libraryDirs package)) (allPackages installedPackages) + return (Just (GHC, compilerVersion, map package ghcProvides)) +ghc6BuiltIns _ = return Nothing + +ghc6BuiltIns' :: Compiler -> IO (Maybe (CompilerFlavor, Version, [PackageIdentifier])) +ghc6BuiltIns' compiler@(Compiler (CompilerId GHC compilerVersion) _) = + do eDebs <- ghc6Provides + case eDebs of + Left e -> error e + Right debNames -> + do mInstalledPackages <- getInstalledPackageIndex compiler + case mInstalledPackages of + Nothing -> error "Could not find the installed package database." + (Just installedPackages) -> + let packages = concatMap (\n -> fromRight $ installedVersions (fromRight $ extractBaseName n) installedPackages) debNames + in + return $ Just (GHC, compilerVersion, packages) + where + fromRight (Right r) = r + fromRight (Left e) = error e +ghc6BuiltIns' compiler@(Compiler _ _) = return Nothing + +ghc6Provides :: IO (Either String [String]) +ghc6Provides = + do eC <- parseControlFromFile "/var/lib/dpkg/status" :: IO (Either ParseError (Control' B.ByteString)) + case eC of + Left e -> return $ Left (show e) + Right (Control c) -> + case find (\p -> fieldValue "Package" p == Just (B.pack "ghc6")) c of + Nothing -> return $ Left "You do not seem to have ghc6 installed." + (Just p) -> + case fieldValue "Provides" p of + Nothing -> return $ Left "Your ghc6 package does not seem to Provide anything." + (Just p) -> + case parseRelations p of + (Left e) -> return (Left (show e)) + (Right relations) -> + return $ Right $ filter (isPrefixOf "libghc6-") $ map (\ (Rel pkgName _ _) -> pkgName) (concat relations) + + +extractBaseName :: String -> Either String String +extractBaseName name = + let (_,_,_,subs) = (name =~ "^libghc6-(.*)-.*$") :: (String, String, String, [String]) + in case subs of + [base] -> Right base + _ -> Left ("When attempt to extract the base name of " ++ name ++ " I found the following matches: " ++ show subs) + +getInstalledPackageIndex :: Compiler -> IO (Maybe (PackageIndex InstalledPackageInfo)) +getInstalledPackageIndex compiler = + do pc <- configureAllKnownPrograms normal defaultProgramConfiguration + getInstalledPackages normal compiler GlobalPackageDB pc + +installedVersions :: String -> PackageIndex InstalledPackageInfo -> Either String [PackageIdentifier] +installedVersions name packageIndex = + case searchByName packageIndex name of + None -> Left $ "The package " ++ name ++ " does not seem to be installed." + Unambiguous pkgs -> + case sortBy (compare `on` (pkgVersion . package)) pkgs of + [] -> Left $ "Odd. searchByName returned an empty Unambiguous match for " ++ name + ps -> Right (map package ps) + v :: String -> [Int] -> PackageIdentifier v n x = PackageIdentifier (PackageName n) (Version x []) diff --git a/Distribution/Package/Debian/Setup.hs b/Distribution/Package/Debian/Setup.hs --- a/Distribution/Package/Debian/Setup.hs +++ b/Distribution/Package/Debian/Setup.hs @@ -21,9 +21,9 @@ import Control.Monad (when) import Data.Char (toLower) -import Distribution.Compiler (CompilerFlavor(..), defaultCompilerFlavor) +import Distribution.Compiler (CompilerFlavor(..)) import Distribution.ReadE (readEOrFail) -import Distribution.PackageDescription (FlagAssignment(..), FlagName(..)) +import Distribution.PackageDescription (FlagName(..)) import Distribution.Verbosity (Verbosity, flagToVerbosity, normal) import System.Console.GetOpt (ArgDescr (..), ArgOrder (..), OptDescr (..), usageInfo, getOpt') diff --git a/debian.cabal b/debian.cabal --- a/debian.cabal +++ b/debian.cabal @@ -1,5 +1,5 @@ Name: debian -Version: 3.21 +Version: 3.23 License: BSD3 License-File: debian/copyright Author: David Fox diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,17 @@ +haskell-debian (3.23) unstable; urgency=low + + * Eliminate the use of EnvPath in most places, just use a regular + path instead. There were very few places where we actually were + inside a changeroot. + + -- David Fox Thu, 29 Jan 2009 16:48:23 -0800 + +haskell-debian (3.22) unstable; urgency=low + + * cabal-debian now has autodetection of ghc6 bundled packages + + -- Jeremy Shaw Thu, 29 Jan 2009 15:26:25 -0600 + haskell-debian (3.21) unstable; urgency=low * Don't write out postinst and postrm for the doc package, they are