diff --git a/Debian/Control/Policy.hs b/Debian/Control/Policy.hs --- a/Debian/Control/Policy.hs +++ b/Debian/Control/Policy.hs @@ -77,7 +77,7 @@ (either (return . Left . ParseControlError [$__LOC__]) validateDebianControl) -- | Class of things that contain a validated Debian control file. -class HasDebianControl a where +class Show a => HasDebianControl a where debianControl :: a -> DebianControl instance HasDebianControl DebianControl where @@ -96,7 +96,7 @@ -- line number generated by template haskell. data ControlFileError = NoParagraphs {locs :: [Loc]} - | NoBinaryParagraphs {locs :: [Loc]} + | NoBinaryParagraphs {locs :: [Loc], ctl :: String} | MissingField {locs :: [Loc], field :: String} | ParseRelationsError {locs :: [Loc], parseError :: ParseError} | ParseControlError {locs :: [Loc], parseError :: ParseError} @@ -105,7 +105,7 @@ instance Show ControlFileError where show (NoParagraphs {..}) = intercalate ", " (map showLoc locs) ++ ": NoParagraphs" - show (NoBinaryParagraphs {..}) = intercalate ", " (map showLoc locs) ++ ": NoBinaryParagraphs" + show (NoBinaryParagraphs {..}) = intercalate ", " (map showLoc locs) ++ ": NoBinaryParagraphs (" ++ show ctl ++ ")" show (MissingField {..}) = intercalate ", " (map showLoc locs) ++ ": MissingField " ++ show field show (ParseRelationsError {..}) = intercalate ", " (map showLoc locs) ++ ": ParseRelationsError " ++ show parseError show (ParseControlError {..}) = intercalate ", " (map showLoc locs) ++ ": ParseControlError " ++ show parseError @@ -128,7 +128,7 @@ debianPackageParagraphs :: HasDebianControl a => a -> (Paragraph' Text, [Paragraph' Text]) debianPackageParagraphs ctl = case removeCommentParagraphs ctl of - DebianControl (Control [_]) -> throw $ NoBinaryParagraphs [$__LOC__] + DebianControl (Control [_]) -> throw $ NoBinaryParagraphs [$__LOC__] (show ctl) DebianControl (Control []) -> throw $ NoParagraphs [$__LOC__] DebianControl (Control (sourceParagraph : binParagraphs)) -> (sourceParagraph, binParagraphs) diff --git a/Debian/Sources.hs b/Debian/Sources.hs --- a/Debian/Sources.hs +++ b/Debian/Sources.hs @@ -1,22 +1,58 @@ {-# LANGUAGE FlexibleInstances, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -module Debian.Sources where +module Debian.Sources + {- ( SourceType(..) + , SourceOption(..) + , SourceOp(..) + , DebSource(..) + , parseSourceLine + , parseSourceLine' + , parseSourcesList + ) -} where -import Data.List (intercalate) +import Data.Maybe (fromJust) import Data.Monoid ((<>)) +import Data.Text (Text) import Debian.Pretty (PP(..)) import Debian.Release import Network.URI (URI, uriToString, parseURI, unEscapeString, escapeURIString, isAllowedInURI) -import Text.PrettyPrint (text, hcat) +import Test.HUnit +import Text.ParserCombinators.Parsec +import Text.PrettyPrint (hcat, punctuate, render, text) import Text.PrettyPrint.HughesPJClass (Pretty(pPrint)) data SourceType = Deb | DebSrc deriving (Eq, Ord, Show) +-- arch +-- lang +-- target +-- pdiffs +-- by-hash +-- allow-insecure=no +-- allow-weak=no +-- allow-downgrade-to-insecure=no +-- trusted=no +-- signed-by +-- check-valid-until +-- valid-until-min +-- valid-until-max +data SourceOption + = SourceOption String SourceOp [String] + deriving (Eq, Ord, Show) + +data SourceOp = OpSet | OpAdd | OpDel deriving (Eq, Ord, Show) + +instance Pretty SourceOp where + pPrint OpSet = text "=" + pPrint OpAdd = text "+=" + pPrint OpDel = text "-=" + data DebSource = DebSource { sourceType :: SourceType + , sourceOptions :: [SourceOption] , sourceUri :: URI , sourceDist :: Either String (ReleaseName, [Section]) } deriving (Eq, Ord, Show) @@ -25,14 +61,21 @@ pPrint Deb = text "deb" pPrint DebSrc = text "deb-src" +instance Pretty SourceOption where + pPrint (SourceOption k op vs) = text k <> pPrint op <> hcat (punctuate (text ",") (map text vs)) + instance Pretty DebSource where - pPrint (DebSource thetype theuri thedist) = - pPrint thetype <> - text (" " <> uriToString id theuri " " <> - case thedist of - Left exactPath -> escape exactPath - Right (dist, sections) -> releaseName' dist <> " " <> intercalate " " (map sectionName' sections)) - where escape = escapeURIString isAllowedInURI + pPrint (DebSource thetype theoptions theuri thedist) = + hcat (punctuate (text " ") + ([pPrint thetype] ++ + (case theoptions of + [] -> [] + _ -> [text "[" <> hcat (punctuate (text ", ") (map pPrint theoptions)) <> text "]"]) ++ + [text (uriToString id theuri "")] ++ + case thedist of + Left exactPath -> [text (escapeURIString isAllowedInURI exactPath)] + Right (dist, sections) -> + map text (releaseName' dist : map sectionName' sections))) instance Pretty (PP [DebSource]) where pPrint = hcat . map (\ x -> pPrint x <> text "\n") . unPP @@ -121,7 +164,8 @@ -- the argument must be a non-empty, valid source line with comments stripped -- see: 'sourceLines' parseSourceLine :: String -> DebSource -parseSourceLine str = +parseSourceLine str = either error id (parseSourceLine' str) +{- case quoteWords str of (theTypeStr : theUriStr : theDistStr : sectionStrs) -> let sections = map parseSection' sectionStrs @@ -136,36 +180,144 @@ in case last theDist of '/' -> if null sections - then DebSource { sourceType = theType, sourceUri = theUri, sourceDist = Left theDist } + then DebSource { sourceType = theType, sourceOptions = [], sourceUri = theUri, sourceDist = Left theDist } else error ("parseSourceLine: Dist is an exact path, so sections are not allowed on the line:\n" ++ str) _ -> if null sections then error ("parseSourceLine: Dist is not an exact path, so at least one section is required on the line:\n" ++ str) - else DebSource { sourceType = theType, sourceUri = theUri, sourceDist = Right (parseReleaseName theDist, sections) } + else DebSource { sourceType = theType, sourceOptions = [], sourceUri = theUri, sourceDist = Right (parseReleaseName theDist, sections) } _ -> error ("parseSourceLine: invalid line in sources.list:\n" ++ str) +-} -parseSourceLine' :: String -> Maybe DebSource +parseOptions :: String -> Either ParseError [SourceOption] +parseOptions s = parse pOptions s s + +pOptions :: CharParser () [SourceOption] +pOptions = do _ <- char '[' + skipMany (oneOf [' ','\t']) + opts <- sepBy1 pOption (char ',') + skipMany (oneOf [' ','\t']) + _ <- char ']' + return opts + +pOption :: CharParser () SourceOption +pOption = do skipMany (oneOf [' ','\t']) + key <- many1 (noneOf ['+','-','=',' ','\t']) + skipMany (oneOf [' ','\t']) + op <- pOp + skipMany (oneOf [' ','\t']) + values <- sepBy1 (many1 (noneOf [',',']',' ','\t'])) (char ',') + skipMany (oneOf [' ','\t']) + return $ SourceOption key op values + +pOp :: CharParser () SourceOp +pOp = do (char '+' >> char '=' >> return OpAdd) + <|> + (char '-' >> char '=' >> return OpDel) + <|> + (char '=' >> return OpSet) + +parseSourceLine' :: String -> Either String DebSource parseSourceLine' str = case quoteWords str of - (theTypeStr : theUriStr : theDistStr : sectionStrs) -> + theTypeStr : theOptionStr@('[' : _) : theURIStr : theDistStr : sectionStrs -> + either + (Left . show) + (\opts -> go theTypeStr opts theURIStr theDistStr sectionStrs) + (parseOptions theOptionStr) + theTypeStr : theURIStr : theDistStr : sectionStrs -> + go theTypeStr [] theURIStr theDistStr sectionStrs + _ -> Left ("parseSourceLine: invalid line in sources.list:\n" ++ str) + where + go theTypeStr theOptions theURIStr theDistStr sectionStrs = let sections = map parseSection' sectionStrs theType = case unEscapeString theTypeStr of - "deb" -> Just Deb - "deb-src" -> Just DebSrc - _ -> Nothing - theUri = case parseURI theUriStr of - Nothing -> Nothing - Just u -> Just u + "deb" -> Right Deb + "deb-src" -> Right DebSrc + s -> Left ("parseSourceLine: invalid type " ++ s ++ " in line:\n" ++ str) + theURI = case parseURI theURIStr of + Nothing -> Left ("parseSourceLine: invalid uri " ++ theURIStr ++ " in the line:\n" ++ str) + Just u -> Right u theDist = unEscapeString theDistStr in - case (last theDist, theType, theUri) of - ('/', Just typ, Just uri) -> if null sections - then Just $ DebSource { sourceType = typ, sourceUri = uri, sourceDist = Left theDist } - else error ("parseSourceLine: Dist is an exact path, so sections are not allowed on the line:\n" ++ str) - (_, Just typ, Just uri) -> if null sections - then Nothing - else Just $ DebSource { sourceType = typ, sourceUri = uri, sourceDist = Right ((parseReleaseName theDist), sections) } - _ -> Nothing - _ -> Nothing + case (last theDist, theType, theURI) of + ('/', Right typ, Right uri) -> if null sections + then Right $ DebSource { sourceType = typ, sourceOptions = theOptions, sourceUri = uri, sourceDist = Left theDist } + else Left ("parseSourceLine: Dist is an exact path, so sections are not allowed on the line:\n" ++ str) + (_, Right typ, Right uri) -> if null sections + then Left ("parseSourceLine: Dist is not an exact path, so at least one section is required on the line:\n" ++ str) + else Right $ DebSource { sourceType = typ, sourceOptions = theOptions, sourceUri = uri, sourceDist = Right ((parseReleaseName theDist), sections) } + (_, Left msg, _) -> Left msg + (_, _, Left msg) -> Left msg parseSourcesList :: String -> [DebSource] parseSourcesList = map parseSourceLine . sourceLines + +-- * 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 "parse and pretty sources.list" validSourcesListExpected (render . pPrint . PP . parseSourcesList $ validSourcesListStr) ] + +testSourcesList2 :: Test +testSourcesList2 = + test [ assertEqual "pretty sources.list" validSourcesListExpected (render . pPrint . PP $ validSourcesList) ] + +validSourcesListStr :: String +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 [trusted=yes] http://ftp.debian.org/whee \"space dist\" main" + , "deb [trusted=yes] http://ftp.debian.org/whee dist space%20section" + ] + +validSourcesList :: [DebSource] +validSourcesList = + [DebSource {sourceType = Deb, sourceOptions = [], sourceUri = fromJust (parseURI "ftp://ftp.debian.org/debian"), sourceDist = Right (ReleaseName {relName = "unstable"},[Section "main",Section "contrib",Section "non-free"])}, + DebSource {sourceType = DebSrc, sourceOptions = [], sourceUri = fromJust (parseURI "ftp://ftp.debian.org/debian"), sourceDist = Right (ReleaseName {relName = "unstable"},[Section "main",Section "contrib",Section "non-free"])}, + DebSource {sourceType = Deb, sourceOptions = [], sourceUri = fromJust (parseURI "http://pkg-kde.alioth.debian.org/kde-3.5.0/"), sourceDist = Left "./"}, + DebSource {sourceType = Deb, sourceOptions = [SourceOption "trusted" OpSet ["yes"]], sourceUri = fromJust (parseURI "http://ftp.debian.org/whee"), sourceDist = Right (ReleaseName {relName = "space dist"},[Section "main"])}, + DebSource {sourceType = Deb, sourceOptions = [SourceOption "trusted" OpSet ["yes"]], sourceUri = fromJust (parseURI "http://ftp.debian.org/whee"), sourceDist = Right (ReleaseName {relName = "dist"},[Section "space section"])}] + +validSourcesListExpected :: String +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 [trusted=yes] http://ftp.debian.org/whee space%20dist main" + , "deb [trusted=yes] http://ftp.debian.org/whee dist space%20section" + ] +_invalidSourcesListStr1 :: Text +_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 "" gutsy (mconcat . map (<> "\n") . map (render . pPrint) . parseSourcesList $ gutsy) ] + where + gutsy = 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 :: Test +sourcesListTests = + TestList [ testQuoteWords, testSourcesList, testSourcesList2, testSourcesListParse ] diff --git a/Test/Main.hs b/Test/Main.hs --- a/Test/Main.hs +++ b/Test/Main.hs @@ -5,12 +5,12 @@ import Changes import Control import Versions -import SourcesList +import Debian.Sources import Dependencies import Text.PrettyPrint main = - do (c,st) <- runTestText putTextToShowS (TestList (versionTests ++ sourcesListTests ++ dependencyTests ++ changesTests ++ controlTests ++ prettyTests)) + do (c,st) <- runTestText putTextToShowS (TestList (versionTests ++ [sourcesListTests] ++ dependencyTests ++ changesTests ++ controlTests ++ prettyTests)) putStrLn (st "") case (failures c) + (errors c) of 0 -> return () diff --git a/Test/SourcesList.hs b/Test/SourcesList.hs deleted file mode 100644 --- a/Test/SourcesList.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module SourcesList where - -import Data.Text (Text) -import Data.Monoid (mconcat, (<>)) -import Debian.Pretty (PP(PP)) -import Debian.Sources -import Test.HUnit -import Text.PrettyPrint (render) -import Text.PrettyPrint.HughesPJClass (pPrint) - --- * 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 (render . pPrint . PP . 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" :: Text - -testSourcesListParse :: Test -testSourcesListParse = - test [ assertEqual "" gutsy (mconcat . map (<> "\n") . map (render . pPrint) . parseSourcesList $ gutsy) ] - where - gutsy = 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 :: [Test] -sourcesListTests = - [ testQuoteWords, testSourcesList, testSourcesListParse ] diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,12 @@ +haskell-debian (3.92) unstable; urgency=low + + * Support parsing of the option list in sources.list lines - see + https://manpages.debian.org/stretch/apt/sources.list.5.en.html + * Move tests of sources.list pretty and parse into Debian.Sources + * Change sig of parseSourceLine' to return Either rather than Maybe + + -- David Fox Wed, 12 Jul 2017 06:30:01 -0700 + haskell-debian (3.91.2) unstable; urgency=low * Work around for https://ghc.haskell.org/trac/ghc/ticket/12130 diff --git a/debian.cabal b/debian.cabal --- a/debian.cabal +++ b/debian.cabal @@ -1,5 +1,5 @@ Name: debian -Version: 3.91.2 +Version: 3.92 License: BSD3 License-File: debian/copyright Author: David Fox , Jeremy Shaw , Clifford Beshers @@ -14,7 +14,7 @@ the Debian policy manual - version numbers, control file syntax, etc. extra-source-files: Test/Main.hs, Test/Changes.hs, Test/Dependencies.hs, - Test/SourcesList.hs, Test/Versions.hs, Test/Control.hs, changelog, debian/changelog, debian/changelog.pre-debian + Test/Versions.hs, Test/Control.hs, changelog, debian/changelog, debian/changelog.pre-debian flag network-uri Description: Get Network.URI from the network-uri package @@ -23,6 +23,7 @@ flag pretty-new Description: pretty-1.1.2 includes the Text.PrettyPrint.HughesPJClass module from prettyclass Default: True + Manual: True Library Hs-Source-Dirs: . diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,12 @@ +haskell-debian (3.92) unstable; urgency=low + + * Support parsing of the option list in sources.list lines - see + https://manpages.debian.org/stretch/apt/sources.list.5.en.html + * Move tests of sources.list pretty and parse into Debian.Sources + * Change sig of parseSourceLine' to return Either rather than Maybe + + -- David Fox Wed, 12 Jul 2017 06:30:01 -0700 + haskell-debian (3.91.2) unstable; urgency=low * Work around for https://ghc.haskell.org/trac/ghc/ticket/12130