debian 3.21 → 3.23
raw patch · 22 files changed
+274/−152 lines, 22 files
Files
- Debian/Apt/Dependencies.hs +3/−3
- Debian/Apt/Index.hs +7/−1
- Debian/Apt/Methods.hs +14/−13
- Debian/Apt/Package.hs +2/−2
- Debian/GenBuildDeps.hs +6/−8
- Debian/Repo/AptImage.hs +6/−6
- Debian/Repo/Insert.hs +1/−1
- Debian/Repo/OSImage.hs +1/−1
- Debian/Repo/Package.hs +4/−4
- Debian/Repo/Release.hs +2/−2
- Debian/Repo/Repository.hs +1/−1
- Debian/Repo/Slice.hs +5/−5
- Debian/Repo/SourceTree.hs +44/−39
- Debian/Repo/Types.hs +1/−1
- Debian/Report.hs +1/−1
- Debian/URI.hs +5/−4
- Debian/Version/Common.hs +4/−0
- Distribution/Package/Debian.hs +44/−40
- Distribution/Package/Debian/Bundled.hs +106/−17
- Distribution/Package/Debian/Setup.hs +2/−2
- debian.cabal +1/−1
- debian/changelog +14/−0
Debian/Apt/Dependencies.hs view
@@ -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
Debian/Apt/Index.hs view
@@ -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
Debian/Apt/Methods.hs view
@@ -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)
Debian/Apt/Package.hs view
@@ -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
Debian/GenBuildDeps.hs view
@@ -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])
Debian/Repo/AptImage.hs view
@@ -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
Debian/Repo/Insert.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-} -- |Insert packages into a release, remove packages from a release. module Debian.Repo.Insert ( scanIncoming
Debian/Repo/OSImage.hs view
@@ -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
Debian/Repo/Package.hs view
@@ -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]
Debian/Repo/Release.hs view
@@ -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]
Debian/Repo/Repository.hs view
@@ -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
Debian/Repo/Slice.hs view
@@ -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
Debian/Repo/SourceTree.hs view
@@ -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: <packagename>-<upstreamversion>.+{- 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))+-}
Debian/Repo/Types.hs view
@@ -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)
Debian/Report.hs view
@@ -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
Debian/URI.hs view
@@ -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"
Debian/Version/Common.hs view
@@ -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
Distribution/Package/Debian.hs view
@@ -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 <cabalname>.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
Distribution/Package/Debian/Bundled.hs view
@@ -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 [])
Distribution/Package/Debian/Setup.hs view
@@ -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')
debian.cabal view
@@ -1,5 +1,5 @@ Name: debian-Version: 3.21+Version: 3.23 License: BSD3 License-File: debian/copyright Author: David Fox
debian/changelog view
@@ -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 <dsf@seereason.com> 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 <jeremy@seereason.com> 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