diff --git a/Debian/Changes.hs b/Debian/Changes.hs --- a/Debian/Changes.hs +++ b/Debian/Changes.hs @@ -167,11 +167,11 @@ -- | Parse the entries of a debian changelog and verify they are all -- valid. -parseChangeLog :: String -> ChangeLog +parseChangeLog :: String -> Either [[String]] ChangeLog parseChangeLog s = case partitionEithers (parseEntries s) of - ([], xs) -> ChangeLog xs - (ss, _) -> error (intercalate "\n " ("Error(s) parsing changelog:" : concat ss)) + ([], xs) -> Right (ChangeLog xs) + (ss, _) -> Left ss -- |Parse a Debian Changelog and return a lazy list of entries parseEntries :: String -> [Either [String] ChangeLogEntry] @@ -182,27 +182,6 @@ Right (entry, text') -> Right entry : parseEntries text' -- |Parse a single changelog entry, returning the entry and the remaining text. -{- -parseEntry :: String -> Failing (ChangeLogEntry, String) -parseEntry 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 @@ -218,30 +197,10 @@ after) 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 - 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. diff --git a/Debian/Control.hs b/Debian/Control.hs --- a/Debian/Control.hs +++ b/Debian/Control.hs @@ -51,7 +51,9 @@ import Debian.Control.String import Data.List import Data.Text as T (Text, pack, concat) +import qualified Debian.Control.Builder () import qualified Debian.Control.Text as T +import qualified Debian.Control.TextLazy as TL import qualified Debian.Control.ByteString as B () import qualified Debian.Control.Policy as P import qualified Debian.Control.String as S diff --git a/Debian/Control/Builder.hs b/Debian/Control/Builder.hs new file mode 100644 --- /dev/null +++ b/Debian/Control/Builder.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} +module Debian.Control.Builder + ( -- * Types + Control'(..) + , Paragraph'(..) + , Field'(..) + , Control + , Paragraph + , Field + -- , ControlParser + , ControlFunctions(..) + -- * Control File Parser + -- , pControl + -- * Helper Functions + , mergeControls + , fieldValue + , removeField + , prependFields + , appendFields + , renameField + , modifyField + , raiseFields + , decodeControl + , decodeParagraph + , decodeField + ) where + +import qualified Data.ByteString.Char8 as B +import Data.Char (toLower, chr) +import Data.List (find) +import qualified Data.ListLike as LL +import Data.ListLike.Text.Builder () +import qualified Data.Text as T (pack, unpack, map, reverse) +import Data.Text.Lazy (toStrict) +import Data.Text.Lazy.Builder (Builder, fromLazyText, fromText, toLazyText) +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) +--import Data.Text.IO as T (readFile) +import qualified Debian.Control.ByteString as B +--import Text.Parsec.Error (ParseError) +--import Text.Parsec.Text (Parser) +--import Text.Parsec.Prim (runP) +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, protectFieldText') + +-- | @parseFromFile p filePath@ runs a string parser @p@ on the +-- input read from @filePath@ using 'Prelude.readFile'. Returns either a 'ParseError' +-- ('Left') or a value of type @a@ ('Right'). +-- +-- > main = do{ result <- parseFromFile numbers "digits.txt" +-- > ; case result of +-- > Left err -> print err +-- > Right xs -> print (sum xs) +-- > } +{- +parseFromFile :: Parser a -> String -> IO (Either ParseError a) +parseFromFile p fname + = do input <- T.readFile fname `E.catch` (\ (_ :: E.SomeException) -> B.readFile fname >>= return . decode) + return (runP p () fname input) +-} + +type Field = Field' Builder +type Control = Control' Builder +type Paragraph = Paragraph' Builder + +decodeControl :: B.Control -> Control +decodeControl (B.Control paragraphs) = Control (map decodeParagraph paragraphs) + +decodeParagraph :: B.Paragraph -> Paragraph +decodeParagraph (B.Paragraph s) = B.Paragraph (map decodeField s) + +decodeField :: Field' B.ByteString -> Field' Builder +decodeField (B.Field (name, value)) = Field (decode name, decode value) +decodeField (B.Comment s) = Comment (decode s) + +decode :: B.ByteString -> Builder +decode = fromText . decodeUtf8With (\ _ w -> fmap (chr . fromIntegral) w) + +-- * ControlFunctions + +instance ControlFunctions Builder where + parseControlFromFile filepath = + -- The ByteString parser is far more efficient than the Text + -- parser. By calling decodeControl we tell the compiler to + -- use it instead. + parseControlFromFile filepath >>= return . either Left (Right . decodeControl) + parseControlFromHandle sourceName handle = + parseControlFromHandle sourceName handle >>= return . either Left (Right . decodeControl) + parseControl sourceName c = + -- Warning: This is very slow, it does a utf8 round trip + either Left (Right . decodeControl) (parseControl sourceName (encodeUtf8 (toStrict (toLazyText c)))) + lookupP fieldName (Paragraph paragraph) = + find (hasFieldName (map toLower fieldName)) paragraph + where hasFieldName :: String -> Field' Builder -> Bool + hasFieldName name (Field (fieldName',_)) = name == LL.map toLower (LL.toString fieldName') + hasFieldName _ _ = False + stripWS = dropAround (`elem` (" \t" :: String)) + -- T.strip would also strip newlines + protectFieldText = protectFieldText' + asString = LL.toString + +dropAround p = LL.dropWhile p . LL.dropWhileEnd p + +-- * Control File Parser +{- +-- type ControlParser = GenParser T.Text +type ControlParser a = Parsec T.Text () a + +-- |A parser for debian control file. This parser handles control files +-- that end without a newline as well as ones that have several blank +-- lines at the end. It is very liberal and does not attempt validate +-- the fields in any way. All trailing, leading, and folded whitespace +-- is preserved in the field values. See 'stripWS'. +pControl :: ControlParser Control +pControl = + do many $ char '\n' + sepEndBy pParagraph pBlanks >>= return . Control + +pParagraph :: ControlParser Paragraph +pParagraph = many1 (pComment <|> pField) >>= return . Paragraph + +-- |We are liberal in that we allow *any* field to have folded white +-- space, even though the specific restricts that to a few fields. +pField :: ControlParser Field +pField = + do c1 <- noneOf "#\n" + fieldName <- many1 $ noneOf ":\n" + char ':' + fieldValue <- many fcharfws + (char '\n' >> return ()) <|> eof + return $ Field (T.cons c1 (T.pack fieldName), T.pack fieldValue) + +pComment :: ControlParser Field +pComment = + do char '#' + text <- many (satisfy (not . ((==) '\n'))) + char '\n' + return $ Comment (T.pack ("#" <> text <> "\n")) + +fcharfws :: ControlParser Char +fcharfws = fchar <|> (try $ lookAhead (string "\n ") >> char '\n') <|> (try $ lookAhead (string "\n\t") >> char '\n') <|> (try $ lookAhead (string "\n#") >> char '\n') + +fchar :: ControlParser Char +fchar = satisfy (/='\n') + +_fws :: ControlParser T.Text +_fws = + try $ do char '\n' + ws <- many1 (char ' ') + c <- many1 (satisfy (not . ((==) '\n'))) + return $ T.cons '\n' (T.pack ws <> T.pack c) + +-- |We go with the assumption that 'blank lines' mean lines that +-- consist of entirely of zero or more whitespace characters. +pBlanks :: ControlParser T.Text +pBlanks = + do s <- many1 (oneOf " \n") + return . T.pack $ s +-} diff --git a/Debian/Control/TextLazy.hs b/Debian/Control/TextLazy.hs new file mode 100644 --- /dev/null +++ b/Debian/Control/TextLazy.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables, TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing -fno-warn-unused-do-bind #-} +module Debian.Control.TextLazy + ( -- * Types + Control'(..) + , Paragraph'(..) + , Field'(..) + , Control + , Paragraph + , Field + -- , ControlParser + , ControlFunctions(..) + -- * Control File Parser + -- , pControl + -- * Helper Functions + , mergeControls + , fieldValue + , removeField + , prependFields + , appendFields + , renameField + , modifyField + , raiseFields + , decodeControl + , decodeParagraph + , decodeField + ) where + +import qualified Data.ByteString.Char8 as B +import Data.Char (toLower, chr) +import Data.List (find) +import qualified Data.Text.Lazy as T (Text, pack, unpack, map, dropAround, reverse, fromStrict, toStrict) +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) +--import Data.Text.IO as T (readFile) +import qualified Debian.Control.ByteString as B +--import Text.Parsec.Error (ParseError) +--import Text.Parsec.Text (Parser) +--import Text.Parsec.Prim (runP) +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, protectFieldText') + +-- | @parseFromFile p filePath@ runs a string parser @p@ on the +-- input read from @filePath@ using 'Prelude.readFile'. Returns either a 'ParseError' +-- ('Left') or a value of type @a@ ('Right'). +-- +-- > main = do{ result <- parseFromFile numbers "digits.txt" +-- > ; case result of +-- > Left err -> print err +-- > Right xs -> print (sum xs) +-- > } +{- +parseFromFile :: Parser a -> String -> IO (Either ParseError a) +parseFromFile p fname + = do input <- T.readFile fname `E.catch` (\ (_ :: E.SomeException) -> B.readFile fname >>= return . decode) + return (runP p () fname input) +-} + +type Field = Field' T.Text +type Control = Control' T.Text +type Paragraph = Paragraph' T.Text + +decodeControl :: B.Control -> Control +decodeControl (B.Control paragraphs) = Control (map decodeParagraph paragraphs) + +decodeParagraph :: B.Paragraph -> Paragraph +decodeParagraph (B.Paragraph s) = B.Paragraph (map decodeField s) + +decodeField :: Field' B.ByteString -> Field' T.Text +decodeField (B.Field (name, value)) = Field (decode name, decode value) +decodeField (B.Comment s) = Comment (decode s) + +decode :: B.ByteString -> T.Text +decode = T.fromStrict . decodeUtf8With (\ _ w -> fmap (chr . fromIntegral) w) + +-- * ControlFunctions + +instance ControlFunctions T.Text where + parseControlFromFile filepath = + -- The ByteString parser is far more efficient than the Text + -- parser. By calling decodeControl we tell the compiler to + -- use it instead. + parseControlFromFile filepath >>= return . either Left (Right . decodeControl) + parseControlFromHandle sourceName handle = + parseControlFromHandle sourceName handle >>= return . either Left (Right . decodeControl) + parseControl sourceName c = + -- Warning: This is very slow, it does a utf8 round trip + either Left (Right . decodeControl) (parseControl sourceName (encodeUtf8 (T.toStrict c))) + lookupP fieldName (Paragraph paragraph) = + find (hasFieldName (map toLower fieldName)) paragraph + where hasFieldName :: String -> Field' T.Text -> Bool + hasFieldName name (Field (fieldName',_)) = T.pack name == T.map toLower fieldName' + hasFieldName _ _ = False + stripWS = T.dropAround (`elem` (" \t" :: String)) + -- T.strip would also strip newlines + protectFieldText = protectFieldText' + asString = T.unpack + +-- * Control File Parser +{- +-- type ControlParser = GenParser T.Text +type ControlParser a = Parsec T.Text () a + +-- |A parser for debian control file. This parser handles control files +-- that end without a newline as well as ones that have several blank +-- lines at the end. It is very liberal and does not attempt validate +-- the fields in any way. All trailing, leading, and folded whitespace +-- is preserved in the field values. See 'stripWS'. +pControl :: ControlParser Control +pControl = + do many $ char '\n' + sepEndBy pParagraph pBlanks >>= return . Control + +pParagraph :: ControlParser Paragraph +pParagraph = many1 (pComment <|> pField) >>= return . Paragraph + +-- |We are liberal in that we allow *any* field to have folded white +-- space, even though the specific restricts that to a few fields. +pField :: ControlParser Field +pField = + do c1 <- noneOf "#\n" + fieldName <- many1 $ noneOf ":\n" + char ':' + fieldValue <- many fcharfws + (char '\n' >> return ()) <|> eof + return $ Field (T.cons c1 (T.pack fieldName), T.pack fieldValue) + +pComment :: ControlParser Field +pComment = + do char '#' + text <- many (satisfy (not . ((==) '\n'))) + char '\n' + return $ Comment (T.pack ("#" <> text <> "\n")) + +fcharfws :: ControlParser Char +fcharfws = fchar <|> (try $ lookAhead (string "\n ") >> char '\n') <|> (try $ lookAhead (string "\n\t") >> char '\n') <|> (try $ lookAhead (string "\n#") >> char '\n') + +fchar :: ControlParser Char +fchar = satisfy (/='\n') + +_fws :: ControlParser T.Text +_fws = + try $ do char '\n' + ws <- many1 (char ' ') + c <- many1 (satisfy (not . ((==) '\n'))) + return $ T.cons '\n' (T.pack ws <> T.pack c) + +-- |We go with the assumption that 'blank lines' mean lines that +-- consist of entirely of zero or more whitespace characters. +pBlanks :: ControlParser T.Text +pBlanks = + do s <- many1 (oneOf " \n") + return . T.pack $ s +-} diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,11 +1,5 @@ #!/usr/bin/runhaskell import Distribution.Simple -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(buildDir)) -import Distribution.Simple.Program -import System.Directory -import System.Exit -import System.FilePath (()) -import System.Process -main = copyFile "debian/changelog" "changelog" >> defaultMainWithHooks simpleUserHooks +main = defaultMainWithHooks simpleUserHooks diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,9 @@ +haskell-debian (3.91) unstable; urgency=low + + * Eliminate error call in parseChangeLog + + -- David Fox Thu, 06 Oct 2016 09:42:06 -0700 + haskell-debian (3.89) unstable; urgency=low * Change signature of parseDebianVersion to return Either ParseError DebianVerions. diff --git a/debian.cabal b/debian.cabal --- a/debian.cabal +++ b/debian.cabal @@ -1,5 +1,5 @@ Name: debian -Version: 3.89 +Version: 3.91 License: BSD3 License-File: debian/copyright Author: David Fox , Jeremy Shaw , Clifford Beshers @@ -37,7 +37,7 @@ filepath, HaXml >= 1.20, HUnit, - ListLike >= 4.1.1, + ListLike >= 4.3.5, mtl, old-locale, parsec >= 2 && <4, @@ -72,10 +72,12 @@ Debian.Changes, Debian.Control, Debian.Control.Common, + Debian.Control.Builder Debian.Control.ByteString, Debian.Control.Policy, Debian.Control.String, Debian.Control.Text, + Debian.Control.TextLazy, Debian.Deb, Debian.Extra.Files, Debian.GenBuildDeps, diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +haskell-debian (3.91) unstable; urgency=low + + * Eliminate error call in parseChangeLog + + -- David Fox Thu, 06 Oct 2016 09:42:06 -0700 + haskell-debian (3.89) unstable; urgency=low * Change signature of parseDebianVersion to return Either ParseError DebianVerions.