diff --git a/Debian/Changes.hs b/Debian/Changes.hs --- a/Debian/Changes.hs +++ b/Debian/Changes.hs @@ -7,8 +7,12 @@ , parseLog , parseEntry , parseChanges + , prettyChanges + , prettyChangesFile + , prettyEntry ) where +import Data.Char (chr) import Data.List (intercalate) import Data.Maybe import qualified Debian.Control.String as S @@ -16,7 +20,8 @@ import Debian.URI() import Debian.Version import System.Posix.Types -import Text.Regex +import Text.Regex.TDFA +import Text.PrettyPrint.HughesPJ -- |A file generated by dpkg-buildpackage describing the result of a -- package build @@ -29,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 -- |An entry in the list of files generated by the build. data ChangedFileSpec = @@ -40,91 +45,191 @@ , changedFileSection :: SubSection , changedFilePriority :: String , changedFileName :: FilePath - } + } deriving Eq -- |A changelog is a series of ChangeLogEntries -data ChangeLogEntry = Entry { logPackage :: String - , logVersion :: DebianVersion - , logDists :: [ReleaseName] - , logUrgency :: String - , logComments :: String - , logWho :: String - , logDate :: String - } +data ChangeLogEntry = + Entry { logPackage :: String + , logVersion :: DebianVersion + , logDists :: [ReleaseName] + , logUrgency :: String + , logComments :: String + , logWho :: String + , logDate :: String + } + | WhiteSpace String + deriving Eq +{- instance Show ChangesFile where show = changesFileName +-} changesFileName :: ChangesFile -> String changesFileName changes = changePackage changes ++ "_" ++ show (changeVersion changes) ++ "_" ++ archName (changeArch changes) ++ ".changes" -instance Show ChangedFileSpec where - show file = changedFileMD5sum file ++ " " ++ - show (changedFileSize file) ++ " " ++ - sectionName (changedFileSection file) ++ " " ++ - changedFilePriority file ++ " " ++ - changedFileName file +prettyChangesFile :: ChangesFile -> Doc +prettyChangesFile = text . changesFileName -instance Show ChangeLogEntry where - show (Entry package version dists urgency details who date) = - package ++ " (" ++ show version ++ ") " ++ intercalate " " (map releaseName' dists) ++ "; urgency=" ++ urgency ++ "\n\n" ++ - details ++ " -- " ++ who ++ " " ++ date ++ "\n\n" +prettyChanges :: ChangedFileSpec -> Doc +prettyChanges file = + text (changedFileMD5sum file ++ " " ++ + show (changedFileSize file) ++ " " ++ + sectionName (changedFileSection file) ++ " " ++ + changedFilePriority file ++ " " ++ + changedFileName file) +prettyEntry (Entry package version dists urgency details who date) = + text (package ++ " (" ++ show version ++ ") " ++ intercalate " " (map releaseName' dists) ++ "; urgency=" ++ urgency ++ "\n\n" ++ + details ++ " -- " ++ who ++ " " ++ date ++ "\n\n") + -- |Show just the top line of a changelog entry (for debugging output.) -showHeader :: ChangeLogEntry -> String +showHeader :: ChangeLogEntry -> Doc showHeader (Entry package version dists urgency _ _ _) = - package ++ " (" ++ show version ++ ") " ++ intercalate " " (map releaseName' dists) ++ "; urgency=" ++ urgency ++ "..." + text (package ++ " (" ++ show version ++ ") " ++ intercalate " " (map releaseName' dists) ++ "; urgency=" ++ urgency ++ "...") +{- +format is a series of entries like this: + + package (version) distribution(s); urgency=urgency + [optional blank line(s), stripped] + * change details + more change details + [blank line(s), included in output of dpkg-parsechangelog] + * even more change details + [optional blank line(s), stripped] + -- maintainer name [two spaces] date + +package and version are the source package name and version number. + +distribution(s) lists the distributions where this version should be +installed when it is uploaded - it is copied to the Distribution field +in the .changes file. See Distribution, Section 5.6.14. + +urgency is the value for the Urgency field in the .changes file for +the upload (see Urgency, Section 5.6.17). It is not possible to +specify an urgency containing commas; commas are used to separate +keyword=value settings in the dpkg changelog format (though there is +currently only one useful keyword, urgency). + +The change details may in fact be any series of lines starting with at +least two spaces, but conventionally each change starts with an +asterisk and a separating space and continuation lines are indented so +as to bring them in line with the start of the text above. Blank lines +may be used here to separate groups of changes, if desired. + +If this upload resolves bugs recorded in the Bug Tracking System +(BTS), they may be automatically closed on the inclusion of this +package into the Debian archive by including the string: closes: +Bug#nnnnn in the change details.[16] This information is conveyed via +the Closes field in the .changes file (see Closes, Section 5.6.22). + +The maintainer name and email address used in the changelog should be +the details of the person uploading this version. They are not +necessarily those of the usual package maintainer. The information +here will be copied to the Changed-By field in the .changes file (see +Changed-By, Section 5.6.4), and then later used to send an +acknowledgement when the upload has been installed. + +The date must be in RFC822 format[17]; it must include the time zone +specified numerically, with the time zone name or abbreviation +optionally present as a comment in parentheses. + +The first "title" line with the package name must start at the left +hand margin. The "trailer" line with the maintainer and date details +must be preceded by exactly one space. The maintainer details and the +date must be separated by exactly two spaces. + +The entire changelog must be encoded in UTF-8. +-} + -- |Parse a Debian Changelog and return a lazy list of entries -parseLog :: String -> [Either String ChangeLogEntry] +parseLog :: String -> [Either [String] ChangeLogEntry] +parseLog "" = [] parseLog text = case parseEntry text of - Nothing -> [] - Just (Left message) -> [Left message] - Just (Right (entry, text')) -> Right entry : parseLog text' + Left messages -> [Left messages] + Right (entry, text') -> Right entry : parseLog text' -- |Parse a single changelog entry, returning the entry and the remaining text. -parseEntry :: String -> Maybe (Either String (ChangeLogEntry, String)) -parseEntry text | dropWhile (\ x -> elem x " \t\n") text == "" = Nothing +{- +parseEntry :: String -> Failing (ChangeLogEntry, String) parseEntry text = - case matchRegexAll entryRE text of - Nothing -> Just (Left ("Parse error in changelog:\n" ++ text)) - Just ("", _, remaining, [_, name, version, dists, urgency, _, details, _, _, _, _, _, who, date, _]) -> - let entry = - Entry name - (parseDebianVersion version) - (map parseReleaseName . words $ dists) - urgency - details - who - date in - Just (Right (entry, remaining)) - Just ("", _, _remaining, submatches) -> Just (Left ("Internal error 15, submatches=" ++ show submatches)) - Just (before, _, _, _) -> Just (Left ("Parse error in changelog at:\n" ++ show before ++ "\nin:\n" ++ text)) + case span (\ x -> elem x " \t\n") text of + ("", _) -> + case matchRegexAll entryRE text of + Nothing -> Failure ["Parse error in changelog:\n" ++ show text] + Just ("", _, remaining, [_, name, version, dists, urgency, _, details, _, _, _, _, _, who, date, _]) -> + Success (Entry name + (parseDebianVersion version) + (map parseReleaseName . words $ dists) + urgency + details + who + date, + remaining) + Just (before, _, remaining, submatches) -> + Failure ["Internal error:\n text=" ++ show text ++ "\n before=" ++ show before ++ "\n remaining=" ++ show remaining ++ ", submatches=" ++ show submatches] + (w, text') -> Success (WhiteSpace (trace ("whitespace: " ++ show w) w), text') +-} + +parseEntry :: String -> Either [String] (ChangeLogEntry, String) +parseEntry text = + case text =~ entryRE :: MatchResult String of + x | mrSubList x == [] -> Left ["Parse error at " ++ show text] + x@MR {mrAfter = after, mrSubList = [_, name, version, dists, urgency, _, details, _, _, who, _, date, _]} -> + Right (Entry name + (parseDebianVersion version) + (map parseReleaseName . words $ dists) + urgency + details + (take (length who - 2) who) + date, + after) + x@MR {mrBefore = before, mrMatch = matched, mrAfter = after, mrSubList = matches} -> + Left ["Internal error\n after=" ++ show after ++ "\n " ++ show (length matches) ++ " matches: " ++ show matches] +{- +parseREs :: [Regex] -> String -> Failing ([String], String) +parseREs res text = + foldr f (Success ([], text)) entryREs where - entryRE = mkRegex $ bol ++ blankLines ++ headerRE ++ nonSigLines ++ blankLines ++ signature ++ blankLines - nonSigLines = "((( .*|\t.*| \t.*)|([ \t]*)\n)+)" - -- In the debian repository, sometimes the extra space in front of the - -- day-of-month is missing, sometimes an extra one is added. - signature = "( -- ([^\n]*) (..., ? ?.. ... .... ........ .....))[ \t]*\n" + f _ (Failure msgs) = Failure msgs + f re (Success (oldMatches, text)) = + case matchRegexAll re text of + Nothing -> Failure ["Parse error at " ++ show text] + Just (before, matched, after, newMatches) -> + Success (oldMatches ++ trace ("newMatches=" ++ show newMatches) newMatches, after) +-} +entryRE = bol ++ blankLines ++ headerRE ++ changeDetails ++ signature ++ blankLines +changeDetails = "((\n| \n| -\n|([^ ]| [^--]| -[^--])[^\n]*\n)*)" +signature = " -- ([ ]*([^ ]+ )* )([^\n]*)\n" + +{- +entryRE = mkRegexWithOpts (bol ++ blankLines ++ headerRE ++ nonSigLines ++ blankLines ++ signature ++ blankLines) False True +nonSigLines = "((( .*|\t.*| \t.*)|([ \t]*)\n)+)" +-- In the debian repository, sometimes the extra space in front of the +-- day-of-month is missing, sometimes an extra one is added. +signature = "( -- ([^\n]*) (..., ? ?.. ... .... ........ .....))[ \t]*\n" +-} + -- |Parse the changelog information that shows up in the .changes -- file, i.e. a changelog entry with no signature. parseChanges :: String -> Maybe ChangeLogEntry parseChanges text = - case matchRegex changesRE text of - Nothing -> Nothing - Just [_, name, version, dists, urgency, _, details] -> + case text =~ changesRE :: MatchResult String of + MR {mrSubList = []} -> Nothing + MR {mrSubList = [_, name, version, dists, urgency, _, details]} -> Just $ Entry name (parseDebianVersion version) (map parseReleaseName . words $ dists) urgency details "" "" - Just x -> error $ "Unexpected match: " ++ show x + MR {mrSubList = x} -> error $ "Unexpected match: " ++ show x where - changesRE = mkRegexWithOpts (bol ++ blankLines ++ optWhite ++ headerRE ++ "(.*)$") False False + changesRE = bol ++ blankLines ++ optWhite ++ headerRE ++ "(.*)$" headerRE = package ++ version ++ dists ++ urgency @@ -138,3 +243,80 @@ blankLine = "(" ++ optWhite ++ "\n)" optWhite = "[ \t]*" bol = "^" + +s1 = intercalate "\n" + ["haskell-regex-compat (0.92-3+seereason1~jaunty4) jaunty-seereason; urgency=low", + "", + " [ Joachim Breitner ]", + " * Adjust priority according to override file", + " * Depend on hscolour (Closes: #550769)", + "", + " [ Marco Túlio Gontijo e Silva ]", + " * debian/control: Use more sintetic name for Vcs-Darcs.", + " * Built from sid apt pool", + " * Build dependency changes:", + " cpphs: 1.9-1+seereason1~jaunty5 -> 1.9-1+seereason1~jaunty6", + " ghc6: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1", + " ghc6-doc: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1", + " ghc6-prof: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1", + " haddock: 2.4.2-3+seereason3~jaunty1 -> 6.12.1-0+seereason1~jaunty1", + " haskell-devscripts: 0.6.18-21+seereason1~jaunty1 -> 0.6.18-23+seereason1~jaunty1", + " haskell-regex-base-doc: 0.93.1-5+seereason1~jaunty1 -> 0.93.1-5++1+seereason1~jaunty1", + " haskell-regex-posix-doc: 0.93.2-4+seereason1~jaunty1 -> 0.93.2-4+seereason1~jaunty2", + " libghc6-regex-base-dev: 0.93.1-5+seereason1~jaunty1 -> 0.93.1-5++1+seereason1~jaunty1", + " libghc6-regex-base-prof: 0.93.1-5+seereason1~jaunty1 -> 0.93.1-5++1+seereason1~jaunty1", + " libghc6-regex-posix-dev: 0.93.2-4+seereason1~jaunty1 -> 0.93.2-4+seereason1~jaunty2", + " libghc6-regex-posix-prof: 0.93.2-4+seereason1~jaunty1 -> 0.93.2-4+seereason1~jaunty2", + "", + " -- SeeReason Autobuilder Fri, 25 Dec 2009 01:55:37 -0800", + "", + "haskell-regex-compat (0.92-3) unstable; urgency=low", + "", + " [ Joachim Breitner ]", + " * Adjust priority according to override file", + " * Depend on hscolour (Closes: #550769)", + "", + " [ Marco Túlio Gontijo e Silva ]", + " * debian/control: Use more sintetic name for Vcs-Darcs.", + "", + " -- Joachim Breitner Mon, 20 Jul 2009 13:05:35 +0200", + "", + "haskell-regex-compat (0.92-2) unstable; urgency=low", + "", + " * Adopt package for the Debian Haskell Group", + " * Fix \"FTBFS with new dpkg-dev\" by adding comma to debian/control", + " (Closes: #536473)", + "", + " -- Joachim Breitner Mon, 20 Jul 2009 12:05:40 +0200", + "", + "haskell-regex-compat (0.92-1.1) unstable; urgency=low", + "", + " * Rebuild for GHC 6.10.", + " * NMU with permission of the author.", + "", + " -- John Goerzen Mon, 16 Mar 2009 10:12:04 -0500", + "", + "haskell-regex-compat (0.92-1) unstable; urgency=low", + "", + " * New upstream release", + " * debian/control:", + " - Bump Standards-Version. No changes needed.", + "", + " -- Arjan Oosting Sun, 18 Jan 2009 00:05:02 +0100", + "", + "haskell-regex-compat (0.91-1) unstable; urgency=low", + "", + " * Take over package from Ian, as I already maintain haskell-regex-base,", + " and move Ian to the Uploaders field.", + " * Packaging complete redone (based on my haskell-regex-base package).", + "", + " -- Arjan Oosting Sat, 19 Jan 2008 16:48:39 +0100", + "", + "haskell-regex-compat (0.71.0.1-1) unstable; urgency=low", + " ", + " * Initial release (used to be part of ghc6).", + " * Using \"Generic Haskell cabal library packaging files v9\".", + " ", + " -- Ian Lynagh (wibble) Wed, 21 Nov 2007 01:26:57 +0000", + " ", + ""] diff --git a/Debian/Control/ByteString.hs b/Debian/Control/ByteString.hs --- a/Debian/Control/ByteString.hs +++ b/Debian/Control/ByteString.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} module Debian.Control.ByteString ( Control'(..) , Paragraph'(..) @@ -19,9 +20,10 @@ -- Standard GHC modules +import qualified Control.Exception as E import Control.Monad.State -import Data.Char(chr,ord) +import Data.Char(chr,ord,toLower) import Data.List import Data.Maybe import Data.Word @@ -122,14 +124,15 @@ Nothing -> return (Left (newErrorMessage (Message ("Failed to parse " ++ fp)) (newPos fp 0 0))) (Just (cntl,_)) -> return (Right cntl) parseControlFromHandle sourceName handle = - C.hGetContents handle >>= return . parseControl sourceName + E.try (C.hGetContents handle) >>= + either (\ (e :: E.SomeException) -> error ("parseControlFromHandle ByteString: Failure parsing " ++ sourceName ++ ": " ++ show e)) (return . parseControl sourceName) parseControl sourceName c = do case parse pControl c of Nothing -> Left (newErrorMessage (Message ("Failed to parse " ++ sourceName)) (newPos sourceName 0 0)) Just (cntl,_) -> Right cntl lookupP fieldName (Paragraph fields) = - let pFieldName = C.pack fieldName in - find (\ (Field (fieldName',_)) -> fieldName' == pFieldName) fields + let pFieldName = C.pack (map toLower fieldName) in + find (\ (Field (fieldName',_)) -> C.map toLower fieldName' == pFieldName) fields -- NOTE: probably inefficient stripWS = C.reverse . strip . C.reverse . strip where strip = C.dropWhile (flip elem " \t") diff --git a/Debian/Control/Common.hs b/Debian/Control/Common.hs --- a/Debian/Control/Common.hs +++ b/Debian/Control/Common.hs @@ -28,6 +28,7 @@ newtype Paragraph' a = Paragraph [Field' a] + deriving Eq -- |NOTE: we do not strip the leading or trailing whitespace in the -- name or value diff --git a/Debian/Control/String.hs b/Debian/Control/String.hs --- a/Debian/Control/String.hs +++ b/Debian/Control/String.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, TypeSynonymInstances #-} module Debian.Control.String ( -- * Types Control'(..) @@ -22,7 +22,8 @@ , raiseFields ) where -import Control.Monad +import qualified Control.Exception as E +import Data.Char (toLower) import Data.List import Text.ParserCombinators.Parsec import System.IO @@ -49,13 +50,14 @@ parseControlFromFile filepath = parseFromFile pControl filepath parseControlFromHandle sourceName handle = - hGetContents handle >>= return . parseControl sourceName + E.try (hGetContents handle) >>= + either (\ (e :: E.SomeException) -> error ("parseControlFromHandle String: Failure parsing " ++ sourceName ++ ": " ++ show e)) (return . parseControl sourceName) parseControl sourceName c = parse pControl sourceName c lookupP fieldName (Paragraph paragraph) = - find hasFieldName paragraph - where hasFieldName (Field (fieldName',_)) = fieldName == fieldName' - hasFieldName _ = False + find (hasFieldName (map toLower fieldName)) paragraph + where hasFieldName name (Field (fieldName',_)) = name == map toLower fieldName' + hasFieldName _ _ = False stripWS = reverse . strip . reverse . strip where strip = dropWhile (flip elem " \t") asString = id diff --git a/Debian/GenBuildDeps.hs b/Debian/GenBuildDeps.hs --- a/Debian/GenBuildDeps.hs +++ b/Debian/GenBuildDeps.hs @@ -115,7 +115,7 @@ -- list of packages, return a triple: One ready package, the packages -- that depend on the ready package directly or indirectly, and all -- the other packages. -buildable :: Show a => (a -> a -> Ordering) -> [a] -> BuildableInfo a +buildable :: (a -> a -> Ordering) -> [a] -> BuildableInfo a buildable cmp packages = -- Find all packages which can't reach any other packages in the -- graph of the "has build dependency" relation. @@ -228,7 +228,7 @@ -- |One example of how to tie the below functions together. In this -- case 'fp' is the path to a directory that contains a bunch of -- checked out source packages. The code will automatically look for --- fp\/*\/debian\/control. It returns a list with the packages in the +-- debian\/control. It returns a list with the packages in the -- order they should be built. getSourceOrder :: FilePath -> IO (Either String [SrcPkgName]) getSourceOrder fp = diff --git a/Debian/Relation/Common.hs b/Debian/Relation/Common.hs --- a/Debian/Relation/Common.hs +++ b/Debian/Relation/Common.hs @@ -4,6 +4,7 @@ import Data.List import Text.ParserCombinators.Parsec +import Data.Function -- Local Modules @@ -63,17 +64,15 @@ show (GRE v) = " (>= " ++ show v ++ ")" show (SGR v) = " (>> " ++ show v ++ ")" --- |@FIXME:@ This instance is currently incomplete and only handles the case --- where two version requirements are equal. +-- |The sort order is based on version number first, then on the kind of +-- relation, sorting in the order <<, <= , ==, >= , >> instance Ord VersionReq where - compare r1 r2 = - if r1 == r2 - then EQ - else - case (r1, r2) of - (EEQ v1, EEQ v2) -> compare v1 v2 - (a,b) -> error $ "Ord VersionReq does not handle (" ++ show a ++", "++ show b++")" - + compare = compare `on` extr + where extr (SLT v) = (v,0) + extr (LTE v) = (v,1) + extr (EEQ v) = (v,2) + extr (GRE v) = (v,3) + extr (SGR v) = (v,4) -- |Check if a version number satisfies a version requirement. checkVersionReq :: Maybe VersionReq -> Maybe DebianVersion -> Bool diff --git a/Debian/URI.hs b/Debian/URI.hs --- a/Debian/URI.hs +++ b/Debian/URI.hs @@ -3,12 +3,14 @@ , URIString , uriToString' , fileFromURI + , fileFromURIStrict , dirFromURI ) where -import Control.OldException (Exception(..), try) +import Control.Exception (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) @@ -24,7 +26,7 @@ -- |If the URI type could be read and showed this wouldn't be necessary. type URIString = String -fileFromURI :: URI -> IO (Either Exception L.ByteString) +fileFromURI :: URI -> IO (Either ErrorCall L.ByteString) fileFromURI uri = case (uriScheme uri, uriAuthority uri) of ("file:", Nothing) -> try (L.readFile (uriPath uri)) @@ -32,6 +34,14 @@ " cat " ++ show (uriPath uri)) _ -> cmdOutput ("curl -s -g '" ++ uriToString' uri ++ "'") +fileFromURIStrict :: URI -> IO (Either ErrorCall 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 ++ "'") + -- | Parse the text returned when a directory is listed by a web -- server. This is currently only known to work with Apache. -- NOTE: there is a second copy of this function in @@ -45,7 +55,7 @@ second _ = Nothing -dirFromURI :: URI -> IO (Either Exception [String]) +dirFromURI :: URI -> IO (Either ErrorCall [String]) dirFromURI uri = case (uriScheme uri, uriAuthority uri) of ("file:", Nothing) -> try (getDirectoryContents (uriPath uri)) @@ -56,10 +66,27 @@ -cmdOutput :: String -> IO (Either Exception L.ByteString) +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) diff --git a/Debian/Util/FakeChanges.hs b/Debian/Util/FakeChanges.hs --- a/Debian/Util/FakeChanges.hs +++ b/Debian/Util/FakeChanges.hs @@ -1,19 +1,19 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} module Debian.Util.FakeChanges (fakeChanges) where --import Control.Arrow -import Control.OldException +import Control.Exception import Control.Monad hiding (mapM) import Data.Foldable import Data.List hiding (concat, foldr, all) import Data.Maybe --import Data.Typeable -import Data.Generics +import Data.Data (Data, Typeable) import Data.Traversable import Debian.Time import System.Environment import System.Posix.Files -import Text.Regex.Posix +import Text.Regex.TDFA import Prelude hiding (catch, concat, foldr, all, mapM) import Network.BSD @@ -235,20 +235,20 @@ do dfn <- try (getEnv "DEBFULLNAME") case dfn of (Right n) -> return n - (Left _) -> + (Left (_ :: SomeException)) -> do dfn <-try (getEnv "USER") case dfn of (Right n) -> return n - (Left _) -> error $ "Could not determine user name, neither DEBFULLNAME nor USER enviroment variables were set." + (Left (_ :: SomeException)) -> error $ "Could not determine user name, neither DEBFULLNAME nor USER enviroment variables were set." emailAddr <- do eml <- try (getEnv "DEBEMAIL") case eml of (Right e) -> return e - (Left _) -> + (Left (_ :: SomeException)) -> do eml <- try (getEnv "EMAIL") case eml of (Right e) -> return e - (Left _) -> getHostName -- FIXME: this is not a FQDN + (Left (_ :: SomeException)) -> getHostName -- FIXME: this is not a FQDN return $ debFullName ++ " <" ++ emailAddr ++ ">" -- * Utils diff --git a/Distribution/Package/Debian.hs b/Distribution/Package/Debian.hs --- a/Distribution/Package/Debian.hs +++ b/Distribution/Package/Debian.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, TypeSynonymInstances #-} +{-# LANGUAGE CPP, ScopedTypeVariables, TypeSynonymInstances #-} -- | -- Module : Distribution.Package.Debian @@ -17,7 +17,7 @@ ( debian ) where -import Control.OldException (try, bracket) +import Control.Exception (SomeException, try, bracket) import Control.Monad (when,mplus) import qualified Data.ByteString.Lazy.Char8 as L import Data.Char (toLower, isSpace) @@ -28,7 +28,7 @@ import Debian.Control import qualified Debian.Relation as D import Debian.Release (parseReleaseName) -import Debian.Changes (ChangeLogEntry(..)) +import Debian.Changes (ChangeLogEntry(..), prettyEntry) import Debian.Time (getCurrentLocalRFC822Time) import Debian.Version import Debian.Version.String @@ -44,13 +44,13 @@ import Distribution.Text (display) import Distribution.Simple.Compiler (CompilerFlavor(..), compilerFlavor, Compiler(..)) --import Distribution.Simple.Configure (localBuildInfoFile) -import Distribution.System (buildOS, buildArch) +import Distribution.System (Platform(..), buildOS, buildArch) import Distribution.License (License(..)) import Distribution.Package (Package(..), PackageIdentifier(..), PackageName(..), Dependency(..)) import Distribution.Simple.Program (defaultProgramConfiguration) import Distribution.Simple.Configure (configCompiler, maybeGetPersistBuildConfig) import Distribution.Simple.InstallDirs (InstallDirs(..), InstallDirTemplates, toPathTemplate) -import Distribution.Simple.Register (writeInstalledConfig) +--import Distribution.Simple.Register (writeInstalledConfig) --import Distribution.Simple.Setup (defaultRegisterFlags) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) import Distribution.Simple.PackageIndex (PackageIndex,fromList) @@ -68,6 +68,7 @@ import Distribution.Package.Debian.Bundled import qualified Distribution.Compat.ReadP as ReadP import Distribution.Text ( Text(parse) ) +import Text.PrettyPrint.HughesPJ parsePackageId' :: ReadP.ReadP PackageIdentifier PackageIdentifier parsePackageId' = parseQuoted parse ReadP.<++ parse @@ -99,7 +100,8 @@ trim = dropWhile isSpace --- installedPackages :: Package pkg => IO [PackageIndex pkg] +--installedPackages :: Package pkg => IO [PackageIndex] +{- installedPackages = do (out, err, code) <- lazyCommand cmd L.empty >>= return . collectOutputUnpacked case code of @@ -107,6 +109,7 @@ result -> error $ "Failure: " ++ cmd ++ " -> " ++ show result ++ " (" ++ err ++ ")" where cmd = "ghc-pkg list --simple-output" +-} simplePackageDescription :: GenericPackageDescription -> Flags -> IO (Compiler, PackageDescription) @@ -114,10 +117,11 @@ (compiler, _) <- configCompiler (Just (rpmCompiler flags)) Nothing Nothing defaultProgramConfiguration (rpmVerbosity flags) - installed <- installedPackages + --installed <- installedPackages case finalizePackageDescription (rpmConfigurationsFlags flags) - (Nothing :: Maybe (PackageIndex PackageIdentifier)) - buildOS buildArch (compilerId compiler) [] genPkgDesc of + (const True) (Platform buildArch buildOS) (compilerId compiler) + {- (Nothing :: Maybe PackageIndex) -} + [] genPkgDesc of Left e -> die $ "finalize failed: " ++ show e Right (pd, _) -> return (compiler, pd) @@ -159,6 +163,7 @@ ExitSuccess -> return () ExitFailure n -> die ("autoreconf failed with status " ++ show n) +{- localBuildInfo :: PackageDescription -> Flags -> IO LocalBuildInfo localBuildInfo pkgDesc flags = maybeGetPersistBuildConfig defaultDistPref >>= @@ -174,6 +179,7 @@ if isNothing (library pkgDesc) then error "cabal-debian - Unsupported: package without a library section" else writeInstalledConfig defaultDistPref pkgDesc lbi False Nothing >> return lbi +-} data PackageInfo = PackageInfo { libDir :: FilePath , cabalName :: String @@ -209,7 +215,7 @@ -- haskell-cabal-debian-doc.substvars: -- haskell:Depends=ghc6-doc, haddock (>= 2.1.0), haddock (<< 2.1.0-999) ([], Just path') -> - do old <- try (readFile path') >>= return . either (const "") id + do old <- try (readFile path') >>= return . either (\ (_ :: SomeException) -> "") id let new = addDeps old hPutStrLn stderr (if new /= old then ("cabal-debian - Updated " ++ show path' ++ ":\n " ++ old ++ "\n ->\n " ++ new) @@ -282,10 +288,10 @@ -- order to compute the text argument. replaceFile :: FilePath -> String -> IO () replaceFile path text = - try (removeFile back) >> -- This may not exist - try (renameFile path back) >> -- This may not exist - try (writeFile path text) >>= -- This must succeed - either (\ e -> error ("writeFile " ++ show path ++ ": " ++ show e)) return + try (removeFile back >> -- This may not exist + renameFile path back >> -- This may not exist + writeFile path text) >>= -- This must succeed + either (\ (e :: SomeException) -> error ("writeFile " ++ show path ++ ": " ++ show e)) return where back = path ++ "~" @@ -298,7 +304,7 @@ mapM (packageInfo compiler debVersions) (a ++ b) >>= return . catMaybes | True = error $ "Can't handle compiler flavor: " ++ show (compilerFlavor compiler) where - getDirPaths path = try (getDirectoryContents path) >>= return . map (\ x -> (path, x)) . either (const []) id + getDirPaths path = try (getDirectoryContents path) >>= return . map (\ x -> (path, x)) . either (\ (_ :: SomeException) -> []) id packageInfo :: Compiler -> DebMap -> (FilePath, String) -> IO (Maybe PackageInfo) packageInfo compiler debVersions (d, f) = @@ -391,7 +397,7 @@ do createDirectoryIfMissing True "debian" date <- getCurrentLocalRFC822Time copyright <- try (readFile (licenseFile pkgDesc)) >>= - return . either (const . showLicense . license $ pkgDesc) id + return . either (\ (_ :: SomeException) -> showLicense . license $ pkgDesc) id debianMaintainer <- getDebianMaintainer flags >>= maybe (error "Missing value for --maintainer") return controlUpdate (tgtPfx "control") flags compiler debianMaintainer pkgDesc changelogUpdate (tgtPfx "changelog") debianMaintainer pkgDesc date @@ -479,7 +485,7 @@ controlUpdate path flags compiler debianMaintainer pkgDesc = builtIns compiler >>= \bundled -> try (readFile path) >>= - either (\ _ -> writeFile path (show (newCtl bundled))) (\ s -> writeFile (path ++ ".new") $! show (merge (newCtl bundled) (oldCtl s))) + either (\ (_ :: SomeException) -> writeFile path (show (newCtl bundled))) (\ s -> writeFile (path ++ ".new") $! show (merge (newCtl bundled) (oldCtl s))) where newCtl bundled = control flags bundled compiler debianMaintainer pkgDesc oldCtl s = either (const (Control [])) id (parseControl "debian/control" s) @@ -656,19 +662,20 @@ changelogUpdate :: FilePath -> String -> PackageDescription -> String -> IO () changelogUpdate path debianMaintainer pkgDesc date = - try (readFile path) >>= either (const (writeFile path log)) (const (writeFile (path ++ ".new") log)) + try (readFile path) >>= either (\ (_ :: SomeException) -> writeFile path log) (const (writeFile (path ++ ".new") log)) where log = changelog debianMaintainer pkgDesc date changelog :: String -> PackageDescription -> String -> String changelog debianMaintainer pkgDesc date = - show (Entry { logPackage = debianSourcePackageName pkgDesc - , logVersion = debianVersionNumber pkgDesc - , logDists = [parseReleaseName "unstable"] - , logUrgency = "low" - , logComments = " * Debianization generated by cabal-debian\n\n" - , logWho = debianMaintainer - , logDate = date }) + render (prettyEntry + (Entry { logPackage = debianSourcePackageName pkgDesc + , logVersion = debianVersionNumber pkgDesc + , logDists = [parseReleaseName "unstable"] + , logUrgency = "low" + , logComments = " * Debianization generated by cabal-debian\n\n" + , logWho = debianMaintainer + , logDate = date })) unPackageName :: PackageName -> String unPackageName (PackageName s) = s @@ -761,8 +768,8 @@ -- taken from TagsCheck.py in the rpmlint distribution. showLicense :: License -> String -showLicense GPL = "GPL" -showLicense LGPL = "LGPL" +showLicense (GPL _) = "GPL" +showLicense (LGPL _) = "LGPL" showLicense BSD3 = "BSD" showLicense BSD4 = "BSD-like" showLicense PublicDomain = "Public Domain" 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 @@ -30,7 +30,7 @@ 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.InstalledPackageInfo(InstalledPackageInfo, libraryDirs, sourcePackageId) import Distribution.Simple.Compiler (Compiler(..), CompilerId(..), CompilerFlavor(..), PackageDB(GlobalPackageDB), compilerFlavor) import Distribution.Simple.Configure (getInstalledPackages) -- import Distribution.Simple.GHC (getInstalledPackages) @@ -40,7 +40,7 @@ import Distribution.Verbosity(normal) import Distribution.Version (withinRange) import Text.ParserCombinators.Parsec(ParseError) -import Text.Regex.Posix ((=~)) +import Text.Regex.TDFA ((=~)) -- | List the packages bundled with this version of the given -- compiler. If the answer is not known, return the empty list. @@ -75,13 +75,20 @@ ] ghc6BuiltIns :: Compiler -> IO (Maybe (CompilerFlavor, Version, [PackageIdentifier])) ghc6BuiltIns compiler@(Compiler (CompilerId GHC compilerVersion) _) = +#ifdef CABAL19 + do installedPackages <- getInstalledPackageIndex compiler + 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 sourcePackageId ghcProvides)) +#else 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)) + return (Just (GHC, compilerVersion, map sourcePackageId ghcProvides)) +#endif ghc6BuiltIns _ = return Nothing ghc6BuiltIns' :: Compiler -> IO (Maybe (CompilerFlavor, Version, [PackageIdentifier])) @@ -90,6 +97,11 @@ case eDebs of Left e -> error e Right debNames -> +#ifdef CABAL19 + do installedPackages <- getInstalledPackageIndex compiler + let packages = concatMap (\n -> fromRight $ installedVersions (fromRight $ extractBaseName n) installedPackages) debNames + return $ Just (GHC, compilerVersion, packages) +#else do mInstalledPackages <- getInstalledPackageIndex compiler case mInstalledPackages of Nothing -> error "Could not find the installed package database." @@ -97,6 +109,7 @@ let packages = concatMap (\n -> fromRight $ installedVersions (fromRight $ extractBaseName n) installedPackages) debNames in return $ Just (GHC, compilerVersion, packages) +#endif where fromRight (Right r) = r fromRight (Left e) = error e @@ -127,19 +140,19 @@ [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 -> IO (Maybe PackageIndex) getInstalledPackageIndex compiler = do pc <- configureAllKnownPrograms normal defaultProgramConfiguration - getInstalledPackages normal compiler GlobalPackageDB pc + getInstalledPackages normal compiler [GlobalPackageDB] pc -installedVersions :: String -> PackageIndex InstalledPackageInfo -> Either String [PackageIdentifier] +installedVersions :: String -> PackageIndex -> 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 + case sortBy (compare `on` (pkgVersion . sourcePackageId)) pkgs of [] -> Left $ "Odd. searchByName returned an empty Unambiguous match for " ++ name - ps -> Right (map package ps) + ps -> Right (map sourcePackageId ps) v :: String -> [Int] -> PackageIdentifier v n x = PackageIdentifier (PackageName n) (Version x []) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,5 +1,14 @@ #!/usr/bin/runhaskell import Distribution.Simple +import Distribution.Simple.Program +import System.Cmd +import System.Exit -main = defaultMainWithHooks simpleUserHooks +main = defaultMainWithHooks simpleUserHooks { + runTests = runTestScript + } + +runTestScript _args _flag _pd _lbi = + system "runhaskell Test/Main.hs" >>= + \ code -> if code == ExitSuccess then return () else error "Test Failure" diff --git a/Test/Changes.hs b/Test/Changes.hs new file mode 100644 --- /dev/null +++ b/Test/Changes.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE StandaloneDeriving #-} +module Test.Changes where + +import Test.HUnit +import Data.List (intercalate) +import Debian.Changes +import Debian.Release (ReleaseName(ReleaseName, relName)) +import Debian.Version (parseDebianVersion) + +deriving instance Show ChangeLogEntry + +s3 = intercalate "\n" + ["name (version) dist; urgency=urgency", + " * details", + " -- David Fox Wed, 21 Nov 2007 01:26:57 +0000", + ""] + +s4 = intercalate "\n" + ["haskell-regex-compat (0.92-3+seereason1~jaunty4) jaunty-seereason; urgency=low", + "", + " [ Joachim Breitner ]", + " * Adjust priority according to override file", + " * Depend on hscolour (Closes: #550769)", + "", + " [ Marco Túlio Gontijo e Silva ]", + "", + " -- David Fox Wed, 21 Nov 2007 01:26:57 +0000", + ""] + +s1 = intercalate "\n" + ["haskell-regex-compat (0.92-3+seereason1~jaunty4) jaunty-seereason; urgency=low", + "", + " [ Joachim Breitner ]", + " * Adjust priority according to override file", + " * Depend on hscolour (Closes: #550769)", + "", + " [ Marco Túlio Gontijo e Silva ]", + " * debian/control: Use more sintetic name for Vcs-Darcs.", + " * Built from sid apt pool", + " * Build dependency changes:", + " cpphs: 1.9-1+seereason1~jaunty5 -> 1.9-1+seereason1~jaunty6", + " ghc6: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1", + " ghc6-doc: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1", + " ghc6-prof: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1", + " haddock: 2.4.2-3+seereason3~jaunty1 -> 6.12.1-0+seereason1~jaunty1", + " haskell-devscripts: 0.6.18-21+seereason1~jaunty1 -> 0.6.18-23+seereason1~jaunty1", + " haskell-regex-base-doc: 0.93.1-5+seereason1~jaunty1 -> 0.93.1-5++1+seereason1~jaunty1", + " haskell-regex-posix-doc: 0.93.2-4+seereason1~jaunty1 -> 0.93.2-4+seereason1~jaunty2", + " libghc6-regex-base-dev: 0.93.1-5+seereason1~jaunty1 -> 0.93.1-5++1+seereason1~jaunty1", + " libghc6-regex-base-prof: 0.93.1-5+seereason1~jaunty1 -> 0.93.1-5++1+seereason1~jaunty1", + " libghc6-regex-posix-dev: 0.93.2-4+seereason1~jaunty1 -> 0.93.2-4+seereason1~jaunty2", + " libghc6-regex-posix-prof: 0.93.2-4+seereason1~jaunty1 -> 0.93.2-4+seereason1~jaunty2", + "", + " -- SeeReason Autobuilder Fri, 25 Dec 2009 01:55:37 -0800", + "", + "haskell-regex-compat (0.92-3) unstable; urgency=low", + "", + " [ Joachim Breitner ]", + " * Adjust priority according to override file", + " * Depend on hscolour (Closes: #550769)", + "", + " [ Marco Túlio Gontijo e Silva ]", + " * debian/control: Use more sintetic name for Vcs-Darcs.", + "", + " -- Joachim Breitner Mon, 20 Jul 2009 13:05:35 +0200", + "", + "haskell-regex-compat (0.92-2) unstable; urgency=low", + "", + " * Adopt package for the Debian Haskell Group", + " * Fix \"FTBFS with new dpkg-dev\" by adding comma to debian/control", + " (Closes: #536473)", + "", + " -- Joachim Breitner Mon, 20 Jul 2009 12:05:40 +0200", + "", + "haskell-regex-compat (0.92-1.1) unstable; urgency=low", + "", + " * Rebuild for GHC 6.10.", + " * NMU with permission of the author.", + "", + " -- John Goerzen Mon, 16 Mar 2009 10:12:04 -0500", + "", + "haskell-regex-compat (0.92-1) unstable; urgency=low", + "", + " * New upstream release", + " * debian/control:", + " - Bump Standards-Version. No changes needed.", + "", + " -- Arjan Oosting Sun, 18 Jan 2009 00:05:02 +0100", + "", + "haskell-regex-compat (0.91-1) unstable; urgency=low", + "", + " * Take over package from Ian, as I already maintain haskell-regex-base,", + " and move Ian to the Uploaders field.", + " * Packaging complete redone (based on my haskell-regex-base package).", + "", + " -- Arjan Oosting Sat, 19 Jan 2008 16:48:39 +0100", + "", + "haskell-regex-compat (0.71.0.1-1) unstable; urgency=low", + " ", + " * Initial release (used to be part of ghc6).", + " * Using \"Generic Haskell cabal library packaging files v9\".", + " ", + " -- Ian Lynagh (wibble) Wed, 21 Nov 2007 01:26:57 +0000", + " ", + ""] + +s2 = intercalate "\n" + ["haskell-haskeline (0.6.1.6-1+seereason1~jaunty6) jaunty-seereason; urgency=low", + "", + " * New upstream version.", + " * Remove extensible-exceptions patch, since ghc6 now ships it.", + " * debian/control:", + " - Use versioned Build-Depends.", + " - Use unversioned Recommends for ghc6-doc in libghc6-terminfo-doc.", + " - Use haskell Section.", + " - Use new Standards-Version: 3.8.1.", + " - Use DM-Upload-Allowed: yes.", + " - Use haskell:Recommends and haskell:Suggests.", + " - Don't use shlibs:Depends for -prof.", + " - Split dependencies in more than one line.", + " * Built from sid apt pool", + " * Build dependency changes:", + " ghc6: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1", + " ghc6-doc: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1", + " ghc6-prof: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1", + " haddock: 2.4.2-3+seereason3~jaunty1 -> 6.12.1-0+seereason1~jaunty1", + " haskell-devscripts: 0.6.18-21+seereason1~jaunty1 -> 0.6.18-23+seereason1~jaunty1", + " libghc6-mtl-dev: 1.1.0.2-7+seereason3~jaunty7 -> 1.1.0.2-7+seereason3~jaunty8", + " libghc6-mtl-doc: 1.1.0.2-7+seereason3~jaunty7 -> 1.1.0.2-7+seereason3~jaunty8", + " libghc6-mtl-prof: 1.1.0.2-7+seereason3~jaunty7 -> 1.1.0.2-7+seereason3~jaunty8", + " libghc6-terminfo-dev: 0.3.0.2-2+seereason1~jaunty5 -> 0.3.0.2-2+seereason1~jaunty6", + " libghc6-terminfo-doc: 0.3.0.2-2+seereason1~jaunty5 -> 0.3.0.2-2+seereason1~jaunty6", + " libghc6-terminfo-prof: 0.3.0.2-2+seereason1~jaunty5 -> 0.3.0.2-2+seereason1~jaunty6", + " libghc6-utf8-string-dev: 0.3.5-1+seereason3~jaunty7 -> 0.3.5-1++1+seereason1~jaunty1", + " libghc6-utf8-string-doc: 0.3.5-1+seereason3~jaunty7 -> 0.3.5-1++1+seereason1~jaunty1", + " libghc6-utf8-string-prof: 0.3.5-1+seereason3~jaunty7 -> 0.3.5-1++1+seereason1~jaunty1", + "", + " -- SeeReason Autobuilder Fri, 25 Dec 2009 13:48:18 -0800", + "", + "haskell-haskeline (0.6.1.6-1) unstable; urgency=low", + "", + " * New upstream version.", + " * Remove extensible-exceptions patch, since ghc6 now ships it.", + " * debian/control:", + " - Use versioned Build-Depends.", + " - Use unversioned Recommends for ghc6-doc in libghc6-terminfo-doc.", + " - Use haskell Section.", + " - Use new Standards-Version: 3.8.1.", + " - Use DM-Upload-Allowed: yes.", + " - Use haskell:Recommends and haskell:Suggests.", + " - Don't use shlibs:Depends for -prof.", + " - Split dependencies in more than one line.", + "", + " -- Marco Túlio Gontijo e Silva Tue, 02 Jun 2009 10:18:27 -0300", + "", + "haskell-haskeline (0.6.1.3-1) unstable; urgency=low", + "", + " * Initial Debian package. (Closes: #496961)", + "", + " -- Marco Túlio Gontijo e Silva Wed, 11 Mar 2009 18:58:06 -0300", + "", + ""] + +test3 = + TestCase (assertEqual "haskell-regex-compat changelog" expected (parseLog s3)) + where expected = [Right (Entry {logPackage = "name", logVersion = parseDebianVersion "version", logDists = [ReleaseName {relName = "dist"}], logUrgency = "urgency", logComments = " * details\n", logWho = "David Fox ", logDate = "Wed, 21 Nov 2007 01:26:57 +0000"})] + +test4 = + TestCase (assertEqual "haskell-regex-compat changelog" expected (parseLog s4)) + where expected = [Right (Entry {logPackage = "haskell-regex-compat", + logVersion = parseDebianVersion "0.92-3+seereason1~jaunty4", + logDists = [ReleaseName {relName = "jaunty-seereason"}], + logUrgency = "low", + logComments = " [ Joachim Breitner ]\n * Adjust priority according to override file\n * Depend on hscolour (Closes: #550769)\n\n [ Marco T\250lio Gontijo e Silva ]\n\n", + logWho = "David Fox ", + logDate = "Wed, 21 Nov 2007 01:26:57 +0000"})] + +test1 = + TestCase (assertEqual "haskell-regex-compat changelog" expected (parseLog s1)) + where expected = [Right (Entry {logPackage = "haskell-regex-compat", logVersion = parseDebianVersion "0.92-3+seereason1~jaunty4", logDists = [ReleaseName {relName = "jaunty-seereason"}], logUrgency = "low", logComments = " [ Joachim Breitner ]\n * Adjust priority according to override file\n * Depend on hscolour (Closes: #550769)\n\n [ Marco T\250lio Gontijo e Silva ]\n * debian/control: Use more sintetic name for Vcs-Darcs.\n * Built from sid apt pool\n * Build dependency changes:\n cpphs: 1.9-1+seereason1~jaunty5 -> 1.9-1+seereason1~jaunty6\n ghc6: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1\n ghc6-doc: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1\n ghc6-prof: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1\n haddock: 2.4.2-3+seereason3~jaunty1 -> 6.12.1-0+seereason1~jaunty1\n haskell-devscripts: 0.6.18-21+seereason1~jaunty1 -> 0.6.18-23+seereason1~jaunty1\n haskell-regex-base-doc: 0.93.1-5+seereason1~jaunty1 -> 0.93.1-5++1+seereason1~jaunty1\n haskell-regex-posix-doc: 0.93.2-4+seereason1~jaunty1 -> 0.93.2-4+seereason1~jaunty2\n libghc6-regex-base-dev: 0.93.1-5+seereason1~jaunty1 -> 0.93.1-5++1+seereason1~jaunty1\n libghc6-regex-base-prof: 0.93.1-5+seereason1~jaunty1 -> 0.93.1-5++1+seereason1~jaunty1\n libghc6-regex-posix-dev: 0.93.2-4+seereason1~jaunty1 -> 0.93.2-4+seereason1~jaunty2\n libghc6-regex-posix-prof: 0.93.2-4+seereason1~jaunty1 -> 0.93.2-4+seereason1~jaunty2\n\n", logWho = "SeeReason Autobuilder ", logDate = "Fri, 25 Dec 2009 01:55:37 -0800"}), + Right (Entry {logPackage = "haskell-regex-compat", logVersion = parseDebianVersion "0.92-3", logDists = [ReleaseName {relName = "unstable"}], logUrgency = "low", logComments = " [ Joachim Breitner ]\n * Adjust priority according to override file\n * Depend on hscolour (Closes: #550769)\n\n [ Marco T\250lio Gontijo e Silva ]\n * debian/control: Use more sintetic name for Vcs-Darcs.\n\n", logWho = "Joachim Breitner ", logDate = "Mon, 20 Jul 2009 13:05:35 +0200"}), + Right (Entry {logPackage = "haskell-regex-compat", logVersion = parseDebianVersion "0.92-2", logDists = [ReleaseName {relName = "unstable"}], logUrgency = "low", logComments = " * Adopt package for the Debian Haskell Group\n * Fix \"FTBFS with new dpkg-dev\" by adding comma to debian/control\n (Closes: #536473)\n\n", logWho = "Joachim Breitner ", logDate = "Mon, 20 Jul 2009 12:05:40 +0200"}), + Right (Entry {logPackage = "haskell-regex-compat", logVersion = parseDebianVersion "0.92-1.1", logDists = [ReleaseName {relName = "unstable"}], logUrgency = "low", logComments = " * Rebuild for GHC 6.10.\n * NMU with permission of the author.\n\n", logWho = "John Goerzen ", logDate = "Mon, 16 Mar 2009 10:12:04 -0500"}), + Right (Entry {logPackage = "haskell-regex-compat", logVersion = parseDebianVersion "0.92-1", logDists = [ReleaseName {relName = "unstable"}], logUrgency = "low", logComments = " * New upstream release\n * debian/control:\n - Bump Standards-Version. No changes needed.\n\n", logWho = "Arjan Oosting ", logDate = "Sun, 18 Jan 2009 00:05:02 +0100"}), + Right (Entry {logPackage = "haskell-regex-compat", logVersion = parseDebianVersion "0.91-1", logDists = [ReleaseName {relName = "unstable"}], logUrgency = "low", logComments = " * Take over package from Ian, as I already maintain haskell-regex-base,\n and move Ian to the Uploaders field.\n * Packaging complete redone (based on my haskell-regex-base package).\n\n", logWho = "Arjan Oosting ", logDate = "Sat, 19 Jan 2008 16:48:39 +0100"}), + Right (Entry {logPackage = "haskell-regex-compat", logVersion = parseDebianVersion "0.71.0.1-1", logDists = [ReleaseName {relName = "unstable"}], logUrgency = "low", logComments = " * Initial release (used to be part of ghc6).\n * Using \"Generic Haskell cabal library packaging files v9\".\n \n", logWho = "Ian Lynagh (wibble) ", logDate = "Wed, 21 Nov 2007 01:26:57 +0000"})] + +test2 = + TestCase (assertEqual "haskell-regex-compat changelog" expected (parseLog s2)) + where expected = [Right (Entry {logPackage = "haskell-haskeline", + logVersion = parseDebianVersion "0.6.1.6-1+seereason1~jaunty6", + logDists = [ReleaseName {relName = "jaunty-seereason"}], + logUrgency = "low", + logComments = " * New upstream version.\n * Remove extensible-exceptions patch, since ghc6 now ships it.\n * debian/control:\n - Use versioned Build-Depends.\n - Use unversioned Recommends for ghc6-doc in libghc6-terminfo-doc.\n - Use haskell Section.\n - Use new Standards-Version: 3.8.1.\n - Use DM-Upload-Allowed: yes.\n - Use haskell:Recommends and haskell:Suggests.\n - Don't use shlibs:Depends for -prof.\n - Split dependencies in more than one line.\n * Built from sid apt pool\n * Build dependency changes:\n ghc6: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1\n ghc6-doc: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1\n ghc6-prof: 6.10.4-1+seereason5~jaunty1 -> 6.12.1-0+seereason1~jaunty1\n haddock: 2.4.2-3+seereason3~jaunty1 -> 6.12.1-0+seereason1~jaunty1\n haskell-devscripts: 0.6.18-21+seereason1~jaunty1 -> 0.6.18-23+seereason1~jaunty1\n libghc6-mtl-dev: 1.1.0.2-7+seereason3~jaunty7 -> 1.1.0.2-7+seereason3~jaunty8\n libghc6-mtl-doc: 1.1.0.2-7+seereason3~jaunty7 -> 1.1.0.2-7+seereason3~jaunty8\n libghc6-mtl-prof: 1.1.0.2-7+seereason3~jaunty7 -> 1.1.0.2-7+seereason3~jaunty8\n libghc6-terminfo-dev: 0.3.0.2-2+seereason1~jaunty5 -> 0.3.0.2-2+seereason1~jaunty6\n libghc6-terminfo-doc: 0.3.0.2-2+seereason1~jaunty5 -> 0.3.0.2-2+seereason1~jaunty6\n libghc6-terminfo-prof: 0.3.0.2-2+seereason1~jaunty5 -> 0.3.0.2-2+seereason1~jaunty6\n libghc6-utf8-string-dev: 0.3.5-1+seereason3~jaunty7 -> 0.3.5-1++1+seereason1~jaunty1\n libghc6-utf8-string-doc: 0.3.5-1+seereason3~jaunty7 -> 0.3.5-1++1+seereason1~jaunty1\n libghc6-utf8-string-prof: 0.3.5-1+seereason3~jaunty7 -> 0.3.5-1++1+seereason1~jaunty1\n\n", + logWho = "SeeReason Autobuilder ", + logDate = "Fri, 25 Dec 2009 13:48:18 -0800"}), + Right (Entry {logPackage = "haskell-haskeline", + logVersion = parseDebianVersion "0.6.1.6-1", + logDists = [ReleaseName {relName = "unstable"}], + logUrgency = "low", + logComments = " * New upstream version.\n * Remove extensible-exceptions patch, since ghc6 now ships it.\n * debian/control:\n - Use versioned Build-Depends.\n - Use unversioned Recommends for ghc6-doc in libghc6-terminfo-doc.\n - Use haskell Section.\n - Use new Standards-Version: 3.8.1.\n - Use DM-Upload-Allowed: yes.\n - Use haskell:Recommends and haskell:Suggests.\n - Don't use shlibs:Depends for -prof.\n - Split dependencies in more than one line.\n\n", + logWho = "Marco T\250lio Gontijo e Silva ", + logDate = "Tue, 02 Jun 2009 10:18:27 -0300"}), + Right (Entry {logPackage = "haskell-haskeline", + logVersion = parseDebianVersion "0.6.1.3-1", + logDists = [ReleaseName {relName = "unstable"}], + logUrgency = "low", + logComments = " * Initial Debian package. (Closes: #496961)\n\n", + logWho = "Marco T\250lio Gontijo e Silva ", + logDate = "Wed, 11 Mar 2009 18:58:06 -0300"})] + +changesTests = [test3, test4, test1, test2] diff --git a/Test/Dependencies.hs b/Test/Dependencies.hs new file mode 100644 --- /dev/null +++ b/Test/Dependencies.hs @@ -0,0 +1,180 @@ +module Test.Dependencies where + +import Control.Arrow +import Test.HUnit + +import Debian.Control.String +import Debian.Apt.Dependencies hiding (packageVersionParagraph) +import Debian.Relation +import Debian.Version +import Debian.Apt.Package + + +packageA = + [ ("Package", " a") + , ("Version", " 1.0") + , ("Depends", " b") + ] + +packageB = + [ ("Package", " b") + , ("Version", " 1.0") + ] + +packageC = + [ ("Package", " c") + , ("Version", " 1.0") + , ("Depends", " doesNotExist") + ] + +packageD = + [ ("Package", " d") + , ("Version", " 1.0") + , ("Depends", " e | f, g | h") + ] + +packageE = + [ ("Package", " e") + , ("Version", " 1.0") + ] + +packageF = + [ ("Package", " f") + , ("Version", " 1.0") + ] + +packageG = + [ ("Package", " g") + , ("Version", " 1.0") + ] + +packageH = + [ ("Package", " h") + , ("Version", " 1.0") + ] + +packageI = + [ ("Package", " i") + , ("Version", " 1.0") + , ("Depends", " k") + ] + +packageJ = + [ ("Package", " j") + , ("Version", " 1.0") + , ("Provides", " k") + ] + +packageK = + [ ("Package", " k") + , ("Version", " 1.0") + ] + + + +control + = [ packageA + , packageB + , packageC + , packageD + , packageE + , packageF + , packageG + , packageH + , packageI + , packageJ + , packageK + ] + +depends p = + case lookup "Depends" p of + Nothing -> [] + (Just v) -> either (error . show) id (parseRelations v) + +mkCSP :: [[(String, String)]] -> String -> ([(String, String)] -> Relations) -> CSP [(String, String)] +mkCSP paragraphs relStr depF = + CSP { pnm = addProvides providesF paragraphs $ packageNameMap getName paragraphs + , relations = either (error . show) id (parseRelations relStr) + , depFunction = depF + , conflicts = conflicts' + , packageVersion = packageVersionParagraph + } + where + getName :: [(String, String)] -> String + getName p = case lookup "Package" p of Nothing -> error "Missing Package field" ; (Just n) -> stripWS n + conflicts' :: [(String, String)] -> Relations + conflicts' p = + case lookup "Conflicts" p of + Nothing -> [] + (Just c) -> either (error . show) id (parseRelations c) + + providesF :: [(String, String)] -> [String] + providesF p = + case lookup "Provides" p of + Nothing -> [] + (Just v) -> + parseCommaList v + +parseCommaList :: String -> [String] +parseCommaList str = + words $ map (\c -> if c == ',' then ' ' else c) str + +packageVersionParagraph :: [(String, String)] -> (String, DebianVersion) +packageVersionParagraph p = + case lookup "Package" p of + Nothing -> error $ "Could not find Package in " ++ show p + (Just n) -> + case lookup "Version" p of + Nothing -> error $ "Could not find Package in " ++ show p + (Just v) -> + (stripWS n, parseDebianVersion v) + +mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)] +mapSnd f = map (second f) + +test1 = + let csp = mkCSP control "a" depends + expected = [ (Complete, [packageB, packageA])] + in + TestCase (assertEqual "test1" expected (search bt csp)) + +missing1 = + let csp = mkCSP control "c" depends + expected = [] + in + TestCase (assertEqual "missing1" expected (search bt csp)) + +ors1 = + let csp = mkCSP control "d" depends + expected = [ (Complete, [packageG, packageE, packageD]) + , (Complete, [packageH, packageE, packageD]) + , (Complete, [packageG, packageF, packageD]) + , (Complete, [packageH, packageF, packageD]) + ] + in + TestCase (assertEqual "ors1" expected (search bt csp)) + +provides1 = + let csp = mkCSP control "i" depends + expected = [ (Complete, [packageK, packageI]) + , (Complete, [packageJ, packageI]) + ] + in + TestCase (assertEqual "provides1" expected (search bt csp)) + +provides2 = + let csp = mkCSP control "k" depends + expected = [ (Complete, [packageK]) + , (Complete, [packageJ]) + ] + in + TestCase (assertEqual "provides2" expected (search bt csp)) + +dependencyTests = + [ test1 + , missing1 + , ors1 + , provides1 + , provides2 + ] +-- runTestText putTextToShowS test1 >>= \(c,st) -> putStrLn (st "") diff --git a/Test/Main.hs b/Test/Main.hs new file mode 100644 --- /dev/null +++ b/Test/Main.hs @@ -0,0 +1,17 @@ +module Main where + +import Test.HUnit +import System.Exit +import Test.Changes +import Test.Versions +--import Test.VersionPolicy +import Test.SourcesList +import Test.Dependencies + +main = + do (c,st) <- runTestText putTextToShowS (TestList (versionTests ++ sourcesListTests ++ dependencyTests ++ changesTests)) + putStrLn (st "") + case (failures c) + (errors c) of + 0 -> return () + n -> exitFailure + diff --git a/Test/SourcesList.hs b/Test/SourcesList.hs new file mode 100644 --- /dev/null +++ b/Test/SourcesList.hs @@ -0,0 +1,59 @@ +module Test.SourcesList where + +import Test.HUnit + +import Debian.Sources +import Data.Maybe + +-- * Unit Tests + +-- TODO: add test cases that test for unterminated double-quote or bracket +testQuoteWords :: Test +testQuoteWords = + test [ assertEqual "Space seperate words, no quoting" ["hello", "world","!"] (quoteWords " hello world ! ") + , assertEqual "Space seperate words, double quotes" ["hello world","!"] (quoteWords " hel\"lo world\" ! ") + , assertEqual "Space seperate words, square brackets" ["hel[lo worl]d","!"] (quoteWords " hel[lo worl]d ! ") + , assertEqual "Space seperate words, square-bracket at end" ["hel[lo world]"] (quoteWords " hel[lo world]") + , assertEqual "Space seperate words, double quote at end" ["hello world"] (quoteWords " hel\"lo world\"") + , assertEqual "Space seperate words, square-bracket at beginning" ["[hello wo]rld","!"] (quoteWords "[hello wo]rld !") + , assertEqual "Space seperate words, double quote at beginning" ["hello world","!"] (quoteWords "\"hello wor\"ld !") + ] + +testSourcesList :: Test +testSourcesList = + test [ assertEqual "valid sources.list" validSourcesListExpected (unlines . map show . parseSourcesList $ validSourcesListStr) ] + where + validSourcesListStr = + unlines $ [ " # A comment only line " + , " deb ftp://ftp.debian.org/debian unstable main contrib non-free # typical deb line" + , " deb-src ftp://ftp.debian.org/debian unstable main contrib non-free # typical deb-src line" + , "" + , "# comment line" + , "deb http://pkg-kde.alioth.debian.org/kde-3.5.0/ ./ # exact path" + , "deb http://ftp.debian.org/whee \"space dist\" main" + , "deb http://ftp.debian.org/whee dist space%20section" + ] + validSourcesListExpected = + unlines $ [ "deb ftp://ftp.debian.org/debian unstable main contrib non-free" + , "deb-src ftp://ftp.debian.org/debian unstable main contrib non-free" + , "deb http://pkg-kde.alioth.debian.org/kde-3.5.0/ ./" + , "deb http://ftp.debian.org/whee space%20dist main" + , "deb http://ftp.debian.org/whee dist space%20section" + ] + invalidSourcesListStr1 = "deb http://pkg-kde.alioth.debian.org/kde-3.5.0/ ./ main contrib non-free # exact path with sections" + +testSourcesListParse :: Test +testSourcesListParse = + test [ assertEqual "" text (concat . map (++ "\n") . map show . parseSourcesList $ text) ] + where + text = (concat ["deb http://us.archive.ubuntu.com/ubuntu/ gutsy main restricted universe multiverse\n", + "deb-src http://us.archive.ubuntu.com/ubuntu/ gutsy main restricted universe multiverse\n", + "deb http://us.archive.ubuntu.com/ubuntu/ gutsy-updates main restricted universe multiverse\n", + "deb-src http://us.archive.ubuntu.com/ubuntu/ gutsy-updates main restricted universe multiverse\n", + "deb http://us.archive.ubuntu.com/ubuntu/ gutsy-backports main restricted universe multiverse\n", + "deb-src http://us.archive.ubuntu.com/ubuntu/ gutsy-backports main restricted universe multiverse\n", + "deb http://security.ubuntu.com/ubuntu/ gutsy-security main restricted universe multiverse\n", + "deb-src http://security.ubuntu.com/ubuntu/ gutsy-security main restricted universe multiverse\n"]) + +sourcesListTests = + [ testQuoteWords, testSourcesList, testSourcesListParse ] diff --git a/Test/VersionPolicy.hs b/Test/VersionPolicy.hs new file mode 100644 --- /dev/null +++ b/Test/VersionPolicy.hs @@ -0,0 +1,68 @@ +module Test.VersionPolicy where + +import Test.HUnit + +import Debian.Version +import Debian.VersionPolicy + +-- * Tag parsing + +versionPolicyTests = + map (\ (vendor, release, versionString) -> + let version = (parseDebianVersion versionString) in + TestCase (assertEqual versionString (rebuildTag vendor version) version)) versionStrings ++ + [ TestCase (assertEqual + "setTag" + (parseDebianVersion "1.2-3seereason4~feisty7") + (either (error "setTag failed!") id + (setTag id "seereason" (Just "feisty") Nothing + -- version currently uploaded to the build release + (Just (parseDebianVersion "1.2-3seereason4~feisty4")) + -- All the versions in the repository + [parseDebianVersion "1.2-3seereason4~feisty5", + parseDebianVersion "1.2-3seereason4~feisty6"] + -- The version retrieved from the changelog + (parseDebianVersion "1.2-3seereason4")))) + , TestCase (assertEqual + "setTag2" + (Right (parseDebianVersion "3000.0.2.1-2+6seereason1~feisty1")) + (setTag id "seereason" (Just "feisty") Nothing + (Just (parseDebianVersion "3000.0.2.1-1+6seereason1~feisty3")) + [parseDebianVersion "3000.0.2.1-1+6seereason3", + parseDebianVersion "3000.0.2.1-1+6seereason1~feisty3", + parseDebianVersion "3000.0.2.1-1+6seereason1~feisty2", + parseDebianVersion "3000.0.2.1-1+6seereason1~feisty1", + parseDebianVersion "3000.0.2.1-1+6seereason0~gutsy4", + parseDebianVersion "3000.0.2.1-1+6seereason0~gutsy3", + parseDebianVersion "3000.0.2.1-1+6seereason0~gutsy2", + parseDebianVersion "3000.0.2-2+6"] + (parseDebianVersion "3000.0.2.1-2+6"))) + , TestCase (assertEqual + "setTag" + (parseDebianVersion "0.4.0.1") + (fst (parseTag "seereason" (parseDebianVersion "0.4.0.1-0seereason1")))) + , TestCase (assertEqual + "appendTag (parseTag \"seereason\" (parseDebianVersion \"0.4.0.1-0seereason1\")) -> \"0.4.0.1-0seereason1\"" + (parseDebianVersion "0.4.0.1-0seereason1") + (uncurry (appendTag id) (parseTag "seereason" (parseDebianVersion "0.4.0.1-0seereason1")))) + , TestCase (assertEqual + "setTag \"seereason\" (Just \"gutsy\") \"0.4.0.1-0seereason1\" -> \"0.4.0.1-0seereason1~gutsy1\"" + (parseDebianVersion "0.4.0.1-0seereason1~gutsy1") + (either (error "setTag failed!") id + (setTag id "seereason" (Just "gutsy") Nothing + -- version currently uploaded to the build release + Nothing + -- All the versions in the repository + [] + -- The version retrieved from the changelog + (parseDebianVersion "0.4.0.1-0seereason1")))) ] + +versionStrings = [ ("seereason", Just "feisty", "1.2-3seereason4~feisty5") + , ("seereason", Just "feisty", "1.2-3") + , ("seereason", Nothing, "1.2-3seereason4") + , ("seereason", Nothing, "1.2-0seereason4") ] + +rebuildTag vendor version = + case parseTag vendor version of + (version, Just tag) -> appendTag id version (Just tag) + (version, Nothing) -> version diff --git a/Test/Versions.hs b/Test/Versions.hs new file mode 100644 --- /dev/null +++ b/Test/Versions.hs @@ -0,0 +1,111 @@ +module Test.Versions where + +import Test.HUnit + +import Debian.Version + +-- * Implicit Values + +implicit1 = + TestCase (assertEqual "1.0 == 1.0-" EQ (compare (parseDebianVersion "1.0") (parseDebianVersion "1.0-"))) + +implicit2 = + TestCase (assertEqual "1.0 == 1.0-0" EQ (compare (parseDebianVersion "1.0") (parseDebianVersion "1.0-0"))) + +implicit3 = + TestCase (assertEqual "1.0 == 0:1.0-0" EQ (compare (parseDebianVersion "1.0") (parseDebianVersion "0:1.0-0"))) + +implicit4 = + TestCase (assertEqual "1.0 == 1.0-" EQ (compare (parseDebianVersion "1.0") (parseDebianVersion "1.0-"))) + +implicit5 = + TestCase (assertEqual "apple = apple0" EQ (compare (parseDebianVersion "apple") (parseDebianVersion "apple0"))) + +implicit6 = + TestCase (assertEqual "apple = apple0-" EQ (compare (parseDebianVersion "apple") (parseDebianVersion "apple0-"))) + +implicit7 = + TestCase (assertEqual "apple = apple0-0" EQ (compare (parseDebianVersion "apple") (parseDebianVersion "apple0-0"))) + +-- * epoch, version, revision + +epoch1 = + TestCase (assertEqual "epoch 0:0" (Just 0) (epoch $ parseDebianVersion "0:0")) + +epoch2 = + TestCase (assertEqual "epoch 0" Nothing(epoch $ parseDebianVersion "0")) + +epoch3 = + TestCase (assertEqual "epoch 1:0" (Just 1) (epoch $ parseDebianVersion "1:0")) + +version1 = + TestCase (assertEqual "version apple" "apple" (version $ parseDebianVersion "apple")) + +version2 = + TestCase (assertEqual "version apple0" "apple0" (version $ parseDebianVersion "apple0")) + +version3 = + TestCase (assertEqual "version apple1" "apple1" (version $ parseDebianVersion "apple1")) + +revision1 = + TestCase (assertEqual "revision 1.0" Nothing (revision $ parseDebianVersion "1.0")) + +revision2 = + TestCase (assertEqual "revision 1.0-" (Just "") (revision $ parseDebianVersion "1.0-")) + +revision3 = + TestCase (assertEqual "revision 1.0-0" (Just "0") (revision $ parseDebianVersion "1.0-0")) + +revision4 = + TestCase (assertEqual "revision 1.0-apple" (Just "apple") (revision $ parseDebianVersion "1.0-apple")) + + +-- * Ordering + +compareV str1 str2 = compare (parseDebianVersion str1) (parseDebianVersion str2) + +order1 = + TestCase (assertEqual "1:1-1 > 0:1-1" GT (compareV "1:1-1" "0:1-1")) + +order2 = + TestCase (assertEqual "1-1-1 > 1-1" GT (compareV "1-1-1" "1-1")) + +-- * Dashes in upstream version + +dash1 = + TestCase (assertEqual "version of upstream-version-revision" "upstream-version" (version (parseDebianVersion "upstream-version-revision"))) + +dash2 = + TestCase (assertEqual "revision of upstream-version-revision" (Just "revision") (revision (parseDebianVersion "upstream-version-revision"))) + +-- * Insignificant Zero's + +zero1 = + TestCase (assertEqual "0.09 = 0.9" EQ (compareV "0.09" "0.9")) + +-- * Tests + +versionTests = + [ TestLabel "implicit1" implicit1 + , TestLabel "implicit2" implicit2 + , TestLabel "implicit3" implicit3 + , TestLabel "implicit4" implicit4 + , TestLabel "implicit5" implicit5 + , TestLabel "implicit5" implicit6 + , TestLabel "implicit5" implicit7 + , TestLabel "epoch1" epoch1 + , TestLabel "epoch2" epoch2 + , TestLabel "epoch3" epoch3 + , TestLabel "version1" version1 + , TestLabel "version2" version2 + , TestLabel "version3" version3 + , TestLabel "revision1" revision1 + , TestLabel "revision2" revision2 + , TestLabel "revision3" revision3 + , TestLabel "revision4" revision4 + , TestLabel "order1" order1 + , TestLabel "order2" order2 + , dash1 + , dash2 + , zero1 + ] diff --git a/debian.cabal b/debian.cabal --- a/debian.cabal +++ b/debian.cabal @@ -1,72 +1,119 @@ Name: debian -Version: 3.40 +Version: 3.46 License: BSD3 -License-File: debian/copyright +License-File: debian/copyright Author: David Fox -Category: System +Category: System Maintainer: david@seereason.com -Homepage: http://src.seereason.com/ghc6103/haskell-debian-3 -Build-Depends: base >= 4 && < 5, syb, bytestring, containers, directory, filepath, mtl, network, old-locale, parsec >= 3, pretty, process, regex-compat, regex-posix, time, unix, bzlib, HaXml, Unixutils, zlib -Build-Type: Simple +Homepage: http://src.seereason.com/haskell-debian +Build-Type: Simple Synopsis: Modules for working with the Debian package system +Cabal-Version: >= 1.2 Description: This library includes modules covering some basic data types defined by the Debian policy manual - version numbers, control file syntax, etc. -ghc-options: -O2 -threaded -W -Extensions: ExistentialQuantification -Exposed-modules: - Debian.Apt.Dependencies, - Debian.Apt.Index, - Debian.Apt.Methods, - Debian.Apt.Package, - Debian.Changes, - Debian.Control, - Debian.Control.Common, - Debian.Control.PrettyPrint, - Debian.Control.ByteString, - Debian.Control.String, - Debian.Deb, - Debian.Extra.Files, - Debian.GenBuildDeps, - Debian.Relation, - Debian.Relation.ByteString, - Debian.Relation.Common, - Debian.Relation.String, +extra-source-files: + Test/Main.hs, Test/Changes.hs, Test/Dependencies.hs, + Test/SourcesList.hs, Test/VersionPolicy.hs, Test/Versions.hs + +Flag cabal19 + Description: True if Cabal >= 1.9 is available + +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, Unixutils, zlib, HUnit + ghc-options: -O2 -W -Wall + if flag(cabal19) + build-depends: Cabal >= 1.9 + cpp-options: -DCABAL19 + else + build-depends: Cabal >= 1.8 + cpp-options: -DCABAL18 + Extensions: ExistentialQuantification CPP + Exposed-modules: + Debian.Apt.Dependencies, + Debian.Apt.Index, + Debian.Apt.Methods, + Debian.Apt.Package, + Debian.Changes, + Debian.Control, + Debian.Control.Common, + Debian.Control.PrettyPrint, + Debian.Control.ByteString, + Debian.Control.String, + Debian.Deb, + Debian.Extra.Files, + Debian.GenBuildDeps, + Debian.Relation, + Debian.Relation.ByteString, + Debian.Relation.Common, + Debian.Relation.String, Debian.Release, Debian.Sources, - Debian.Version, - Debian.Version.Common, - Debian.Version.String, - Debian.Version.ByteString, - Debian.Report, + Debian.Version, + Debian.Version.Common, + Debian.Version.String, + Debian.Version.ByteString, + Debian.Report, Debian.Time, Debian.URI, - Debian.Util.FakeChanges -other-modules: - Debian.Version.Internal, - Distribution.Package.Debian.Bundled, - Distribution.Package.Debian.Setup, - Distribution.Package.Debian.Main, - Distribution.Package.Debian -extra-source-files: - tests/Main.hs + Debian.Util.FakeChanges + other-modules: + Debian.Version.Internal, + Distribution.Package.Debian.Bundled, + Distribution.Package.Debian.Setup, + Distribution.Package.Debian.Main, + Distribution.Package.Debian, + Test.Changes, + Test.Dependencies, + Test.SourcesList, + Test.Versions -Executable: fakechanges -Main-is: utils/FakeChanges.hs -ghc-options: -O2 -threaded -W +Executable fakechanges + Main-is: utils/FakeChanges.hs + ghc-options: -O2 -threaded -W + Extensions: ExistentialQuantification CPP + if flag(cabal19) + build-depends: Cabal >= 1.9 + cpp-options: -DCABAL19 + else + build-depends: Cabal >= 1.8 + cpp-options: -DCABAL18 -Executable: debian-report -Main-is: utils/Report.hs -ghc-options: -O2 -threaded -W -C-Sources: cbits/gwinsz.c -Include-Dirs: cbits -Install-Includes: gwinsz.h +Executable debian-report + Main-is: utils/Report.hs + ghc-options: -O2 -threaded -W + C-Sources: cbits/gwinsz.c + Include-Dirs: cbits + Install-Includes: gwinsz.h + Extensions: ExistentialQuantification CPP + if flag(cabal19) + build-depends: Cabal >= 1.9 + cpp-options: -DCABAL19 + else + build-depends: Cabal >= 1.8 + cpp-options: -DCABAL18 -Executable: cabal-debian -Main-is: utils/CabalDebian.hs -ghc-options: -O2 -threaded -W -Build-Depends: Cabal >= 1.6.0.1 +Executable cabal-debian + Main-is: utils/CabalDebian.hs + ghc-options: -O2 -threaded -W + Build-Depends: Cabal >= 1.6.0.1 + Extensions: ExistentialQuantification CPP + if flag(cabal19) + build-depends: Cabal >= 1.9 + cpp-options: -DCABAL19 + else + build-depends: Cabal >= 1.8 + cpp-options: -DCABAL18 -Executable: apt-get-build-depends -Main-is: utils/AptGetBuildDeps.hs -ghc-options: -O2 -threaded -W +Executable apt-get-build-depends + Main-is: utils/AptGetBuildDeps.hs + ghc-options: -O2 -threaded -W + Extensions: ExistentialQuantification CPP + if flag(cabal19) + build-depends: Cabal >= 1.9 + cpp-options: -DCABAL19 + else + build-depends: Cabal >= 1.8 + cpp-options: -DCABAL18 diff --git a/tests/Main.hs b/tests/Main.hs deleted file mode 100644 --- a/tests/Main.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Main where - -import Test.HUnit -import System.Exit -import Versions -import VersionPolicy -import SourcesList -import Dependencies - -main = - do (c,st) <- runTestText putTextToShowS (TestList (versionTests ++ versionPolicyTests ++ sourcesListTests ++ dependencyTests)) - putStrLn (st "") - case (failures c) + (errors c) of - 0 -> return () - n -> exitFailure -