debian-3.31: Debian/Changes.hs
-- |Changelog and changes file support.
module Debian.Changes
{-
(-- * read, show
parseLog -- String -> [ChangeLogEntry]
, parseEntry -- String -> Maybe (ChangeLogEntry, String)
, parseChanges -- String -> Maybe ChangeLogEntry
, showHeader -- ChangeLogEntry -> String
-- * Changes File
, findChangesFiles
--, Section
--, sectionName
--, subSectionName
--, load
, parseChangesFilename
, parseChangesFile
, save
, key
, matchKey
, base
, Debian.Repo.Changes.path
, name
--, poolDir -- PackageIndex -> ChangesFile -> FilePath
, poolDir' -- Release -> ChangesFile -> ChangedFileSpec -> FilePath
, uploadLocal
, ChangesFile(..)
, changesFileName
, ChangedFileSpec(..)
, ChangeLogEntry(..)
) -} where
--import Control.Monad.Trans
import Data.List (intercalate)
import Data.Maybe
import qualified Debian.Control.String as S
--import Debian.Repo.LocalRepository
--import Debian.Repo.Types
import Debian.Release
import Debian.Version
--import Extra.Files (replaceFile)
--import Extra.CIO (CIO)
--import System.FilePath(splitFileName, (</>))
--import System.Directory
--import qualified System.Posix.Files as F
--import Text.ParserCombinators.Parsec
import Text.Regex
--import qualified Debian.Control.ByteString as B
import Debian.URI()
import System.Posix.Types
-- |A file generated by dpkg-buildpackage describing the result of a
-- package build
data ChangesFile =
Changes { changeDir :: FilePath -- ^ The full pathname of the directory holding the .changes file.
, changePackage :: String -- ^ The package name parsed from the .changes file name
, changeVersion :: DebianVersion -- ^ The version number parsed from the .changes file name
, changeRelease :: ReleaseName -- ^ The Distribution field of the .changes file
, changeArch :: Arch -- ^ The architecture parsed from the .changes file name
, 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
}
-- |An entry in the list of files generated by the build.
data ChangedFileSpec =
ChangedFileSpec { changedFileMD5sum :: String
, changedFileSize :: FileOffset
, changedFileSection :: SubSection
, changedFilePriority :: String
, changedFileName :: FilePath
}
-- |A changelog is a series of ChangeLogEntries
data ChangeLogEntry = Entry { logPackage :: String
, logVersion :: DebianVersion
, logDists :: [ReleaseName]
, logUrgency :: String
, logComments :: String
, logWho :: String
, logDate :: String
}
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
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"
-- |Show just the top line of a changelog entry (for debugging output.)
showHeader :: ChangeLogEntry -> String
showHeader (Entry package version dists urgency _ _ _) =
package ++ " (" ++ show version ++ ") " ++ intercalate " " (map releaseName' dists) ++ "; urgency=" ++ urgency ++ "..."
-- |Parse a Debian Changelog and return a lazy list of entries
parseLog :: String -> [Either String ChangeLogEntry]
parseLog text =
case parseEntry text of
Nothing -> []
Just (Left message) -> [Left message]
Just (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 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))
where
entryRE = mkRegex $ bol ++ blankLines ++ headerRE ++ nonSigLines ++ blankLines ++ signature ++ blankLines
nonSigLines = "((( .*)|([ \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] ->
Just $ Entry name
(parseDebianVersion version)
(map parseReleaseName . words $ dists)
urgency
details
"" ""
Just x -> error $ "Unexpected match: " ++ show x
where
changesRE = mkRegexWithOpts (bol ++ blankLines ++ optWhite ++ headerRE ++ "(.*)$") False False
headerRE =
package ++ version ++ dists ++ urgency
where
package = "([^ \t(]*)" ++ optWhite
version = "\\(([^)]*)\\)" ++ optWhite
dists = "([^;]*);" ++ optWhite
urgency = "urgency=([^\n]*)\n" ++ blankLines
blankLines = blankLine ++ "*"
blankLine = "(" ++ optWhite ++ "\n)"
optWhite = "[ \t]*"
bol = "^"
{-
findChangesFiles :: FilePath -> IO [ChangesFile]
findChangesFiles dir =
getDirectoryContents dir >>=
return . filter (isSuffixOf ".changes") >>=
mapM (load dir) >>= return . catMaybes
load :: FilePath -> String -> IO (Maybe ChangesFile)
load dir file =
do
case parseChangesFilename file of
Just (name, ver, arch) ->
do
result <- parseChangesFile dir file
case result of
Right (S.Control changes) ->
-- The .changes file should be a single paragraph,
-- but there have been instances where extra newlines
-- are inserted. To be forgiving we will concat all
-- the paragraphs into one (rather than erroring out
-- or discarding all but the first paragraph.)
let changes' = mergeParagraphs changes in
case (S.fieldValue "Files" changes',
maybe Nothing parseChanges (S.fieldValue "Changes" changes'),
S.fieldValue "Distribution" changes') of
(Just text, Just entry, Just release) ->
do return . Just $ Changes { changeDir = dir
, changePackage = name
, changeVersion = ver
, changeRelease = parseReleaseName release
, changeArch = arch
, changeInfo = changes'
, changeEntry = entry
, changeFiles = parseFileList text }
_ -> return Nothing -- Missing 'Files', 'Changes', or 'Distribution' field in .changes
Left _error -> return Nothing
Nothing -> return Nothing -- Couldn't parse changes filename
mergeParagraphs :: [S.Paragraph] -> S.Paragraph
mergeParagraphs paragraphs =
S.Paragraph . concat . map fieldsOf $ paragraphs
where fieldsOf (S.Paragraph fields) = fields
save :: ChangesFile -> IO ()
save changes =
replaceFile path (show (updateFiles (changeFiles changes) (changeInfo changes)))
where
path = changeDir changes ++ "/" ++ changesFileName changes
updateFiles files info = S.modifyField "Files" (const (showFileList files)) info
key :: ChangesFile -> (String, DebianVersion, Arch)
key changes = (changePackage changes, changeVersion changes, changeArch changes)
matchKey :: ChangesFile -> (String, DebianVersion, Arch) -> Bool
matchKey changes key = key == (changePackage changes, changeVersion changes, changeArch changes)
base :: ChangesFile -> String
base changes =
changePackage changes ++ "_" ++ show (changeVersion changes) ++ "_" ++ archName (changeArch changes)
name :: ChangesFile -> FilePath
name changes = base changes ++ ".changes"
path :: ChangesFile -> FilePath
path changes = changeDir changes ++ "/" ++ name changes
-- filename name version arch ext
parseChangesFilename :: String -> Maybe (String, DebianVersion, Arch)
parseChangesFilename name =
case matchRegex (mkRegex "^(.*/)?([^_]*)_(.*)_([^.]*)\\.changes$") name of
Just [_, name, version, arch] -> Just (name, parseDebianVersion version, Binary arch)
_ -> error ("Invalid .changes file name: " ++ name)
parseChangesFile :: FilePath -> String -> IO (Either ParseError S.Control)
parseChangesFile dir file = S.parseControlFromFile (dir ++ "/" ++ file)
parseFileList :: String -> [ChangedFileSpec]
parseFileList text =
-- md5sum size section priority name
case (text, matchRegexAll re text) of
("", _) -> []
(_, Just (_, _, remaining, [md5sum, size, section, priority, filename])) ->
ChangedFileSpec { changedFileMD5sum = md5sum
, changedFileSize = read size
, changedFileSection = parseSection section
, changedFilePriority = priority
, changedFileName = filename } : parseFileList remaining
_ -> error ("Parse error in Files section of changes file: '" ++ text)
where
re = mkRegex ("^[ \t\n]*" ++ g ++w++ g ++w++ g ++w++ g ++w++ g ++ "[ \t\n]*")
g = "(" ++ t ++ ")"
t = "[^ \t\n]+"
w = "[ \t]+"
showFileList :: [ChangedFileSpec] -> String
showFileList files = concat (map (("\n " ++) . show) files)
-- | Return the subdirectory in the pool where a source package would be
-- installed.
poolDir' :: Release -> ChangesFile -> ChangedFileSpec -> FilePath
poolDir' release changes file =
case S.fieldValue "Source" (changeInfo changes) of
Nothing -> error "No 'Source' field in .changes file"
Just source ->
case releaseRepo release of
LocalRepo repo -> poolDir repo (section . changedFileSection $ file) source
x -> error $ "Unexpected repository passed to poolDir': " ++ show x
-- | Move a build result into a local repository's 'incoming' directory.
uploadLocal :: CIO m => LocalRepository -> ChangesFile -> m ()
uploadLocal repo changesFile =
do let paths = map (\ file -> changeDir changesFile </> changedFileName file) (changeFiles changesFile)
mapM_ (liftIO . install (outsidePath root)) (Debian.Repo.Changes.path changesFile : paths)
where
root = repoRoot repo
-- Hard link a file into the incoming directory
install root path =
do removeIfExists (dest root path)
F.createLink path (dest root path)
-- F.removeLink path
dest root path = root ++ "/incoming/" ++ snd (splitFileName path)
removeIfExists path =
do exists <- doesFileExist path
if exists then F.removeLink path else return ()
-}