{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} module Debian.Util.FakeChanges (fakeChanges) where --import Control.Arrow import Control.Exception import Control.Monad hiding (mapM) import qualified Data.ByteString.Lazy.Char8 as L import Data.Data (Data, Typeable) import Data.Digest.Pure.SHA as SHA import Data.Foldable (concat, all, foldr) import Data.List as List (intercalate, nub, partition, isSuffixOf) import Data.Maybe import Debian.Pretty (prettyShow) import Data.Traversable import Debian.Control import qualified Debian.Deb as Deb import Debian.Time import Network.BSD (getHostName) import Prelude hiding (concat, foldr, all, mapM, sum) import System.Environment import System.FilePath import System.Posix.Files import Text.Regex.TDFA 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 } 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"], prettyShow 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 [b] -> b _ -> error $ "Could not uniquely determine binary architecture: " ++ show binArch mkFileLine :: FilePath -> IO String mkFileLine fp | ".deb" `isSuffixOf` fp = do sum <- L.readFile fp >>= return . show . sha256 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), " ", (takeBaseName fp) ] | otherwise = do sum <- L.readFile fp >>= return . show . sha256 size <- liftM fileSize $ getFileStatus fp return $ concat [ " ", sum, " ", show size, " ", "unknown", " " , "optional"," ", (takeBaseName 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 (takeFileName 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: " ++ prettyShow 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: " ++ prettyShow res getUploader :: IO String getUploader = do debFullName <- do dfn <- try (getEnv "DEBFULLNAME") case dfn of (Right n) -> return n (Left (_ :: SomeException)) -> do dfn' <-try (getEnv "USER") case dfn' of (Right n) -> return n (Left (_ :: SomeException)) -> 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 (_ :: SomeException)) -> do eml' <- try (getEnv "EMAIL") case eml' of (Right e) -> return e (Left (_ :: SomeException)) -> getHostName -- FIXME: this is not a FQDN return $ debFullName ++ " <" ++ emailAddr ++ ">" -- * Utils singleton :: [a] -> Bool singleton [_] = True singleton _ = False