module Debian.Repo.Changes
(
parseLog
, parseEntry
, parseChanges
, showHeader
, findChangesFiles
, parseChangesFilename
, parseChangesFile
, save
, key
, matchKey
, base
, Debian.Repo.Changes.path
, name
, poolDir'
, uploadLocal
, ChangesFile(..)
, changesFileName
, ChangedFileSpec(..)
, ChangeLogEntry(..)
) where
import Control.Monad.Trans
import Data.List (isSuffixOf, intercalate)
import Data.Maybe
import qualified Debian.Control.String as S
import Debian.Repo.LocalRepository
import Debian.Repo.Types
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
data ChangesFile =
Changes { changeDir :: FilePath
, changePackage :: String
, changeVersion :: DebianVersion
, changeRelease :: ReleaseName
, changeArch :: Arch
, changeInfo :: S.Paragraph
, changeEntry :: ChangeLogEntry
, changeFiles :: [ChangedFileSpec]
}
data ChangedFileSpec =
ChangedFileSpec { changedFileMD5sum :: String
, changedFileSize :: FileOffset
, changedFileSection :: SubSection
, changedFilePriority :: String
, changedFileName :: FilePath
}
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"
showHeader :: ChangeLogEntry -> String
showHeader (Entry package version dists urgency _ _ _) =
package ++ " (" ++ show version ++ ") " ++ intercalate " " (map releaseName' dists) ++ "; urgency=" ++ urgency ++ "..."
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'
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)+)"
signature = "( -- ([^\n]*) (..., ? ?.. ... .... ........ .....))[ \t]*\n"
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) ->
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
Left _error -> return Nothing
Nothing -> return Nothing
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
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 =
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)
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
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
install root path =
do removeIfExists (dest root path)
F.createLink path (dest root path)
dest root path = root ++ "/incoming/" ++ snd (splitFileName path)
removeIfExists path =
do exists <- doesFileExist path
if exists then F.removeLink path else return ()