diff --git a/cblrepo.cabal b/cblrepo.cabal --- a/cblrepo.cabal +++ b/cblrepo.cabal @@ -1,5 +1,5 @@ name: cblrepo -version: 0.15.1 +version: 0.16.0 cabal-version: >= 1.6 license: OtherLicense license-file: LICENSE-2.0 @@ -26,10 +26,10 @@ other-modules: PkgDB Add BumpPkgs BuildPkgs Sync Versions Updates ListPkgs PkgBuild OldPkgDB ConvertDB Remove Extract Util.Translation Util.Cabal Util.HackageIndex Util.Misc Util.Dist build-depends: base ==4.8.*, filepath ==1.4.*, - directory ==1.2.*, Cabal ==1.22.*, + directory ==1.2.*, Cabal ==1.22.*, transformers ==0.4.*, bytestring ==0.10.*, tar ==0.4.*, zlib ==0.5.*, mtl ==2.2.*, - process ==1.2.*, Unixutils ==1.52.*, unix ==2.7.*, - ansi-wl-pprint ==0.6.*, aeson ==0.8.*, + process ==1.2.*, Unixutils ==1.53.*, unix ==2.7.*, + ansi-wl-pprint ==0.6.*, aeson ==0.8.*, stringsearch ==0.3.*, optparse-applicative ==0.11.*, safe ==0.3.*, containers ==0.5.*, utf8-string ==1 diff --git a/src/Add.hs b/src/Add.hs --- a/src/Add.hs +++ b/src/Add.hs @@ -25,7 +25,6 @@ -- {{{2 system import Control.Monad.Reader --- import Control.Monad.Error import Data.List import Data.Maybe import Distribution.PackageDescription @@ -39,7 +38,7 @@ -- {{{1 types data PkgType = GhcType String Version - | DistroType String Version String + | DistroType String Version Int | RepoType GenericPackageDescription deriving (Eq, Show) @@ -55,9 +54,9 @@ -- ghcPkgs <- asks $ map (uncurry GhcType) . cmdAddGhcPkgs . optsCmd distroPkgs <- asks $ map (\ (n, v, r) -> DistroType n v r) . cmdAddDistroPkgs . optsCmd - genFilePkgs <- mapM (runCabalParseWithTempDir . Cbl.readFromFile . fst) filePkgs - genIdxPkgs <- mapM ((runCabalParseWithTempDir . Cbl.readFromIdx) . (\ (a, b, _) -> (a, b))) idxPkgs - genPkgs <- liftM (map RepoType) $ exitOnErrors (genFilePkgs ++ genIdxPkgs) + genFilePkgs <- mapM (runCabalParseWithTempDir . fmap snd . Cbl.readFromFile . fst) filePkgs + genIdxPkgs <- mapM ((runCabalParseWithTempDir . fmap snd . Cbl.readFromIdx) . (\ (a, b, _) -> (a, b))) idxPkgs + genPkgs <- liftM (map RepoType) $ exitOnAnyLefts (genFilePkgs ++ genIdxPkgs) -- let pkgs = ghcPkgs ++ distroPkgs ++ genPkgs pkgNames = map getName pkgs diff --git a/src/ConvertDB.hs b/src/ConvertDB.hs --- a/src/ConvertDB.hs +++ b/src/ConvertDB.hs @@ -46,4 +46,4 @@ x = 0 d = ODB.pkgDeps o f = ODB.pkgFlags o - r = ODB.pkgRelease o + r = read $ ODB.pkgRelease o diff --git a/src/Extract.hs b/src/Extract.hs --- a/src/Extract.hs +++ b/src/Extract.hs @@ -5,7 +5,7 @@ import Util.HackageIndex import Util.Misc -import Control.Monad.Error +import Control.Monad.Trans.Except import Control.Monad.Reader import qualified Data.ByteString.Lazy as BSL import Data.Version @@ -18,11 +18,11 @@ pkgsNVersions <- asks $ cmdExtractPkgs . optsCmd -- idx <- liftIO $ readIndexFile aD - _ <- mapM (runErrorT . extractAndSave idx) pkgsNVersions >>= exitOnErrors + _ <- mapM (runExceptT . extractAndSave idx) pkgsNVersions >>= exitOnAnyLefts return () -extractAndSave :: (MonadError String m, MonadIO m) => BSL.ByteString -> (String, Version) -> m () -extractAndSave idx (pkg, ver) = maybe (throwError errorMsg) (liftIO . BSL.writeFile destFn) (extractCabal idx pkg ver) +extractAndSave :: MonadIO m => BSL.ByteString -> (String, Version) -> ExceptT String m () +extractAndSave idx (pkg, ver) = maybe (throwE errorMsg) (liftIO . BSL.writeFile destFn) (extractCabal idx pkg ver) where destFn = pkg <.> "cabal" errorMsg = "Failed to extract Cabal for " ++ pkg ++ " " ++ display ver diff --git a/src/ListPkgs.hs b/src/ListPkgs.hs --- a/src/ListPkgs.hs +++ b/src/ListPkgs.hs @@ -46,8 +46,10 @@ printCblPkgShort :: CblPkg -> IO () printCblPkgShort p = - putStrLn $ pkgName p ++ " " ++ display (pkgVersion p) ++ "-" ++ pkgRelease p ++ showFlagsIfPresent p + putStrLn $ pkgName p ++ " " ++ v ++ "-" ++ r ++ showFlagsIfPresent p where + v = display (pkgVersion p) ++ if isRepoPkg p then ("_" ++ show (pkgXRev p)) else "" + r = if isGhcPkg p then "xx" else show (pkgRelease p) showFlagsIfPresent _p | [] <- pkgFlags _p = "" | fa <- pkgFlags _p = " (" ++ unwords (map showSingleFlag fa) ++ ")" diff --git a/src/OldPkgDB.hs b/src/OldPkgDB.hs --- a/src/OldPkgDB.hs +++ b/src/OldPkgDB.hs @@ -1,5 +1,5 @@ {- - - Copyright 2011-2013 Per Magnus Therning + - Copyright 2011-2014 Per Magnus Therning - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. @@ -16,7 +16,38 @@ {-# LANGUAGE TemplateHaskell #-} -module OldPkgDB where +module OldPkgDB + ( CblPkg + , pkgName + , pkgPkg + , pkgVersion + , pkgXRev + , pkgDeps + , pkgFlags + , pkgRelease + -- + , isGhcPkg + , isDistroPkg + , isRepoPkg + , isBasePkg + -- + , createGhcPkg + , createDistroPkg + , createRepoPkg + , createCblPkg + -- + , CblDB + , addPkg + , addPkg2 + , delPkg + , bumpRelease + , lookupPkg + , transitiveDependants + , checkDependants + , checkAgainstDb + , saveDb + , readDb + ) where -- {{{1 imports import Control.Arrow @@ -33,15 +64,13 @@ import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..)) import qualified Data.ByteString.Lazy.Char8 as C --- {{{ temporary -_depName (P.Dependency (P.PackageName n) _) = n -_depVersionRange (P.Dependency _ vr) = vr +import qualified Util.Dist -- {{{1 types data Pkg = GhcPkg { version :: V.Version } | DistroPkg { version :: V.Version, release :: String } - | RepoPkg { version :: V.Version, deps :: [P.Dependency], flags :: FlagAssignment, release :: String } + | RepoPkg { version :: V.Version, xrev :: Int, deps :: [P.Dependency], flags :: FlagAssignment, release :: String } deriving (Eq, Show) data CblPkg = CP String Pkg @@ -79,6 +108,10 @@ pkgVersion :: CblPkg -> V.Version pkgVersion (CP _ p) = version p +pkgXRev :: CblPkg -> Int +pkgXRev (CP _ RepoPkg { xrev = x }) = x +pkgXRev _ = 0 + pkgDeps :: CblPkg -> [P.Dependency] pkgDeps (CP _ RepoPkg { deps = d}) = d pkgDeps _ = [] @@ -92,26 +125,35 @@ pkgRelease (CP _ DistroPkg { release = r }) = r pkgRelease (CP _ RepoPkg { release = r }) = r +createGhcPkg :: String -> V.Version -> CblPkg createGhcPkg n v = CP n (GhcPkg v) + +createDistroPkg :: String -> V.Version -> String -> CblPkg createDistroPkg n v r = CP n (DistroPkg v r) -createRepoPkg n v d fa r = CP n (RepoPkg v d fa r) +createRepoPkg :: String -> V.Version -> Int -> [P.Dependency] -> FlagAssignment -> String -> CblPkg +createRepoPkg n v x d fa r = CP n (RepoPkg v x d fa r) + createCblPkg :: PackageDescription -> FlagAssignment -> CblPkg -createCblPkg pd fa = createRepoPkg name version deps fa "1" +createCblPkg pd fa = createRepoPkg name version xrev deps fa "1" where - name = (\ (P.PackageName n) -> n) (P.pkgName $ package pd) + name = Util.Dist.pkgNameStr pd version = P.pkgVersion $ package pd + xrev = Util.Dist.pkgXRev pd deps = buildDepends pd getDependencyOn :: String -> CblPkg -> Maybe P.Dependency -getDependencyOn n p = find (\ d -> _depName d == n) (pkgDeps p) +getDependencyOn n p = find (\ d -> Util.Dist.depName d == n) (pkgDeps p) +isGhcPkg :: CblPkg -> Bool isGhcPkg (CP _ GhcPkg {}) = True isGhcPkg _ = False +isDistroPkg :: CblPkg -> Bool isDistroPkg (CP _ DistroPkg {}) = True isDistroPkg _ = False +isRepoPkg :: CblPkg -> Bool isRepoPkg (CP _ RepoPkg {}) = True isRepoPkg _ = False @@ -141,12 +183,12 @@ delPkg db n = filter (\ p -> n /= pkgName p) db bumpRelease :: CblDB -> String -> CblDB -bumpRelease db n = let +bumpRelease db n = maybe db (addPkg2 db . doBump) (lookupPkg db n) + where doBump (CP n' p@RepoPkg { release = r }) = CP n' (p { release = nr }) where nr = show $ read r + (1 :: Int) doBump p = p - in maybe db (addPkg2 db . doBump) (lookupPkg db n) lookupPkg :: CblDB -> String -> Maybe CblPkg lookupPkg [] _ = Nothing @@ -154,9 +196,10 @@ | n == pkgName p = Just p | otherwise = lookupPkg db n +lookupDependants :: [CblPkg] -> String -> [String] lookupDependants db n = filter (/= n) $ map pkgName $ filter (`doesDependOn` n) db where - doesDependOn p n = n `elem` map _depName (pkgDeps p) + doesDependOn p n = n `elem` map Util.Dist.depName (pkgDeps p) transitiveDependants :: CblDB -> [String] -> [String] transitiveDependants db names = keepLast $ concatMap transUsersOfOne names @@ -164,14 +207,22 @@ transUsersOfOne n = n : transitiveDependants db (lookupDependants db n) keepLast = reverse . nub . reverse --- Todo: test checkDependants :: CblDB -> String -> V.Version -> [(String, Maybe P.Dependency)] checkDependants db n v = let d1 = mapMaybe (lookupPkg db) (lookupDependants db n) -- d2 = map (\ p -> (pkgName p, getDependencyOn n p)) d1 d2 = map (pkgName &&& getDependencyOn n ) d1 - fails = filter (not . V.withinRange v . _depVersionRange . fromJust . snd) d2 + fails = filter (not . V.withinRange v . Util.Dist.depVersionRange . fromJust . snd) d2 in fails + +checkAgainstDb :: CblDB -> String -> P.Dependency -> Bool +checkAgainstDb db name dep = let + dN = Util.Dist.depName dep + dVR = Util.Dist.depVersionRange dep + in (dN == name) || + (case lookupPkg db dN of + Nothing -> False + Just (CP _ p) -> V.withinRange (version p) dVR) readDb :: FilePath -> IO CblDB readDb fp = handle diff --git a/src/PkgBuild.hs b/src/PkgBuild.hs --- a/src/PkgBuild.hs +++ b/src/PkgBuild.hs @@ -23,7 +23,8 @@ import Control.Arrow import Control.Monad.Reader -import Control.Monad.Error +import Control.Monad.Trans.Except +import qualified Data.ByteString.Lazy as BSL (writeFile) import System.Directory import System.FilePath import System.IO @@ -33,43 +34,44 @@ pkgBuild :: Command () pkgBuild = do pkgs <- asks $ pkgs . optsCmd - void $ mapM (runErrorT . generatePkgBuild) pkgs >>= exitOnErrors + void $ mapM (runExceptT . generatePkgBuild) pkgs >>= exitOnAnyLefts -generatePkgBuild :: String -> ErrorT String Command () +generatePkgBuild :: String -> ExceptT String Command () generatePkgBuild pkg = do db <- asks dbFile >>= liftIO . readDb patchDir <- asks $ patchDir . optsCmd ghcVer <- asks $ ghcVer . optsCmd ghcRel <- asks $ ghcRel . optsCmd - (ver, fa) <- maybe (throwError $ "Unknown package: " ++ pkg) (return . (pkgVersion &&& pkgFlags)) $ lookupPkg db pkg - -- - genericPkgDesc <- runCabalParseWithTempDir $ Cbl.readFromIdx (pkg, ver) - pkgDescAndFlags <- either (const $ throwError ("Failed to finalize package: " ++ pkg)) return + (ver, fa) <- maybe (throwE $ "Unknown package: " ++ pkg) (return . (pkgVersion &&& pkgFlags)) $ lookupPkg db pkg + --- + (cblFile, genericPkgDesc) <- runCabalParseWithTempDir $ Cbl.readFromIdx (pkg, ver) + pkgDescAndFlags <- either (const $ throwE ("Failed to finalize package: " ++ pkg)) return (finalizePkg ghcVer db fa genericPkgDesc) let archPkg = translate ghcVer ghcRel db (snd pkgDescAndFlags) (fst pkgDescAndFlags) archPkgWPatches <- liftIO $ addPatches patchDir archPkg - archPkgWHash <- withTempDirErrT "/tmp/cblrepo." (addHashes archPkgWPatches) + archPkgWHash <- withTempDirExceptT "/tmp/cblrepo." (addHashes archPkgWPatches cblFile) liftIO $ createDirectoryIfMissing False (apPkgName archPkgWHash) liftIO $ withWorkingDirectory (apPkgName archPkgWHash) $ do copyPatches "." archPkgWHash hPKGBUILD <- openFile "PKGBUILD" WriteMode hPutDoc hPKGBUILD $ pretty archPkgWHash hClose hPKGBUILD - maybe (return ()) (void . runErrorT . applyPatch "PKGBUILD") + maybe (return ()) (void . runExceptT . applyPatch "PKGBUILD") (apPkgbuildPatch archPkgWHash) when (apHasLibrary archPkgWHash) $ do hInstall <- openFile (apPkgName archPkgWHash <.> "install") WriteMode let archInstall = aiFromAP archPkgWHash hPutDoc hInstall $ pretty archInstall hClose hInstall - maybe (return ()) (void . runErrorT . applyPatch (apPkgName archPkgWHash <.> "install")) + maybe (return ()) (void . runExceptT . applyPatch (apPkgName archPkgWHash <.> "install")) (apInstallPatch archPkgWHash) + BSL.writeFile ("original.cabal") cblFile -runCabalParseWithTempDir :: Cbl.CabalParse a -> ErrorT String Command a +runCabalParseWithTempDir :: Cbl.CabalParse a -> ExceptT String Command a runCabalParseWithTempDir f = do aD <- asks appDir pD <- asks $ patchDir . optsCmd r <- liftIO $ withTemporaryDirectory "/tmp/cblrepo." $ \ destDir -> do let cpe = Cbl.CabalParseEnv aD pD destDir Cbl.runCabalParse cpe f - reThrowError r + reThrowE r diff --git a/src/PkgDB.hs b/src/PkgDB.hs --- a/src/PkgDB.hs +++ b/src/PkgDB.hs @@ -55,6 +55,7 @@ import Control.Monad import Data.List import Data.Maybe +import Data.Monoid import Distribution.PackageDescription import System.IO.Error import qualified Distribution.Package as P @@ -68,35 +69,42 @@ -- {{{1 types data Pkg - = GhcPkg { version :: V.Version } - | DistroPkg { version :: V.Version, release :: String } - | RepoPkg { version :: V.Version, xrev :: Int, deps :: [P.Dependency], flags :: FlagAssignment, release :: String } + = GhcPkg GhcPkgD + | DistroPkg DistroPkgD + | RepoPkg RepoPkgD deriving (Eq, Show) +data GhcPkgD = GhcPkgD { gpVersion :: V.Version } + deriving (Eq, Show) + +data DistroPkgD = DistroPkgD { dpVersion :: V.Version , dpRelease :: Int } + deriving (Eq, Show) + +data RepoPkgD = RepoPkgD + { rpVersion :: V.Version + , rpXrev :: Int + , rpDeps :: [P.Dependency] + , rpFlags :: FlagAssignment, rpRelease :: Int + } deriving (Eq, Show) + data CblPkg = CP String Pkg deriving (Eq, Show) type CblDB = [CblPkg] instance Ord CblPkg where - compare - (CP n1 GhcPkg { version = v1 }) - (CP n2 GhcPkg { version = v2 }) = - compare (n1, v1) (n2, v2) + compare (CP n1 (GhcPkg d1)) (CP n2 (GhcPkg d2)) = + compare (n1, gpVersion d1) (n2, gpVersion d2) compare (CP _ GhcPkg {}) _ = LT compare _ (CP _ GhcPkg {}) = GT - compare - (CP n1 DistroPkg { version = v1, release = r1 }) - (CP n2 DistroPkg { version = v2, release = r2 }) = - compare (n1, v1, r1) (n2, v2, r2) + compare (CP n1 (DistroPkg d1)) (CP n2 (DistroPkg d2)) = + compare (n1, dpVersion d1, dpRelease d1) (n2, dpVersion d2, dpRelease d2) compare (CP _ DistroPkg {}) _ = LT compare _ (CP _ DistroPkg {}) = GT - compare - (CP n1 RepoPkg { version = v1, release = r1 }) - (CP n2 RepoPkg { version = v2, release = r2 }) = - compare (n1, v1, r1) (n2, v2, r2) + compare (CP n1 (RepoPkg d1)) (CP n2 (RepoPkg d2)) = + compare (n1, rpVersion d1, rpRelease d1) (n2, rpVersion d2, rpRelease d2) -- {{{1 packages pkgName :: CblPkg -> String @@ -106,36 +114,38 @@ pkgPkg (CP _ p) = p pkgVersion :: CblPkg -> V.Version -pkgVersion (CP _ p) = version p +pkgVersion (CP _ (GhcPkg d)) = gpVersion d +pkgVersion (CP _ (DistroPkg d)) = dpVersion d +pkgVersion (CP _ (RepoPkg d)) = rpVersion d pkgXRev :: CblPkg -> Int -pkgXRev (CP _ RepoPkg { xrev = x }) = x +pkgXRev (CP _ (RepoPkg d)) = rpXrev d pkgXRev _ = 0 pkgDeps :: CblPkg -> [P.Dependency] -pkgDeps (CP _ RepoPkg { deps = d}) = d +pkgDeps (CP _ (RepoPkg d)) = rpDeps d pkgDeps _ = [] pkgFlags :: CblPkg -> FlagAssignment -pkgFlags (CP _ RepoPkg { flags = fa}) = fa +pkgFlags (CP _ (RepoPkg d)) = rpFlags d pkgFlags _ = [] -pkgRelease :: CblPkg -> String -pkgRelease (CP _ GhcPkg {}) = "xx" -pkgRelease (CP _ DistroPkg { release = r }) = r -pkgRelease (CP _ RepoPkg { release = r }) = r +pkgRelease :: CblPkg -> Int +pkgRelease (CP _ (GhcPkg _)) = (-1) +pkgRelease (CP _ (DistroPkg d)) = dpRelease d +pkgRelease (CP _ (RepoPkg d)) = rpRelease d createGhcPkg :: String -> V.Version -> CblPkg -createGhcPkg n v = CP n (GhcPkg v) +createGhcPkg n v = CP n (GhcPkg $ GhcPkgD v) -createDistroPkg :: String -> V.Version -> String -> CblPkg -createDistroPkg n v r = CP n (DistroPkg v r) +createDistroPkg :: String -> V.Version -> Int -> CblPkg +createDistroPkg n v r = CP n (DistroPkg (DistroPkgD v r)) -createRepoPkg :: String -> V.Version -> Int -> [P.Dependency] -> FlagAssignment -> String -> CblPkg -createRepoPkg n v x d fa r = CP n (RepoPkg v x d fa r) +createRepoPkg :: String -> V.Version -> Int -> [P.Dependency] -> FlagAssignment -> Int -> CblPkg +createRepoPkg n v x d fa r = CP n (RepoPkg $ RepoPkgD v x d fa r) createCblPkg :: PackageDescription -> FlagAssignment -> CblPkg -createCblPkg pd fa = createRepoPkg name version xrev deps fa "1" +createCblPkg pd fa = createRepoPkg name version xrev deps fa 1 where name = Util.Dist.pkgNameStr pd version = P.pkgVersion $ package pd @@ -176,7 +186,7 @@ addGhcPkg :: CblDB -> String -> V.Version -> CblDB addGhcPkg db n v = addPkg2 db (createGhcPkg n v) -addDistroPkg :: CblDB -> String -> V.Version -> String -> CblDB +addDistroPkg :: CblDB -> String -> V.Version -> Int -> CblDB addDistroPkg db n v r = addPkg2 db (createDistroPkg n v r) delPkg :: CblDB -> String -> CblDB @@ -185,9 +195,7 @@ bumpRelease :: CblDB -> String -> CblDB bumpRelease db n = maybe db (addPkg2 db . doBump) (lookupPkg db n) where - doBump (CP n' p@RepoPkg { release = r }) = CP n' (p { release = nr }) - where - nr = show $ read r + (1 :: Int) + doBump (CP n' (RepoPkg d)) = CP n' (RepoPkg d { rpRelease = (rpRelease d + 1) }) doBump p = p lookupPkg :: CblDB -> String -> Maybe CblPkg @@ -222,7 +230,7 @@ in (dN == name) || (case lookupPkg db dN of Nothing -> False - Just (CP _ p) -> V.withinRange (version p) dVR) + Just p -> V.withinRange (pkgVersion p) dVR) readDb :: FilePath -> IO CblDB readDb fp = handle @@ -245,6 +253,9 @@ $(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''V.VersionRange) $(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''FlagName) $(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''Pkg) +$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''GhcPkgD) +$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''DistroPkgD) +$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''RepoPkgD) $(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''CblPkg) instance ToJSON P.Dependency where diff --git a/src/Remove.hs b/src/Remove.hs --- a/src/Remove.hs +++ b/src/Remove.hs @@ -22,7 +22,8 @@ import Util.Misc -- {{{1 system -import Control.Monad.Error +import Control.Monad +import Control.Monad.Trans import Control.Monad.Reader (asks) import System.Exit @@ -44,4 +45,4 @@ depsString = foldr (\ s t -> " " ++ s ++ "\n" ++ t) "" deps in if null deps then return (delPkg db pkg) - else throwError ("Can't delete package " ++ pkg ++ ", dependants:\n" ++ depsString) + else fail ("Can't delete package " ++ pkg ++ ", dependants:\n" ++ depsString) diff --git a/src/Util/Cabal.hs b/src/Util/Cabal.hs --- a/src/Util/Cabal.hs +++ b/src/Util/Cabal.hs @@ -20,9 +20,8 @@ import Util.HackageIndex -import Control.Monad.Error +import Control.Monad.Trans.Except import Control.Monad.Reader -import qualified Data.ByteString.Lazy as BSL import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Parse @@ -35,6 +34,8 @@ import System.Posix import System.Process +import qualified Data.ByteString.Lazy as BSL + data CabalParseEnv = CabalParseEnv { cpeAppDir :: FilePath , cpePatchDir :: FilePath @@ -42,38 +43,40 @@ } deriving (Eq, Show) -- | Type used for reading Cabal files -type CabalParse a = ReaderT CabalParseEnv (ErrorT String IO) a +type CabalParse a = ReaderT CabalParseEnv (ExceptT String IO) a -- | Run a Cabal parse action in the provided environment. runCabalParse :: CabalParseEnv -> CabalParse a -> IO (Either String a) -runCabalParse cpe f = runErrorT $ runReaderT f cpe +runCabalParse cpe f = runExceptT $ runReaderT f cpe -runCabalParseE :: CabalParseEnv -> CabalParse a -> (ErrorT String IO) a +runCabalParseE :: CabalParseEnv -> CabalParse a -> (ExceptT String IO) a runCabalParseE cpe f = runReaderT f cpe readFromFile :: FilePath -- ^ file name - -> CabalParse GenericPackageDescription + -> CabalParse (BSL.ByteString, GenericPackageDescription) readFromFile fn = do destDir <- asks cpeDestDir let destFn = destDir takeFileName fn liftIO $ copyFile fn destFn - patch destFn - liftIO $ readPackageDescription silent destFn + cblFile <- patch destFn + gpd <- liftIO $ readPackageDescription silent destFn + return (cblFile, gpd) readFromIdx :: (String, Version) -- ^ package name and version - -> CabalParse GenericPackageDescription + -> CabalParse (BSL.ByteString, GenericPackageDescription) readFromIdx (pN, pV) = do destDir <- asks cpeDestDir appDir <- asks cpeAppDir let destFn = destDir pN <.> ".cabal" - copyCabal appDir destFn - patch destFn - liftIO $ readPackageDescription silent destFn + lift $ copyCabal appDir destFn + cblFile <- patch destFn + gpd <- liftIO $ readPackageDescription silent destFn + return (cblFile, gpd) where copyCabal appDir destFn = do idx <- liftIO $ readIndexFile appDir - cbl <- maybe (throwError $ "Failed to extract contents for " ++ pN ++ " " ++ display pV) return + cbl <- maybe (throwE $ "Failed to extract contents for " ++ pN ++ " " ++ display pV) return (extractCabal idx pN pV) liftIO $ BSL.writeFile destFn cbl @@ -83,12 +86,13 @@ -- pkg name>.patch@. The file is patched only if a patch with the correct name -- is found in the patch directory (provided via 'CabalParseEnv'). patch :: FilePath -- ^ file to patch - -> CabalParse () + -> CabalParse BSL.ByteString patch fn = do pkgName <- liftIO $ extractName fn patchDir <- asks cpePatchDir let patchFn = patchDir pkgName <.> "cabal" - applyPatchIfExist fn patchFn + lift $ applyPatchIfExist fn patchFn + liftIO $ BSL.readFile fn where extractName fn = liftM name $ readPackageDescription silent fn @@ -102,4 +106,4 @@ case ec of ExitSuccess -> return () ExitFailure _ -> - throwError ("Failed patching " ++ origFn ++ " with " ++ patchFn) + throwE ("Failed patching " ++ origFn ++ " with " ++ patchFn) diff --git a/src/Util/HackageIndex.hs b/src/Util/HackageIndex.hs --- a/src/Util/HackageIndex.hs +++ b/src/Util/HackageIndex.hs @@ -23,7 +23,9 @@ import qualified Codec.Archive.Tar as Tar import qualified Codec.Compression.GZip as GZip import Control.Applicative +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Search as BSLS import qualified Data.ByteString.Lazy.UTF8 as BSLU import Data.List import qualified Data.Map as M @@ -72,10 +74,12 @@ -> String -- ^ package name -> Version -- ^ package version -> Maybe BSL.ByteString -extractCabal idx pkg ver = getContent entries +extractCabal idx pkg ver = fmap dosToUnix $ getContent entries where entries = Tar.read $ GZip.decompress idx pkgPath = pkg display ver pkg <.> "cabal" + + dosToUnix bs = BSLS.replace (BS.pack [0xd, 0xa]) (BSL.pack [0xa]) bs getContent (Tar.Next e es) | pkgPath == Tar.entryPath e = diff --git a/src/Util/Misc.hs b/src/Util/Misc.hs --- a/src/Util/Misc.hs +++ b/src/Util/Misc.hs @@ -23,7 +23,7 @@ import Control.Exception (onException) import Control.Monad -import Control.Monad.Error +import Control.Monad.Trans.Except import Control.Monad.Reader import Data.Either import Data.Version @@ -100,13 +100,13 @@ ghcPkgArgReader :: ReadM (String, Version) ghcPkgArgReader = pkgNVersionArgReader -distroPkgArgReader :: ReadM (String, Version, String) +distroPkgArgReader :: ReadM (String, Version, Int) distroPkgArgReader = let readDistroPkg = do (n, v) <- readPkgNVersion char ',' r <- many (satisfy (/= ',')) - return (n, v, r) + return (n, v, read r) in do s <- readerAsk @@ -154,7 +154,7 @@ data Cmds = CmdAdd { patchDir :: FilePath, ghcVer :: Version, cmdAddGhcPkgs :: [(String, Version)] - , cmdAddDistroPkgs :: [(String, Version, String)], cmdAddFileCbls :: [(FilePath, FlagAssignment)] + , cmdAddDistroPkgs :: [(String, Version, Int)], cmdAddFileCbls :: [(FilePath, FlagAssignment)] , cmdAddCbls :: [(String, Version, FlagAssignment)] } | CmdBuildPkgs { pkgs :: [String] } | CmdBumpPkgs { inclusive :: Bool, pkgs :: [String] } @@ -193,7 +193,7 @@ case ec of ExitSuccess -> return () ExitFailure _ -> - throwError ("Failed patching " ++ origFilename ++ " with " ++ patchFilename) + throwE ("Failed patching " ++ origFilename ++ " with " ++ patchFilename) applyPatchIfExist origFilename patchFilename = liftIO (fileExist patchFilename) >>= flip when (applyPatch origFilename patchFilename) @@ -214,16 +214,16 @@ runCommand cmds func = runReaderT func cmds --- {{{1 ErrorT -reThrowError :: MonadError a m => Either a b -> m b -reThrowError = either throwError return +-- {{{1 ExceptT +reThrowE :: Monad m => Either a b -> ExceptT a m b +reThrowE = either throwE return -withTempDirErrT :: (MonadError e m, MonadIO m) => FilePath -> (FilePath -> ErrorT e IO b) -> m b -withTempDirErrT fp func = do - r <- liftIO $ withTemporaryDirectory fp (runErrorT . func) - reThrowError r +withTempDirExceptT :: MonadIO m => FilePath -> (FilePath -> ExceptT e IO b) -> ExceptT e m b +withTempDirExceptT fp func = do + r <- liftIO $ withTemporaryDirectory fp (runExceptT . func) + reThrowE r -exitOnErrors vs = let +exitOnAnyLefts vs = let es = lefts vs in if not $ null $ lefts vs diff --git a/src/Util/Translation.hs b/src/Util/Translation.hs --- a/src/Util/Translation.hs +++ b/src/Util/Translation.hs @@ -23,7 +23,8 @@ import Prelude hiding ( (<$>) ) import Control.Monad -import Control.Monad.Error +import Control.Monad.Trans +import Control.Monad.Trans.Except import Data.Char import Data.List import Data.Maybe @@ -39,6 +40,8 @@ import System.Unix.Directory import Text.PrettyPrint.ANSI.Leijen hiding(()) +import qualified Data.ByteString.Lazy as BSL (writeFile) + -- {{{1 ShQuotedString newtype ShQuotedString = ShQuotedString String deriving (Eq, Show) @@ -65,6 +68,8 @@ shVarNewValue (ShVar n _) v = ShVar n v shVarAppendValue (ShVar n v1) v2 = ShVar n (v1 `mappend` v2) shVarValue (ShVar _ v) = v +shVarName (ShVar n _) = n +shVarRefName (ShVar n _) = "${" ++ n ++ "}" instance Pretty a => Pretty (ShVar a) where pretty (ShVar n v) = text n <> char '=' <> pretty v @@ -83,7 +88,8 @@ , apShHkgName :: ShVar String , apShPkgName :: ShVar String , apShPkgVer :: ShVar Version - , apShPkgRel :: ShVar String + , apShPkgRel :: ShVar Int + , apShXRev :: ShVar String , apShPkgDesc :: ShVar ShQuotedString , apShUrl :: ShVar ShQuotedString , apShLicence :: ShVar ShArray @@ -107,14 +113,15 @@ , apBuildPatch = Nothing , apShHkgName = ShVar "_hkgname" "" , apShPkgName = ShVar "pkgname" "" - , apShPkgVer = ShVar "pkgver" (Version [] []) - , apShPkgRel = ShVar "pkgrel" "0" + , apShPkgVer = ShVar "_ver" (Version [] []) + , apShPkgRel = ShVar "pkgrel" 0 + , apShXRev = ShVar "_xrev" "0" , apShPkgDesc = ShVar "pkgdesc" (ShQuotedString "") , apShUrl = ShVar "url" (ShQuotedString "http://hackage.haskell.org/package/${_hkgname}") , apShLicence = ShVar "license" (ShArray []) , apShMakeDepends = ShVar "makedepends" (ShArray []) , apShDepends = ShVar "depends" (ShArray []) - , apShSource = ShVar "source" (ShArray ["http://hackage.haskell.org/packages/archive/${_hkgname}/${pkgver}/${_hkgname}-${pkgver}.tar.gz"]) + , apShSource = ShVar "source" (ShArray ["http://hackage.haskell.org/packages/archive/${_hkgname}/${_ver}/${_hkgname}-${_ver}.tar.gz", "original.cabal"]) , apShInstall = Just $ ShVar "install" (ShQuotedString "${pkgname}.install") -- this is a trick to make sure that the user's setting for integrity -- checking in makepkg.conf isn't used, as long as this array contains @@ -134,6 +141,7 @@ , apShPkgName = pkgName , apShPkgVer = pkgVer , apShPkgRel = pkgRel + , apShXRev = xrev , apShPkgDesc = pkgDesc , apShUrl = url , apShLicence = pkgLicense @@ -147,9 +155,11 @@ [ text "# custom variables" , pretty hkgName , maybe empty (pretty . ShVar "_licensefile") licenseFile + , pretty pkgVer + , pretty xrev , empty, text "# PKGBUILD options/directives" , pretty pkgName - , pretty pkgVer + , text "pkgver=${_ver}_${_xrev}" , pretty pkgRel , pretty pkgDesc , pretty url @@ -173,11 +183,9 @@ where prepareFunction = text "prepare() {" <> nest 4 (empty <$> - text "cd \"${srcdir}/${_hkgname}-${pkgver}\"" <$> + text "cd \"${srcdir}/${_hkgname}-${_ver}\"" <$> + text "cp \"${srcdir}/original.cabal\" \"${srcdir}/${_hkgname}-${_ver}/${_hkgname}.cabal\"" <$> empty <$> - maybe (text "# no cabal patch") (\ _ -> - text $ "patch " ++ shVarValue hkgName ++ ".cabal \"${srcdir}/cabal.patch\" ") - cabalPatchFile <$> maybe (text "# no source patch") (\ _ -> text "patch -p4 < \"${srcdir}/source.patch\"") buildPatchFile @@ -185,7 +193,7 @@ char '}' libBuildFunction = text "build() {" <> nest 4 (empty <$> - text "cd \"${srcdir}/${_hkgname}-${pkgver}\"" <$> + text "cd \"${srcdir}/${_hkgname}-${_ver}\"" <$> empty <$> nest 4 (text "runhaskell Setup configure -O --enable-library-profiling --enable-shared \\" <$> text "--prefix=/usr --docdir=\"/usr/share/doc/${pkgname}\" \\" <$> @@ -199,7 +207,7 @@ char '}' exeBuildFunction = text "build() {" <> - nest 4 (empty <$> text "cd \"${srcdir}/${_hkgname}-${pkgver}\"" <$> + nest 4 (empty <$> text "cd \"${srcdir}/${_hkgname}-${_ver}\"" <$> empty <$> text "runhaskell Setup configure -O --prefix=/usr --docdir=\"/usr/share/doc/${pkgname}\"" <> confFlags <$> text "runhaskell Setup build" @@ -213,7 +221,7 @@ libPackageFunction = text "package() {" <> nest 4 (empty <$> - text "cd \"${srcdir}/${_hkgname}-${pkgver}\"" <$> + text "cd \"${srcdir}/${_hkgname}-${_ver}\"" <$> empty <$> text "install -D -m744 register.sh \"${pkgdir}/usr/share/haskell/${pkgname}/register.sh\"" <$> text "install -m744 unregister.sh \"${pkgdir}/usr/share/haskell/${pkgname}/unregister.sh\"" <$> @@ -226,7 +234,7 @@ char '}' exePackageFunction = text "package() {" <> - nest 4 (empty <$> text "cd \"${srcdir}/${_hkgname}-${pkgver}\"" <$> + nest 4 (empty <$> text "cd \"${srcdir}/${_hkgname}-${_ver}\"" <$> text "runhaskell Setup copy --destdir=\"${pkgdir}\"" ) <$> char '}' @@ -263,18 +271,18 @@ ] where postInstallFunction = text "post_install() {" <> - nest 4 (empty <$> text "${HS_DIR}/register.sh" <$> + nest 4 (empty <$> text "${HS_DIR}/register.sh --verbose=0" <$> text "/usr/share/doc/ghc/html/libraries/arch-gen-contents-index") <$> char '}' preUpgradeFunction = text "pre_upgrade() {" <> - nest 4 (empty <$> text "${HS_DIR}/unregister.sh") <$> + nest 4 (empty <$> text "${HS_DIR}/unregister.sh --verbose=0") <$> char '}' postUpgradeFunction = text "post_upgrade() {" <> - nest 4 (empty <$> text "${HS_DIR}/register.sh" <$> + nest 4 (empty <$> text "${HS_DIR}/register.sh --verbose=0" <$> text "/usr/share/doc/ghc/html/libraries/arch-gen-contents-index") <$> char '}' preRemoveFunction = text "pre_remove() {" <> - nest 4 (empty <$> text "${HS_DIR}/unregister.sh") <$> + nest 4 (empty <$> text "${HS_DIR}/unregister.sh --verbose=0") <$> char '}' postRemoveFunction = text "post_remove() {" <> nest 4 (empty <$> text "/usr/share/doc/ghc/html/libraries/arch-gen-contents-index") <$> @@ -290,11 +298,13 @@ -- {{{1 translate -- TODO: -- • translation of extraLibDepends-libs to Arch packages +translate :: Version -> Int -> CblDB -> FlagAssignment -> PackageDescription -> ArchPkg translate ghcVer ghcRel db fa pd = let ap = baseArchPkg (PackageName hkgName) = packageName pd pkgVer = packageVersion pd - pkgRel = maybe "1" pkgRelease (lookupPkg db hkgName) + pkgRel = maybe 1 pkgRelease (lookupPkg db hkgName) + xrev = show $ Util.Dist.pkgXRev pd hasLib = isJust (library pd) licFn = let l = licenseFiles pd in if null l then Nothing else Just (head l) archName = (if hasLib then "haskell-" else "") ++ map toLower hkgName @@ -314,6 +324,7 @@ , apShPkgName = shVarNewValue (apShPkgName ap) archName , apShPkgVer = shVarNewValue (apShPkgVer ap) pkgVer , apShPkgRel = shVarNewValue (apShPkgRel ap) pkgRel + , apShXRev = shVarNewValue (apShXRev ap) xrev , apShPkgDesc = shVarNewValue (apShPkgDesc ap) (ShQuotedString pkgDesc) , apShUrl = shVarNewValue (apShUrl ap) (ShQuotedString url) , apShLicence = shVarNewValue (apShLicence ap) (ShArray [lic]) @@ -329,17 +340,18 @@ -- TODO: -- • this is most likely too simplistic to create the Arch package names -- correctly for all possible dependencies -calcExactDeps db pd = let - n = pkgNameStr pd - remPkgs = map DB.pkgName (filter isGhcPkg db) ++ [n] +calcExactDeps db pd = map depString deps + where + remPkgs = map DB.pkgName (filter isGhcPkg db) ++ [pkgNameStr pd] deps = filter (not . (`elem` remPkgs)) (map depName (buildDepends pd)) - depString n = let + + depString n = "haskell-" ++ name ++ "=" ++ ver ++ "_" ++ xrev ++ "-" ++ rel + where pkg = fromJust $ lookupPkg db n name = map toLower $ DB.pkgName pkg ver = display $ DB.pkgVersion pkg - rel = pkgRelease pkg - in "haskell-" ++ name ++ "=" ++ ver ++ "-" ++ rel - in map depString deps + xrev = show $ DB.pkgXRev pkg + rel = show $ pkgRelease pkg -- {{{1 stuff with patches -- {{{2 addPatches @@ -357,7 +369,7 @@ installPatch <- doesFileExist installPatchFn >>= fi (liftM Just $ canonicalizePath installPatchFn) (return Nothing) buildPatch <- doesFileExist buildPatchFn >>= fi (liftM Just $ canonicalizePath buildPatchFn) (return Nothing) let sources' = shVarAppendValue sources - (ShArray $ catMaybes [maybe Nothing (const $ Just "cabal.patch") cabalPatch, maybe Nothing (const $ Just "source.patch") buildPatch]) + (ShArray $ catMaybes [maybe Nothing (const $ Just "source.patch") buildPatch]) return ap { apCabalPatch = cabalPatch , apPkgbuildPatch = pkgBuildPatch @@ -375,18 +387,20 @@ maybe (return ()) (\ fn -> copyFile fn (destDir "source.patch")) buildPatch -- {{{1 addHashes -addHashes ap tmpDir = let +addHashes ap cbl tmpDir = let hashes = map (filter (`elem` "1234567890abcdef")) . lines . drop 11 pkgbuildFn = tmpDir "PKGBUILD" + cblFn = tmpDir "original.cabal" pkgbuildPatch = apPkgbuildPatch ap in do liftIO $ copyPatches tmpDir ap liftIO $ writeFile pkgbuildFn (show $ pretty ap) maybe (return ()) (void . applyPatch pkgbuildFn) pkgbuildPatch + liftIO $ BSL.writeFile cblFn cbl (ec, out, _) <- liftIO $ withWorkingDirectory tmpDir (readProcessWithExitCode "makepkg" ["-g"] "") case ec of ExitFailure _ -> - throwError $ "makepkg: error while calculating the source hashes for " ++ apHkgName ap + throwE $ "makepkg: error while calculating the source hashes for " ++ apHkgName ap ExitSuccess -> return (if "sha256sums=(" `isPrefixOf` out then replaced else ap) where