module Debian.Util.FakeChanges (fakeChanges) where
import Control.Exception
import Control.Monad hiding (mapM)
import Data.Foldable
import Data.List hiding (concat, foldr, all)
import Data.Maybe
import Data.Generics
import Data.Traversable
import Debian.Time
import System.Environment
import System.Posix.Files
import Text.Regex.Posix
import Prelude hiding (catch, concat, foldr, all, mapM)
import Network.BSD
import Debian.Control
import qualified Debian.Deb as Deb
import System.Unix.FilePath
import System.Unix.Misc
data Error
= NoDebs
| TooManyDscs [FilePath]
| TooManyTars [FilePath]
| TooManyDiffs [FilePath]
| UnknownFiles [FilePath]
| MalformedDebFilename [FilePath]
| VersionMismatch [Maybe String]
deriving (Read, Show, Eq, Typeable, Data)
data Files
= Files { dsc :: Maybe (FilePath, Paragraph)
, debs :: [(FilePath, Paragraph)]
, tar :: Maybe FilePath
, diff :: Maybe FilePath
}
deriving Show
fakeChanges :: [FilePath] -> IO (FilePath, String)
fakeChanges fps =
do files <- loadFiles fps
let version = getVersion files
source = getSource files
maintainer = getMaintainer files
arches = getArches files
binArch = getBinArch files
dist = "unstable"
urgency = "low"
(invalid, binaries) = unzipEithers $ map (debNameSplit . fst) (debs files)
when (not . null $ invalid) (error $ "Some .deb names are invalid: " ++ show invalid)
uploader <- getUploader
date <- getCurrentLocalRFC822Time
fileLines <- mapM mkFileLine fps
let changes = Control $ return . Paragraph $ map Field
[ ("Format"," 1.7")
, ("Date", ' ' : date)
, ("Source", ' ' : source)
, ("Binary", ' ' : (intercalate " " $ map (\(n,_,_) -> n) binaries))
, ("Architecture", ' ' : intercalate " " arches)
, ("Version", ' ' : version)
, ("Distribution", ' ' : dist)
, ("Urgency", ' ' : urgency)
, ("Maintainer", ' ' : maintainer)
, ("Changed-By", ' ' : uploader)
, ("Description", "\n Simulated description")
, ("Changes", "\n" ++ unlines (map (' ':) [ source ++ " (" ++ version ++") " ++ dist ++ "; urgency=" ++ urgency
, "."
, " * Simulated changes"
]
))
, ("Files", "\n" ++ unlines fileLines)
]
return $ (concat [ source, "_", version, "_", binArch, ".changes"], show changes)
getVersion :: Files -> String
getVersion files
| isNothing (dsc files) =
let versions = map (fieldValue "Version" . snd) (debs files)
in
if (all isJust versions) && (length (nub versions) == 1)
then fromJust (head versions)
else error (show [VersionMismatch (nub versions)])
| otherwise =
case fieldValue "Version" (snd . fromJust $ dsc files) of
(Just v) -> v
Nothing -> error $ show (dsc files) ++ " does not have a Version field :("
getSource :: Files -> String
getSource files =
let dscSource =
case (dsc files) of
Nothing -> []
(Just (fp, p)) ->
case fieldValue "Source" p of
(Just v) -> [v]
Nothing -> error $ fp ++ " does not have a Source field :("
debSources = map debSource (debs files)
srcs = nub (dscSource ++ debSources)
in
if (singleton srcs)
then (head srcs)
else error $ "Could not determine source."
where
debSource (deb,p) =
case (fieldValue "Source" p) of
(Just v) -> v
Nothing ->
case fieldValue "Package" p of
(Just v) -> v
Nothing -> error $ "Could not find Source or Package field in " ++ deb
getMaintainer :: Files -> String
getMaintainer files
| isJust (dsc files) =
let (fp, p) = fromJust (dsc files)
in
case fieldValue "Maintainer" p of
Nothing -> error $ fp ++ " is missing the Maintainer field."
(Just v) -> v
| otherwise =
let maintainers = catMaybes $ map (fieldValue "Maintainer" . snd) (debs files)
maintainer = nub maintainers
in
if singleton maintainer
then head maintainer
else error $ "Could not uniquely determine the maintainer: " ++ show maintainer
getArches :: Files -> [String]
getArches files =
let debArchs = map (fieldValue "Architecture" . snd) (debs files)
tarArch = fmap (const "source") (tar files)
diffArch = fmap (const "source") (diff files)
in
nub $ catMaybes (tarArch : diffArch : debArchs)
getBinArch :: Files -> String
getBinArch files =
let binArch = nub $ mapMaybe (fieldValue "Architecture" . snd) (debs files)
in
if singleton binArch
then head binArch
else case (filter (/= "all") binArch) of
[binArch] -> binArch
_ -> error $ "Could not uniquely determine binary architecture: " ++ show binArch
mkFileLine :: FilePath -> IO String
mkFileLine fp
| ".deb" `isSuffixOf` fp =
do sum <- md5sum fp
size <- liftM fileSize $ getFileStatus fp
(Control (p:_)) <- Deb.fields fp
return $ concat [ " ", sum, " ", show size, " ", fromMaybe "unknown" (fieldValue "Section" p), " "
, fromMaybe "optional" (fieldValue "Priority" p), " ", (baseName fp)
]
| otherwise =
do sum <- md5sum fp
size <- liftM fileSize $ getFileStatus fp
return $ concat [ " ", sum, " ", show size, " ", "unknown", " "
, "optional"," ", (baseName fp)
]
unzipEithers :: [Either a b] -> ([a],[b])
unzipEithers = foldr unzipEither ([],[])
where
unzipEither (Left l) ~(ls, rs) = (l:ls, rs)
unzipEither (Right r) ~(ls, rs) = (ls, r:rs)
debNameSplit :: String -> Either FilePath (String, String, String)
debNameSplit fp =
case (baseName fp) =~ "^(.*)_(.*)_(.*).deb$" of
[[_, name, version, arch]] -> Right (name, version, arch)
_ -> Left fp
loadFiles :: [FilePath] -> IO Files
loadFiles files =
let (dscs, files'') = partition (isSuffixOf ".dsc") files'
(debs, files') = partition (isSuffixOf ".deb") files
(tars, files''') = partition (isSuffixOf ".tar.gz") files''
(diffs, rest) = partition (isSuffixOf ".diff.gz") files'''
errors = concat [ if (length debs < 1) then [NoDebs] else []
, if (length dscs > 1) then [TooManyDscs dscs] else []
, if (length tars > 1) then [TooManyTars tars] else []
, if (length diffs > 1) then [TooManyDiffs diffs] else []
, if (length rest > 0) then [UnknownFiles rest] else []
]
in
do when (not . null $ errors) (error $ show errors)
dsc <- mapM loadDsc (listToMaybe dscs)
debs <- mapM loadDeb debs
return $ Files { dsc = dsc, debs = debs, tar = listToMaybe tars, diff = listToMaybe diffs }
where
loadDsc :: FilePath -> IO (FilePath, Paragraph)
loadDsc dsc =
do res <- parseControlFromFile dsc
case res of
(Left e) -> error $ "Error parsing " ++ dsc ++ "\n" ++ show e
(Right (Control [p])) -> return (dsc, p)
(Right c) -> error $ dsc ++ " did not have exactly one paragraph: " ++ show c
loadDeb :: FilePath -> IO (FilePath, Paragraph)
loadDeb deb =
do res <- Deb.fields deb
case res of
(Control [p]) -> return (deb, p)
_ -> error $ deb ++ " did not have exactly one paragraph: " ++ show res
getUploader :: IO String
getUploader =
do debFullName <-
do dfn <- try (getEnv "DEBFULLNAME")
case dfn of
(Right n) -> return n
(Left _) ->
do dfn <-try (getEnv "USER")
case dfn of
(Right n) -> return n
(Left _) -> error $ "Could not determine user name, neither DEBFULLNAME nor USER enviroment variables were set."
emailAddr <-
do eml <- try (getEnv "DEBEMAIL")
case eml of
(Right e) -> return e
(Left _) ->
do eml <- try (getEnv "EMAIL")
case eml of
(Right e) -> return e
(Left _) -> getHostName
return $ debFullName ++ " <" ++ emailAddr ++ ">"
singleton :: [a] -> Bool
singleton [_] = True
singleton _ = False