diff --git a/cblrepo.cabal b/cblrepo.cabal --- a/cblrepo.cabal +++ b/cblrepo.cabal @@ -1,5 +1,5 @@ name: cblrepo -version: 0.13 +version: 0.14.0 cabal-version: >= 1.6 license: OtherLicense license-file: LICENSE-2.0 @@ -23,15 +23,14 @@ executable cblrepo hs-source-dirs: src main-is: Main.hs - other-modules: Util.Misc PkgDB Add BumpPkgs BuildPkgs Sync - Versions Updates ListPkgs Urls PkgBuild Util.Translation - OldPkgDB ConvertDB Remove + 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.7.*, filepath ==1.3.*, - directory ==1.2.*, Cabal ==1.18.*, json ==0.7.*, + directory ==1.2.*, Cabal ==1.18.*, bytestring ==0.10.*, tar ==0.4.*, zlib ==0.5.*, mtl >=2.0 && <2.2, process ==1.2.*, Unixutils ==1.52.*, unix ==2.7.*, ansi-wl-pprint ==0.6.*, aeson ==0.8.*, - optparse-applicative ==0.11.*, safe + optparse-applicative ==0.11.*, safe, containers, utf8-string Source-Repository head Type: git diff --git a/src/Add.hs b/src/Add.hs --- a/src/Add.hs +++ b/src/Add.hs @@ -19,10 +19,13 @@ -- {{{1 imports -- {{{2 local import PkgDB +import qualified Util.Cabal as Cbl import Util.Misc +import Util.Dist -- {{{2 system -import Control.Monad.Error +import Control.Monad.Reader +-- import Control.Monad.Error import Data.List import Data.Maybe import Distribution.PackageDescription @@ -31,6 +34,7 @@ import Control.Arrow import Data.Monoid import Data.Either +import System.Unix.Directory -- {{{1 types data PkgType @@ -44,8 +48,6 @@ add = do dbFn <- optGet dbFile db <- liftIO $ readDb dbFn - ad <- optGet appDir - pd <- optGet $ patchDir . optsCmd dr <- optGet dryRun ghcVersion <- optGet $ ghcVer . optsCmd filePkgs <- optGet $ cmdAddFileCbls . optsCmd @@ -53,24 +55,33 @@ -- ghcPkgs <- optGet $ map (uncurry GhcType) . cmdAddGhcPkgs . optsCmd distroPkgs <- optGet $ map (\ (n, v, r) -> DistroType n v r) . cmdAddDistroPkgs . optsCmd - genFilePkgs <- mapM ((runErrorT . withTempDirErrT "/tmp/cblrepo." . readCabalFromFile ad pd) . fst) filePkgs - genIdxPkgs <- mapM ((runErrorT . withTempDirErrT "/tmp/cblrepo." . readCabalFromIdx ad pd) . (\ (a, b, _) -> (a, b))) idxPkgs + genFilePkgs <- mapM (runCabalParseWithTempDir . Cbl.readFromFile . fst) filePkgs + genIdxPkgs <- mapM ((runCabalParseWithTempDir . Cbl.readFromIdx) . (\ (a, b, _) -> (a, b))) idxPkgs genPkgs <- liftM (map RepoType) $ exitOnErrors (genFilePkgs ++ genIdxPkgs) -- let pkgs = ghcPkgs ++ distroPkgs ++ genPkgs pkgNames = map getName pkgs tmpDb = foldl delPkg db pkgNames oldFlags = map (maybe ([], []) (pkgName &&& pkgFlags) . lookupPkg db . getName) pkgs - fileFlags = map (\ (pkg, (_, fa)) -> ((\ (P.PackageName n) -> n) $ P.packageName pkg, fa)) (zip (rights genFilePkgs) filePkgs) + fileFlags = map (\ (pkg, (_, fa)) -> (pkgNameStr pkg, fa)) + (zip (rights genFilePkgs) filePkgs) idxFlags = map (\ (a, _, b) -> (a, b)) idxPkgs flags = fileFlags `combineFlags` idxFlags `combineFlags` oldFlags case addPkgs ghcVersion tmpDb flags pkgs of Left (unsatisfiables, breaksOthers) -> liftIO (mapM_ printUnSat unsatisfiables >> mapM_ printBrksOth breaksOthers) Right newDb -> liftIO $ unless dr $ saveDb newDb dbFn +runCabalParseWithTempDir :: Cbl.CabalParse a -> Command (Either String a) +runCabalParseWithTempDir f = do + aD <- asks appDir + pD <- asks $ patchDir . optsCmd + liftIO $ withTemporaryDirectory "/tmp/cblrepo." $ \ destDir -> do + let cpe = Cbl.CabalParseEnv aD pD destDir + Cbl.runCabalParse cpe f + getName (GhcType n _) = n getName (DistroType n _ _) = n -getName (RepoType gpd) = (\ (P.PackageName n) -> n) $ P.pkgName $ package $ packageDescription gpd +getName (RepoType gpd) = pkgNameStr $ packageDescription gpd -- {{{1 addPkgs addPkgs :: Version -> CblDB -> [(String, FlagAssignment)] -> [PkgType] -> Either ([(String, [P.Dependency])], [((String, Version), [(String, Maybe P.Dependency)])]) CblDB @@ -91,7 +102,7 @@ where fa = fromMaybe [] $ lookup (getName pkg) flags finable = either (const False) (const True) (finalizePkg ghcVer db fa gpd) - n = ((\ (P.PackageName n) -> n ) . P.pkgName . package . packageDescription) gpd + n = pkgNameStr (packageDescription gpd) v = P.pkgVersion $ package $ packageDescription gpd depsOK = null $ checkDependants db n v @@ -106,7 +117,7 @@ finalizeToUnsatisfiableDeps ghcVer db flags pkg@(RepoType gpd) = let fa = fromMaybe [] $ lookup (getName pkg) flags in case finalizePkg ghcVer db fa gpd of - Left ds -> Just (((\ (P.PackageName n) -> n ) . P.pkgName . package . packageDescription) gpd, ds) + Left ds -> Just (pkgNameStr (packageDescription gpd), ds) _ -> Nothing finalizeToUnsatisfiableDeps _ _ _ _ = Nothing @@ -122,7 +133,7 @@ then Nothing else Just ((n, v), d) findBreaking db (RepoType gpd) = let - n = (\ (P.PackageName n) -> n) $ P.pkgName $ package $ packageDescription gpd + n = pkgNameStr (packageDescription gpd) v = P.pkgVersion $ package $ packageDescription gpd d = checkDependants db n v in if null d diff --git a/src/ConvertDB.hs b/src/ConvertDB.hs --- a/src/ConvertDB.hs +++ b/src/ConvertDB.hs @@ -1,5 +1,5 @@ {- - - Copyright 2011 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,13 +16,10 @@ module ConvertDB where --- {{{1 imports --- {{{2 local import Util.Misc import qualified OldPkgDB as ODB import qualified PkgDB as NDB --- {{{2 system import Control.Monad.Reader convertDb :: Command () @@ -33,6 +30,15 @@ liftIO $ NDB.saveDb newDb outDbFn doConvert :: ODB.CblPkg -> NDB.CblPkg -doConvert (ODB.CP n (ODB.GhcPkg v)) = NDB.CP n (NDB.GhcPkg v) -doConvert (ODB.CP n (ODB.DistroPkg v r)) = NDB.CP n (NDB.DistroPkg v r) -doConvert (ODB.CP n (ODB.RepoPkg v d f r)) = NDB.CP n (NDB.RepoPkg v d f r) +doConvert o + | ODB.isGhcPkg o = NDB.createGhcPkg n v + | ODB.isDistroPkg o = NDB.createDistroPkg n v r + | ODB.isRepoPkg o = NDB.createRepoPkg n v x d f r + | otherwise = error "" + where + n = ODB.pkgName o + v = ODB.pkgVersion o + x = 0 + d = ODB.pkgDeps o + f = ODB.pkgFlags o + r = ODB.pkgRelease o diff --git a/src/Extract.hs b/src/Extract.hs new file mode 100644 --- /dev/null +++ b/src/Extract.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE FlexibleContexts #-} +module Extract + where + +import Util.HackageIndex +import Util.Misc + +import Control.Monad.Error +import Control.Monad.Reader +import qualified Data.ByteString.Lazy as BSL +import Data.Version +import Distribution.Text (display) +import System.FilePath + +extract :: Command () +extract = do + aD <- asks appDir + pkgsNVersions <- asks $ cmdExtractPkgs . optsCmd + -- + idx <- liftIO $ readIndexFile aD + _ <- mapM (runErrorT . extractAndSave idx) pkgsNVersions >>= exitOnErrors + 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) + where + destFn = pkg <.> "cabal" + errorMsg = "Failed to extract Cabal for " ++ pkg ++ " " ++ display ver diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -25,10 +25,10 @@ import ListPkgs import Updates import Util.Misc -import Urls import PkgBuild import ConvertDB import Remove +import Extract import Paths_cblrepo @@ -87,11 +87,6 @@ cmdListPkgsCmd = command "list" (info (helper <*> cmdListPkgsOpts) (fullDesc <> progDesc "List packages in repo")) -cmdUrlsOpts = CmdUrls - <$> some (option pkgNVersionArgReader (metavar "PKGNAME,VERSION ...")) -cmdUrlsCmd = command "urls" (info (helper <*> cmdUrlsOpts) - (fullDesc <> progDesc "List urls of CABAL files for the given packages")) - cmdPkgBuildOpts = CmdPkgBuild <$> option ghcVersionArgReader (long "ghc-version" <> value ghcDefVersion <> help "GHC version to use in PKGBUILD") <*> option auto (long "ghc-release" <> value 1 <> help "GHC release to use in PKGBUILD") @@ -111,12 +106,17 @@ cmdRemovePkgCmd = command "rm" (info (helper <*> cmdRemovePkgOpts) (fullDesc <> progDesc "Remove packages")) +cmdExtractOpts = CmdExtract + <$> many (argument pkgNVersionArgReader (metavar "PKGNAME,VERSION")) +cmdExtractCmd = command "extract" (info (helper <*> cmdExtractOpts) (fullDesc <> progDesc "Extract Cabal file from index")) + argParser = info (helper <*> opts) (fullDesc <> header (progName ++ " v" ++ display version) <> progDesc "Maintain a datatbase of dependencies of CABAL packages") where opts = Opts <$> argAppDir <*> argDbFile <*> argDryRun - <*> subparser ( - cmdAddPkgCmd <> cmdBumpPkgsCmd <> cmdBuildPkgsCmd <> cmdSyncCmd <> cmdVersionsCmd <> - cmdUpdatesCmd <> cmdListPkgsCmd <> cmdUrlsCmd <> cmdPkgBuildCmd <> cmdConvertDbCmd <> cmdRemovePkgCmd) + <*> subparser ( cmdAddPkgCmd + <> cmdBumpPkgsCmd <> cmdBuildPkgsCmd <> cmdSyncCmd <> cmdVersionsCmd <> cmdUpdatesCmd + <> cmdListPkgsCmd <> cmdPkgBuildCmd <> cmdConvertDbCmd <> cmdRemovePkgCmd <> cmdExtractCmd + ) -- {{{1 main main :: IO () @@ -134,7 +134,7 @@ CmdVersions {} -> runCommand o' versions CmdListPkgs {} -> runCommand o' listPkgs CmdUpdates {} -> runCommand o' updates - CmdUrls {} -> runCommand o' urls CmdPkgBuild {} -> runCommand o' pkgBuild CmdConvertDb {} -> runCommand o' convertDb CmdRemovePkg {} -> runCommand o' remove + CmdExtract {} -> runCommand o' extract diff --git a/src/OldPkgDB.hs b/src/OldPkgDB.hs --- a/src/OldPkgDB.hs +++ b/src/OldPkgDB.hs @@ -1,5 +1,5 @@ {- - - Copyright 2011 Per Magnus Therning + - Copyright 2011-2013 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. @@ -14,22 +14,25 @@ - limitations under the License. -} +{-# LANGUAGE TemplateHaskell #-} + module OldPkgDB where -- {{{1 imports +import Control.Arrow import Control.Exception as CE import Control.Monad -import Data.Data import Data.List import Data.Maybe -import Data.Typeable import Distribution.PackageDescription -import Distribution.Text import System.IO.Error -import Text.JSON import qualified Distribution.Package as P import qualified Distribution.Version as V +import Data.Aeson (decode, encode) +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 @@ -123,7 +126,7 @@ addPkg db n p = nubBy cmp newdb where cmp (CP n1 _) (CP n2 _) = n1 == n2 - newdb = (CP n p):db + newdb = CP n p:db addPkg2 :: CblDB -> CblPkg -> CblDB addPkg2 db (CP n p) = addPkg db n p @@ -141,7 +144,7 @@ bumpRelease db n = let doBump (CP n' p@RepoPkg { release = r }) = CP n' (p { release = nr }) where - nr = show $ (read r) + 1 + nr = show $ read r + (1 :: Int) doBump p = p in maybe db (addPkg2 db . doBump) (lookupPkg db n) @@ -151,12 +154,12 @@ | n == pkgName p = Just p | otherwise = lookupPkg db n -lookupDependants db n = filter (/= n) $ map pkgName $ filter (\ p -> doesDependOn p n) db +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 _depName (pkgDeps p) transitiveDependants :: CblDB -> [String] -> [String] -transitiveDependants db names = keepLast $ concat $ map transUsersOfOne names +transitiveDependants db names = keepLast $ concatMap transUsersOfOne names where transUsersOfOne n = n : transitiveDependants db (lookupDependants db n) keepLast = reverse . nub . reverse @@ -164,80 +167,33 @@ -- Todo: test checkDependants :: CblDB -> String -> V.Version -> [(String, Maybe P.Dependency)] checkDependants db n v = let - d1 = catMaybes $ map (lookupPkg db) (lookupDependants db n) - d2 = map (\ p -> (pkgName p, getDependencyOn n p)) d1 + 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 in fails readDb :: FilePath -> IO CblDB -readDb fp = (flip CE.catch) +readDb fp = handle (\ e -> if isDoesNotExistError e then return emptyPkgDB else throwIO e) $ do - r <- readFile fp >>= return . sequence . map decode . lines + r <- (mapM decode . C.lines) `liftM` C.readFile fp case r of - Ok a -> return a - Error s -> fail s + Just a -> return a + Nothing -> fail "JSON parsing failed" saveDb :: CblDB -> FilePath -> IO () -saveDb db fp = writeFile fp s +saveDb db fp = C.writeFile fp s where - s = unlines $ map encode $ sort db + s = C.unlines $ map encode $ sort db -- {{{1 JSON instances -instance JSON CblPkg where - showJSON (CP n p) = showJSON (n, p) - - readJSON object = do - (n,p) <- readJSON object - return (CP n p) - -instance JSON V.Version where - showJSON v = makeObj [ ("Version", showJSON $ display v) ] - - readJSON object = do - obj <- readJSON object - version <- valFromObj "Version" obj - maybe (fail "Not a Version object") return (simpleParse version) - -instance JSON P.Dependency where - showJSON d = makeObj [ ("Dependency", showJSON $ display d) ] - - readJSON object = do - obj <- readJSON object - dep <- valFromObj "Dependency" obj - maybe (fail "Not a Dependency object") return (simpleParse dep) - -instance JSON FlagName where - showJSON (FlagName n) = makeObj [ ("FlagName", showJSON n) ] - - readJSON object = do - obj <- readJSON object - n <- valFromObj "FlagName" obj - return $ FlagName n - -instance JSON Pkg where - showJSON p@(GhcPkg { version = v}) = makeObj [("GhcPkg", showJSON v)] - showJSON p@(DistroPkg { version = v, release = r}) = - makeObj [("DistroPkg", showJSON (v, r))] - showJSON p@(RepoPkg { version = v, deps = d, flags = fa, release = r }) = - makeObj [("RepoPkg", showJSON (v, d, fa, r))] - - readJSON object = let - readGhc = do - obj <- readJSON object - v <- valFromObj "GhcPkg" obj >>= readJSON - return $ GhcPkg v - - readDistro = do - obj <- readJSON object - (v, r) <- valFromObj "DistroPkg" obj >>= readJSON - return $ DistroPkg v r - - readRepo = do - obj <- readJSON object - (v, d, fa, r) <- valFromObj "RepoPkg" obj >>= readJSON - return $ RepoPkg v d fa r - - in readGhc `mplus` readDistro `mplus` readRepo `mplus` fail "Not a Pkg object" +$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''V.Version) +$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''V.VersionRange) +$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''P.Dependency) +$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''P.PackageName) +$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''FlagName) +$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''Pkg) +$(deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField, allNullaryToStringTag = False } ''CblPkg) diff --git a/src/PkgBuild.hs b/src/PkgBuild.hs --- a/src/PkgBuild.hs +++ b/src/PkgBuild.hs @@ -19,10 +19,11 @@ import PkgDB import Util.Misc import Util.Translation +import qualified Util.Cabal as Cbl +import Control.Arrow +import Control.Monad.Reader import Control.Monad.Error -import Data.Maybe -import Distribution.Text import System.Directory import System.FilePath import System.IO @@ -31,20 +32,20 @@ pkgBuild :: Command () pkgBuild = do - db <- optGet dbFile >>= liftIO . readDb - aD <- optGet appDir - pD <- optGet $ patchDir . optsCmd - pkgs <- optGet $ pkgs . optsCmd - ghcVersion <- optGet $ ghcVer . optsCmd - ghcRelease <- optGet $ ghcRel . optsCmd - void $ mapM (runErrorT . generatePkgBuild ghcVersion ghcRelease db aD pD) pkgs >>= exitOnErrors + pkgs <- asks $ pkgs . optsCmd + void $ mapM (runErrorT . generatePkgBuild) pkgs >>= exitOnErrors -generatePkgBuild ghcVer ghcRel db appDir patchDir pkg = let - appendPkgVer = pkg ++ "," ++ display (pkgVersion $ fromJust $ lookupPkg db pkg) - in do - fa <- maybe (throwError $ "Unknown package: " ++ pkg) (\(CP _ x) -> return $ PkgDB.flags x) (lookupPkg db pkg) - genericPkgDesc <- withTempDirErrT "/tmp/cblrepo." (readCabal appDir patchDir appendPkgVer) - pkgDescAndFlags <- either (const $ throwError ("Failed to finalize package: " ++ pkg)) return (finalizePkg ghcVer db fa genericPkgDesc) +generatePkgBuild :: String -> ErrorT String Command () +generatePkgBuild pkg = do + db <- optGet dbFile >>= liftIO . readDb + patchDir <- asks $ patchDir . optsCmd + ghcVer <- optGet $ ghcVer . optsCmd + ghcRel <- optGet $ 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 + (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) @@ -54,10 +55,21 @@ hPKGBUILD <- openFile "PKGBUILD" WriteMode hPutDoc hPKGBUILD $ pretty archPkgWHash hClose hPKGBUILD - maybe (return ()) (void . runErrorT . applyPatch "PKGBUILD") (apPkgbuildPatch archPkgWHash) + maybe (return ()) (void . runErrorT . 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") ) (apInstallPatch archPkgWHash) + maybe (return ()) (void . runErrorT . applyPatch (apPkgName archPkgWHash <.> "install")) + (apInstallPatch archPkgWHash) + +runCabalParseWithTempDir :: Cbl.CabalParse a -> ErrorT 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 diff --git a/src/PkgDB.hs b/src/PkgDB.hs --- a/src/PkgDB.hs +++ b/src/PkgDB.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 PkgDB where +module PkgDB + ( 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/Updates.hs b/src/Updates.hs --- a/src/Updates.hs +++ b/src/Updates.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. @@ -14,66 +14,43 @@ - limitations under the License. -} -module Updates where +module Updates + ( updates + ) where import PkgDB import Util.Misc +import Util.HackageIndex -import Codec.Archive.Tar as Tar -import Codec.Compression.GZip as GZip +import Control.Applicative import Control.Arrow -import Control.Monad import Control.Monad.Reader import Data.Maybe import Distribution.Text import Distribution.Version -import System.FilePath updates :: Command () updates = do db <- optGet dbFile >>= liftIO . readDb aD <- optGet appDir aCS <- optGet $ idxStyle .optsCmd - entries <- liftIO $ liftM (Tar.read . GZip.decompress) (readIndexFile aD) + availPkgsNVers <- liftIO $ buildPkgVersions <$> readIndexFile aD let nonBasePkgs = filter (not . isBasePkg) db - let pkgsNVers = map (pkgName &&& pkgVersion) nonBasePkgs - let availPkgs = catMaybes $ eMap extractPkgVer entries - let outdated = filter - (\ (p, v) -> maybe False (> v) (latestVer p availPkgs)) + pkgsNVers = map (pkgName &&& pkgVersion &&& pkgXRev) nonBasePkgs + outdated = filter + (\ (p, vx) -> maybe False (> vx) (latestVersion availPkgsNVers p)) pkgsNVers - let printer = if aCS - then printOutdatedIdx + printer = if aCS + then printOutdatedShort else printOutdated - liftIO $ mapM_ (`printer` availPkgs) outdated - -type PkgVer = (String, Version) - -extractPkgVer :: Entry -> Maybe PkgVer -extractPkgVer e = let - ep = entryPath e - isCabal = '/' `elem` ep - (pkg:ver':_) = map dropTrailingPathSeparator $ splitPath ep - ver = simpleParse ver' - in if isCabal && isJust ver - then Just (pkg, fromJust ver) - else Nothing - -latestVer p pvs = let - vs = map snd $ filter ((== p) . fst) pvs - in if null vs - then Nothing - else Just $ maximum vs - -eMap _ Done = [] -eMap f (Next e es) = f e:eMap f es -eMap _ (Fail _) = error "Failure to read index" + liftIO $ mapM_ (printer availPkgsNVers) outdated -printOutdated (p, v) avail = let - l = fromJust $ latestVer p avail - in - putStrLn $ p ++ ": " ++ display v ++ " (" ++ display l ++ ")" +printOutdated :: PkgVersions -> (String, (Version, Int)) -> IO () +printOutdated avail (p, (v, x)) = putStrLn $ p ++ ": " ++ display v ++ ":x" ++ show x ++ " (" ++ display lv ++ ":x" ++ show lx ++ ")" + where + (lv, lx) = fromJust $ latestVersion avail p -printOutdatedIdx (p, _) avail = let - l = fromJust $ latestVer p avail - in - putStrLn $ p ++ "," ++ display l +printOutdatedShort :: PkgVersions -> (String, (Version, Int)) -> IO () +printOutdatedShort avail (p, _) = putStrLn $ p ++ "," ++ display l + where + l = fst $ fromJust $ latestVersion avail p diff --git a/src/Urls.hs b/src/Urls.hs deleted file mode 100644 --- a/src/Urls.hs +++ /dev/null @@ -1,29 +0,0 @@ -{- - - Copyright 2011 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. - - You may obtain a copy of the License at - - - - http://www.apache.org/licenses/LICENSE-2.0 - - - - Unless required by applicable law or agreed to in writing, software - - distributed under the License is distributed on an "AS IS" BASIS, - - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - - See the License for the specific language governing permissions and - - limitations under the License. - -} - -module Urls where - -import Util.Misc - -import Control.Monad.Reader -import Distribution.Text (display) - -urls :: Command () -urls = do - pkgs <- optGet $ pkgVers . optsCmd - liftIO $ mapM_ (putStrLn . createUrl) pkgs - -createUrl (pkg, ver) = "http://hackage.haskell.org/packages/archive/" ++ pkg ++ "/" ++ display ver ++ "/" ++ pkg ++ ".cabal" diff --git a/src/Util/Cabal.hs b/src/Util/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/Util/Cabal.hs @@ -0,0 +1,104 @@ +{- + - Copyright 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. + - You may obtain a copy of the License at + - + - http://www.apache.org/licenses/LICENSE-2.0 + - + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +module Util.Cabal + where + +import Util.HackageIndex + +import Control.Monad.Error +import Control.Monad.Reader +import qualified Data.ByteString.Lazy as BSL +import Distribution.Package +import Distribution.PackageDescription +import Distribution.PackageDescription.Parse +import Distribution.Text +import Distribution.Verbosity +import Distribution.Version +import System.Directory +import System.Exit +import System.FilePath +import System.Posix +import System.Process + +data CabalParseEnv = CabalParseEnv + { cpeAppDir :: FilePath + , cpePatchDir :: FilePath + , cpeDestDir :: FilePath + } deriving (Eq, Show) + +-- | Type used for reading Cabal files +type CabalParse a = ReaderT CabalParseEnv (ErrorT 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 + +runCabalParseE :: CabalParseEnv -> CabalParse a -> (ErrorT String IO) a +runCabalParseE cpe f = runReaderT f cpe + +readFromFile :: FilePath -- ^ file name + -> CabalParse GenericPackageDescription +readFromFile fn = do + destDir <- asks cpeDestDir + let destFn = destDir takeFileName fn + liftIO $ copyFile fn destFn + patch destFn + liftIO $ readPackageDescription silent destFn + +readFromIdx :: (String, Version) -- ^ package name and version + -> CabalParse 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 + + where + copyCabal appDir destFn = do + idx <- liftIO $ readIndexFile appDir + cbl <- maybe (throwError $ "Failed to extract contents for " ++ pN ++ " " ++ display pV) return + (extractCabal idx pN pV) + liftIO $ BSL.writeFile destFn cbl + +-- | Patch a Cabal file. +-- +-- The name of the patch file is based on the name of the Cabal package: @.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 () +patch fn = do + pkgName <- liftIO $ extractName fn + patchDir <- asks cpePatchDir + let patchFn = patchDir pkgName <.> "cabal" + applyPatchIfExist fn patchFn + + where + extractName fn = liftM name $ readPackageDescription silent fn + name = display . pkgName . package . packageDescription + + applyPatchIfExist origFn patchFn = + liftIO (fileExist patchFn) >>= flip when (applyPatch origFn patchFn) + + applyPatch origFn patchFn = do + (ec, _, _) <- liftIO $ readProcessWithExitCode "patch" [origFn, patchFn] "" + case ec of + ExitSuccess -> return () + ExitFailure _ -> + throwError ("Failed patching " ++ origFn ++ " with " ++ patchFn) diff --git a/src/Util/Dist.hs b/src/Util/Dist.hs new file mode 100644 --- /dev/null +++ b/src/Util/Dist.hs @@ -0,0 +1,45 @@ +{- + - Copyright 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. + - You may obtain a copy of the License at + - + - http://www.apache.org/licenses/LICENSE-2.0 + - + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +module Util.Dist + ( depName + , depVersionRange + , pkgNameStr + , pkgXRev + ) where + +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Version + +-- | Extract the name of a 'Dependency'. +depName :: Dependency -> String +depName (Dependency (PackageName n) _) = n + +-- | Extract the version range from a 'Dependency'. +depVersionRange :: Dependency -> VersionRange +depVersionRange (Dependency _ vr) = vr + +-- | Get the name from a 'Package', i.e. various variants of package +-- descriptions. +pkgNameStr :: Package pkg => pkg -> String +pkgNameStr p = n + where + (PackageName n) = packageName p + +-- | Get the "x-revision" from a 'PackageDescription'. +pkgXRev :: PackageDescription -> Int +pkgXRev p = maybe 0 read $ lookup "x-revision" (customFieldsPD p) diff --git a/src/Util/HackageIndex.hs b/src/Util/HackageIndex.hs new file mode 100644 --- /dev/null +++ b/src/Util/HackageIndex.hs @@ -0,0 +1,97 @@ +{- + - Copyright 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. + - You may obtain a copy of the License at + - + - http://www.apache.org/licenses/LICENSE-2.0 + - + - Unless required by applicable law or agreed to in writing, software + - distributed under the License is distributed on an "AS IS" BASIS, + - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + - See the License for the specific language governing permissions and + - limitations under the License. + -} + +module Util.HackageIndex + where + +import Util.Misc +import Util.Dist + +import qualified Codec.Archive.Tar as Tar +import qualified Codec.Compression.GZip as GZip +import Control.Applicative +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.UTF8 as BSLU +import Data.List +import qualified Data.Map as M +import Data.Maybe +import Data.Version +import Distribution.PackageDescription +import Distribution.PackageDescription.Parse +import Distribution.Text +import System.FilePath + +readIndexFile :: FilePath -> IO BSL.ByteString +readIndexFile indexLocation = exitOnException + "Cannot open index file, have you run the 'sync' command?" + (BSL.readFile $ indexLocation indexFileName) + +type PkgVersions = M.Map String [(Version, Int)] + +-- | Build up a map of packages and their versions. The versions are listed in +-- descending order, i.e. `head` contains the latest version. +buildPkgVersions :: BSL.ByteString -- ^ the index + -> PkgVersions +buildPkgVersions idx = createPkgVerMap M.empty entries + where + entries = Tar.read $ GZip.decompress idx + + createPkgVerMap acc (Tar.Next e es) = createPkgVerMap (M.insertWith (++) (parts !! 0) [(ver, xrev)] acc) es + where + parts = splitDirectories (Tar.entryPath e) + ver = fromJust . simpleParse $ parts !! 1 + content = case Tar.entryContent e of + Tar.NormalFile c _ -> Just $ BSLU.toString c + _ -> Nothing + xrev = case (parsePackageDescription <$> content) of + Just (ParseOk _ gpd) -> pkgXRev (packageDescription gpd) + _ -> 0 + + createPkgVerMap acc Tar.Done = acc + createPkgVerMap _ (Tar.Fail _) = undefined + +latestVersion :: PkgVersions + -> String -- ^ package name + -> Maybe (Version, Int) +latestVersion pnv pkg = last . sort <$> M.lookup pkg pnv + +extractCabal :: BSL.ByteString -- ^ the index + -> String -- ^ package name + -> Version -- ^ package version + -> Maybe BSL.ByteString +extractCabal idx pkg ver = getContent entries + where + entries = Tar.read $ GZip.decompress idx + pkgPath = pkg display ver pkg <.> "cabal" + + getContent (Tar.Next e es) + | pkgPath == Tar.entryPath e = + case Tar.entryContent e of + Tar.NormalFile c _ -> Just c + _ -> Nothing + | otherwise = getContent es + + getContent _ = Nothing + +getRevision :: BSL.ByteString -- ^ the index + -> String -- ^ package name + -> Version -- ^ package version + -> Maybe Int +getRevision idx pkg ver = do + cblStr <- BSLU.toString <$> extractCabal idx pkg ver + case parsePackageDescription cblStr of + ParseOk _ gpd -> maybe (return 0) (return . read) $ lookup "x-revision" (customFieldsPD $ packageDescription gpd) + _ -> fail "no good" diff --git a/src/Util/Misc.hs b/src/Util/Misc.hs --- a/src/Util/Misc.hs +++ b/src/Util/Misc.hs @@ -18,9 +18,8 @@ -- {{{1 imports import qualified PkgDB as DB +import Util.Dist -import Codec.Archive.Tar as Tar -import Codec.Compression.GZip as GZip import Control.Exception (onException) import Control.Monad import Control.Monad.Error @@ -28,31 +27,20 @@ import Data.Either import Data.Version import Distribution.Compiler -import Distribution.Package as P import Distribution.PackageDescription import Distribution.PackageDescription.Configuration -import Distribution.PackageDescription.Parse import Distribution.System import Distribution.Text -import Distribution.Verbosity -import Distribution.Version import Options.Applicative import Options.Applicative.Types import Safe (lastMay) -import System.Directory import System.Exit -import System.FilePath import System.IO import System.Posix.Files import System.Process import System.Unix.Directory import Text.ParserCombinators.ReadP hiding (many) -import qualified Data.ByteString.Lazy.Char8 as BS --- {{{1 dependency -depName (Dependency (PackageName n) _) = n -depVersionRange (Dependency _ vr) = vr - -- {{{ print functions printUnSat (n, ds) = do putStrLn $ "Failed to satisfy the following dependencies for " ++ n ++ ":" @@ -179,10 +167,10 @@ { listGhc :: Bool, listDistro :: Bool, noListRepo :: Bool , hackageFmt :: Bool, pkgs :: [String] } | CmdUpdates { idxStyle :: Bool } - | CmdUrls { pkgVers :: [(String, Version)] } | CmdPkgBuild { ghcVer :: Version, ghcRel :: Int, patchDir :: FilePath, pkgs :: [String] } | CmdConvertDb { inDbFile :: FilePath, outDbFile :: FilePath } | CmdRemovePkg { pkgs :: [String] } + | CmdExtract { cmdExtractPkgs :: [(String, Version)] } deriving (Show) data Opts = Opts @@ -213,102 +201,30 @@ applyPatchIfExist origFilename patchFilename = liftIO (fileExist patchFilename) >>= flip when (applyPatch origFilename patchFilename) --- {{{1 index functions -readIndexFile indexLocation = exitOnException - "Cannot open index file, have you run the 'sync' command?" - (BS.readFile $ indexLocation indexFileName) - --- {{{1 package descriptions --- {{{2 readCabal -data LocType = Idx | File - --- | Read in a Cabal file. -readCabalFromFile = readCabal -readCabalFromIdx ad pd (p, v) = readCabal ad pd (p ++ "," ++ v') - where v' = display v - -readCabal :: FilePath -> FilePath -> String -> FilePath -> ErrorT String IO GenericPackageDescription -readCabal appDir patchDir loc tmpDir = let - locType - | ',' `elem` loc = Idx - | otherwise = File - - copyCabal tmpDir loc = copyFile loc fn >> return fn - where fn = tmpDir takeFileName loc - - extractCabal tmpDir loc = let - (p, _: v) = span (/= ',') loc - path = p v p ++ ".cabal" - pkgStr = p ++ " " ++ v - fn = tmpDir (p ++ ".cabal") - - esFindEntry p (Next e es) = if p == entryPath e - then Just e - else esFindEntry p es - esFindEntry _ _ = Nothing - - eGetContent e = let - ec = entryContent e - in case ec of - NormalFile c _ -> Just $ BS.unpack c - _ -> Nothing - - in do - es <- liftM (Tar.read . GZip.decompress) (liftIO $ readIndexFile appDir) - e <- maybe (throwError $ "No entry for " ++ pkgStr) - return - (esFindEntry path es) - cbl <- maybe (throwError $ "Failed to extract contents for " ++ pkgStr) - return - (eGetContent e) - liftIO $ writeFile fn cbl - return fn - - extractName fn = liftM name $ readPackageDescription silent fn - where - packageName (PackageName s) = s - name = packageName . pkgName . package . packageDescription - - in do - cblFn <- case locType of - File -> liftIO $ copyCabal tmpDir loc - Idx -> extractCabal tmpDir loc - pn <- liftIO $ extractName cblFn - let patchFn = patchDir pn <.> "cabal" - applyPatchIfExist cblFn patchFn - liftIO $ readPackageDescription silent cblFn - --- {{{2 finalising -finalizePkg ghcVersion db fa gpd = let - n = ((\ (P.PackageName n) -> n ) . P.pkgName . package . packageDescription) gpd - in finalizePackageDescription +-- {{{1 finalising package descriptions +finalizePkg ghcVersion db fa gpd = finalizePackageDescription fa - (checkAgainstDb db n) + (DB.checkAgainstDb db n) (Platform X86_64 buildOS) -- platform (CompilerId GHC ghcVersion) -- compiler version [] -- no additional constraints gpd - -checkAgainstDb db name dep = let - dN = depName dep - dVR = depVersionRange dep - in (dN == name) || - (case DB.lookupPkg db dN of - Nothing -> False - Just (DB.CP _ p) -> withinRange (DB.version p) dVR) + where + n = pkgNameStr gpd -- {{{1 Command type -type Command a = ReaderT Opts IO a +type Command = ReaderT Opts IO runCommand cmds func = runReaderT func cmds -- {{{1 ErrorT -withTempDirErrT fp func = let - reWrapErrT (Left e) = throwError e - reWrapErrT (Right v) = return v - in do - r <- liftIO $ withTemporaryDirectory fp (runErrorT . func) - reWrapErrT r +reThrowError :: MonadError a m => Either a b -> m b +reThrowError = either throwError 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 exitOnErrors vs = let es = lefts vs diff --git a/src/Util/Translation.hs b/src/Util/Translation.hs --- a/src/Util/Translation.hs +++ b/src/Util/Translation.hs @@ -19,6 +19,7 @@ import PkgDB as DB import Util.Misc +import Util.Dist import Control.Monad import Control.Monad.Error @@ -329,7 +330,7 @@ -- • this is most likely too simplistic to create the Arch package names -- correctly for all possible dependencies calcExactDeps db pd = let - n = (\ (P.PackageName n) -> n ) (P.packageName pd) + n = pkgNameStr pd remPkgs = map DB.pkgName (filter isGhcPkg db) ++ [n] deps = filter (not . (`elem` remPkgs)) (map depName (buildDepends pd)) depString n = let diff --git a/src/Versions.hs b/src/Versions.hs --- a/src/Versions.hs +++ b/src/Versions.hs @@ -16,17 +16,14 @@ module Versions where +import Util.HackageIndex import Util.Misc -import Codec.Archive.Tar as Tar -import Codec.Compression.GZip as GZip -import Control.Monad +import Control.Applicative import Control.Monad.Reader -import Data.List -import Data.Maybe +import Data.Map as M import Distribution.Text import Distribution.Version -import System.FilePath versions :: Command () versions = do @@ -35,28 +32,15 @@ pkgs <- optGet $ pkgs . optsCmd let printFunc = if l then printLatestVersion else printAllVersions liftIO $ do - es <- liftM (Tar.read . GZip.decompress) (readIndexFile aD) - mapM_ (printFunc . findVersions es) pkgs + pkgsNVers <- buildPkgVersions <$> readIndexFile aD + mapM_ (\ pkg -> printFunc (pkg, M.lookup pkg pkgsNVers)) pkgs -findVersions es p = (p, findV p es []) +printAllVersions :: (String, Maybe [(Version, Int)]) -> IO () +printAllVersions (p, Nothing) = putStrLn $ p ++ ": No such package" +printAllVersions (p, Just vs) = putStrLn $ p ++ ": " ++ versions where - findV pkgName (Next e es) acc = let - eP = entryPath e - (ePkg:v:_) = splitDirectories eP - in findV pkgName es - (if ('/' `elem` eP) && (pkgName == ePkg) then v:acc else acc) - - findV _ Done acc = let - vs :: [Version] - vs = map (fromJust . simpleParse) acc - in map display $ sort vs - - findV _ (Fail _) _ = error "Failure to read index file" - -printAllVersions (p, vs) = do - putStr $ p ++ " : " - putStrLn $ unwords vs + versions = unwords $ display . fst <$> vs -printLatestVersion (p, vs) = do - putStr $ p ++ "," - putStrLn $ last vs +printLatestVersion :: (String, Maybe [(Version, Int)]) -> IO () +printLatestVersion (p, Nothing) = putStrLn $ p ++ ": No such package" +printLatestVersion (p, Just vs) = putStrLn $ p ++ "," ++ display (fst $ head vs)