{-# LANGUAGE DeriveDataTypeable #-} module Debian.Util.FakeChanges (fakeChanges) where --import Control.Arrow import Control.OldException import Control.Monad hiding (mapM) import Data.Foldable import Data.List hiding (concat, foldr, all) import Data.Maybe --import Data.Typeable 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) -- let (invalid, binaries) = unzipEithers $ map debNameSplit debs {- when (not . null $ invalid) (throwDyn [MalformedDebFilename invalid]) version <- getVersion dsc debs putStrLn version source <- getSource dsc debs putStrLn source -} -- TODO: seems like this could be more aggressive about ensure the -- versions make sense. Except with packages like libc, the versions -- don't make sense. Maybe we want a flag that disables version check -- ? 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) ] -- more implementations can be found at: -- http://www.google.com/codesearch?hl=en&lr=&q=%22%5BEither+a+b%5D+-%3E+%28%5Ba%5D%2C%5Bb%5D%29%22&btnG=Search 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) -- move to different library 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 } -- if (not . null $ errors) then throwDyn errors else return (debs, listToMaybe dscs, listToMaybe tars, 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 -- FIXME: this is not a FQDN return $ debFullName ++ " <" ++ emailAddr ++ ">" -- * Utils singleton :: [a] -> Bool singleton [_] = True singleton _ = False