diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +## 0.4.3 + +* Updates (better cabal config parsing) [#30](https://github.com/snoyberg/packdeps/pull/30) + ## 0.4.2 * Added --quiet flag to suppress output for up to date cabal files [#29](https://github.com/snoyberg/packdeps/pull/29) diff --git a/Distribution/PackDeps.hs b/Distribution/PackDeps.hs --- a/Distribution/PackDeps.hs +++ b/Distribution/PackDeps.hs @@ -25,15 +25,17 @@ , diName -- * Internal , PackInfo (..) + , piRevision , DescInfo (..) ) where -import System.Directory (getAppUserDataDirectory) +import Control.Applicative as A ((<$>)) +import System.Directory (getAppUserDataDirectory, doesFileExist) import System.FilePath (()) import qualified Data.Map as Map -import Data.List (foldl', group, sort, isInfixOf, isPrefixOf) +import Data.List (foldl', group, sort, isInfixOf) import Data.Time (UTCTime (UTCTime), addUTCTime) -import Data.Maybe (mapMaybe, catMaybes) +import Data.Maybe (mapMaybe, fromMaybe) import Control.Exception (throw) import Distribution.Package @@ -41,8 +43,9 @@ import Distribution.PackageDescription.Parse import Distribution.Version import Distribution.Text +import qualified Distribution.ParseUtils as PU -import Data.Char (toLower, isSpace) +import Data.Char (toLower) import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.Encoding as T import qualified Data.Text.Encoding.Error as T @@ -57,39 +60,30 @@ import Data.List (groupBy, sortBy) import Data.Ord (comparing) import qualified Data.Set as Set +import Text.Read (readMaybe) +-- import Data.Monoid ((<>)) loadNewest :: IO Newest loadNewest = do c <- getAppUserDataDirectory "cabal" - cfg <- readFile (c "config") + cfg' <- readFile (c "config") + cfg <- parseResult (fail . show) return $ PU.readFields cfg' let repos = reposFromConfig cfg repoCache = case lookupInConfig "remote-repo-cache" cfg of [] -> c "packages" -- Default (rrc : _) -> rrc -- User-specified - tarName repo = repoCache repo "00-index.tar" - fmap (Map.unionsWith maxVersion) . mapM (loadNewestFrom . tarName) $ repos - -reposFromConfig :: String -> [String] -reposFromConfig = map (takeWhile (/= ':')) . lookupInConfig "remote-repo" - --- | Looks up the given key in the cabal configuration file -lookupInConfig :: String -> String -> [String] -lookupInConfig key = map trim . catMaybes . map (dropPrefix prefix) . lines - where - prefix = key ++ ":" - --- | Utility: drop leading and trailing spaces from a string -trim :: String -> String -trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace - -dropPrefix :: (Eq a) => [a] -> [a] -> Maybe [a] -dropPrefix prefix s = - if prefix `isPrefixOf` s - then Just . drop (length prefix) $ s - else Nothing + tarNames repo = [ pfx "01-index.tar", pfx "00-index.tar" ] + where pfx = repoCache repo + fmap (Map.unionsWith maxVersion) . mapM (loadNewestFrom . tarNames) $ repos -loadNewestFrom :: FilePath -> IO Newest -loadNewestFrom = fmap parseNewest . L.readFile +-- | Takes a list of possible pathes, tries them in order until one exists. +loadNewestFrom :: [FilePath] -> IO Newest +loadNewestFrom [] = fail "loadNewestFrom: no index tarball" +loadNewestFrom (fp : fps) = do + e <- doesFileExist fp + if e + then fmap parseNewest (L.readFile fp) + else loadNewestFrom fps parseNewest :: L.ByteString -> Newest parseNewest = foldl' addPackage Map.empty . entriesToList . Tar.read @@ -108,7 +102,8 @@ case Map.lookup package' m of Nothing -> go package' version Just PackInfo { piVersion = oldv } -> - if version > oldv + -- in 01-index.tar there are entries with the same versions + if version >= oldv then go package' version else m Nothing -> m @@ -117,7 +112,7 @@ go package' version = case Tar.entryContent entry of Tar.NormalFile bs _ -> - Map.insert package' PackInfo + Map.insertWith maxVersion package' PackInfo { piVersion = version , piDesc = parsePackage bs , piEpoch = Tar.entryTime entry @@ -125,12 +120,21 @@ _ -> m data PackInfo = PackInfo - { piVersion :: Version - , piDesc :: Maybe DescInfo - , piEpoch :: Tar.EpochTime + { piVersion :: Version + , piDesc :: Maybe DescInfo + , piEpoch :: Tar.EpochTime } deriving (Show, Read) +-- Extract revision from PackInfo, default to 0 +piRevision :: PackInfo -> Int +piRevision = fromMaybe 0 . fmap diRevision . piDesc + +-- We should compare revisions as well, +-- but we don't do that, as it would force `piDesc` and make `packdeps` +-- executable increadibly slow (parse all cabal files on Hackage) +-- Instead we rely on the fact that newer revisions are always later in +-- 01-index.tar maxVersion :: PackInfo -> PackInfo -> PackInfo maxVersion pi1 pi2 = if piVersion pi1 <= piVersion pi2 then pi2 else pi1 @@ -162,24 +166,30 @@ -- | Information on a single package. data DescInfo = DescInfo { diHaystack :: String - , diDeps :: [Dependency] - , diLibDeps :: [Dependency] - , diPackage :: PackageIdentifier + , diDeps :: [Dependency] + , diLibDeps :: [Dependency] + , diPackage :: PackageIdentifier + , diRevision :: Int , diSynopsis :: String } deriving (Show, Read) +-- | Return revision and DescInfo getDescInfo :: GenericPackageDescription -> DescInfo getDescInfo gpd = DescInfo { diHaystack = map toLower $ author p ++ maintainer p ++ name - , diDeps = getDeps gpd - , diLibDeps = getLibDeps gpd - , diPackage = pi' + , diDeps = getDeps gpd + , diLibDeps = getLibDeps gpd + , diPackage = pi' + , diRevision = rev , diSynopsis = synopsis p } where p = packageDescription gpd pi'@(PackageIdentifier (PackageName name) _) = package p + rev = fromMaybe 0 $ do + r <- lookup "x-revision" (customFieldsPD p) + readMaybe r getDeps :: GenericPackageDescription -> [Dependency] getDeps x = getLibDeps x ++ concat @@ -290,3 +300,32 @@ unPN . pkgName . diPackage where unPN (PackageName pn) = pn + +------------------------------------------------------------------------------- +-- ~/.cabal/config parsing +------------------------------------------------------------------------------- + +reposFromConfig :: [PU.Field] -> [String] +reposFromConfig fields = takeWhile (/= ':') A.<$> mapMaybe f fields + where + f (PU.F _lineNo name value) + | name == "remote-repo" + = Just value + f (PU.Section _lineNo secName arg _fields) + | secName == "repository" + = Just arg + f _ = Nothing + +-- | Looks up the given key in the cabal configuration file +lookupInConfig :: String -> [PU.Field] -> [String] +lookupInConfig key = mapMaybe f + where + f (PU.F _lineNo name value) + | name == key + = Just value + f _ = Nothing + +-- | Like 'either', but for 'ParseResult' +parseResult :: (PU.PError -> r) -> (a -> r) -> ParseResult a -> r +parseResult l _ (PU.ParseFailed e) = l e +parseResult _ r (PU.ParseOk _warns x) = r x diff --git a/packdeps.cabal b/packdeps.cabal --- a/packdeps.cabal +++ b/packdeps.cabal @@ -1,5 +1,5 @@ name: packdeps -version: 0.4.2.1 +version: 0.4.3 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -17,12 +17,12 @@ extra-source-files: README.md ChangeLog.md library - build-depends: base >= 4 && < 5 + build-depends: base >= 4.6 && < 5 , tar >= 0.4 && < 0.6 , split >= 0.1.2.3 , bytestring >= 0.9 , text >= 0.7 - , Cabal >= 1.8 + , Cabal >= 1.14 && <1.25 , time >= 1.1.4 , containers >= 0.2 , directory >= 1.0