diff --git a/Debian/Control/ByteString.hs b/Debian/Control/ByteString.hs --- a/Debian/Control/ByteString.hs +++ b/Debian/Control/ByteString.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PackageImports, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, PackageImports, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-orphans #-} module Debian.Control.ByteString ( Control'(..) @@ -24,8 +24,11 @@ import qualified Control.Exception as E import "mtl" Control.Monad.State -import Data.Char(toLower) +import Data.Char(toLower, isSpace, chr, ord) +import Data.Word (Word8) import Data.List +import qualified Data.ListLike as LL +import qualified Data.ListLike.String as LL import Text.ParserCombinators.Parsec.Error import Text.ParserCombinators.Parsec.Pos @@ -34,7 +37,7 @@ import qualified Data.ByteString.Char8 as C -import Debian.Control.Common +import Debian.Control.Common hiding (protectFieldText') -- Local Modules @@ -119,7 +122,23 @@ -- NOTE: probably inefficient stripWS = C.reverse . strip . C.reverse . strip where strip = C.dropWhile (flip elem " \t") + protectFieldText = protectFieldText' asString = C.unpack + +protectFieldText' :: (LL.StringLike a, LL.ListLike a Word8) => ControlFunctions a => a -> a +protectFieldText' s = + case LL.lines s of + [] -> LL.empty + (l : ls) -> dropWhileEnd (isSpace . chr . fromIntegral) $ LL.unlines $ l : map protect ls + where + dropWhileEnd :: (LL.StringLike a, LL.ListLike a Word8) => (Word8 -> Bool) -> a -> a + dropWhileEnd func = LL.reverse . LL.dropWhile func . LL.reverse -- foldr (\x xs -> if func x && LL.null xs then LL.empty else LL.cons x xs) empty + protect :: (LL.StringLike a, LL.ListLike a Word8) => a -> a + protect l = maybe LL.empty (\ c -> if isHorizSpace c then l else LL.cons (ord' ' ' :: Word8) l) (LL.find (const True :: Word8 -> Bool) l) + isSpace' = isSpace . chr' + isHorizSpace c = elem c (map ord' " \t") + ord' = fromIntegral . ord + chr' = chr . fromIntegral {- main = diff --git a/Debian/Control/Common.hs b/Debian/Control/Common.hs --- a/Debian/Control/Common.hs +++ b/Debian/Control/Common.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings, UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, OverloadedStrings, ScopedTypeVariables, UndecidableInstances #-} module Debian.Control.Common ( -- * Types Control'(..) @@ -15,10 +15,14 @@ , raiseFields , parseControlFromCmd , md5sumField + , protectFieldText' ) where +import Data.Char (isSpace) import Data.List (partition, intersperse) +import Data.ListLike as LL (ListLike, dropWhile, empty, cons, find, reverse) +import Data.ListLike.String as LL (StringLike, lines, unlines) import Data.Monoid ((<>)) import Debian.Pretty (PP(..)) import System.Exit (ExitCode(ExitSuccess, ExitFailure)) @@ -57,28 +61,48 @@ -- string. Folded whitespace is /not/ unfolded. This should probably -- be moved to someplace more general purpose. stripWS :: a -> a + -- |Protect field value text so the parser doesn't split it into + -- multiple fields or paragraphs. This must modify all field text + -- to enforce two conditions: (1) All lines other than the initial + -- one must begin with a space or a tab, and (2) the trailing + -- white space must not contain newlines. This is called before + -- pretty printing to prevent the parser from misinterpreting + -- field text as multiple fields or paragraphs. + protectFieldText :: a -> a asString :: a -> String +-- | This can usually be used as the implementation of protectFieldText +protectFieldText' :: forall a. (StringLike a, ListLike a Char) => ControlFunctions a => a -> a +protectFieldText' s = + case LL.lines s of + [] -> empty + (l : ls) -> dropWhileEnd isSpace $ LL.unlines $ l : map protect ls + where + dropWhileEnd :: (Char -> Bool) -> a -> a + dropWhileEnd func = LL.reverse . LL.dropWhile func . LL.reverse -- foldr (\x xs -> if func x && LL.null xs then LL.empty else LL.cons x xs) empty + protect :: a -> a + protect l = maybe empty (\ c -> if elem c " \t" then l else LL.cons ' ' l) (LL.find (const True) l) + -- | This may have bad performance issues (dsf: Whoever wrote this -- comment should have explained why.) -instance Pretty (PP a) => Pretty (PP (Control' a)) where +instance (ControlFunctions a, Pretty (PP a)) => Pretty (PP (Control' a)) where pPrint = ppControl . unPP -instance Pretty (PP a) => Pretty (PP (Paragraph' a)) where +instance (ControlFunctions a, Pretty (PP a)) => Pretty (PP (Paragraph' a)) where pPrint = ppParagraph . unPP -instance Pretty (PP a) => Pretty (PP (Field' a)) where +instance (ControlFunctions a, Pretty (PP a)) => Pretty (PP (Field' a)) where pPrint = ppField . unPP -ppControl :: Pretty (PP a) => Control' a -> Doc +ppControl :: (ControlFunctions a, Pretty (PP a)) => Control' a -> Doc ppControl (Control paragraph) = hcat (intersperse (text "\n") (map ppParagraph paragraph)) -ppParagraph :: Pretty (PP a) => Paragraph' a -> Doc +ppParagraph :: (ControlFunctions a, Pretty (PP a)) => Paragraph' a -> Doc ppParagraph (Paragraph fields) = hcat (map (\ x -> ppField x <> text "\n") fields) -ppField :: Pretty (PP a) => Field' a -> Doc -ppField (Field (n,v)) = pPrint (PP n) <> text ":" <> pPrint (PP v) +ppField :: (ControlFunctions a, Pretty (PP a)) => Field' a -> Doc +ppField (Field (n,v)) = pPrint (PP n) <> text ":" <> pPrint (PP (protectFieldText v)) ppField (Comment c) = pPrint (PP c) mergeControls :: [Control' a] -> Control' a diff --git a/Debian/Control/Policy.hs b/Debian/Control/Policy.hs --- a/Debian/Control/Policy.hs +++ b/Debian/Control/Policy.hs @@ -49,9 +49,6 @@ instance Show DebianControl where show c = "(parseDebianControl \"\" " ++ show (ppDisplay (unDebianControl c)) ++ ")" -instance Show (Control' Text) where - show c = "(parseControl \"\" " ++ show (ppDisplay c) ++ ")" - -- | Validate and return a control file in an opaque wrapper. May -- throw a ControlFileError. Currently we only verify that it has a -- Source field in the first paragraph and one or more subsequent diff --git a/Debian/Control/String.hs b/Debian/Control/String.hs --- a/Debian/Control/String.hs +++ b/Debian/Control/String.hs @@ -26,10 +26,10 @@ import qualified Control.Exception as E import Data.Char (toLower) import Data.List (find) -import Debian.Control.Common (ControlFunctions(parseControlFromFile, parseControlFromHandle, parseControl, lookupP, stripWS, asString), +import Debian.Control.Common (ControlFunctions(parseControlFromFile, parseControlFromHandle, parseControl, lookupP, stripWS, protectFieldText, asString), Control'(Control), Paragraph'(Paragraph), Field'(Field, Comment), mergeControls, fieldValue, removeField, prependFields, appendFields, - renameField, modifyField, raiseFields) + renameField, modifyField, raiseFields, protectFieldText') import System.IO (hGetContents) import Text.ParserCombinators.Parsec (CharParser, parse, parseFromFile, sepEndBy, satisfy, oneOf, string, lookAhead, try, many, many1, (<|>), noneOf, char, eof) @@ -53,6 +53,7 @@ hasFieldName _ _ = False stripWS = reverse . strip . reverse . strip where strip = dropWhile (flip elem " \t") + protectFieldText = protectFieldText' asString = id -- * Control File Parser diff --git a/Debian/Control/Text.hs b/Debian/Control/Text.hs --- a/Debian/Control/Text.hs +++ b/Debian/Control/Text.hs @@ -27,9 +27,9 @@ ) where import qualified Data.ByteString.Char8 as B -import Data.Char (toLower, chr) +import Data.Char (toLower, chr, isSpace) import Data.List (find) -import qualified Data.Text as T (Text, pack, unpack, map, strip, reverse) +import qualified Data.Text as T (Text, pack, unpack, map, strip, reverse, dropWhileEnd) import Data.Text.Encoding (decodeUtf8With, encodeUtf8) --import Data.Text.IO as T (readFile) import qualified Debian.Control.ByteString as B @@ -39,7 +39,7 @@ import Debian.Control.Common (ControlFunctions(parseControlFromFile, parseControlFromHandle, parseControl, lookupP, stripWS, asString), Control'(Control), Paragraph'(Paragraph), Field'(Field, Comment), mergeControls, fieldValue, removeField, prependFields, appendFields, - renameField, modifyField, raiseFields) + renameField, modifyField, raiseFields, protectFieldText') -- | @parseFromFile p filePath@ runs a string parser @p@ on the -- input read from @filePath@ using 'Prelude.readFile'. Returns either a 'ParseError' @@ -93,6 +93,7 @@ hasFieldName name (Field (fieldName',_)) = T.pack name == T.map toLower fieldName' hasFieldName _ _ = False stripWS = T.reverse . T.strip . T.reverse . T.strip + protectFieldText = protectFieldText' asString = T.unpack -- * Control File Parser diff --git a/Test/Control.hs b/Test/Control.hs --- a/Test/Control.hs +++ b/Test/Control.hs @@ -8,9 +8,10 @@ import Debian.Control import Debian.Control.Policy import Debian.Control.Text ({- Pretty instances -}) -import Debian.Pretty (ppPrint) +import Debian.Pretty (ppPrint, ppDisplay) import Debian.Relation import Debian.Version (parseDebianVersion) +import Text.Parsec.Error (ParseError) import Text.PrettyPrint.HughesPJClass (Doc, text) instance Eq Doc where @@ -40,13 +41,35 @@ , TestCase (parseDebianControlFromFile "Test/Control.hs" >>= \ vc -> assertEqual "policy4" -- Exceptions have bogus Eq instances, so we need to show then compare. - "Left (ParseControlError {locs = [Loc {loc_filename = \"./Debian/Control/Policy.hs\", loc_package = \"main\", loc_module = \"Debian.Control.Policy\", loc_start = (78,54), loc_end = (78,62)}], parseError = \"Test/Control.hs\" (line 0, column 0):\nFailed to parse Test/Control.hs})" + "Left (ParseControlError {locs = [Loc {loc_filename = \"./Debian/Control/Policy.hs\", loc_package = \"main\", loc_module = \"Debian.Control.Policy\", loc_start = (75,54), loc_end = (75,62)}], parseError = \"Test/Control.hs\" (line 0, column 0):\nFailed to parse Test/Control.hs})" (show (either Left (either Left Right . debianRelations "Foo") vc))) , TestCase (parseDebianControlFromFile "nonexistant" >>= \ vc -> assertEqual "policy5" - "Left (IOError {locs = [Loc {loc_filename = \"./Debian/Control/Policy.hs\", loc_package = \"main\", loc_module = \"Debian.Control.Policy\", loc_start = (77,36), loc_end = (77,44)}], ioError = nonexistant: openBinaryFile: does not exist (No such file or directory)})" + "Left (IOError {locs = [Loc {loc_filename = \"./Debian/Control/Policy.hs\", loc_package = \"main\", loc_module = \"Debian.Control.Policy\", loc_start = (74,36), loc_end = (74,44)}], ioError = nonexistant: openBinaryFile: does not exist (No such file or directory)})" (show (either Left (debianRelations "Foo") (vc :: Either ControlFileError DebianControl)))) + + -- Test whether embedded newlines in field values can be mistaken + -- for field or paragraph divisions. In cases pretty7 and pretty9 + -- the parsed output is not correct, so the buggy result is placed + -- in the "expected" position. + , TestCase (assertEqual "pretty6" input6 parsed6) + , TestCase (assertEqual "pretty7" expected7 parsed7) + , TestCase (assertEqual "pretty8" input8 parsed8) + , TestCase (assertEqual "pretty9" expected9 parsed9) ] + where + input6 = Control {unControl = [Paragraph [Field ("Field1", " field1 begins\n Field1a: indented text that looks like a field")]]} :: Control' String + input7 = Control {unControl = [Paragraph [Field ("Field1", " field1 begins\nField1a: text that looks like a field")]]} :: Control' String + -- parsed7buggy = Control {unControl = [Paragraph [Field ("Field1"," field1 begins"),Field ("Field1a"," text that looks like a field")]]} :: Control' String + expected7 = Control {unControl = [Paragraph [Field ("Field1"," field1 begins\n Field1a: text that looks like a field")]]} + input8 = Control {unControl = [Paragraph [Field ("Field1", " field1 content"), Field ("Field2", " an actual second field")]]} :: Control' String + input9 = Control {unControl = [Paragraph [Field ("Field1", " field1 content\n"), Field ("Field2", " an actual second field")]]} :: Control' String + -- parsed9buggy = Control {unControl = [Paragraph [Field ("Field1"," field1 content")],Paragraph [Field ("Field2"," an actual second field")]]} :: Control' String + expected9 = Control {unControl = [Paragraph [Field ("Field1"," field1 content"),Field ("Field2"," an actual second field")]]} + (Right parsed6) = parseControl "string" (ppDisplay input6) :: Either ParseError (Control' String) + (Right parsed7) = parseControl "string" (ppDisplay input7) :: Either ParseError (Control' String) + (Right parsed8) = parseControl "string" (ppDisplay input8) :: Either ParseError (Control' String) + (Right parsed9) = parseControl "string" (ppDisplay input9) :: Either ParseError (Control' String) -- | These paragraphs have no terminating newlines. They are added -- where appropriate to the expected test results. diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,17 @@ +haskell-debian (3.84.2) unstable; urgency=low + + * Fix some cases where the pretty printer output parsed to something + different from its input + + -- David Fox Sat, 29 Nov 2014 09:27:42 -0800 + +haskell-debian (3.84.1) unstable; urgency=low + + * Remove a Show instance that overlaps the one derived in the Control + type declaration. + + -- David Fox Sat, 29 Nov 2014 05:18:40 -0800 + haskell-debian (3.84) unstable; urgency=low * Replace the Debian.Pretty module with a module copied from the diff --git a/debian.cabal b/debian.cabal --- a/debian.cabal +++ b/debian.cabal @@ -1,5 +1,5 @@ Name: debian -Version: 3.84 +Version: 3.85 License: BSD3 License-File: debian/copyright Author: David Fox , Jeremy Shaw , Clifford Beshers diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,17 @@ +haskell-debian (3.84.2) unstable; urgency=low + + * Fix some cases where the pretty printer output parsed to something + different from its input + + -- David Fox Sat, 29 Nov 2014 09:27:42 -0800 + +haskell-debian (3.84.1) unstable; urgency=low + + * Remove a Show instance that overlaps the one derived in the Control + type declaration. + + -- David Fox Sat, 29 Nov 2014 05:18:40 -0800 + haskell-debian (3.84) unstable; urgency=low * Replace the Debian.Pretty module with a module copied from the