diff --git a/Debian/Changes.hs b/Debian/Changes.hs --- a/Debian/Changes.hs +++ b/Debian/Changes.hs @@ -34,7 +34,7 @@ , changeInfo :: S.Paragraph -- ^ The contents of the .changes file , changeEntry :: ChangeLogEntry -- ^ The value of the Changes field of the .changes file , changeFiles :: [ChangedFileSpec] -- ^ The parsed value of the Files attribute - } deriving Eq + } deriving (Eq, Show) -- |An entry in the list of files generated by the build. data ChangedFileSpec = @@ -45,7 +45,7 @@ , changedFileSection :: SubSection , changedFilePriority :: String , changedFileName :: FilePath - } deriving Eq + } deriving (Eq, Show) -- |A changelog is a series of ChangeLogEntries data ChangeLogEntry = @@ -58,7 +58,7 @@ , logDate :: String } | WhiteSpace String - deriving Eq + deriving (Eq, Show) {- instance Show ChangesFile where @@ -177,7 +177,7 @@ parseEntry :: String -> Either [String] (ChangeLogEntry, String) parseEntry text = case text =~ entryRE :: MatchResult String of - x | mrSubList x == [] -> Left ["Parse error at " ++ show text] + x | mrSubList x == [] -> Left ["Parse error in " ++ show text] x@MR {mrAfter = after, mrSubList = [_, name, version, dists, urgency, _, details, _, _, who, _, date, _]} -> Right (Entry name (parseDebianVersion version) diff --git a/Debian/Deb.hs b/Debian/Deb.hs --- a/Debian/Deb.hs +++ b/Debian/Deb.hs @@ -2,6 +2,7 @@ import Control.Monad +import Data.ByteString.Lazy (empty) import Debian.Control.Common import System.Unix.Directory import System.Unix.FilePath @@ -12,9 +13,9 @@ withTemporaryDirectory ("fields.XXXXXX") $ \tmpdir -> do debFP <- realpath debFP withWorkingDirectory tmpdir $ - do (out, err, res) <- simpleProcess "ar" ["x",debFP,"control.tar.gz"] + do (out, err, res) <- lazyProcess "ar" ["x",debFP,"control.tar.gz"] Nothing Nothing empty >>= return . collectOutputUnpacked when (res /= ExitSuccess) (error $ "Dpkg.fields: " ++ out ++ "\n" ++ err ++ "\n" ++ show res) - (out, err, res) <- simpleProcess "tar" ["xzf", "control.tar.gz", "./control"] + (out, err, res) <- lazyProcess "tar" ["xzf", "control.tar.gz", "./control"] Nothing Nothing empty >>= return . collectOutputUnpacked when (res /= ExitSuccess) (error $ "Dpkg.fields: " ++ out ++ "\n" ++ err ++ "\n" ++ show res) c <- parseControlFromFile "control" case c of diff --git a/Debian/Relation/String.hs b/Debian/Relation/String.hs --- a/Debian/Relation/String.hs +++ b/Debian/Relation/String.hs @@ -48,7 +48,8 @@ return rel pOrRelation :: RelParser OrRelation -pOrRelation = do rel <- sepBy1 pRelation (char '|') +pOrRelation = do skipMany (char ',' <|> whiteChar) + rel <- sepBy1 pRelation (char '|') skipMany (char ',' <|> whiteChar) return rel diff --git a/Debian/Release.hs b/Debian/Release.hs --- a/Debian/Release.hs +++ b/Debian/Release.hs @@ -1,4 +1,17 @@ -module Debian.Release where +module Debian.Release + ( ReleaseName(..) + , parseReleaseName + , releaseName' + , Arch(..) + , archName + , Section(..) + , SubSection(..) + , sectionName + , sectionName' + , sectionNameOfSubSection + , parseSection + , parseSection' + ) where import Debian.URI @@ -28,7 +41,7 @@ -- |A package's subsection is only evident in its control information, -- packages from different subsections all reside in the same index. -data SubSection = SubSection { section :: Section, subSectionName :: String } deriving (Read, {-Show,-} Eq, Ord) +data SubSection = SubSection { section :: Section, subSectionName :: String } deriving (Read, Show, Eq, Ord) sectionName :: SubSection -> String sectionName (SubSection (Section "main") y) = y diff --git a/Debian/URI.hs b/Debian/URI.hs --- a/Debian/URI.hs +++ b/Debian/URI.hs @@ -7,17 +7,21 @@ , dirFromURI ) where -import Control.Exception (ErrorCall(ErrorCall), try) +import Control.Exception (SomeException, {-ErrorCall(ErrorCall),-} try) --import Control.Monad.Trans (MonadIO) import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString as B import Data.Maybe (catMaybes) import Network.URI import System.Directory (getDirectoryContents) -import System.Exit -import System.Unix.Process (lazyCommand, collectOutput) +--import System.Exit +--import System.Unix.Process (lazyCommand, collectOutput) +import System.Unix.Process (collectStdout) +import System.Unix.Progress (lazyCommandSF, quieter) +--import System.Unix.ProcessExtra (cmdOutput, cmdOutputStrict) import Text.Regex (mkRegex, matchRegex) +uriToString' :: URI -> String uriToString' uri = uriToString id uri "" instance Ord URI where @@ -26,21 +30,26 @@ -- |If the URI type could be read and showed this wouldn't be necessary. type URIString = String -fileFromURI :: URI -> IO (Either ErrorCall L.ByteString) +fileFromURI :: URI -> IO (Either SomeException L.ByteString) fileFromURI uri = case (uriScheme uri, uriAuthority uri) of ("file:", Nothing) -> try (L.readFile (uriPath uri)) - ("ssh:", Just auth) -> cmdOutput ("ssh " ++ uriUserInfo auth ++ uriRegName auth ++ uriPort auth ++ - " cat " ++ show (uriPath uri)) - _ -> cmdOutput ("curl -s -g '" ++ uriToString' uri ++ "'") + -- ("ssh:", Just auth) -> cmdOutput ("ssh " ++ uriUserInfo auth ++ uriRegName auth ++ uriPort auth ++ " cat " ++ show (uriPath uri)) + ("ssh:", Just auth) -> try (lazyCommandSF ("ssh " ++ uriUserInfo auth ++ uriRegName auth ++ uriPort auth ++ " cat " ++ show (uriPath uri)) L.empty >>= + return . fst . collectStdout) + _ -> try (lazyCommandSF ("curl -s -g '" ++ uriToString' uri ++ "'") L.empty >>= + return . fst . collectStdout) -fileFromURIStrict :: URI -> IO (Either ErrorCall B.ByteString) +fileFromURIStrict :: URI -> IO (Either SomeException B.ByteString) fileFromURIStrict uri = case (uriScheme uri, uriAuthority uri) of ("file:", Nothing) -> try (B.readFile (uriPath uri)) - ("ssh:", Just auth) -> cmdOutputStrict ("ssh " ++ uriUserInfo auth ++ uriRegName auth ++ uriPort auth ++ - " cat " ++ show (uriPath uri)) - _ -> cmdOutputStrict ("curl -s -g '" ++ uriToString' uri ++ "'") + -- ("ssh:", Just auth) -> cmdOutputStrict ("ssh " ++ uriUserInfo auth ++ uriRegName auth ++ uriPort auth ++ " cat " ++ show (uriPath uri)) + ("ssh:", Just auth) -> try (lazyCommandSF ("ssh " ++ uriUserInfo auth ++ uriRegName auth ++ uriPort auth ++ " cat " ++ show (uriPath uri)) L.empty >>= + return . B.concat . L.toChunks . fst . collectStdout) + _ -> try (lazyCommandSF ("curl -s -g '" ++ uriToString' uri ++ "'") L.empty >>= + return . B.concat . L.toChunks . fst . collectStdout) + -- _ -> cmdOutputStrict ("curl -s -g '" ++ uriToString' uri ++ "'") -- | Parse the text returned when a directory is listed by a web -- server. This is currently only known to work with Apache. @@ -55,38 +64,12 @@ second _ = Nothing -dirFromURI :: URI -> IO (Either ErrorCall [String]) +dirFromURI :: URI -> IO (Either SomeException [String]) dirFromURI uri = case (uriScheme uri, uriAuthority uri) of ("file:", Nothing) -> try (getDirectoryContents (uriPath uri)) - ("ssh:", Just auth) -> cmdOutput ("ssh " ++ uriUserInfo auth ++ uriRegName auth ++ uriPort auth ++ - " ls -1 " ++ uriPath uri) >>= - return . either Left (Right . lines . L.unpack) - _ -> cmdOutput ("curl -s -g '" ++ uriToString' uri ++ "/'") >>= return . either Left (Right . webServerDirectoryContents) - - - -cmdOutput :: String -> IO (Either ErrorCall L.ByteString) -cmdOutput cmd = - do (out, _err, code) <- lazyCommand cmd L.empty >>= return . collectOutput - case code of - (ExitSuccess : _) -> return (Right out) - (ExitFailure _ : _) -> return . Left . ErrorCall $ "Failure: " ++ show cmd - [] -> return . Left . ErrorCall $ "Failure: no exit code" - -cmdOutputStrict :: String -> IO (Either ErrorCall B.ByteString) -cmdOutputStrict cmd = - do (out, _err, code) <- lazyCommand cmd L.empty >>= return . f . collectOutput - case code of - (ExitSuccess : _) -> return (Right out) - (ExitFailure _ : _) -> return . Left . ErrorCall $ "Failure: " ++ show cmd - [] -> return . Left . ErrorCall $ "Failure: no exit code" - where - f :: (L.ByteString, L.ByteString, [ExitCode]) -> (B.ByteString, B.ByteString, [ExitCode]) - f (o, e, c) = (toStrict o, toStrict e, c) - -toLazy :: B.ByteString -> L.ByteString -toLazy b = L.fromChunks [b] - -toStrict :: L.ByteString -> B.ByteString -toStrict b = B.concat (L.toChunks b) + -- ("ssh:", Just auth) -> cmdOutput ("ssh " ++ uriUserInfo auth ++ uriRegName auth ++ uriPort auth ++ " ls -1 " ++ uriPath uri) >>= + ("ssh:", Just auth) -> try (lazyCommandSF ("ssh " ++ uriUserInfo auth ++ uriRegName auth ++ uriPort auth ++ " ls -1 " ++ uriPath uri) L.empty >>= + return . lines . L.unpack . fst . collectStdout) + -- _ -> cmdOutput ("curl -s -g '" ++ uriToString' uri ++ "/'") >>= return . either Left (Right . webServerDirectoryContents) + _ -> try (lazyCommandSF ("curl -s -g '" ++ uriToString' uri ++ "/'") L.empty >>= return . webServerDirectoryContents . fst . collectStdout) diff --git a/Distribution/Package/Debian.hs b/Distribution/Package/Debian.hs --- a/Distribution/Package/Debian.hs +++ b/Distribution/Package/Debian.hs @@ -62,7 +62,7 @@ import Distribution.PackageDescription.Configuration (finalizePackageDescription) import Distribution.ParseUtils (parseQuoted) import Distribution.Verbosity (Verbosity) -import Distribution.Version (VersionRange(..)) +import Distribution.Version (Version(..),VersionRange(..)) import Distribution.Simple.Setup (defaultDistPref) import Distribution.Package.Debian.Setup (Flags(..), DebAction(..), DebType(..)) import Distribution.Package.Debian.Bundled @@ -333,7 +333,7 @@ debOfFile s = do (out, _err, code) <- lazyCommand cmd L.empty >>= return . collectOutputUnpacked case code of - [ExitSuccess] -> return (takePackageName out) + ExitSuccess -> return (takePackageName out) _ -> return Nothing where cmd = "cd /var/lib/dpkg/info && grep '" ++ s ++ "' *.list" @@ -731,7 +731,7 @@ debianRelations :: String -> VersionRange -> D.Relations debianRelations name range = - map (merge . map (relation name)) (canon range) + map (merge . concat . map (relation name)) (canon range) where -- A debian dependency list is always a list of or-relations -- which are anded. This function turns the more freeform cabal @@ -741,10 +741,11 @@ canon (UnionVersionRanges a b) = map concat (cartesianProduct [canon a, canon b]) canon x = [[x]] -- Turn simple Cabal relations into Debian relations - relation name AnyVersion = D.Rel name Nothing Nothing - relation name (ThisVersion version) = D.Rel name (Just (D.EEQ (parseDebianVersion (showVersion version)))) Nothing - relation name (EarlierVersion version) = D.Rel name (Just (D.SLT (parseDebianVersion (showVersion version)))) Nothing - relation name (LaterVersion version) = D.Rel name (Just (D.SGR (parseDebianVersion (showVersion version)))) Nothing + relation name AnyVersion = [D.Rel name Nothing Nothing] + relation name (ThisVersion version) = [D.Rel name (Just (D.EEQ (parseDebianVersion (showVersion version)))) Nothing] + relation name (EarlierVersion version) = [D.Rel name (Just (D.SLT (parseDebianVersion (showVersion version)))) Nothing] + relation name (LaterVersion version) = [D.Rel name (Just (D.SGR (parseDebianVersion (showVersion version)))) Nothing] + relation name (WildcardVersion version) = [D.Rel name (Just (D.GRE (parseDebianVersion (showVersion version)))) Nothing, D.Rel name (Just (D.SLT (parseDebianVersion (showVersion (upperBound version))))) Nothing] relation _ _ = error $ "Invalid argument to debianRelations: " ++ show range -- Merge some combinations that frequently show up. merge (D.Rel name1 (Just (D.EEQ ver1)) arch1 : D.Rel name2 (Just (D.SLT ver2)) arch2 : xs) @@ -755,6 +756,9 @@ = merge (D.Rel name1 (Just (D.GRE ver1)) arch1 : xs) merge (x : xs) = x : merge xs merge [] = [] + upperBound v = v { versionBranch = bump (versionBranch v) } + bump = reverse . (zipWith (+) (1:(repeat 0))) . reverse + debianDocumentationPackageName :: String -> String debianDocumentationPackageName x = 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 @@ -74,7 +74,7 @@ , (GHC, Version [6,6] [], ghc66BuiltIns) ] ghc6BuiltIns :: Compiler -> IO (Maybe (CompilerFlavor, Version, [PackageIdentifier])) -ghc6BuiltIns compiler@(Compiler (CompilerId GHC compilerVersion) _) = +ghc6BuiltIns compiler@(Compiler {compilerId = CompilerId GHC compilerVersion}) = #ifdef CABAL19 do installedPackages <- getInstalledPackageIndex compiler ghc6Files <- fmap lines $ readFile "/var/lib/dpkg/info/ghc6.list" @@ -92,7 +92,7 @@ ghc6BuiltIns _ = return Nothing ghc6BuiltIns' :: Compiler -> IO (Maybe (CompilerFlavor, Version, [PackageIdentifier])) -ghc6BuiltIns' compiler@(Compiler (CompilerId GHC compilerVersion) _) = +ghc6BuiltIns' compiler@(Compiler {compilerId = CompilerId GHC compilerVersion}) = do eDebs <- ghc6Provides case eDebs of Left e -> error e @@ -113,7 +113,7 @@ where fromRight (Right r) = r fromRight (Left e) = error e -ghc6BuiltIns' compiler@(Compiler _ _) = return Nothing +ghc6BuiltIns' compiler@(Compiler {}) = return Nothing ghc6Provides :: IO (Either String [String]) ghc6Provides = @@ -299,29 +299,4 @@ isLibrary _ _ = True docPrefix :: String -> String -{- -docPrefix "alut" = "libghc6-" -docPrefix "arrows" = "libghc6-" -docPrefix "binary" = "libghc6-" -docPrefix "cgi" = "libghc6-" -docPrefix "fgl" = "libghc6-" -docPrefix "glut" = "libghc6-" -docPrefix "haskell-src" = "libghc6-" -docPrefix "hgl" = "libghc6-" -docPrefix "html" = "libghc6-" -docPrefix "hunit" = "libghc6-" -docPrefix "mtl" = "libghc6-" -docPrefix "network" = "libghc6-" -docPrefix "openal" = "libghc6-" -docPrefix "opengl" = "libghc6-" -docPrefix "parallel" = "libghc6-" -docPrefix "parsec" = "libghc6-" -docPrefix "quickcheck" = "libghc6-" -docPrefix "stm" = "libghc6-" -docPrefix "stream" = "libghc6-" -docPrefix "time" = "libghc6-" -docPrefix "x11" = "libghc6-" -docPrefix "xhtml" = "libghc6-" -docPrefix "xmonad" = "libghc6-" --} -docPrefix _ = "haskell-" +docPrefix _ = "libghc6-" diff --git a/Test/Changes.hs b/Test/Changes.hs --- a/Test/Changes.hs +++ b/Test/Changes.hs @@ -7,8 +7,6 @@ import Debian.Release (ReleaseName(ReleaseName, relName)) import Debian.Version (parseDebianVersion) -deriving instance Show ChangeLogEntry - s3 = intercalate "\n" ["name (version) dist; urgency=urgency", " * details", diff --git a/debian.cabal b/debian.cabal --- a/debian.cabal +++ b/debian.cabal @@ -1,5 +1,5 @@ Name: debian -Version: 3.47 +Version: 3.54 License: BSD3 License-File: debian/copyright Author: David Fox @@ -22,7 +22,7 @@ Library Build-Depends: base >= 4 && < 5, bytestring, containers, directory, filepath, mtl, network, old-locale, parsec >= 2 && <4, pretty, process, - regex-tdfa, regex-compat, time, unix, bzlib, HaXml < 1.14, Unixutils, zlib, HUnit + regex-tdfa, regex-compat, time, unix, bzlib, HaXml < 1.14, Unixutils >= 1.32, zlib, HUnit ghc-options: -O2 -W -Wall if flag(cabal19) build-depends: Cabal >= 1.9